coq-8.4pl4/0000755000175000017500000000000012326224777011633 5ustar stephstephcoq-8.4pl4/README.win0000644000175000017500000000376312326224777013320 0ustar stephstephTHE COQ V8 SYSTEM ================= This file contains remarks specific to the windows port of Coq. INSTALLATION. ============= The Coq package for Windows comes with an auto-installer. It will install Coq binaries and libraries under any directory you specify (C:\Program Files\Coq is the default path). It also creates shortcuts in the Windows menus. Alternatively, you can launch Coq using coqide.exe or coqtop.exe in the bin sub-directory of the installation (C:\Program Files\Coq\bin by default). COMPILATION. ============ If you want to install coq, you had better transfer the precompiled distribution. If you really need to recompile under Windows, here are some indications: 1- Install ocaml for Windows (MinGW port). See: http://caml.inria.fr 2- Install a shell environment with at least: - a C compiler (gcc), - the GNU make utility The Cygwin environment is well suited for compiling Coq (official packages are made using Cygwin) See: http://www.cygwin.com 3- In order to compile Coqide, you will need the LablGTK library See: http://wwwfun.kurims.kyoto-u.ac.jp/soft/olabl/lablgtk.html You also need to install the GTK libraries for Windows (see the installation instruction for LablGTK) 4- In a shell window, type successively ./configure make world make install 5- Though not nescessary, you can find useful: - Windows version of (X)Emacs: it is a powerful environment for developpers with coloured syntax, modes for compilation and debug, and many more. It is free. See: http://www.gnu.org/software. - Windows subversion client (very useful if you have access to the Coq archive). Good luck :-) Alternatively, it is now possible (and even recommended ...) to build Windows executables of coq from Linux thanks to a mingw cross-compiler. If interested, please contact us for more details. The Coq Team. coq-8.4pl4/test-suite/0000755000175000017500000000000012365131023013721 5ustar stephstephcoq-8.4pl4/test-suite/csdp.cache0000644000175000017500000022541312326224777015666 0ustar stephsteph„•Ķūxģē   (pure_sos@  ē @@@ē ‘@@@ @@C  ē ‘@@@ē @@@ @@C  ēē ‘@@@ ‘@@@Ą@ē ‘@@@ @@@  Ą@ēē ‘@@@ ‘@@@ē ‘@@@ ‘@@C@@„•ĶūU€x   5real_nonlinear_proverC  ē @@@ē ‘@@@ @@C  ē ‘@@@ē @@@ @@C  ēē ‘@@@ ‘@@@Ą@ē ‘@@@ @@@  Ą@ēē ‘@@@ ‘@@@ē ‘@@@ ‘@@C@Đ•AĐĻĸBĐŠŠ‘C•AŠ•A–AĐŠŠ‘A•AŠ•A–” – ’° A_nat A_natA‘"x1” – ’° A_nat A_natA‘"x2AŠŠ‘@•AŠ•’° A_nat A_natA–” ‘"x1‘"x2„•ĶūT€x   5real_nonlinear_proverC  ē @@@ē ‘@@@ @@C  ē ‘@@@ē @@@ @@C  ēē ‘@@@ ‘@@@Ą@ē ‘@@@ @@@  Ą@ēē @@@ @@@ē ‘‘@@@ ‘@@C@Đ•AĐĻABĐŠŠ‘C•AŠ•A–AĐŠŠ‘A•AŠ•’° A_nat A_natA–” ‘"x1‘"x2ŠŠ‘@•AŠ•A–” – ’° A_nat A_natA‘"x1” – ’° A_nat A_natA‘"x2A„•ĶūĪîë   5real_nonlinear_proverC  ē ‘@@@ē @@@ ‘@@C  ē ‘@@@ē @@@ @@C  ēē ‘@@@ ‘@@@Ą@ē ‘@@@ @@@  ē @@@ē ‘@@@ @@C@Đ•AĐĻ@BĐŠŠ‘C•AŠ•A–AŠŠ‘@•AŠ•A–A„•ĶūĒčå   5real_nonlinear_proverC  ē ‘@@@ē @@@ ‘@@C  ē ‘@@@ē @@@ @@C  ēē ‘@@@ ‘@@@Ą@ē ‘@@@ @@@  ēē ‘@@@ ‘@@@Ą@ē ‘@@@ ‘@@C@Đ•AĐĻĸBŠŠ‘C•AŠ•A–A„•ĶūĄčå   5real_nonlinear_proverC  ē ‘@@@ē @@@ ‘@@C  ē ‘@@@ē @@@ @@C  ēē ‘@@@ ‘@@@Ą@ē ‘@@@ @@@  ēē @@@ @@@Ą@ē ‘‘@@@ ‘@@C@Đ•AĐĻABŠŠ‘C•AŠ•A–A„•ĶūqŒ‹   (pure_sos@  ēē ‘‘‘@@@ ‘@@@ ‘@@C@Đ’@Š•’° A_nat A_natAĐŠ•A–” – H‘"x1CĐŠ•g–A•@„•Ķū_Œ‹   (pure_sos@  ēĄ@ē @@@ @@@ēĄ‘@ē @@‘@ @@@ē @@@ @@@  ē ‘@@‘@ēĄ@ē ‘‘@@@ @@@ ‘@@C@@„•Ķū­úũ   5real_nonlinear_proverD  ēĄ@ē @@@ @@@ēĄ‘@ē @@‘@ @@@ē @@@ @@@  ē ‘@@‘@ēĄ@ē ‘‘@@@ @@@ ‘@@C@Đ•AĐĻ– ü‘"x2@ĐŠ•AŠ•A–” – B– ‘"x2‘"x4‘"x1ŠŠ‘A•AŠ•A–A„•ĶūQvu   (pure_sos@  ē @@@ē ‘@@@ @@C  ē @@@ē @@@ @@C  ē ‘@@‘@ē @@‘@ ‘@@C@@„•Ķū…ūŧ   5real_nonlinear_proverB  ē @@@ē ‘@@@ @@C  ē @@@ē @@@ @@C  ē ‘@@‘@ē @@‘@ ‘@@C@Đ•AĐŠŠ‘B•AŠ•A–AŠŠ‘@Š‘A•AŠ•A–A„•ĶūX€   (pure_sos@  ē @@@ē @@@ @@C  ēēē ‘@@@ē ‘@@@ @@@ē ‘@@‘@ @@@ē ‘@@@ ‘@@C@@„•ĶūÍĘ   5real_nonlinear_proverD  ē @@@ē @@@ @@C  ēēē ‘@@@ē ‘@@@ @@@ē ‘@@‘@ @@@ē ‘@@@ ‘@@C@Đ•AĐŠŠ‘A•AŠ•A–AŠŠ‘@•AŠ•A–” ‘"x1‘"x2„•ĶūįŠ‰   (pure_sos@  Ą@ē @@@ē ‘@@@ @@C  Ą@ē @@@Ą‘‘@ē @@@ē ‘@@@ @@@  Ą@ē ‘@@@Ą‘‘@ē @@@ē @@@ @@@  Ą‘@ē @@@Ą‘@ē @@@ē ‘@@@ @@@  Ą‘@ē ‘@@@Ą‘@ē @@@ē @@@ @@@  ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C@@„•ĶūŲÚŨ   5real_nonlinear_proverB  Ą@ē @@@ē ‘@@@ @@C  Ą@ē @@@Ą‘‘@ē @@@ē ‘@@@ @@@  Ą@ē ‘@@@Ą‘‘@ē @@@ē @@@ @@@  Ą‘@ē @@@Ą‘@ē @@@ē ‘@@@ @@@  Ą‘@ē ‘@@@Ą‘@ē @@@ē @@@ @@@  ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ” – ’° A_nat A_natA‘#x10” – ’° ĸ_nat A_natA‘"x4” – ’° A_nat A_natA‘"x9’° ĸ_nat A_natAAĐĻ” – ’° A_nat A_natA‘#x10” – ’° ĸ_nat A_natA‘"x4” – ’° ĸ_nat A_natA‘"x9’° ĸ_nat A_natABĐĻ” – ’° ĸ_nat A_natA‘#x13” – ’° ĸ_nat A_natA‘#x14” – ’° A_nat A_natA‘"x6’° A_nat A_natACĐĻ” – ’° A_nat A_natA‘#x13” – ’° ĸ_nat A_natA‘#x14” – ’° A_nat A_natA‘"x6’° A_nat A_natADĐŠŠ‘N•AŠ•A–AŠŠ‘@Š‘E•AŠ•B–A„•Ķūō&"   5real_nonlinear_proverB  Ą@ē @@@ē ‘@@@ @@C  Ą@ē @@@Ą‘‘@ē @@@ē ‘@@@ @@@  Ą@ē ‘@@@Ą‘‘@ē @@@ē @@@ @@@  Ą‘@ē @@@Ą‘@ē @@@ē ‘@@@ @@@  Ą‘@ē ‘@@@Ą@ē @@@ ‘@@C  ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ” – ’° ĸ_nat A_natA‘#x10” – ’° A_nat A_natA‘"x4” – ’° ĸ_nat A_natA‘"x9’° ĸ_nat A_natAAĐĻ” – ’° ĸ_nat A_natA‘#x10” – ’° A_nat A_natA‘"x4” – ’° A_nat A_natA‘"x9’° ĸ_nat A_natABĐĻ’° A_nat A_natACĐŠŠ‘N•AŠ•’° A_nat A_natA–AĐŠŠ‘D•AŠ•’° A_nat A_natA–AŠŠ‘@Š‘E•AŠ•A–A„•Ķūō&"   5real_nonlinear_proverB  Ą@ē @@@ē ‘@@@ @@C  Ą@ē @@@Ą‘‘@ē @@@ē ‘@@@ @@@  Ą@ē ‘@@@Ą‘‘@ē @@@ē @@@ @@@  Ą‘@ē @@@Ą@ē ‘@@@ ‘@@C  Ą‘@ē ‘@@@Ą‘@ē @@@ē @@@ @@@  ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ” – ’° A_nat A_natA‘#x10” – ’° ĸ_nat A_natA‘"x4” – ’° A_nat A_natA‘"x9’° ĸ_nat A_natAAĐĻ” – ’° A_nat A_natA‘#x10” – ’° ĸ_nat A_natA‘"x4” – ’° ĸ_nat A_natA‘"x9’° ĸ_nat A_natABĐĻ’° A_nat A_natADĐŠŠ‘N•AŠ•’° A_nat A_natA–AĐŠŠ‘C•AŠ•’° A_nat A_natA–AŠŠ‘@Š‘E•AŠ•A–A„•Ķū#âß   5real_nonlinear_proverB  Ą@ē @@@ē ‘@@@ @@C  Ą@ē @@@Ą‘‘@ē @@@ē ‘@@@ @@@  Ą@ē ‘@@@Ą‘‘@ē @@@ē @@@ @@@  Ą‘@ē @@@Ą@ē ‘@@@ ‘@@C  Ą‘@ē ‘@@@Ą@ē @@@ ‘@@C  ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ@AĐĻ@BĐŠ•AŠ•A–AĐŠŠ‘D•AŠ•A–AŠŠ‘C•AŠ•A–A„•Ķūēqn   5real_nonlinear_proverB  Ą@ē @@@ē ‘@@@ @@C  Ą@ē @@@Ą‘‘@ē @@@ē ‘@@@ @@@  Ą@ē ‘@@@Ą‘@ē @@@ ‘@@C  Ą‘@ē @@@Ą‘@ē @@@ē ‘@@@ @@@  Ą‘@ē ‘@@@Ą‘@ē @@@ē @@@ @@@  ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ@AĐĻ” – ĸ‘#x13” – ĸ‘#x14” ‘"x6’° A_nat A_natACĐĻ” ‘#x13” – ĸ‘#x14” ‘"x6’° ĸ_nat A_natADĐŠŠ‘M•AŠ•A–AĐŠŠ‘F•AŠ•A–AŠŠ‘B•AŠ•A–A„•Ķū†|y   5real_nonlinear_proverB  Ą@ē @@@ē ‘@@@ @@C  Ą@ē @@@Ą‘‘@ē @@@ē ‘@@@ @@@  Ą@ē ‘@@@Ą‘@ē @@@ ‘@@C  Ą‘@ē @@@Ą‘@ē @@@ē ‘@@@ @@@  Ą‘@ē ‘@@@Ą@ē @@@ ‘@@C  ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ” – ō‘#x13” – N‘#x14” – ō‘"x6ĸAĐĻ” – ō‘#x10” – N‘"x4” – N‘"x9ACĐŠŠ‘N•AŠ•A–AĐŠŠ‘M•AŠ•A–AĐŠŠ‘F•AŠ•A–AŠŠ‘@Š‘E•AŠ•B–A„•ĶūΠ  5real_nonlinear_proverB  Ą@ē @@@ē ‘@@@ @@C  Ą@ē @@@Ą‘‘@ē @@@ē ‘@@@ @@@  Ą@ē ‘@@@Ą‘@ē @@@ ‘@@C  Ą‘@ē @@@Ą@ē ‘@@@ ‘@@C  Ą‘@ē ‘@@@Ą‘@ē @@@ē @@@ @@@  ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ” – ’° A_nat9 A_natA‘#x13” – ’° A_nat9 A_natA‘#x14– ’° ĸ_nat9 A_natA‘"x6AĐĻ” – ’° A_nat9 A_natA‘#x10” – ’° ĸ_nat9 A_natA‘"x4– ’° ĸ_nat9 A_natA‘"x9DĐŠŠ‘M•AŠ•’° A_nat A_natA–AĐŠŠ‘F•AŠ•’° A_nat A_natA–AĐŠŠ‘C•AŠ•’° A_nat A_natA–AŠŠ‘B•AŠ•’° A_nat A_natA–A„•ĶūŅΠ  5real_nonlinear_proverB  Ą@ē @@@ē ‘@@@ @@C  Ą@ē @@@Ą‘‘@ē @@@ē ‘@@@ @@@  Ą@ē ‘@@@Ą‘@ē @@@ ‘@@C  Ą‘@ē @@@Ą@ē ‘@@@ ‘@@C  Ą‘@ē ‘@@@Ą@ē @@@ ‘@@C  ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ@AĐŠ•AŠ•A–AĐŠŠ‘D•AŠ•A–AŠŠ‘C•AŠ•A–A„•Ķūēqn   5real_nonlinear_proverB  Ą@ē @@@ē ‘@@@ @@C  Ą@ē @@@Ą‘@ē ‘@@@ ‘@@C  Ą@ē ‘@@@Ą‘‘@ē @@@ē @@@ @@@  Ą‘@ē @@@Ą‘@ē @@@ē ‘@@@ @@@  Ą‘@ē ‘@@@Ą‘@ē @@@ē @@@ @@@  ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ@BĐĻ” ‘#x13” ‘#x14” – ĸ‘"x6’° ĸ_nat A_natACĐĻ” – ĸ‘#x13” ‘#x14” – ĸ‘"x6’° A_nat A_natADĐŠŠ‘L•AŠ•A–AĐŠŠ‘G•AŠ•A–AŠŠ‘A•AŠ•A–A„•ĶūΠ  5real_nonlinear_proverB  Ą@ē @@@ē ‘@@@ @@C  Ą@ē @@@Ą‘@ē ‘@@@ ‘@@C  Ą@ē ‘@@@Ą‘‘@ē @@@ē @@@ @@@  Ą‘@ē @@@Ą‘@ē @@@ē ‘@@@ @@@  Ą‘@ē ‘@@@Ą@ē @@@ ‘@@C  ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ” – ’° A_nat' A_natA‘#x13” – ’° ĸ_nat' A_natA‘#x14– ’° A_nat' A_natA‘"x6BĐĻ” – ’° ĸ_nat' A_natA‘#x10” – ’° A_nat' A_natA‘"x4– ’° ĸ_nat' A_natA‘"x9CĐŠŠ‘L•AŠ•’° A_nat A_natA–AĐŠŠ‘G•AŠ•’° A_nat A_natA–AĐŠŠ‘D•AŠ•’° A_nat A_natA–AŠŠ‘A•AŠ•’° A_nat A_natA–A„•Ķū†|y   5real_nonlinear_proverB  Ą@ē @@@ē ‘@@@ @@C  Ą@ē @@@Ą‘@ē ‘@@@ ‘@@C  Ą@ē ‘@@@Ą‘‘@ē @@@ē @@@ @@@  Ą‘@ē @@@Ą@ē ‘@@@ ‘@@C  Ą‘@ē ‘@@@Ą‘@ē @@@ē @@@ @@@  ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ” – ø‘#x13” – ø‘#x14” – H‘"x6ĸBĐĻ” – H‘#x10” – ø‘"x4” – H‘"x9ADĐŠŠ‘N•AŠ•A–AĐŠŠ‘L•AŠ•A–AĐŠŠ‘G•AŠ•A–AŠŠ‘@Š‘E•AŠ•B–A„•ĶūŅΠ  5real_nonlinear_proverB  Ą@ē @@@ē ‘@@@ @@C  Ą@ē @@@Ą‘@ē ‘@@@ ‘@@C  Ą@ē ‘@@@Ą‘‘@ē @@@ē @@@ @@@  Ą‘@ē @@@Ą@ē ‘@@@ ‘@@C  Ą‘@ē ‘@@@Ą@ē @@@ ‘@@C  ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ@BĐŠ•AŠ•A–AĐŠŠ‘D•AŠ•A–AŠŠ‘C•AŠ•A–A„•Ķū#âß   5real_nonlinear_proverB  Ą@ē @@@ē ‘@@@ @@C  Ą@ē @@@Ą‘@ē ‘@@@ ‘@@C  Ą@ē ‘@@@Ą‘@ē @@@ ‘@@C  Ą‘@ē @@@Ą‘@ē @@@ē ‘@@@ @@@  Ą‘@ē ‘@@@Ą‘@ē @@@ē @@@ @@@  ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ@CĐĻ@DĐŠ•AŠ•A–AĐŠŠ‘B•AŠ•A–AŠŠ‘A•AŠ•A–A„•ĶūŅΠ  5real_nonlinear_proverB  Ą@ē @@@ē ‘@@@ @@C  Ą@ē @@@Ą‘@ē ‘@@@ ‘@@C  Ą@ē ‘@@@Ą‘@ē @@@ ‘@@C  Ą‘@ē @@@Ą‘@ē @@@ē ‘@@@ @@@  Ą‘@ē ‘@@@Ą@ē @@@ ‘@@C  ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ@CĐŠ•AŠ•A–AĐŠŠ‘B•AŠ•A–AŠŠ‘A•AŠ•A–A„•ĶūŅΠ  5real_nonlinear_proverB  Ą@ē @@@ē ‘@@@ @@C  Ą@ē @@@Ą‘@ē ‘@@@ ‘@@C  Ą@ē ‘@@@Ą‘@ē @@@ ‘@@C  Ą‘@ē @@@Ą@ē ‘@@@ ‘@@C  Ą‘@ē ‘@@@Ą‘@ē @@@ē @@@ @@@  ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ@DĐŠ•AŠ•A–AĐŠŠ‘B•AŠ•A–AŠŠ‘A•AŠ•A–A„•ĶūJËÆ   5real_nonlinear_proverB  Ą@ē @@@ē ‘@@@ @@C  Ą@ē @@@Ą‘@ē ‘@@@ ‘@@C  Ą@ē ‘@@@Ą‘@ē @@@ ‘@@C  Ą‘@ē @@@Ą@ē ‘@@@ ‘@@C  Ą‘@ē ‘@@@Ą@ē @@@ ‘@@C  ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C@Đ•AĐŠŠ‘B•AŠ•’° A_nat A_natA–AŠŠ‘A•AŠ•’° A_nat A_natA–A„•ĶūEba   (pure_sos@  Ą@ē @@@ ‘@@C  ē @@@ ‘@@C  ēĄ@ē ‘@@@ @@@ @@C@@„•Ķū™âß   5real_nonlinear_proverB  Ą@ē @@@ ‘@@C  ē @@@ ‘@@C  ēĄ@ē ‘@@@ @@@ @@C@Đ•AĐŠŠ‘B•AŠ•A–AĐŠŠ‘A•AŠ•A–AĐŠŠ‘@•AŠ•A–AŠŠ‘@Š‘A•AŠ•A–A„•ĶūEba   (pure_sos@  Ą@ē @@@ @@@  ē @@@ ‘@@C  ēĄ@ē @@@ @@@ ‘@@C@@„•Ķūtž›   5real_nonlinear_proverB  Ą@ē @@@ @@@  ē @@@ ‘@@C  ēĄ@ē @@@ @@@ ‘@@C@Đ•AĐĻ– ĸ‘"x1@ŠŠ‘B•AŠ•A–A„•Ķūn•’   5real_nonlinear_proverB  Ą@ē @@@ @@@  ē @@@ ‘@@C  ēĄ@ē ‘@@@ @@@ ‘@@C@Đ•AĐĻ‘"x1@ŠŠ‘B•AŠ•A–A„•ĶūEba   (pure_sos@  Ą@ē ‘@@@ ‘@@C  ē @@@ ‘@@C  ēĄ@ē @@@ @@@ @@C@@„•Ķū™âß   5real_nonlinear_proverB  Ą@ē ‘@@@ ‘@@C  ē @@@ ‘@@C  ēĄ@ē @@@ @@@ @@C@Đ•AĐŠŠ‘B•AŠ•A–AĐŠŠ‘A•AŠ•A–AĐŠŠ‘@•AŠ•A–AŠŠ‘@Š‘A•AŠ•A–A„•ĶūEba   (pure_sos@  Ą@ē @@@ ‘@@C  ē @@@ @@@  ēĄ@ē @@@ @@@ ‘@@C@@„•Ķūtž›   5real_nonlinear_proverB  Ą@ē @@@ ‘@@C  ē @@@ @@@  ēĄ@ē @@@ @@@ ‘@@C@Đ•AĐĻ– ĸ‘"x2AŠŠ‘B•AŠ•A–A„•Ķūn•’   5real_nonlinear_proverB  Ą@ē @@@ ‘@@C  ē @@@ @@@  ēĄ@ē ‘@@@ @@@ ‘@@C@Đ•AĐĻ‘"x2AŠŠ‘B•AŠ•A–A„•ĶūD`_   (pure_sos@  Ą@ē @@@ @@@  ē @@@ @@@  ēĄ@ē @@@ @@@ ‘@@C@@„•ĶūxĪĄ   5real_nonlinear_proverB  Ą@ē @@@ @@@  ē @@@ @@@  ēĄ@ē @@@ @@@ ‘@@C@Đ•AĐĻ@@ĐĻ– ĸ‘"x2AŠŠ‘B•AŠ•A–A„•Ķūr›˜   5real_nonlinear_proverB  Ą@ē @@@ @@@  ē @@@ @@@  ēĄ@ē ‘@@@ @@@ ‘@@C@Đ•AĐĻ@@ĐĻ‘"x2AŠŠ‘B•AŠ•A–A„•ĶūEba   (pure_sos@  Ą@ē ‘@@@ ‘@@C  ē @@@ @@@  ēĄ@ē @@@ @@@ ‘@@C@@„•Ķūtž›   5real_nonlinear_proverB  Ą@ē ‘@@@ ‘@@C  ē @@@ @@@  ēĄ@ē @@@ @@@ ‘@@C@Đ•AĐĻ– ĸ‘"x2AŠŠ‘B•AŠ•A–A„•Ķūn•’   5real_nonlinear_proverB  Ą@ē ‘@@@ ‘@@C  ē @@@ @@@  ēĄ@ē ‘@@@ @@@ ‘@@C@Đ•AĐĻ‘"x2AŠŠ‘B•AŠ•A–A„•ĶūEba   (pure_sos@  Ą@ē @@@ ‘@@C  ē ‘@@@ ‘@@C  ēĄ@ē @@@ @@@ @@C@@„•Ķū™âß   5real_nonlinear_proverB  Ą@ē @@@ ‘@@C  ē ‘@@@ ‘@@C  ēĄ@ē @@@ @@@ @@C@Đ•AĐŠŠ‘B•AŠ•A–AĐŠŠ‘A•AŠ•A–AĐŠŠ‘@•AŠ•A–AŠŠ‘@Š‘A•AŠ•A–A„•ĶūEba   (pure_sos@  Ą@ē @@@ @@@  ē ‘@@@ ‘@@C  ēĄ@ē @@@ @@@ ‘@@C@@„•Ķūtž›   5real_nonlinear_proverB  Ą@ē @@@ @@@  ē ‘@@@ ‘@@C  ēĄ@ē @@@ @@@ ‘@@C@Đ•AĐĻ– ĸ‘"x1@ŠŠ‘B•AŠ•A–A„•Ķūn•’   5real_nonlinear_proverB  Ą@ē @@@ @@@  ē ‘@@@ ‘@@C  ēĄ@ē ‘@@@ @@@ ‘@@C@Đ•AĐĻ‘"x1@ŠŠ‘B•AŠ•A–A„•ĶūEba   (pure_sos@  Ą@ē ‘@@@ ‘@@C  ē ‘@@@ ‘@@C  ēĄ@ē ‘@@@ @@@ @@C@@„•Ķū™âß   5real_nonlinear_proverB  Ą@ē ‘@@@ ‘@@C  ē ‘@@@ ‘@@C  ēĄ@ē ‘@@@ @@@ @@C@Đ•AĐŠŠ‘B•AŠ•A–AĐŠŠ‘A•AŠ•A–AĐŠŠ‘@•AŠ•A–AŠŠ‘@Š‘A•AŠ•A–A„•ĶūD`_   (pure_sos@  Ą@ē @@@ @@C  ē @@@ @@C  ēĄ@ē ‘@@@ @@@ ‘@@C@@„•ĶūxĻĨ   5real_nonlinear_proverB  Ą@ē @@@ @@C  ē @@@ @@C  ēĄ@ē ‘@@@ @@@ ‘@@C@Đ•AĐŠŠ‘B•AŠ•A–AŠŠ‘@Š‘A•AŠ•A–A„•Ķū'&   (pure_sos@  ē @@‘@ @@@@@„•ĶūFUR   5real_nonlinear_proverB  ē @@‘@ @@@@Đ•AĐĻĸ@Š•AŠ•A–‘"x1„•Ķū?[Z   (pure_sos@  ē @@‘@ē @@@ ‘@@@  ē @@@ē ‘@@‘@ @@C@@„•Ķūŋ~x   5real_nonlinear_proverB  ē @@‘@ē @@@ ‘@@@  ē @@@ē ‘@@‘@ @@C@Đ•AĐĻ’° ĸ_nat1 A_nat A@ĐŠ•AĐŠ•’° A_nat A_natA–” – ’° ĸ_natU A_nat A‘"x1” – ’° A_nat1 A_natWA‘"x2AĐŠ•’° A_nat’ŋ A_nat% A–” ‘"x1– ’° A_nataž A_nat’ŋA‘"x2Š•’° A_natũ A_natIEļA–‘"x2ŠŠ‘A•AŠ•’° A_natU A_natHA–A„•ĶūĨúų   (pure_sos@  ēĄ‘@ē @@@ @@@ēĄ‘@ē @@@ @@@ @@@  ē @@‘@ē @@‘@ē ‘@@‘@ē ‘@@‘@ ‘‘@@@  Ą@ē @@@ @@C  ē @@@ @@C  ēĄ@ē ‘@@@ @@@Ą@ēĄ@ē @@@ @@@ ‘@@C@@„•ĶūĢ˜   5real_nonlinear_proverD  ēĄ‘@ē @@@ @@@ēĄ‘@ē @@@ @@@ @@@  ē @@‘@ē @@‘@ē ‘@@‘@ē ‘@@‘@ ‘‘@@@  Ą@ē @@@ @@C  ē @@@ @@C  ēĄ@ē ‘@@@ @@@Ą@ēĄ@ē @@@ @@@ ‘@@C@Đ•AĐĻ” – ’° ĸ_nat A_natA– ‘"x1‘"x4– ’° ĸ_nat A_natA– ‘"x2‘"x3@ĐĻ” – ’° ĸ_nat A_natA– ‘"x1‘"x2’° A_nat A_natAAĐŠ•AŠ•’° A_nat A_natA–” – ĸ‘"x3‘"x4ĐŠŠ‘D•AĐŠ•’° A_nat A_natA–AĐŠ•’° A_nat A_natA–‘"x2Š•’° A_nat A_natA–‘"x1ŠŠ‘BŠ‘C•AĐŠ•’° A_nat A_natA–‘"x2Š•’° A_nat A_natA–‘"x1„•ĶūKon   (pure_sos@  Ą@ē ‘@@@ ‘‘‘@@C  ē ‘@@@ē ‘@@@ @@C  ē @@@ @@C@@„•Ķū-)"   5real_nonlinear_proverB  Ą@ē ‘@@@ ‘‘‘@@C  ē ‘@@@ē ‘@@@ @@C  ē @@@ @@C@Đ•AĐŠ•AŠ•’° A_nat A_natA–AĐŠŠ‘B•AŠ•’° A_nat A_natA–AĐŠŠ‘A•AŠ•’° A_nat A_natA–AŠŠ‘@•AŠ•’° A_nat A_natA–A„•ĶūĮ32   (pure_sos@  ē @@@ @@C  ē ‘@@@ @@C  Ą@ē @@@ @@C  Ą@ē ‘@@@ @@C  ē @@‘@ē @@‘@ ‘@@C  ēē @@@ ‘‘@@@ē @@‘@ @@C  ē @@‘@ēē @@@ ‘‘@@@ @@C  ēē @@@ ‘‘@@@ēē @@@ ‘‘@@@ @@C@@„•Ķū$Âŋ   5real_nonlinear_proverC  ē @@@ @@C  ē ‘@@@ @@C  Ą@ē @@@ @@C  Ą@ē ‘@@@ @@C  ē @@‘@ē @@‘@ ‘@@C  ēē @@@ ‘‘@@@ē @@‘@ @@C  ē @@‘@ēē @@@ ‘‘@@@ @@C  ēē @@@ ‘‘@@@ēē @@@ ‘‘@@@ @@C@Đ•AĐŠŠ‘CŠ‘E•AŠ•A–AĐŠŠ‘BŠ‘F•AŠ•A–AĐŠŠ‘AŠ‘D•AŠ•A–AŠŠ‘@Š‘G•AŠ•A–A„•Ķū“ÝÜ   (pure_sos@  ē @@@ @@C  Ą@ē @@@ @@C  Ą‘@ē @@@ @@C  ē ‘@@@ē ‘@@@ē ‘@@@ @@C  ēĄ@ēĄ@ē @@@ ‘@@@ē ‘@@@ @@@ēĄ@ē ‘@@@ @@@ ‘@@C@@„•Ķū+f]   5real_nonlinear_proverC  ē @@@ @@C  Ą@ē @@@ @@C  Ą‘@ē @@@ @@C  ē ‘@@@ē ‘@@@ē ‘@@@ @@C  ēĄ@ēĄ@ē @@@ ‘@@@ē ‘@@@ @@@ēĄ@ē ‘@@@ @@@ ‘@@C@Đ•AĐŠŠ‘D•AŠ•A–AĐŠŠ‘B•AŠ•’° A_nat A_natA–” – ĸ‘"x1‘"x2ĐŠŠ‘A•AŠ•’° A_nat A_natA–” – ĸ‘"x1‘"x3ĐŠŠ‘AŠ‘BŠ‘C•AŠ•’° A_nat A_natA–AĐŠŠ‘@•AŠ•’° A_nat A_natA–” – ĸ‘"x2‘"x3ĐŠŠ‘@Š‘BŠ‘C•AŠ•’° A_nat A_natA–AŠŠ‘@Š‘AŠ‘C•AŠ•’° A_nat A_natA–A„•ĶūsŪ­   (pure_sos@  ē @@‘@ē @@‘@ē @@‘@ ‘@@@  ēē @@@ē ‘@@@ē ‘@@@ @@@ēē @@@ē ‘@@@ @@@ē @@‘@ ‘‘‘@@C@@„•Ķū;nk   5real_nonlinear_proverB  ē @@‘@ē @@‘@ē @@‘@ ‘@@@  ēē @@@ē ‘@@@ē ‘@@@ @@@ēē @@@ē ‘@@@ @@@ē @@‘@ ‘‘‘@@C@Đ•AĐĻý@ĐŠ•AĐŠ•B–” ‘"x1” – ’° ĸ_nat A_natA‘"x2– ’° ĸ_nat A_natA‘"x3Š•’° A_nat A_natA–” – ĸ‘"x2‘"x3ŠŠ‘A•AŠ•A–A„•Ķū öõ   (pure_sos@  ē @@‘@ē @@‘@ē @@‘@ē @@‘@ ‘@@@  ēē @@@ē ‘@@@ē ‘@@@ē ‘@@@ @@@ēē @@@ē ‘@@@ē ‘@@@ @@@ēē @@@ē ‘@@@ @@@ē @@‘@ ‘‘@@C@@„•Ķūų,)   5real_nonlinear_proverB  ē @@‘@ē @@‘@ē @@‘@ē @@‘@ ‘@@@  ēē @@@ē ‘@@@ē ‘@@@ē ‘@@@ @@@ēē @@@ē ‘@@@ē ‘@@@ @@@ēē @@@ē ‘@@@ @@@ē @@‘@ ‘‘@@C@Đ•AĐĻü@ĐŠ•AĐŠ•C–” ‘"x1” – ’° ĸ_nat A_natA‘"x2” – ’° ĸ_nat A_natA‘"x3– ’° ĸ_nat A_natA‘"x4ĐŠ•’° A_nat A_natA–” – ’° ĸ_nat A_natA‘"x2” ‘"x3– ’° ĸ_nat A_natA‘"x4Š•B–” – ĸ‘"x2‘"x4ŠŠ‘A•AŠ•A–A„•ĶūOsr   (pure_sos@  ē @@@ ‘@@C  Ą@ē @@@ ‘@@C  ēĄ@ē ‘@@@ @@@ē @@@ ‘‘@@C@@„•Ķūƒŧļ   5real_nonlinear_proverB  ē @@@ ‘@@C  Ą@ē @@@ ‘@@C  ēĄ@ē ‘@@@ @@@ē @@@ ‘‘@@C@Đ•AĐŠŠ‘B•AŠ•A–AŠŠ‘@Š‘A•AŠ•A–A„•ĶūPut   (pure_sos@  ē @@@ ‘‘@@C  Ą@ē @@@ ‘‘@@C  ēĄ@ē ‘@@@ @@@ē @@@ ‘@@C@@„•ĶūĪõō   5real_nonlinear_proverB  ē @@@ ‘‘@@C  Ą@ē @@@ ‘‘@@C  ēĄ@ē ‘@@@ @@@ē @@@ ‘@@C@Đ•AĐŠŠ‘B•AŠ•A–AĐŠŠ‘A•AŠ•A–AĐŠŠ‘@•AŠ•A–AŠŠ‘@Š‘A•AŠ•A–A„•Ķūŧ"!   (pure_sos@  ē @@@ ‘‘@@C  ē ‘@@@ ‘@@C  Ą‘@ē @@@ ‘‘@@C  Ą‘@ē ‘@@@ ‘@@C  Ą@ē @@@ ‘‘@@C  Ą@ē ‘@@@ ‘@@C  ēē @@@ē ‘‘@@@ē ‘‘@@@ @@@ēē @@@ē ‘‘@@@ @@@ē @@‘@ ‘@@C@@„•ĶūŒ “   5real_nonlinear_proverB  ē @@@ ‘‘@@C  ē ‘@@@ ‘@@C  Ą‘@ē @@@ ‘‘@@C  Ą‘@ē ‘@@@ ‘@@C  Ą@ē @@@ ‘‘@@C  Ą@ē ‘@@@ ‘@@C  ēē @@@ē ‘‘@@@ē ‘‘@@@ @@@ēē @@@ē ‘‘@@@ @@@ē @@‘@ ‘@@C@Đ•AĐŠŠ‘F•AŠ•’° A_nat A_nat A–AĐŠŠ‘D•AŠ•’° A_nat A_nat A–AĐŠŠ‘DŠ‘E•AŠ•’° A_nat A_nat A–AĐŠŠ‘CŠ‘E•AŠ•’° A_nat A_nat A–AĐŠŠ‘B•AŠ•’° A_nat A_nat A–AĐŠŠ‘BŠ‘D•AŠ•’° A_nat A_nat A–AĐŠŠ‘BŠ‘C•AŠ•’° A_nat A_nat A–AĐŠŠ‘AŠ‘E•AŠ•’° A_nat A_nat A–AĐŠŠ‘AŠ‘C•AŠ•’° A_nat A_nat A–AĐŠŠ‘@•AŠ•’° A_nat A_nat A–AĐŠŠ‘@Š‘D•AŠ•’° A_nat A_nat A–AĐŠŠ‘@Š‘B•AŠ•’° A_nat A_nat A–AŠŠ‘@Š‘A•AŠ•’° A_nat A_nat A–A„•ĶūÁ.-   (pure_sos@  ē @@@ ‘‘@@C  ē ‘@@@ ‘‘@@C  Ą‘@ē @@@ ‘‘@@C  Ą‘@ē ‘@@@ ‘‘@@C  Ą@ē @@@ ‘‘@@C  Ą@ē ‘@@@ ‘‘@@C  ēē @@@ē ‘‘@@@ē ‘‘@@@ @@@ēē @@@ē ‘‘@@@ @@@ē @@‘@ ‘@@C@@„•ĶūŠĸō   5real_nonlinear_proverB  ē @@@ ‘‘@@C  ē ‘@@@ ‘‘@@C  Ą‘@ē @@@ ‘‘@@C  Ą‘@ē ‘@@@ ‘‘@@C  Ą@ē @@@ ‘‘@@C  Ą@ē ‘@@@ ‘‘@@C  ēē @@@ē ‘‘@@@ē ‘‘@@@ @@@ēē @@@ē ‘‘@@@ @@@ē @@‘@ ‘@@C@Đ•AĐŠŠ‘F•AŠ•A–AĐŠŠ‘D•AŠ•’° A_nat A_natA–AĐŠŠ‘DŠ‘E•AŠ•A–AĐŠŠ‘CŠ‘D•AŠ•’° A_nat A_natA–AĐŠŠ‘B•AŠ•’° A_nat A_natA–AĐŠŠ‘BŠ‘E•AŠ•’° A_nat A_natA–AĐŠŠ‘BŠ‘D•AŠ•’° A_nat A_natA–AĐŠŠ‘BŠ‘C•AŠ•A–AĐŠŠ‘AŠ‘D•AŠ•’° A_nat A_natA–AĐŠŠ‘AŠ‘B•AŠ•’° A_nat A_natA–AĐŠŠ‘@•AŠ•’° A_nat A_natA–AĐŠŠ‘@Š‘E•AŠ•’° A_nat A_natA–AĐŠŠ‘@Š‘D•AŠ•’° A_nat A_natA–AĐŠŠ‘@Š‘C•AŠ•’° A_nat A_natA–AĐŠŠ‘@Š‘B•AŠ•’° A_nat A_natA–AŠŠ‘@Š‘A•AŠ•A–A„•Ķūh™˜   (pure_sos@  ē @@@ @@C  Ą@ē @@@ @@C  ēĄ@ē @@@ @@@ ‘@@@  ēē ‘@@@ @@@ēē ‘@@@ @@@ ‘@@C@@„•ĶūB^V   5real_nonlinear_proverB  ē @@@ @@C  Ą@ē @@@ @@C  ēĄ@ē @@@ @@@ ‘@@@  ēē ‘@@@ @@@ēē ‘@@@ @@@ ‘@@C@Đ•AĐĻABĐŠ•AĐŠ•A–” – ’° ĸ_nat A_natA‘"x1” – ’° ĸ_nat A_natA‘"x2AŠ•’° A_nat A_natA–” – ĸ‘"x1‘"x2ŠŠ‘C•AŠ•A–A„•ĶūrĐĻ   (pure_sos@  ē @@@ @@C  Ą@ē @@@ @@C  ēĄ@ē @@@ @@@ ‘@@@  ēēĄ@ē @@@ ‘@@@ē @@‘@ @@@ē ‘@@‘@ ‘@@C@@„•Ķūd’Š   5real_nonlinear_proverC  ē @@@ @@C  Ą@ē @@@ @@C  ēĄ@ē @@@ @@@ ‘@@@  ēēĄ@ē @@@ ‘@@@ē @@‘@ @@@ē ‘@@‘@ ‘@@C@Đ•AĐĻ” – ĸ‘"x1” – ĸ‘"x2ABĐŠ•AĐŠ•A–” – ’° ĸ_nat A_natA‘"x1” – ’° ĸ_nat A_natA‘"x2AŠ•’° A_nat A_natA–” – ĸ‘"x1‘"x2ŠŠ‘C•AŠ•A–A„•ĶūaŽ   (pure_sos@  ē @@@ @@C  Ą@ē @@@ @@C  ēēē ‘@@@ē @@@ @@‘@ē @@@ @@@ē ‘@@‘‘@ ‘@@C@@„•ĶūJia   5real_nonlinear_proverD  ē @@@ @@C  Ą@ē @@@ @@C  ēēē ‘@@@ē @@@ @@‘@ē @@@ @@@ē ‘@@‘‘@ ‘@@C@Đ•AĐŠ•AĐŠ•A–” – ’° ĸ_nat A_natA˜ ‘"x1B” – ’° ĸ_nat A_natA– ‘"x1‘"x2˜ ‘"x2BŠ•’° A_nat A_natA–” – ĸ˜ ‘"x1B– ‘"x1‘"x2ŠŠ‘B•AŠ•A–A„•Ķū3FE   (pure_sos@  ē @@@ @@C  ēē ‘@@@ @@@ ‘@@C@@„•Ķūéã   5real_nonlinear_proverB  ē @@@ @@C  ēē ‘@@@ @@@ ‘@@C@Đ•AĐŠ•AĐŠ•’° A_nat A_natA–” – ’° ĸ_nat A_natA‘"x1AŠ•’° A_nat A_natA–‘"x1ŠŠ‘A•AŠ•’° A_nat A_natA–A„•Ķūķ   (pure_sos@  ēē @@@ē ‘@@@ @@@ē @@‘@ēē ‘@@@ē ‘‘@@@ ‘@@@ē ‘@@‘@ @@@  Ą@ē @@@ @@C  Ą@ē @@@ @@C  Ą‘@ē @@@ @@C  ē @@@ @@C  ē @@@ē @@@ē ‘@@@ē ‘@@@ ‘@@C@@„•Ķū[!   5real_nonlinear_proverB  ēē @@@ē ‘@@@ @@@ē @@‘@ēē ‘@@@ē ‘‘@@@ ‘@@@ē ‘@@‘@ @@@  Ą@ē @@@ @@C  Ą@ē @@@ @@C  Ą‘@ē @@@ @@C  ē @@@ @@C  ē @@@ē @@@ē ‘@@@ē ‘@@@ ‘@@C@Đ•AĐĻĸ@ĐŠŠ‘E•AŠ•A–AĐŠŠ‘D•AŠ•A–AĐŠŠ‘DŠ‘E•AŠ•A–AĐŠŠ‘C•AŠ•A–AĐŠŠ‘CŠ‘E•AŠ•A–AĐŠŠ‘BŠ‘E•AŠ•A–AĐŠŠ‘A•AŠ•B–AŠŠ‘AŠ‘E•AŠ•A–A„•ĶūZ!   5real_nonlinear_proverB  ēē @@@ē ‘@@@ @@@ē @@‘@ēē ‘@@@ē ‘‘@@@ ‘@@@ē ‘@@‘@ @@@  Ą@ē @@@ @@C  Ą@ē @@@ @@C  Ą‘@ē @@@ @@C  ē @@@ @@C  ē ‘@@@ē ‘@@@ē @@@ē @@@ ‘@@C@Đ•AĐĻA@ĐŠŠ‘E•AŠ•A–AĐŠŠ‘D•AŠ•A–AĐŠŠ‘DŠ‘E•AŠ•A–AĐŠŠ‘C•AŠ•A–AĐŠŠ‘CŠ‘E•AŠ•A–AĐŠŠ‘B•AŠ•B–AĐŠŠ‘BŠ‘E•AŠ•A–AŠŠ‘AŠ‘E•AŠ•A–A„•Ķū…BA   (pure_sos@  ēēēĄ@ē ‘@@‘@ @@‘@ēē ‘‘@@‘@ ‘@@‘@ @@‘@ēēē ‘@@‘@ ‘@@‘@ @@‘@ ‘@@‘@ē ‘@@‘@ ‘‘@@C@Đ’@Š•’° A_nat A_nat2AĐŠ•B–” – E– ˜ ‘"x1C‘"x2” – C– ‘"x1˜ ‘"x2C– ú– ‘"x1‘"x2ĐŠ•J–” – B– ˜ ‘"x1B˜ ‘"x2BýĐŠ•E–” – B– ˜ ‘"x1B‘"x2– ý‘"x2ĐŠ•B–” – D– ‘"x1˜ ‘"x2C– ý– ‘"x1‘"x2ĐŠ•E–” – B– ‘"x1˜ ‘"x2B– ý‘"x1ĐŠ•E–‘"x1ĐŠ•E–‘"x2ĐŠ•J–A•@„•Ķūôó   (pure_sos@  ēēēĄ@ē @@‘@ @@‘@ēē ‘@@‘@ ‘‘@@‘@ @@‘@ēēē @@‘@ ‘‘@@‘@ ‘@@‘@ @@‘@ē @@‘@ @@C  ēēĄ@ē ‘@@‘@ @@‘@ēē ‘@@‘@ @@‘@ @@‘@ ‘‘@@C@@„•ĶūĪž—   5real_nonlinear_proverH  ēēēĄ@ē @@‘@ @@‘@ēē ‘@@‘@ ‘‘@@‘@ @@‘@ēēē @@‘@ ‘‘@@‘@ ‘@@‘@ @@‘@ē @@‘@ @@C  ēēĄ@ē ‘@@‘@ @@‘@ēē ‘@@‘@ @@‘@ @@‘@ ‘‘@@C@Đ•AĐŠ•AĐŠ•’° A_nat A_natA–” – ’° ĸ_nat A_natA– ˜ ‘"x1B‘"x2‘"x2ĐŠ•’° A_nat A_natA–” – ’° ĸ_nat A_natA– ‘"x1˜ ‘"x2B‘"x1ĐŠ•’° A_nat A_natiA–– ‘"x1˜ ‘"x2BŠ•’° A_nat A_natiA–– ˜ ‘"x1B‘"x2ĐŠŠ‘A•AĐŠ•’° A_nat  A_natA–AĐŠ•’° A_nat A_natA–‘"x2Š•’° A_nat A_natA–‘"x1ŠŠ‘@•AŠ•’° A_nat A_natA–A„•Ķūîrq   (pure_sos@  Ą‘@ē @@@Ą@ē ‘@@@ē ‘@@@ ‘‘@@@  Ą‘@ē ‘@@@ē @@@ ‘‘@@@  ē @@@Ą‘@ē ‘@@@ ‘@@@  Ą@ē @@@Ą‘@ē ‘@@@ @@C  Ą@ē ‘‘@@@Ą@ē @@@ ‘@@@  Ą@ēē ‘@@@ ‘‘@@@ē @@@ ‘@@@  Ą@ē @@@Ą@ē ‘@@‘@ @@C  ē @@‘@ē ‘@@@ ‘@@C@@„•Ķū,ÓÏ   5real_nonlinear_proverB  Ą‘@ē @@@Ą@ē ‘@@@ē ‘@@@ ‘‘@@@  Ą‘@ē ‘@@@ē @@@ ‘‘@@@  ē @@@Ą‘@ē ‘@@@ ‘@@@  Ą@ē @@@Ą‘@ē ‘@@@ @@C  Ą@ē ‘‘@@@Ą@ē @@@ ‘@@@  Ą@ēē ‘@@@ ‘‘@@@ē @@@ ‘@@@  Ą@ē @@@Ą@ē ‘@@‘@ @@C  ē @@‘@ē ‘@@@ ‘@@C@Đ•AĐĻ” – ’° A_nat+ A_natA‘"x1” – ’° ĸ_nata A_natA‘"x4” – ’° A_nat  A_natA‘"x6” – ’° ĸ_natļ A_natA‘"x7’° A_nat  A_natA@ĐĻ” – ’° ĸ_nat3 A_natA‘"x1” – ’° A_natļ A_natA‘"x3” – ’° A_natē A_natA‘"x4” – ’° ĸ_natļ A_natA‘"x5” – ’° ĸ_nat' A_natA‘"x6’° ĸ_nat) A_natAAĐĻ” – ĸ‘"x1” – ’° ĸ_nat+ A_natA‘"x3” – ’° ĸ_nat A_natA‘"x4” – ’° A_nat+ A_natA‘"x5” – ’° ĸ_nat  A_natA‘"x6” – ’° A_nat3 A_natA‘"x7’° ĸ_nat A_natABĐĻ” – ’° A_nat A_natA‘"x1” – ’° ĸ_nat› A_natA‘"x3” – ’° ĸ_nat A_natA‘"x4” – ’° A_nat› A_natA‘"x5” – ’° A_nat A_natA‘"x6– ’° A_nat1 A_natA‘"x7DĐĻAEĐŠŠ‘G•AŠ•A–AŠŠ‘C•AŠ•A–A„•Ķūŋ‹†   5real_nonlinear_proverB  Ą‘@ē @@@Ą@ē ‘@@@ē ‘@@@ ‘‘@@@  Ą‘@ē ‘@@@ē @@@ ‘‘@@@  ē @@@Ą‘@ē ‘@@@ ‘@@@  Ą@ē @@@Ą‘@ē ‘@@@ @@C  Ą@ē ‘‘@@@Ą@ē @@@ ‘@@@  Ą@ēē ‘@@@ ‘‘@@@ē @@@ ‘@@@  Ą@ē @@@Ą@ē ‘@@‘@ @@C  ēē @@@ ‘@@@Ą@ē ‘@@@ @@C@Đ•AĐĻ” – ’° A_nat A_natA‘"x1” – ’° ĸ_nat A_natA‘"x4” – ’° A_nat A_nat A‘"x6” – ĸ‘"x7’° A_nat# A_natA@ĐĻ” – ’° A_nat A_nat A‘"x1” ‘"x3” – ’° A_nat A_natA‘"x4” – ĸ‘"x5” – ’° ĸ_nat A_natA‘"x6’° ĸ_natO A_nat$AAĐĻ” – ĸ‘"x1” – ’° ĸ_nat A_natA‘"x3” – ’° ĸ_nat A_nat A‘"x4” – ’° A_nat A_natA‘"x5” – ’° A_nat A_natA‘"x6” – ’° ĸ_nat A_nat A‘"x7’° A_nat A_natABĐĻ” – ’° A_nat A_natA‘"x1” – ’° A_nat A_nat A‘"x3” – ’° ĸ_nat A_natA‘"x4” – ’° ĸ_nat A_nat A‘"x5” – ’° ĸ_nat  A_nat$A‘"x6– ’° A_nat A_natA‘"x7DĐĻAEŠŠ‘G•AŠ•A–A„•Ķūîrq   (pure_sos@  Ą‘@ē @@@Ą@ē ‘@@@ē ‘@@@ ‘‘@@@  Ą‘@ē ‘@@@ē @@@ ‘‘@@@  ē @@@Ą‘@ē ‘@@@ ‘@@@  Ą@ē @@@Ą‘@ē ‘@@@ @@C  Ą@ēē ‘@@@ ‘‘@@@ē @@@ ‘@@@  Ą@ē ‘‘@@@Ą@ē @@@ ‘@@@  Ą@ē @@@Ą@ē ‘@@‘@ @@C  ē @@‘@ē ‘@@@ ‘@@C@@„•ĶūLëč   5real_nonlinear_proverB  Ą‘@ē @@@Ą@ē ‘@@@ē ‘@@@ ‘‘@@@  Ą‘@ē ‘@@@ē @@@ ‘‘@@@  ē @@@Ą‘@ē ‘@@@ ‘@@@  Ą@ē @@@Ą‘@ē ‘@@@ @@C  Ą@ēē ‘@@@ ‘‘@@@ē @@@ ‘@@@  Ą@ē ‘‘@@@Ą@ē @@@ ‘@@@  Ą@ē @@@Ą@ē ‘@@‘@ @@C  ē @@‘@ē ‘@@@ ‘@@C@Đ•AĐĻ” – ’° A_nat. A_natA‘"x1” – ’° ĸ_natî A_natA‘"x4” – ’° A_natĶ A_natA‘"x6” – ’° A_nat: A_natA‘"x7’° ĸ_nat‚ A_natA@ĐĻ” – ’° A_nat A_natA‘"x1” – ’° ĸ_nat: A_natA‘"x3” – ’° A_nat A_natA‘"x4” – ’° A_nat: A_natA‘"x5” – ’° ĸ_natÕ A_natA‘"x6’° A_natl A_natAAĐĻ” – ĸ‘"x1” – ’° ĸ_nat. A_natA‘"x3” – ’° A_nat  A_natA‘"x4” – ’° A_nat. A_natA‘"x5” – ’° A_nat> A_natA‘"x6” – ’° ĸ_nat A_natA‘"x7’° A_natŒ A_natABĐĻADĐĻ” – ’° A_nat A_natA‘"x1” – ’° ĸ_natā A_natA‘"x3” – ’° ĸ_nat A_natA‘"x4” – ’° A_natā A_natA‘"x5” – ’° ĸ_nat/ A_natA‘"x6” – ’° A_nat A_natA‘"x7’° ĸ_nate A_natAEĐŠŠ‘G•AŠ•A–AŠŠ‘C•AŠ•A–A„•ĶūCÛØ   5real_nonlinear_proverB  Ą‘@ē @@@Ą@ē ‘@@@ē ‘@@@ ‘‘@@@  Ą‘@ē ‘@@@ē @@@ ‘‘@@@  ē @@@Ą‘@ē ‘@@@ ‘@@@  Ą@ē @@@Ą‘@ē ‘@@@ @@C  Ą@ēē ‘@@@ ‘‘@@@ē @@@ ‘@@@  Ą@ē ‘‘@@@Ą@ē @@@ ‘@@@  Ą@ē @@@Ą@ē ‘@@‘@ @@C  ēē @@@ ‘@@@Ą@ē ‘@@@ @@C@Đ•AĐĻ” – ’° A_nat<{ A_natA‘"x1” – ’° A_natÓ A_natA‘"x4” – ’° A_natÁ A_natA‘"x6” – ’° ĸ_nat­ A_natA‘"x7’° A_nat? A_natA@ĐĻ” – ’° ĸ_natÕ A_natA‘"x1” – ’° A_nat­ A_natA‘"x3” – ’° ĸ_natĐ A_natA‘"x4” – ’° ĸ_nat­ A_natA‘"x5” – ’° A_natą A_nat€A‘"x6’° ĸ_natģs A_natAAĐĻ” – ĸ‘"x1” – ’° ĸ_nat<{ A_natA‘"x3” – ’° A_nat] A_natA‘"x4” – ’° A_nat<{ A_natA‘"x5” – ’° A_nat I A_natA‘"x6” – ’° A_natÕ A_natA‘"x7’° A_natIĐ A_natABĐĻADĐĻ” – ’° A_nat] A_natA‘"x1” – ’° A_nat§ A_natA‘"x3” – ’° ĸ_nat] A_natA‘"x4” – ’° ĸ_nat§ A_natA‘"x5” – ’° A_natAŅ A_natA‘"x6” – ’° ĸ_nat  A_natA‘"x7’° A_natsE A_natAEŠŠ‘G•AŠ•A–A„•Ķū-=<   (pure_sos@  ē @@@ ‘@@C  ē ‘@@‘@ @@C@@„•ĶūâÛÖ   5real_nonlinear_proverC  ē @@@ ‘@@C  ē ‘@@‘@ @@C@Đ•AĐŠ•AŠ•’° A_nat A_natA–” – þ‘"x1AĐŠŠ‘A•AŠ•’° A_nat A_natA–AŠŠ‘@•AŠ•’° A_nat A_natA–A„•ĶūNãâ   (pure_sos@  ēēēĄ@ē ‘@@‘@ @@‘@ēē ‘‘@@‘@ ‘@@‘@ @@‘@ēēē ‘@@‘@ ‘@@‘@ @@‘@ ‘@@‘@ē ‘@@‘@ ‘@@B@Đ’@Š•’° A_nat A_natAĐŠ•A–” – B– ˜ ‘"x1C‘"x2” – ‘"x1˜ ‘"x2C– ý– ‘"x1‘"x2ĐŠ•D–” – ˜ ‘"x1B˜ ‘"x2BĸĐŠ•D–” – ˜ ‘"x1B‘"x2– ĸ‘"x2ĐŠ•C–” – ‘"x1˜ ‘"x2C– ĸ– ‘"x1‘"x2ĐŠ•D–” – ‘"x1˜ ‘"x2B– ĸ‘"x1•@„•Ķū<UT   (pure_sos@  ē ‘@@@ē @@@ @@@  ē @@‘@ē ‘@@‘@ ‘@@C@@„•Ķūk‘Ž   5real_nonlinear_proverB  ē ‘@@@ē @@@ @@@  ē @@‘@ē ‘@@‘@ ‘@@C@Đ•AĐĻ” ‘"x1‘"x2@ŠŠ‘A•AŠ•A–A„•ĶūwĢ    5real_nonlinear_proverB  ē ‘@@@ē @@@ @@@  ē ‘@@‘@ē @@‘@ ‘@@C@Đ•AĐĻ” – ĸ‘"x1– ĸ‘"x2@ŠŠ‘A•AŠ•A–A„•Ķū<UT   (pure_sos@  ē @@@ē @@@ @@@  ē @@‘@ē ‘@@‘@ ‘@@C@@„•Ķūqš—   5real_nonlinear_proverB  ē @@@ē @@@ @@@  ē @@‘@ē ‘@@‘@ ‘@@C@Đ•AĐĻ” – ĸ‘"x1‘"x2@ŠŠ‘A•AŠ•A–A„•Ķūqš—   5real_nonlinear_proverB  ē @@@ē @@@ @@@  ē ‘@@‘@ē @@‘@ ‘@@C@Đ•AĐĻ” ‘"x1– ĸ‘"x2@ŠŠ‘A•AŠ•A–A„•Ķūœîí   (pure_sos@  Ą@ē @@‘@Ą@ē ‘@@‘@ @@@  ē @@‘@Ą@ē ‘@@‘@ @@@  Ą@ē @@@ @@C  ē @@@ @@C  Ą‘@ē ‘@@@ ‘@@C  Ą‘@ē @@‘@ē ‘‘@@‘@ @@@  ē ‘@@@ @@C@@„•Ķū…―ļ   5real_nonlinear_proverB  Ą@ē @@‘@Ą@ē ‘@@‘@ @@@  ē @@‘@Ą@ē ‘@@‘@ @@@  Ą@ē @@@ @@C  ē @@@ @@C  Ą‘@ē ‘@@@ ‘@@C  Ą‘@ē @@‘@ē ‘‘@@‘@ @@@  ē ‘@@@ @@C@Đ•AĐĻ@@ĐĻ’° A_nat A_natAAĐĻ@EĐŠ•AŠ•’° A_nat A_natA–” – B‘"x3AĐŠŠ‘D•AŠ•’° A_nat A_natA–AŠŠ‘CŠ‘F•AŠ•’° A_nat A_natA–A„•ĶūßNK   5real_nonlinear_proverB  Ą@ē @@‘@Ą@ē ‘@@‘@ @@@  ē @@‘@Ą@ē ‘@@‘@ @@@  Ą@ē @@@ @@C  ē @@@ @@C  Ą‘@ē ‘@@@ ‘@@C  Ą‘@ē @@‘@ē ‘‘@@‘@ @@@  Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ@@ĐĻ@AĐĻ@EĐŠŠ‘F•AŠ•A–AŠŠ‘B•AŠ•A–A„•ĶūßLI   5real_nonlinear_proverB  Ą@ē @@‘@Ą@ē ‘@@‘@ @@@  ē @@‘@Ą@ē ‘@@‘@ @@@  Ą@ē @@@ @@C  ē @@@ @@C  Ą‘@ē ‘@@@ ‘@@C  Ą‘@ē @@‘@ē ‘‘@@‘@ @@@  ē @@‘@ē ‘‘@@‘@ ‘@@C@Đ•AĐĻB@ĐĻĸAĐĻĸEŠŠ‘F•AŠ•A–A„•ĶūÞLI   5real_nonlinear_proverB  Ą@ē @@‘@Ą@ē ‘@@‘@ @@@  ē @@‘@Ą@ē ‘@@‘@ @@@  Ą@ē @@@ @@C  ē @@@ @@C  Ą‘@ē ‘@@@ ‘@@C  Ą‘@ē @@‘@ē ‘‘@@‘@ @@@  ē ‘@@‘@ē ‘@@‘@ ‘@@C@Đ•AĐĻþ@ĐĻAAĐĻAEŠŠ‘F•AŠ•A–A„•Ķū†―ļ   5real_nonlinear_proverB  Ą@ē @@‘@Ą@ē ‘@@‘@ @@@  ē @@‘@Ą@ē ‘@@‘@ @@@  Ą@ē @@@ @@C  ē @@@ @@C  Ą‘@ē @@@ ‘@@C  Ą‘@ē @@‘@ē ‘‘@@‘@ @@@  ē ‘@@@ @@C@Đ•AĐĻ@@ĐĻ’° A_nat A_natAAĐĻ@EĐŠ•AŠ•’° A_nat A_natA–” – þ‘"x3AĐŠŠ‘D•AŠ•’° A_nat A_natA–AŠŠ‘CŠ‘F•AŠ•’° A_nat A_natA–A„•ĶūßNK   5real_nonlinear_proverB  Ą@ē @@‘@Ą@ē ‘@@‘@ @@@  ē @@‘@Ą@ē ‘@@‘@ @@@  Ą@ē @@@ @@C  ē @@@ @@C  Ą‘@ē @@@ ‘@@C  Ą‘@ē @@‘@ē ‘‘@@‘@ @@@  Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ@@ĐĻ@AĐĻ@EĐŠŠ‘F•AŠ•A–AŠŠ‘B•AŠ•A–A„•ĶūßLI   5real_nonlinear_proverB  Ą@ē @@‘@Ą@ē ‘@@‘@ @@@  ē @@‘@Ą@ē ‘@@‘@ @@@  Ą@ē @@@ @@C  ē @@@ @@C  Ą‘@ē @@@ ‘@@C  Ą‘@ē @@‘@ē ‘‘@@‘@ @@@  ē @@‘@ē ‘‘@@‘@ ‘@@C@Đ•AĐĻB@ĐĻĸAĐĻĸEŠŠ‘F•AŠ•A–A„•ĶūÞLI   5real_nonlinear_proverB  Ą@ē @@‘@Ą@ē ‘@@‘@ @@@  ē @@‘@Ą@ē ‘@@‘@ @@@  Ą@ē @@@ @@C  ē @@@ @@C  Ą‘@ē @@@ ‘@@C  Ą‘@ē @@‘@ē ‘‘@@‘@ @@@  ē ‘@@‘@ē ‘@@‘@ ‘@@C@Đ•AĐĻþ@ĐĻAAĐĻAEŠŠ‘F•AŠ•A–A„•ĶūU}|   (pure_sos@  ē @@‘@ē ‘‘@@‘@ @@@  Ą@ē @@@ @@C  ē @@@ ‘@@C  ē ‘@@@ ‘@@C@@„•Ķū˜ßÜ   5real_nonlinear_proverB  ē @@‘@ē ‘‘@@‘@ @@@  Ą@ē @@@ @@C  ē @@@ ‘@@C  ē ‘@@@ ‘@@C@Đ•AĐĻ@@ĐŠ•AŠ•A–AĐŠŠ‘C•AŠ•A–AŠŠ‘B•AŠ•A–A„•ĶūóMI   5real_nonlinear_proverB  ē @@‘@ē ‘‘@@‘@ @@@  Ą@ē @@@ @@C  ē @@@ ‘@@C  ē ‘‘@@@ē ‘@@@ @@C@Đ•AĐĻA@ĐŠŠ‘C•AŠ•A–AĐŠŠ‘B•AŠ•A–AĐŠŠ‘BŠ‘C•AŠ•’° A_nat A_natA–AĐŠŠ‘AŠ‘C•AŠ•A–AŠŠ‘AŠ‘B•AŠ•A–A„•Ķū\ˆ‡   (pure_sos@  ē ‘‘@@‘@ē @@‘@ @@@  ē @@@ @@C  Ą@ē @@@ ‘@@C  ē ‘‘@@@ē @@@ @@C@@„•ĶūÔB?   5real_nonlinear_proverB  ē ‘‘@@‘@ē @@‘@ @@@  ē @@@ @@C  Ą@ē @@@ ‘@@C  ē ‘‘@@@ē @@@ @@C@Đ•AĐĻþ@ĐŠ•AŠ•A–” – ĸ‘"x2AĐŠŠ‘C•AŠ•A–AĐŠŠ‘B•AŠ•B–AĐŠŠ‘BŠ‘C•AŠ•A–AŠŠ‘AŠ‘C•AŠ•B–A„•Ķū›œ—   5real_nonlinear_proverB  ē ‘‘@@‘@ē @@‘@ @@@  ē @@@ @@C  Ą@ē @@@ ‘@@C  ē @@@ē ‘@@@ ‘@@C@Đ•AĐĻ’° A_nat A_natA@ĐŠŠ‘C•AŠ•’° A_nat A_natA–AĐŠŠ‘B•AŠ•’° A_nat A_natA–AĐŠŠ‘BŠ‘C•AŠ•’° A_nat A_natA–AĐŠŠ‘AŠ‘C•AŠ•’° A_nat A_natA–AŠŠ‘AŠ‘B•AŠ•’° A_nat A_natA–A„•Ķū‡Áū   5real_nonlinear_proverB  ē ‘‘@@‘@ē @@‘@ @@@  ē @@@ @@C  Ą@ē @@@ ‘@@C  ē ‘@@‘@ē ‘@@‘@ ‘@@C@Đ•AĐĻA@ŠŠ‘C•AŠ•A–A„•ĶūˆÁū   5real_nonlinear_proverB  ē ‘‘@@‘@ē @@‘@ @@@  ē @@@ @@C  Ą@ē @@@ ‘@@C  ē ‘‘@@‘@ē @@‘@ ‘@@C@Đ•AĐĻĸ@ŠŠ‘C•AŠ•A–A„•ĶūïÐÆ   5real_nonlinear_proverB  ēē ‘‘‘@@@ ‘@@@ ‘@@C@Đ•AĐŠ•AĐŠ•’° A_nat A_natA–” – B‘"x1AŠ•’° A_nat A_nat A–‘"x1ŠŠ‘@•AŠ•’° A_nat A_nat A–A„•Ķūxģē   (pure_sos@  Ą@ēē ‘@@@ ‘@@@ē ‘@@@ ‘@@C  ēē ‘@@@ ‘@@@Ą@ē ‘@@@ @@@  ē ‘@@@ē @@@ @@C  ē @@@ē ‘@@@ @@C@@„•ĶūU€x   5real_nonlinear_proverC  Ą@ēē ‘@@@ ‘@@@ē ‘@@@ ‘@@C  ēē ‘@@@ ‘@@@Ą@ē ‘@@@ @@@  ē ‘@@@ē @@@ @@C  ē @@@ē ‘@@@ @@C@Đ•AĐĻĸAĐŠŠ‘C•AŠ•’° A_nat A_natA–” ‘"x1‘"x2ĐŠŠ‘B•AŠ•A–” – ’° A_nat A_natA‘"x1” – ’° A_nat A_natA‘"x2AŠŠ‘@•AŠ•A–A„•ĶūT€x   5real_nonlinear_proverC  Ą@ēē @@@ @@@ē ‘‘@@@ ‘@@C  ēē ‘@@@ ‘@@@Ą@ē ‘@@@ @@@  ē ‘@@@ē @@@ @@C  ē @@@ē ‘@@@ @@C@Đ•AĐĻAAĐŠŠ‘C•AŠ•A–” – ’° A_nat A_natA‘"x1” – ’° A_nat A_natA‘"x2AĐŠŠ‘B•AŠ•’° A_nat A_natA–” ‘"x1‘"x2ŠŠ‘@•AŠ•A–A„•ĶūĒčå   5real_nonlinear_proverC  ēē ‘@@@ ‘@@@Ą@ē ‘@@@ ‘@@C  ēē ‘@@@ ‘@@@Ą@ē ‘@@@ @@@  ē ‘@@@ē @@@ @@C  ē ‘@@@ē @@@ ‘@@C@Đ•AĐĻĸAŠŠ‘@•AŠ•A–A„•Ķū_Œ‹   (pure_sos@  ē ‘@@‘@ēĄ@ē ‘‘@@@ @@@ ‘@@C  ēĄ@ē @@@ @@@ēĄ‘@ē @@‘@ @@@ē @@@ @@@@@„•Ķū­úũ   5real_nonlinear_proverD  ē ‘@@‘@ēĄ@ē ‘‘@@@ @@@ ‘@@C  ēĄ@ē @@@ @@@ēĄ‘@ē @@‘@ @@@ē @@@ @@@@Đ•AĐĻ– ü‘"x2AĐŠ•AŠ•A–” – B– ‘"x2‘"x4‘"x1ŠŠ‘@•AŠ•A–A„•ĶūQvu   (pure_sos@  ē ‘@@‘@ē @@‘@ ‘@@C  ē @@@ē @@@ @@C  ē @@@ē ‘@@@ @@C@@„•Ķū…ūŧ   5real_nonlinear_proverB  ē ‘@@‘@ē @@‘@ ‘@@C  ē @@@ē @@@ @@C  ē @@@ē ‘@@@ @@C@Đ•AĐŠŠ‘AŠ‘B•AŠ•A–AŠŠ‘@•AŠ•A–A„•ĶūX€   (pure_sos@  ēēē ‘@@@ē ‘@@@ @@@ē ‘@@‘@ @@@ē ‘@@@ ‘@@C  ē @@@ē @@@ @@C@@„•ĶūÍĘ   5real_nonlinear_proverD  ēēē ‘@@@ē ‘@@@ @@@ē ‘@@‘@ @@@ē ‘@@@ ‘@@C  ē @@@ē @@@ @@C@Đ•AĐŠŠ‘A•AŠ•A–” ‘"x1‘"x2ŠŠ‘@•AŠ•A–A„•ĶūįŠ‰   (pure_sos@  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ē @@@ @@C  Ą‘@ē ‘@@@Ą‘@ē @@@ē @@@ @@@  Ą‘@ē @@@Ą‘@ē @@@ē ‘@@@ @@@  Ą@ē ‘@@@Ą‘‘@ē @@@ē @@@ @@@  Ą@ē @@@Ą‘‘@ē @@@ē ‘@@@ @@@  Ą@ē @@@ē ‘@@@ @@C@@„•ĶūM   5real_nonlinear_proverB  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ē @@@ @@C  Ą‘@ē ‘@@@Ą‘@ē @@@ē @@@ @@@  Ą‘@ē @@@Ą‘@ē @@@ē ‘@@@ @@@  Ą@ē ‘@@@Ą‘‘@ē @@@ē @@@ @@@  Ą@ē @@@Ą‘‘@ē @@@ē ‘@@@ @@@  Ą@ē @@@ē ‘@@@ @@C@Đ•AĐĻ” – ü‘#x13” – D‘#x14” – ü‘"x6’° A_nat A_natAJĐĻ” – D‘#x13” – D‘#x14” – ü‘"x6’° A_nat A_natAKĐĻ” – D‘#x10” – ü‘"x4” – ü‘"x9’° ĸ_nat A_natALĐĻ” – D‘#x10” – ü‘"x4” – D‘"x9’° ĸ_nat A_natAMĐŠŠ‘IŠ‘N•AŠ•B–AŠŠ‘@•AŠ•A–A„•ĶūˆXT   5real_nonlinear_proverB  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ē @@@ @@C  Ą‘@ē ‘@@@Ą@ē @@@ ‘@@C  Ą‘@ē @@@Ą‘@ē @@@ē ‘@@@ @@@  Ą@ē ‘@@@Ą‘‘@ē @@@ē @@@ @@@  Ą@ē @@@Ą‘‘@ē @@@ē ‘@@@ @@@  Ą@ē @@@ē ‘@@@ @@C@Đ•AĐĻ” – ’° ĸ_nat A_natA‘#x10” – ’° A_nat A_natA‘"x4” – ’° ĸ_nat A_nat A‘"x9’° A_nat A_natAKĐĻ” – ’° A_nat A_nat A‘#x10” – ’° A_nat A_natA‘#x13” – ’° ĸ_nat A_natA‘#x14” – ’° ĸ_nat A_nat A‘"x4” – ’° A_nat A_natA‘"x6” – ’° ĸ_nat A_nat A‘"x9’° ĸ_nat A_natALĐĻ” – ’° A_nat A_nat A‘#x10” – ’° ĸ_nat A_natA‘#x13” – ’° A_nat A_natA‘#x14” – ’° ĸ_nat A_nat A‘"x4” – ’° ĸ_nat A_natA‘"x6” – ’° A_nat A_nat A‘"x9’° ĸ_nat A_natAMĐŠŠ‘J•AŠ•’° A_nat A_natA–AĐŠŠ‘IŠ‘N•AŠ•A–AŠŠ‘@•AŠ•’° A_nat A_natA–A„•Ķū‡XT   5real_nonlinear_proverB  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ē @@@ @@C  Ą‘@ē ‘@@@Ą‘@ē @@@ē @@@ @@@  Ą‘@ē @@@Ą@ē ‘@@@ ‘@@C  Ą@ē ‘@@@Ą‘‘@ē @@@ē @@@ @@@  Ą@ē @@@Ą‘‘@ē @@@ē ‘@@@ @@@  Ą@ē @@@ē ‘@@@ @@C@Đ•AĐĻ” – ’° A_nat A_natA‘#x10” – ’° ĸ_nat A_natA‘"x4” – ’° A_nat A_natA‘"x9’° A_nat A_natAJĐĻ” – ’° ĸ_nat A_natA‘#x10” – ’° ĸ_nat A_natA‘#x13” – ’° ĸ_nat A_natA‘#x14” – ’° A_nat A_natA‘"x4” – ’° A_nat A_natA‘"x6” – ’° A_nat A_natA‘"x9’° ĸ_nat A_natALĐĻ” – ’° ĸ_nat A_natA‘#x10” – ’° A_nat A_natA‘#x13” – ’° A_nat A_natA‘#x14” – ’° A_nat A_natA‘"x4” – ’° ĸ_nat A_natA‘"x6” – ’° ĸ_nat A_natA‘"x9’° ĸ_nat A_natAMĐŠŠ‘K•AŠ•’° A_nat A_natA–AĐŠŠ‘IŠ‘N•AŠ•A–AŠŠ‘@•AŠ•’° A_nat A_natA–A„•ĶūĖSP   5real_nonlinear_proverB  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ē @@@ @@C  Ą‘@ē ‘@@@Ą‘@ē @@@ē @@@ @@@  Ą‘@ē @@@Ą‘@ē @@@ē ‘@@@ @@@  Ą@ē ‘@@@Ą‘@ē @@@ ‘@@C  Ą@ē @@@Ą‘‘@ē @@@ē ‘@@@ @@@  Ą@ē @@@ē ‘@@@ @@C@Đ•AĐĻ” – B‘#x13” – þ‘#x14” – B‘"x6’° ĸ_nat A_natAJĐĻ” – ’° ĸ_nat A_natA‘#x10” – þ‘#x13” – þ‘#x14” – ’° A_nat A_natA‘"x4” – B‘"x6” – ’° A_nat A_natA‘"x9’° A_nat A_natAKĐĻ” – ’° ĸ_nat A_natA‘#x13” – ’° A_nat A_natA‘#x14– ’° ĸ_nat A_natA‘"x6MĐŠŠ‘L•AŠ•A–AĐŠŠ‘H•AŠ•A–AŠŠ‘A•AŠ•A–A„•Ķū†|y   5real_nonlinear_proverB  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ē @@@ @@C  Ą‘@ē ‘@@@Ą@ē @@@ ‘@@C  Ą‘@ē @@@Ą‘@ē @@@ē ‘@@@ @@@  Ą@ē ‘@@@Ą‘@ē @@@ ‘@@C  Ą@ē @@@Ą‘‘@ē @@@ē ‘@@@ @@@  Ą@ē @@@ē ‘@@@ @@C@Đ•AĐĻ” – B‘#x10” – þ‘"x4” – þ‘"x9AKĐĻ” – B‘#x13” – þ‘#x14” – B‘"x6ĸMĐŠŠ‘IŠ‘N•AŠ•B–AĐŠŠ‘H•AŠ•A–AĐŠŠ‘A•AŠ•A–AŠŠ‘@•AŠ•A–A„•ĶūÆF@   5real_nonlinear_proverB  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ē @@@ @@C  Ą‘@ē ‘@@@Ą‘@ē @@@ē @@@ @@@  Ą‘@ē @@@Ą@ē ‘@@@ ‘@@C  Ą@ē ‘@@@Ą‘@ē @@@ ‘@@C  Ą@ē @@@Ą‘‘@ē @@@ē ‘@@@ @@@  Ą@ē @@@ē ‘@@@ @@C@Đ•AĐĻ@JĐĻ@MĐŠŠ‘L•AŠ•’° A_nat A_natA–AĐŠŠ‘K•AŠ•’° A_nat A_natA–AĐŠŠ‘H•AŠ•’° A_nat A_natA–AŠŠ‘A•AŠ•’° A_nat A_natA–A„•ĶūĖSP   5real_nonlinear_proverB  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ē @@@ @@C  Ą‘@ē ‘@@@Ą‘@ē @@@ē @@@ @@@  Ą‘@ē @@@Ą‘@ē @@@ē ‘@@@ @@@  Ą@ē ‘@@@Ą‘‘@ē @@@ē @@@ @@@  Ą@ē @@@Ą‘@ē ‘@@@ ‘@@C  Ą@ē @@@ē ‘@@@ @@C@Đ•AĐĻ” – ’° ĸ_nat A_natA‘#x10” – B‘#x13” – þ‘#x14” – ’° A_nat A_natA‘"x4” – B‘"x6” – ’° ĸ_nat A_natA‘"x9’° A_nat A_natAJĐĻ” – þ‘#x13” – þ‘#x14” – B‘"x6’° ĸ_nat A_natAKĐĻ” – ’° A_nat A_natA‘#x13” – ’° A_nat A_natA‘#x14– ’° ĸ_nat A_natA‘"x6LĐŠŠ‘M•AŠ•A–AĐŠŠ‘G•AŠ•A–AŠŠ‘B•AŠ•A–A„•ĶūΠ  5real_nonlinear_proverB  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ē @@@ @@C  Ą‘@ē ‘@@@Ą@ē @@@ ‘@@C  Ą‘@ē @@@Ą‘@ē @@@ē ‘@@@ @@@  Ą@ē ‘@@@Ą‘‘@ē @@@ē @@@ @@@  Ą@ē @@@Ą‘@ē ‘@@@ ‘@@C  Ą@ē @@@ē ‘@@@ @@C@Đ•AĐĻ” – ’° A_nat A_natA‘#x10” – ’° ĸ_nat A_natA‘"x4– ’° A_nat A_natA‘"x9KĐĻ” – ’° ĸ_nat A_natA‘#x13” – ’° A_nat A_natA‘#x14– ’° ĸ_nat A_natA‘"x6LĐŠŠ‘M•AŠ•’° A_nat A_natA–AĐŠŠ‘J•AŠ•’° A_nat A_natA–AĐŠŠ‘G•AŠ•’° A_nat A_natA–AŠŠ‘B•AŠ•’° A_nat A_natA–A„•Ķū>    5real_nonlinear_proverB  ēĄ@ē ‘‘@@@ē ‘@@@ @@@Ą@ē @@@Ą@ē ‘@@@ ‘@@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą‘‘@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą‘‘@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@Ą@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@Ą@ē @@@Ą@ē ‘@@@ @@C  ēĄ@ē ‘@@@ē @@@ @@@ē @@@ē ‘@@@ē ‘@@@Ą@ē @@@ @@C  ēĄ@ē @@@ē ‘@@@ @@@ē ‘@@@ē @@@ē @@@Ą@ē ‘@@@ @@C  ē @@@ @@C  Ą‘@ē ‘@@@Ą‘@ē @@@ē @@@ @@@  Ą‘@ē @@@Ą@ē ‘@@@ ‘@@C  Ą@ē ‘@@@Ą‘‘@ē @@@ē @@@ @@@  Ą@ē @@@Ą‘@ē ‘@@@ ‘@@C  Ą@ē @@@ē ‘@@@ @@C@Đ•AĐĻAJĐĻĸLĐŠŠ‘IŠ‘N•AŠ•B–AĐŠŠ‘G•AŠ•A–AĐŠŠ‘B•AŠ•A–AŠŠ‘@•AŠ•A–A„•ĶūEba   (pure_sos@  ēĄ@ē ‘@@@ @@@ @@C  ē @@@ ‘@@C  Ą@ē @@@ ‘@@C@@„•Ķū™âß   5real_nonlinear_proverB  ēĄ@ē ‘@@@ @@@ @@C  ē @@@ ‘@@C  Ą@ē @@@ ‘@@C@Đ•AĐŠŠ‘B•AŠ•A–AĐŠŠ‘A•AŠ•A–AĐŠŠ‘AŠ‘B•AŠ•A–AŠŠ‘@•AŠ•A–A„•ĶūEba   (pure_sos@  ēĄ@ē @@@ @@@ ‘@@C  ē @@@ ‘@@C  Ą@ē @@@ @@@@@„•Ķūtž›   5real_nonlinear_proverB  ēĄ@ē @@@ @@@ ‘@@C  ē @@@ ‘@@C  Ą@ē @@@ @@@@Đ•AĐĻ– ĸ‘"x1BŠŠ‘@•AŠ•A–A„•Ķūn•’   5real_nonlinear_proverB  ēĄ@ē ‘@@@ @@@ ‘@@C  ē @@@ ‘@@C  Ą@ē @@@ @@@@Đ•AĐĻ‘"x1BŠŠ‘@•AŠ•A–A„•ĶūEba   (pure_sos@  ēĄ@ē @@@ @@@ @@C  ē @@@ ‘@@C  Ą@ē ‘@@@ ‘@@C@@„•Ķū™âß   5real_nonlinear_proverB  ēĄ@ē @@@ @@@ @@C  ē @@@ ‘@@C  Ą@ē ‘@@@ ‘@@C@Đ•AĐŠŠ‘B•AŠ•A–AĐŠŠ‘A•AŠ•A–AĐŠŠ‘AŠ‘B•AŠ•A–AŠŠ‘@•AŠ•A–A„•ĶūEba   (pure_sos@  ēĄ@ē @@@ @@@ ‘@@C  ē @@@ @@@  Ą@ē @@@ ‘@@C@@„•Ķūtž›   5real_nonlinear_proverB  ēĄ@ē @@@ @@@ ‘@@C  ē @@@ @@@  Ą@ē @@@ ‘@@C@Đ•AĐĻ– ĸ‘"x2AŠŠ‘@•AŠ•A–A„•Ķūn•’   5real_nonlinear_proverB  ēĄ@ē ‘@@@ @@@ ‘@@C  ē @@@ @@@  Ą@ē @@@ ‘@@C@Đ•AĐĻ‘"x2AŠŠ‘@•AŠ•A–A„•ĶūD`_   (pure_sos@  ēĄ@ē @@@ @@@ ‘@@C  ē @@@ @@@  Ą@ē @@@ @@@@@„•ĶūxĪĄ   5real_nonlinear_proverB  ēĄ@ē @@@ @@@ ‘@@C  ē @@@ @@@  Ą@ē @@@ @@@@Đ•AĐĻ@AĐĻ– ĸ‘"x1BŠŠ‘@•AŠ•A–A„•Ķūr›˜   5real_nonlinear_proverB  ēĄ@ē ‘@@@ @@@ ‘@@C  ē @@@ @@@  Ą@ē @@@ @@@@Đ•AĐĻ@AĐĻ‘"x1BŠŠ‘@•AŠ•A–A„•ĶūEba   (pure_sos@  ēĄ@ē @@@ @@@ ‘@@C  ē @@@ @@@  Ą@ē ‘@@@ ‘@@C@@„•Ķūtž›   5real_nonlinear_proverB  ēĄ@ē @@@ @@@ ‘@@C  ē @@@ @@@  Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ– ĸ‘"x2AŠŠ‘@•AŠ•A–A„•Ķūn•’   5real_nonlinear_proverB  ēĄ@ē ‘@@@ @@@ ‘@@C  ē @@@ @@@  Ą@ē ‘@@@ ‘@@C@Đ•AĐĻ‘"x2AŠŠ‘@•AŠ•A–A„•ĶūEba   (pure_sos@  ēĄ@ē @@@ @@@ @@C  ē ‘@@@ ‘@@C  Ą@ē @@@ ‘@@C@@„•Ķū™âß   5real_nonlinear_proverB  ēĄ@ē @@@ @@@ @@C  ē ‘@@@ ‘@@C  Ą@ē @@@ ‘@@C@Đ•AĐŠŠ‘B•AŠ•A–AĐŠŠ‘A•AŠ•A–AĐŠŠ‘AŠ‘B•AŠ•A–AŠŠ‘@•AŠ•A–A„•ĶūEba   (pure_sos@  ēĄ@ē @@@ @@@ ‘@@C  ē ‘@@@ ‘@@C  Ą@ē @@@ @@@@@„•Ķūtž›   5real_nonlinear_proverB  ēĄ@ē @@@ @@@ ‘@@C  ē ‘@@@ ‘@@C  Ą@ē @@@ @@@@Đ•AĐĻ– ĸ‘"x1BŠŠ‘@•AŠ•A–A„•Ķūn•’   5real_nonlinear_proverB  ēĄ@ē ‘@@@ @@@ ‘@@C  ē ‘@@@ ‘@@C  Ą@ē @@@ @@@@Đ•AĐĻ‘"x1BŠŠ‘@•AŠ•A–A„•ĶūEba   (pure_sos@  ēĄ@ē ‘@@@ @@@ @@C  ē ‘@@@ ‘@@C  Ą@ē ‘@@@ ‘@@C@@„•Ķū™âß   5real_nonlinear_proverB  ēĄ@ē ‘@@@ @@@ @@C  ē ‘@@@ ‘@@C  Ą@ē ‘@@@ ‘@@C@Đ•AĐŠŠ‘B•AŠ•A–AĐŠŠ‘A•AŠ•A–AĐŠŠ‘AŠ‘B•AŠ•A–AŠŠ‘@•AŠ•A–A„•ĶūD`_   (pure_sos@  ēĄ@ē ‘@@@ @@@ ‘@@C  ē @@@ @@C  Ą@ē @@@ @@C@@„•ĶūxĻĨ   5real_nonlinear_proverB  ēĄ@ē ‘@@@ @@@ ‘@@C  ē @@@ @@C  Ą@ē @@@ @@C@Đ•AĐŠŠ‘AŠ‘B•AŠ•A–AŠŠ‘@•AŠ•A–A„•Ķū?[Z   (pure_sos@  ē @@@ē ‘@@‘@ @@C  ē @@‘@ē @@@ ‘@@@@@„•Ķūŋ~x   5real_nonlinear_proverB  ē @@@ē ‘@@‘@ @@C  ē @@‘@ē @@@ ‘@@@@Đ•AĐĻ’° ĸ_nat1 A_nat AAĐŠ•AĐŠ•’° A_nat A_natA–” – ’° ĸ_natU A_nat A‘"x1” – ’° A_nat1 A_natWA‘"x2AĐŠ•’° A_nat’ŋ A_nat% A–” ‘"x1– ’° A_nataž A_nat’ŋA‘"x2Š•’° A_natũ A_natIEļA–‘"x2ŠŠ‘@•AŠ•’° A_natU A_natHA–A„•ĶūĨúų   (pure_sos@  ēĄ@ē ‘@@@ @@@Ą@ēĄ@ē @@@ @@@ ‘@@C  ē @@@ @@C  Ą@ē @@@ @@C  ē @@‘@ē @@‘@ē ‘@@‘@ē ‘@@‘@ ‘‘@@@  ēĄ‘@ē @@@ @@@ēĄ‘@ē @@@ @@@ @@@@@„•ĶūĢ˜   5real_nonlinear_proverD  ēĄ@ē ‘@@@ @@@Ą@ēĄ@ē @@@ @@@ ‘@@C  ē @@@ @@C  Ą@ē @@@ @@C  ē @@‘@ē @@‘@ē ‘@@‘@ē ‘@@‘@ ‘‘@@@  ēĄ‘@ē @@@ @@@ēĄ‘@ē @@@ @@@ @@@@Đ•AĐĻ” – ’° ĸ_nat A_natA– ‘"x1‘"x2’° A_nat A_natACĐĻ” – ’° ĸ_nat A_natA– ‘"x1‘"x4– ’° ĸ_nat A_natA– ‘"x2‘"x3DĐŠ•AŠ•’° A_nat A_natA–” – ĸ‘"x3‘"x4ĐŠŠ‘AŠ‘B•AĐŠ•’° A_nat A_natA–‘"x2Š•’° A_nat A_natA–‘"x1ŠŠ‘@•AĐŠ•’° A_nat A_natA–AĐŠ•’° A_nat A_natA–‘"x2Š•’° A_nat A_natA–‘"x1„•ĶūKon   (pure_sos@  ē @@@ @@C  ē ‘@@@ē ‘@@@ @@C  Ą@ē ‘@@@ ‘‘‘@@C@@„•Ķū-)"   5real_nonlinear_proverB  ē @@@ @@C  ē ‘@@@ē ‘@@@ @@C  Ą@ē ‘@@@ ‘‘‘@@C@Đ•AĐŠ•AŠ•’° A_nat A_natA–AĐŠŠ‘B•AŠ•’° A_nat A_natA–AĐŠŠ‘A•AŠ•’° A_nat A_natA–AŠŠ‘@•AŠ•’° A_nat A_natA–A„•ĶūĮ32   (pure_sos@  ēē @@@ ‘‘@@@ēē @@@ ‘‘@@@ @@C  ē @@‘@ēē @@@ ‘‘@@@ @@C  ēē @@@ ‘‘@@@ē @@‘@ @@C  ē @@‘@ē @@‘@ ‘@@C  Ą@ē ‘@@@ @@C  Ą@ē @@@ @@C  ē ‘@@@ @@C  ē @@@ @@C@@„•ĶūŒËà  5real_nonlinear_proverC  ēē @@@ ‘‘@@@ēē @@@ ‘‘@@@ @@C  ē @@‘@ēē @@@ ‘‘@@@ @@C  ēē @@@ ‘‘@@@ē @@‘@ @@C  ē @@‘@ē @@‘@ ‘@@C  Ą@ē ‘@@@ @@C  Ą@ē @@@ @@C  ē ‘@@@ @@C  ē @@@ @@C@Đ•AĐŠŠ‘CŠ‘F•AŠ•’° A_nat A_natA–AĐŠŠ‘CŠ‘D•AŠ•’° A_nat A_natA–AĐŠŠ‘BŠ‘G•AŠ•’° A_nat A_natA–AĐŠŠ‘BŠ‘D•AŠ•’° A_nat A_natA–AĐŠŠ‘AŠ‘F•AŠ•’° A_nat A_natA–AĐŠŠ‘AŠ‘E•AŠ•’° A_nat A_natA–AĐŠŠ‘@Š‘G•AŠ•’° A_nat A_natA–AŠŠ‘@Š‘E•AŠ•’° A_nat A_natA–A„•Ķū“ÝÜ   (pure_sos@  ēĄ@ēĄ@ē @@@ ‘@@@ē ‘@@@ @@@ēĄ@ē ‘@@@ @@@ ‘@@C  ē ‘@@@ē ‘@@@ē ‘@@@ @@C  Ą‘@ē @@@ @@C  Ą@ē @@@ @@C  ē @@@ @@C@@„•Ķū+f]   5real_nonlinear_proverC  ēĄ@ēĄ@ē @@@ ‘@@@ē ‘@@@ @@@ēĄ@ē ‘@@@ @@@ ‘@@C  ē ‘@@@ē ‘@@@ē ‘@@@ @@C  Ą‘@ē @@@ @@C  Ą@ē @@@ @@C  ē @@@ @@C@Đ•AĐŠŠ‘D•AŠ•’° A_nat A_natA–” ‘"x2– ĸ‘"x3ĐŠŠ‘C•AŠ•’° A_nat A_natA–” ‘"x1– ĸ‘"x3ĐŠŠ‘B•AŠ•’° A_nat A_natA–” ‘"x1– ĸ‘"x2ĐŠŠ‘AŠ‘CŠ‘D•AŠ•’° A_nat A_natA–AĐŠŠ‘AŠ‘BŠ‘D•AŠ•’° A_nat A_natA–AĐŠŠ‘AŠ‘BŠ‘C•AŠ•’° A_nat A_natA–AŠŠ‘@•AŠ•A–A„•ĶūsŪ­   (pure_sos@  ēē @@@ē ‘@@@ē ‘@@@ @@@ēē @@@ē ‘@@@ @@@ē @@‘@ ‘‘‘@@C  ē @@‘@ē @@‘@ē @@‘@ ‘@@@@@„•Ķū;nk   5real_nonlinear_proverB  ēē @@@ē ‘@@@ē ‘@@@ @@@ēē @@@ē ‘@@@ @@@ē @@‘@ ‘‘‘@@C  ē @@‘@ē @@‘@ē @@‘@ ‘@@@@Đ•AĐĻýAĐŠ•AĐŠ•B–” ‘"x1” – ’° ĸ_nat A_natA‘"x2– ’° ĸ_nat A_natA‘"x3Š•’° A_nat A_natA–” – ĸ‘"x2‘"x3ŠŠ‘@•AŠ•A–A„•Ķū öõ   (pure_sos@  ēē @@@ē ‘@@@ē ‘@@@ē ‘@@@ @@@ēē @@@ē ‘@@@ē ‘@@@ @@@ēē @@@ē ‘@@@ @@@ē @@‘@ ‘‘@@C  ē @@‘@ē @@‘@ē @@‘@ē @@‘@ ‘@@@@@„•Ķūų,)   5real_nonlinear_proverB  ēē @@@ē ‘@@@ē ‘@@@ē ‘@@@ @@@ēē @@@ē ‘@@@ē ‘@@@ @@@ēē @@@ē ‘@@@ @@@ē @@‘@ ‘‘@@C  ē @@‘@ē @@‘@ē @@‘@ē @@‘@ ‘@@@@Đ•AĐĻüAĐŠ•AĐŠ•C–” ‘"x1” – ’° ĸ_nat A_natA‘"x2” – ’° ĸ_nat A_natA‘"x3– ’° ĸ_nat A_natA‘"x4ĐŠ•’° A_nat A_natA–” – ’° ĸ_nat A_natA‘"x2” ‘"x3– ’° ĸ_nat A_natA‘"x4Š•B–” – ĸ‘"x2‘"x4ŠŠ‘@•AŠ•A–A„•ĶūOsr   (pure_sos@  ēĄ@ē ‘@@@ @@@ē @@@ ‘‘@@C  Ą@ē @@@ ‘@@C  ē @@@ ‘@@C@@„•Ķūƒŧļ   5real_nonlinear_proverB  ēĄ@ē ‘@@@ @@@ē @@@ ‘‘@@C  Ą@ē @@@ ‘@@C  ē @@@ ‘@@C@Đ•AĐŠŠ‘AŠ‘B•AŠ•A–AŠŠ‘@•AŠ•A–A„•ĶūPut   (pure_sos@  ēĄ@ē ‘@@@ @@@ē @@@ ‘@@C  Ą@ē @@@ ‘‘@@C  ē @@@ ‘‘@@C@@„•ĶūĪõō   5real_nonlinear_proverB  ēĄ@ē ‘@@@ @@@ē @@@ ‘@@C  Ą@ē @@@ ‘‘@@C  ē @@@ ‘‘@@C@Đ•AĐŠŠ‘B•AŠ•A–AĐŠŠ‘A•AŠ•A–AĐŠŠ‘AŠ‘B•AŠ•A–AŠŠ‘@•AŠ•A–A„•Ķūŧ"!   (pure_sos@  ēē @@@ē ‘‘@@@ē ‘‘@@@ @@@ēē @@@ē ‘‘@@@ @@@ē @@‘@ ‘@@C  Ą@ē ‘@@@ ‘@@C  Ą@ē @@@ ‘‘@@C  Ą‘@ē ‘@@@ ‘@@C  Ą‘@ē @@@ ‘‘@@C  ē ‘@@@ ‘@@C  ē @@@ ‘‘@@C@@„•Ķū”Ē“   5real_nonlinear_proverB  ēē @@@ē ‘‘@@@ē ‘‘@@@ @@@ēē @@@ē ‘‘@@@ @@@ē @@‘@ ‘@@C  Ą@ē ‘@@@ ‘@@C  Ą@ē @@@ ‘‘@@C  Ą‘@ē ‘@@@ ‘@@C  Ą‘@ē @@@ ‘‘@@C  ē ‘@@@ ‘@@C  ē @@@ ‘‘@@C@Đ•AĐŠŠ‘F•AŠ•’° A_nat A_nat A–AĐŠŠ‘EŠ‘F•AŠ•’° A_nat A_nat A–AĐŠŠ‘D•AŠ•’° A_nat A_nat A–AĐŠŠ‘DŠ‘F•AŠ•’° A_nat A_nat A–AĐŠŠ‘CŠ‘E•AŠ•’° A_nat A_nat A–AĐŠŠ‘CŠ‘D•AŠ•’° A_nat A_nat A–AĐŠŠ‘B•AŠ•’° A_nat A_nat A–AĐŠŠ‘BŠ‘F•AŠ•’° A_nat A_nat A–AĐŠŠ‘BŠ‘D•AŠ•’° A_nat A_nat A–AĐŠŠ‘AŠ‘E•AŠ•’° A_nat A_nat A–AĐŠŠ‘AŠ‘C•AŠ•’° A_nat A_nat A–AĐŠŠ‘AŠ‘B•AŠ•’° A_nat A_nat A–AŠŠ‘@•AŠ•’° A_nat A_nat A–A„•ĶūÁ.-   (pure_sos@  ēē @@@ē ‘‘@@@ē ‘‘@@@ @@@ēē @@@ē ‘‘@@@ @@@ē @@‘@ ‘@@C  Ą@ē ‘@@@ ‘‘@@C  Ą@ē @@@ ‘‘@@C  Ą‘@ē ‘@@@ ‘‘@@C  Ą‘@ē @@@ ‘‘@@C  ē ‘@@@ ‘‘@@C  ē @@@ ‘‘@@C@@„•ĶūĶþō   5real_nonlinear_proverB  ēē @@@ē ‘‘@@@ē ‘‘@@@ @@@ēē @@@ē ‘‘@@@ @@@ē @@‘@ ‘@@C  Ą@ē ‘@@@ ‘‘@@C  Ą@ē @@@ ‘‘@@C  Ą‘@ē ‘@@@ ‘‘@@C  Ą‘@ē @@@ ‘‘@@C  ē ‘@@@ ‘‘@@C  ē @@@ ‘‘@@C@Đ•AĐŠŠ‘F•AŠ•’° A_nat A_natA–AĐŠŠ‘EŠ‘F•AŠ•A–AĐŠŠ‘D•AŠ•’° A_nat A_natA–AĐŠŠ‘DŠ‘F•AŠ•’° A_nat A_natA–AĐŠŠ‘DŠ‘E•AŠ•’° A_nat A_natA–AĐŠŠ‘CŠ‘F•AŠ•’° A_nat A_natA–AĐŠŠ‘CŠ‘D•AŠ•A–AĐŠŠ‘B•AŠ•’° A_nat A_natA–AĐŠŠ‘BŠ‘F•AŠ•’° A_nat A_natA–AĐŠŠ‘BŠ‘E•AŠ•’° A_nat A_natA–AĐŠŠ‘BŠ‘D•AŠ•’° A_nat A_natA–AĐŠŠ‘BŠ‘C•AŠ•’° A_nat A_natA–AĐŠŠ‘AŠ‘F•AŠ•’° A_nat A_natA–AĐŠŠ‘AŠ‘D•AŠ•’° A_nat A_natA–AĐŠŠ‘AŠ‘B•AŠ•A–AŠŠ‘@•AŠ•A–A„•ĶūÆ   (pure_sos@  ēē ‘@@@ @@@ēē ‘@@@ @@@ ‘@@C  ēĄ@ē @@@ @@@ ‘@@@  Ą@ē @@@ @@C  ē @@@ @@C@Đ’@Š•’° A_nat A_natAĐŠ•A–” – B‘"x1ĸĐŠ•A–” – B‘"x2ĸĐŠ•B–A•@„•ĶūrĐĻ   (pure_sos@  ēēĄ@ē @@@ ‘@@@ē @@‘@ @@@ē ‘@@‘@ ‘@@C  ēĄ@ē @@@ @@@ ‘@@@  Ą@ē @@@ @@C  ē @@@ @@C@@„•Ķūd’Š   5real_nonlinear_proverC  ēēĄ@ē @@@ ‘@@@ē @@‘@ @@@ē ‘@@‘@ ‘@@C  ēĄ@ē @@@ @@@ ‘@@@  Ą@ē @@@ @@C  ē @@@ @@C@Đ•AĐĻ” – ĸ‘"x1” – ĸ‘"x2AAĐŠ•AĐŠ•A–” – ’° ĸ_nat A_natA‘"x1” – ’° ĸ_nat A_natA‘"x2AŠ•’° A_nat A_natA–” ‘"x1– ĸ‘"x2ŠŠ‘@•AŠ•A–A„•ĶūįA@   (pure_sos@  ēēē ‘@@@ē @@@ @@‘@ē @@@ @@@ē ‘@@‘‘@ ‘@@C  Ą@ē @@@ @@C  ē @@@ @@C@Đ’@Š•’° A_nat A_natAĐŠ•A–” – B˜ ‘"x1B” – ĸ– ‘"x1‘"x2– ĸ˜ ‘"x2BĐŠ•C–” – ‘"x1‘"x2– ĸ˜ ‘"x2BĐŠ•D–A•@„•Ķū|š™   (pure_sos@  ēē ‘@@@ @@@ ‘@@C  ē @@@ @@C@Đ’@Š•’° A_nat A_natAĐŠ•A–” – B‘"x1ĸĐŠ•C–A•@„•Ķūķ   (pure_sos@  ē @@@ē @@@ē ‘@@@ē ‘@@@ ‘@@C  ē @@@ @@C  Ą‘@ē @@@ @@C  Ą@ē @@@ @@C  Ą@ē @@@ @@C  ēē @@@ē ‘@@@ @@@ē @@‘@ēē ‘@@@ē ‘‘@@@ ‘@@@ē ‘@@‘@ @@@@@„•Ķū[!   5real_nonlinear_proverB  ē @@@ē @@@ē ‘@@@ē ‘@@@ ‘@@C  ē @@@ @@C  Ą‘@ē @@@ @@C  Ą@ē @@@ @@C  Ą@ē @@@ @@C  ēē @@@ē ‘@@@ @@@ē @@‘@ēē ‘@@@ē ‘‘@@@ ‘@@@ē ‘@@‘@ @@@@Đ•AĐĻĸEĐŠŠ‘D•AŠ•B–AĐŠŠ‘B•AŠ•A–AĐŠŠ‘A•AŠ•A–AĐŠŠ‘@•AŠ•A–AĐŠŠ‘@Š‘D•AŠ•A–AĐŠŠ‘@Š‘C•AŠ•A–AĐŠŠ‘@Š‘B•AŠ•A–AŠŠ‘@Š‘A•AŠ•A–A„•ĶūZ!   5real_nonlinear_proverB  ē ‘@@@ē ‘@@@ē @@@ē @@@ ‘@@C  ē @@@ @@C  Ą‘@ē @@@ @@C  Ą@ē @@@ @@C  Ą@ē @@@ @@C  ēē @@@ē ‘@@@ @@@ē @@‘@ēē ‘@@@ē ‘‘@@@ ‘@@@ē ‘@@‘@ @@@@Đ•AĐĻAEĐŠŠ‘C•AŠ•B–AĐŠŠ‘B•AŠ•A–AĐŠŠ‘A•AŠ•A–AĐŠŠ‘@•AŠ•A–AĐŠŠ‘@Š‘D•AŠ•A–AĐŠŠ‘@Š‘C•AŠ•A–AĐŠŠ‘@Š‘B•AŠ•A–AŠŠ‘@Š‘A•AŠ•A–A„•Ķūôó   (pure_sos@  ēēĄ@ē ‘@@‘@ @@‘@ēē ‘@@‘@ @@‘@ @@‘@ ‘‘@@C  ēēēĄ@ē @@‘@ @@‘@ēē ‘@@‘@ ‘‘@@‘@ @@‘@ēēē @@‘@ ‘‘@@‘@ ‘@@‘@ @@‘@ē @@‘@ @@C@@„•Ķū —   5real_nonlinear_proverH  ēēĄ@ē ‘@@‘@ @@‘@ēē ‘@@‘@ @@‘@ @@‘@ ‘‘@@C  ēēēĄ@ē @@‘@ @@‘@ēē ‘@@‘@ ‘‘@@‘@ @@‘@ēēē @@‘@ ‘‘@@‘@ ‘@@‘@ @@‘@ē @@‘@ @@C@Đ•AĐŠ•AĐŠ•’° A_nat A_natA–” – ’° ĸ_nat A_natA– ˜ ‘"x1B‘"x2‘"x2ĐŠ•’° A_nat A_natA–” – ’° ĸ_nat A_natA– ‘"x1˜ ‘"x2B‘"x1ĐŠ•’° A_nat A_natiA–– ‘"x1˜ ‘"x2BŠ•’° A_nat A_natiA–– ˜ ‘"x1B‘"x2ĐŠŠ‘A•AŠ•’° A_nat A_natA–AŠŠ‘@•AĐŠ•’° A_nat  A_natA–AĐŠ•’° A_nat A_natA–‘"x2Š•’° A_nat A_natA–‘"x1„•Ķū-=<   (pure_sos@  ē ‘@@‘@ @@C  ē @@@ ‘@@C@@„•ĶūæÜÖ   5real_nonlinear_proverC  ē ‘@@‘@ @@C  ē @@@ ‘@@C@Đ•AĐŠ•AŠ•’° A_nat A_natA–” – þ‘"x1AĐŠŠ‘A•AŠ•’° A_nat A_natA–AŠŠ‘@•AŠ•’° A_nat A_natA–A„•Ķū<UT   (pure_sos@  ē @@‘@ē ‘@@‘@ ‘@@C  ē ‘@@@ē @@@ @@@@@„•Ķūk‘Ž   5real_nonlinear_proverB  ē @@‘@ē ‘@@‘@ ‘@@C  ē ‘@@@ē @@@ @@@@Đ•AĐĻ” ‘"x1‘"x2AŠŠ‘@•AŠ•A–A„•ĶūwĢ    5real_nonlinear_proverB  ē ‘@@‘@ē @@‘@ ‘@@C  ē ‘@@@ē @@@ @@@@Đ•AĐĻ” – ĸ‘"x1– ĸ‘"x2AŠŠ‘@•AŠ•A–A„•Ķū<UT   (pure_sos@  ē @@‘@ē ‘@@‘@ ‘@@C  ē @@@ē @@@ @@@@@„•Ķūqš—   5real_nonlinear_proverB  ē @@‘@ē ‘@@‘@ ‘@@C  ē @@@ē @@@ @@@@Đ•AĐĻ” – ĸ‘"x1‘"x2AŠŠ‘@•AŠ•A–A„•Ķūqš—   5real_nonlinear_proverB  ē ‘@@‘@ē @@‘@ ‘@@C  ē @@@ē @@@ @@@@Đ•AĐĻ” ‘"x1– ĸ‘"x2AŠŠ‘@•AŠ•A–A„•Ķūœîí   (pure_sos@  ē ‘@@@ @@C  Ą‘@ē @@‘@ē ‘‘@@‘@ @@@  Ą‘@ē ‘@@@ ‘@@C  ē @@@ @@C  Ą@ē @@@ @@C  ē @@‘@Ą@ē ‘@@‘@ @@@  Ą@ē @@‘@Ą@ē ‘@@‘@ @@@@@„•Ķū…―ļ   5real_nonlinear_proverB  ē ‘@@@ @@C  Ą‘@ē @@‘@ē ‘‘@@‘@ @@@  Ą‘@ē ‘@@@ ‘@@C  ē @@@ @@C  Ą@ē @@@ @@C  ē @@‘@Ą@ē ‘@@‘@ @@@  Ą@ē @@‘@Ą@ē ‘@@‘@ @@@@Đ•AĐĻ@AĐĻ’° A_nat A_natAEĐĻ@FĐŠ•AŠ•’° A_nat A_natA–” – B‘"x3AĐŠŠ‘B•AŠ•’° A_nat A_natA–AŠŠ‘@Š‘C•AŠ•’° A_nat A_natA–A„•ĶūßLI   5real_nonlinear_proverB  ē @@‘@ē ‘‘@@‘@ ‘@@C  Ą‘@ē @@‘@ē ‘‘@@‘@ @@@  Ą‘@ē ‘@@@ ‘@@C  ē @@@ @@C  Ą@ē @@@ @@C  ē @@‘@Ą@ē ‘@@‘@ @@@  Ą@ē @@‘@Ą@ē ‘@@‘@ @@@@Đ•AĐĻĸAĐĻĸEĐĻBFŠŠ‘@•AŠ•A–A„•ĶūÞLI   5real_nonlinear_proverB  ē ‘@@‘@ē ‘@@‘@ ‘@@C  Ą‘@ē @@‘@ē ‘‘@@‘@ @@@  Ą‘@ē ‘@@@ ‘@@C  ē @@@ @@C  Ą@ē @@@ @@C  ē @@‘@Ą@ē ‘@@‘@ @@@  Ą@ē @@‘@Ą@ē ‘@@‘@ @@@@Đ•AĐĻAAĐĻAEĐĻþFŠŠ‘@•AŠ•A–A„•Ķū†―ļ   5real_nonlinear_proverB  ē ‘@@@ @@C  Ą‘@ē @@‘@ē ‘‘@@‘@ @@@  Ą‘@ē @@@ ‘@@C  ē @@@ @@C  Ą@ē @@@ @@C  ē @@‘@Ą@ē ‘@@‘@ @@@  Ą@ē @@‘@Ą@ē ‘@@‘@ @@@@Đ•AĐĻ@AĐĻ’° A_nat A_natAEĐĻ@FĐŠ•AŠ•’° A_nat A_natA–” – þ‘"x3AĐŠŠ‘B•AŠ•’° A_nat A_natA–AŠŠ‘@Š‘C•AŠ•’° A_nat A_natA–A„•ĶūßLI   5real_nonlinear_proverB  ē @@‘@ē ‘‘@@‘@ ‘@@C  Ą‘@ē @@‘@ē ‘‘@@‘@ @@@  Ą‘@ē @@@ ‘@@C  ē @@@ @@C  Ą@ē @@@ @@C  ē @@‘@Ą@ē ‘@@‘@ @@@  Ą@ē @@‘@Ą@ē ‘@@‘@ @@@@Đ•AĐĻĸAĐĻĸEĐĻBFŠŠ‘@•AŠ•A–A„•ĶūÞLI   5real_nonlinear_proverB  ē ‘@@‘@ē ‘@@‘@ ‘@@C  Ą‘@ē @@‘@ē ‘‘@@‘@ @@@  Ą‘@ē @@@ ‘@@C  ē @@@ @@C  Ą@ē @@@ @@C  ē @@‘@Ą@ē ‘@@‘@ @@@  Ą@ē @@‘@Ą@ē ‘@@‘@ @@@@Đ•AĐĻAAĐĻAEĐĻþFŠŠ‘@•AŠ•A–A„•Ķū]Š‰   (pure_sos@  ē ‘‘@@@ē ‘@@@ @@C  ē @@@ ‘@@C  Ą@ē @@@ @@C  ē @@‘@ē ‘‘@@‘@ @@@@@„•ĶūóMI   5real_nonlinear_proverB  ē ‘‘@@@ē ‘@@@ @@C  ē @@@ ‘@@C  Ą@ē @@@ @@C  ē @@‘@ē ‘‘@@‘@ @@@@Đ•AĐĻACĐŠŠ‘A•AŠ•A–AĐŠŠ‘AŠ‘B•AŠ•A–AĐŠŠ‘@•AŠ•A–AĐŠŠ‘@Š‘B•AŠ•A–AŠŠ‘@Š‘A•AŠ•’° A_nat A_natA–A„•Ķū\ˆ‡   (pure_sos@  ē ‘‘@@@ē @@@ @@C  Ą@ē @@@ ‘@@C  ē @@@ @@C  ē ‘‘@@‘@ē @@‘@ @@@@@„•ĶūÔB?   5real_nonlinear_proverB  ē ‘‘@@@ē @@@ @@C  Ą@ē @@@ ‘@@C  ē @@@ @@C  ē ‘‘@@‘@ē @@‘@ @@@@Đ•AĐĻþCĐŠ•AŠ•A–” – ĸ‘"x2AĐŠŠ‘A•AŠ•B–AĐŠŠ‘@•AŠ•A–AĐŠŠ‘@Š‘B•AŠ•B–AŠŠ‘@Š‘A•AŠ•A–A„•ĶūĢž—   5real_nonlinear_proverB  ē @@@ē ‘@@@ ‘@@C  Ą@ē @@@ ‘@@C  ē @@@ @@C  ē ‘‘@@‘@ē @@‘@ @@@@Đ•AĐĻ’° A_nat A_natACĐŠŠ‘A•AŠ•’° A_nat A_natA–AĐŠŠ‘AŠ‘B•AŠ•’° A_nat A_natA–AĐŠŠ‘@•AŠ•’° A_nat A_natA–AĐŠŠ‘@Š‘B•AŠ•’° A_nat A_natA–AŠŠ‘@Š‘A•AŠ•’° A_nat A_natA–A„•ĶūˆÁū   5real_nonlinear_proverB  ē ‘‘@@‘@ē @@‘@ ‘@@C  Ą@ē @@@ ‘@@C  ē @@@ @@C  ē ‘‘@@‘@ē @@‘@ @@@@Đ•AĐĻĸCŠŠ‘@•AŠ•A–Acoq-8.4pl4/test-suite/ideal-features/0000755000175000017500000000000012365131023016613 5ustar stephstephcoq-8.4pl4/test-suite/ideal-features/Case4.v0000644000175000017500000000226112326224777017762 0ustar stephstephInductive listn : nat -> Set := | niln : listn 0 | consn : forall n : nat, nat -> listn n -> listn (S n). Inductive empty : forall n : nat, listn n -> Prop := intro_empty : empty 0 niln. Parameter inv_empty : forall (n a : nat) (l : listn n), ~ empty (S n) (consn n a l). Type (fun (n : nat) (l : listn n) => match l in (listn n) return (empty n l \/ ~ empty n l) with | niln => or_introl (~ empty 0 niln) intro_empty | consn n O y as b => or_intror (empty (S n) b) (inv_empty n 0 y) | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y) end). Type (fun (n : nat) (l : listn n) => match l in (listn n) return (empty n l \/ ~ empty n l) with | niln => or_introl (~ empty 0 niln) intro_empty | consn n O y => or_intror (empty (S n) (consn n 0 y)) (inv_empty n 0 y) | consn n a y => or_intror (empty (S n) (consn n a y)) (inv_empty n a y) end). Type (fun (n : nat) (l : listn n) => match l in (listn n) return (empty n l \/ ~ empty n l) with | niln => or_introl (~ empty 0 niln) intro_empty | consn O a y as b => or_intror (empty 1 b) (inv_empty 0 a y) | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y) end). coq-8.4pl4/test-suite/ideal-features/eapply_evar.v0000644000175000017500000000043412326224777021332 0ustar stephsteph(* Test propagation of evars from subgoal to brother subgoals *) (* This does not work (oct 2008) because "match goal" sees "?evar = O" and not "O = O" *) Lemma eapply_evar : O=O -> 0=O. intro H; eapply eq_trans; [apply H | match goal with |- ?x = ?x => reflexivity end]. Qed. coq-8.4pl4/test-suite/ideal-features/evars_subst.v0000644000175000017500000000277412326224777021374 0ustar stephsteph(* Bug report #932 *) (* Expected time < 1.00s *) (* Let n be the number of let-in. The complexity comes from the fact that each implicit arguments of f was in a larger and larger context. To compute the type of "let _ := f ?Tn 0 in f ?T 0", "f ?Tn 0" is substituted in the type of "f ?T 0" which is ?T. This type is an evar instantiated on the n variables denoting the "f ?Ti 0". One obtain "?T[1;...;n-1;f ?Tn[1;...;n-1] 0]". To compute the type of "let _ := f ?Tn-1 0 in let _ := f ?Tn 0 in f ?T 0", another substitution is done leading to "?T[1;...;n-2;f ?Tn[1;...;n-2] 0;f ?Tn[1;...;n-2;f ?Tn[1;...;n-2] 0] 0]" and so on. At the end, we get a term of exponential size *) (* A way to cut the complexity could have been to remove the dependency in anonymous variables in evars but this breaks intuitive behaviour (see Case15.v); another approach could be to substitute lazily and/or to simultaneously substitute let binders and evars *) Variable P : Set -> Set. Variable f : forall A : Set, A -> P A. Time Check let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in f _ 0. coq-8.4pl4/test-suite/ideal-features/complexity/0000755000175000017500000000000012365131023021010 5ustar stephstephcoq-8.4pl4/test-suite/ideal-features/complexity/evars_subst.v0000644000175000017500000000277412326224777023571 0ustar stephsteph(* Bug report #932 *) (* Expected time < 1.00s *) (* Let n be the number of let-in. The complexity comes from the fact that each implicit arguments of f was in a larger and larger context. To compute the type of "let _ := f ?Tn 0 in f ?T 0", "f ?Tn 0" is substituted in the type of "f ?T 0" which is ?T. This type is an evar instantiated on the n variables denoting the "f ?Ti 0". One obtain "?T[1;...;n-1;f ?Tn[1;...;n-1] 0]". To compute the type of "let _ := f ?Tn-1 0 in let _ := f ?Tn 0 in f ?T 0", another substitution is done leading to "?T[1;...;n-2;f ?Tn[1;...;n-2] 0;f ?Tn[1;...;n-2;f ?Tn[1;...;n-2] 0] 0]" and so on. At the end, we get a term of exponential size *) (* A way to cut the complexity could have been to remove the dependency in anonymous variables in evars but this breaks intuitive behaviour (see Case15.v); another approach could be to substitute lazily and/or to simultaneously substitute let binders and evars *) Variable P : Set -> Set. Variable f : forall A : Set, A -> P A. Time Check let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in f _ 0. coq-8.4pl4/test-suite/ideal-features/Case9.v0000644000175000017500000000047512326224777017774 0ustar stephsteph(* Exemple soumis par Pierre Corbineau (bug #1671) *) CoInductive hdlist : unit -> Type := | cons : hdlist tt -> hdlist tt. Variable P : forall bo, hdlist bo -> Prop. Variable all : forall bo l, P bo l. Definition F (l:hdlist tt) : P tt l := match l in hdlist u return P u l with | cons (cons l') => all tt _ end. coq-8.4pl4/test-suite/ideal-features/universes.v0000644000175000017500000000341012326224777021043 0ustar stephsteph(* Some issues with polymorphic inductive types *) (* 1- upper constraints with respect to non polymorphic inductive types *) Unset Elimination Schemes. Definition Ty := Type (* Top.1 *). Inductive Q (A:Type (* Top.2 *)) : Prop := q : A -> Q A. Inductive T (B:Type (* Top.3 *)) := t : B -> Q (T B) -> T B. (* ajoute Top.4 <= Top.2 inutilement: 4 est l'univers utilisÃĐ dans le calcul du type polymorphe de T *) Definition C := T Ty. (* ajoute Top.1 < Top.3 : Top.3 jour le rÃīle de pivot pour propager les contraintes supÃĐrieures qu'on a sur l'argument B de T: Top.3 sera rÃĐutilisÃĐ plus tard comme majorant des arguments effectifs de T, propageant à cette occasion les contraintes supÃĐrieures sur Top.3 *) (* We need either that Q is polymorphic on A (though it is in Type) or that the constraint Top.1 < Top.2 is set (and it is not set!) *) (* 2- upper constraints with respect to unfoldable constants *) Definition f (A:Type (* Top.1 *)) := True. Inductive R := r : f R -> R. (* ajoute Top.3 <= Top.1 inutilement: Top.3 est l'univers utilisÃĐ dans le calcul du type polymorphe de R *) (* mais il manque la contrainte que l'univers de R est plus petit que Top.1 ce qui l'empÊcherait en fait d'Être vraiment polymorphe *) (* 3- constraints with respect to global constants *) Inductive S (A:Ty) := s : A -> S A. (* Q est considÃĐrÃĐ polymorphique vis à vis de A alors que le type de A n'est pas une variable mais un univers dÃĐjà existant *) (* MalgrÃĐ tout la contrainte Ty < Ty est ajoutÃĐe (car Ty est vu comme un pivot pour propager les contraintes sur le type A, comme si Q ÃĐtait vraiment polymorphique, ce qu'il n'est pas parce que Ty est une constante). Et heureusement qu'elle est ajoutÃĐ car elle ÃĐvite de pouvoir typer "Q Ty" *) coq-8.4pl4/test-suite/ideal-features/Apply.v0000644000175000017500000000170612326224777020113 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* True | S p => n = n -> T p end. Require Import Arith. Goal T 3 -> T 1. intro H. apply H. (* This needs unification on type *) Goal forall n m : nat, S m = S n :>nat. intros. apply f_equal. (* f_equal : forall (A B:Set) (f:A->B) (x y:A), x=y->(f x)=(f y) *) (* and A cannot be deduced from the goal but only from the type of f, x or y *) coq-8.4pl4/test-suite/ideal-features/implicit_binders.v0000644000175000017500000001037312326224777022346 0ustar stephsteph(** * Questions de syntaxe autour de la gÃĐnÃĐralisation implicite ** Lieurs de classes Aujourd'hui, les lieurs de classe [ ] et les lieurs {{ }} sont ÃĐquivalents et on a toutes les combinaisons de { et ( pour les lieurs de classes (oÃđ la variable liÃĐe peut Être anonyme): *) Class Foo (A : Type) := foo : A -> nat. Definition bar [ Foo A ] (x y : A) := foo x + foo y. Definition bar₀ {{ Foo A }} (x y : A) := foo x + foo y. Definition bar₁ {( Foo A )} (x y : A) := foo x + foo y. Definition bar₂ ({ Foo A }) (x y : A) := foo x + foo y. Definition bar₃ (( Foo A )) (x y : A) := foo x + foo y. Definition bar₄ {( F : Foo A )} (x y : A) := foo x + foo y. (** Les lieurs sont gÃĐnÃĐralisÃĐs à tous les termes, pas seulement aux classes: *) Definition relation A := A -> A -> Prop. Definition inverse {( R : relation A )} := fun x y => R y x. (** Autres propositions: [Definition inverse ..(R : relation A) := fun x y => R y x] et [Definition inverse ..[R : relation A] := fun x y => R y x] ou [Definition inverse ..{R : relation A} := fun x y => R y x] pour lier [R] implicitement. MS: Le .. empÊche d'utiliser electric-terminator dans Proof General. Cependant, il existe aussi les caractÃĻres utf8 â€Ĩ (two dot leader) et â€Ķ (horizontal ellipsis) qui permettraient d'ÃĐviter ce souci moyennant l'utilisation d'unicode. [Definition inverse _(R : relation A) := fun x y => R y x] et [Definition inverse _[R : relation A] := fun x y => R y x] ou [Definition inverse _{R : relation A} := fun x y => R y x] [Definition inverse `(R : relation A) := fun x y => R y x] et [Definition inverse `[R : relation A] := fun x y => R y x] ou [Definition inverse `{R : relation A} := fun x y => R y x] Toujours avec la possibilitÃĐ de ne pas donner le nom de la variable: *) Definition div (x : nat) ({ y <> 0 }) := 0. (** Un choix à faire pour les inductifs: accepter ou non de ne pas donner de nom à l'argument. Manque de variables anonymes pour l'utilisateur mais pas pour le systÃĻme... *) Inductive bla [ Foo A ] : Type :=. (** *** Les autres syntaxes ne supportent pas de pouvoir spÃĐcifier sÃĐparÃĐment les statuts des variables gÃĐnÃĐralisÃĐes et celui de la variable liÃĐe. Ca peut Être utile pour les classes oÃđ l'on a les cas de figure: *) (** Trouve [A] et l'instance par unification du type de [x]. *) Definition allimpl {{ Foo A }} (x : A) : A := x. (** Trouve l'instance à partir de l'index explicite *) Class SomeStruct (a : nat) := non_zero : a <> 0. Definition instimpl ({ SomeStruct a }) : nat := a + a. (** Donne l'instance explicitement (façon foncteur). *) Definition foo_prod {( Foo A, Foo B )} : Foo (A * B) := fun x => let (l, r) := x in foo l + foo r. (** *** Questions: - Gardez les crochets [ ] pour {{ }} ? - Quelle syntaxe pour la gÃĐnÃĐralisation ? - Veut-on toutes les combinaisons de statut pour les variables gÃĐnÃĐralisÃĐes et la variable liÃĐe ? *) (** ** Constructeur de gÃĐnÃĐralisation implicite Permet de faire une gÃĐnÃĐralisation n'importe oÃđ dans le terme: on utilise un produit ou un lambda suivant le scope (fragile ?). *) Goal `(x + y + z = x + (y + z)). Admitted. (** La gÃĐnÃĐralisation donne un statut implicite aux variables si l'on utilise `{ }. *) Definition baz := `{x + y + z = x + (y + z)}. Print baz. (** Proposition d'Arthur C.: dÃĐclarer les noms de variables gÃĐnÃĐralisables à la [Implicit Types] pour plus de robustesse (cela vaudrait aussi pour les lieurs). Les typos du genre de l'exemple suivant ne sont plus silencieuses: *) Check `(foob 0 + x). (** UtilisÃĐ pour gÃĐnÃĐraliser l'implÃĐmentation de la gÃĐnÃĐralisation implicite dans les dÃĐclarations d'instances (i.e. les deux defs suivantes sont ÃĐquivalentes). *) Instance fooa : Foo A. Admitted. Definition fooa' : `(Foo A). Admitted. (** Un peu diffÃĐrent de la gÃĐnÃĐralisation des lieurs qui "explosent" les variables libres en les liant au mÊme niveau que l'objet. Dans la deuxiÃĻme defs [a] n'est pas liÃĐ dans la dÃĐfinition mais [F : Π a, SomeStruct a]. *) Definition qux {( F : SomeStruct a )} : nat := a. Definition qux₁ {( F : `(SomeStruct a) )} : nat := 0. (** *** Questions - Autres propositions de syntaxe ? - RÃĐactions sur la construction ? *)coq-8.4pl4/test-suite/coqdoc/0000755000175000017500000000000012365131024015172 5ustar stephstephcoq-8.4pl4/test-suite/coqdoc/links.v0000644000175000017500000000316412326224777016524 0ustar stephsteph(** Various checks for coqdoc - symbols should not be inlined in string g - links to both kinds of notations in a' should work to the right notation - with utf8 option, forall must be unicode - splitting between symbols and ident should be correct in a' and c - ".." should be rendered correctly *) Require Import String. Definition g := "dfjkh""sdfhj forall <> * ~"%string. Definition a (b: nat) := b. Definition f := forall C:Prop, C. Notation "n ++ m" := (plus n m). Notation "n ++ m" := (mult n m). (* redefinition *) Notation "n ** m" := (plus n m) (at level 60). Notation "n â–ĩ m" := (plus n m) (at level 60). Notation "n '_' ++ 'x' m" := (plus n m) (at level 3). Inductive eq (A:Type) (x:A) : A -> Prop := eq_refl : x = x :>A where "x = y :> A" := (@eq A x y) : type_scope. Definition eq0 := 0 = 0 :> nat. Notation "( x # y ; .. ; z )" := (pair .. (pair x y) .. z). Definition b_Îą := ((0#0;0) , (0 ** 0)). Notation h := a. Section test. Variables b' b2: nat. Notation "n + m" := (n â–ĩ m) : my_scope. Delimit Scope my_scope with my. Notation l := 0. Definition Îą := (0 + l)%my. Definition a' b := b'++0++b2 _ ++x b. Definition c := {True}+{True}. Definition d := (1+2)%nat. Lemma e : nat + nat. Admitted. End test. Section test2. Variables b': nat. Section test. Variables b2: nat. Definition a'' b := b' ++ O ++ b2 _ ++ x b + h 0. End test. End test2. (** skip *) (** skip *) (** skip *) (** skip *) (** skip *) (** skip *) (** skip *) (** skip *) (** skip *) (** skip *) (** skip *) (** skip *) (** skip *) (** skip *) coq-8.4pl4/test-suite/output/0000755000175000017500000000000012365131023015261 5ustar stephstephcoq-8.4pl4/test-suite/output/Record.out0000644000175000017500000000032412326224777017247 0ustar stephsteph{| field := 5 |} : test {| field := 5 |} : test {| field_r := 5 |} : test_r build_c 5 : test_c build 5 : test build 5 : test {| field_r := 5 |} : test_r build_c 5 : test_c coq-8.4pl4/test-suite/output/Tactics.v0000644000175000017500000000054512326224777017066 0ustar stephsteph(* Test printing of Tactic Notation *) Tactic Notation "a" constr(x) := apply x. Tactic Notation "e" constr(x) := exact x. Ltac f H := split; [a H|e H]. Print Ltac f. (* Test printing of match context *) (* Used to fail after translator removal (see bug #1070) *) Ltac g := match goal with |- context [if ?X then _ else _ ] => case X end. Print Ltac g. coq-8.4pl4/test-suite/output/NumbersSyntax.v0000644000175000017500000000250712326224777020316 0ustar stephsteph Require Import BigQ. Open Scope int31_scope. Check I31. (* Would be nice to have I31 : digits->digits->...->int31 For the moment, I31 : digits31 int31, which is better than (fix nfun .....) size int31 *) Check 2. Check 1000000000000000000. (* = 660865024, after modulo 2^31 *) Check (add31 2 2). Check (2+2). Eval vm_compute in 2+2. Eval vm_compute in 65675757 * 565675998. Close Scope int31_scope. Open Scope bigN_scope. Check 2. Check 1000000000000000000. Check (BigN.add 2 2). Check (2+2). Eval vm_compute in 2+2. Eval vm_compute in 65675757 * 565675998. Eval vm_compute in 2^100. Close Scope bigN_scope. Open Scope bigZ_scope. Check 2. Check -1000000000000000000. Check (BigZ.add 2 2). Check (2+2). Eval vm_compute in 2+2. Eval vm_compute in 65675757 * 565675998. Eval vm_compute in (-2)^100. Close Scope bigZ_scope. Open Scope bigQ_scope. Check 2. Check -1000000000000000000. Check (BigQ.add 2 2). Check (2+2). Eval vm_compute in 2+2. Eval vm_compute in 65675757 * 565675998. (* fractions *) Check (6562 # 456). (* Nota: # is BigQ.Qq i.e. base fractions *) Eval vm_compute in (BigQ.red (6562 # 456)). Eval vm_compute in (1/-10000). Eval vm_compute in (BigQ.red (1/(1/100))). (* back to integers... *) Eval vm_compute in ((2/3)^(-100)). Eval vm_compute in BigQ.red ((2/3)^(-1000) * (2/3)^(1000)). Close Scope bigQ_scope. coq-8.4pl4/test-suite/output/SearchPattern.out0000644000175000017500000000142512326224777020577 0ustar stephstephfalse: bool true: bool xorb: bool -> bool -> bool orb: bool -> bool -> bool negb: bool -> bool implb: bool -> bool -> bool andb: bool -> bool -> bool S: nat -> nat O: nat pred: nat -> nat plus: nat -> nat -> nat mult: nat -> nat -> nat minus: nat -> nat -> nat min: nat -> nat -> nat max: nat -> nat -> nat length: forall A : Type, list A -> nat S: nat -> nat pred: nat -> nat plus: nat -> nat -> nat mult: nat -> nat -> nat minus: nat -> nat -> nat min: nat -> nat -> nat max: nat -> nat -> nat mult_n_Sm: forall n m : nat, n * m + n = n * S m le_n: forall n : nat, n <= n identity_refl: forall (A : Type) (a : A), identity a a eq_refl: forall (A : Type) (x : A), x = x iff_refl: forall A : Prop, A <-> A pair: forall A B : Type, A -> B -> A * B conj: forall A B : Prop, A -> B -> A /\ B coq-8.4pl4/test-suite/output/ZSyntax.v0000644000175000017500000000105612326224777017112 0ustar stephstephRequire Import ZArith. Check 32%Z. Check (fun f : nat -> Z => (f 0%nat + 0)%Z). Check (fun x : positive => Zpos (xO x)). Check (fun x : positive => (Zpos x + 1)%Z). Check (fun x : positive => Zpos x). Check (fun x : positive => Zneg (xO x)). Check (fun x : positive => (Zpos (xO x) + 0)%Z). Check (fun x : positive => (- Zpos (xO x))%Z). Check (fun x : positive => (- Zpos (xO x) + 0)%Z). Check (Z.of_nat 0 + 1)%Z. Check (0 + Z.of_nat (0 + 0))%Z. Check (Z.of_nat 0 = 0%Z). (* Submitted by Pierre Casteran *) Require Import Arith. Check (0 + Z.of_nat 11)%Z. coq-8.4pl4/test-suite/output/inference.out0000644000175000017500000000044212326224777017770 0ustar stephstephP = fun e : option L => match e with | Some cl => Some cl | None => None end : option L -> option L fun n : nat => let x := A n in ?12 ?15:T n : forall n : nat, T n fun n : nat => ?20 ?23:T n : forall n : nat, T n coq-8.4pl4/test-suite/output/Sum.out0000644000175000017500000000014312326224777016574 0ustar stephstephnat + nat + {True} : Set {True} + {True} + {True} : Set nat + {True} + {True} : Set coq-8.4pl4/test-suite/output/Match_subterm.v0000644000175000017500000000012612326224777020264 0ustar stephstephGoal 0 = 1. match goal with | |- context [?v] => idtac v ; fail | _ => idtac 2 end. coq-8.4pl4/test-suite/output/PrintAssumptions.out0000644000175000017500000000105012326224777021370 0ustar stephstephAxioms: foo : nat Axioms: foo : nat Axioms: extensionality : forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g Axioms: extensionality : forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g Axioms: extensionality : forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g Axioms: extensionality : forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g Closed under the global context Closed under the global context coq-8.4pl4/test-suite/output/rewrite-2172.out0000644000175000017500000000014512326224777020104 0ustar stephstephThe command has indeed failed with message: => Error: Unable to find an instance for the variable E. coq-8.4pl4/test-suite/output/Notations.v0000644000175000017500000002023612326224777017451 0ustar stephsteph(**********************************************************************) (* Notations for if and let (submitted by Roland Zumkeller) *) Notation "a ? b ; c" := (if a then b else c) (at level 10). Check (true ? 0 ; 1). Check if true as x return (if x then nat else bool) then 0 else true. Notation "'proj1' t" := (let (a,_) := t in a) (at level 1). Check (fun e : nat * nat => proj1 e). Notation "'decomp' a 'as' x , y 'in' b" := (let (x,y) := a in b) (at level 1). Check (decomp (true,true) as t, u in (t,u)). (**********************************************************************) (* Behaviour wrt to binding variables (submitted by Roland Zumkeller) *) Section A. Notation "! A" := (forall _:nat, A) (at level 60). Check ! (0=0). Check forall n, n=0. Check forall n:nat, 0=0. End A. (**********************************************************************) (* Behaviour wrt to binding variables (cf bug report #1186) *) Section B. Notation "# A" := (forall n:nat, n=n->A) (at level 60). Check forall n:nat, # (n=n). Notation "## A" := (forall n n0:nat, n=n0->A) (at level 60). Check forall n n0:nat, ## (n=n0). Notation "### A" := (forall n n0:nat, match n with O => True | S n => n=n0 end ->A) (at level 60). Check forall n n0:nat, ### (n=n0). End B. (**********************************************************************) (* Conflict between notation and notation below coercions *) (* Case of a printer conflict *) Require Import BinInt. Coercion Zpos : positive >-> Z. Open Scope Z_scope. (* Check that (Zpos 3) is better printed by the printer for Z than by the printer for positive *) Check (3 + Zpos 3). (* Case of a num printer only below coercion (submitted by Georges Gonthier) *) Open Scope nat_scope. Inductive znat : Set := Zpos (n : nat) | Zneg (m : nat). Coercion Zpos: nat >-> znat. Delimit Scope znat_scope with znat. Open Scope znat_scope. Variable addz : znat -> znat -> znat. Notation "z1 + z2" := (addz z1 z2) : znat_scope. (* Check that "3+3", where 3 is in nat and the coercion to znat is implicit, is printed the same way, and not "S 2 + S 2" as if numeral printing was only tested with coercion still present *) Check (3+3). (**********************************************************************) (* Check recursive notations *) Require Import List. Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..). Check [1;2;4]. Reserved Notation "( x ; y , .. , z )" (at level 0). Notation "( x ; y , .. , z )" := (pair .. (pair x y) .. z). Check (1;2,4). (* Check basic notations involving "match" *) Section C. Notation "'ifzero' n" := (match n with 0 => true | S _ => false end) (at level 0, n at level 0). Check (ifzero 3). Notation "'pred' n" := (match n with 0 => 0 | S n' => n' end) (at level 0, n at level 0). Check (pred 3). Check (fun n => match n with 0 => 0 | S n => n end). Check (fun n => match n with S p as x => p | y => 0 end). Notation "'ifn' x 'is' 'succ' n 'then' t 'else' u" := (match x with O => u | S n => t end) (at level 0, u at level 0). Check fun x => ifn x is succ n then n else 0. End C. (* Check correction of bug #1179 *) Notation "1 -" := true (at level 0). Check 1-. (* This is another aspect of bug #1179 (raises anomaly in 8.1) *) Require Import ZArith. Open Scope Z_scope. Notation "- 4" := (-2 + -2). Check -4. (**********************************************************************) (* Check ill-formed recursive notations *) (* Recursive variables not part of a recursive pattern *) Fail Notation "( x , y , .. , z )" := (pair x .. (pair y z) ..). (* No recursive notation *) Fail Notation "( x , y , .. , z )" := (pair x (pair y z)). (* Left-unbound variable *) Fail Notation "( x , y , .. , z )" := (pair x .. (pair y w) ..). (* Right-unbound variable *) Fail Notation "( x , y , .. , z )" := (pair y .. (pair z 0) ..). (* Not the right kind of recursive pattern *) Fail Notation "( x , y , .. , z )" := (ex (fun z => .. (ex (fun y => x)) ..)). Fail Notation "( x -- y , .. , z )" := (pair y .. (pair z 0) ..) (y closed binder, z closed binder). (* No separator allowed with open binders *) Fail Notation "( x -- y , .. , z )" := (ex (fun z => .. (ex (fun y => x)) ..)) (y binder, z binder). (* Ends of pattern do not match *) Fail Notation "( x , y , .. , z )" := (pair y .. (pair (plus z) 0) ..). Fail Notation "( x , y , .. , z )" := (pair y .. (plus z 0) ..). Fail Notation "( x1 , x2 , y , .. , z )" := (y y .. (x2 z 0) ..). Fail Notation "( x1 , x2 , y , .. , z )" := (x1 y .. (x2 z 0) ..). (* Ends of pattern are the same *) Fail Notation "( x , y , .. , z )" := (pair .. (pair (pair y z) x) .. x). (**********************************************************************) (* Check preservation of scopes at printing time *) Notation SUM := sum. Check SUM (nat*nat) nat. (**********************************************************************) (* Check preservation of implicit arguments at printing time *) Notation FST := fst. Check FST (0;1). (**********************************************************************) (* Check notations for references with activated or deactivated *) (* implicit arguments *) Notation Nil := @nil. Check Nil. Notation NIL := nil. Check NIL : list nat. (**********************************************************************) (* Test printing of notation with coercions in scope of a coercion *) Open Scope nat_scope. Coercion is_true := fun b => b=true. Coercion of_nat n := match n with 0 => true | _ => false end. Notation "'I' x" := (of_nat (S x) || true)%bool (at level 10). Check (false && I 3)%bool /\ I 6. (**********************************************************************) (* Check notations with several recursive patterns *) Open Scope Z_scope. Notation "[| x , y , .. , z ; a , b , .. , c |]" := (pair (pair .. (pair x y) .. z) (pair .. (pair a b) .. c)). Check [|1,2,3;4,5,6|]. Notation "[| t * ( x , y , .. , z ) ; ( a , b , .. , c ) * u |]" := (pair (pair .. (pair (pair t x) (pair t y)) .. (pair t z)) (pair .. (pair (pair a u) (pair b u)) .. (pair c u))) (t at level 39). Check [|0*(1,2,3);(4,5,6)*false|]. (**********************************************************************) (* Test recursive notations involving applications *) (* Caveat: does not work for applied constant because constants are *) (* classified as notations for the particular constant while this *) (* generic application notation is classified as generic *) Notation "{| f ; x ; .. ; y |}" := ( .. (f x) .. y). Check fun f => {| f; 0; 1; 2 |} : Z. (**********************************************************************) (* Check printing of notations from other modules *) (* 1- Non imported case *) Require make_notation. Check plus. Check S. Check mult. Check le. (* 2- Imported case *) Import make_notation. Check plus. Check S. Check mult. Check le. (* Check notations in cases patterns *) Notation SOME := Some. Notation NONE := None. Check (fun x => match x with SOME x => x | NONE => 0 end). Notation NONE2 := (@None _). Notation SOME2 := (@Some _). Check (fun x => match x with SOME2 x => x | NONE2 => 0 end). Notation NONE3 := @None. Notation SOME3 := @Some. Check (fun x => match x with SOME3 x => x | NONE3 => 0 end). (* Check correct matching of "Type" in notations. Of course the notation denotes a term that will be reinterpreted with a different universe than the actual one; but it would be the same anyway without a notation *) Notation s := Type. Check s. (* Test bug #2835: notations were not uniformly managed under prod and lambda *) Open Scope nat_scope. Notation "'foo' n" := (S n) (at level 50): nat_scope. Check (foo 9). Check (fun _ : nat => 9). (* Checking parsing and printing of numerical and non-numerical notations for eq_refl *) (* This notation was not correctly printed until Pierre B.'s improvements to the interpretation of patterns *) Notation "'ONE'" := eq_refl. Check fun (x:nat) (p : x=x) => match p with ONE => ONE end = p. (* This one used to failed at parsing until now *) Notation "1" := eq_refl. Check fun (x:nat) (p : x=x) => match p with 1 => 1 end = p. coq-8.4pl4/test-suite/output/rewrite-2172.v0000644000175000017500000000133612326224777017545 0ustar stephsteph(* This checks an error message as reported in bug #2172 *) Axiom axiom : forall (E F : nat), E = F. Lemma test : forall (E F : nat), E = F. Proof. intros. (* This used to raise the following non understandable error message: Error: Unable to find an instance for the variable x The reason this error was that rewrite generated the proof "eq_ind ?A ?x ?P ? ?y (axiom ?E ?F)" and the equation ?x=?E was solved in the way ?E:=?x leaving ?x unresolved. A stupid hack for solve this consisted in ordering meta=meta equations the other way round (with most recent evars instantiated first - since they are assumed to come first from the user in rewrite/induction/destruct calls). *) Fail rewrite <- axiom. coq-8.4pl4/test-suite/output/reduction.v0000644000175000017500000000042612326224777017466 0ustar stephsteph(* Test the behaviour of hnf and simpl introduced in revision *) Variable n:nat. Definition a:=0. Eval simpl in (fix plus (n m : nat) {struct n} : nat := match n with | 0 => m | S p => S (p + m) end) a a. Eval hnf in match (plus (S n) O) with S n => n | _ => O end. coq-8.4pl4/test-suite/output/Notations2.out0000644000175000017500000000235512326224777020077 0ustar stephsteph2 3 : PAIR 2[+]3 : nat forall (A : Set) (le : A -> A -> Prop) (x y : A), le x y \/ le y x : Prop match (0, 0, 0) with | (x, y, z) => x + y + z end : nat let '(a, _, _) := (2, 3, 4) in a : nat exists myx (y : bool), myx = y : Prop fun (P : nat -> nat -> Prop) (x : nat) => exists x0, P x x0 : (nat -> nat -> Prop) -> nat -> Prop ∃ n p : nat, n + p = 0 : Prop let a := 0 in ∃ x y : nat, let b := 1 in let c := b in let d := 2 in ∃ z : nat, let e := 3 in let f := 4 in x + y = z + d : Prop ∀ n p : nat, n + p = 0 : Prop Identifier 'Îŧ' now a keyword Îŧ n p : nat, n + p = 0 : nat -> nat -> Prop Îŧ (A : Type) (n p : A), n = p : ∀ A : Type, A -> A -> Prop Îŧ A : Type, ∃ n p : A, n = p : Type -> Prop Îŧ A : Type, ∀ n p : A, n = p : Type -> Prop Identifier 'let'' now a keyword let' f (x y : nat) (a:=0) (z : nat) (_ : bool) := x + y + z + 1 in f 0 1 2 : bool -> nat Îŧ (f : nat -> nat) (x : nat), f(x) + S(x) : (nat -> nat) -> nat -> nat Notation plus2 n := (S (S n)) Îŧ n : list(nat), match n with | nil => 2 | 0 :: _ => 2 | list1 => 0 | 1 :: _ :: _ => 2 | plus2 _ :: _ => 2 end : list(nat) -> nat # x : nat => x : nat -> nat # _ : nat => 2 : nat -> nat coq-8.4pl4/test-suite/output/Fixpoint.v0000644000175000017500000000203012326224777017263 0ustar stephstephRequire Import List. Check (fix F (A B : Set) (f : A -> B) (l : list A) {struct l} : list B := match l with | nil => nil | a :: l => f a :: F _ _ f l end). (* V8 printing of this term used to failed in V8.0 and V8.0pl1 (cf bug #860) *) Check let fix f (m : nat) : nat := match m with | O => 0 | S m' => f m' end in f 0. Require Import ZArith_base Omega. Open Scope Z_scope. Inductive even: Z -> Prop := | even_base: even 0 | even_succ: forall n, odd (n - 1) -> even n with odd: Z -> Prop := | odd_succ: forall n, even (n - 1) -> odd n. (* Check printing of fix *) Ltac f id1 id2 := fix id1 2 with (id2 n (H:odd n) {struct H} : n >= 1). Print Ltac f. (* Incidentally check use of fix in proofs *) Lemma even_pos_odd_pos: forall n, even n -> n >= 0. Proof. fix even_pos_odd_pos 2 with (odd_pos_even_pos n (H:odd n) {struct H} : n >= 1). intros. destruct H. omega. apply odd_pos_even_pos in H. omega. intros. destruct H. apply even_pos_odd_pos in H. omega. Qed. coq-8.4pl4/test-suite/output/Errors.v0000644000175000017500000000025612326224777016747 0ustar stephsteph(* Test error messages *) (* Test non-regression of bug fixed in r13486 (bad printer for module names) *) Module Type S. Parameter t:Type. End S. Module M : S. Fail End M. coq-8.4pl4/test-suite/output/Arguments.v0000644000175000017500000000254712326224777017445 0ustar stephstephArguments minus n m : simpl nomatch. About minus. Arguments minus n / m : simpl nomatch. About minus. Arguments minus !n / m : simpl nomatch. About minus. Arguments minus !n !m /. About minus. Arguments minus !n !m. About minus. Definition pf (D1 C1 : Type) (f : D1 -> C1) (D2 C2 : Type) (g : D2 -> C2) := fun x => (f (fst x), g (snd x)). Delimit Scope foo_scope with F. Arguments pf {D1%F C1%type} f [D2 C2] g x : simpl never. About pf. Definition fcomp A B C f (g : A -> B) (x : A) : C := f (g x). Arguments fcomp {_ _ _}%type_scope f g x /. About fcomp. Definition volatile := fun x : nat => x. Arguments volatile /. About volatile. Set Implicit Arguments. Section S1. Variable T1 : Type. Section S2. Variable T2 : Type. Fixpoint f (x : T1) (y : T2) n (v : unit) m {struct n} : nat := match n, m with | 0,_ => 0 | S _, 0 => n | S n', S m' => f x y n' v m' end. About f. Global Arguments f x y !n !v !m. About f. End S2. About f. End S1. About f. Arguments f : clear implicits and scopes. About f. Record r := { pi :> nat -> bool -> unit }. Notation "$" := 3 (only parsing) : foo_scope. Notation "$" := true (only parsing) : bar_scope. Delimit Scope bar_scope with B. Arguments pi _ _%F _%B. Check (forall w : r, pi w $ $ = tt). Fail Check (forall w : r, w $ $ = tt). Axiom w : r. Arguments w _%F _%B : extra scopes. Check (w $ $ = tt). Fail Arguments w _%F _%B. coq-8.4pl4/test-suite/output/RealSyntax.v0000644000175000017500000000006112326224777017557 0ustar stephstephRequire Import Reals. Check 32%R. Check (-31)%R. coq-8.4pl4/test-suite/output/Naming.out0000644000175000017500000000342712326224777017251 0ustar stephsteph1 subgoal x3 : nat ============================ forall x x1 x4 x0 : nat, (forall x2 x5 : nat, x2 + x1 = x4 + x5) -> x + x1 = x4 + x0 1 subgoal x3 : nat x : nat x1 : nat x4 : nat x0 : nat H : forall x5 x6 : nat, x5 + x1 = x4 + x6 ============================ x + x1 = x4 + x0 1 subgoal x3 : nat ============================ forall x x1 x4 x0 : nat, (forall x2 x5 : nat, x2 + x1 = x4 + x5 -> foo (S x2 + x1)) -> x + x1 = x4 + x0 -> foo (S x) 1 subgoal x3 : nat ============================ forall x x1 x4 x0 : nat, (forall x2 x5 : nat, x2 + x1 = x4 + x5 -> forall x6 x7 x8 S0 : nat, x6 + S0 = x7 + x8 + (S x2 + x1)) -> x + x1 = x4 + x0 -> forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x 1 subgoal x3 : nat x : nat x1 : nat x4 : nat x0 : nat ============================ (forall x2 x5 : nat, x2 + x1 = x4 + x5 -> forall x6 x7 x8 S0 : nat, x6 + S0 = x7 + x8 + (S x2 + x1)) -> x + x1 = x4 + x0 -> forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x 1 subgoal x3 : nat x : nat x1 : nat x4 : nat x0 : nat H : forall x5 x6 : nat, x5 + x1 = x4 + x6 -> forall x7 x8 x9 S : nat, x7 + S = x8 + x9 + (Datatypes.S x5 + x1) H0 : x + x1 = x4 + x0 ============================ forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x 1 subgoal x3 : nat x : nat x1 : nat x4 : nat x0 : nat H : forall x5 x6 : nat, x5 + x1 = x4 + x6 -> forall x7 x8 x9 S : nat, x7 + S = x8 + x9 + (Datatypes.S x5 + x1) H0 : x + x1 = x4 + x0 x5 : nat x6 : nat x7 : nat S : nat ============================ x5 + S = x6 + x7 + Datatypes.S x 1 subgoal x3 : nat a : nat H : a = 0 -> forall a0 : nat, a0 = 0 ============================ a = 0 coq-8.4pl4/test-suite/output/SearchRewrite.v0000644000175000017500000000016612326224777020242 0ustar stephsteph(* Some tests of the SearchRewrite command *) SearchRewrite (_+0). (* left *) SearchRewrite (0+_). (* right *) coq-8.4pl4/test-suite/output/Intuition.out0000644000175000017500000000013312326224777020011 0ustar stephsteph1 subgoal m : Z n : Z H : (m >= n)%Z ============================ (m >= m)%Z coq-8.4pl4/test-suite/output/Quote.out0000644000175000017500000000171412326224777017132 0ustar stephsteph(interp_f (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (f_atom End_idx)) (interp_f (Node_vm B (Empty_vm Prop) (Empty_vm Prop)) (f_and (f_const A) (f_and (f_or (f_atom End_idx) (f_const A)) (f_or (f_const A) (f_not (f_atom End_idx)))))) 1 subgoal H : interp_f (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (f_atom End_idx) \/ B ============================ interp_f (Node_vm B (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (Empty_vm Prop)) (f_and (f_atom (Left_idx End_idx)) (f_and (f_or (f_atom End_idx) (f_atom (Left_idx End_idx))) (f_or (f_atom (Left_idx End_idx)) (f_not (f_atom End_idx))))) 1 subgoal H : interp_f (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (f_atom End_idx) \/ B ============================ interp_f (Node_vm B (Empty_vm Prop) (Empty_vm Prop)) (f_and (f_const A) (f_and (f_or (f_atom End_idx) (f_const A)) (f_or (f_const A) (f_not (f_atom End_idx))))) coq-8.4pl4/test-suite/output/ZSyntax.out0000644000175000017500000000110212326224777017444 0ustar stephsteph32%Z : Z fun f : nat -> Z => (f 0%nat + 0)%Z : (nat -> Z) -> Z fun x : positive => Z.pos x~0 : positive -> Z fun x : positive => (Z.pos x + 1)%Z : positive -> Z fun x : positive => Z.pos x : positive -> Z fun x : positive => Z.neg x~0 : positive -> Z fun x : positive => (Z.pos x~0 + 0)%Z : positive -> Z fun x : positive => (- Z.pos x~0)%Z : positive -> Z fun x : positive => (- Z.pos x~0 + 0)%Z : positive -> Z (Z.of_nat 0 + 1)%Z : Z (0 + Z.of_nat (0 + 0))%Z : Z Z.of_nat 0 = 0%Z : Prop (0 + Z.of_nat 11)%Z : Z coq-8.4pl4/test-suite/output/PrintInfos.out0000644000175000017500000001027712326224777020134 0ustar stephstephexistT : forall (A : Type) (P : A -> Type) (x : A), P x -> sigT P Argument A is implicit Argument scopes are [type_scope _ _ _] Expands to: Constructor Coq.Init.Specif.existT Inductive sigT (A : Type) (P : A -> Type) : Type := existT : forall x : A, P x -> sigT P For sigT: Argument A is implicit For existT: Argument A is implicit For sigT: Argument scopes are [type_scope type_scope] For existT: Argument scopes are [type_scope _ _ _] existT : forall (A : Type) (P : A -> Type) (x : A), P x -> sigT P Argument A is implicit Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x For eq: Argument A is implicit and maximally inserted For eq_refl, when applied to no arguments: Arguments A, x are implicit and maximally inserted For eq_refl, when applied to 1 argument: Argument A is implicit For eq: Argument scopes are [type_scope _ _] For eq_refl: Argument scopes are [type_scope _] eq_refl : forall (A : Type) (x : A), x = x When applied to no arguments: Arguments A, x are implicit and maximally inserted When applied to 1 argument: Argument A is implicit Argument scopes are [type_scope _] Expands to: Constructor Coq.Init.Logic.eq_refl eq_refl : forall (A : Type) (x : A), x = x When applied to no arguments: Arguments A, x are implicit and maximally inserted When applied to 1 argument: Argument A is implicit plus = fix plus (n m : nat) {struct n} : nat := match n with | 0 => m | S p => S (plus p m) end : nat -> nat -> nat Argument scopes are [nat_scope nat_scope] plus : nat -> nat -> nat Argument scopes are [nat_scope nat_scope] plus is transparent Expands to: Constant Coq.Init.Peano.plus plus : nat -> nat -> nat plus_n_O : forall n : nat, n = n + 0 Argument scope is [nat_scope] plus_n_O is opaque Expands to: Constant Coq.Init.Peano.plus_n_O Warning: Implicit Arguments is deprecated; use Arguments instead Inductive le (n : nat) : nat -> Prop := le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m For le_S: Argument m is implicit For le_S: Argument n is implicit and maximally inserted For le: Argument scopes are [nat_scope nat_scope] For le_n: Argument scope is [nat_scope] For le_S: Argument scopes are [nat_scope nat_scope _] Inductive le (n : nat) : nat -> Prop := le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m For le_S: Argument m is implicit For le_S: Argument n is implicit and maximally inserted For le: Argument scopes are [nat_scope nat_scope] For le_n: Argument scope is [nat_scope] For le_S: Argument scopes are [nat_scope nat_scope _] comparison : Set Expands to: Inductive Coq.Init.Datatypes.comparison Inductive comparison : Set := Eq : comparison | Lt : comparison | Gt : comparison Warning: Implicit Arguments is deprecated; use Arguments instead bar : foo Expanded type for implicit arguments bar : forall x : nat, x = 0 Argument x is implicit and maximally inserted Expands to: Constant Top.bar *** [ bar : foo ] Expanded type for implicit arguments bar : forall x : nat, x = 0 Argument x is implicit and maximally inserted bar : foo Expanded type for implicit arguments bar : forall x : nat, x = 0 Argument x is implicit and maximally inserted Expands to: Constant Top.bar *** [ bar : foo ] Expanded type for implicit arguments bar : forall x : nat, x = 0 Argument x is implicit and maximally inserted Module Coq.Init.Peano Notation existS2 := existT2 Expands to: Notation Coq.Init.Specif.existS2 Warning: Implicit Arguments is deprecated; use Arguments instead Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x For eq: Argument A is implicit and maximally inserted For eq_refl, when applied to no arguments: Arguments A, x are implicit and maximally inserted For eq_refl, when applied to 1 argument: Argument A is implicit and maximally inserted For eq: Argument scopes are [type_scope _ _] For eq_refl: Argument scopes are [type_scope _] Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x For eq: Argument A is implicit and maximally inserted For eq_refl, when applied to no arguments: Arguments A, x are implicit and maximally inserted For eq_refl, when applied to 1 argument: Argument A is implicit and maximally inserted For eq: Argument scopes are [type_scope _ _] For eq_refl: Argument scopes are [type_scope _] coq-8.4pl4/test-suite/output/Tactics.out0000644000175000017500000000020012326224777017414 0ustar stephstephLtac f H := split; [ a H | e H ] Ltac g := match goal with | |- context [if ?X then _ else _] => case X end coq-8.4pl4/test-suite/output/Extraction_matchs_2413.out0000644000175000017500000000204212326224777022160 0ustar stephsteph(** val test1 : bool -> bool **) let test1 b = b (** val test2 : bool -> bool **) let test2 b = False (** val wrong_id : 'a1 hole -> 'a2 hole **) let wrong_id = function | Hole -> Hole | Hole2 -> Hole2 (** val test3 : 'a1 option -> 'a1 option **) let test3 o = o (** val test4 : indu -> indu **) let test4 = function | A m -> A (S m) | x -> x (** val test5 : indu -> indu **) let test5 = function | A m -> A (S m) | _ -> B (** val test6 : indu' -> indu' **) let test6 = function | A' m -> A' (S m) | E' -> B' | F' -> B' | _ -> C' (** val test7 : indu -> nat option **) let test7 = function | A m -> Some m | _ -> None (** val decode_cond_mode : (word -> opcode option) -> (word -> 'a1 decoder_result) -> word -> ('a1 -> opcode -> 'a2) -> 'a2 decoder_result **) let decode_cond_mode condition f w g = match condition w with | Some oc -> (match f w with | DecUndefined -> DecUndefined | DecUnpredictable -> DecUnpredictable | DecInst i -> DecInst (g i oc) | DecError m -> DecError m) | None -> DecUndefined coq-8.4pl4/test-suite/output/Coercions.out0000644000175000017500000000015412326224777017756 0ustar stephstephP x : Prop R x x : Prop fun (x : foo) (n : nat) => x n : foo -> nat -> nat "1" 0 : PAIR coq-8.4pl4/test-suite/output/ArgumentsScope.v0000644000175000017500000000102712326224777020427 0ustar stephsteph(* A few tests to check Global Argument Scope command *) Section A. Variable a : bool -> bool. Definition negb' := negb. Section B. Variable b : bool -> bool. Definition negb'' := negb. About a. About b. About negb''. About negb'. About negb. Global Arguments Scope negb'' [ _ ]. Global Arguments Scope negb' [ _ ]. Global Arguments Scope negb [ _ ]. Global Arguments Scope a [ _ ]. Global Arguments Scope b [ _ ]. About a. About b. About negb. About negb'. About negb''. End B. About a. End A. About negb. About negb'. About negb''. coq-8.4pl4/test-suite/output/InitSyntax.out0000644000175000017500000000060512326224777020145 0ustar stephstephInductive sig2 (A : Type) (P Q : A -> Prop) : Type := exist2 : forall x : A, P x -> Q x -> {x | P x & Q x} For sig2: Argument A is implicit For exist2: Argument A is implicit For sig2: Argument scopes are [type_scope type_scope type_scope] For exist2: Argument scopes are [type_scope _ _ _ _ _] exists x : nat, x = x : Prop fun b : bool => if b then b else b : bool -> bool coq-8.4pl4/test-suite/output/Arguments.out0000644000175000017500000000640312326224777020002 0ustar stephstephminus : nat -> nat -> nat Argument scopes are [nat_scope nat_scope] The simpl tactic unfolds minus avoiding to expose match constructs minus is transparent Expands to: Constant Coq.Init.Peano.minus minus : nat -> nat -> nat Argument scopes are [nat_scope nat_scope] The simpl tactic unfolds minus when applied to 1 argument avoiding to expose match constructs minus is transparent Expands to: Constant Coq.Init.Peano.minus minus : nat -> nat -> nat Argument scopes are [nat_scope nat_scope] The simpl tactic unfolds minus when the 1st argument evaluates to a constructor and when applied to 1 argument avoiding to expose match constructs minus is transparent Expands to: Constant Coq.Init.Peano.minus minus : nat -> nat -> nat Argument scopes are [nat_scope nat_scope] The simpl tactic unfolds minus when the 1st and 2nd arguments evaluate to a constructor and when applied to 2 arguments minus is transparent Expands to: Constant Coq.Init.Peano.minus minus : nat -> nat -> nat Argument scopes are [nat_scope nat_scope] The simpl tactic unfolds minus when the 1st and 2nd arguments evaluate to a constructor minus is transparent Expands to: Constant Coq.Init.Peano.minus pf : forall D1 C1 : Type, (D1 -> C1) -> forall D2 C2 : Type, (D2 -> C2) -> D1 * D2 -> C1 * C2 Arguments D2, C2 are implicit Arguments D1, C1 are implicit and maximally inserted Argument scopes are [foo_scope type_scope _ _ _ _ _] The simpl tactic never unfolds pf pf is transparent Expands to: Constant Top.pf fcomp : forall A B C : Type, (B -> C) -> (A -> B) -> A -> C Arguments A, B, C are implicit and maximally inserted Argument scopes are [type_scope type_scope type_scope _ _ _] The simpl tactic unfolds fcomp when applied to 6 arguments fcomp is transparent Expands to: Constant Top.fcomp volatile : nat -> nat Argument scope is [nat_scope] The simpl tactic always unfolds volatile volatile is transparent Expands to: Constant Top.volatile f : T1 -> T2 -> nat -> unit -> nat -> nat Argument scopes are [_ _ nat_scope _ nat_scope] f is transparent Expands to: Constant Top.S1.S2.f f : T1 -> T2 -> nat -> unit -> nat -> nat Argument scopes are [_ _ nat_scope _ nat_scope] The simpl tactic unfolds f when the 3rd, 4th and 5th arguments evaluate to a constructor f is transparent Expands to: Constant Top.S1.S2.f f : forall T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat Argument T2 is implicit Argument scopes are [type_scope _ _ nat_scope _ nat_scope] The simpl tactic unfolds f when the 4th, 5th and 6th arguments evaluate to a constructor f is transparent Expands to: Constant Top.S1.f f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat Arguments T1, T2 are implicit Argument scopes are [type_scope type_scope _ _ nat_scope _ nat_scope] The simpl tactic unfolds f when the 5th, 6th and 7th arguments evaluate to a constructor f is transparent Expands to: Constant Top.f f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat The simpl tactic unfolds f when the 5th, 6th and 7th arguments evaluate to a constructor f is transparent Expands to: Constant Top.f forall w : r, w 3 true = tt : Prop The command has indeed failed with message: => Error: Unknown interpretation for notation "$". w 3 true = tt : Prop The command has indeed failed with message: => Error: Extra argument _. coq-8.4pl4/test-suite/output/Sum.v0000644000175000017500000000013512326224777016233 0ustar stephstephCheck (nat + nat + {True}). Check ({True} + {True} + {True}). Check (nat + {True} + {True}). coq-8.4pl4/test-suite/output/PrintInfos.v0000644000175000017500000000124112326224777017561 0ustar stephstephAbout existT. Print existT. Print Implicit existT. Print eq_refl. About eq_refl. Print Implicit eq_refl. Print plus. About plus. Print Implicit plus. About plus_n_O. Implicit Arguments le_S [[n] m]. Print le_S. Arguments le_S {n} [m] _. (* Test new syntax *) Print le_S. About comparison. Print comparison. Definition foo := forall x, x = 0. Parameter bar : foo. Implicit Arguments bar [x]. About bar. Print bar. Arguments bar [x]. (* Test new syntax *) About bar. Print bar. About Peano. (* Module *) About existS2. (* Notation *) Implicit Arguments eq_refl [[A] [x]] [[A]]. Print eq_refl. Arguments eq_refl {A} {x}, {A} x. (* Test new syntax *) Print eq_refl. coq-8.4pl4/test-suite/output/InitSyntax.v0000644000175000017500000000015712326224777017605 0ustar stephsteph(* Soumis par Pierre *) Print sig2. Check (exists x : nat, x = x). Check (fun b : bool => if b then b else b). coq-8.4pl4/test-suite/output/Cases.v0000644000175000017500000000150712326224777016531 0ustar stephsteph(* Cases with let-in in constructors types *) Inductive t : Set := k : let x := t in x -> x. Print t_rect. (* Do not contract nested patterns with dependent return type *) (* see bug #1699 *) Require Import Arith. Definition proj (x y:nat) (P:nat -> Type) (def:P x) (prf:P y) : P y := match eq_nat_dec x y return P y with | left eqprf => match eqprf in (_ = z) return (P z) with | refl_equal => def end | _ => prf end. Print proj. (* Use notations even below aliases *) Require Import List. Fixpoint foo (A:Type) (l:list A) : option A := match l with | nil => None | x0 :: nil => Some x0 | x0 :: (x1 :: xs) as l0 => foo A l0 end. Print foo. (* Do not duplicate the matched term *) Axiom A : nat -> bool. Definition foo' := match A 0 with | true => true | x => x end. Print foo'. coq-8.4pl4/test-suite/output/Naming.v0000644000175000017500000000364512326224777016711 0ustar stephsteph(* This file checks the compatibility of naming strategy *) (* This does not mean that the given naming strategy is good *) Parameter x2:nat. Definition foo y := forall x x3 x4 S, x + S = x3 + x4 + y. Section A. Variable x3:nat. Goal forall x x1 x2 x3:nat, (forall x x3:nat, x+x1 = x2+x3) -> x+x1 = x2+x3. Show. intros. Show. (* Remark: in V8.2, this used to be printed x3 : nat ============================ forall x x1 x4 x5 : nat, (forall x0 x6 : nat, x0 + x1 = x4 + x6) -> x + x1 = x4 + x5 before intro and x3 : nat x : nat x1 : nat x4 : nat x0 : nat H : forall x x3 : nat, x + x1 = x4 + x3 ============================ x + x1 = x4 + x0 after. From V8.3, the quantified hypotheses are printed the sames as they would be intro. However the hypothesis H remains printed differently to avoid using the same name in autonomous but nested subterms *) Abort. Goal forall x x1 x2 x3:nat, (forall x x3:nat, x+x1 = x2+x3 -> foo (S x + x1)) -> x+x1 = x2+x3 -> foo (S x). Show. unfold foo. Show. do 4 intro. (* --> x, x1, x4, x0, ... *) Show. do 2 intro. Show. do 4 intro. Show. (* Remark: in V8.2, this used to be printed x3 : nat ============================ forall x x1 x4 x5 : nat, (forall x0 x6 : nat, x0 + x1 = x4 + x6 -> forall x7 x8 x9 S0 : nat, x7 + S0 = x8 + x9 + (S x0 + x1)) -> x + x1 = x4 + x5 -> forall x0 x6 x7 S0 : nat, x0 + S0 = x6 + x7 + S x before the intros and x3 : nat x : nat x1 : nat x4 : nat x0 : nat H : forall x x3 : nat, x + x1 = x4 + x3 -> forall x0 x4 x5 S0 : nat, x0 + S0 = x4 + x5 + (S x + x1) H0 : x + x1 = x4 + x0 x5 : nat x6 : nat x7 : nat S : nat ============================ x5 + S = x6 + x7 + Datatypes.S x after (note the x5/x0 and the S0/S) *) Abort. (* Check naming in hypotheses *) Goal forall a, (a = 0 -> forall a, a = 0) -> a = 0. intros. Show. apply H with (a:=a). (* test compliance with printing *) Abort. coq-8.4pl4/test-suite/output/PrintAssumptions.v0000644000175000017500000000456612326224777021045 0ustar stephsteph (** Print Assumption and opaque modules : Print Assumption used to consider as axioms the modular fields unexported by their signature, cf bug report #2186. This should now be fixed, let's test this here. *) (* First, a minimal test-case *) Axiom foo : nat. Module Type T. Parameter bar : nat. End T. Module M : T. Module Hide. (* An entire sub-module could be hidden *) Definition x := foo. End Hide. Definition bar := Hide.x. End M. Module N (X:T) : T. Definition y := X.bar. (* A non-exported field *) Definition bar := y. End N. Module P := N M. Print Assumptions M.bar. (* Should answer: foo *) Print Assumptions P.bar. (* Should answer: foo *) (* The original test-case of the bug-report *) Require Import Arith. Axiom extensionality : forall P Q (f g:P -> Q), (forall x, f x = g x) -> f = g. Module Type ADD_COMM_EXT. Axiom add_comm_ext : forall n, (fun x => x + n) = (fun x => n + x). End ADD_COMM_EXT. Module AddCommExt_Opaque : ADD_COMM_EXT. Lemma add_comm_ext : forall n, (fun x => x + n) = (fun x => n + x). Proof. intro n; apply extensionality; auto with arith. Qed. End AddCommExt_Opaque. Module AddCommExt_Transparent <: ADD_COMM_EXT. Lemma add_comm_ext : forall n, (fun x => x + n) = (fun x => n + x). Proof. intro n; apply extensionality; auto with arith. Qed. End AddCommExt_Transparent. Print Assumptions AddCommExt_Opaque.add_comm_ext. (* Should answer: extensionality *) Print Assumptions AddCommExt_Transparent.add_comm_ext. (* Should answer: extensionality *) Lemma add1_comm_ext_opaque : (fun x => x + 1) = (fun x => 1 + x). Proof (AddCommExt_Opaque.add_comm_ext 1). Lemma add1_comm_ext_transparent : (fun x => x + 1) = (fun x => 1 + x). Proof (AddCommExt_Transparent.add_comm_ext 1). Print Assumptions add1_comm_ext_opaque. (* Should answer: extensionality *) Print Assumptions add1_comm_ext_transparent. (* Should answer: extensionality *) Module Type FALSE_POSITIVE. Axiom add_comm : forall n x, x + n = n + x. End FALSE_POSITIVE. Module false_positive : FALSE_POSITIVE. Lemma add_comm : forall n x, x + n = n + x. Proof. auto with arith. Qed. Print Assumptions add_comm. (* Should answer : Closed under the global context *) End false_positive. Lemma comm_plus5 : forall x, x + 5 = 5 + x. Proof (false_positive.add_comm 5). Print Assumptions comm_plus5. (* Should answer : Closed under the global context *) coq-8.4pl4/test-suite/output/Implicit.v0000644000175000017500000000236312326224777017246 0ustar stephstephSet Implicit Arguments. Unset Strict Implicit. (* Suggested by Pierre Casteran (bug #169) *) (* Argument 3 is needed to typecheck and should be printed *) Definition compose (A B C : Set) (f : A -> B) (g : B -> C) (x : A) := g (f x). Check (compose (C:=nat) S). (* Better to explicitly display the arguments inferable from a position that could disappear after reduction *) Inductive ex (A : Set) (P : A -> Prop) : Prop := ex_intro : forall x : A, P x -> ex P. Check (ex_intro (P:=fun _ => True) (x:=0) I). (* Test for V8 printing of implicit by names *) Definition d1 y x (h : x = y :>nat) := h. Definition d2 x := d1 (y:=x). Print d2. Set Strict Implicit. Unset Implicit Arguments. (* Check maximal insertion of implicit *) Require Import List. Open Scope list_scope. Set Implicit Arguments. Set Maximal Implicit Insertion. Definition id (A:Type) (x:A) := x. Check map id (1::nil). Definition id' (A:Type) (x:A) := x. Arguments id' {A} x. Check map id' (1::nil). Unset Maximal Implicit Insertion. Unset Implicit Arguments. (* Check explicit insertion of last non-maximal trailing implicit to ensure *) (* correct arity of partiol applications *) Set Implicit Arguments. Definition id'' (A:Type) (x:A) := x. Check map (@id'' nat) (1::nil). coq-8.4pl4/test-suite/output/Arguments_renaming.out0000644000175000017500000001007412326224777021661 0ustar stephstephThe command has indeed failed with message: => Error: To rename arguments the "rename" flag must be specified. Argument A renamed to B. The command has indeed failed with message: => Error: To rename arguments the "rename" flag must be specified. Argument A renamed to T. @eq_refl : forall (B : Type) (y : B), y = y eq_refl : forall x : nat, x = x Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x For eq_refl: Arguments are renamed to B, y For eq: Argument A is implicit and maximally inserted For eq_refl, when applied to no arguments: Arguments B, y are implicit and maximally inserted For eq_refl, when applied to 1 argument: Argument B is implicit For eq: Argument scopes are [type_scope _ _] For eq_refl: Argument scopes are [type_scope _] eq_refl : forall (A : Type) (x : A), x = x Arguments are renamed to B, y When applied to no arguments: Arguments B, y are implicit and maximally inserted When applied to 1 argument: Argument B is implicit Argument scopes are [type_scope _] Expands to: Constructor Coq.Init.Logic.eq_refl Inductive myEq (B : Type) (x : A) : A -> Prop := myrefl : B -> myEq B x x For myrefl: Arguments are renamed to C, x, _ For myrefl: Argument C is implicit and maximally inserted For myEq: Argument scopes are [type_scope _ _] For myrefl: Argument scopes are [type_scope _ _] myrefl : forall (B : Type) (x : A), B -> myEq B x x Arguments are renamed to C, x, _ Argument C is implicit and maximally inserted Argument scopes are [type_scope _ _] Expands to: Constructor Top.Test1.myrefl myplus = fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := match n with | 0 => m | S n' => S (myplus T t n' m) end : forall T : Type, T -> nat -> nat -> nat Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] myplus : forall T : Type, T -> nat -> nat -> nat Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] The simpl tactic unfolds myplus when the 2nd and 3rd arguments evaluate to a constructor myplus is transparent Expands to: Constant Top.Test1.myplus myplus : forall Z : Type, Z -> nat -> nat -> nat Inductive myEq (A B : Type) (x : A) : A -> Prop := myrefl : B -> myEq A B x x For myrefl: Arguments are renamed to A, C, x, _ For myrefl: Argument C is implicit and maximally inserted For myEq: Argument scopes are [type_scope type_scope _ _] For myrefl: Argument scopes are [type_scope type_scope _ _] myrefl : forall (A B : Type) (x : A), B -> myEq A B x x Arguments are renamed to A, C, x, _ Argument C is implicit and maximally inserted Argument scopes are [type_scope type_scope _ _] Expands to: Constructor Top.myrefl myrefl : forall (A C : Type) (x : A), C -> myEq A C x x myplus = fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := match n with | 0 => m | S n' => S (myplus T t n' m) end : forall T : Type, T -> nat -> nat -> nat Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] myplus : forall T : Type, T -> nat -> nat -> nat Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] The simpl tactic unfolds myplus when the 2nd and 3rd arguments evaluate to a constructor myplus is transparent Expands to: Constant Top.myplus myplus : forall Z : Type, Z -> nat -> nat -> nat The command has indeed failed with message: => Error: All arguments lists must declare the same names. The command has indeed failed with message: => Error: The following arguments are not declared: x. The command has indeed failed with message: => Error: Arguments names must be distinct. The command has indeed failed with message: => Error: Argument z cannot be declared implicit. The command has indeed failed with message: => Error: Extra argument y. The command has indeed failed with message: => Error: To rename arguments the "rename" flag must be specified. Argument A renamed to R. coq-8.4pl4/test-suite/output/Errors.out0000644000175000017500000000012712326224777017306 0ustar stephstephThe command has indeed failed with message: => Error: The field t is missing in Top.M. coq-8.4pl4/test-suite/output/Arguments_renaming.v0000644000175000017500000000177212326224777021324 0ustar stephstephFail Arguments eq_refl {B y}, [B] y. Fail Arguments identity T _ _. Arguments eq_refl A x. Arguments eq_refl {B y}, [B] y : rename. Check @eq_refl. Check (eq_refl (B := nat)). Print eq_refl. About eq_refl. Goal 3 = 3. apply @eq_refl with (B := nat). Undo. apply @eq_refl with (y := 3). Undo. pose (y := nat). apply (@eq_refl y) with (y0 := 3). Qed. Section Test1. Variable A : Type. Inductive myEq B (x : A) : A -> Prop := myrefl : B -> myEq B x x. Global Arguments myrefl {C} x _ : rename. Print myrefl. About myrefl. Fixpoint myplus T (t : T) (n m : nat) {struct n} := match n with O => m | S n' => S (myplus T t n' m) end. Global Arguments myplus {Z} !t !n m : rename. Print myplus. About myplus. Check @myplus. End Test1. Print myrefl. About myrefl. Check myrefl. Print myplus. About myplus. Check @myplus. Fail Arguments eq_refl {F g}, [H] k. Fail Arguments eq_refl {F}, [F]. Fail Arguments eq_refl {F F}, [F] F. Fail Arguments eq {F} x [z]. Fail Arguments eq {F} x z y. Fail Arguments eq {R} s t. coq-8.4pl4/test-suite/output/SearchRewrite.out0000644000175000017500000000011012326224777020571 0ustar stephstephplus_n_O: forall n : nat, n = n + 0 plus_O_n: forall n : nat, 0 + n = n coq-8.4pl4/test-suite/output/Existentials.out0000644000175000017500000000027112326224777020506 0ustar stephstephExistential 1 = ?10 : [q : nat n : nat m : nat |- n = ?9] Existential 2 = ?9 : [n : nat m : nat |- nat] Existential 3 = ?7 : [p : nat q := S p : nat n : nat m : nat |- ?9 = m] coq-8.4pl4/test-suite/output/Search.out0000644000175000017500000000160012326224777017234 0ustar stephstephle_S: forall n m : nat, n <= m -> n <= S m le_n: forall n : nat, n <= n le_pred: forall n m : nat, n <= m -> pred n <= pred m le_S_n: forall n m : nat, S n <= S m -> n <= m false: bool true: bool xorb: bool -> bool -> bool orb: bool -> bool -> bool negb: bool -> bool implb: bool -> bool -> bool andb: bool -> bool -> bool pred_Sn: forall n : nat, n = pred (S n) plus_n_Sm: forall n m : nat, S (n + m) = n + S m plus_n_O: forall n : nat, n = n + 0 plus_Sn_m: forall n m : nat, S n + m = S (n + m) plus_O_n: forall n : nat, 0 + n = n mult_n_Sm: forall n m : nat, n * m + n = n * S m mult_n_O: forall n : nat, 0 = n * 0 min_r: forall n m : nat, m <= n -> min n m = m min_l: forall n m : nat, n <= m -> min n m = n max_r: forall n m : nat, n <= m -> max n m = m max_l: forall n m : nat, m <= n -> max n m = n eq_add_S: forall n m : nat, S n = S m -> n = m eq_S: forall x y : nat, x = y -> S x = S y coq-8.4pl4/test-suite/output/Notations2.v0000644000175000017500000000613312326224777017533 0ustar stephsteph(**********************************************************************) (* Test call to primitive printers in presence of coercion to *) (* functions (cf bug #2044) *) Inductive PAIR := P (n1:nat) (n2:nat). Coercion P : nat >-> Funclass. Check (2 3). (* Check that notations with coercions to functions inserted still work *) (* (were not working from revision 11886 to 12951) *) Record Binop := { binop :> nat -> nat -> nat }. Class Plusop := { plusop : Binop; zero : nat }. Infix "[+]" := plusop (at level 40). Instance Plus : Plusop := {| plusop := {| binop := plus |} ; zero := 0 |}. Check 2[+]3. (* Test bug #2091 (variable le was printed using <= !) *) Check forall (A: Set) (le: A -> A -> Prop) (x y: A), le x y \/ le y x. (* Test recursive notations in cases pattern *) Remove Printing Let prod. Check match (0,0,0) with (x,y,z) => x+y+z end. Check let '(a,b,c) := ((2,3),4) in a. (* Check printing of notations with mixed reserved binders (see bug #2571) *) Implicit Type myx : bool. Check exists myx y, myx = y. (* Test notation for anonymous functions up to eta-expansion *) Check fun P:nat->nat->Prop => fun x:nat => ex (P x). (* Test notations with binders *) Notation "∃ x .. y , P":= (ex (fun x => .. (ex (fun y => P)) ..)) (x binder, y binder, at level 200, right associativity). Check (∃ n p, n+p=0). Check ∃ (a:=0) (x:nat) y (b:=1) (c:=b) (d:=2) z (e:=3) (f:=4), x+y = z+d. Notation "∀ x .. y , P":= (forall x, .. (forall y, P) ..) (x binder, at level 200, right associativity). Check (∀ n p, n+p=0). Notation "'Îŧ' x .. y , P":= (fun x => .. (fun y => P) ..) (y binder, at level 200, right associativity). Check (Îŧ n p, n+p=0). Generalizable Variable A. Check `(Îŧ n p : A, n=p). Check `(∃ n p : A, n=p). Check `(∀ n p : A, n=p). Notation "'let'' f x .. y := t 'in' u":= (let f := fun x => .. (fun y => t) .. in u) (f ident, x closed binder, y closed binder, at level 200, right associativity). Check let' f x y (a:=0) z (b:bool) := x+y+z+1 in f 0 1 2. (* In practice, only the printing rule is used here *) (* Note: does not work for pattern *) Notation "f ( x )" := (f x) (at level 10, format "f ( x )"). Check fun f x => f x + S x. Open Scope list_scope. Notation list1 := (1::nil)%list. Notation plus2 n := (S (S n)). (* plus2 was not correctly printed in the two following tests in 8.3pl1 *) Print plus2. Check fun n => match n with list1 => 0 | _ => 2 end. (* This one is not fully satisfactory because binders in the same type are re-factorized and parentheses are needed even for atomic binder Notation "'mylet' f [ x ; .. ; y ] := t 'in' u":= (let f := fun x => .. (fun y => t) .. in u) (f ident, x closed binder, y closed binder, at level 200, right associativity). Check mylet f [x;y;z;(a:bool)] := x+y+z+1 in f 0 1 2. *) (* Check notations for functional terms which do not necessarily depend on their parameter *) (* Old request mentioned again on coq-club 20/1/2012 *) Notation "# x : T => t" := (fun x : T => t) (at level 0, t at level 200, x ident). Check # x : nat => x. Check # _ : nat => 2. coq-8.4pl4/test-suite/output/NumbersSyntax.out0000644000175000017500000000166612326224777020665 0ustar stephstephI31 : digits31 int31 2 : int31 660865024 : int31 2 + 2 : int31 2 + 2 : int31 = 4 : int31 = 710436486 : int31 2 : BigN.t' 1000000000000000000 : BigN.t' 2 + 2 : bigN 2 + 2 : bigN = 4 : bigN = 37151199385380486 : bigN = 1267650600228229401496703205376 : bigN 2 : BigZ.t_ -1000000000000000000 : BigZ.t_ 2 + 2 : BigZ.t_ 2 + 2 : BigZ.t_ = 4 : BigZ.t_ = 37151199385380486 : BigZ.t_ = 1267650600228229401496703205376 : BigZ.t_ 2 : BigQ.t_ -1000000000000000000 : BigQ.t_ 2 + 2 : bigQ 2 + 2 : bigQ = 4 : bigQ = 37151199385380486 : bigQ 6562 # 456 : BigQ.t_ = 3281 # 228 : bigQ = -1 # 10000 : bigQ = 100 : bigQ = 515377520732011331036461129765621272702107522001 # 1267650600228229401496703205376 : bigQ = 1 : bigQ coq-8.4pl4/test-suite/output/simpl.out0000644000175000017500000000031112326224777017151 0ustar stephsteph1 subgoal x : nat ============================ x = S x 1 subgoal x : nat ============================ 0 + x = S x 1 subgoal x : nat ============================ x = 1 + x coq-8.4pl4/test-suite/output/Search.v0000644000175000017500000000021712326224777016675 0ustar stephsteph(* Some tests of the Search command *) Search le. (* app nodes *) Search bool. (* no apps *) Search (@eq nat). (* complex pattern *) coq-8.4pl4/test-suite/output/Cases.out0000644000175000017500000000162412326224777017073 0ustar stephstepht_rect = fun (P : t -> Type) (f : let x := t in forall x0 : x, P x0 -> P (k x0)) => fix F (t : t) : P t := match t as t0 return (P t0) with | k _ x0 => f x0 (F x0) end : forall P : t -> Type, (let x := t in forall x0 : x, P x0 -> P (k x0)) -> forall t : t, P t proj = fun (x y : nat) (P : nat -> Type) (def : P x) (prf : P y) => match eq_nat_dec x y with | left eqprf => match eqprf in (_ = z) return (P z) with | eq_refl => def end | right _ => prf end : forall (x y : nat) (P : nat -> Type), P x -> P y -> P y Argument scopes are [nat_scope nat_scope _ _ _] foo = fix foo (A : Type) (l : list A) {struct l} : option A := match l with | nil => None | x0 :: nil => Some x0 | x0 :: (_ :: _) as l0 => foo A l0 end : forall A : Type, list A -> option A Argument scopes are [type_scope list_scope] foo' = if A 0 then true else false : bool coq-8.4pl4/test-suite/output/reduction.out0000644000175000017500000000005412326224777020025 0ustar stephsteph = a : nat = n + 0 : nat coq-8.4pl4/test-suite/output/Match_subterm.out0000644000175000017500000000003112326224777020621 0ustar stephsteph(0 = 1) eq nat 0 1 S 0 2 coq-8.4pl4/test-suite/output/TranspModtype.out0000644000175000017500000000013112326224777020636 0ustar stephstephTrM.A = M.A : Set OpM.A = M.A : Set TrM.B = M.B : Set *** [ OpM.B : Set ] coq-8.4pl4/test-suite/output/inference.v0000644000175000017500000000133612326224777017431 0ustar stephsteph(* Check that types are not uselessly unfolded *) (* Check here that P returns something of type "option L" and not "option (list nat)" *) Definition L := list nat. Definition P (e:option L) := match e with | None => None | Some cl => Some cl end. Print P. (* Check that the heuristic to solve constraints is not artificially dependent on the presence of a let-in, and in particular that the second [_] below is not inferred to be n, as if obtained by first-order unification with [T n] of the conclusion [T _] of the type of the first [_]. *) (* Note: exact numbers of evars are not important... *) Inductive T (n:nat) : Type := A : T n. Check fun n (x:=A n:T n) => _ _ : T n. Check fun n => _ _ : T n. coq-8.4pl4/test-suite/output/Nametab.out0000644000175000017500000000213212326224777017377 0ustar stephstephConstant Top.Q.N.K.foo (shorter name to refer to it in current context is Q.N.K.foo) Constant Top.Q.N.K.foo (shorter name to refer to it in current context is Q.N.K.foo) Constant Top.Q.N.K.foo (shorter name to refer to it in current context is Q.N.K.foo) Constant Top.Q.N.K.foo Constant Top.Q.N.K.foo (shorter name to refer to it in current context is Q.N.K.foo) No module is referred to by basename K No module is referred to by name N.K Module Top.Q.N.K Module Top.Q.N.K No module is referred to by basename N Module Top.Q.N Module Top.Q.N Module Top.Q Module Top.Q Constant Top.Q.N.K.foo (shorter name to refer to it in current context is K.foo) Constant Top.Q.N.K.foo Constant Top.Q.N.K.foo (shorter name to refer to it in current context is K.foo) Constant Top.Q.N.K.foo (shorter name to refer to it in current context is K.foo) Constant Top.Q.N.K.foo (shorter name to refer to it in current context is K.foo) Module Top.Q.N.K No module is referred to by name N.K Module Top.Q.N.K Module Top.Q.N.K No module is referred to by basename N Module Top.Q.N Module Top.Q.N Module Top.Q Module Top.Q coq-8.4pl4/test-suite/output/Intuition.v0000644000175000017500000000017112326224777017451 0ustar stephstephRequire Import ZArith_base. Goal forall m n : Z, (m >= n)%Z -> (m >= m)%Z /\ (m >= n)%Z. intros; intuition. Show. Abort. coq-8.4pl4/test-suite/output/SearchPattern.v0000644000175000017500000000063012326224777020232 0ustar stephsteph(* Some tests of the SearchPattern command *) (* Simple, random tests *) SearchPattern bool. SearchPattern nat. SearchPattern le. (* With some hypothesis *) SearchPattern (nat -> nat). SearchPattern (?n * ?m + ?n = ?n * S ?m). (* Non-linearity *) SearchPattern (_ ?X ?X). (* Non-linearity with hypothesis *) SearchPattern (forall (x:?A) (y:?B), _ ?A ?B). (* No delta-reduction *) SearchPattern (Exc _). coq-8.4pl4/test-suite/output/Record.v0000644000175000017500000000060112326224777016703 0ustar stephstephRecord test := build { field : nat }. Record test_r := build_r { field_r : nat }. Record test_c := build_c { field_c : nat }. Add Printing Constructor test_c. Add Printing Record test_r. Set Printing Records. Check build 5. Check {| field := 5 |}. Check build_r 5. Check build_c 5. Unset Printing Records. Check build 5. Check {| field := 5 |}. Check build_r 5. Check build_c 5. coq-8.4pl4/test-suite/output/Extraction_matchs_2413.v0000644000175000017500000000525412326224777021626 0ustar stephsteph(** Extraction : tests of optimizations of pattern matching *) (** First, a few basic tests *) Definition test1 b := match b with | true => true | false => false end. Extraction test1. (** should be seen as the identity *) Definition test2 b := match b with | true => false | false => false end. Extraction test2. (** should be seen a the always-false constant function *) Inductive hole (A:Set) : Set := Hole | Hole2. Definition wrong_id (A B : Set) (x:hole A) : hole B := match x with | Hole => @Hole _ | Hole2 => @Hole2 _ end. Extraction wrong_id. (** should _not_ be optimized as an identity *) Definition test3 (A:Type)(o : option A) := match o with | Some x => Some x | None => None end. Extraction test3. (** Even with type parameters, should be seen as identity *) Inductive indu : Type := A : nat -> indu | B | C. Definition test4 n := match n with | A m => A (S m) | B => B | C => C end. Extraction test4. (** should merge branchs B C into a x->x *) Definition test5 n := match n with | A m => A (S m) | B => B | C => B end. Extraction test5. (** should merge branches B C into _->B *) Inductive indu' : Type := A' : nat -> indu' | B' | C' | D' | E' | F'. Definition test6 n := match n with | A' m => A' (S m) | B' => C' | C' => C' | D' => C' | E' => B' | F' => B' end. Extraction test6. (** should merge some branches into a _->C' *) (** NB : In Coq, "| a => a" corresponds to n, hence some "| _ -> n" are extracted *) Definition test7 n := match n with | A m => Some m | B => None | C => None end. Extraction test7. (** should merge branches B,C into a _->None *) (** Script from bug #2413 *) Set Implicit Arguments. Section S. Definition message := nat. Definition word := nat. Definition mode := nat. Definition opcode := nat. Variable condition : word -> option opcode. Section decoder_result. Variable inst : Type. Inductive decoder_result : Type := | DecUndefined : decoder_result | DecUnpredictable : decoder_result | DecInst : inst -> decoder_result | DecError : message -> decoder_result. End decoder_result. Definition decode_cond_mode (mode : Type) (f : word -> decoder_result mode) (w : word) (inst : Type) (g : mode -> opcode -> inst) : decoder_result inst := match condition w with | Some oc => match f w with | DecInst i => DecInst (g i oc) | DecError m => @DecError inst m | DecUndefined => @DecUndefined inst | DecUnpredictable => @DecUnpredictable inst end | None => @DecUndefined inst end. End S. Extraction decode_cond_mode. (** inner match should not be factorized with a partial x->x (different type) *) coq-8.4pl4/test-suite/output/Coercions.v0000644000175000017500000000121312326224777017411 0ustar stephsteph(* Submitted by Randy Pollack *) Record pred (S : Set) : Type := {sp_pred :> S -> Prop}. Record rel (S : Set) : Type := {sr_rel :> S -> S -> Prop}. Section testSection. Variables (S : Set) (P : pred S) (R : rel S) (x : S). Check (P x). Check (R x x). End testSection. (* Check the removal of coercions with target Funclass *) Record foo : Type := {D :> nat -> nat}. Check (fun (x : foo) (n : nat) => x n). (* Check both removal of coercions with target Funclass and mixing string and numeral scopes *) Require Import String. Open Scope string_scope. Inductive PAIR := P (s:string) (n:nat). Coercion P : string >-> Funclass. Check ("1" 0). coq-8.4pl4/test-suite/output/Nametab.v0000644000175000017500000000162512326224777017043 0ustar stephstephModule Q. Module N. Module K. Definition foo := Set. End K. End N. End Q. (* Bad *) Locate foo. (* Bad *) Locate K.foo. (* Bad *) Locate N.K.foo. (* OK *) Locate Q.N.K.foo. (* OK *) Locate Top.Q.N.K.foo. (* Bad *) Locate Module K. (* Bad *) Locate Module N.K. (* OK *) Locate Module Q.N.K. (* OK *) Locate Module Top.Q.N.K. (* Bad *) Locate Module N. (* OK *) Locate Module Q.N. (* OK *) Locate Module Top.Q.N. (* OK *) Locate Module Q. (* OK *) Locate Module Top.Q. Import Q.N. (* Bad *) Locate foo. (* OK *) Locate K.foo. (* Bad *) Locate N.K.foo. (* OK *) Locate Q.N.K.foo. (* OK *) Locate Top.Q.N.K.foo. (* OK *) Locate Module K. (* Bad *) Locate Module N.K. (* OK *) Locate Module Q.N.K. (* OK *) Locate Module Top.Q.N.K. (* Bad *) Locate Module N. (* OK *) Locate Module Q.N. (* OK *) Locate Module Top.Q.N. (* OK *) Locate Module Q. (* OK *) Locate Module Top.Q. coq-8.4pl4/test-suite/output/Fixpoint.out0000644000175000017500000000071712326224777017637 0ustar stephstephfix F (A B : Set) (f : A -> B) (l : list A) {struct l} : list B := match l with | nil => nil | a :: l0 => f a :: F A B f l0 end : forall A B : Set, (A -> B) -> list A -> list B let fix f (m : nat) : nat := match m with | 0 => 0 | S m' => f m' end in f 0 : nat Ltac f id1 id2 := fix id1 2 with (id2 (n:_) (H:odd n) {struct H} : n >= 1) coq-8.4pl4/test-suite/output/TranspModtype.v0000644000175000017500000000060112326224777020276 0ustar stephstephModule Type SIG. Axiom A : Set. Axiom B : Set. End SIG. Module M : SIG. Definition A := nat. Definition B := nat. End M. Module N <: SIG := M. Module TranspId (X: SIG) <: SIG with Definition A := X.A := X. Module OpaqueId (X: SIG) : SIG with Definition A := X.A := X. Module TrM := TranspId M. Module OpM := OpaqueId M. Print TrM.A. Print OpM.A. Print TrM.B. Print OpM.B. coq-8.4pl4/test-suite/output/Notations.out0000644000175000017500000000731112326224777020012 0ustar stephstephtrue ? 0; 1 : nat if true as x return (x ? nat; bool) then 0 else true : nat Identifier 'proj1' now a keyword fun e : nat * nat => proj1 e : nat * nat -> nat Identifier 'decomp' now a keyword decomp (true, true) as t, u in (t, u) : bool * bool !(0 = 0) : Prop forall n : nat, n = 0 : Prop !(0 = 0) : Prop forall n : nat, #(n = n) : Prop forall n n0 : nat, ##(n = n0) : Prop forall n n0 : nat, ###(n = n0) : Prop 3 + 3 : Z 3 + 3 : znat [1; 2; 4] : list nat (1; 2, 4) : nat * nat * nat Identifier 'ifzero' now a keyword ifzero 3 : bool Identifier 'pred' now a keyword pred 3 : nat fun n : nat => pred n : nat -> nat fun n : nat => pred n : nat -> nat Identifier 'ifn' now a keyword Identifier 'is' now a keyword fun x : nat => ifn x is succ n then n else 0 : nat -> nat 1- : bool -4 : Z The command has indeed failed with message: => Error: x should not be bound in a recursive pattern of the right-hand side. The command has indeed failed with message: => Error: in the right-hand side, y and z should appear in term position as part of a recursive pattern. The command has indeed failed with message: => Error: The reference w was not found in the current environment. The command has indeed failed with message: => Error: x is unbound in the right-hand side. The command has indeed failed with message: => Error: in the right-hand side, y and z should appear in term position as part of a recursive pattern. The command has indeed failed with message: => Error: z is expected to occur in binding position in the right-hand side. The command has indeed failed with message: => Error: as y is a non-closed binder, no such "," is allowed to occur. The command has indeed failed with message: => Error: Cannot find where the recursive pattern starts. The command has indeed failed with message: => Error: Cannot find where the recursive pattern starts. The command has indeed failed with message: => Error: Cannot find where the recursive pattern starts. The command has indeed failed with message: => Error: Cannot find where the recursive pattern starts. The command has indeed failed with message: => Error: Both ends of the recursive pattern are the same. SUM (nat * nat) nat : Set FST (0; 1) : Z Nil : forall A : Type, list A NIL:list nat : list nat Identifier 'I' now a keyword (false && I 3)%bool /\ I 6 : Prop [|1, 2, 3; 4, 5, 6|] : Z * Z * Z * (Z * Z * Z) [|0 * (1, 2, 3); (4, 5, 6) * false|] : Z * Z * (Z * Z) * (Z * Z) * (Z * bool * (Z * bool) * (Z * bool)) fun f : Z -> Z -> Z -> Z => {|f; 0; 1; 2|}:Z : (Z -> Z -> Z -> Z) -> Z plus : nat -> nat -> nat S : nat -> nat mult : nat -> nat -> nat le : nat -> nat -> Prop plus : nat -> nat -> nat succ : nat -> nat mult : nat -> nat -> nat le : nat -> nat -> Prop fun x : option Z => match x with | SOME x0 => x0 | NONE => 0 end : option Z -> Z fun x : option Z => match x with | SOME2 x0 => x0 | NONE2 => 0 end : option Z -> Z fun x : option Z => match x with | SOME3 x0 => x0 | NONE3 => 0 end : option Z -> Z s : s Identifier 'foo' now a keyword 10 : nat fun _ : nat => 9 : nat -> nat Identifier 'ONE' now a keyword fun (x : nat) (p : x = x) => match p with | ONE => ONE end = p : forall x : nat, x = x -> Prop fun (x : nat) (p : x = x) => match p with | 1 => 1 end = p : forall x : nat, x = x -> Prop coq-8.4pl4/test-suite/output/set.v0000644000175000017500000000023212326224777016260 0ustar stephstephGoal let x:=O+O in x=x. intro. set (y1:=O) in (type of x). Show. set (y2:=O) in (value of x) at 1. Show. set (y3:=O) in (value of x). Show. trivial. Qed. coq-8.4pl4/test-suite/output/set.out0000644000175000017500000000047312326224777016631 0ustar stephsteph1 subgoal y1 := 0 : nat x := 0 + 0 : nat ============================ x = x 1 subgoal y1 := 0 : nat y2 := 0 : nat x := y2 + 0 : nat ============================ x = x 1 subgoal y1 := 0 : nat y2 := 0 : nat y3 := 0 : nat x := y2 + y3 : nat ============================ x = x coq-8.4pl4/test-suite/output/Implicit.out0000644000175000017500000000060712326224777017607 0ustar stephstephcompose (C:=nat) S : (nat -> nat) -> nat -> nat ex_intro (P:=fun _ : nat => True) (x:=0) I : ex (fun _ : nat => True) d2 = fun x : nat => d1 (y:=x) : forall x x0 : nat, x0 = x -> x0 = x Arguments x, x0 are implicit Argument scopes are [nat_scope nat_scope _] map id (1 :: nil) : list nat map id' (1 :: nil) : list nat map (id'' (A:=nat)) (1 :: nil) : list nat coq-8.4pl4/test-suite/output/Quote.v0000644000175000017500000000161712326224777016572 0ustar stephstephRequire Import Quote. Parameter A B : Prop. Inductive formula : Type := | f_and : formula -> formula -> formula | f_or : formula -> formula -> formula | f_not : formula -> formula | f_true : formula | f_atom : index -> formula | f_const : Prop -> formula. Fixpoint interp_f (vm: varmap Prop) (f:formula) {struct f} : Prop := match f with | f_and f1 f2 => interp_f vm f1 /\ interp_f vm f2 | f_or f1 f2 => interp_f vm f1 \/ interp_f vm f2 | f_not f1 => ~ interp_f vm f1 | f_true => True | f_atom i => varmap_find True i vm | f_const c => c end. Goal A \/ B -> A /\ (B \/ A) /\ (A \/ ~ B). intro H. match goal with | H : ?a \/ ?b |- _ => quote interp_f in a using (fun x => idtac x; change (x \/ b) in H) end. match goal with |- ?g => quote interp_f [ A ] in g using (fun x => idtac x) end. quote interp_f. Show. simpl; quote interp_f [ A ]. Show. Admitted. coq-8.4pl4/test-suite/output/RealSyntax.out0000644000175000017500000000003712326224777020124 0ustar stephsteph32%R : R (-31)%R : R coq-8.4pl4/test-suite/output/simpl.v0000644000175000017500000000022412326224777016612 0ustar stephsteph(* Simpl with patterns *) Goal forall x, 0+x = 1+x. intro x. simpl (_ + x). Show. Undo. simpl (_ + x) at 2. Show. Undo. simpl (0 + _). Show. Undo. coq-8.4pl4/test-suite/output/Existentials.v0000644000175000017500000000034112326224777020142 0ustar stephsteph(* Test propagation of clear/clearbody in existential variables *) Section Test. Variable p:nat. Let q := S p. Goal forall n m:nat, n = m. intros. eapply eq_trans. clearbody q. clear p. (* Error ... *) Show Existentials. coq-8.4pl4/test-suite/output/ArgumentsScope.out0000644000175000017500000000256112326224777020775 0ustar stephstepha : bool -> bool Argument scope is [bool_scope] Expands to: Variable a b : bool -> bool Argument scope is [bool_scope] Expands to: Variable b negb'' : bool -> bool Argument scope is [bool_scope] negb'' is transparent Expands to: Constant Top.A.B.negb'' negb' : bool -> bool Argument scope is [bool_scope] negb' is transparent Expands to: Constant Top.A.negb' negb : bool -> bool Argument scope is [bool_scope] negb is transparent Expands to: Constant Coq.Init.Datatypes.negb Warning: Arguments Scope is deprecated; use Arguments instead Warning: Arguments Scope is deprecated; use Arguments instead Warning: Arguments Scope is deprecated; use Arguments instead Warning: Arguments Scope is deprecated; use Arguments instead Warning: Arguments Scope is deprecated; use Arguments instead a : bool -> bool Expands to: Variable a b : bool -> bool Expands to: Variable b negb : bool -> bool negb is transparent Expands to: Constant Coq.Init.Datatypes.negb negb' : bool -> bool negb' is transparent Expands to: Constant Top.A.negb' negb'' : bool -> bool negb'' is transparent Expands to: Constant Top.A.B.negb'' a : bool -> bool Expands to: Variable a negb : bool -> bool negb is transparent Expands to: Constant Coq.Init.Datatypes.negb negb' : bool -> bool negb' is transparent Expands to: Constant Top.negb' negb'' : bool -> bool negb'' is transparent Expands to: Constant Top.negb'' coq-8.4pl4/test-suite/bugs/0000755000175000017500000000000012365131024014662 5ustar stephstephcoq-8.4pl4/test-suite/bugs/opened/0000755000175000017500000000000012326224777016153 5ustar stephstephcoq-8.4pl4/test-suite/bugs/opened/shouldnotfail/0000755000175000017500000000000012326224777021026 5ustar stephstephcoq-8.4pl4/test-suite/bugs/opened/shouldnotfail/743.v0000644000175000017500000000032312326224777021530 0ustar stephstephRequire Import Omega. Lemma foo : forall n m : Z, (n >= 0)%Z -> (n * m >= 0)%Z -> (n <= n + n * m)%Z. Proof. intros. omega. Qed. Lemma foo' : forall n m : nat, n <= n + n * m. Proof. intros. omega. Qed. coq-8.4pl4/test-suite/bugs/opened/shouldnotfail/1811.v0000644000175000017500000000027412326224777021612 0ustar stephstephRequire Export Bool. Lemma neg2xor : forall b, xorb true b = negb b. Proof. auto. Qed. Goal forall b1 b2, (negb b1 = b2) -> xorb true b1 = b2. Proof. intros b1 b2. rewrite neg2xor.coq-8.4pl4/test-suite/bugs/opened/shouldnotfail/1501.v0000644000175000017500000000470112326224777021605 0ustar stephstephSet Implicit Arguments. Require Export Relation_Definitions. Require Export Setoid. Section Essais. (* Parametrized Setoid *) Parameter K : Type -> Type. Parameter equiv : forall A : Type, K A -> K A -> Prop. Parameter equiv_refl : forall (A : Type) (x : K A), equiv x x. Parameter equiv_sym : forall (A : Type) (x y : K A), equiv x y -> equiv y x. Parameter equiv_trans : forall (A : Type) (x y z : K A), equiv x y -> equiv y z -> equiv x z. (* basic operations *) Parameter val : forall A : Type, A -> K A. Parameter bind : forall A B : Type, K A -> (A -> K B) -> K B. Parameter bind_compat : forall (A B : Type) (m1 m2 : K A) (f1 f2 : A -> K B), equiv m1 m2 -> (forall x : A, equiv (f1 x) (f2 x)) -> equiv (bind m1 f1) (bind m2 f2). (* monad axioms *) Parameter bind_val_l : forall (A B : Type) (a : A) (f : A -> K B), equiv (bind (val a) f) (f a). Parameter bind_val_r : forall (A : Type) (m : K A), equiv (bind m (fun a => val a)) m. Parameter bind_assoc : forall (A B C : Type) (m : K A) (f : A -> K B) (g : B -> K C), equiv (bind (bind m f) g) (bind m (fun a => bind (f a) g)). Hint Resolve equiv_refl equiv_sym equiv_trans: monad. Add Relation K equiv reflexivity proved by (@equiv_refl) symmetry proved by (@equiv_sym) transitivity proved by (@equiv_trans) as equiv_rel. Definition fequiv (A B: Type) (f g: A -> K B) := forall (x:A), (equiv (f x) (g x)). Lemma fequiv_refl : forall (A B: Type) (f : A -> K B), fequiv f f. Proof. unfold fequiv; auto with monad. Qed. Lemma fequiv_sym : forall (A B: Type) (x y : A -> K B), fequiv x y -> fequiv y x. Proof. unfold fequiv; auto with monad. Qed. Lemma fequiv_trans : forall (A B: Type) (x y z : A -> K B), fequiv x y -> fequiv y z -> fequiv x z. Proof. unfold fequiv; intros; eapply equiv_trans; auto with monad. Qed. Add Relation (fun (A B:Type) => A -> K B) fequiv reflexivity proved by (@fequiv_refl) symmetry proved by (@fequiv_sym) transitivity proved by (@fequiv_trans) as fequiv_rel. Add Morphism bind with signature equiv ==> fequiv ==> equiv as bind_mor. Proof. unfold fequiv; intros; apply bind_compat; auto. Qed. Lemma test: forall (A B: Type) (m1 m2 m3: K A) (f: A -> A -> K B), (equiv m1 m2) -> (equiv m2 m3) -> equiv (bind m1 (fun a => bind m2 (fun a' => f a a'))) (bind m2 (fun a => bind m3 (fun a' => f a a'))). Proof. intros A B m1 m2 m3 f H1 H2. setoid_rewrite H1. (* this works *) setoid_rewrite H2. trivial by equiv_refl. Qed. coq-8.4pl4/test-suite/bugs/opened/shouldnotfail/2310.v0000644000175000017500000000117612326224777021607 0ustar stephsteph(* Dependent higher-order hole in "refine" (simplified version) *) Set Implicit Arguments. Inductive Nest t := Cons : Nest (prod t t) -> Nest t. Definition cast A x y Heq P H := @eq_rect A x P H y Heq. Definition replace a (y:Nest (prod a a)) : a = a -> Nest a. (* This used to raise an anomaly Unknown Meta in 8.2 and 8.3beta. It raises a regular error in 8.3 and almost succeeds with the new proof engine: there are two solutions to a unification problem (P:=\a.Nest (prod a a) and P:=\_.Nest (prod a a)) and refine should either leave P as subgoal or choose itself one solution *) intros. refine (Cons (cast H _ y)). coq-8.4pl4/test-suite/bugs/opened/shouldnotfail/1596.v0000644000175000017500000001521412326224777021624 0ustar stephsteph Require Import Relations. Require Import FSets. Require Import Arith. Lemma Bool_elim_bool : forall (b:bool),b=true \/ b=false. destruct b;try tauto. Qed. Module OrderedPair (X:OrderedType) (Y:OrderedType) <: OrderedType with Definition t := (X.t * Y.t)%type. Definition t := (X.t * Y.t)%type. Definition eq (xy1:t) (xy2:t) := let (x1,y1) := xy1 in let (x2,y2) := xy2 in (X.eq x1 x2) /\ (Y.eq y1 y2). Definition lt (xy1:t) (xy2:t) := let (x1,y1) := xy1 in let (x2,y2) := xy2 in (X.lt x1 x2) \/ ((X.eq x1 x2) /\ (Y.lt y1 y2)). Lemma eq_refl : forall (x:t),(eq x x). destruct x. unfold eq. split;[apply X.eq_refl | apply Y.eq_refl]. Qed. Lemma eq_sym : forall (x y:t),(eq x y)->(eq y x). destruct x;destruct y;unfold eq;intro. elim H;clear H;intros. split;[apply X.eq_sym | apply Y.eq_sym];trivial. Qed. Lemma eq_trans : forall (x y z:t),(eq x y)->(eq y z)->(eq x z). unfold eq;destruct x;destruct y;destruct z;intros. elim H;clear H;intros. elim H0;clear H0;intros. split;[eapply X.eq_trans | eapply Y.eq_trans];eauto. Qed. Lemma lt_trans : forall (x y z:t),(lt x y)->(lt y z)->(lt x z). unfold lt;destruct x;destruct y;destruct z;intros. case H;clear H;intro. case H0;clear H0;intro. left. eapply X.lt_trans;eauto. elim H0;clear H0;intros. left. case (X.compare t0 t4);trivial;intros. generalize (X.eq_sym H0);intro. generalize (X.eq_trans e H2);intro. elim (X.lt_not_eq H H3). generalize (X.lt_trans l H);intro. generalize (X.eq_sym H0);intro. elim (X.lt_not_eq H2 H3). elim H;clear H;intros. case H0;clear H0;intro. left. case (X.compare t0 t4);trivial;intros. generalize (X.eq_sym H);intro. generalize (X.eq_trans H2 e);intro. elim (X.lt_not_eq H0 H3). generalize (X.lt_trans H0 l);intro. generalize (X.eq_sym H);intro. elim (X.lt_not_eq H2 H3). elim H0;clear H0;intros. right. split. eauto. eauto. Qed. Lemma lt_not_eq : forall (x y:t),(lt x y)->~(eq x y). unfold lt, eq;destruct x;destruct y;intro;intro. elim H0;clear H0;intros. case H. intro. apply (X.lt_not_eq H2 H0). intro. elim H2;clear H2;intros. apply (Y.lt_not_eq H3 H1). Qed. Definition compare : forall (x y:t),(Compare lt eq x y). destruct x;destruct y. case (X.compare t0 t2);intro. apply LT. left;trivial. case (Y.compare t1 t3);intro. apply LT. right. tauto. apply EQ. split;trivial. apply GT. right;auto. apply GT. left;trivial. Defined. Hint Immediate eq_sym. Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. End OrderedPair. Module MessageSpi. Inductive message : Set := | MNam : nat -> message. Definition t := message. Fixpoint message_lt (m n:message) {struct m} : Prop := match (m,n) with | (MNam n1,MNam n2) => n1 < n2 end. Module Ord <: OrderedType with Definition t := message with Definition eq := @eq message. Definition t := message. Definition eq := @eq message. Definition lt := message_lt. Lemma eq_refl : forall (x:t),eq x x. unfold eq;auto. Qed. Lemma eq_sym : forall (x y:t),(eq x y )->(eq y x). unfold eq;auto. Qed. Lemma eq_trans : forall (x y z:t),(eq x y)->(eq y z)->(eq x z). unfold eq;auto;intros;congruence. Qed. Lemma lt_trans : forall (x y z:t),(lt x y)->(lt y z)->(lt x z). unfold lt. induction x;destruct y;simpl;try tauto;destruct z;try tauto;intros. omega. Qed. Lemma lt_not_eq : forall (x y:t),(lt x y)->~(eq x y). unfold eq;unfold lt. induction x;destruct y;simpl;try tauto;intro;red;intro;try (discriminate H0);injection H0;intros. elim (lt_irrefl n);try omega. Qed. Definition compare : forall (x y:t),(Compare lt eq x y). unfold lt, eq. induction x;destruct y;intros;try (apply LT;simpl;trivial;fail);try (apply GT;simpl;trivial;fail). case (lt_eq_lt_dec n n0);intros;try (case s;clear s;intros). apply LT;trivial. apply EQ;trivial. rewrite e;trivial. apply GT;trivial. Defined. Hint Immediate eq_sym. Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. End Ord. Theorem eq_dec : forall (m n:message),{m=n}+{~(m=n)}. intros. case (Ord.compare m n);intro;[right | left | right];try (red;intro). elim (Ord.lt_not_eq m n);auto. rewrite e;auto. elim (Ord.lt_not_eq n m);auto. Defined. End MessageSpi. Module MessagePair := OrderedPair MessageSpi.Ord MessageSpi.Ord. Module Type Hedge := FSetInterface.S with Module E := MessagePair. Module A (H:Hedge). Definition hedge := H.t. Definition message_relation := relation MessageSpi.message. Definition relation_of_hedge (h:hedge) (m n:MessageSpi.message) := H.In (m,n) h. Inductive hedge_synthesis_relation (h:message_relation) : message_relation := | SynInc : forall (m n:MessageSpi.message),(h m n)->(hedge_synthesis_relation h m n). Fixpoint hedge_in_synthesis (h:hedge) (m:MessageSpi.message) (n:MessageSpi.message) {struct m} : bool := if H.mem (m,n) h then true else false. Definition hedge_synthesis_spec (h:hedge) := hedge_synthesis_relation (relation_of_hedge h). Lemma hedge_in_synthesis_impl_hedge_synthesis_spec : forall (h:hedge),forall (m n:MessageSpi.message),(hedge_in_synthesis h m n)=true->(hedge_synthesis_spec h m n). unfold hedge_synthesis_spec;unfold relation_of_hedge. induction m;simpl;intro. elim (Bool_elim_bool (H.mem (MessageSpi.MNam n,n0) h));intros. apply SynInc;apply H.mem_2;trivial. rewrite H in H0. (* !! possible here !! *) discriminate H0. Qed. End A. Module B (H:Hedge). Definition hedge := H.t. Definition message_relation := relation MessageSpi.t. Definition relation_of_hedge (h:hedge) (m n:MessageSpi.t) := H.In (m,n) h. Inductive hedge_synthesis_relation (h:message_relation) : message_relation := | SynInc : forall (m n:MessageSpi.t),(h m n)->(hedge_synthesis_relation h m n). Fixpoint hedge_in_synthesis (h:hedge) (m:MessageSpi.t) (n:MessageSpi.t) {struct m} : bool := if H.mem (m,n) h then true else false. Definition hedge_synthesis_spec (h:hedge) := hedge_synthesis_relation (relation_of_hedge h). Lemma hedge_in_synthesis_impl_hedge_synthesis_spec : forall (h:hedge),forall (m n:MessageSpi.t),(hedge_in_synthesis h m n)=true->(hedge_synthesis_spec h m n). unfold hedge_synthesis_spec;unfold relation_of_hedge. induction m;simpl;intro. elim (Bool_elim_bool (H.mem (MessageSpi.MNam n,n0) h));intros. apply SynInc;apply H.mem_2;trivial. rewrite H in H0. (* !! impossible here !! *) discriminate H0. Qed. End B.coq-8.4pl4/test-suite/bugs/opened/shouldnotfail/1338.v-disabled0000644000175000017500000000050512326224777023360 0ustar stephstephRequire Import Omega. Goal forall x, 0 <= x -> x <= 20 -> x <> 0 -> x <> 1 -> x <> 2 -> x <> 3 -> x <>4 -> x <> 5 -> x <> 6 -> x <> 7 -> x <> 8 -> x <> 9 -> x <> 10 -> x <> 11 -> x <> 12 -> x <> 13 -> x <> 14 -> x <> 15 -> x <> 16 -> x <> 17 -> x <> 18 -> x <> 19 -> x <> 20 -> False. Proof. intros. omega. Qed. coq-8.4pl4/test-suite/bugs/opened/shouldnotfail/1671.v0000644000175000017500000000047512326224777021621 0ustar stephsteph(* Exemple soumis par Pierre Corbineau (bug #1671) *) CoInductive hdlist : unit -> Type := | cons : hdlist tt -> hdlist tt. Variable P : forall bo, hdlist bo -> Prop. Variable all : forall bo l, P bo l. Definition F (l:hdlist tt) : P tt l := match l in hdlist u return P u l with | cons (cons l') => all tt _ end. coq-8.4pl4/test-suite/bugs/opened/1773.v0000644000175000017500000000030012326224777016734 0ustar stephstephGoal forall B C : nat -> nat -> Prop, forall k, C 0 k -> (exists A, (forall k', C A k' -> B A k') -> B A k). Proof. intros B C k H. econstructor. intros X. apply X. apply H. Qed. coq-8.4pl4/test-suite/bugs/closed/0000755000175000017500000000000012365131024016133 5ustar stephstephcoq-8.4pl4/test-suite/bugs/closed/1780.v0000644000175000017500000000044312326224777016741 0ustar stephsteph Definition bug := Eval vm_compute in eq_rect. (* bug: Error: Illegal application (Type Error): The term "eq" of type "forall A : Type, A -> A -> Prop" cannot be applied to the terms "x" : "A" "P" : "A -> Type" "x0" : "A" The 1st term has type "A" which should be coercible to "Type". *) coq-8.4pl4/test-suite/bugs/closed/2319.v0000644000175000017500000000045312326224777016741 0ustar stephstephSection S. CoInductive A (X: Type) := mkA: A X -> A X. Variable T : Type. (* This used to loop (bug #2319) *) Timeout 5 Eval vm_compute in cofix s : A T := mkA T s. CoFixpoint s : A T := mkA T s with t : A unit := mkA unit (mkA unit t). Timeout 5 Eval vm_compute in s. End S.coq-8.4pl4/test-suite/bugs/closed/2105.v0000644000175000017500000000006112326224777016725 0ustar stephsteph Definition id (T:Type) := Eval vm_compute in T. coq-8.4pl4/test-suite/bugs/closed/shouldfail/0000755000175000017500000000000012365131024020265 5ustar stephstephcoq-8.4pl4/test-suite/bugs/closed/shouldfail/2006.v0000644000175000017500000000112112326224777021055 0ustar stephsteph(* Take the type constraint on Record into account *) Definition Type1 := Type. Record R : Type1 := { p:Type1 }. (* was accepted before trunk revision 11619 *) (* Remarks: - The behaviour was inconsistent with the one of Inductive, e.g. Inductive R : Type1 := Build_R : Type1 -> R. was correctly refused. - CoRN makes some use of the following configuration: Definition CProp := Type. Record R : CProp := { ... }. CoRN may have to change the CProp definition into a notation if the preservation of the former semantics of Record type constraints turns to be required. *) coq-8.4pl4/test-suite/bugs/closed/shouldfail/2586.v0000644000175000017500000000017012326224777021075 0ustar stephstephRequire Import Setoid SetoidClass Program. Goal forall `(Setoid nat) x y, x == y -> S x == S y. intros. clsubst H0.coq-8.4pl4/test-suite/bugs/closed/shouldfail/2251.v0000644000175000017500000000026712326224777021071 0ustar stephsteph(* Check that rewrite does not apply to single evars *) Lemma evar_rewrite : (forall a : nat, a = 0 -> True) -> True. intros; eapply H. (* goal is ?30 = nil *) rewrite plus_n_Sm. coq-8.4pl4/test-suite/bugs/closed/shouldfail/2406.v0000644000175000017500000000021312326224777021062 0ustar stephsteph(* Check correct handling of unsupported notations *) Notation "'’'" := (fun x => x) (at level 20). Definition crash_the_rooster f := ’. coq-8.4pl4/test-suite/bugs/closed/shouldfail/1703.v0000644000175000017500000000027012326224777021064 0ustar stephsteph(* Check correct binding of intros until used in Ltac *) Ltac intros_until n := intros until n. Goal forall i j m n : nat, i = 0 /\ j = 0 /\ m = 0 /\ n = 0. intro i. intros until i. coq-8.4pl4/test-suite/bugs/closed/shouldfail/1898.v0000644000175000017500000000016312326224777021104 0ustar stephsteph(* folding should not allow circular dependencies *) Lemma bug_fold_unfold : True. set (h := 1). fold h in h. coq-8.4pl4/test-suite/bugs/closed/shouldfail/1915.v0000644000175000017500000000015212326224777021070 0ustar stephsteph Require Import Setoid. Goal forall x, impl True (x = 0) -> x = 0 -> False. intros x H E. rewrite H in E.coq-8.4pl4/test-suite/bugs/closed/3023.v0000644000175000017500000000165412326224777016736 0ustar stephsteph(* Checking use of eta on Flexible/Rigid and SemiFlexible/Rigid unif problems *) Set Implicit Arguments. Generalizable All Variables. Record Category {obj : Type} := { Morphism : obj -> obj -> Type; Identity : forall x, Morphism x x; Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d'; LeftIdentity : forall a b (f : Morphism a b), Compose (Identity b) f = f }. Section DiscreteAdjoints. Let C := {| Morphism := (fun X Y : Type => X -> Y); Identity := (fun X : Type => (fun x : X => x)); Compose := (fun _ _ _ f g => (fun x => f (g x))); LeftIdentity := (fun X Y p => @eq_refl _ p : (fun x : X => p x) = p) |}. Variable ObjectFunctor : C = C. Goal True. Proof. subst C. revert ObjectFunctor. intro ObjectFunctor. simpl in ObjectFunctor. revert ObjectFunctor. (* Used to failed in 8.4 up to 16 April 2013 *) coq-8.4pl4/test-suite/bugs/closed/1787.v0000644000175000017500000000041012326224777016742 0ustar stephstephParameter P : nat -> nat -> Prop. Parameter Q : nat -> nat -> Prop. Axiom A : forall x x' x'', P x x' -> Q x'' x' -> P x x''. Goal (P 1 3) -> (Q 1 3) -> (P 1 1). intros H H'. refine ((fun H1 : P 1 _ => let H2 := (_:Q 1 _) in A _ _ _ H1 H2) _). clear. Admitted. coq-8.4pl4/test-suite/bugs/closed/2955.v0000644000175000017500000000123012326224777016741 0ustar stephstephRequire Import Coq.Arith.Arith. Module A. Fixpoint foo (n:nat) := match n with | 0 => 0 | S n => bar n end with bar (n:nat) := match n with | 0 => 0 | S n => foo n end. Lemma using_foo: forall (n:nat), foo n = 0 /\ bar n = 0. Proof. induction n ; split ; auto ; destruct IHn ; auto. Qed. End A. Module B. Module A := A. Import A. End B. Module E. Module B := B. Import B.A. (* Bug 1 *) Lemma test_1: forall (n:nat), foo n = 0. Proof. intros ; destruct n. reflexivity. specialize (A.using_foo (S n)) ; intros. simpl in H. simpl. destruct H. assumption. Qed. End E.coq-8.4pl4/test-suite/bugs/closed/1519.v0000644000175000017500000000046612326224777016746 0ustar stephstephSection S. Variable A:Prop. Variable W:A. Remark T: A -> A. intro Z. rename W into Z_. rename Z into W. rename Z_ into Z. exact Z. Qed. (* bug : Error: Unbound reference: In environment A : Prop W : A Z : A The reference 2 is free *) End S. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/0000755000175000017500000000000012326224777021004 5ustar stephstephcoq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2300.v0000644000175000017500000000036712326224777021565 0ustar stephsteph(* Check some behavior of Ltac pattern-matching wrt universe levels *) Section contents. Variables (A: Type) (B: (unit -> Type) -> Type). Inductive C := c: A -> unit -> C. Let unused2 (x: unit) := C. Goal True. intuition. Qed. End contents. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1891.v0000644000175000017500000000046012326224777021575 0ustar stephsteph(* Check evar-evar unification *) Inductive T (A: Set): Set := mkT: unit -> T A. Definition f (A: Set) (l: T A): unit := tt. Implicit Arguments f [A]. Lemma L (x: T unit): (unit -> T unit) -> unit. Proof. refine (match x return _ with mkT n => fun g => f (g _) end). trivial. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1944.v0000644000175000017500000000034012326224777021571 0ustar stephsteph(* Test some uses of ? in introduction patterns *) Inductive J : nat -> Prop := | K : forall p, J p -> (True /\ True) -> J (S p). Lemma bug : forall n, J n -> J (S n). Proof. intros ? H. induction H as [? ? [? ?]]. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2145.v0000644000175000017500000000063612326224777021573 0ustar stephsteph(* Test robustness of Groebner tactic in presence of disequalities *) Require Export Reals. Require Export Nsatz. Open Scope R_scope. Lemma essai : forall yb xb m1 m2 xa ya, xa <> xb -> yb - 2 * m2 * xb = ya - m2 * xa -> yb - m1 * xb = ya - m1 * xa -> yb - ya = (2 * xb - xa) * m2 -> yb - ya = (xb - xa) * m1. Proof. intros. (* clear H. groebner used not to work when H was not cleared *) nsatz. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1779.v0000644000175000017500000000150412326224777021602 0ustar stephstephRequire Import Div2. Lemma double_div2: forall n, div2 (double n) = n. exact (fun n => let _subcase := let _cofact := fun _ : 0 = 0 => refl_equal 0 in _cofact (let _fact := refl_equal 0 in _fact) in let _subcase0 := fun (m : nat) (Hrec : div2 (double m) = m) => let _fact := f_equal div2 (double_S m) in let _eq := trans_eq _fact (refl_equal (S (div2 (double m)))) in let _eq0 := trans_eq _eq (trans_eq (f_equal (fun f : nat -> nat => f (div2 (double m))) (refl_equal S)) (f_equal S Hrec)) in _eq0 in (fix _fix (__ : nat) : div2 (double __) = __ := match __ as n return (div2 (double n) = n) with | 0 => _subcase | S __0 => (fun _hrec : div2 (double __0) = __0 => _subcase0 __0 _hrec) (_fix __0) end) n). Guarded. Defined. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/3004.v0000644000175000017500000000036612326224777021566 0ustar stephstephSet Implicit Arguments. Unset Strict Implicit. Parameter (M : nat -> Type). Parameter (mp : forall (T1 T2 : Type) (f : T1 -> T2), list T1 -> list T2). Definition foo (s : list {n : nat & M n}) := let exT := existT in mp (fun x => projT1 x) s. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2362.v0000644000175000017500000000153412326224777021572 0ustar stephstephSet Implicit Arguments. Class Pointed (M:Type -> Type) := { creturn: forall {A: Type}, A -> M A }. Unset Implicit Arguments. Inductive FPair (A B:Type) (neutral: B) : Type:= fpair : forall (a:A) (b:B), FPair A B neutral. Implicit Arguments fpair [[A] [B] [neutral]]. Set Implicit Arguments. Notation "( x ,> y )" := (fpair x y) (at level 0). Instance Pointed_FPair B neutral: Pointed (fun A => FPair A B neutral) := { creturn := fun A (a:A) => (a,> neutral) }. Definition blah_fail (x:bool) : FPair bool nat O := creturn x. Set Printing All. Print blah_fail. Definition blah_explicit (x:bool) : FPair bool nat O := @creturn _ (Pointed_FPair _ ) _ x. Print blah_explicit. Instance Pointed_FPair_mono: Pointed (fun A => FPair A nat 0) := { creturn := fun A (a:A) => (a,> 0) }. Definition blah (x:bool) : FPair bool nat O := creturn x. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2750.v0000644000175000017500000000051512326224777021571 0ustar stephsteph Module Type ModWithRecord. Record foo : Type := { A : nat ; B : nat }. End ModWithRecord. Module Test_ModWithRecord (M : ModWithRecord). Definition test1 : M.foo := {| M.A := 0 ; M.B := 2 |}. Module B := M. Definition test2 : M.foo := {| M.A := 0 ; M.B := 2 |}. End Test_ModWithRecord.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2464.v0000644000175000017500000000232712326224777021576 0ustar stephstephRequire Import FSetWeakList. Require Import FSetDecide. Parameter Name : Set. Axiom eq_Name_dec : forall (n : Name) (o : Name), {n = o} + {n <> o}. Module DecidableName. Definition t := Name. Definition eq := @eq Name. Definition eq_refl := @refl_equal Name. Definition eq_sym := @sym_eq Name. Definition eq_trans := @trans_eq Name. Definition eq_dec := eq_Name_dec. End DecidableName. Module NameSetMod := Make(DecidableName). Module NameSetDec := WDecide (NameSetMod). Class PartPatchUniverse (pu_type1 pu_type2 : Type) : Type := mkPartPatchUniverse { }. Class PatchUniverse {pu_type : Type} (ppu : PartPatchUniverse pu_type pu_type) : Type := mkPatchUniverse { pu_nameOf : pu_type -> Name }. Lemma foo : forall (pu_type : Type) (ppu : PartPatchUniverse pu_type pu_type) (patchUniverse : PatchUniverse ppu) (ns ns1 ns2 : NameSetMod.t) (containsOK : NameSetMod.Equal ns1 ns2) (p : pu_type) (HX1 : NameSetMod.Equal ns1 (NameSetMod.add (pu_nameOf p) ns)), NameSetMod.Equal ns2 (NameSetMod.add (pu_nameOf p) ns). Proof. NameSetDec.fsetdec. Qed.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1576.v0000644000175000017500000000072412326224777021600 0ustar stephstephModule Type TA. Parameter t : Set. End TA. Module Type TB. Declare Module A: TA. End TB. Module Type TC. Declare Module B : TB. End TC. Module Type TD. Declare Module B: TB . Declare Module C: TC with Module B := B . End TD. Module Type TE. Declare Module D : TD. End TE. Module Type TF. Declare Module E: TE. End TF. Module G (D: TD). Module B' := D.C.B. End G. Module H (F: TF). Module I := G(F.E.D). End H. Declare Module F: TF. Module K := H(F). coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2342.v0000644000175000017500000000035612326224777021571 0ustar stephsteph(* Checking that the type inference algoithme does not commit to an equality over sorts when only a subtyping constraint is around *) Parameter A : Set. Parameter B : A -> Set. Parameter F : Set -> Prop. Check (F (forall x, B x)). coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1963.v0000644000175000017500000000104612326224777021576 0ustar stephsteph(* Check that "dependent inversion" behaves correctly w.r.t to universes *) Require Import Eqdep. Set Implicit Arguments. Inductive illist(A:Type) : nat -> Type := illistn : illist A 0 | illistc : forall n:nat, A -> illist A n -> illist A (S n). Inductive isig (A:Type)(P:A -> Type) : Type := iexists : forall x : A, P x -> isig P. Lemma inv : forall (A:Type)(n n':nat)(ts':illist A n'), n' = S n -> isig (fun t => isig (fun ts => eq_dep nat (fun n => illist A n) n' ts' (S n) (illistc t ts))). Proof. intros. dependent inversion ts'. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/348.v0000644000175000017500000000027212326224777021512 0ustar stephstephModule Type S. Parameter empty: Set. End S. Module D (M:S). Import M. Definition empty:=nat. End D. Module D' (M:S). Import M. Definition empty:Set. exact nat. Save. End D'. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/931.v0000644000175000017500000000015712326224777021512 0ustar stephstephParameter P : forall n : nat, n=n -> Prop. Goal Prop. refine (P _ _). instantiate (1:=0). trivial. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2299.v0000644000175000017500000000033412326224777021600 0ustar stephsteph(* Check that destruct refreshes universes in what it generalizes *) Section test. Variable A: Type. Inductive T: unit -> Type := C: A -> unit -> T tt. Let unused := T tt. Goal T tt -> False. intro X. destruct X. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2613.v0000644000175000017500000000061012326224777021563 0ustar stephsteph(* Check that eq_sym is still pointing to Logic.eq_sym after use of Function *) Require Import ZArith. Require Recdef. Axiom nat_eq_dec: forall x y : nat, {x=y}+{x<>y}. Locate eq_sym. (* Constant Coq.Init.Logic.eq_sym *) Function loop (n: nat) {measure (fun x => x) n} : bool := if nat_eq_dec n 0 then false else loop (pred n). Proof. admit. Defined. Check eq_sym eq_refl : 0=0. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1951.v0000644000175000017500000000306712326224777021600 0ustar stephsteph (* First a simplification of the bug *) Set Printing Universes. Inductive enc (A:Type (*1*)) (* : Type.1 *) := C : A -> enc A. Definition id (X:Type(*5*)) (x:X) := x. Lemma test : let S := Type(*6 : 7*) in enc S -> S. simpl; intros. apply enc. apply id. apply Prop. Defined. (* Then the original bug *) Require Import List. Inductive a : Set := (* some dummy inductive *) b : (list a) -> a. (* i don't know if this *) (* happens for smaller *) (* ones *) Inductive sg : Type := Sg. (* single *) Definition ipl2 (P : a -> Type) := (* in Prop, that means P is true forall *) fold_right (fun x => prod (P x)) sg. (* the elements of a given list *) Definition ind : forall S : a -> Type, (forall ls : list a, ipl2 S ls -> S (b ls)) -> forall s : a, S s := fun (S : a -> Type) (X : forall ls : list a, ipl2 S ls -> S (b ls)) => fix ind2 (s : a) := match s as a return (S a) with | b l => X l (list_rect (fun l0 : list a => ipl2 S l0) Sg (fun (a0 : a) (l0 : list a) (IHl : ipl2 S l0) => pair (ind2 a0) IHl) l) end. (* some induction principle *) Implicit Arguments ind [S]. Lemma k : a -> Type. (* some ininteresting lemma *) intro;pattern H;apply ind;intros. assert (K : Type). induction ls. exact sg. exact sg. exact (prod K sg). Defined. Lemma k' : a -> Type. (* same lemma but with our bug *) intro;pattern H;apply ind;intros. apply prod. induction ls. exact sg. exact sg. exact sg. (* Proof complete *) Defined. (* bug *) coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1243.v0000644000175000017500000000030312326224777021560 0ustar stephstephRequire Import ZArith. Require Import Arith. Open Scope Z_scope. Theorem r_ex : (forall x y:nat, x + y = x + y)%nat. Admitted. Theorem r_ex' : forall x y:nat, (x + y = x + y)%nat. Admitted. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2404.v0000644000175000017500000000262212326224777021566 0ustar stephsteph(* Check that dependencies in the indices of the type of the terms to match are taken into account and correctly generalized *) Require Import Relations.Relation_Definitions. Require Import Basics. Record Base := mkBase {(* Primitives *) World : Set (* Names are real, links are theoretical *) ; Name : World -> Set ; wweak : World -> World -> Prop ; exportw : forall a b : World, (wweak a b) -> (Name b) -> option (Name a) }. Section Derived. Variable base : Base. Definition bWorld := World base. Definition bName := Name base. Definition bexportw := exportw base. Definition bwweak := wweak base. Implicit Arguments bexportw [a b]. Inductive RstarSetProof {I : Type} (T : I -> I -> Type) : I -> I -> Type := starReflS : forall a, RstarSetProof T a a | starTransS : forall i j k, T i j -> (RstarSetProof T j k) -> RstarSetProof T i k. Implicit Arguments starTransS [I T i j k]. Definition RstarInv {A : Set} (rel : relation A) : A -> A -> Type := (flip (RstarSetProof (flip rel))). Definition bwweakFlip (b a : bWorld) : Prop := (bwweak a b). Definition Rweak : forall a b : bWorld, Type := RstarInv bwweak. Fixpoint exportRweak {a b} (aRWb : Rweak a b) (y : bName b) : option (bName a) := match aRWb,y with | starReflS a, y' => Some y' | starTransS i j k jWk jRWi, y' => match (bexportw jWk y) with | Some x => exportRweak jRWi x | None => None end end. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1784.v0000644000175000017500000000556212326224777021606 0ustar stephstephRequire Import List. Require Import ZArith. Require String. Open Scope string_scope. Ltac Case s := let c := fresh "case" in set (c := s). Set Implicit Arguments. Unset Strict Implicit. Inductive sv : Set := | I : Z -> sv | S : list sv -> sv. Section sv_induction. Variables (VP: sv -> Prop) (LP: list sv -> Prop) (VPint: forall n, VP (I n)) (VPset: forall vs, LP vs -> VP (S vs)) (lpcons: forall v vs, VP v -> LP vs -> LP (v::vs)) (lpnil: LP nil). Fixpoint setl_value_indp (x:sv) {struct x}: VP x := match x as x return VP x with | I n => VPint n | S vs => VPset ((fix values_indp (vs:list sv) {struct vs}: (LP vs) := match vs as vs return LP vs with | nil => lpnil | v::vs => lpcons (setl_value_indp v) (values_indp vs) end) vs) end. End sv_induction. Inductive slt : sv -> sv -> Prop := | IC : forall z, slt (I z) (I z) | IS : forall vs vs', slist_in vs vs' -> slt (S vs) (S vs') with sin : sv -> list sv -> Prop := | Ihd : forall s s' sv', slt s s' -> sin s (s'::sv') | Itl : forall s s' sv', sin s sv' -> sin s (s'::sv') with slist_in : list sv -> list sv -> Prop := | Inil : forall sv', slist_in nil sv' | Icons : forall s sv sv', sin s sv' -> slist_in sv sv' -> slist_in (s::sv) sv'. Hint Constructors sin slt slist_in. Require Import Program. Program Fixpoint lt_dec (x y:sv) { struct x } : {slt x y}+{~slt x y} := match x with | I x => match y with | I y => if (Z.eq_dec x y) then in_left else in_right | S ys => in_right end | S xs => match y with | I y => in_right | S ys => let fix list_in (xs ys:list sv) {struct xs} : {slist_in xs ys} + {~slist_in xs ys} := match xs with | nil => in_left | x::xs => let fix elem_in (ys:list sv) : {sin x ys}+{~sin x ys} := match ys with | nil => in_right | y::ys => if lt_dec x y then in_left else if elem_in ys then in_left else in_right end in if elem_in ys then if list_in xs ys then in_left else in_right else in_right end in if list_in xs ys then in_left else in_right end end. Next Obligation. intro H0. apply H; inversion H0; subst; trivial. Defined. Next Obligation. intro H; inversion H. Defined. Next Obligation. intro H; inversion H. Defined. Next Obligation. intro H; inversion H; subst. Defined. Next Obligation. intro H1; contradict H. inversion H1; subst. assumption. contradict H0; assumption. Defined. Next Obligation. intro H1; contradict H0. inversion H1; subst. assumption. Defined. Next Obligation. intro H1; contradict H. inversion H1; subst. assumption. Defined. Next Obligation. intro H0; contradict H. inversion H0; subst; auto. Defined. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2668.v0000644000175000017500000000025112326224777021576 0ustar stephstephRequire Import MSetPositive. Require Import MSetProperties. Module Pos := MSetPositive.PositiveSet. Module PPPP := MSetProperties.WPropertiesOn(Pos). Print Module PPPP.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2262.v0000644000175000017500000000031612326224777021566 0ustar stephsteph Generalizable Variables A. Class Test A := { test : A }. Lemma mylemma : forall `{Test A}, test = test. Admitted. (* works fine *) Definition mylemma' := forall `{Test A}, test = test. About mylemma'. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1834.v0000644000175000017500000001163712326224777021602 0ustar stephsteph(* This tests rather deep nesting of abstracted terms *) (* This used to fail before Nov 2011 because of a de Bruijn indice bug in extract_predicate. Note: use of eq_ok allows shorten notations but was not in the original example *) Scheme eq_rec_dep := Induction for eq Sort Type. Section Teq. Variable P0: Type. Variable P1: forall (y0:P0), Type. Variable P2: forall y0 (y1:P1 y0), Type. Variable P3: forall y0 y1 (y2:P2 y0 y1), Type. Variable P4: forall y0 y1 y2 (y3:P3 y0 y1 y2), Type. Variable P5: forall y0 y1 y2 y3 (y4:P4 y0 y1 y2 y3), Type. Variable x0:P0. Inductive eq0 : P0 -> Prop := refl0: eq0 x0. Definition eq_0 y0 := x0 = y0. Variable x1:P1 x0. Inductive eq1 : forall y0, P1 y0 -> Prop := refl1: eq1 x0 x1. Definition S0_0 y0 (e0:eq_0 y0) := eq_rec_dep P0 x0 (fun y0 e0 => P1 y0) x1 y0 e0. Definition eq_ok0 y0 y1 (E: eq_0 y0) := S0_0 y0 E = y1. Definition eq_1 y0 y1 := {E0:eq_0 y0 | eq_ok0 y0 y1 E0}. Variable x2:P2 x0 x1. Inductive eq2 : forall y0 y1, P2 y0 y1 -> Prop := refl2: eq2 x0 x1 x2. Definition S1_0 y0 (e0:eq_0 y0) := eq_rec_dep P0 x0 (fun y0 e0 => P2 y0 (S0_0 y0 e0)) x2 y0 e0. Definition S1_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) := eq_rec_dep (P1 y0) (S0_0 y0 e0) (fun y1 e1 => P2 y0 y1) (S1_0 y0 e0) y1 e1. Definition eq_ok1 y0 y1 y2 (E: eq_1 y0 y1) := match E with exist e0 e1 => S1_1 y0 y1 e0 e1 = y2 end. Definition eq_2 y0 y1 y2 := {E1:eq_1 y0 y1 | eq_ok1 y0 y1 y2 E1}. Variable x3:P3 x0 x1 x2. Inductive eq3 : forall y0 y1 y2, P3 y0 y1 y2 -> Prop := refl3: eq3 x0 x1 x2 x3. Definition S2_0 y0 (e0:eq_0 y0) := eq_rec_dep P0 x0 (fun y0 e0 => P3 y0 (S0_0 y0 e0) (S1_0 y0 e0)) x3 y0 e0. Definition S2_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) := eq_rec_dep (P1 y0) (S0_0 y0 e0) (fun y1 e1 => P3 y0 y1 (S1_1 y0 y1 e0 e1)) (S2_0 y0 e0) y1 e1. Definition S2_2 y0 y1 y2 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) (e2:S1_1 y0 y1 e0 e1 = y2) := eq_rec_dep (P2 y0 y1) (S1_1 y0 y1 e0 e1) (fun y2 e2 => P3 y0 y1 y2) (S2_1 y0 y1 e0 e1) y2 e2. Definition eq_ok2 y0 y1 y2 y3 (E: eq_2 y0 y1 y2) : Prop := match E with exist (exist e0 e1) e2 => S2_2 y0 y1 y2 e0 e1 e2 = y3 end. Definition eq_3 y0 y1 y2 y3 := {E2: eq_2 y0 y1 y2 | eq_ok2 y0 y1 y2 y3 E2}. Variable x4:P4 x0 x1 x2 x3. Inductive eq4 : forall y0 y1 y2 y3, P4 y0 y1 y2 y3 -> Prop := refl4: eq4 x0 x1 x2 x3 x4. Definition S3_0 y0 (e0:eq_0 y0) := eq_rec_dep P0 x0 (fun y0 e0 => P4 y0 (S0_0 y0 e0) (S1_0 y0 e0) (S2_0 y0 e0)) x4 y0 e0. Definition S3_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) := eq_rec_dep (P1 y0) (S0_0 y0 e0) (fun y1 e1 => P4 y0 y1 (S1_1 y0 y1 e0 e1) (S2_1 y0 y1 e0 e1)) (S3_0 y0 e0) y1 e1. Definition S3_2 y0 y1 y2 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) (e2:S1_1 y0 y1 e0 e1 = y2) := eq_rec_dep (P2 y0 y1) (S1_1 y0 y1 e0 e1) (fun y2 e2 => P4 y0 y1 y2 (S2_2 y0 y1 y2 e0 e1 e2)) (S3_1 y0 y1 e0 e1) y2 e2. Definition S3_3 y0 y1 y2 y3 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) (e2:S1_1 y0 y1 e0 e1 = y2) (e3:S2_2 y0 y1 y2 e0 e1 e2 = y3):= eq_rec_dep (P3 y0 y1 y2) (S2_2 y0 y1 y2 e0 e1 e2) (fun y3 e3 => P4 y0 y1 y2 y3) (S3_2 y0 y1 y2 e0 e1 e2) y3 e3. Definition eq_ok3 y0 y1 y2 y3 y4 (E: eq_3 y0 y1 y2 y3) : Prop := match E with exist (exist (exist e0 e1) e2) e3 => S3_3 y0 y1 y2 y3 e0 e1 e2 e3 = y4 end. Definition eq_4 y0 y1 y2 y3 y4 := {E3: eq_3 y0 y1 y2 y3 | eq_ok3 y0 y1 y2 y3 y4 E3}. Variable x5:P5 x0 x1 x2 x3 x4. Inductive eq5 : forall y0 y1 y2 y3 y4, P5 y0 y1 y2 y3 y4 -> Prop := refl5: eq5 x0 x1 x2 x3 x4 x5. Definition S4_0 y0 (e0:eq_0 y0) := eq_rec_dep P0 x0 (fun y0 e0 => P5 y0 (S0_0 y0 e0) (S1_0 y0 e0) (S2_0 y0 e0) (S3_0 y0 e0)) x5 y0 e0. Definition S4_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) := eq_rec_dep (P1 y0) (S0_0 y0 e0) (fun y1 e1 => P5 y0 y1 (S1_1 y0 y1 e0 e1) (S2_1 y0 y1 e0 e1) (S3_1 y0 y1 e0 e1)) (S4_0 y0 e0) y1 e1. Definition S4_2 y0 y1 y2 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) (e2:S1_1 y0 y1 e0 e1 = y2) := eq_rec_dep (P2 y0 y1) (S1_1 y0 y1 e0 e1) (fun y2 e2 => P5 y0 y1 y2 (S2_2 y0 y1 y2 e0 e1 e2) (S3_2 y0 y1 y2 e0 e1 e2)) (S4_1 y0 y1 e0 e1) y2 e2. Definition S4_3 y0 y1 y2 y3 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) (e2:S1_1 y0 y1 e0 e1 = y2) (e3:S2_2 y0 y1 y2 e0 e1 e2 = y3):= eq_rec_dep (P3 y0 y1 y2) (S2_2 y0 y1 y2 e0 e1 e2) (fun y3 e3 => P5 y0 y1 y2 y3 (S3_3 y0 y1 y2 y3 e0 e1 e2 e3)) (S4_2 y0 y1 y2 e0 e1 e2) y3 e3. Definition S4_4 y0 y1 y2 y3 y4 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) (e2:S1_1 y0 y1 e0 e1 = y2) (e3:S2_2 y0 y1 y2 e0 e1 e2 = y3) (e4:S3_3 y0 y1 y2 y3 e0 e1 e2 e3 = y4) := eq_rec_dep (P4 y0 y1 y2 y3) (S3_3 y0 y1 y2 y3 e0 e1 e2 e3) (fun y4 e4 => P5 y0 y1 y2 y3 y4) (S4_3 y0 y1 y2 y3 e0 e1 e2 e3) y4 e4. Definition eq_ok4 y0 y1 y2 y3 y4 y5 (E: eq_4 y0 y1 y2 y3 y4) : Prop := match E with exist (exist (exist (exist e0 e1) e2) e3) e4 => S4_4 y0 y1 y2 y3 y4 e0 e1 e2 e3 e4 = y5 end. Definition eq_5 y0 y1 y2 y3 y4 y5 := {E4: eq_4 y0 y1 y2 y3 y4 | eq_ok4 y0 y1 y2 y3 y4 y5 E4 }. End Teq. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1773.v0000644000175000017500000000035212326224777021574 0ustar stephsteph(* An occur-check test was done too early *) Goal forall B C : nat -> nat -> Prop, forall k, (exists A, (forall k', C A k' -> B A k') -> B A k). Proof. intros B C k. econstructor. intros X. apply X. (* used to fail here *) coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1905.v0000644000175000017500000000033512326224777021572 0ustar stephsteph Require Import Setoid Program. Axiom t : Set. Axiom In : nat -> t -> Prop. Axiom InE : forall (x : nat) (s:t), impl (In x s) True. Goal forall a s, In a s -> False. Proof. intros a s Ia. rewrite InE in Ia. Admitted.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2127.v0000644000175000017500000000035612326224777021572 0ustar stephsteph(* Check that "apply eq_refl" is not exported as an interactive tactic but as a statically globalized one *) (* (this is a simplification of the original bug report) *) Module A. Hint Rewrite eq_sym using apply eq_refl : foo. End A. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2230.v0000644000175000017500000000014112326224777021555 0ustar stephstephGoal forall f, f 1 1 -> True. intros. match goal with | [ H : _ ?a |- _ ] => idtac end. Abort. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1711.v0000644000175000017500000000175612326224777021575 0ustar stephsteph(* Test for evar map consistency - was failing at some point and was *) (* assumed to be solved from revision 10151 (but using a bad fix) *) Require Import List. Set Implicit Arguments. Inductive rose : Set := Rose : nat -> list rose -> rose. Section RoseRec. Variables (P: rose -> Set)(L: list rose -> Set). Hypothesis (R: forall n rs, L rs -> P (Rose n rs)) (Lnil: L nil) (Lcons: forall r rs, P r -> L rs -> L (cons r rs)). Fixpoint rose_rec2 (t:rose) {struct t} : P t := match t as x return P x with | Rose n rs => R n ((fix rs_ind (l' : list rose): L l' := match l' as x return L x with | nil => Lnil | cons t tl => Lcons (rose_rec2 t) (rs_ind tl) end) rs) end. End RoseRec. Lemma rose_map : rose -> rose. Proof. intro H; elim H using rose_rec2 with (L:=fun _ => list rose); (* was assumed to fail here *) (* (L:=fun (_:list rose) => list rose); *) clear H; simpl; intros. exact (Rose n rs). exact nil. exact (H::H0). Defined. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2837.v0000644000175000017500000000062312326224777021577 0ustar stephstephRequire Import JMeq. Axiom test : forall n m : nat, JMeq n m. Goal forall n m : nat, JMeq n m. (* I) with no intros nor variable hints, this should produce a regular error instead of Uncaught exception Failure("nth"). *) Fail rewrite test. (* II) with intros but indication of variables, still an error *) Fail (intros; rewrite test). (* III) a working variant: *) intros; rewrite (test n m).coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1414.v0000644000175000017500000000224212326224777021564 0ustar stephstephRequire Import ZArith Coq.Program.Wf Coq.Program.Utils. Parameter data:Set. Inductive t : Set := | Leaf : t | Node : t -> data -> t -> Z -> t. Parameter avl : t -> Prop. Parameter bst : t -> Prop. Parameter In : data -> t -> Prop. Parameter cardinal : t -> nat. Definition card2 (s:t*t) := let (s1,s2) := s in cardinal s1 + cardinal s2. Parameter split : data -> t -> t*(bool*t). Parameter join : t -> data -> t -> t. Parameter add : data -> t -> t. Program Fixpoint union (s u:t) (hb1: bst s)(ha1: avl s)(hb2: bst u)(hb2: avl u) { measure (cardinal s + cardinal u) } : {s' : t | bst s' /\ avl s' /\ forall x, In x s' <-> In x s \/ In x u} := match s, u with | Leaf,t2 => t2 | t1,Leaf => t1 | Node l1 v1 r1 h1, Node l2 v2 r2 h2 => if (Z_ge_lt_dec h1 h2) then if (Z.eq_dec h2 1) then add v2 s else let (l2', r2') := split v1 u in join (union l1 l2' _ _ _ _) v1 (union r1 (snd r2') _ _ _ _) else if (Z.eq_dec h1 1) then add v1 s else let (l1', r1') := split v2 u in join (union l1' l2 _ _ _ _) v2 (union (snd r1') r2 _ _ _ _) end. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/3000.v0000644000175000017500000000016012326224777021552 0ustar stephstephInductive t (t':Type) : Type := A | B. Definition d := match t with _ => 1 end. (* used to fail on list_chop *) coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2473.v0000644000175000017500000000205412326224777021573 0ustar stephsteph Require Import Relations Program Setoid Morphisms. Section S1. Variable R: nat -> relation bool. Instance HR1: forall n, Transitive (R n). Admitted. Instance HR2: forall n, Symmetric (R n). Admitted. Hypothesis H: forall n a, R n (andb a a) a. Goal forall n a b, R n b a. intros. (* rewrite <- H. *) (* Anomaly: Evar ?.. was not declared. Please report. *) (* idem with setoid_rewrite *) (* assert (HR2' := HR2 n). *) rewrite <- H. (* ok *) admit. Qed. End S1. Section S2. Variable R: nat -> relation bool. Instance HR: forall n, Equivalence (R n). Admitted. Hypothesis H: forall n a, R n (andb a a) a. Goal forall n a b, R n a b. intros. rewrite <- H. admit. Qed. End S2. (* the parametrised relation is required to get the problem *) Section S3. Variable R: relation bool. Instance HR1': Transitive R. Admitted. Instance HR2': Symmetric R. Admitted. Hypothesis H: forall a, R (andb a a) a. Goal forall a b, R b a. intros. rewrite <- H. (* ok *) admit. Qed. End S3.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1425.v0000644000175000017500000000074112326224777021570 0ustar stephstephRequire Import Setoid. Parameter recursion : forall A : Set, A -> (nat -> A -> A) -> nat -> A. Axiom recursion_S : forall (A : Set) (EA : relation A) (a : A) (f : nat -> A -> A) (n : nat), EA (recursion A a f (S n)) (f n (recursion A a f n)). Goal forall n : nat, recursion nat 0 (fun _ _ => 1) (S n) = 1. intro n. rewrite recursion_S. reflexivity. Qed. Goal forall n : nat, recursion nat 0 (fun _ _ => 1) (S n) = 1. intro n. setoid_rewrite recursion_S. reflexivity. Qed.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1901.v0000644000175000017500000000045512326224777021571 0ustar stephstephRequire Import Relations. Record Poset{A:Type}(Le : relation A) : Type := Build_Poset { Le_refl : forall x : A, Le x x; Le_trans : forall x y z : A, Le x y -> Le y z -> Le x z; Le_antisym : forall x y : A, Le x y -> Le y x -> x = y }. Definition nat_Poset : Poset Peano.le. Admitted.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/3008.v0000644000175000017500000000123012326224777021561 0ustar stephstephModule Type Intf1. Parameter T : Type. Inductive a := A. End Intf1. Module Impl1 <: Intf1. Definition T := unit. Inductive a := A. End Impl1. Module Type Intf2 (Impl1 : Intf1). Parameter x : Impl1.A=Impl1.A -> Impl1.T. End Intf2. Module Type Intf3 (Impl1 : Intf1) (Impl2 : Intf2(Impl1)). End Intf3. Fail Module Toto (Impl1' : Intf1) (Impl2 : Intf2(Impl1')) (Impl3 : Intf3(Impl1)(Impl2)). (* A UserError is expected here, not an uncaught Not_found *) (* NB : the Inductive above and the A=A weren't in the initial test, they are here only to force an access to the environment (cf [Printer.qualid_of_global]) and check that this env is ok. *)coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1925.v0000644000175000017500000000133312326224777021573 0ustar stephsteph(* Check that the analysis of projectable rel's in an evar instance is up to aliases *) Require Import List. Definition compose (A B C : Type) (g : B -> C) (f : A -> B) : A -> C := fun x : A => g(f x). Definition map_fuse' : forall (A B C : Type) (g : B -> C) (f : A -> B) (xs : list A), (map g (map f xs)) = map (compose _ _ _ g f) xs := fun A B C g f => (fix loop (ys : list A) {struct ys} := match ys as ys return (map g (map f ys)) = map (compose _ _ _ g f) ys with | nil => refl_equal nil | x :: xs => match loop xs in eq _ a return eq _ ((g (f x)) :: a) with | refl_equal => refl_equal (map g (map f (x :: xs))) end end). coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1981.v0000644000175000017500000000014712326224777021577 0ustar stephstephImplicit Arguments ex_intro [A]. Goal exists n : nat, True. eapply ex_intro. exact 0. exact I. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2001.v0000644000175000017500000000054312326224777021557 0ustar stephsteph(* Automatic computing of guard in "Theorem with"; check that guard is not computed when the user explicitly indicated it *) Unset Automatic Introduction. Inductive T : Set := | v : T. Definition f (s:nat) (t:T) : nat. fix 2. intros s t. refine match t with | v => s end. Defined. Lemma test : forall s, f s v = s. Proof. reflexivity. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2123.v0000644000175000017500000000045112326224777021562 0ustar stephsteph(* About the detection of non-dependent metas by the refine tactic *) (* The following is a simplification of bug #2123 *) Parameter fset : nat -> Set. Parameter widen : forall (n : nat) (s : fset n), { x : fset (S n) | s=s }. Goal forall i, fset (S i). intro. refine (proj1_sig (widen i _)). coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1918.v0000644000175000017500000002203712326224777021601 0ustar stephsteph(** Occur-check for Meta (up to delta) *) (** LNMItPredShort.v Version 2.0 July 2008 *) (** does not need impredicative Set, runs under V8.2, tested with SVN 11296 *) (** Copyright Ralph Matthes, I.R.I.T., C.N.R.S. & University of Toulouse*) Set Implicit Arguments. (** the universe of all monotypes *) Definition k0 := Set. (** the type of all type transformations *) Definition k1 := k0 -> k0. (** the type of all rank-2 type transformations *) Definition k2 := k1 -> k1. (** polymorphic identity *) Definition id : forall (A:Set), A -> A := fun A x => x. (** composition *) Definition comp (A B C:Set)(g:B->C)(f:A->B) : A->C := fun x => g (f x). Infix "o" := comp (at level 90). Definition sub_k1 (X Y:k1) : Type := forall A:Set, X A -> Y A. Infix "c_k1" := sub_k1 (at level 60). (** monotonicity *) Definition mon (X:k1) : Type := forall (A B:Set), (A -> B) -> X A -> X B. (** extensionality *) Definition ext (X:k1)(h: mon X): Prop := forall (A B:Set)(f g:A -> B), (forall a, f a = g a) -> forall r, h _ _ f r = h _ _ g r. (** first functor law *) Definition fct1 (X:k1)(m: mon X) : Prop := forall (A:Set)(x:X A), m _ _ (id(A:=A)) x = x. (** second functor law *) Definition fct2 (X:k1)(m: mon X) : Prop := forall (A B C:Set)(f:A -> B)(g:B -> C)(x:X A), m _ _ (g o f) x = m _ _ g (m _ _ f x). (** pack up the good properties of the approximation into the notion of an extensional functor *) Record EFct (X:k1) : Type := mkEFct { m : mon X; e : ext m; f1 : fct1 m; f2 : fct2 m }. (** preservation of extensional functors *) Definition pEFct (F:k2) : Type := forall (X:k1), EFct X -> EFct (F X). (** we show some closure properties of pEFct, depending on such properties for EFct *) Definition moncomp (X Y:k1)(mX:mon X)(mY:mon Y): mon (fun A => X(Y A)). Proof. red. intros A B f x. exact (mX (Y A)(Y B) (mY A B f) x). Defined. (** closure under composition *) Lemma compEFct (X Y:k1): EFct X -> EFct Y -> EFct (fun A => X(Y A)). Proof. intros ef1 ef2. apply (mkEFct(m:=moncomp (m ef1) (m ef2))); red; intros; unfold moncomp. (* prove ext *) apply (e ef1). intro. apply (e ef2); trivial. (* prove fct1 *) rewrite (e ef1 (m ef2 (id (A:=A))) (id(A:=Y A))). apply (f1 ef1). intro. apply (f1 ef2). (* prove fct2 *) rewrite (e ef1 (m ef2 (g o f))((m ef2 g)o(m ef2 f))). apply (f2 ef1). intro. unfold comp at 2. apply (f2 ef2). Defined. Corollary comppEFct (F G:k2): pEFct F -> pEFct G -> pEFct (fun X A => F X (G X A)). Proof. red. intros. apply compEFct; auto. Defined. (** closure under sums *) Lemma sumEFct (X Y:k1): EFct X -> EFct Y -> EFct (fun A => X A + Y A)%type. Proof. intros ef1 ef2. set (m12:=fun (A B:Set)(f:A->B) x => match x with | inl y => inl _ (m ef1 f y) | inr y => inr _ (m ef2 f y) end). apply (mkEFct(m:=m12)); red; intros. (* prove ext *) destruct r. simpl. apply (f_equal (fun x=>inl (A:=X B) (Y B) x)). apply (e ef1); trivial. simpl. apply (f_equal (fun x=>inr (X B) (B:=Y B) x)). apply (e ef2); trivial. (* prove fct1 *) destruct x. simpl. apply (f_equal (fun x=>inl (A:=X A) (Y A) x)). apply (f1 ef1). simpl. apply (f_equal (fun x=>inr (X A) (B:=Y A) x)). apply (f1 ef2). (* prove fct2 *) destruct x. simpl. rewrite (f2 ef1); reflexivity. simpl. rewrite (f2 ef2); reflexivity. Defined. Corollary sumpEFct (F G:k2): pEFct F -> pEFct G -> pEFct (fun X A => F X A + G X A)%type. Proof. red. intros. apply sumEFct; auto. Defined. (** closure under products *) Lemma prodEFct (X Y:k1): EFct X -> EFct Y -> EFct (fun A => X A * Y A)%type. Proof. intros ef1 ef2. set (m12:=fun (A B:Set)(f:A->B) x => match x with (x1,x2) => (m ef1 f x1, m ef2 f x2) end). apply (mkEFct(m:=m12)); red; intros. (* prove ext *) destruct r as [x1 x2]. simpl. apply injective_projections; simpl. apply (e ef1); trivial. apply (e ef2); trivial. (* prove fct1 *) destruct x as [x1 x2]. simpl. apply injective_projections; simpl. apply (f1 ef1). apply (f1 ef2). (* prove fct2 *) destruct x as [x1 x2]. simpl. apply injective_projections; simpl. apply (f2 ef1). apply (f2 ef2). Defined. Corollary prodpEFct (F G:k2): pEFct F -> pEFct G -> pEFct (fun X A => F X A * G X A)%type. Proof. red. intros. apply prodEFct; auto. Defined. (** the identity in k2 preserves extensional functors *) Lemma idpEFct: pEFct (fun X => X). Proof. red. intros. assumption. Defined. (** a variant for the eta-expanded identity *) Lemma idpEFct_eta: pEFct (fun X A => X A). Proof. red. intros X ef. destruct ef as [m0 e0 f01 f02]. change (mon X) with (mon (fun A => X A)) in m0. apply (mkEFct (m:=m0) e0 f01 f02). Defined. (** the identity in k1 "is" an extensional functor *) Lemma idEFct: EFct (fun A => A). Proof. set (mId:=fun A B (f:A->B)(x:A) => f x). apply (mkEFct(m:=mId)). red. intros. unfold mId. apply H. red. reflexivity. red. reflexivity. Defined. (** constants in k2 *) Lemma constpEFct (X:k1): EFct X -> pEFct (fun _ => X). Proof. red. intros. assumption. Defined. (** constants in k1 *) Lemma constEFct (C:Set): EFct (fun _ => C). Proof. set (mC:=fun A B (f:A->B)(x:C) => x). apply (mkEFct(m:=mC)); red; intros; unfold mC; reflexivity. Defined. (** the option type *) Lemma optionEFct: EFct (fun (A:Set) => option A). apply (mkEFct (X:=fun (A:Set) => option A)(m:=option_map)); red; intros. destruct r. simpl. rewrite H. reflexivity. reflexivity. destruct x; reflexivity. destruct x; reflexivity. Defined. (** natural transformations from (X,mX) to (Y,mY) *) Definition NAT(X Y:k1)(j:X c_k1 Y)(mX:mon X)(mY:mon Y) : Prop := forall (A B:Set)(f:A->B)(t:X A), j B (mX A B f t) = mY _ _ f (j A t). Module Type LNMIt_Type. Parameter F:k2. Parameter FpEFct: pEFct F. Parameter mu20: k1. Definition mu2: k1:= fun A => mu20 A. Parameter mapmu2: mon mu2. Definition MItType: Type := forall G : k1, (forall X : k1, X c_k1 G -> F X c_k1 G) -> mu2 c_k1 G. Parameter MIt0 : MItType. Definition MIt : MItType:= fun G s A t => MIt0 s t. Definition InType : Type := forall (X:k1)(ef:EFct X)(j: X c_k1 mu2), NAT j (m ef) mapmu2 -> F X c_k1 mu2. Parameter In : InType. Axiom mapmu2Red : forall (A:Set)(X:k1)(ef:EFct X)(j: X c_k1 mu2) (n: NAT j (m ef) mapmu2)(t: F X A)(B:Set)(f:A->B), mapmu2 f (In ef n t) = In ef n (m (FpEFct ef) f t). Axiom MItRed : forall (G : k1) (s : forall X : k1, X c_k1 G -> F X c_k1 G)(X : k1)(ef:EFct X)(j: X c_k1 mu2) (n: NAT j (m ef) mapmu2)(A:Set)(t:F X A), MIt s (In ef n t) = s X (fun A => (MIt s (A:=A)) o (j A)) A t. Definition mu2IndType : Prop := forall (P : (forall A : Set, mu2 A -> Prop)), (forall (X : k1)(ef:EFct X)(j : X c_k1 mu2)(n: NAT j (m ef) mapmu2), (forall (A : Set) (x : X A), P A (j A x)) -> forall (A:Set)(t : F X A), P A (In ef n t)) -> forall (A : Set) (r : mu2 A), P A r. Axiom mu2Ind : mu2IndType. End LNMIt_Type. (** BushDepPredShort.v Version 0.2 July 2008 *) (** does not need impredicative Set, produces stack overflow under V8.2, tested with SVN 11296 *) (** Copyright Ralph Matthes, I.R.I.T., C.N.R.S. & University of Toulouse *) Set Implicit Arguments. Require Import List. Definition listk1 (A:Set) : Set := list A. Open Scope type_scope. Definition BushF(X:k1)(A:Set) := unit + A * X (X A). Definition bushpEFct : pEFct BushF. Proof. unfold BushF. apply sumpEFct. apply constpEFct. apply constEFct. apply prodpEFct. apply constpEFct. apply idEFct. apply comppEFct. apply idpEFct. apply idpEFct_eta. Defined. Module Type BUSH := LNMIt_Type with Definition F:=BushF with Definition FpEFct := bushpEFct. Module Bush (BushBase:BUSH). Definition Bush : k1 := BushBase.mu2. Definition bush : mon Bush := BushBase.mapmu2. End Bush. Definition Id : k1 := fun X => X. Fixpoint Pow (X:k1)(k:nat){struct k}:k1:= match k with 0 => Id | S k' => fun A => X (Pow X k' A) end. Fixpoint POW (k:nat)(X:k1)(m:mon X){struct k} : mon (Pow X k) := match k return mon (Pow X k) with 0 => fun _ _ f => f | S k' => fun _ _ f => m _ _ (POW k' m f) end. Module Type BushkToList_Type. Declare Module Import BP: BUSH. Definition F:=BushF. Definition FpEFct:= bushpEFct. Definition mu20 := mu20. Definition mu2 := mu2. Definition mapmu2 := mapmu2. Definition MItType:= MItType. Definition MIt0 := MIt0. Definition MIt := MIt. Definition InType := InType. Definition In := In. Definition mapmu2Red:=mapmu2Red. Definition MItRed:=MItRed. Definition mu2IndType:=mu2IndType. Definition mu2Ind:=mu2Ind. Definition Bush:= mu2. Module BushM := Bush BP. Parameter BushkToList: forall(k:nat)(A:k0)(t:Pow Bush k A), list A. Axiom BushkToList0: forall(A:k0)(t:Pow Bush 0 A), BushkToList 0 A t = t::nil. End BushkToList_Type. Module BushDep (BushkToListM:BushkToList_Type). Module Bush := Bush BushkToListM. Import Bush. Import BushkToListM. Lemma BushkToList0NAT: NAT(Y:=listk1) (BushkToList 0) (POW 0 bush) map. Proof. red. intros. simpl. rewrite BushkToList0. (* stack overflow for coqc and coqtop *) Abort. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1683.v0000644000175000017500000000174312326224777021601 0ustar stephstephRequire Import Setoid. Section SetoidBug. Variable ms : Type. Variable ms_type : ms -> Type. Variable ms_eq : forall (A:ms), relation (ms_type A). Variable CR : ms. Record Ring : Type := {Ring_type : Type}. Variable foo : forall (A:Ring), nat -> Ring_type A. Variable IR : Ring. Variable IRasCR : Ring_type IR -> ms_type CR. Definition CRasCRing : Ring := Build_Ring (ms_type CR). Hypothesis ms_refl : forall A x, ms_eq A x x. Hypothesis ms_sym : forall A x y, ms_eq A x y -> ms_eq A y x. Hypothesis ms_trans : forall A x y z, ms_eq A x y -> ms_eq A y z -> ms_eq A x z. Add Parametric Relation A : (ms_type A) (ms_eq A) reflexivity proved by (ms_refl A) symmetry proved by (ms_sym A) transitivity proved by (ms_trans A) as ms_Setoid. Hypothesis foobar : forall n, ms_eq CR (IRasCR (foo IR n)) (foo CRasCRing n). Goal forall (b:ms_type CR), ms_eq CR (IRasCR (foo IR O)) b -> ms_eq CR (IRasCR (foo IR O)) b. intros b H. rewrite foobar. rewrite foobar in H. assumption. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2817.v0000644000175000017500000000044312326224777021575 0ustar stephsteph(** Occur-check for Meta (up to application of already known instances) *) Goal forall (f: nat -> nat -> Prop) (x:bool) (H: forall (u: nat), f u u -> True) (H0: forall x0, f (if x then x0 else x0) x0), False. intros. Fail apply H in H0. (* should fail without exhausting the stack *) coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2608.v0000644000175000017500000000166412326224777021601 0ustar stephsteph Module Type T. Parameter Inline t : Type. End T. Module M. Definition t := nat. End M. Module Make (X:T). Include X. (* here t is : (Top.Make.t,Top.X.t) *) (* in libobject HEAD : EvalConstRef (Top.X.t,Top.X.t) which is substituted by : {Top.X |-> Top.Make [, Top.Make.t=>Top.X.t]} which gives : EvalConstRef (Top.Make.t,Top.X.t) *) End Make. Module P := Make M. (* resolver returned by add_module : Top.P.t=>inline *) (* then constant_of_delta_kn P.t produces (Top.P.t,Top.P.t) *) (* in libobject HEAD : EvalConstRef (Top.Make.t,Top.X.t) given to subst = { |-> Top.M [, Top.M.t=>inline]} which used to give : EvalConstRef (Top.Make.t,Top.M.t) given to subst = {Top.Make |-> Top.P [, Top.P.t=>inline]} which used to give : EvalConstRef (Top.P.t,Top.M.t) *) Definition u := P.t. (* was raising Not_found since Heads.head_map knows of (Top.P.t,Top.M.t) and not of (Top.P.t,Top.P.t) *) coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1775.v0000644000175000017500000000177012326224777021603 0ustar stephstephAxiom pair : nat -> nat -> nat -> Prop. Axiom pl : (nat -> Prop) -> (nat -> Prop) -> (nat -> Prop). Axiom plImp : forall k P Q, pl P Q k -> forall (P':nat -> Prop), (forall k', P k' -> P' k') -> forall (Q':nat -> Prop), (forall k', Q k' -> Q' k') -> pl P' Q' k. Definition nexists (P:nat -> nat -> Prop) : nat -> Prop := fun k' => exists k, P k k'. Goal forall s k k' m, (pl k' (nexists (fun w => (nexists (fun b => pl (pair w w) (pl (pair s b) (nexists (fun w0 => (nexists (fun a => pl (pair b w0) (nexists (fun w1 => (nexists (fun c => pl (pair a w1) (pl (pair a c) k))))))))))))))) m. intros. eapply plImp; [ | eauto | intros ]. 2:econstructor. 2:econstructor. 2:eapply plImp; [ | eauto | intros ]. 3:eapply plImp; [ | eauto | intros ]. 4:econstructor. 4:econstructor. 4:eapply plImp; [ | eauto | intros ]. 5:econstructor. 5:econstructor. 5:eauto. 4:eauto. 3:eauto. 2:eauto. assert (X := 1). clear X. (* very slow! *) simpl. (* exception Not_found *) Admitted. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1477.v0000644000175000017500000000047012326224777021576 0ustar stephstephInductive I : Set := | A : nat -> nat -> I | B : nat -> nat -> I. Definition foo1 (x:I) : nat := match x with | A a b | B a b => S b end. Definition foo2 (x:I) : nat := match x with | A _ b | B b _ => S b end. Definition foo (x:I) : nat := match x with | A a b | B b a => S b end. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2136.v0000644000175000017500000000272612326224777021575 0ustar stephsteph(* Bug #2136 The fsetdec tactic seems to get confused by hypotheses like HeqH1 : H1 = MkEquality s0 s1 b If I clear them then it is able to solve my goal; otherwise it is not. I would expect it to be able to solve the goal even without this hypothesis being cleared. A small, self-contained example is below. I have coq r12238. Thanks Ian *) Require Import FSets. Require Import Arith. Require Import FSetWeakList. Module DecidableNat. Definition t := nat. Definition eq := @eq nat. Definition eq_refl := @refl_equal nat. Definition eq_sym := @sym_eq nat. Definition eq_trans := @trans_eq nat. Definition eq_dec := eq_nat_dec. End DecidableNat. Module NatSet := Make(DecidableNat). Module Export Dec := WDecide (NatSet). Import FSetDecideAuxiliary. Parameter MkEquality : forall ( s0 s1 : NatSet.t ) ( x : nat ), NatSet.Equal s1 (NatSet.add x s0). Lemma ThisLemmaWorks : forall ( s0 s1 : NatSet.t ) ( a b : nat ), NatSet.In a s0 -> NatSet.In a s1. Proof. intros. remember (MkEquality s0 s1 b) as H1. clear HeqH1. fsetdec. Qed. Lemma ThisLemmaWasFailing : forall ( s0 s1 : NatSet.t ) ( a b : nat ), NatSet.In a s0 -> NatSet.In a s1. Proof. intros. remember (MkEquality s0 s1 b) as H1. fsetdec. (* Error: Tactic failure: because the goal is beyond the scope of this tactic. *) Qed.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1568.v0000644000175000017500000000027112326224777021576 0ustar stephstephCoInductive A: Set := mk_A: B -> A with B: Set := mk_B: A -> B. CoFixpoint a:A := mk_A b with b:B := mk_B a. Goal b = match a with mk_A a1 => a1 end. simpl. reflexivity. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2733.v0000644000175000017500000000153712326224777021577 0ustar stephstephDefinition goodid : forall {A} (x: A), A := fun A x => x. Definition wrongid : forall A (x: A), A := fun {A} x => x. Inductive ty := N | B. Inductive alt_list : ty -> ty -> Type := | nil {k} : alt_list k k | Ncons {k} : nat -> alt_list B k -> alt_list N k | Bcons {k} : bool -> alt_list N k -> alt_list B k. Definition trullynul k {k'} (l : alt_list k k') := match k,l with |N,l' => Ncons 0 (Bcons true l') |B,l' => Bcons true (Ncons 0 l') end. Fixpoint app (P : forall {k k'}, alt_list k k' -> alt_list k k') {t1 t2} (l : alt_list t1 t2) {struct l}: forall {t3}, alt_list t2 t3 -> alt_list t1 t3 := match l with | nil _ => fun _ l2 => P l2 | Ncons _ n l1 => fun _ l2 => Ncons n (app (@P) l1 l2) | Bcons _ b l1 => fun _ l2 => Bcons b (app (@P) l1 l2) end. Check (fun {t t'} (l: alt_list t t') => app trullynul (goodid l) (wrongid _ nil)). coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1774.v0000644000175000017500000000100012326224777021564 0ustar stephstephAxiom pl : (nat -> Prop) -> (nat -> Prop) -> (nat -> Prop). Axiom plImp : forall k P Q, pl P Q k -> forall (P':nat -> Prop), (forall k', P k' -> P' k') -> forall (Q':nat -> Prop), (forall k', Q k' -> Q' k') -> pl P' Q' k. Definition nexists (P:nat -> nat -> Prop) : nat -> Prop := fun k' => exists k, P k k'. Goal forall k (A:nat -> nat -> Prop) (B:nat -> Prop), pl (nexists A) B k. intros. eapply plImp. 2:intros m' M'; econstructor; apply M'. 2:intros m' M'; apply M'. simpl. Admitted. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2836.v0000644000175000017500000000251512326224777021600 0ustar stephsteph(* Check that possible instantiation made during evar materialization are taken into account and do not raise Not_found *) Set Implicit Arguments. Record SpecializedCategory (obj : Type) (Morphism : obj -> obj -> Type) := { Object :> _ := obj; Identity' : forall o, Morphism o o; Compose' : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' }. Section SpecializedCategoryInterface. Variable obj : Type. Variable mor : obj -> obj -> Type. Variable C : @SpecializedCategory obj mor. Definition Morphism (s d : C) := mor s d. Definition Identity (o : C) : Morphism o o := C.(Identity') o. Definition Compose (s d d' : C) (m : Morphism d d') (m0 : Morphism s d) : Morphism s d' := C.(Compose') s d d' m m0. End SpecializedCategoryInterface. Section ProductCategory. Variable objC : Type. Variable morC : objC -> objC -> Type. Variable objD : Type. Variable morD : objD -> objD -> Type. Variable C : SpecializedCategory morC. Variable D : SpecializedCategory morD. (* Should fail nicely *) Definition ProductCategory : @SpecializedCategory (objC * objD)%type (fun s d => (morC (fst s) (fst d) * morD (snd s) (snd d))%type). Fail refine {| Identity' := (fun o => (Identity (fst o), Identity (snd o))); Compose' := (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1))) |}. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2347.v0000644000175000017500000000054012326224777021571 0ustar stephstephRequire Import EquivDec List. Generalizable All Variables. Program Definition list_eqdec `(eqa : EqDec A eq) : EqDec (list A) eq := (fun (x y : list A) => _). Admit Obligations of list_eqdec. Program Definition list_eqdec' `(eqa : EqDec A eq) : EqDec (list A) eq := (fun _ : nat => (fun (x y : list A) => _)) 0. Admit Obligations of list_eqdec'. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2304.v0000644000175000017500000000022112326224777021556 0ustar stephsteph(* This used to fail with an anomaly NotASort at some time *) Class A (O: Type): Type := a: O -> Type. Fail Goal forall (x: a tt), @a x = @a x. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2244.v0000644000175000017500000000101012326224777021556 0ustar stephsteph(* 1st-order unification did not work when in competition with pattern unif. *) Set Implicit Arguments. Lemma test : forall (A : Type) (B : Type) (f : A -> B) (S : B -> Prop) (EV : forall y (f':A->B), (forall x', S (f' x')) -> S (f y)) (HS : forall x', S (f x')) (x : A), S (f x). Proof. intros. eapply EV. intros. (* worked in v8.2 but not in v8.3beta, fixed in r12898 *) apply HS. (* still not compatible with 8.2 because an evar can be solved in two different ways and is left open *) coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2141.v0000644000175000017500000000047512326224777021570 0ustar stephstephRequire Import FSetList. Require Import OrderedTypeEx. Module NatSet := FSetList.Make (Nat_as_OT). Recursive Extraction NatSet.fold. Module FSetHide (X : FSetInterface.S). Include X. End FSetHide. Module NatSet' := FSetHide NatSet. Recursive Extraction NatSet'.fold. (* Extraction "test2141.ml" NatSet'.fold. *)coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1614.v0000644000175000017500000000074712326224777021576 0ustar stephstephRequire Import Ring. Require Import ArithRing. Fixpoint eq_nat_bool (x y : nat) {struct x} : bool := match x, y with | 0, 0 => true | S x', S y' => eq_nat_bool x' y' | _, _ => false end. Theorem eq_nat_bool_implies_eq : forall x y, eq_nat_bool x y = true -> x = y. Proof. induction x; destruct y; simpl; intro H; try (reflexivity || inversion H). apply IHx in H; rewrite H; reflexivity. Qed. Add Ring MyNatSRing : natSRth (decidable eq_nat_bool_implies_eq). Goal 0 = 0. ring. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1791.v0000644000175000017500000000146712326224777021604 0ustar stephsteph(* simpl performs eta expansion *) Set Implicit Arguments. Require Import List. Definition k0 := Set. Definition k1 := k0 -> k0. (** iterating X n times *) Fixpoint Pow (X:k1)(k:nat){struct k}:k1:= match k with 0 => fun X => X | S k' => fun A => X (Pow X k' A) end. Parameter Bush: k1. Parameter BushToList: forall (A:k0), Bush A -> list A. Definition BushnToList (n:nat)(A:k0)(t:Pow Bush n A): list A. Proof. intros. induction n. exact (t::nil). simpl in t. exact (flat_map IHn (BushToList t)). Defined. Parameter bnil : forall (A:k0), Bush A. Axiom BushToList_bnil: forall (A:k0), BushToList (bnil A) = nil(A:=A). Lemma BushnToList_bnil (n:nat)(A:k0): BushnToList (S n) A (bnil (Pow Bush n A)) = nil. Proof. intros. simpl. rewrite BushToList_bnil. simpl. reflexivity. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1680.v0000644000175000017500000000027612326224777021576 0ustar stephstephLtac int1 := let h := fresh in intro h. Goal nat -> nat -> True. let h' := fresh in (let h := fresh in intro h); intro h'. Restart. let h' := fresh in int1; intro h'. trivial. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1604.v0000644000175000017500000000025312326224777021565 0ustar stephstephRequire Import Setoid. Parameter F : nat -> nat. Axiom F_id : forall n : nat, n = F n. Goal forall n : nat, F n = n. intro n. setoid_rewrite F_id at 3. reflexivity. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2117.v0000644000175000017500000000420112326224777021562 0ustar stephsteph(* Check pattern-unification on evars in apply unification *) Axiom app : forall tau tau':Type, (tau -> tau') -> tau -> tau'. Axiom copy : forall tau:Type, tau -> tau -> Prop. Axiom copyr : forall tau:Type, tau -> tau -> Prop. Axiom copyf : forall tau:Type, tau -> tau -> Prop. Axiom eq : forall tau:Type, tau -> tau -> Prop. Axiom subst : forall tau tau':Type, (tau -> tau') -> tau -> tau' -> Prop. Axiom copy_atom : forall tau:Type, forall t t':tau, eq tau t t' -> copy tau t t'. Axiom copy_fun: forall tau tau':Type, forall t t':(tau->tau'), (forall x:tau, copyr tau x x->copy tau' (t x) (t' x)) ->copy (tau->tau') t t'. Axiom copyr_atom : forall tau:Type, forall t t':tau, copyr tau t t' -> eq tau t t'. Axiom copyr_fun: forall tau tau':Type, forall t t':(tau->tau'), copyr (tau->tau') t t' ->(forall x y:tau, copy tau x y->copyr tau' (t x) (t' y)). Axiom copyf_atom : forall tau:Type, forall t t':tau, copyf tau t t' -> eq tau t t'. Axiom copyf_fun: forall tau tau':Type, forall t t':(tau->tau'), copyr (tau->tau') t t' ->(forall x y:tau, forall z1 z2:tau', (copy tau x y)-> (subst tau tau' t x z1)-> (subst tau tau' t' y z2)-> copyf tau' z1 z2). Axiom eqappg: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau',forall t':tau', ( ((subst tau tau' t q t') /\ (eq tau' t' r)) ->eq tau' (app tau tau' t q) r). Axiom eqappd: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau', forall t':tau', ((subst tau tau' t q t') /\ (eq tau' r t')) ->eq tau' r (app tau tau' t q). Axiom substcopy: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau', (forall x:tau, (copyf tau x q) -> (copy tau' (t x) r)) ->subst tau tau' t q r. Ltac EtaLong := (apply copy_fun;intros;EtaLong)|| apply copy_atom. Ltac Subst := apply substcopy;intros;EtaLong. Ltac Rigid_aux := fun A => apply A|| Rigid_aux (copyr_fun _ _ _ _ A). Ltac Rigid := fun A => apply copyr_atom; Rigid_aux A. Theorem church0: forall i:Type, exists X:(i->i)->i->i, copy ((i->i)->i->i) (fun f:i->i => fun x:i=>f (X f x)) (fun f:i->i=>fun x:i=>app i i (X f) (f x)). intros. esplit. EtaLong. eapply eqappd;split. Subst. apply copyf_atom. Show Existentials. apply H1. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2017.v0000644000175000017500000000075012326224777021566 0ustar stephsteph(* Some check of Miller's pattern inference - used to fail in 8.2 due first to the presence of aliases, secondly due to the absence of restriction of the potential interesting variables to the subset of variables effectively occurring in the term to instantiate *) Set Implicit Arguments. Variable choose : forall(P : bool -> Prop)(H : exists x, P x), bool. Variable H : exists x : bool, True. Definition coef := match Some true with Some _ => @choose _ H |_ => true end . coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2375.v0000644000175000017500000000054212326224777021574 0ustar stephsteph(* In the following code, the (superfluous) lemma [lem] is responsible for the failure of congruence. *) Definition f : nat -> Prop := fun x => True. Lemma lem : forall x, (True -> True) = ( True -> f x). Proof. intros. reflexivity. Qed. Goal forall (x:nat), x = x. Proof. intros. assert (lem := lem). (*clear ax.*) congruence. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1962.v0000644000175000017500000000260712326224777021601 0ustar stephsteph(* Bug 1962.v Bonjour, J'ai un exemple de lemme que j'arrivais à prouver avec fsetdec avec la 8.2beta3 avec la beta4 et la version svn 11447 branche 8.2 çà diverge. Voici l'exemple en question, l'exmple test2 marche bien dans les deux version, test en revanche pose probleme: *) Require Export FSets. (** This module takes a decidable type and build finite sets of this type, tactics and defs *) Module BuildFSets (DecPoints: UsualDecidableType). Module Export FiniteSetsOfPoints := FSetWeakList.Make DecPoints. Module Export FiniteSetsOfPointsProperties := WProperties FiniteSetsOfPoints. Module Export Dec := WDecide FiniteSetsOfPoints. Module Export FM := Dec.F. Definition set_of_points := t. Definition Point := DecPoints.t. Definition couple(x y :Point) : set_of_points := add x (add y empty). Definition triple(x y t :Point): set_of_points := add x (add y (add t empty)). Lemma test : forall P A B C A' B' C', Equal (union (singleton P) (union (triple A B C) (triple A' B' C'))) (union (triple P B B') (union (couple P A) (triple C A' C'))). Proof. intros. unfold triple, couple. Time fsetdec. (* works in 8.2 beta 3, not in beta 4 and final 8.2 *) (* appears to works again in 8.3 and trunk, take 4-6 seconds *) Qed. Lemma test2 : forall A B C, Equal (union (singleton C) (couple A B)) (triple A B C). Proof. intros. unfold triple, couple. Time fsetdec. Qed. End BuildFSets.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2928.v0000644000175000017500000000053212326224777021577 0ustar stephstephClass Equiv A := equiv: A -> A -> Prop. Infix "=" := equiv : type_scope. Class Associative {A} f `{Equiv A} := associativity x y z : f x (f y z) = f (f x y) z. Class SemiGroup A op `{Equiv A} := { sg_ass :>> Associative op }. Class SemiLattice A op `{Equiv A} := { semilattice_sg :>> SemiGroup A op ; redundant : Associative op }. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1977.v0000644000175000017500000000011412326224777021576 0ustar stephstephInductive T {A} : Prop := c : A -> T. Goal (@T nat). apply c. exact 0. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2734.v0000644000175000017500000000053012326224777021570 0ustar stephstephRequire Import Arith List. Require Import OrderedTypeEx. Module Adr. Include Nat_as_OT. Definition nat2t (i: nat) : t := i. End Adr. Inductive expr := Const: Adr.t -> expr. Inductive control := Go: expr -> control. Definition program := (Adr.t * (control))%type. Fail Definition myprog : program := (Adr.nat2t 0, Go (Adr.nat2t 0) ).coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1738.v0000644000175000017500000000115612326224777021600 0ustar stephstephRequire Import FSets. Module SomeSetoids (Import M:FSetInterface.S). Lemma Equal_refl : forall s, s[=]s. Proof. red; split; auto. Qed. Add Relation t Equal reflexivity proved by Equal_refl symmetry proved by eq_sym transitivity proved by eq_trans as EqualSetoid. Add Morphism Empty with signature Equal ==> iff as Empty_m. Proof. unfold Equal, Empty; firstorder. Qed. End SomeSetoids. Module Test (Import M:FSetInterface.S). Module A:=SomeSetoids M. Module B:=SomeSetoids M. (* lots of warning *) Lemma Test : forall s s', s[=]s' -> Empty s -> Empty s'. intros. rewrite H in H0. assumption. Qed. End Test.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1302.v0000644000175000017500000000040312326224777021555 0ustar stephstephModule Type T. Parameter A : Type. Inductive L : Type := | L0 : L (* without this constructor, it works right *) | L1 : A -> L. End T. Axiom Tp : Type. Module TT : T. Definition A : Type := Tp. Inductive L : Type := | L0 : L | L1 : A -> L. End TT. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2393.v0000644000175000017500000000043612326224777021576 0ustar stephstephRequire Import Program. Inductive T := MkT. Definition sizeOf (t : T) : nat := match t with | MkT => 1 end. Variable vect : nat -> Type. Program Fixpoint idType (t : T) (n := sizeOf t) (b : vect n) {measure n} : T := match t with | MkT => MkT end. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2089.v0000644000175000017500000000112712326224777021576 0ustar stephstephInductive even (x: nat): nat -> Prop := | even_base: even x O | even_succ: forall n, odd x n -> even x (S n) with odd (x: nat): nat -> Prop := | odd_succ: forall n, even x n -> odd x (S n). Scheme even_ind2 := Minimality for even Sort Prop with odd_ind2 := Minimality for odd Sort Prop. Combined Scheme even_odd_ind from even_ind2, odd_ind2. Check (even_odd_ind :forall (x : nat) (P P0 : nat -> Prop), P 0 -> (forall n : nat, odd x n -> P0 n -> P (S n)) -> (forall n : nat, even x n -> P n -> P0 (S n)) -> (forall n : nat, even x n -> P n) /\ (forall n : nat, odd x n -> P0 n)). coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1507.v0000644000175000017500000001066612326224777021600 0ustar stephsteph(* Implementing reals a la Stolzenberg Danko Ilik, March 2007 XField.v -- (unfinished) axiomatisation of the theories of real and rational intervals. *) Definition associative (A:Type)(op:A->A->A) := forall x y z:A, op (op x y) z = op x (op y z). Definition commutative (A:Type)(op:A->A->A) := forall x y:A, op x y = op y x. Definition trichotomous (A:Type)(R:A->A->Prop) := forall x y:A, R x y \/ x=y \/ R y x. Definition relation (A:Type) := A -> A -> Prop. Definition reflexive (A:Type)(R:relation A) := forall x:A, R x x. Definition transitive (A:Type)(R:relation A) := forall x y z:A, R x y -> R y z -> R x z. Definition symmetric (A:Type)(R:relation A) := forall x y:A, R x y -> R y x. Record interval (X:Set)(le:X->X->Prop) : Set := interval_make { interval_left : X; interval_right : X; interval_nonempty : le interval_left interval_right }. Record I (grnd:Set)(le:grnd->grnd->Prop) : Type := Imake { Icar := interval grnd le; Iplus : Icar -> Icar -> Icar; Imult : Icar -> Icar -> Icar; Izero : Icar; Ione : Icar; Iopp : Icar -> Icar; Iinv : Icar -> Icar; Ic : Icar -> Icar -> Prop; (* consistency *) (* monoids *) Iplus_assoc : associative Icar Iplus; Imult_assoc : associative Icar Imult; (* abelian groups *) Iplus_comm : commutative Icar Iplus; Imult_comm : commutative Icar Imult; Iplus_0_l : forall x:Icar, Ic (Iplus Izero x) x; Iplus_0_r : forall x:Icar, Ic (Iplus x Izero) x; Imult_0_l : forall x:Icar, Ic (Imult Ione x) x; Imult_0_r : forall x:Icar, Ic (Imult x Ione) x; Iplus_opp_r : forall x:Icar, Ic (Iplus x (Iopp x)) (Izero); Imult_inv_r : forall x:Icar, ~(Ic x Izero) -> Ic (Imult x (Iinv x)) Ione; (* distributive laws *) Imult_plus_distr_l : forall x x' y y' z z' z'', Ic x x' -> Ic y y' -> Ic z z' -> Ic z z'' -> Ic (Imult (Iplus x y) z) (Iplus (Imult x' z') (Imult y' z'')); (* order and lattice structure *) Ilt : Icar -> Icar -> Prop; Ilc := fun (x y:Icar) => Ilt x y \/ Ic x y; Isup : Icar -> Icar -> Icar; Iinf : Icar -> Icar -> Icar; Ilt_trans : transitive _ lt; Ilt_trich : forall x y:Icar, Ilt x y \/ Ic x y \/ Ilt y x; Isup_lub : forall x y z:Icar, Ilc x z -> Ilc y z -> Ilc (Isup x y) z; Iinf_glb : forall x y z:Icar, Ilc x y -> Ilc x z -> Ilc x (Iinf y z); (* order preserves operations? *) (* properties of Ic *) Ic_refl : reflexive _ Ic; Ic_sym : symmetric _ Ic }. Definition interval_set (X:Set)(le:X->X->Prop) := (interval X le) -> Prop. (* can be Set as well *) Check interval_set. Check Ic. Definition consistent (X:Set)(le:X->X->Prop)(TI:I X le)(p:interval_set X le) := forall I J:interval X le, p I -> p J -> (Ic X le TI) I J. Check consistent. (* define 'fine' *) Record N (grnd:Set)(le:grnd->grnd->Prop)(grndI:I grnd le) : Type := Nmake { Ncar := interval_set grnd le; Nplus : Ncar -> Ncar -> Ncar; Nmult : Ncar -> Ncar -> Ncar; Nzero : Ncar; None : Ncar; Nopp : Ncar -> Ncar; Ninv : Ncar -> Ncar; Nc : Ncar -> Ncar -> Prop; (* Ncistency *) (* monoids *) Nplus_assoc : associative Ncar Nplus; Nmult_assoc : associative Ncar Nmult; (* abelian groups *) Nplus_comm : commutative Ncar Nplus; Nmult_comm : commutative Ncar Nmult; Nplus_0_l : forall x:Ncar, Nc (Nplus Nzero x) x; Nplus_0_r : forall x:Ncar, Nc (Nplus x Nzero) x; Nmult_0_l : forall x:Ncar, Nc (Nmult None x) x; Nmult_0_r : forall x:Ncar, Nc (Nmult x None) x; Nplus_opp_r : forall x:Ncar, Nc (Nplus x (Nopp x)) (Nzero); Nmult_inv_r : forall x:Ncar, ~(Nc x Nzero) -> Nc (Nmult x (Ninv x)) None; (* distributive laws *) Nmult_plus_distr_l : forall x x' y y' z z' z'', Nc x x' -> Nc y y' -> Nc z z' -> Nc z z'' -> Nc (Nmult (Nplus x y) z) (Nplus (Nmult x' z') (Nmult y' z'')); (* order and lattice structure *) Nlt : Ncar -> Ncar -> Prop; Nlc := fun (x y:Ncar) => Nlt x y \/ Nc x y; Nsup : Ncar -> Ncar -> Ncar; Ninf : Ncar -> Ncar -> Ncar; Nlt_trans : transitive _ lt; Nlt_trich : forall x y:Ncar, Nlt x y \/ Nc x y \/ Nlt y x; Nsup_lub : forall x y z:Ncar, Nlc x z -> Nlc y z -> Nlc (Nsup x y) z; Ninf_glb : forall x y z:Ncar, Nlc x y -> Nlc x z -> Nlc x (Ninf y z); (* order preserves operations? *) (* properties of Nc *) Nc_refl : reflexive _ Nc; Nc_sym : symmetric _ Nc }. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2181.v0000644000175000017500000000011212326224777021560 0ustar stephstephClass C. Parameter P: C -> Prop. Fail Record R: Type := { _: C; u: P _ }. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2603.v0000644000175000017500000000157312326224777021573 0ustar stephsteph(** Namespace of module vs. namescope of definitions/constructors/... As noticed by A. Appel in bug #2603, module names and definition names used to be in the same namespace. But conflict with names of constructors (or 2nd mutual inductive...) used to not be checked enough, leading to stange situations. - In 8.3pl3 we introduced checks that forbid uniformly the following situations. - For 8.4 we finally managed to make module names and other names live in two separate namespace, hence allowing all of the following situations. *) Module Type T. End T. Declare Module K : T. Module Type L. Declare Module E : T. End L. Module M1 : L with Module E:=K. Module E := K. Inductive t := E. (* Used to be accepted, but End M1 below was failing *) End M1. Module M2 : L with Module E:=K. Inductive t := E. Module E := K. (* Used to be accepted *) End M2. (* Used to be accepted *) coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2139.v0000644000175000017500000000133212326224777021570 0ustar stephsteph(* Call of apply on <-> failed because of evars in elimination predicate *) Generalizable Variables patch. Class Patch (patch : Type) := { commute : patch -> patch -> Prop }. Parameter flip : forall `{patchInstance : Patch patch} {a b : patch}, commute a b <-> commute b a. Lemma Foo : forall `{patchInstance : Patch patch} {a b : patch}, (commute a b) -> True. Proof. intros. apply flip in H. (* failed in well-formed arity check because elimination predicate of iff in (@flip _ _ _ _) had normalized evars while the ones in the type of (@flip _ _ _ _) itself had non-normalized evars *) (* By the way, is the check necessary ? *) coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1100.v0000644000175000017500000000030512326224777021552 0ustar stephstephRequire Import Setoid. Parameter P : nat -> Prop. Parameter Q : nat -> Prop. Parameter PQ : forall n, P n <-> Q n. Lemma PQ2 : forall n, P n -> Q n. intros. rewrite PQ in H. trivial. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1483.v0000644000175000017500000000022612326224777021572 0ustar stephstephRequire Import BinPos. Definition P := (fun x : positive => x = xH). Goal forall (p q : positive), P q -> q = p -> P p. intros; congruence. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1907.v0000644000175000017500000000025112326224777021571 0ustar stephsteph(* An example of type inference *) Axiom A : Type. Definition f (x y : A) := x. Axiom g : forall x y : A, f x y = y -> Prop. Axiom x : A. Check (g x _ (refl_equal x)). coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2615.v0000644000175000017500000000113212326224777021565 0ustar stephsteph(* This failed with an anomaly in pre-8.4 because of let-in not properly taken into account in the test for unification pattern *) Inductive foo : forall A, A -> Prop := | foo_intro : forall A x, foo A x. Lemma bar A B f : foo (A -> B) f -> forall x : A, foo B (f x). Fail induction 1. (* Whether these examples should succeed with a non-dependent return predicate or fail because there is well-typed return predicate dependent in f is questionable. As of 25 oct 2011, they succeed *) refine (fun p => match p with _ => _ end). Undo. refine (fun p => match p with foo_intro _ _ => _ end). coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2456.v0000644000175000017500000000341312326224777021574 0ustar stephsteph Require Import Equality. Parameter Patch : nat -> nat -> Set. Inductive Catch (from to : nat) : Type := MkCatch : forall (p : Patch from to), Catch from to. Implicit Arguments MkCatch [from to]. Inductive CatchCommute5 : forall {from mid1 mid2 to : nat}, Catch from mid1 -> Catch mid1 to -> Catch from mid2 -> Catch mid2 to -> Prop := MkCatchCommute5 : forall {from mid1 mid2 to : nat} (p : Patch from mid1) (q : Patch mid1 to) (q' : Patch from mid2) (p' : Patch mid2 to), CatchCommute5 (MkCatch p) (MkCatch q) (MkCatch q') (MkCatch p'). Inductive CatchCommute {from mid1 mid2 to : nat} (p : Catch from mid1) (q : Catch mid1 to) (q' : Catch from mid2) (p' : Catch mid2 to) : Prop := isCatchCommute5 : forall (catchCommuteDetails : CatchCommute5 p q q' p'), CatchCommute p q q' p'. Notation "<< p , q >> <~> << q' , p' >>" := (CatchCommute p q q' p') (at level 60, no associativity). Lemma CatchCommuteUnique2 : forall {from mid mid' to : nat} {p : Catch from mid} {q : Catch mid to} {q' : Catch from mid'} {p' : Catch mid' to} {q'' : Catch from mid'} {p'' : Catch mid' to} (commute1 : <> <~> <>) (commute2 : <> <~> <>), (p' = p'') /\ (q' = q''). Proof with auto. intros. set (X := commute2). dependent destruction commute1; dependent destruction catchCommuteDetails; dependent destruction commute2; dependent destruction catchCommuteDetails generalizing X. Admitted.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1416.v0000644000175000017500000000170212326224777021566 0ustar stephsteph(* In 8.1 autorewrite used to raised an anomaly here *) (* After resolution of the bug, autorewrite succeeded *) (* From forthcoming 8.4, autorewrite is forbidden to instantiate *) (* evars, so the new test just checks it is not an anomaly *) Set Implicit Arguments. Record Place (Env A: Type) : Type := { read: Env -> A ; write: Env -> A -> Env ; write_read: forall (e:Env), (write e (read e))=e }. Hint Rewrite -> write_read: placeeq. Record sumPl (Env A B: Type) (vL:(Place Env A)) (vR:(Place Env B)) : Type := { mkEnv: A -> B -> Env ; mkEnv2writeL: forall (e:Env) (x:A), (mkEnv x (read vR e))=(write vL e x) }. (* when the following line is commented, the bug does not appear *) Hint Rewrite -> mkEnv2writeL: placeeq. Lemma autorewrite_raise_anomaly: forall (Env A:Type) (e: Env) (p:Place Env A), (exists e1:Env, e=(write p e1 (read p e))). Proof. intros Env A e p; eapply ex_intro. autorewrite with placeeq. (* Here is the bug *) coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1776.v0000644000175000017500000000115412326224777021600 0ustar stephstephAxiom pair : nat -> nat -> nat -> Prop. Axiom pl : (nat -> Prop) -> (nat -> Prop) -> (nat -> Prop). Axiom plImpR : forall k P Q, pl P Q k -> forall (Q':nat -> Prop), (forall k', Q k' -> Q' k') -> pl P Q' k. Definition nexists (P:nat -> nat -> Prop) : nat -> Prop := fun k' => exists k, P k k'. Goal forall a A m, True -> (pl A (nexists (fun x => (nexists (fun y => pl (pair a (S x)) (pair a (S y))))))) m. Proof. intros. eapply plImpR; [ | intros; econstructor; econstructor; eauto]. clear H; match goal with | |- (pl _ (pl (pair _ ?x) _)) _ => replace x with 0 end. Admitted. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1704.v0000644000175000017500000000060512326224777021567 0ustar stephsteph Require Import Setoid. Parameter E : nat -> nat -> Prop. Axiom E_equiv : equiv nat E. Add Relation nat E reflexivity proved by (proj1 E_equiv) symmetry proved by (proj2 (proj2 E_equiv)) transitivity proved by (proj1 (proj2 E_equiv)) as E_rel. Notation "x == y" := (E x y) (at level 70, no associativity). Axiom r : False -> 0 == 1. Goal 0 == 0. Proof. rewrite r. reflexivity. admit. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1643.v0000644000175000017500000000073312326224777021573 0ustar stephsteph(* Check some aspects of that the algorithm used to possibly reuse a global name in the recursive calls (coinductive case) *) CoInductive Str : Set := Cons (h:nat) (t:Str). Definition decomp_func (s:Str) := match s with | Cons h t => Cons h t end. Theorem decomp s: s = decomp_func s. Proof. case s; simpl; reflexivity. Qed. Definition zeros := (cofix z : Str := Cons 0 z). Lemma zeros_rw : zeros = Cons 0 zeros. rewrite (decomp zeros). simpl. Admitted. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2231.v0000644000175000017500000000020612326224777021560 0ustar stephstephInductive unit2 : Type := U : unit -> unit2. Inductive dummy (u: unit2) : unit -> Type := V: dummy u (let (tt) := u in tt). coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2640.v0000644000175000017500000000051112326224777021563 0ustar stephsteph(* Testing consistency of globalization and interpretation in some extreme cases *) Section sect. (* Simplification of the initial example *) Hypothesis Other: True. Lemma C2 : True. proof. Fail have True using Other. Abort. (* Variant of the same problem *) Lemma C2 : True. Fail clear; Other. Abort. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2378.v0000644000175000017500000005137312326224777021607 0ustar stephsteph(* test with Coq 8.3rc1 *) Require Import Program. Inductive Unit: Set := unit: Unit. Definition eq_dec T := forall x y:T, {x=y}+{x<>y}. Section TTS_TASM. Variable Time: Set. Variable Zero: Time. Variable tle: Time -> Time -> Prop. Variable tlt: Time -> Time -> Prop. Variable tadd: Time -> Time -> Time. Variable tsub: Time -> Time -> Time. Variable tmin: Time -> Time -> Time. Notation "t1 @<= t2" := (tle t1 t2) (at level 70, no associativity). Notation "t1 @< t2" := (tlt t1 t2) (at level 70, no associativity). Notation "t1 @+ t2" := (tadd t1 t2) (at level 50, left associativity). Notation "t1 @- t2" := (tsub t1 t2) (at level 50, left associativity). Notation "t1 @<= t2 @<= t3" := ((tle t1 t2) /\ (tle t2 t3)) (at level 70, t2 at next level). Notation "t1 @<= t2 @< t3" := ((tle t1 t2) /\ (tlt t2 t3)) (at level 70, t2 at next level). Variable tzerop: forall n, (n = Zero) + {Zero @< n}. Variable tlt_eq_gt_dec: forall x y, {x @< y} + {x=y} + {y @< x}. Variable tle_plus_l: forall n m, n @<= n @+ m. Variable tle_lt_eq_dec: forall n m, n @<= m -> {n @< m} + {n = m}. Variable tzerop_zero: tzerop Zero = inleft (Zero @< Zero) (@eq_refl _ Zero). Variable tplus_n_O: forall n, n @+ Zero = n. Variable tlt_le_weak: forall n m, n @< m -> n @<= m. Variable tlt_irrefl: forall n, ~ n @< n. Variable tplus_nlt: forall n m, ~n @+ m @< n. Variable tle_n: forall n, n @<= n. Variable tplus_lt_compat_l: forall n m p, n @< m -> p @+ n @< p @+ m. Variable tlt_trans: forall n m p, n @< m -> m @< p -> n @< p. Variable tle_lt_trans: forall n m p, n @<= m -> m @< p -> n @< p. Variable tlt_le_trans: forall n m p, n @< m -> m @<= p -> n @< p. Variable tle_refl: forall n, n @<= n. Variable tplus_le_0: forall n m, n @+ m @<= n -> m = Zero. Variable Time_eq_dec: eq_dec Time. (*************************************************************) Section PropLogic. Variable Predicate: Type. Inductive LP: Type := LPPred: Predicate -> LP | LPAnd: LP -> LP -> LP | LPNot: LP -> LP. Variable State: Type. Variable Sat: State -> Predicate -> Prop. Fixpoint lpSat st f: Prop := match f with LPPred p => Sat st p | LPAnd f1 f2 => lpSat st f1 /\ lpSat st f2 | LPNot f1 => ~lpSat st f1 end. End PropLogic. Implicit Arguments lpSat. Fixpoint LPTransfo Pred1 Pred2 p2lp (f: LP Pred1): LP Pred2 := match f with LPPred p => p2lp p | LPAnd f1 f2 => LPAnd _ (LPTransfo Pred1 Pred2 p2lp f1) (LPTransfo Pred1 Pred2 p2lp f2) | LPNot f1 => LPNot _ (LPTransfo Pred1 Pred2 p2lp f1) end. Implicit Arguments LPTransfo. Definition addIndex (Ind:Type) (Pred: Ind -> Type) (i: Ind) f := LPTransfo (fun p => LPPred _ (existT (fun i => Pred i) i p)) f. Section TTS. Variable State: Type. Record TTS: Type := mkTTS { Init: State -> Prop; Delay: State -> Time -> State -> Prop; Next: State -> State -> Prop; Predicate: Type; Satisfy: State -> Predicate -> Prop }. Definition TTSIndexedProduct Ind (tts: Ind -> TTS): TTS := mkTTS (fun st => forall i, Init (tts i) st) (fun st d st' => forall i, Delay (tts i) st d st') (fun st st' => forall i, Next (tts i) st st') { i: Ind & Predicate (tts i) } (fun st p => Satisfy (tts (projT1 p)) st (projT2 p)). End TTS. Section SIMU_F. Variables StateA StateC: Type. Record mapping: Type := mkMapping { mState: Type; mInit: StateC -> mState; mNext: mState -> StateC -> mState; mDelay: mState -> StateC -> Time -> mState; mabs: mState -> StateC -> StateA }. Variable m: mapping. Record simu (Pred: Type) (a: TTS StateA) (c: TTS StateC) (tra: Pred -> LP (Predicate _ a)) (trc: Pred -> LP (Predicate _ c)): Type := simuPrf { inv: (mState m) -> StateC -> Prop; invInit: forall st, Init _ c st -> inv (mInit m st) st; invDelay: forall ex1 st1 st2 d, Delay _ c st1 d st2 -> inv ex1 st1 -> inv (mDelay m ex1 st1 d) st2; invNext: forall ex1 st1 st2, Next _ c st1 st2 -> inv ex1 st1 -> inv (mNext m ex1 st1) st2; simuInit: forall st, Init _ c st -> Init _ a (mabs m (mInit m st) st); simuDelay: forall ex1 st1 st2 d, Delay _ c st1 d st2 -> inv ex1 st1 -> Delay _ a (mabs m ex1 st1) d (mabs m (mDelay m ex1 st1 d) st2); simuNext: forall ex1 st1 st2, Next _ c st1 st2 -> inv ex1 st1 -> Next _ a (mabs m ex1 st1) (mabs m (mNext m ex1 st1) st2); simuPred: forall ext st, inv ext st -> (forall p, lpSat (Satisfy _ c) st (trc p) <-> lpSat (Satisfy _ a) (mabs m ext st) (tra p)) }. Theorem satProd: forall State Ind Pred (Sat: forall i, State -> Pred i -> Prop) (st:State) i (f: LP (Pred i)), lpSat (Sat i) st f <-> lpSat (fun (st : State) (p : {i : Ind & Pred i}) => Sat (projT1 p) st (projT2 p)) st (addIndex Ind _ i f). Proof. induction f; simpl; intros; split; intros; intuition. Qed. Definition trProd (State: Type) Ind (Pred: Ind -> Type) (tts: Ind -> TTS State) (tr: forall i, (Pred i) -> LP (Predicate _ (tts i))): {i:Ind & Pred i} -> LP (Predicate _ (TTSIndexedProduct _ Ind tts)) := fun p => addIndex Ind _ (projS1 p) (tr (projS1 p) (projS2 p)). Implicit Arguments trProd. Require Import Setoid. Theorem satTrProd: forall State Ind Pred (tts: Ind -> TTS State) (tr: forall i, (Pred i) -> LP (Predicate _ (tts i))) (st:State) (p: {i:Ind & (Pred i)}), lpSat (Satisfy _ (tts (projS1 p))) st (tr (projS1 p) (projS2 p)) <-> lpSat (Satisfy _ (TTSIndexedProduct _ _ tts)) st (trProd _ tts tr p). Proof. unfold trProd, TTSIndexedProduct; simpl; intros. rewrite (satProd State Ind (fun i => Predicate State (tts i)) (fun i => Satisfy _ (tts i))); tauto. Qed. Theorem simuProd: forall Ind (Pred: Ind -> Type) (tta: Ind -> TTS StateA) (ttc: Ind -> TTS StateC) (tra: forall i, (Pred i) -> LP (Predicate _ (tta i))) (trc: forall i, (Pred i) -> LP (Predicate _ (ttc i))), (forall i, simu _ (tta i) (ttc i) (tra i) (trc i)) -> simu _ (TTSIndexedProduct _ Ind tta) (TTSIndexedProduct _ Ind ttc) (trProd Pred tta tra) (trProd Pred ttc trc). Proof. intros. apply simuPrf with (fun ex st => forall i, inv _ _ (ttc i) (tra i) (trc i) (X i) ex st); simpl; intros; auto. eapply invInit; eauto. eapply invDelay; eauto. eapply invNext; eauto. eapply simuInit; eauto. eapply simuDelay; eauto. eapply simuNext; eauto. split; simpl; intros. generalize (proj1 (simuPred _ _ _ _ _ (X (projS1 p)) ext st (H (projS1 p)) (projS2 p))); simpl; intro. rewrite <- (satTrProd StateA Ind Pred tta tra); apply H1. rewrite (satTrProd StateC Ind Pred ttc trc); apply H0. generalize (proj2 (simuPred _ _ _ _ _ (X (projS1 p)) ext st (H (projS1 p)) (projS2 p))); simpl; intro. rewrite <- (satTrProd StateC Ind Pred ttc trc); apply H1. rewrite (satTrProd StateA Ind Pred tta tra); apply H0. Qed. End SIMU_F. Section TRANSFO. Record simu_equiv StateA StateC m1 m2 Pred (a: TTS StateA) (c: TTS StateC) (tra: Pred -> LP (Predicate _ a)) (trc: Pred -> LP (Predicate _ c)): Type := simuEquivPrf { simuLR: simu StateA StateC m1 Pred a c tra trc; simuRL: simu StateC StateA m2 Pred c a trc tra }. Theorem simu_equivProd: forall StateA StateC m1 m2 Ind (Pred: Ind -> Type) (tta: Ind -> TTS StateA) (ttc: Ind -> TTS StateC) (tra: forall i, (Pred i) -> LP (Predicate _ (tta i))) (trc: forall i, (Pred i) -> LP (Predicate _ (ttc i))), (forall i, simu_equiv StateA StateC m1 m2 _ (tta i) (ttc i) (tra i) (trc i)) -> simu_equiv StateA StateC m1 m2 _ (TTSIndexedProduct _ Ind tta) (TTSIndexedProduct _ Ind ttc) (trProd _ _ Pred tta tra) (trProd _ _ Pred ttc trc). Proof. intros; split; intros. apply simuProd; intro. elim (X i); auto. apply simuProd; intro. elim (X i); auto. Qed. Record RTLanguage: Type := mkRTLanguage { Syntax: Type; DynamicState: Syntax -> Type; Semantic: forall (mdl:Syntax), TTS (DynamicState mdl); MdlPredicate: Syntax -> Type; MdlPredicateDefinition: forall mdl, MdlPredicate mdl -> LP (Predicate _ (Semantic mdl)) }. Record Transformation (l1 l2: RTLanguage): Type := mkTransformation { Tmodel: Syntax l1 -> Syntax l2; Tl1l2: forall mdl, mapping (DynamicState l1 mdl) (DynamicState l2 (Tmodel mdl)); Tl2l1: forall mdl, mapping (DynamicState l2 (Tmodel mdl)) (DynamicState l1 mdl); Tpred: forall mdl, MdlPredicate l1 mdl -> LP (MdlPredicate l2 (Tmodel mdl)); Tsim: forall mdl, simu_equiv (DynamicState l1 mdl) (DynamicState l2 (Tmodel mdl)) (Tl1l2 mdl) (Tl2l1 mdl) (MdlPredicate l1 mdl) (Semantic l1 mdl) (Semantic l2 (Tmodel mdl)) (MdlPredicateDefinition l1 mdl) (fun p => LPTransfo (MdlPredicateDefinition l2 (Tmodel mdl)) (Tpred mdl p)) }. Section Product. Record PSyntax (L: RTLanguage): Type := mkPSyntax { pIndex: Type; pIsEmpty: pIndex + {pIndex -> False}; pState: Type; pComponents: pIndex -> Syntax L; pIsShared: forall i, DynamicState L (pComponents i) = pState }. Definition pPredicate (L: RTLanguage) (sys: PSyntax L) := { i : pIndex L sys & MdlPredicate L (pComponents L sys i)}. (* product with shared state *) Definition PLanguage (L: RTLanguage): RTLanguage := mkRTLanguage (PSyntax L) (pState L) (fun mdl => TTSIndexedProduct (pState L mdl) (pIndex L mdl) (fun i => match pIsShared L mdl i in (_ = y) return TTS y with eq_refl => Semantic L (pComponents L mdl i) end)) (pPredicate L) (fun mdl => trProd _ _ _ _ (fun i pi => match pIsShared L mdl i as e in (_ = y) return (LP (Predicate y match e in (_ = y0) return (TTS y0) with | eq_refl => Semantic L (pComponents L mdl i) end)) with | eq_refl => MdlPredicateDefinition L (pComponents L mdl i) pi end)). Inductive Empty: Type :=. Record isSharedTransfo l1 l2 tr: Prop := isSharedTransfoPrf { sameState: forall mdl i j, DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) = DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl j)); sameMState: forall mdl i j, mState _ _ (Tl1l2 _ _ tr (pComponents l1 mdl i)) = mState _ _ (Tl1l2 _ _ tr (pComponents l1 mdl j)); sameM12: forall mdl i j, Tl1l2 _ _ tr (pComponents l1 mdl i) = match sym_eq (sameState mdl i j) in _=y return mapping _ y with eq_refl => match sym_eq (pIsShared l1 mdl i) in _=x return mapping x _ with eq_refl => match pIsShared l1 mdl j in _=x return mapping x _ with eq_refl => Tl1l2 _ _ tr (pComponents l1 mdl j) end end end; sameM21: forall mdl i j, Tl2l1 l1 l2 tr (pComponents l1 mdl i) = match sym_eq (sameState mdl i j) in (_ = y) return (mapping y (DynamicState l1 (pComponents l1 mdl i))) with eq_refl => match sym_eq (pIsShared l1 mdl i) in (_ = y) return (mapping (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl j))) y) with | eq_refl => match pIsShared l1 mdl j in (_ = y) return (mapping (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl j))) y) with | eq_refl => Tl2l1 l1 l2 tr (pComponents l1 mdl j) end end end }. Definition PTransfoSyntax l1 l2 tr (h: isSharedTransfo l1 l2 tr) mdl := mkPSyntax l2 (pIndex l1 mdl) (pIsEmpty l1 mdl) (match pIsEmpty l1 mdl return Type with inleft i => DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) |inright h => pState l1 mdl end) (fun i => Tmodel l1 l2 tr (pComponents l1 mdl i)) (fun i => match pIsEmpty l1 mdl as y return (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) = match y with | inleft i0 => DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i0)) | inright _ => pState l1 mdl end) with inleft j => sameState l1 l2 tr h mdl i j | inright h => match h i with end end). Definition compSemantic l mdl i := match pIsShared l mdl i in (_=y) return TTS y with eq_refl => Semantic l (pComponents l mdl i) end. Definition compSemanticEq l mdl i s (e: DynamicState l (pComponents l mdl i) = s) := match e in (_=y) return TTS y with eq_refl => Semantic l (pComponents l mdl i) end. Definition Pmap12 l1 l2 tr (h: isSharedTransfo l1 l2 tr) (mdl : PSyntax l1) := match pIsEmpty l1 mdl as s return (mapping (pState l1 mdl) match s with | inleft i => DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) | inright _ => pState l1 mdl end) with | inleft p => match pIsShared l1 mdl p in (_ = y) return (mapping y (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl p)))) with | eq_refl => Tl1l2 l1 l2 tr (pComponents l1 mdl p) end | inright _ => mkMapping (pState l1 mdl) (pState l1 mdl) Unit (fun _ : pState l1 mdl => unit) (fun (_ : Unit) (_ : pState l1 mdl) => unit) (fun (_ : Unit) (_ : pState l1 mdl) (_ : Time) => unit) (fun (_ : Unit) (X : pState l1 mdl) => X) end. Definition Pmap21 l1 l2 tr (h : isSharedTransfo l1 l2 tr) mdl := match pIsEmpty l1 mdl as s return (mapping match s with | inleft i => DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) | inright _ => pState l1 mdl end (pState l1 mdl)) with | inleft p => match pIsShared l1 mdl p in (_ = y) return (mapping (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl p))) y) with | eq_refl => Tl2l1 l1 l2 tr (pComponents l1 mdl p) end | inright _ => mkMapping (pState l1 mdl) (pState l1 mdl) Unit (fun _ : pState l1 mdl => unit) (fun (_ : Unit) (_ : pState l1 mdl) => unit) (fun (_ : Unit) (_ : pState l1 mdl) (_ : Time) => unit) (fun (_ : Unit) (X : pState l1 mdl) => X) end. Definition PTpred l1 l2 tr (h : isSharedTransfo l1 l2 tr) mdl (pp : pPredicate l1 mdl): LP (MdlPredicate (PLanguage l2) (PTransfoSyntax l1 l2 tr h mdl)) := match pIsEmpty l1 mdl with | inleft _ => let (x, p) := pp in addIndex (pIndex l1 mdl) (fun i => MdlPredicate l2 (Tmodel l1 l2 tr (pComponents l1 mdl i))) x (LPTransfo (Tpred l1 l2 tr (pComponents l1 mdl x)) (LPPred (MdlPredicate l1 (pComponents l1 mdl x)) p)) | inright f => match f (projS1 pp) with end end. Lemma simu_eqA: forall A1 A2 C m P sa sc tta ttc (h: A2=A1), simu A1 C (match h in (_=y) return mapping _ C with eq_refl => m end) P (match h in (_=y) return TTS y with eq_refl => sa end) sc (fun p => match h in (_=y) return LP (Predicate y _) with eq_refl => tta p end) ttc -> simu A2 C m P sa sc tta ttc. admit. Qed. Lemma simu_eqC: forall A C1 C2 m P sa sc tta ttc (h: C2=C1), simu A C1 (match h in (_=y) return mapping A _ with eq_refl => m end) P sa (match h in (_=y) return TTS y with eq_refl => sc end) tta (fun p => match h in (_=y) return LP (Predicate y _) with eq_refl => ttc p end) -> simu A C2 m P sa sc tta ttc. admit. Qed. Lemma simu_eqA1: forall A1 A2 C m P sa sc tta ttc (h: A1=A2), simu A1 C m P (match (sym_eq h) in (_=y) return TTS y with eq_refl => sa end) sc (fun p => match (sym_eq h) as e in (_=y) return LP (Predicate y (match e in (_=z) return TTS z with eq_refl => sa end)) with eq_refl => tta p end) ttc -> simu A2 C (match h in (_=y) return mapping _ C with eq_refl => m end) P sa sc tta ttc. admit. Qed. Lemma simu_eqA2: forall A1 A2 C m P sa sc tta ttc (h: A1=A2), simu A1 C (match (sym_eq h) in (_=y) return mapping _ C with eq_refl => m end) P sa sc tta ttc -> simu A2 C m P (match h in (_=y) return TTS y with eq_refl => sa end) sc (fun p => match h as e in (_=y) return LP (Predicate y match e in (_=y0) return TTS y0 with eq_refl => sa end) with eq_refl => tta p end) ttc. admit. Qed. Lemma simu_eqC2: forall A C1 C2 m P sa sc tta ttc (h: C1=C2), simu A C1 (match (sym_eq h) in (_=y) return mapping A _ with eq_refl => m end) P sa sc tta ttc -> simu A C2 m P sa (match h in (_=y) return TTS y with eq_refl => sc end) tta (fun p => match h as e in (_=y) return LP (Predicate y match e in (_=y0) return TTS y0 with eq_refl => sc end) with eq_refl => ttc p end). admit. Qed. Lemma simu_eqM: forall A C m1 m2 P sa sc tta ttc (h: m1=m2), simu A C m1 P sa sc tta ttc -> simu A C m2 P sa sc tta ttc. admit. Qed. Lemma LPTransfo_trans: forall Pred1 Pred2 Pred3 (tr1: Pred1 -> LP Pred2) (tr2: Pred2 -> LP Pred3) f, LPTransfo tr2 (LPTransfo tr1 f) = LPTransfo (fun x => LPTransfo tr2 (tr1 x)) f. Proof. admit. Qed. Lemma LPTransfo_addIndex: forall Ind Pred tr1 x (tr2: forall i, Pred i -> LP (tr1 i)) (p: LP (Pred x)), addIndex Ind tr1 x (LPTransfo (tr2 x) p) = LPTransfo (fun p0 : {i : Ind & Pred i} => addIndex Ind tr1 (projT1 p0) (tr2 (projT1 p0) (projT2 p0))) (addIndex Ind Pred x p). Proof. unfold addIndex; intros. rewrite LPTransfo_trans. rewrite LPTransfo_trans. simpl. auto. Qed. Record tr_compat I0 I1 tr := compatPrf { and_compat: forall p1 p2, tr (LPAnd I0 p1 p2) = LPAnd I1 (tr p1) (tr p2); not_compat: forall p, tr (LPNot I0 p) = LPNot I1 (tr p) }. Lemma LPTransfo_addIndex_tr: forall Ind Pred tr0 tr1 x (tr2: forall i, Pred i -> LP (tr0 i)) (tr3: forall i, LP (tr0 i) -> LP (tr1 i)) (p: LP (Pred x)), (forall x, tr_compat (tr0 x) (tr1 x) (tr3 x)) -> addIndex Ind tr1 x (tr3 x (LPTransfo (tr2 x) p)) = LPTransfo (fun p0 : {i : Ind & Pred i} => addIndex Ind tr1 (projT1 p0) (tr3 (projT1 p0) (tr2 (projT1 p0) (projT2 p0)))) (addIndex Ind Pred x p). Proof. unfold addIndex; simpl; intros. rewrite LPTransfo_trans; simpl. rewrite <- LPTransfo_trans. f_equal. induction p; simpl; intros; auto. rewrite (and_compat _ _ _ (H x)). rewrite <- IHp1, <- IHp2; auto. rewrite <- IHp. rewrite (not_compat _ _ _ (H x)); auto. Qed. Require Export Coq.Logic.FunctionalExtensionality. Print PLanguage. Program Definition PTransfo l1 l2 (tr: Transformation l1 l2) (h: isSharedTransfo l1 l2 tr): Transformation (PLanguage l1) (PLanguage l2) := mkTransformation (PLanguage l1) (PLanguage l2) (PTransfoSyntax l1 l2 tr h) (Pmap12 l1 l2 tr h) (Pmap21 l1 l2 tr h) (PTpred l1 l2 tr h) (fun mdl => simu_equivProd (pState l1 mdl) (pState l2 (PTransfoSyntax l1 l2 tr h mdl)) (Pmap12 l1 l2 tr h mdl) (Pmap21 l1 l2 tr h mdl) (pIndex l1 mdl) (fun i => MdlPredicate l1 (pComponents l1 mdl i)) (compSemantic l1 mdl) (compSemantic l2 (PTransfoSyntax l1 l2 tr h mdl)) _ _ _ ). Next Obligation. unfold compSemantic, PTransfoSyntax; simpl. case (pIsEmpty l1 mdl); simpl; intros. unfold pPredicate; simpl. unfold pPredicate in X; simpl in X. case (sameState l1 l2 tr h mdl i p). apply (LPTransfo (MdlPredicateDefinition l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)))). apply (LPTransfo (Tpred l1 l2 tr (pComponents l1 mdl i))). apply (LPPred _ X). apply False_rect; apply (f i). Defined. Next Obligation. split; intros. unfold Pmap12; simpl. unfold PTransfo_obligation_1; simpl. unfold compSemantic; simpl. unfold eq_ind, eq_rect, f_equal; simpl. case (pIsEmpty l1 mdl); intros. apply simu_eqA2. apply simu_eqC2. apply simu_eqM with (Tl1l2 l1 l2 tr (pComponents l1 mdl i)). apply sameM12. apply (simuLR _ _ _ _ _ _ _ _ _ (Tsim l1 l2 tr (pComponents l1 mdl i))); intro. apply False_rect; apply (f i). unfold Pmap21; simpl. unfold PTransfo_obligation_1; simpl. unfold compSemantic; simpl. unfold eq_ind, eq_rect, f_equal; simpl. case (pIsEmpty l1 mdl); intros. apply simu_eqC2. apply simu_eqA2. apply simu_eqM with (Tl2l1 l1 l2 tr (pComponents l1 mdl i)). apply sameM21. apply (simuRL _ _ _ _ _ _ _ _ _ (Tsim l1 l2 tr (pComponents l1 mdl i))); intro. apply False_rect; apply (f i). Qed. Next Obligation. unfold trProd; simpl. unfold PTransfo_obligation_1; simpl. unfold compSemantic; simpl. unfold eq_ind, eq_rect, f_equal; simpl. apply functional_extensionality; intro. case x; clear x; intros. unfold PTpred; simpl. case (pIsEmpty l1 mdl); simpl; intros. set (tr0 i := Predicate (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl i))) (Semantic l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)))). set (tr1 i := Predicate (DynamicState l2 (Tmodel l1 l2 tr (pComponents l1 mdl p))) match sameState l1 l2 tr h mdl i p in (_ = y) return (TTS y) with | eq_refl => Semantic l2 (Tmodel l1 l2 tr (pComponents l1 mdl i)) end). set (tr2 x := MdlPredicateDefinition l2 (Tmodel l1 l2 tr (pComponents l1 mdl x))). set (Pred x := MdlPredicate l2 (Tmodel l1 l2 tr (pComponents l1 mdl x))). set (tr3 x f := match sameState l1 l2 tr h mdl x p as e in (_ = y) return (LP (Predicate y match e in (_ = y0) return (TTS y0) with | eq_refl => Semantic l2 (Tmodel l1 l2 tr (pComponents l1 mdl x)) end)) with | eq_refl => f end). apply (LPTransfo_addIndex_tr _ Pred tr0 tr1 x tr2 tr3 (Tpred l1 l2 tr (pComponents l1 mdl x) m)). unfold tr0, tr1, tr3; intros; split; simpl; intros; auto. case (sameState l1 l2 tr h mdl x0 p); auto. case (sameState l1 l2 tr h mdl x0 p); auto. apply False_rect; apply (f x). Qed. End Product. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1582.v0000644000175000017500000000036212326224777021573 0ustar stephstephRequire Import Peano_dec. Definition fact_F : forall (n:nat), (forall m, m nat) -> nat. refine (fun n fact_rec => if eq_nat_dec n 0 then 1 else let fn := fact_rec (n-1) _ in n * fn). Admitted. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1865.v0000644000175000017500000000064212326224777021600 0ustar stephsteph(* Check that tactics (here dependent inversion) do not generate conversion problems T <= U with sup's of universes in U *) (* Submitted by David Nowak *) Inductive list (A:Set) : nat -> Set := | nil : list A O | cons : forall n, A -> list A n -> list A (S n). Definition f (n:nat) : Type := match n with | O => bool | _ => unit end. Goal forall A n, list A n -> f n. intros A n. dependent inversion n. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2732.v0000644000175000017500000000050012326224777021563 0ustar stephsteph(* Check correct behavior of add_primitive_tactic in TACEXTEND *) (* Added also the case of eauto and congruence *) Ltac thus H := solve [H]. Lemma test: forall n : nat, n <= n. Proof. intro. thus firstorder. Undo. thus eauto. Qed. Lemma test2: false = true -> False. Proof. intro. thus congruence. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1912.v0000644000175000017500000000012412326224777021564 0ustar stephstephRequire Import ZArith. Goal forall x, Z.succ (Z.pred x) = x. intros x. omega. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2255.v0000644000175000017500000000137612326224777021577 0ustar stephsteph(* Check injection in presence of dependencies hidden in applicative terms *) Inductive TupleT : nat -> Type := nilT : TupleT 0 | consT {n} A : (A -> TupleT n) -> TupleT (S n). Inductive Tuple : forall n, TupleT n -> Type := nil : Tuple _ nilT | cons {n} A (x : A) (F : A -> TupleT n) : Tuple _ (F x) -> Tuple _ (consT A F). Goal forall n A F x X n0 A0 x0 F0 H0 (H : existT (fun n0 : nat => {H0 : TupleT n0 & Tuple n0 H0}) (S n0) (existT (fun H0 : TupleT (S n0) => Tuple (S n0) H0) (consT A0 F0) (cons A0 x0 F0 H0)) = existT (fun n0 : nat => {H0 : TupleT n0 & Tuple n0 H0}) (S n) (existT (fun H0 : TupleT (S n) => Tuple (S n) H0) (consT A F) (cons A x F X))), False. intros. injection H. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/846.v0000644000175000017500000001057512326224777021524 0ustar stephstephSet Implicit Arguments. Open Scope type_scope. Inductive One : Set := inOne: One. Definition maybe: forall A B:Set,(A -> B) -> One + A -> One + B. Proof. intros A B f c. case c. left; assumption. right; apply f; assumption. Defined. Definition id (A:Set)(a:A):=a. Definition LamF (X: Set -> Set)(A:Set) :Set := A + (X A)*(X A) + X(One + A). Definition LamF' (X: Set -> Set)(A:Set) :Set := LamF X A. Require Import List. Require Import Bool. Definition index := list bool. Inductive L (A:Set) : index -> Set := initL: A -> L A nil | pluslL: forall l:index, One -> L A (false::l) | plusrL: forall l:index, L A l -> L A (false::l) | varL: forall l:index, L A l -> L A (true::l) | appL: forall l:index, L A (true::l) -> L A (true::l) -> L A (true::l) | absL: forall l:index, L A (true::false::l) -> L A (true::l). Scheme L_rec_simp := Minimality for L Sort Set. Definition Lam' (A:Set) := L A (true::nil). Definition aczelapp: forall (l1 l2: index)(A:Set), L (L A l2) l1 -> L A (l1++l2). Proof. intros l1 l2 A. generalize l1. clear l1. (* Check (fun i:index => L A (i++l2)). *) apply (L_rec_simp (A:=L A l2) (fun i:index => L A (i++l2))). trivial. intros l o. simpl app. apply pluslL; assumption. intros l _ t. simpl app. apply plusrL; assumption. intros l _ t. simpl app. apply varL; assumption. intros l _ t1 _ t2. simpl app in *|-*. Check 0. apply appL; [exact t1| exact t2]. intros l _ t. simpl app in *|-*. Check 0. apply absL; assumption. Defined. Definition monL: forall (l:index)(A:Set)(B:Set), (A->B) -> L A l -> L B l. Proof. intros l A B f. intro t. elim t. intro a. exact (initL (f a)). intros i u. exact (pluslL _ _ u). intros i _ r. exact (plusrL r). intros i _ r. exact (varL r). intros i _ r1 _ r2. exact (appL r1 r2). intros i _ r. exact (absL r). Defined. Definition lam': forall (A B:Set), (A -> B) -> Lam' A -> Lam' B. Proof. intros A B f t. unfold Lam' in *|-*. Check 0. exact (monL f t). Defined. Definition inLam': forall A:Set, LamF' Lam' A -> Lam' A. Proof. intros A [[a|[t1 t2]]|r]. unfold Lam'. exact (varL (initL a)). exact (appL t1 t2). unfold Lam' in * |- *. Check 0. apply absL. change (L A ((true::nil) ++ (false::nil))). apply aczelapp. (* Check (fun x:One + A => (match (maybe (fun a:A => initL a) x) with | inl u => pluslL _ _ u | inr t' => plusrL t' end)). *) exact (monL (fun x:One + A => (match (maybe (fun a:A => initL a) x) with | inl u => pluslL _ _ u | inr t' => plusrL t' end)) r). Defined. Section minimal. Definition sub1 (F G: Set -> Set):= forall A:Set, F A->G A. Hypothesis G: Set -> Set. Hypothesis step: sub1 (LamF' G) G. Fixpoint L'(A:Set)(i:index){struct i} : Set := match i with nil => A | false::l => One + L' A l | true::l => G (L' A l) end. Definition LinL': forall (A:Set)(i:index), L A i -> L' A i. Proof. intros A i t. elim t. intro a. unfold L'. assumption. intros l u. left; assumption. intros l _ r. right; assumption. intros l _ r. apply (step (A:=L' A l)). exact (inl _ (inl _ r)). intros l _ r1 _ r2. apply (step (A:=L' A l)). (* unfold L' in * |- *. Check 0. *) exact (inl _ (inr _ (pair r1 r2))). intros l _ r. apply (step (A:=L' A l)). exact (inr _ r). Defined. Definition L'inG: forall A: Set, L' A (true::nil) -> G A. Proof. intros A t. unfold L' in t. assumption. Defined. Definition Itbasic: sub1 Lam' G. Proof. intros A t. apply L'inG. unfold Lam' in t. exact (LinL' t). Defined. End minimal. Definition recid := Itbasic inLam'. Definition L'Lam'inL: forall (i:index)(A:Set), L' Lam' A i -> L A i. Proof. intros i A t. induction i. unfold L' in t. apply initL. assumption. induction a. simpl L' in t. apply (aczelapp (l1:=true::nil) (l2:=i)). exact (lam' IHi t). simpl L' in t. induction t. exact (pluslL _ _ a). exact (plusrL (IHi b)). Defined. Lemma recidgen: forall(A:Set)(i:index)(t:L A i), L'Lam'inL i A (LinL' inLam' t) = t. Proof. intros A i t. induction t. trivial. trivial. simpl. rewrite IHt. trivial. simpl L'Lam'inL. rewrite IHt. trivial. simpl L'Lam'inL. simpl L'Lam'inL in IHt1. unfold lam' in IHt1. simpl L'Lam'inL in IHt2. unfold lam' in IHt2. (* going on. This fails for the original solution. *) rewrite IHt1. rewrite IHt2. trivial. Abort. (* one goal still left *) coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2360.v0000644000175000017500000000055712326224777021574 0ustar stephsteph(* This failed in V8.3 because descend_in_conjunctions built ill-typed terms *) Definition interp (etyp : nat -> Type) (p: nat) := etyp p. Record Value (etyp : nat -> Type) := Mk { typ : nat; value : interp etyp typ }. Definition some_value (etyp : nat -> Type) : (Value etyp). Proof. intros. Fail apply Mk. (* Check that it does not raise an anomaly *) coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2303.v0000644000175000017500000000021312326224777021556 0ustar stephstephClass A := a: unit. Class B (x: unit). Axiom H: forall x: A, @B x -> x = x -> unit. Definition Field (z: A) (m: @B z) x := (@H _ _ x) = z. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1900.v0000644000175000017500000000014312326224777021562 0ustar stephstephParameter A : Type . Definition eq_A := @eq A. Goal forall x, eq_A x x. intros. reflexivity. Qed.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1446.v0000644000175000017500000000053612326224777021575 0ustar stephstephLemma not_true_eq_false : forall (b:bool), b <> true -> b = false. Proof. destruct b;intros;trivial. elim H. exact (refl_equal true). Qed. Section BUG. Variable b : bool. Hypothesis H : b <> true. Hypothesis H0 : b = true. Hypothesis H1 : b <> true. Goal False. rewrite (not_true_eq_false _ H) in * |-. contradiction. Qed. End BUG. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2307.v0000644000175000017500000000014612326224777021567 0ustar stephstephInductive V: nat -> Type := VS n: V (S n). Definition f (e: V 1): nat := match e with VS 0 => 3 end. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2350.v0000644000175000017500000000027312326224777021566 0ustar stephsteph(* Check that the fix tactic, when called from refine, reduces enough to see the products *) Definition foo := forall n:nat, n=n. Definition bar : foo. refine (fix aux (n:nat) := _). coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2135.v0000644000175000017500000000046612326224777021573 0ustar stephsteph(* Check that metas are whd-normalized before trying 2nd-order unification *) Lemma test : forall (D:Type) (T : forall C, option C) (Q:forall D, option D -> Prop), (forall (A : Type) (P : forall B:Type, option B -> Prop), P A (T A)) -> Q D (T D). Proof. intros D T Q H. pattern (T D). apply H. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2616.v0000644000175000017500000000031312326224777021566 0ustar stephsteph(* Testing ill-typed rewrite which used to succeed in 8.3 *) Goal forall (N : nat -> Prop) (g : nat -> sig N) (IN : forall a : sig N, a = g 0), N 0 -> False. Proof. intros. Fail rewrite IN in H. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2353.v0000644000175000017500000000075212326224777021573 0ustar stephsteph(* Are recursively non-uniform params correctly treated? *) Inductive list (A:nat -> Type) n := cons : A n -> list A (S n) -> list A n. Inductive term n := app (l : list term n). Definition term_list := fix term_size n (t : term n) (acc : nat) {struct t} : nat := match t with | app l => (fix term_list_size n (l : list term n) (acc : nat) {struct l} : nat := match l with | cons t q => term_list_size (S n) q (term_size n t acc) end) n l (S acc) end. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2137.v0000644000175000017500000000236712326224777021577 0ustar stephsteph(* Bug #2137 The fsetdec tactic is sensitive to which way round the arguments to <> are. In the small, self-contained example below, it is able to solve the goal if it knows that "b <> a", but not if it knows that "a <> b". I would expect it to be able to solve hte goal in either case. I have coq r12238. Thanks Ian *) Require Import Arith FSets FSetWeakList. Module DecidableNat. Definition t := nat. Definition eq := @eq nat. Definition eq_refl := @refl_equal nat. Definition eq_sym := @sym_eq nat. Definition eq_trans := @trans_eq nat. Definition eq_dec := eq_nat_dec. End DecidableNat. Module NatSet := Make(DecidableNat). Module Export NameSetDec := WDecide (NatSet). Lemma ThisLemmaWorks : forall ( s0 : NatSet.t ) ( a b : nat ), b <> a -> ~(NatSet.In a s0) -> ~(NatSet.In a (NatSet.add b s0)). Proof. intros. fsetdec. Qed. Lemma ThisLemmaWasFailing : forall ( s0 : NatSet.t ) ( a b : nat ), a <> b -> ~(NatSet.In a s0) -> ~(NatSet.In a (NatSet.add b s0)). Proof. intros. fsetdec. (* Error: Tactic failure: because the goal is beyond the scope of this tactic. *) Qed.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2295.v0000644000175000017500000000041612326224777021575 0ustar stephsteph(* Check if omission of "as" in return clause works w/ section variables too *) Section sec. Variable b: bool. Definition d' := (match b return b = true \/ b = false with | true => or_introl _ (refl_equal true) | false => or_intror _ (refl_equal false) end). coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/335.v0000644000175000017500000000015312326224777021504 0ustar stephsteph(* Compatibility of Require with backtracking at interactive module end *) Module A. Require List. End A. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/38.v0000644000175000017500000000075312326224777021432 0ustar stephstephRequire Import Setoid. Variable A : Set. Inductive liste : Set := | vide : liste | c : A -> liste -> liste. Inductive e : A -> liste -> Prop := | ec : forall (x : A) (l : liste), e x (c x l) | ee : forall (x y : A) (l : liste), e x l -> e x (c y l). Definition same := fun (l m : liste) => forall (x : A), e x l <-> e x m. Definition same_refl (x:liste) : (same x x). unfold same; split; intros; trivial. Save. Goal forall (x:liste), (same x x). intro. apply (same_refl x). Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1939.v0000644000175000017500000000054412326224777021603 0ustar stephstephRequire Import Setoid Program.Basics. Parameter P : nat -> Prop. Parameter R : nat -> nat -> Prop. Add Parametric Morphism : P with signature R ++> impl as PM1. Admitted. Add Parametric Morphism : P with signature R --> impl as PM2. Admitted. Goal forall x y, R x y -> P y -> P x. Proof. intros x y H1 H2. rewrite H1. auto. Qed.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1448.v0000644000175000017500000000117612326224777021600 0ustar stephstephRequire Import Relations. Require Import Setoid. Require Import Ring_theory. Require Import Ring_base. Variable R : Type. Variable Rone Rzero : R. Variable Rplus Rmult Rminus : R -> R -> R. Variable Rneg : R -> R. Lemma my_ring_theory : @ring_theory R Rzero Rone Rplus Rmult Rminus Rneg (@eq R). Admitted. Variable Req : R -> R -> Prop. Hypothesis Req_refl : reflexive _ Req. Hypothesis Req_sym : symmetric _ Req. Hypothesis Req_trans : transitive _ Req. Add Relation R Req reflexivity proved by Req_refl symmetry proved by Req_sym transitivity proved by Req_trans as Req_rel. Add Ring my_ring : my_ring_theory (abstract). coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1411.v0000644000175000017500000000163212326224777021563 0ustar stephstephRequire Import List. Require Import Program. Inductive Tree : Set := | Br : Tree -> Tree -> Tree | No : nat -> Tree . (* given a tree, we want to know which lists can be used to navigate exactly to a node *) Inductive Exact : Tree -> list bool -> Prop := | exDone n : Exact (No n) nil | exLeft l r p: Exact l p -> Exact (Br l r) (true::p) | exRight l r p: Exact r p -> Exact (Br l r) (false::p) . Definition unreachable A : False -> A. intros. destruct H. Defined. Program Fixpoint fetch t p (x:Exact t p) {struct t} := match t, p with | No p' , nil => p' | No p' , _::_ => unreachable nat _ | Br l r, nil => unreachable nat _ | Br l r, true::t => fetch l t _ | Br l r, false::t => fetch r t _ end. Next Obligation. inversion x. Qed. Next Obligation. inversion x. Qed. Next Obligation. inversion x; trivial. Qed. Next Obligation. inversion x; trivial. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2027.v0000644000175000017500000000034212326224777021564 0ustar stephsteph Parameter T : Type -> Type. Parameter f : forall {A}, T A -> T A. Parameter P : forall {A}, T A -> Prop. Axiom f_id : forall {A} (l : T A), f l = l. Goal forall A (p : T A), P p. Proof. intros. rewrite <- f_id. Admitted.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/545.v0000644000175000017500000000017212326224777021510 0ustar stephstephRequire Export Reals. Parameter toto : nat -> nat -> nat. Notation " e # f " := (toto e f) (at level 30, f at level 0). coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2193.v0000644000175000017500000000214312326224777021571 0ustar stephsteph(* Computation of dependencies in the "match" return predicate was incomplete *) (* Submitted by R. O'Connor, Nov 2009 *) Inductive Symbol : Set := | VAR : Symbol. Inductive SExpression := | atomic : Symbol -> SExpression. Inductive ProperExpr : SExpression -> SExpression -> Type := | pe_3 : forall (x : Symbol) (alpha : SExpression), ProperExpr alpha (atomic VAR) -> ProperExpr (atomic x) alpha. Definition A (P : forall s : SExpression, Type) (x alpha alpha1 : SExpression) (t : ProperExpr (x) alpha1) : option (x = atomic VAR) := match t as pe in ProperExpr a b return option (a = atomic VAR) with | pe_3 x0 alpha3 tye' => (fun (x:Symbol) (alpha : SExpression) => @None (atomic x = atomic VAR)) x0 alpha3 end. Definition B (P : forall s : SExpression, Type) (x alpha alpha1 : SExpression) (t : ProperExpr (x) alpha1) : option (x = atomic VAR) := match t as pe in ProperExpr a b return option (a = atomic VAR) with | pe_3 x0 alpha3 tye' => (fun (x:Symbol) (alpha : SExpression) (t:ProperExpr alpha (atomic VAR)) => @None (atomic x = atomic VAR)) x0 alpha3 tye' end. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1519.v0000644000175000017500000000025612326224777021575 0ustar stephstephSection S. Variable A:Prop. Variable W:A. Remark T: A -> A. intro Z. rename W into Z_. rename Z into W. rename Z_ into Z. exact Z. Qed. End S. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2995.v0000644000175000017500000000036112326224777021603 0ustar stephstephModule Type Interface. Parameter error: nat. End Interface. Module Implementation <: Interface. Definition t := bool. Definition error: t := false. Fail End Implementation. (* A UserError here is expected, not an uncaught Not_found *)coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1754.v0000644000175000017500000000124112326224777021571 0ustar stephstephAxiom hp : Set. Axiom cont : nat -> hp -> Prop. Axiom sconj : (hp -> Prop) -> (hp -> Prop) -> hp -> Prop. Axiom sconjImpl : forall h A B, (sconj A B) h -> forall (A' B': hp -> Prop), (forall h', A h' -> A' h') -> (forall h', B h' -> B' h') -> (sconj A' B') h. Definition cont' (h:hp) := exists y, cont y h. Lemma foo : forall h x y A, (sconj (cont x) (sconj (cont y) A)) h -> (sconj cont' (sconj cont' A)) h. Proof. intros h x y A H. eapply sconjImpl. 2:intros h' Hp'; econstructor; apply Hp'. 2:intros h' Hp'; eapply sconjImpl. 3:intros h'' Hp''; econstructor; apply Hp''. 3:intros h'' Hp''; apply Hp''. 2:apply Hp'. clear H. Admitted. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2108.v0000644000175000017500000000062712326224777021572 0ustar stephsteph(* Declare Module in Module Type *) Module Type A. Record t : Set := { something : unit }. End A. Module Type B. Declare Module BA : A. End B. Module Type C. Declare Module CA : A. Declare Module CB : B with Module BA := CA. End C. Module Type D. Declare Module DA : A. (* Next line gives: "Anomaly: uncaught exception Not_found. Please report." *) Declare Module DC : C with Module CA := DA. End D. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/808_2411.v0000644000175000017500000000076612326224777022172 0ustar stephstephSection test. Variable n:nat. Lemma foo: 0 <= n. Proof. (* declaring an Axiom during a proof makes it immediatly usable, juste as a full Definition. *) Axiom bar : n = 1. rewrite bar. now apply le_S. Qed. Lemma foo' : 0 <= n. Proof. (* Declaring an Hypothesis during a proof is ok, but this hypothesis won't be usable by the current proof(s), only by later ones. *) Hypothesis bar' : n = 1. Fail rewrite bar'. Abort. Lemma foo'' : 0 <= n. Proof. rewrite bar'. now apply le_S. Qed. End test.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1634.v0000644000175000017500000000116712326224777021575 0ustar stephstephRequire Export Relation_Definitions. Require Export Setoid. Variable A : Type. Variable S : A -> Type. Variable Seq : forall {a:A}, relation (S a). Hypothesis Seq_refl : forall {a:A} (x : S a), Seq x x. Hypothesis Seq_sym : forall {a:A} (x y : S a), Seq x y -> Seq y x. Hypothesis Seq_trans : forall {a:A} (x y z : S a), Seq x y -> Seq y z -> Seq x z. Add Parametric Relation a : (S a) Seq reflexivity proved by Seq_refl symmetry proved by Seq_sym transitivity proved by Seq_trans as S_Setoid. Goal forall (a : A) (x y : S a), Seq x y -> Seq x y. intros a x y H. setoid_replace x with y. reflexivity. trivial. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1419.v0000644000175000017500000000015612326224777021573 0ustar stephstephGoal True. set(a := 0). set(b := a). unfold a in b. clear a. Eval vm_compute in b. trivial. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1844.v0000644000175000017500000001642212326224777021600 0ustar stephstephRequire Import ZArith. Definition zeq := Z.eq_dec. Definition update (A: Set) (x: Z) (v: A) (s: Z -> A) : Z -> A := fun y => if zeq x y then v else s y. Implicit Arguments update [A]. Definition ident := Z. Parameter operator: Set. Parameter value: Set. Parameter is_true: value -> Prop. Definition label := Z. Inductive expr : Set := | Evar: ident -> expr | Econst: value -> expr | Eop: operator -> expr -> expr -> expr. Inductive stmt : Set := | Sskip: stmt | Sassign: ident -> expr -> stmt | Scall: ident -> ident -> expr -> stmt (* x := f(e) *) | Sreturn: expr -> stmt | Sseq: stmt -> stmt -> stmt | Sifthenelse: expr -> stmt -> stmt -> stmt | Sloop: stmt -> stmt | Sblock: stmt -> stmt | Sexit: nat -> stmt | Slabel: label -> stmt -> stmt | Sgoto: label -> stmt. Record function : Set := mkfunction { fn_param: ident; fn_body: stmt }. Parameter program: ident -> option function. Parameter main_function: ident. Definition store := ident -> value. Parameter empty_store : store. Parameter eval_op: operator -> value -> value -> option value. Fixpoint eval_expr (st: store) (e: expr) {struct e} : option value := match e with | Evar v => Some (st v) | Econst v => Some v | Eop op e1 e2 => match eval_expr st e1, eval_expr st e2 with | Some v1, Some v2 => eval_op op v1 v2 | _, _ => None end end. Inductive outcome: Set := | Onormal: outcome | Oexit: nat -> outcome | Ogoto: label -> outcome | Oreturn: value -> outcome. Definition outcome_block (out: outcome) : outcome := match out with | Onormal => Onormal | Oexit O => Onormal | Oexit (S m) => Oexit m | Ogoto lbl => Ogoto lbl | Oreturn v => Oreturn v end. Fixpoint label_defined (lbl: label) (s: stmt) {struct s}: Prop := match s with | Sskip => False | Sassign id e => False | Scall id fn e => False | Sreturn e => False | Sseq s1 s2 => label_defined lbl s1 \/ label_defined lbl s2 | Sifthenelse e s1 s2 => label_defined lbl s1 \/ label_defined lbl s2 | Sloop s1 => label_defined lbl s1 | Sblock s1 => label_defined lbl s1 | Sexit n => False | Slabel lbl1 s1 => lbl1 = lbl \/ label_defined lbl s1 | Sgoto lbl => False end. Inductive exec : stmt -> store -> outcome -> store -> Prop := | exec_skip: forall st, exec Sskip st Onormal st | exec_assign: forall id e st v, eval_expr st e = Some v -> exec (Sassign id e) st Onormal (update id v st) | exec_call: forall id fn e st v1 f v2 st', eval_expr st e = Some v1 -> program fn = Some f -> exec_function f (update f.(fn_param) v1 empty_store) v2 st' -> exec (Scall id fn e) st Onormal (update id v2 st) | exec_return: forall e st v, eval_expr st e = Some v -> exec (Sreturn e) st (Oreturn v) st | exec_seq_2: forall s1 s2 st st1 out' st', exec s1 st Onormal st1 -> exec s2 st1 out' st' -> exec (Sseq s1 s2) st out' st' | exec_seq_1: forall s1 s2 st out st', exec s1 st out st' -> out <> Onormal -> exec (Sseq s1 s2) st out st' | exec_ifthenelse_true: forall e s1 s2 st out st' v, eval_expr st e = Some v -> is_true v -> exec s1 st out st' -> exec (Sifthenelse e s1 s2) st out st' | exec_ifthenelse_false: forall e s1 s2 st out st' v, eval_expr st e = Some v -> ~is_true v -> exec s2 st out st' -> exec (Sifthenelse e s1 s2) st out st' | exec_loop_loop: forall s st st1 out' st', exec s st Onormal st1 -> exec (Sloop s) st1 out' st' -> exec (Sloop s) st out' st' | exec_loop_stop: forall s st st' out, exec s st out st' -> out <> Onormal -> exec (Sloop s) st out st' | exec_block: forall s st out st', exec s st out st' -> exec (Sblock s) st (outcome_block out) st' | exec_exit: forall n st, exec (Sexit n) st (Oexit n) st | exec_label: forall s lbl st st' out, exec s st out st' -> exec (Slabel lbl s) st out st' | exec_goto: forall st lbl, exec (Sgoto lbl) st (Ogoto lbl) st (** [execg lbl stmt st out st'] starts executing at label [lbl] within [s], in initial store [st]. The result of the execution is the outcome [out] with final store [st']. *) with execg: label -> stmt -> store -> outcome -> store -> Prop := | execg_left_seq_2: forall lbl s1 s2 st st1 out' st', execg lbl s1 st Onormal st1 -> exec s2 st1 out' st' -> execg lbl (Sseq s1 s2) st out' st' | execg_left_seq_1: forall lbl s1 s2 st out st', execg lbl s1 st out st' -> out <> Onormal -> execg lbl (Sseq s1 s2) st out st' | execg_right_seq: forall lbl s1 s2 st out st', ~(label_defined lbl s1) -> execg lbl s2 st out st' -> execg lbl (Sseq s1 s2) st out st' | execg_ifthenelse_left: forall lbl e s1 s2 st out st', execg lbl s1 st out st' -> execg lbl (Sifthenelse e s1 s2) st out st' | execg_ifthenelse_right: forall lbl e s1 s2 st out st', ~(label_defined lbl s1) -> execg lbl s2 st out st' -> execg lbl (Sifthenelse e s1 s2) st out st' | execg_loop_loop: forall lbl s st st1 out' st', execg lbl s st Onormal st1 -> exec (Sloop s) st1 out' st' -> execg lbl (Sloop s) st out' st' | execg_loop_stop: forall lbl s st st' out, execg lbl s st out st' -> out <> Onormal -> execg lbl (Sloop s) st out st' | execg_block: forall lbl s st out st', execg lbl s st out st' -> execg lbl (Sblock s) st (outcome_block out) st' | execg_label_found: forall lbl s st st' out, exec s st out st' -> execg lbl (Slabel lbl s) st out st' | execg_label_notfound: forall lbl s lbl' st st' out, lbl' <> lbl -> execg lbl s st out st' -> execg lbl (Slabel lbl' s) st out st' (** [exec_finish out st st'] takes the outcome [out] and the store [st] at the end of the evaluation of the program. If [out] is a [goto], execute again the program starting at the corresponding label. Iterate this way until [out] is [Onormal]. *) with exec_finish: function -> outcome -> store -> value -> store -> Prop := | exec_finish_normal: forall f st v, exec_finish f (Oreturn v) st v st | exec_finish_goto: forall f lbl st out v st1 st', execg lbl f.(fn_body) st out st1 -> exec_finish f out st1 v st' -> exec_finish f (Ogoto lbl) st v st' (** Execution of a function *) with exec_function: function -> store -> value -> store -> Prop := | exec_function_intro: forall f st out st1 v st', exec f.(fn_body) st out st1 -> exec_finish f out st1 v st' -> exec_function f st v st'. Scheme exec_ind4:= Minimality for exec Sort Prop with execg_ind4:= Minimality for execg Sort Prop with exec_finish_ind4 := Minimality for exec_finish Sort Prop with exec_function_ind4 := Minimality for exec_function Sort Prop. Scheme exec_dind4:= Induction for exec Sort Prop with execg_dind4:= Minimality for execg Sort Prop with exec_finish_dind4 := Induction for exec_finish Sort Prop with exec_function_dind4 := Induction for exec_function Sort Prop. Combined Scheme exec_inductiond from exec_dind4, execg_dind4, exec_finish_dind4, exec_function_dind4. Scheme exec_dind4' := Induction for exec Sort Prop with execg_dind4' := Induction for execg Sort Prop with exec_finish_dind4' := Induction for exec_finish Sort Prop with exec_function_dind4' := Induction for exec_function Sort Prop. Combined Scheme exec_induction from exec_ind4, execg_ind4, exec_finish_ind4, exec_function_ind4. Combined Scheme exec_inductiond' from exec_dind4', execg_dind4', exec_finish_dind4', exec_function_dind4'. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1041.v0000644000175000017500000000042312326224777021557 0ustar stephstephGoal Prop. pose (P:=(fun x y :Prop => y)). evar (Q: (forall X Y,P X Y -> Prop)) . instantiate (1:= fun _ => _ ) in (Value of Q). instantiate (1:= fun _ => _ ) in (Value of Q). instantiate (1:= fun _ => _ ) in (Value of Q). instantiate (1:=H) in (Value of Q). Admitted. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1718.v0000644000175000017500000000026612326224777021577 0ustar stephsteph(* lazy delta unfolding used to miss delta on rels and vars (fixed in 10172) *) Check let g := fun _ => 0 in fix f (n : nat) := match n with | 0 => g f | S n' => 0 end. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2629.v0000644000175000017500000000133112326224777021573 0ustar stephstephClass Join (t: Type) : Type := mkJoin {join: t -> t -> t -> Prop}. Class sepalg (t: Type) {JOIN: Join t} : Type := SepAlg { join_eq: forall {x y z z'}, join x y z -> join x y z' -> z = z'; join_assoc: forall {a b c d e}, join a b d -> join d c e -> {f : t & join b c f /\ join a f e}; join_com: forall {a b c}, join a b c -> join b a c; join_canc: forall {a1 a2 b c}, join a1 b c -> join a2 b c -> a1=a2; unit_for : t -> t -> Prop := fun e a => join e a a; join_ex_units: forall a, {e : t & unit_for e a} }. Definition joins {A} `{Join A} (a b : A) : Prop := exists c, join a b c. Lemma join_joins {A} `{sepalg A}: forall {a b c}, join a b c -> joins a b. Proof. firstorder. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2083.v0000644000175000017500000000125412326224777021571 0ustar stephstephRequire Import Program Arith. Program Fixpoint check_n (n : nat) (P : { i | i < n } -> bool) (p : nat) (H : forall (i : { i | i < n }), i < p -> P i = true) {measure (n - p)} : Exc (forall (p : { i | i < n}), P p = true) := match le_lt_dec n p with | left _ => value _ | right cmp => if dec (P p) then check_n n P (S p) _ else error end. Require Import Omega. Solve Obligations using program_simpl ; auto with *; try omega. Next Obligation. apply H. simpl. omega. Defined. Next Obligation. case (le_lt_dec p i) ; intros. assert(i = p) by omega. subst. revert H0. clear_subset_proofs. auto. apply H. simpl. assumption. Defined. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2467.v0000644000175000017500000000301712326224777021576 0ustar stephsteph(* In the code below, I would expect the NameSetDec.fsetdec. to solve the Lemma, but I need to do it in steps instead. This is a regression relative to FSet, I have v8.3 (13702). *) Require Import Coq.MSets.MSets. Parameter Name : Set. Parameter Name_compare : Name -> Name -> comparison. Parameter Name_compare_sym : forall {x y : Name}, Name_compare y x = CompOpp (Name_compare x y). Parameter Name_compare_trans : forall {c : comparison} {x y z : Name}, Name_compare x y = c -> Name_compare y z = c -> Name_compare x z = c. Parameter Name_eq_leibniz : forall {s s' : Name}, Name_compare s s' = Eq -> s = s'. Module NameOrderedTypeAlt. Definition t := Name. Definition compare := Name_compare. Definition compare_sym := @Name_compare_sym. Definition compare_trans := @Name_compare_trans. End NameOrderedTypeAlt. Module NameOrderedType := OT_from_Alt(NameOrderedTypeAlt). Module NameOrderedTypeWithLeibniz. Include NameOrderedType. Definition eq_leibniz := @Name_eq_leibniz. End NameOrderedTypeWithLeibniz. Module NameSetMod := MSetList.MakeWithLeibniz(NameOrderedTypeWithLeibniz). Module NameSetDec := WDecide (NameSetMod). Lemma foo : forall (xs ys : NameSetMod.t) (n : Name) (H1 : NameSetMod.Equal xs (NameSetMod.add n ys)), NameSetMod.In n xs. Proof. NameSetDec.fsetdec. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/121.v0000644000175000017500000000064412326224777021502 0ustar stephstephRequire Import Setoid. Section Setoid_Bug. Variable X:Type -> Type. Variable Xeq : forall A, (X A) -> (X A) -> Prop. Hypothesis Xst : forall A, Equivalence (Xeq A). Variable map : forall A B, (A -> B) -> X A -> X B. Implicit Arguments map [A B]. Goal forall A B (a b:X (B -> A)) (c:X A) (f:A -> B -> A), Xeq _ a b -> Xeq _ b (map f c) -> Xeq _ a (map f c). intros A B a b c f Hab Hbc. rewrite Hab. assumption. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2388.v0000644000175000017500000000054312326224777021601 0ustar stephsteph(* Error message was not printed in the correct environment *) Fail Parameters (A:Prop) (a:A A). (* This is a variant (reported as part of bug #2347) *) Require Import EquivDec. Fail Program Instance bool_eq_eqdec : EqDec bool eq := {equiv_dec x y := (fix aux (x y : bool) {struct x}:= aux _ y) x y}. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1322.v0000644000175000017500000000106712326224777021566 0ustar stephstephRequire Import Setoid. Section transition_gen. Variable I : Type. Variable I_eq :I -> I -> Prop. Variable I_eq_equiv : Setoid_Theory I I_eq. (* Add Relation I I_eq reflexivity proved by I_eq_equiv.(Seq_refl I I_eq) symmetry proved by I_eq_equiv.(Seq_sym I I_eq) transitivity proved by I_eq_equiv.(Seq_trans I I_eq) as I_eq_relation. *) Add Setoid I I_eq I_eq_equiv as I_with_eq. Variable F : I -> Type. Variable F_morphism : forall i j, I_eq i j -> F i = F j. Add Morphism F with signature I_eq ==> (@eq _) as F_morphism2. Admitted. End transition_gen. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1618.v0000644000175000017500000000063012326224777021571 0ustar stephstephInductive A: Set := | A1: nat -> A. Definition A_size (a: A) : nat := match a with | A1 n => 0 end. Require Import Recdef. Function n3 (P: A -> Prop) (f: forall n, P (A1 n)) (a: A) {struct a} : P a := match a return (P a) with | A1 n => f n end. Function n1 (P: A -> Prop) (f: forall n, P (A1 n)) (a: A) {measure A_size a} : P a := match a return (P a) with | A1 n => f n end. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2983.v0000644000175000017500000000017712326224777021605 0ustar stephstephModule Type ModA. End ModA. Module Type ModB(A : ModA). End ModB. Module Foo(A : ModA)(B : ModB A). End Foo. Print Module Foo.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1740.v0000644000175000017500000000072712326224777021574 0ustar stephsteph(* Check that expansion of alias in pattern-matching compilation is no longer dependent of whether the pattern-matching problem occurs in a typed context or at toplevel (solved from revision 10883) *) Definition f := fun n m : nat => match n, m with | O, _ => O | n, O => n | _, _ => O end. Goal f = fun n m : nat => match n, m with | O, _ => O | n, O => n | _, _ => O end. unfold f. reflexivity. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1935.v0000644000175000017500000000055212326224777021576 0ustar stephstephDefinition f (n:nat) := n = n. Lemma f_refl : forall n , f n. intros. reflexivity. Qed. Definition f' (x:nat) (n:nat) := n = n. Lemma f_refl' : forall n , f' n n. Proof. intros. reflexivity. Qed. Require Import ZArith. Definition f'' (a:bool) := if a then eq (A:= Z) else Z.lt. Lemma f_refl'' : forall n , f'' true n n. Proof. intro. reflexivity. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2095.v0000644000175000017500000000047012326224777021573 0ustar stephsteph(* Classes and sections *) Section OPT. Variable A: Type. Inductive MyOption: Type := | MyNone: MyOption | MySome: A -> MyOption. Class Opt: Type := { f_opt: A -> MyOption }. End OPT. Definition f_nat (n: nat): MyOption nat := MySome _ n. Instance Nat_Opt: Opt nat := { f_opt := f_nat }. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2281.v0000644000175000017500000000226412326224777021573 0ustar stephsteph(** Bug #2281 In the code below, coq is confused by an equality unless it is first 'subst'ed away, yet http://coq.inria.fr/stdlib/Coq.FSets.FSetDecide.html says fsetdec will first perform any necessary zeta and beta reductions and will invoke subst to eliminate any Coq equalities between finite sets or their elements. I have coq r12851. *) Require Import Arith. Require Import FSets. Require Import FSetWeakList. Module DecidableNat. Definition t := nat. Definition eq := @eq nat. Definition eq_refl := @refl_equal nat. Definition eq_sym := @sym_eq nat. Definition eq_trans := @trans_eq nat. Definition eq_dec := eq_nat_dec. End DecidableNat. Module NatSet := Make(DecidableNat). Module Export NameSetDec := WDecide (NatSet). Lemma ThisLemmaWorks : forall ( s1 s2 : NatSet.t ) ( H : s1 = s2 ), NatSet.Equal s1 s2. Proof. intros. subst. fsetdec. Qed. Import FSetDecideAuxiliary. Lemma ThisLemmaWasFailing : forall ( s1 s2 : NatSet.t ) ( H : s1 = s2 ), NatSet.Equal s1 s2. Proof. intros. fsetdec. (* Error: Tactic failure: because the goal is beyond the scope of this tactic. *) Qed.coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2320.v0000644000175000017500000000106412326224777021562 0ustar stephsteph(* Managing metavariables in the return clause of a match *) (* This was working in 8.1 but is failing in 8.2 and 8.3. It works in trunk thanks to the new proof engine. It could probably made to work in 8.2 and 8.3 if a return predicate of the form "dummy 0" instead of (or in addition to) a sophisticated predicate of the form "as x in dummy y return match y with 0 => ?P | _ => ID end" *) Inductive dummy : nat -> Prop := constr : dummy 0. Lemma failure : forall (x : dummy 0), x = constr. Proof. intros x. refine (match x with constr => _ end). coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1931.v0000644000175000017500000000114212326224777021566 0ustar stephsteph Set Implicit Arguments. Inductive T (A:Set) : Set := app : T A -> T A -> T A. Fixpoint map (A B:Set)(f:A->B)(t:T A) : T B := match t with app t1 t2 => app (map f t1)(map f t2) end. Fixpoint subst (A B:Set)(f:A -> T B)(t:T A) :T B := match t with app t1 t2 => app (subst f t1)(subst f t2) end. (* This is the culprit: *) Definition k0:=Set. (** interaction of subst with map *) Lemma substLaw1 (A:k0)(B C:Set)(f: A -> B)(g:B -> T C)(t: T A): subst g (map f t) = subst (fun x => g (f x)) t. Proof. intros. generalize B C f g; clear B C f g. induction t; intros; simpl. f_equal. Admitted. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/2021.v0000644000175000017500000000107312326224777021560 0ustar stephsteph(* correct failure of injection/discriminate on types whose inductive status derives from the substitution of an argument *) Inductive t : nat -> Type := | M : forall n: nat, nat -> t n. Lemma eq_t : forall n n' m m', existT (fun B : Type => B) (t n) (M n m) = existT (fun B : Type => B) (t n') (M n' m') -> True. Proof. intros. injection H. intro Ht. exact I. Qed. Lemma eq_t' : forall n n' : nat, existT (fun B : Type => B) (t n) (M n 0) = existT (fun B : Type => B) (t n') (M n' 1) -> True. Proof. intros. discriminate H || exact I. Qed. coq-8.4pl4/test-suite/bugs/closed/shouldsucceed/1696.v0000644000175000017500000000066012326224777021602 0ustar stephstephRequire Import Setoid. Inductive mynat := z : mynat | s : mynat -> mynat. Parameter E : mynat -> mynat -> Prop. Axiom E_equiv : equiv mynat E. Add Relation mynat E reflexivity proved by (proj1 E_equiv) symmetry proved by (proj2 (proj2 E_equiv)) transitivity proved by (proj1 (proj2 E_equiv)) as E_rel. Notation "x == y" := (E x y) (at level 70). Goal z == s z -> s z == z. intros H. setoid_rewrite H at 2. reflexivity. Qed. coq-8.4pl4/test-suite/bugs/closed/3003.v0000644000175000017500000000101412326224777016722 0ustar stephsteph(* This used to raise an anomaly in 8.4 and trunk up to 17 April 2013 *) Set Implicit Arguments. Inductive path (V : Type) (E : V -> V -> Type) (s : V) : V -> Type := | NoEdges : path E s s | AddEdge : forall d d' : V, path E s d -> E d d' -> path E s d'. Inductive G_Vertex := G_v0 | G_v1. Inductive G_Edge : G_Vertex -> G_Vertex -> Set := G_e : G_Edge G_v0 G_v1. Goal forall x1 : G_Edge G_v1 G_v1, @AddEdge _ G_Edge G_v1 _ _ (NoEdges _ _) x1 = NoEdges _ _. intro x1. try destruct x1. (* now raises a typing error *) coq-8.4pl4/test-suite/modules/0000755000175000017500000000000012365131023015371 5ustar stephstephcoq-8.4pl4/test-suite/modules/modul.v0000644000175000017500000000061212326224777016717 0ustar stephstephModule M. Parameter rel : nat -> nat -> Prop. Axiom w : forall n : nat, rel 0 (S n). Hint Resolve w. (* : Grammar is replaced by Notation *) Print Hint *. Lemma w1 : rel 0 1. auto. Qed. End M. Locate Module M. (*Lemma w1 : (M.rel O (S O)). Auto. *) Import M. Lemma w1 : rel 0 1. auto. Qed. Check (rel 0 0). Locate rel. Locate Module M. Module N := Top.M. coq-8.4pl4/test-suite/modules/sig.v0000644000175000017500000000065612326224777016371 0ustar stephstephModule M. Module Type SIG. Parameter T : Set. Parameter x : T. End SIG. Module N : SIG. Definition T := nat. Definition x := 0. End N. End M. Module N := M. Module Type SPRYT. Module N. Definition T := M.N.T. Parameter x : T. End N. End SPRYT. Module K : SPRYT := N. Module K' : SPRYT := M. Module Type SIG. Definition T : Set := M.N.T. Parameter x : T. End SIG. Module J : SIG := M.N.coq-8.4pl4/test-suite/modules/subtyping.v0000644000175000017500000000253512326224777017631 0ustar stephsteph(* Non regression for bug #1302 *) (* With universe polymorphism for inductive types, subtyping of inductive types needs a special treatment: the standard conversion algorithm does not work as it only knows to deal with constraints of the form alpha = beta or max(alphas, alphas+1) <= beta, while subtyping of inductive types in Type generates constraints of the form max(alphas, alphas+1) <= max(betas, betas+1). These constraints are anyway valid by monotonicity of subtyping but we have to detect it early enough to avoid breaking the standard algorithm for constraints on algebraic universes. *) Module Type T. Parameter A : Type (* Top.1 *) . Inductive L : Type (* max(Top.1,1) *) := | L0 | L1 : (A -> Prop) -> L. End T. Axiom Tp : Type (* Top.5 *) . Module TT : T. Definition A : Type (* Top.6 *) := Tp. (* generates Top.5 <= Top.6 *) Inductive L : Type (* max(Top.6,1) *) := | L0 | L1 : (A -> Prop) -> L. End TT. (* Generates Top.6 <= Top.1 (+ auxiliary constraints for L_rect) *) (* Note: Top.6 <= Top.1 is generated by subtyping on A; subtyping of L follows and has not to be checked *) (* The same bug as #1302 but for Definition *) (* Check that inferred algebraic universes in interfaces are considered *) Module Type U. Definition A := Type -> Type. End U. Module M:U. Definition A := Type -> Type. End M. coq-8.4pl4/test-suite/modules/resolver.v0000644000175000017500000000072212326224777017442 0ustar stephstephModule Type TA. Parameter t : Set. End TA. Module Type TB. Declare Module A: TA. End TB. Module Type TC. Declare Module B : TB. End TC. Module Type TD. Declare Module B: TB . Declare Module C: TC with Module B := B . End TD. Module Type TE. Declare Module D : TD. End TE. Module Type TF. Declare Module E: TE. End TF. Module G (D: TD). Module B' := D.C.B. End G. Module H (F: TF). Module I := G(F.E.D). End H. Declare Module F: TF. Module K := H(F). coq-8.4pl4/test-suite/modules/injection_discriminate_inversion.v0000644000175000017500000000114212326224777024407 0ustar stephstephModule M. Inductive I : Set := C : nat -> I. End M. Module M1 := M. Goal forall x, M.C x = M1.C 0 -> x = 0 . intros x H. (* injection sur deux constructeurs egaux mais appeles par des modules differents *) injection H. tauto. Qed. Goal M.C 0 <> M1.C 1. (* Discriminate sur deux constructeurs egaux mais appeles par des modules differents *) intro H;discriminate H. Qed. Goal forall x, M.C x = M1.C 0 -> x = 0. intros x H. (* inversion sur deux constructeurs egaux mais appeles par des modules differents *) inversion H. reflexivity. Qed.coq-8.4pl4/test-suite/modules/pliczek.v0000644000175000017500000000007212326224777017240 0ustar stephstephRequire Export plik. Definition tutu (X : Set) := toto X.coq-8.4pl4/test-suite/modules/errors.v0000644000175000017500000000564412326224777017125 0ustar stephsteph(* Inductive mismatches *) Module Type SA. Inductive TA : nat -> Prop := CA : nat -> TA 0. End SA. Module MA : SA. Inductive TA : Prop := CA : bool -> TA. Fail End MA. Module Type SA. Inductive TA := CA : nat -> TA. End SA. Module MA : SA. Inductive TA := CA : bool -> TA. Fail End MA. Module Type SA. Inductive TA := CA : nat -> TA. End SA. Module MA : SA. Inductive TA := CA : bool -> nat -> TA. Fail End MA. Module Type SA2. Inductive TA2 := CA2 : nat -> TA2. End SA2. Module MA2 : SA2. Inductive TA2 := CA2 : nat -> TA2 | DA2 : TA2. Fail End MA2. Module Type SA3. Inductive TA3 := CA3 : nat -> TA3. End SA3. Module MA3 : SA3. Inductive TA3 := CA3 : nat -> TA3 with UA3 := DA3. Fail End MA3. Module Type SA4. Inductive TA4 := CA4 : nat -> TA4 with UA4 := DA4. End SA4. Module MA4 : SA4. Inductive TA4 := CA4 : nat -> TA4 with VA4 := DA4. Fail End MA4. Module Type SA5. Inductive TA5 := CA5 : nat -> TA5 with UA5 := DA5. End SA5. Module MA5 : SA5. Inductive TA5 := CA5 : nat -> TA5 with UA5 := EA5. Fail End MA5. Module Type SA6. Inductive TA6 (A:Type) := CA6 : A -> TA6 A. End SA6. Module MA6 : SA6. Inductive TA6 (A B:Type):= CA6 : A -> TA6 A B. Fail End MA6. Module Type SA7. Inductive TA7 (A:Type) := CA7 : A -> TA7 A. End SA7. Module MA7 : SA7. CoInductive TA7 (A:Type):= CA7 : A -> TA7 A. Fail End MA7. Module Type SA8. CoInductive TA8 (A:Type) := CA8 : A -> TA8 A. End SA8. Module MA8 : SA8. Inductive TA8 (A:Type):= CA8 : A -> TA8 A. Fail End MA8. Module Type SA9. Record TA9 (A:Type) := { CA9 : A }. End SA9. Module MA9 : SA9. Inductive TA9 (A:Type):= CA9 : A -> TA9 A. Fail End MA9. Module Type SA10. Inductive TA10 (A:Type) := CA10 : A -> TA10 A. End SA10. Module MA10 : SA10. Record TA10 (A:Type):= { CA10 : A }. Fail End MA10. Module Type SA11. Record TA11 (A:Type):= { CA11 : A }. End SA11. Module MA11 : SA11. Record TA11 (A:Type):= { DA11 : A }. Fail End MA11. (* Basic mismatches *) Module Type SB. Inductive TB := CB : nat -> TB. End SB. Module MB : SB. Module Type TB. End TB. Fail End MB. Module Type SC. Module Type TC. End TC. End SC. Module MC : SC. Inductive TC := CC : nat -> TC. Fail End MC. Module Type SD. Module TD. End TD. End SD. Module MD : SD. Inductive TD := DD : nat -> TD. Fail End MD. Module Type SE. Definition DE := nat. End SE. Module ME : SE. Definition DE := bool. Fail End ME. Module Type SF. Parameter DF : nat. End SF. Module MF : SF. Definition DF := bool. Fail End MF. (* Needs a type constraint in module type *) Module Type SG. Definition DG := Type. End SG. Module MG : SG. Definition DG := Type : Type. Fail End MG. (* Should work *) Module Type SA7. Inductive TA7 (A:Type) := CA7 : A -> TA7 A. End SA7. Module MA7 : SA7. Inductive TA7 (B:Type):= CA7 : B -> TA7 B. End MA7. Module Type SA11. Record TA11 (B:Type):= { CA11 : B }. End SA11. Module MA11 : SA11. Record TA11 (A:Type):= { CA11 : A }. End MA11. Module Type SE. Parameter DE : Type. End SE. Module ME : SE. Definition DE := Type : Type. End ME. coq-8.4pl4/test-suite/modules/PO.v0000644000175000017500000000213312326224777016115 0ustar stephstephSet Implicit Arguments. Unset Strict Implicit. Implicit Arguments fst. Implicit Arguments snd. Module Type PO. Parameter T : Set. Parameter le : T -> T -> Prop. Axiom le_refl : forall x : T, le x x. Axiom le_trans : forall x y z : T, le x y -> le y z -> le x z. Axiom le_antis : forall x y : T, le x y -> le y x -> x = y. Hint Resolve le_refl le_trans le_antis. End PO. Module Pair (X: PO) (Y: PO) <: PO. Definition T := (X.T * Y.T)%type. Definition le p1 p2 := X.le (fst p1) (fst p2) /\ Y.le (snd p1) (snd p2). Hint Unfold le. Lemma le_refl : forall p : T, le p p. info auto. Qed. Lemma le_trans : forall p1 p2 p3 : T, le p1 p2 -> le p2 p3 -> le p1 p3. unfold le; intuition; info eauto. Qed. Lemma le_antis : forall p1 p2 : T, le p1 p2 -> le p2 p1 -> p1 = p2. destruct p1. destruct p2. unfold le. intuition. cutrewrite (t = t1). cutrewrite (t0 = t2). reflexivity. info auto. info auto. Qed. End Pair. Require Nat. Module NN := Pair Nat Nat. Lemma zz_min : forall p : NN.T, NN.le (0, 0) p. info auto with arith. Qed.coq-8.4pl4/test-suite/modules/mod_decl.v0000644000175000017500000000103712326224777017347 0ustar stephstephModule Type SIG. Axiom A : Set. End SIG. Module M0. Definition A : Set. exact nat. Qed. End M0. Module M1 : SIG. Definition A := nat. End M1. Module M2 <: SIG. Definition A := nat. End M2. Module M3 := M0. Module M4 : SIG := M0. Module M5 <: SIG := M0. Module F (X: SIG) := X. Module Type T. Module M0. Axiom A : Set. End M0. Declare Module M1: SIG. Module M2 <: SIG. Definition A := nat. End M2. Module M3 := M0. Module M4 : SIG := M0. Module M5 <: SIG := M0. Module M6 := F M0. End T. coq-8.4pl4/test-suite/modules/Przyklad.v0000644000175000017500000000733212326224777017405 0ustar stephstephDefinition ifte (T : Set) (A B : Prop) (s : {A} + {B}) (th el : T) := if s then th else el. Implicit Arguments ifte. Lemma Reflexivity_provable : forall (A : Set) (a : A) (s : {a = a} + {a <> a}), exists x : _, s = left _ x. intros. elim s. intro x. split with x; reflexivity. intro. absurd (a = a); auto. Qed. Lemma Disequality_provable : forall (A : Set) (a b : A), a <> b -> forall s : {a = b} + {a <> b}, exists x : _, s = right _ x. intros. elim s. intro. absurd (a = a); auto. intro. split with b0; reflexivity. Qed. Module Type ELEM. Parameter T : Set. Parameter eq_dec : forall a a' : T, {a = a'} + {a <> a'}. End ELEM. Module Type SET (Elt: ELEM). Parameter T : Set. Parameter empty : T. Parameter add : Elt.T -> T -> T. Parameter find : Elt.T -> T -> bool. (* Axioms *) Axiom find_empty_false : forall e : Elt.T, find e empty = false. Axiom find_add_true : forall (s : T) (e : Elt.T), find e (add e s) = true. Axiom find_add_false : forall (s : T) (e e' : Elt.T), e <> e' -> find e (add e' s) = find e s. End SET. Module FuncDict (E: ELEM). Definition T := E.T -> bool. Definition empty (e' : E.T) := false. Definition find (e' : E.T) (s : T) := s e'. Definition add (e : E.T) (s : T) (e' : E.T) := ifte (E.eq_dec e e') true (find e' s). Lemma find_empty_false : forall e : E.T, find e empty = false. auto. Qed. Lemma find_add_true : forall (s : T) (e : E.T), find e (add e s) = true. intros. unfold find, add. elim (Reflexivity_provable _ _ (E.eq_dec e e)). intros. rewrite H. auto. Qed. Lemma find_add_false : forall (s : T) (e e' : E.T), e <> e' -> find e (add e' s) = find e s. intros. unfold add, find. cut (exists x : _, E.eq_dec e' e = right _ x). intros. elim H0. intros. rewrite H1. unfold ifte. reflexivity. apply Disequality_provable. auto. Qed. End FuncDict. Module F : SET := FuncDict. Module Nat. Definition T := nat. Lemma eq_dec : forall a a' : T, {a = a'} + {a <> a'}. decide equality. Qed. End Nat. Module SetNat := F Nat. Lemma no_zero_in_empty : SetNat.find 0 SetNat.empty = false. apply SetNat.find_empty_false. Qed. (***************************************************************************) Module Lemmas (G: SET) (E: ELEM). Module ESet := G E. Lemma commute : forall (S : ESet.T) (a1 a2 : E.T), let S1 := ESet.add a1 (ESet.add a2 S) in let S2 := ESet.add a2 (ESet.add a1 S) in forall a : E.T, ESet.find a S1 = ESet.find a S2. intros. unfold S1, S2. elim (E.eq_dec a a1); elim (E.eq_dec a a2); intros H1 H2; try rewrite <- H1; try rewrite <- H2; repeat (try ( rewrite ESet.find_add_true; auto); try ( rewrite ESet.find_add_false; auto); auto). Qed. End Lemmas. Inductive list (A : Set) : Set := | nil : list A | cons : A -> list A -> list A. Module ListDict (E: ELEM). Definition T := list E.T. Definition elt := E.T. Definition empty := nil elt. Definition add (e : elt) (s : T) := cons elt e s. Fixpoint find (e : elt) (s : T) {struct s} : bool := match s with | nil => false | cons e' s' => ifte (E.eq_dec e e') true (find e s') end. Definition find_empty_false (e : elt) := refl_equal false. Lemma find_add_true : forall (s : T) (e : E.T), find e (add e s) = true. intros. simpl. elim (Reflexivity_provable _ _ (E.eq_dec e e)). intros. rewrite H. auto. Qed. Lemma find_add_false : forall (s : T) (e e' : E.T), e <> e' -> find e (add e' s) = find e s. intros. simpl. elim (Disequality_provable _ _ _ H (E.eq_dec e e')). intros. rewrite H0. simpl. reflexivity. Qed. End ListDict. Module L : SET := ListDict. coq-8.4pl4/test-suite/modules/nested_mod_types.v0000644000175000017500000000060512326224777021146 0ustar stephstephModule Type T. Module Type U. Module Type V. Variable b : nat. End V. Variable a : nat. End U. Declare Module u : U. Declare Module v : u.V. End T. Module F (t:T). End F. Module M:T. Module Type U. Module Type V. Variable b : nat. End V. Variable a : nat. End U. Declare Module u : U. Declare Module v : u.V. End M. Module FM := F M. coq-8.4pl4/test-suite/modules/Nat.v0000644000175000017500000000047212326224777016325 0ustar stephstephDefinition T := nat. Definition le := le. Hint Unfold le. Lemma le_refl : forall n : nat, le n n. auto. Qed. Require Import Le. Lemma le_trans : forall n m k : nat, le n m -> le m k -> le n k. eauto with arith. Qed. Lemma le_antis : forall n m : nat, le n m -> le m n -> n = m. eauto with arith. Qed.coq-8.4pl4/test-suite/modules/modeq.v0000644000175000017500000000050112326224777016701 0ustar stephstephModule M. Definition T := nat. Definition x : T := 0. End M. Module Type SIG. Module M := Top.M. Module Type SIG. Parameter T : Set. End SIG. Declare Module N: SIG. End SIG. Module Z. Module M := Top.M. Module Type SIG. Parameter T : Set. End SIG. Module N := M. End Z. Module A : SIG := Z.coq-8.4pl4/test-suite/modules/plik.v0000644000175000017500000000012212326224777016532 0ustar stephstephDefinition toto (x : Set) := x. (* : Grammar is replaced by Notation *)coq-8.4pl4/test-suite/modules/objects.v0000644000175000017500000000062212326224777017231 0ustar stephstephModule Type SET. Axiom T : Set. Axiom x : T. End SET. Set Implicit Arguments. Unset Strict Implicit. Module M (X: SET). Definition T := nat. Definition x := 0. Definition f (A : Set) (x : A) := X.x. End M. Module N := M. Module Nat. Definition T := nat. Definition x := 0. End Nat. Module Z := N Nat. Check (Z.f 0). Module P (Y: SET) := N. Module Y := P Z Nat. Check (Y.f 0). coq-8.4pl4/test-suite/modules/Demo.v0000644000175000017500000000114712326224777016467 0ustar stephstephModule M. Definition t := nat. Definition x := 0. End M. Print M.t. Module Type SIG. Parameter t : Set. Parameter x : t. End SIG. Module F (X: SIG). Definition t := X.t -> X.t. Definition x : t. intro. exact X.x. Defined. Definition y := X.x. End F. Module N := F M. Print N.t. Eval compute in N.t. Module N' : SIG := N. Print N'.t. Eval compute in N'.t. Module N'' <: SIG := F N. Print N''.t. Eval compute in N''.t. Eval compute in N''.x. Module N''' : SIG with Definition t := nat -> nat := N. Print N'''.t. Eval compute in N'''.t. Print N'''.x. Import N'''. Print t.coq-8.4pl4/test-suite/modules/fun_objects.v0000644000175000017500000000066012326224777020103 0ustar stephstephSet Implicit Arguments. Unset Strict Implicit. Module Type SIG. Parameter id : forall A : Set, A -> A. End SIG. Module M (X: SIG). Definition idid := X.id X.id. Definition id := idid X.id. End M. Module N := M. Module Nat. Definition T := nat. Definition x := 0. Definition id (A : Set) (x : A) := x. End Nat. Module Z := N Nat. Check (Z.idid 0). Module P (Y: SIG) := N. Module Y := P Nat Z. Check (Y.id 0). coq-8.4pl4/test-suite/modules/obj.v0000644000175000017500000000060212326224777016350 0ustar stephstephSet Implicit Arguments. Unset Strict Implicit. Module M. Definition a (s : Set) := s. Print a. End M. Print M.a. Module K. Definition app (A B : Set) (f : A -> B) (x : A) := f x. Module N. Definition apap (A B : Set) := app (app (A:=A) (B:=B)). Print app. Print apap. End N. Print N.apap. End K. Print K.app. Print K.N.apap. Module W := K.N. Print W.apap. coq-8.4pl4/test-suite/modules/pseudo_circular_with.v0000644000175000017500000000023312326224777022014 0ustar stephstephModule Type S. End S. Module Type T. Declare Module M:S. End T. Module N:S. End N. Module NN:T. Module M:=N. End NN. Module Type U := T with Module M:=NN.coq-8.4pl4/test-suite/modules/grammar.v0000644000175000017500000000035612326224777017232 0ustar stephstephModule N. Definition f := plus. (* : Syntax is discontinued *) Check (f 0 0). End N. Check (N.f 0 0). Import N. Check (f 0 0). Check (f 0 0). Module M := N. Check (f 0 0). Check (f 0 0). Import M. Check (f 0 0). Check (N.f 0 0).coq-8.4pl4/test-suite/modules/objects2.v0000644000175000017500000000060212326224777017311 0ustar stephsteph(* Check that non logical object loading is done after registration of the logical objects in the environment *) (* Bug #1118 (simplified version), submitted by Evelyne Contejean (used to failed in pre-V8.1 trunk because of a call to lookup_mind for structure objects) *) Module Type S. Record t : Set := { a : nat; b : nat }. End S. Module Make (X:S). Module Y:=X. End Make. coq-8.4pl4/test-suite/modules/Tescik.v0000644000175000017500000000106712326224777017026 0ustar stephsteph Module Type ELEM. Parameter A : Set. Parameter x : A. End ELEM. Module Nat. Definition A := nat. Definition x := 0. End Nat. Module List (X: ELEM). Inductive list : Set := | nil : list | cons : X.A -> list -> list. Definition head (l : list) := match l with | nil => X.x | cons x _ => x end. Definition singl (x : X.A) := cons x nil. Lemma head_singl : forall x : X.A, head (singl x) = x. auto. Qed. End List. Module N := List Nat.coq-8.4pl4/test-suite/modules/sub_objects.v0000644000175000017500000000113012326224777020075 0ustar stephstephSet Implicit Arguments. Unset Strict Implicit. Module M. Definition id (A : Set) (x : A) := x. Module Type SIG. Parameter idid : forall A : Set, A -> A. End SIG. Module N. Definition idid (A : Set) (x : A) := id x. (* : Grammar is replaced by Notation *) Notation inc := (plus 1). End N. Definition zero := N.idid 0. End M. Definition zero := M.N.idid 0. Definition jeden := M.N.inc 0. Module Goly := M.N. Definition Gole_zero := Goly.idid 0. Definition Goly_jeden := Goly.inc 0. Module Ubrany : M.SIG := M.N. Definition Ubrane_zero := Ubrany.idid 0. coq-8.4pl4/test-suite/modules/ind.v0000644000175000017500000000245212326224777016355 0ustar stephstephModule Type SIG. Inductive w : Set := A : w. Parameter f : w -> w. End SIG. Module M : SIG. Inductive w : Set := A : w. Definition f x := match x with | A => A end. End M. Module N := M. Check (N.f M.A). (* Check use of equivalence on inductive types (bug #1242) *) Module Type ASIG. Inductive t : Set := a | b : t. Definition f := fun x => match x with a => true | b => false end. End ASIG. Module Type BSIG. Declare Module A : ASIG. Definition f := fun x => match x with A.a => true | A.b => false end. End BSIG. Module C (A : ASIG) (B : BSIG with Module A:=A). (* Check equivalence is considered in "case_info" *) Lemma test : forall x, A.f x = B.f x. intro x. unfold B.f, A.f. destruct x; reflexivity. Qed. (* Check equivalence is considered in pattern-matching *) Definition f (x : A.t) := match x with B.A.a => true | B.A.b => false end. End C. (* Check subtyping of the context of parameters of the inductive types *) (* Only the number of expected uniform parameters and the convertibility *) (* of the inductive arities and constructors types are checked *) Module Type S. Inductive I (x:=0) (y:nat): Set := c: x=y -> I y. End S. Module P : S. Inductive I (y':nat) (z:=y'): Set := c : 0=y' -> I y'. End P. coq-8.4pl4/test-suite/ide/0000755000175000017500000000000012365131023014462 5ustar stephstephcoq-8.4pl4/test-suite/ide/undo015.fake0000644000175000017500000000116612326224777016531 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # Test backtracking in presence of nested proofs # Fourth, undo from an inner proof to a above proof # INTERP Lemma aa : True -> True /\ True. INTERP intro H. INTERP split. INTERP Lemma bb : False -> False. INTERP intro H. INTERP apply H. INTERP Qed. INTERP apply H. INTERP Lemma cc : False -> True. INTERP intro H. INTERP destruct H. REWIND 4 # INTERP apply H. INTERP Lemma cc : False -> True. INTERP intro H. INTERP destruct H. # INTERP Qed. INTERP apply H. INTERP Qed. INTERPRAW Fail idtac. INTERPRAW Check (aa,bb,cc). coq-8.4pl4/test-suite/ide/undo001.fake0000644000175000017500000000040212326224777016514 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # Simple backtrack by 1 between two global definitions # INTERP Definition foo := 0. INTERP Definition bar := 1. REWIND 1 INTERPRAW Check foo. INTERPRAW Fail Check bar. coq-8.4pl4/test-suite/ide/undo013.fake0000644000175000017500000000125212326224777016523 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # Test backtracking in presence of nested proofs # Second, trigger the full undo of an inner proof # INTERP Lemma aa : True -> True /\ True. INTERP intro H. INTERP split. INTERP Lemma bb : False -> False. INTERP intro H. INTERP apply H. INTERP Qed. INTERP apply H. INTERP Lemma cc : False -> True. INTERP intro H. INTERP destruct H. INTERP Qed. INTERP apply H. REWIND 2 # We should now be just before "Lemma cc" # INTERP Lemma cc : False -> True. INTERP intro H. INTERP destruct H. INTERP Qed. INTERP apply H. # INTERP Qed. INTERPRAW Fail idtac. INTERPRAW Check (aa,bb,cc). coq-8.4pl4/test-suite/ide/undo008.fake0000644000175000017500000000060512326224777016530 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # Undoing declarations, as non-first step # new in 8.2 # INTERP Theorem h : O=O. INTERP assert True by trivial. INTERP Definition i := O. INTERP Definition j := O. REWIND 1 # INTERP Definition j := O. # <\replay> INTERP assert True by trivial. INTERP trivial. INTERP Qed. INTERPRAW Check i. coq-8.4pl4/test-suite/ide/undo016.fake0000644000175000017500000000136212326224777016530 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # Test backtracking in presence of nested proofs # Fifth, undo from an inner proof to a previous inner proof # INTERP Lemma aa : True -> True /\ True. INTERP intro H. INTERP split. INTERP Lemma bb : False -> False. INTERP intro H. INTERP apply H. INTERP Qed. INTERP apply H. INTERP Lemma cc : False -> True. INTERP intro H. INTERP destruct H. REWIND 6 # We should be just before "Lemma bb" # INTERP Lemma bb : False -> False. INTERP intro H. INTERP apply H. INTERP Qed. INTERP apply H. INTERP Lemma cc : False -> True. INTERP intro H. INTERP destruct H. # INTERP Qed. INTERP apply H. INTERP Qed. INTERPRAW Fail idtac. INTERPRAW Check (aa,bb,cc). coq-8.4pl4/test-suite/ide/undo009.fake0000644000175000017500000000073012326224777016530 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # Undoing declarations, interleaved with proof steps # new in 8.2 *) # INTERP Theorem k : O=O. INTERP assert True by trivial. INTERP Definition l := O. INTERP assert True by trivial. INTERP Definition m := O. REWIND 3 # INTERP Definition l := O. INTERP assert True by trivial. INTERP Definition m := O. # <\replay> INTERP assert True by trivial. INTERP trivial. INTERP Qed. coq-8.4pl4/test-suite/ide/undo002.fake0000644000175000017500000000040612326224777016521 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # Simple backtrack by 2 before two global definitions # INTERP Definition foo := 0. INTERP Definition bar := 1. REWIND 2 INTERPRAW Fail Check foo. INTERPRAW Fail Check bar. coq-8.4pl4/test-suite/ide/undo003.fake0000644000175000017500000000027712326224777016530 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # Simple backtrack by 0 should be a no-op # INTERP Definition foo := 0. REWIND 0 INTERPRAW Check foo. coq-8.4pl4/test-suite/ide/undo.v0000644000175000017500000000351212326224777015637 0ustar stephsteph(* Here are a sequences of scripts to test interactively with undo and replay in coqide proof sessions *) (* Undoing arbitrary commands, as first step *) Theorem a : O=O. (* 2 *) Ltac f x := x. (* 1 * 3 *) assert True by trivial. trivial. Qed. (* Undoing arbitrary commands, as non-first step *) Theorem b : O=O. assert True by trivial. Ltac g x := x. assert True by trivial. trivial. Qed. (* Undoing declarations, as first step *) (* was bugged in 8.1 *) Theorem c : O=O. Inductive T : Type := I. trivial. Qed. (* Undoing declarations, as first step *) (* new in 8.2 *) Theorem d : O=O. Definition e := O. Definition f := O. assert True by trivial. trivial. Qed. (* Undoing declarations, as non-first step *) (* new in 8.2 *) Theorem h : O=O. assert True by trivial. Definition i := O. Definition j := O. assert True by trivial. trivial. Qed. (* Undoing declarations, interleaved with proof steps *) (* new in 8.2 *) Theorem k : O=O. assert True by trivial. Definition l := O. assert True by trivial. Definition m := O. assert True by trivial. trivial. Qed. (* Undoing declarations, interleaved with proof steps and commands *) (* new in 8.2 *) Theorem n : O=O. assert True by trivial. Definition o := O. Ltac h x := x. assert True by trivial. Focus. Definition p := O. assert True by trivial. trivial. Qed. (* Undoing declarations, not in proof *) Definition q := O. Definition r := O. (* Bug 2082 : Follow the numbers *) (* Broken due to proof engine rewriting *) Variable A : Prop. Variable B : Prop. Axiom OR : A \/ B. Lemma MyLemma2 : True. proof. per cases of (A \/ B) by OR. suppose A. then (1 = 1). then H1 : thesis. (* 4 *) thus thesis by H1. (* 2 *) suppose B. (* 1 *) (* 3 *) then (1 = 1). then H2 : thesis. thus thesis by H2. end cases. end proof. Qed. (* 5 if you made it here, there is no regression *) coq-8.4pl4/test-suite/ide/undo011.fake0000644000175000017500000000124612326224777016524 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # Bug 2082 # Broken due to proof engine rewriting # INTERP Variable A : Prop. INTERP Variable B : Prop. INTERP Axiom OR : A \/ B. INTERP Lemma MyLemma2 : True. INTERP proof. INTERP per cases of (A \/ B) by OR. INTERP suppose A. INTERP then (1 = 1). INTERP then H1 : thesis. INTERP thus thesis by H1. INTERP suppose B. REWIND 1 # INTERP suppose B. # REWIND 2 # INTERP thus thesis by H1. INTERP suppose B. # INTERP then (1 = 1). INTERP then H2 : thesis. INTERP thus thesis by H2. INTERP end cases. INTERP end proof. INTERP Qed. coq-8.4pl4/test-suite/ide/undo018.fake0000644000175000017500000000037312326224777016533 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # bug #2569 : Undoing inside section # INTERP Section M. INTERP Definition x := 0. INTERP End M. REWIND 1 # INTERP End M. # INTERPRAW Check x. coq-8.4pl4/test-suite/ide/undo010.fake0000644000175000017500000000112412326224777016516 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # Undoing declarations, interleaved with proof steps and commands *) # new in 8.2 *) # INTERP Theorem n : O=O. INTERP assert True by trivial. INTERP Definition o := O. INTERP Ltac h x := x. INTERP assert True by trivial. INTERP Focus. INTERP Definition p := O. REWIND 1 REWIND 1 REWIND 1 REWIND 1 REWIND 1 # INTERP Definition o := O. INTERP Ltac h x := x. INTERP assert True by trivial. INTERP Focus. INTERP Definition p := O. # INTERP assert True by trivial. INTERP trivial. INTERP Qed. coq-8.4pl4/test-suite/ide/undo012.fake0000644000175000017500000000113212326224777016517 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # Test backtracking in presence of nested proofs # First, undoing the whole # INTERP Lemma aa : True -> True /\ True. INTERP intro H. INTERP split. INTERP Lemma bb : False -> False. INTERP intro H. INTERP apply H. INTERP Qed. INTERP apply H. INTERP Lemma cc : False -> True. INTERP intro H. INTERP destruct H. INTERP Qed. INTERP apply H. INTERP Qed. REWIND 1 # We should now be just before aa, without opened proofs INTERPRAW Fail idtac. INTERPRAW Fail Check aa. INTERPRAW Fail Check bb. INTERPRAW Fail Check cc. coq-8.4pl4/test-suite/ide/undo019.fake0000644000175000017500000000035512326224777016534 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # bug #2569 : Undoing a focused subproof # INTERP Goal True. INTERP { INTERP exact I. INTERP } REWIND 1 # INTERP } # INTERP Qed. coq-8.4pl4/test-suite/ide/undo017.fake0000644000175000017500000000037412326224777016533 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # bug #2569 : Undoing inside modules # INTERP Module M. INTERP Definition x := 0. INTERP End M. REWIND 1 # INTERP End M. # INTERPRAW Check M.x. coq-8.4pl4/test-suite/ide/undo007.fake0000644000175000017500000000054212326224777016527 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # Undoing declarations, as first step # new in 8.2 # INTERP Theorem d : O=O. INTERP Definition e := O. INTERP Definition f := O. REWIND 1 # INTERP Definition f := O. # <\replay> INTERP assert True by trivial. INTERP trivial. INTERP Qed. INTERPRAW Check e. coq-8.4pl4/test-suite/ide/undo014.fake0000644000175000017500000000104512326224777016524 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # Test backtracking in presence of nested proofs # Third, undo inside an inner proof # INTERP Lemma aa : True -> True /\ True. INTERP intro H. INTERP split. INTERP Lemma bb : False -> False. INTERP intro H. INTERP apply H. INTERP Qed. INTERP apply H. INTERP Lemma cc : False -> True. INTERP intro H. INTERP destruct H. REWIND 1 # INTERP destruct H. # INTERP Qed. INTERP apply H. INTERP Qed. INTERPRAW Fail idtac. INTERPRAW Check (aa,bb,cc). coq-8.4pl4/test-suite/ide/undo006.fake0000644000175000017500000000045112326224777016525 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # Undoing declarations, as first step # Was bugged in 8.1 # INTERP Theorem c : O=O. INTERP Inductive T : Type := I. REWIND 1 # INTERP Inductive T : Type := I. # <\replay> INTERP trivial. INTERP Qed. coq-8.4pl4/test-suite/ide/undo004.fake0000644000175000017500000000044612326224777016527 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # Undoing arbitrary commands, as first step # INTERP Theorem a : O=O. INTERP Ltac f x := x. REWIND 1 # INTERP Ltac f x := x. # <\replay> INTERP assert True by trivial. INTERP trivial. INTERP Qed. coq-8.4pl4/test-suite/ide/undo005.fake0000644000175000017500000000051112326224777016521 0ustar stephsteph# Script simulating a dialog between coqide and coqtop -ideslave # Run it via fake_ide # # Undoing arbitrary commands, as non-first step # INTERP Theorem b : O=O. INTERP assert True by trivial. INTERP Ltac g x := x. # REWIND 1 # <\replay> INTERP Ltac g x := x. INTERP assert True by trivial. INTERP trivial. INTERP Qed. coq-8.4pl4/test-suite/success/0000755000175000017500000000000012365131023015371 5ustar stephstephcoq-8.4pl4/test-suite/success/bullet.v0000644000175000017500000000006512326224777017070 0ustar stephstephGoal True /\ True. split. - exact I. - exact I. Qed. coq-8.4pl4/test-suite/success/Fourier.v0000644000175000017500000000043112326224777017211 0ustar stephstephRequire Import Rfunctions. Require Import Fourier. Lemma l1 : forall x y z : R, Rabs (x - z) <= Rabs (x - y) + Rabs (y - z). intros; split_Rabs; fourier. Qed. Lemma l2 : forall x y : R, x < Rabs y -> y < 1 -> x >= 0 -> - y <= 1 -> Rabs x <= 1. intros. split_Rabs; fourier. Qed. coq-8.4pl4/test-suite/success/instantiate.v0000644000175000017500000000044412326224777020125 0ustar stephsteph(* Test régression bug #1041 *) Goal Prop. pose (P:= fun x y :Prop => y). evar (Q: forall X Y,P X Y -> Prop) . instantiate (1:= fun _ => _ ) in (Value of Q). instantiate (1:= fun _ => _ ) in (Value of Q). instantiate (1:= fun _ => _ ) in (Value of Q). instantiate (1:= H) in (Value of Q). coq-8.4pl4/test-suite/success/replace.v0000644000175000017500000000117312326224777017215 0ustar stephstephGoal forall x, x = 0 -> S x = 7 -> x = 22 . Proof. replace 0 with 33. Undo. intros x H H0. replace x with 0. Undo. replace x with 0 in |- *. Undo. replace x with 1 in *. Undo. replace x with 0 in *|- *. Undo. replace x with 0 in *|-. Undo. replace x with 0 in H0 . Undo. replace x with 0 in H0 |- * . Undo. replace x with 0 in H,H0 |- * . Undo. Admitted. (* This failed at some point when "replace" started to support arguments with evars but "abstract" did not supported any evars even defined ones *) Class U. Lemma l (u : U) (f : U -> nat) (H : 0 = f u) : f u = 0. replace (f _) with 0 by abstract apply H. reflexivity. Qed. coq-8.4pl4/test-suite/success/parsing.v0000644000175000017500000000033212326224777017241 0ustar stephstephSection A. Notation "*" := O (at level 8). Notation "**" := O (at level 99). Notation "***" := O (at level 9). End A. Notation "*" := O (at level 8). Notation "**" := O (at level 99). Notation "***" := O (at level 9). coq-8.4pl4/test-suite/success/setoid_test.v0000644000175000017500000000746612326224777020143 0ustar stephstephRequire Import Setoid. Parameter A : Set. Axiom eq_dec : forall a b : A, {a = b} + {a <> b}. Inductive set : Set := | Empty : set | Add : A -> set -> set. Fixpoint In (a : A) (s : set) {struct s} : Prop := match s with | Empty => False | Add b s' => a = b \/ In a s' end. Definition same (s t : set) : Prop := forall a : A, In a s <-> In a t. Lemma setoid_set : Setoid_Theory set same. unfold same; split ; red. red; auto. red. intros. elim (H a); auto. intros. elim (H a); elim (H0 a). split; auto. Qed. Add Setoid set same setoid_set as setsetoid. Add Morphism In : In_ext. unfold same; intros a s t H; elim (H a); auto. Qed. Lemma add_aux : forall s t : set, same s t -> forall a b : A, In a (Add b s) -> In a (Add b t). unfold same; simple induction 2; intros. rewrite H1. simpl; left; reflexivity. elim (H a). intros. simpl; right. apply (H2 H1). Qed. Add Morphism Add : Add_ext. split; apply add_aux. assumption. rewrite H. reflexivity. Qed. Fixpoint remove (a : A) (s : set) {struct s} : set := match s with | Empty => Empty | Add b t => match eq_dec a b with | left _ => remove a t | right _ => Add b (remove a t) end end. Lemma in_rem_not : forall (a : A) (s : set), ~ In a (remove a (Add a Empty)). intros. setoid_replace (remove a (Add a Empty)) with Empty. auto. unfold same. split. simpl. case (eq_dec a a). intros e ff; elim ff. intros; absurd (a = a); trivial. simpl. intro H; elim H. Qed. Parameter P : set -> Prop. Parameter P_ext : forall s t : set, same s t -> P s -> P t. Add Morphism P : P_extt. intros; split; apply P_ext; (assumption || apply (Seq_sym _ _ setoid_set); assumption). Qed. Lemma test_rewrite : forall (a : A) (s t : set), same s t -> P (Add a s) -> P (Add a t). intros. rewrite <- H. rewrite H. setoid_rewrite <- H. setoid_rewrite H. setoid_rewrite <- H. trivial. Qed. (* Unifying the domain up to delta-conversion (example from emakarov) *) Definition id: Set -> Set := fun A => A. Definition rel : forall A : Set, relation (id A) := @eq. Definition f: forall A : Set, A -> A := fun A x => x. Add Relation (id A) (rel A) as eq_rel. Add Morphism (@f A) : f_morph. Proof. unfold rel, f. trivial. Qed. (* Submitted by Nicolas Tabareau *) (* Needs unification.ml to support environments with de Bruijn *) Goal forall (f : Prop -> Prop) (Q : (nat -> Prop) -> Prop) (H : forall (h : nat -> Prop), Q (fun x : nat => f (h x)) <-> True) (h:nat -> Prop), Q (fun x : nat => f (Q (fun b : nat => f (h x)))) <-> True. intros f0 Q H. setoid_rewrite H. tauto. Qed. (** Check proper refreshing of the lemma application for multiple different instances in a single setoid rewrite. *) Section mult. Context (fold : forall {A} {B}, (A -> B) -> A -> B). Context (add : forall A, A -> A). Context (fold_lemma : forall {A B f} {eqA : relation B} x, eqA (fold A B f (add A x)) (fold _ _ f x)). Context (ab : forall B, A -> B). Context (anat : forall A, nat -> A). Goal forall x, (fold _ _ (fun x => ab A x) (add A x) = anat _ (fold _ _ (ab nat) (add _ x))). Proof. intros. setoid_rewrite fold_lemma. change (fold A A (fun x0 : A => ab A x0) x = anat A (fold A nat (ab nat) x)). Abort. End mult. (** Current semantics for rewriting with typeclass constraints in the lemma does not fix the instance at the first unification, use [at], or simply rewrite for this semantics. *) Require Import Arith. Class Foo (A : Type) := {foo_neg : A -> A ; foo_prf : forall x : A, x = foo_neg x}. Instance: Foo nat. admit. Defined. Instance: Foo bool. admit. Defined. Goal forall (x : nat) (y : bool), beq_nat (foo_neg x) 0 = foo_neg y. Proof. intros. setoid_rewrite <- foo_prf. change (beq_nat x 0 = y). Abort. Goal forall (x : nat) (y : bool), beq_nat (foo_neg x) 0 = foo_neg y. Proof. intros. setoid_rewrite <- @foo_prf at 1. change (beq_nat x 0 = foo_neg y). Abort. coq-8.4pl4/test-suite/success/ROmegaPre.v0000644000175000017500000000425012326224777017422 0ustar stephstephRequire Import ZArith Nnat ROmega. Open Scope Z_scope. (** Test of the zify preprocessor for (R)Omega *) (* More details in file PreOmega.v (r)omega with Z : starts with zify_op (r)omega with nat : starts with zify_nat (r)omega with positive : starts with zify_positive (r)omega with N : starts with uses zify_N (r)omega with * : starts zify (a saturation of the others) *) (* zify_op *) Goal forall a:Z, Z.max a a = a. intros. romega with *. Qed. Goal forall a b:Z, Z.max a b = Z.max b a. intros. romega with *. Qed. Goal forall a b c:Z, Z.max a (Z.max b c) = Z.max (Z.max a b) c. intros. romega with *. Qed. Goal forall a b:Z, Z.max a b + Z.min a b = a + b. intros. romega with *. Qed. Goal forall a:Z, (Z.abs a)*(Z.sgn a) = a. intros. zify. intuition; subst; romega. (* pure multiplication: omega alone can't do it *) Qed. Goal forall a:Z, Z.abs a = a -> a >= 0. intros. romega with *. Qed. Goal forall a:Z, Z.sgn a = a -> a = 1 \/ a = 0 \/ a = -1. intros. romega with *. Qed. (* zify_nat *) Goal forall m: nat, (m<2)%nat -> (0<= m+m <=2)%nat. intros. romega with *. Qed. Goal forall m:nat, (m<1)%nat -> (m=0)%nat. intros. romega with *. Qed. Goal forall m: nat, (m<=100)%nat -> (0<= m+m <=200)%nat. intros. romega with *. Qed. (* 2000 instead of 200: works, but quite slow *) Goal forall m: nat, (m*m>=0)%nat. intros. romega with *. Qed. (* zify_positive *) Goal forall m: positive, (m<2)%positive -> (2 <= m+m /\ m+m <= 2)%positive. intros. romega with *. Qed. Goal forall m:positive, (m<2)%positive -> (m=1)%positive. intros. romega with *. Qed. Goal forall m: positive, (m<=1000)%positive -> (2<=m+m/\m+m <=2000)%positive. intros. romega with *. Qed. Goal forall m: positive, (m*m>=1)%positive. intros. romega with *. Qed. (* zify_N *) Goal forall m:N, (m<2)%N -> (0 <= m+m /\ m+m <= 2)%N. intros. romega with *. Qed. Goal forall m:N, (m<1)%N -> (m=0)%N. intros. romega with *. Qed. Goal forall m:N, (m<=1000)%N -> (0<=m+m/\m+m <=2000)%N. intros. romega with *. Qed. Goal forall m:N, (m*m>=0)%N. intros. romega with *. Qed. (* mix of datatypes *) Goal forall p, Z.of_N (N.of_nat (N.to_nat (Npos p))) = Zpos p. intros. romega with *. Qed. coq-8.4pl4/test-suite/success/apply.v0000644000175000017500000002537212326224777016736 0ustar stephsteph(* Test apply in *) Goal (forall x y, x = S y -> y=y) -> 2 = 4 -> 3=3. intros H H0. apply H in H0. assumption. Qed. Require Import ZArith. Goal (forall x y z, ~ z <= 0 -> x * z < y * z -> x <= y)%Z. intros; apply Znot_le_gt, Z.gt_lt in H. apply Zmult_lt_reg_r, Z.lt_le_incl in H0; auto. Qed. (* Test application under tuples *) Goal (forall x, x=0 <-> 0=x) -> 1=0 -> 0=1. intros H H'. apply H in H'. exact H'. Qed. (* Test as clause *) Goal (forall x, x=0 <-> (0=x /\ True)) -> 1=0 -> True. intros H H'. apply H in H' as (_,H'). exact H'. Qed. (* Test application modulo conversion *) Goal (forall x, id x = 0 -> 0 = x) -> 1 = id 0 -> 0 = 1. intros H H'. apply H in H'. exact H'. Qed. (* Check apply/eapply distinction in presence of open terms *) Parameter h : forall x y z : nat, x = z -> x = y. Implicit Arguments h [[x] [y]]. Goal 1 = 0 -> True. intro H. apply h in H || exact I. Qed. Goal False -> 1 = 0. intro H. apply h || contradiction. Qed. (* Check if it unfolds when there are not enough premises *) Goal forall n, n = S n -> False. intros. apply n_Sn in H. assumption. Qed. (* Check naming in with bindings; printing used to be inconsistent before *) (* revision 9450 *) Notation S':=S (only parsing). Goal (forall S, S = S' S) -> (forall S, S = S' S). intros. apply H with (S0 := S). Qed. (* Check inference of implicit arguments in bindings *) Goal exists y : nat -> Type, y 0 = y 0. exists (fun x => True). trivial. Qed. (* Check universe handling in typed unificationn *) Definition E := Type. Goal exists y : E, y = y. exists Prop. trivial. Qed. Variable Eq : Prop = (Prop -> Prop) :> E. Goal Prop. rewrite Eq. Abort. (* Check insertion of coercions in bindings *) Coercion eq_true : bool >-> Sortclass. Goal exists A:Prop, A = A. exists true. trivial. Qed. (* Check use of unification of bindings types in specialize *) Module Type Test. Variable P : nat -> Prop. Variable L : forall (l : nat), P l -> P l. Goal P 0 -> True. intros. specialize L with (1:=H). Abort. End Test. (* Two examples that show that hnf_constr is used when unifying types of bindings (a simplification of a script from Field_Theory) *) Require Import List. Open Scope list_scope. Fixpoint P (l : list nat) : Prop := match l with | nil => True | e1 :: nil => e1 = e1 | e1 :: l1 => e1 = e1 /\ P l1 end. Variable L : forall n l, P (n::l) -> P l. Goal forall (x:nat) l, P (x::l) -> P l. intros. apply L with (1:=H). Qed. Goal forall (x:nat) l, match l with nil => x=x | _::_ => x=x /\ P l end -> P l. intros. apply L with (1:=H). Qed. (* The following call to auto fails if the type of the clause associated to the H is not beta-reduced [but apply H works] (a simplification of a script from FSetAVL) *) Definition apply (f:nat->Prop) := forall x, f x. Goal apply (fun n => n=0) -> 1=0. intro H. auto. Qed. (* The following fails if the coercion Zpos is not introduced around p before trying a subterm that matches the left-hand-side of the equality (a simplication of an example taken from Nijmegen/QArith) *) Require Import ZArith. Coercion Zpos : positive >-> Z. Variable f : Z -> Z -> Z. Variable g : forall q1 q2 p : Z, f (f q1 p) (f q2 p) = Z0. Goal forall p q1 q2, f (f q1 (Zpos p)) (f q2 (Zpos p)) = Z0. intros; rewrite g with (p:=p). reflexivity. Qed. (* A funny example where the behavior differs depending on which of a multiple solution to a unification problem is chosen (an instance of this case can be found in the proof of Buchberger.BuchRed.nf_divp) *) Definition succ x := S x. Goal forall (I : nat -> Set) (P : nat -> Prop) (Q : forall n:nat, I n -> Prop), (forall x y, P x -> Q x y) -> (forall x, P (S x)) -> forall y: I (S 0), Q (succ 0) y. intros. apply H with (y:=y). (* [x] had two possible instances: [S 0], coming from unifying the type of [y] with [I ?n] and [succ 0] coming from the unification with the goal; only the first one allows to make the next apply (which does not work modulo delta) working *) apply H0. Qed. (* A similar example with a arbitrary long conversion between the two possible instances *) Fixpoint compute_succ x := match x with O => S 0 | S n => S (compute_succ n) end. Goal forall (I : nat -> Set) (P : nat -> Prop) (Q : forall n:nat, I n -> Prop), (forall x y, P x -> Q x y) -> (forall x, P (S x)) -> forall y: I (S 100), Q (compute_succ 100) y. intros. apply H with (y:=y). apply H0. Qed. (* Another example with multiple convertible solutions to the same metavariable (extracted from Algebra.Hom_module.Hom_module, 10th subgoal which precisely fails) *) Definition ID (A:Type) := A. Goal forall f:Type -> Type, forall (P : forall A:Type, A -> Prop), (forall (B:Type) x, P (f B) x -> P (f B) x) -> (forall (A:Type) x, P (f (f A)) x) -> forall (A:Type) (x:f (f A)), P (f (ID (f A))) x. intros. apply H. (* The parameter [B] had two possible instances: [ID (f A)] by direct unification and [f A] by unification of the type of [x]; only the first choice makes the next command fail, as it was (unfortunately?) in Hom_module *) try apply H. unfold ID; apply H0. Qed. (* Test hyp in "apply -> ... in hyp" is correctly instantiated by Ltac *) Goal (True <-> False) -> True -> False. intros Heq H. match goal with [ H : True |- _ ] => apply -> Heq in H end. Abort. (* Test coercion below product and on non meta-free terms in with bindings *) (* Cf wishes #1408 from E. Makarov *) Parameter bool_Prop :> bool -> Prop. Parameter r : bool -> bool -> bool. Axiom ax : forall (A : Set) (R : A -> A -> Prop) (x y : A), R x y. Theorem t : r true false. apply ax with (R := r). Qed. (* Check verification of type at unification (submitted by StÃĐphane Lengrand): without verification, the first "apply" works what leads to the incorrect instantiation of x by Prop *) Theorem u : ~(forall x:Prop, ~x). unfold not. intro. eapply H. apply (forall B:Prop,B->B) || (instantiate (1:=True); exact I). Defined. (* Fine-tuning coercion insertion in presence of unfolding (bug #1883) *) Parameter name : Set. Definition atom := name. Inductive exp : Set := | var : atom -> exp. Coercion var : atom >-> exp. Axiom silly_axiom : forall v : exp, v = v -> False. Lemma silly_lemma : forall x : atom, False. intros x. apply silly_axiom with (v := x). (* fails *) reflexivity. Qed. (* Check that unification does not commit too early to a representative of an eta-equivalence class that would be incompatible with other unification constraints *) Lemma eta : forall f : (forall P, P 1), (forall P, f P = f P) -> forall Q, f (fun x => Q x) = f (fun x => Q x). intros. apply H. Qed. (* Test propagation of evars from subgoal to brother subgoals *) (* This works because unfold calls clos_norm_flags which calls nf_evar *) Lemma eapply_evar_unfold : let x:=O in O=x -> 0=O. intros x H; eapply eq_trans; [apply H | unfold x;match goal with |- ?x = ?x => reflexivity end]. Qed. (* Test non-regression of (temporary) bug 1981 *) Goal exists n : nat, True. eapply ex_intro. exact O. trivial. Qed. (* Check pattern-unification on evars in apply unification *) Lemma evar : exists f : nat -> nat, forall x, f x = 0 -> x = 0. Proof. eexists; intros x H. apply H. Qed. (* Check that "as" clause applies to main premise only and leave the side conditions away *) Lemma side_condition : forall (A:Type) (B:Prop) x, (True -> B -> x=0) -> B -> x=x. Proof. intros. apply H in H0 as ->. reflexivity. exact I. Qed. (* Check that "apply" is chained on the last subgoal of each lemma and that side conditions come first (as it is the case since 8.2) *) Lemma chaining : forall A B C : Prop, (1=1 -> (2=2 -> A -> B) /\ True) -> (3=3 -> (True /\ (4=4 -> C -> A))) -> C -> B. Proof. intros. apply H, H0. exact (refl_equal 1). exact (refl_equal 2). exact (refl_equal 3). exact (refl_equal 4). assumption. Qed. (* Check that the side conditions of "apply in", even when chained and used through conjunctions, come last (as it is the case for single calls to "apply in" w/o destruction of conjunction since 8.2) *) Lemma chaining_in : forall A B C : Prop, (1=1 -> True /\ (B -> 2=2 -> 5=0)) -> (3=3 -> (A -> 4=4 -> B) /\ True) -> A -> 0=5. Proof. intros. apply H0, H in H1 as ->. exact (refl_equal 0). exact (refl_equal 1). exact (refl_equal 2). exact (refl_equal 3). exact (refl_equal 4). Qed. (* From 12612, descent in conjunctions is more powerful *) (* The following, which was failing badly in bug 1980, is now properly rejected, as descend in conjunctions builds an ill-formed elimination from Prop to Type. *) Goal True. Fail eapply ex_intro. exact I. Qed. (* The following, which were not accepted, are now accepted as expected by descent in conjunctions *) Goal True. eapply (ex_intro (fun _ => True) I). exact I. Qed. Goal True. eapply (fun (A:Prop) (x:A) => conj I x). exact I. Qed. (* The following was not accepted from r12612 to r12657 *) Record sig0 := { p1 : nat; p2 : p1 = 0 }. Goal forall x : sig0, p1 x = 0. intro x; apply x. Qed. (* The following worked in 8.2 but was not accepted from r12229 to r12926 because "simple apply" started to use pattern unification of evars. Evars pattern unification for simple (e)apply was disabled in 12927 but "simple eapply" below worked from 12898 to 12926 because pattern-unification also started supporting abstraction over Metas. However it did not find the "simple" solution and hence the subsequent "assumption" failed. *) Goal exists f:nat->nat, forall x y, x = y -> f x = f y. intros; eexists; intros. simple eapply (@f_equal nat). assumption. Existential 1 := fun x => x. Qed. (* The following worked in 8.2 but was not accepted from r12229 to r12897 for the same reason because eauto uses "simple apply". It worked from 12898 to 12926 because eauto uses eassumption and not assumption. *) Goal exists f:nat->nat, forall x y, x = y -> f x = f y. intros; eexists; intros. eauto. Existential 1 := fun x => x. Qed. (* The following was accepted before r12612 but is still not accepted in r12658 Goal forall x : { x:nat | x = 0}, proj1_sig x = 0. intro x; apply x. *) Section A. Variable map : forall (T1 T2 : Type) (f : T1 -> T2) (t11 t12 : T1), identity (f t11) (f t12). Variable mapfuncomp : forall (X Y Z : Type) (f : X -> Y) (g : Y -> Z) (x x' : X), identity (map Y Z g (f x) (f x')) (map X Z (fun x0 : X => g (f x0)) x x'). Goal forall X:Type, forall Y:Type, forall f:X->Y, forall x : X, forall x' : X, forall g : Y -> X, let gf := (fun x : X => g (f x)) : X -> X in identity (map Y X g (f x) (f x')) (map X X gf x x'). intros. apply mapfuncomp. Abort. End A. (* Check "with" clauses refer to names as they are printed *) Definition hide p := forall n:nat, p = n. Goal forall n, (forall n, n=0) -> hide n -> n=0. unfold hide. intros n H H'. (* H is displayed as (forall n, n=0) *) apply H with (n:=n). Undo. (* H' is displayed as (forall n0, n=n0) *) apply H' with (n0:=0). Qed. coq-8.4pl4/test-suite/success/guard.v0000644000175000017500000000050212326224777016677 0ustar stephsteph(* Specific tests about guard condition *) (* f must unfold to x, not F (de Bruijn mix-up!) *) Check let x (f:nat->nat) k := f k in fun (y z:nat->nat) => let f:=x in (* f := Rel 3 *) fix F (n:nat) : nat := match n with | 0 => 0 | S k => f F k (* here Rel 3 = F ! *) end. coq-8.4pl4/test-suite/success/eqdecide.v0000644000175000017500000000146312326224777017347 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* T. Lemma lem1 : forall x y : T, {x = y} + {x <> y}. decide equality. Qed. Lemma lem2 : forall x y : T, {x = y} + {x <> y}. intros x y. decide equality. Qed. Lemma lem4 : forall x y : T, {x = y} + {x <> y}. intros x y. compare x y; auto. Qed. coq-8.4pl4/test-suite/success/eauto.v0000644000175000017500000000351312326224777016717 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* nat -> Prop. Definition not_in_list (l : list (nat * nat)) (n : nat) : Prop := ~ in_list l n. (* Hints Unfold not_in_list. *) Axiom lem1 : forall (l1 l2 : list (nat * nat)) (n : nat), not_in_list (l1 ++ l2) n -> not_in_list l1 n. Axiom lem2 : forall (l1 l2 : list (nat * nat)) (n : nat), not_in_list (l1 ++ l2) n -> not_in_list l2 n. Axiom lem3 : forall (l : list (nat * nat)) (n p q : nat), not_in_list ((p, q) :: l) n -> not_in_list l n. Axiom lem4 : forall (l1 l2 : list (nat * nat)) (n : nat), not_in_list l1 n -> not_in_list l2 n -> not_in_list (l1 ++ l2) n. Hint Resolve lem1 lem2 lem3 lem4: essai. Goal forall (l : list (nat * nat)) (n p q : nat), not_in_list ((p, q) :: l) n -> not_in_list l n. intros. eauto with essai. Qed. (* Example from Nicolas Magaud on coq-club - Jul 2000 *) Definition Nat : Set := nat. Parameter S' : Nat -> Nat. Parameter plus' : Nat -> Nat -> Nat. Lemma simpl_plus_l_rr1 : (forall n0 : Nat, (forall m p : Nat, plus' n0 m = plus' n0 p -> m = p) -> forall m p : Nat, S' (plus' n0 m) = S' (plus' n0 p) -> m = p) -> forall n : Nat, (forall m p : Nat, plus' n m = plus' n p -> m = p) -> forall m p : Nat, S' (plus' n m) = S' (plus' n p) -> m = p. intros. eauto. (* does EApply H *) Qed. coq-8.4pl4/test-suite/success/Case13.v0000644000175000017500000000414512326224777016623 0ustar stephsteph(* Check coercions in patterns *) Inductive I : Set := | C1 : nat -> I | C2 : I -> I. Coercion C1 : nat >-> I. (* Coercion at the root of pattern *) Check (fun x => match x with | C2 n => 0 | O => 0 | S n => n end). (* Coercion not at the root of pattern *) Check (fun x => match x with | C2 O => 0 | _ => 0 end). (* Unification and coercions inside patterns *) Check (fun x : option nat => match x with | None => 0 | Some O => 0 | _ => 0 end). (* Coercion up to delta-conversion, and unification *) Coercion somenat := Some (A:=nat). Check (fun x => match x with | None => 0 | O => 0 | S n => n end). (* Coercions with parameters *) Inductive listn : nat -> Set := | niln : listn 0 | consn : forall n : nat, nat -> listn n -> listn (S n). Inductive I' : nat -> Set := | C1' : forall n : nat, listn n -> I' n | C2' : forall n : nat, I' n -> I' n. Coercion C1' : listn >-> I'. Check (fun x : I' 0 => match x with | C2' _ _ => 0 | niln => 0 | _ => 0 end). Check (fun x : I' 0 => match x with | C2' _ niln => 0 | _ => 0 end). (* Check insertion of coercions around matched subterm *) Parameter A:Set. Parameter f:> A -> nat. Inductive J : Set := D : A -> J. Check (fun x => match x with | D 0 => 0 | D _ => 1 end). (* Check coercions against the type of the term to match *) (* Used to fail in V8.1beta *) Inductive C : Set := c : C. Inductive E : Set := e :> C -> E. Check fun (x : E) => match x with c => e c end. (* Check coercions with uniform parameters (cf bug #1168) *) Inductive C' : bool -> Set := c' : C' true. Inductive E' (b : bool) : Set := e' :> C' b -> E' b. Check fun (x : E' true) => match x with c' => e' true c' end. coq-8.4pl4/test-suite/success/setoid_test2.v0000644000175000017500000002007312326224777020212 0ustar stephstephRequire Export Setoid. (* Testare: +1. due setoidi con ugualianza diversa sullo stesso tipo +2. due setoidi sulla stessa uguaglianza +3. due morfismi sulla stessa funzione ma setoidi diversi +4. due morfismi sulla stessa funzione e stessi setoidi +5. setoid_replace +6. solo cammini mal tipati +7. esempio (f (g (h E1))) dove h:(T1,=1) -> T2, g:T2->(T3,=3), f:(T3,=3)->Prop +8. test con occorrenze non lineari del pattern +9. test in cui setoid_replace fa direttamente fallback su replace 10. sezioni +11. goal con impl +12. testare *veramente* setoid_replace (ora testato solamente il caso di fallback su replace) Incompatibilita': 1. full_trivial in setoid_replace 2. "as ..." per "Add Setoid" 3. ipotesi permutate in lemma di "Add Morphism" 4. iff invece di if in "Add Morphism" nel caso di predicati 5. setoid_replace poteva riscrivere sia c1 in c2 che c2 in c1 (???? o poteva farlo da destra a sinitra o viceversa? ????) ### Come evitare di dover fare "Require Setoid" prima di usare la tattica? ??? scelta: quando ci sono piu' scelte dare un warning oppure fallire? difficile quando la tattica e' rewrite ed e' usata in tattiche automatiche ??? in test4.v il setoid_rewrite non si puo' sostituire con rewrite perche' questo ultimo fallisce per via dell'unificazione ??? ??? <-> non e' sottorelazione di ->. Quindi ora puo' capitare di non riuscire a provare goal del tipo A /\ B dove (A, <->) e (B, ->) (per esempio) ### Nota: il parsing e pretty printing delle relazioni non e' in synch! eq contro (ty,eq). Uniformare ### diminuire la taglia dei proof term ??? il messaggio di errore non e' assolutamente significativo quando nessuna marcatura viene trovata ### fare in modo che uscendo da una sezione vengano quantificate le relazioni e i morfismi. Hugo: paciugare nel discharge.ml ### implementare relazioni/morfismi quantificati con dei LetIn (che palle...) decompose_prod da far diventare simile a un Reduction.dest_arity? (ma senza riduzione??? e perche' li' c'e' riduzione?) Soluzione da struzzo: fare zeta-conversione. ### fare in modo che impl sia espanso nel lemma di compatibilita' del morfismo (richiesta di Marco per poter fare Add Hing) ??? snellire la sintassi omettendo "proved by" come proposto da Marco? ;-( ### non capisce piu' le riscritture con uguaglianze quantificate (almeno nell'esempio di Marco) ### Bas Spitters: poter dichiarare che ogni variabile nel contesto di tipo un setoid_function e' un morfismo ### unificare le varie check_... ### sostituire a Use_* una sola eccezione Optimize Implementare: -2. user-defined subrelations && user-proved subrelations -1. trucco di Bruno Sorgenti di inefficacia: 1. scelta del setoide di default per un sostegno: per farlo velocemente ci vorrebbe una tabella hash; attualmente viene fatta una ricerca lineare sul range della setoid_table Vantaggi rispetto alla vecchia tattica: 1. permette di avere setoidi differenti con lo stesso sostegno, ma equivalenza differente 2. accetta setoidi differenti con lo stesso sostegno e stessa equivalenza, scegliendo a caso quello da usare (proof irrelevance) 3. permette di avere morfismi differenti sulla stessa funzione se hanno dominio o codominio differenti 4. accetta di avere morfismi differenti sulla stessa funzione e con lo stesso dominio e codominio, scegliendo a caso quello da usare (proof irrelevance) 5. quando un morfismo viene definito, se la scelta del dominio o del codominio e' ambigua l'utente puo' esplicitamente disambiguare la scelta fornendo esplicitamente il "tipo" del morfismo 6. permette di gestire riscritture ove ad almeno una funzione venga associato piu' di un morfismo. Vengono automaticamente calcolate le scelte globali che rispettano il tipaggio. 7. se esistono piu' scelte globali che rispettano le regole di tipaggio l'utente puo' esplicitamente disambiguare la scelta globale fornendo esplicitamente la scelta delle side conditions generate. 8. nel caso in cui la setoid_replace sia stata invocata al posto della replace la setoid_replace invoca direttamente la replace. Stessa cosa per la setoid_rewrite. 9. permette di gestire termini in cui il prefisso iniziale dell'albero (fino a trovare il termine da riscrivere) non sia formato esclusivamente da morfismi il cui dominio e codominio sia un setoide. Ovvero ammette anche morfismi il cui dominio e/o codominio sia l'uguaglianza di Leibniz. (Se entrambi sono uguaglianze di Leibniz allora il setoide e' una semplice funzione). 10. [setoid_]rewrite ... in ... setoid_replace ... in ... [setoid_]reflexivity [setoid_]transitivity ... [setoid_]symmetry [setoid_]symmetry in ... 11. permette di dichiarare dei setoidi/relazioni/morfismi in un module type 12. relazioni, morfismi e setoidi quantificati *) Axiom S1: Set. Axiom eqS1: S1 -> S1 -> Prop. Axiom SetoidS1 : Setoid_Theory S1 eqS1. Add Setoid S1 eqS1 SetoidS1 as S1setoid. Instance eqS1_default : DefaultRelation eqS1. Axiom eqS1': S1 -> S1 -> Prop. Axiom SetoidS1' : Setoid_Theory S1 eqS1'. Axiom SetoidS1'_bis : Setoid_Theory S1 eqS1'. Add Setoid S1 eqS1' SetoidS1' as S1setoid'. Add Setoid S1 eqS1' SetoidS1'_bis as S1setoid''. Axiom S2: Set. Axiom eqS2: S2 -> S2 -> Prop. Axiom SetoidS2 : Setoid_Theory S2 eqS2. Add Setoid S2 eqS2 SetoidS2 as S2setoid. Axiom f : S1 -> nat -> S2. Add Morphism f : f_compat. Admitted. Add Morphism f : f_compat2. Admitted. Theorem test1: forall x y, (eqS1 x y) -> (eqS2 (f x 0) (f y 0)). intros. rewrite H. reflexivity. Qed. Theorem test1': forall x y, (eqS1 x y) -> (eqS2 (f x 0) (f y 0)). intros. setoid_replace x with y. reflexivity. assumption. Qed. Axiom g : S1 -> S2 -> nat. Add Morphism g : g_compat. Admitted. Axiom P : nat -> Prop. Theorem test2: forall x x' y y', (eqS1 x x') -> (eqS2 y y') -> (P (g x' y')) -> (P (g x y)). intros. rewrite H. rewrite H0. assumption. Qed. Theorem test3: forall x x' y y', (eqS1 x x') -> (eqS2 y y') -> (P (S (g x' y'))) -> (P (S (g x y))). intros. rewrite H. rewrite H0. assumption. Qed. Theorem test4: forall x x' y y', (eqS1 x x') -> (eqS2 y y') -> (S (g x y)) = (S (g x' y')). intros. rewrite H. rewrite H0. reflexivity. Qed. Theorem test5: forall x x' y y', (eqS1 x x') -> (eqS2 y y') -> (S (g x y)) = (S (g x' y')). intros. setoid_replace (g x y) with (g x' y'). reflexivity. rewrite <- H0. rewrite H. reflexivity. Qed. Axiom f_test6 : S2 -> Prop. Add Morphism f_test6 : f_test6_compat. Admitted. Axiom g_test6 : bool -> S2. Add Morphism g_test6 : g_test6_compat. Admitted. Axiom h_test6 : S1 -> bool. Add Morphism h_test6 : h_test6_compat. Admitted. Theorem test6: forall E1 E2, (eqS1 E1 E2) -> (f_test6 (g_test6 (h_test6 E2))) -> (f_test6 (g_test6 (h_test6 E1))). intros. rewrite H. assumption. Qed. Theorem test7: forall E1 E2 y y', (eqS1 E1 E2) -> (eqS2 y y') -> (f_test6 (g_test6 (h_test6 E2))) -> (f_test6 (g_test6 (h_test6 E1))) /\ (S (g E1 y')) = (S (g E2 y')). intros. rewrite H. split; [assumption | reflexivity]. Qed. Axiom S1_test8: Set. Axiom eqS1_test8: S1_test8 -> S1_test8 -> Prop. Axiom SetoidS1_test8 : Setoid_Theory S1_test8 eqS1_test8. Add Setoid S1_test8 eqS1_test8 SetoidS1_test8 as S1_test8setoid. Instance eqS1_test8_default : DefaultRelation eqS1_test8. Axiom f_test8 : S2 -> S1_test8. Add Morphism f_test8 : f_compat_test8. Admitted. Axiom eqS1_test8': S1_test8 -> S1_test8 -> Prop. Axiom SetoidS1_test8' : Setoid_Theory S1_test8 eqS1_test8'. Add Setoid S1_test8 eqS1_test8' SetoidS1_test8' as S1_test8setoid'. (*CSC: for test8 to be significant I want to choose the setoid (S1_test8, eqS1_test8'). However this does not happen and there is still no syntax for it ;-( *) Axiom g_test8 : S1_test8 -> S2. Add Morphism g_test8 : g_compat_test8. Admitted. Theorem test8: forall x x': S2, (eqS2 x x') -> (eqS2 (g_test8 (f_test8 x)) (g_test8 (f_test8 x'))). intros. rewrite H. Abort. (*Print Setoids.*) coq-8.4pl4/test-suite/success/pattern.v0000644000175000017500000000257012326224777017261 0ustar stephsteph(* Test pattern with dependent occurrences; Note that it does not behave as the succession of three generalize because each quantification introduces new occurrences that are automatically abstracted with the numbering still based on the original statement *) Goal (id true,id false)=(id true,id true). generalize bool at 2 4 6 8 10 as B, true at 3 as tt, false as ff. Abort. (* Check use of occurrences in hypotheses for a reduction tactic such as pattern *) (* Did not work in 8.2 *) Goal 0=0->True. intro H. pattern 0 in H at 2. set (f n := 0 = n) in H. (* check pattern worked correctly *) Abort. (* Syntactic variant which was working in 8.2 *) Goal 0=0->True. intro H. pattern 0 at 2 in H. set (f n := 0 = n) in H. (* check pattern worked correctly *) Abort. (* Ambiguous occurrence selection *) Goal 0=0->True. intro H. pattern 0 at 1 in H at 2 || exact I. (* check pattern fails *) Qed. (* Ambiguous occurrence selection *) Goal 0=1->True. intro H. pattern 0, 1 in H at 1 2 || exact I. (* check pattern fails *) Qed. (* Occurrence selection shared over hypotheses is difficult to advocate and hence no longer allowed *) Goal 0=1->1=0->True. intros H1 H2. pattern 0 at 1, 1 in H1, H2 || exact I. (* check pattern fails *) Qed. (* Test catching of reduction tactics errors (was not the case in 8.2) *) Goal eq_refl 0 = eq_refl 0. pattern 0 at 1 || reflexivity. Qed. coq-8.4pl4/test-suite/success/Try.v0000644000175000017500000000025612326224777016361 0ustar stephsteph(* To shorten interactive scripts, it is better that Try catches non-existent names in Unfold [cf bug #263] *) Lemma lem1 : True. try unfold i_dont_exist. trivial. Qed. coq-8.4pl4/test-suite/success/Case19.v0000644000175000017500000000103612326224777016625 0ustar stephsteph(* This used to fail in Coq version 8.1 beta due to a non variable universe (issued by the inductive sort-polymorphism) being sent by pretyping to the kernel (bug #1182) *) Variable T : Type. Variable x : nat*nat. Check let (_, _) := x in sigT (fun _ : T => nat). (* This used to raise an anomaly in V8.4, up to pl2 *) Goal {x: nat & x=x}. Fail exists (fun x => match projT2 (projT2 x) as e in (_ = y) return _ = existT _ (projT1 x) (existT _ y e) with | eq_refl => eq_refl end). coq-8.4pl4/test-suite/success/fix.v0000644000175000017500000000417012326224777016370 0ustar stephsteph(* Ancien bug signale par Laurent Thery sur la condition de garde *) Require Import Bool. Require Import ZArith. Definition rNat := positive. Inductive rBoolOp : Set := | rAnd : rBoolOp | rEq : rBoolOp. Definition rlt (a b : rNat) : Prop := Pos.compare_cont a b Eq = Lt. Definition rltDec : forall m n : rNat, {rlt m n} + {rlt n m \/ m = n}. intros n m; generalize (nat_of_P_lt_Lt_compare_morphism n m); generalize (nat_of_P_gt_Gt_compare_morphism n m); generalize (Pcompare_Eq_eq n m); case (Pos.compare_cont n m Eq). intros H' H'0 H'1; right; right; auto. intros H' H'0 H'1; left; unfold rlt. apply nat_of_P_lt_Lt_compare_complement_morphism; auto. intros H' H'0 H'1; right; left; unfold rlt. apply nat_of_P_lt_Lt_compare_complement_morphism; auto. apply H'0; auto. Defined. Definition rmax : rNat -> rNat -> rNat. intros n m; case (rltDec n m); intros Rlt0. exact m. exact n. Defined. Inductive rExpr : Set := | rV : rNat -> rExpr | rN : rExpr -> rExpr | rNode : rBoolOp -> rExpr -> rExpr -> rExpr. Fixpoint maxVar (e : rExpr) : rNat := match e with | rV n => n | rN p => maxVar p | rNode n p q => rmax (maxVar p) (maxVar q) end. (* Check bug #1491 *) Require Import Streams. Definition decomp (s:Stream nat) : Stream nat := match s with Cons _ s => s end. CoFixpoint bx0 : Stream nat := Cons 0 bx1 with bx1 : Stream nat := Cons 1 bx0. Lemma bx0bx : decomp bx0 = bx1. simpl. (* used to return bx0 in V8.1 and before instead of bx1 *) reflexivity. Qed. (* Check mutually inductive statements *) Require Import ZArith_base Omega. Open Scope Z_scope. Inductive even: Z -> Prop := | even_base: even 0 | even_succ: forall n, odd (n - 1) -> even n with odd: Z -> Prop := | odd_succ: forall n, even (n - 1) -> odd n. Lemma even_pos_odd_pos: forall n, even n -> n >= 0 with odd_pos_even_pos : forall n, odd n -> n >= 1. Proof. intros. destruct H. omega. apply odd_pos_even_pos in H. omega. intros. destruct H. apply even_pos_odd_pos in H. omega. Qed. CoInductive a : Prop := acons : b -> a with b : Prop := bcons : a -> b. Lemma a1 : a with b1 : b. Proof. apply acons. assumption. apply bcons. assumption. Qed. coq-8.4pl4/test-suite/success/if.v0000644000175000017500000000055612326224777016204 0ustar stephsteph(* The synthesis of the elimination predicate may fail if algebric *) (* universes are not cautiously treated *) Check (fun b : bool => if b then Type else nat). (* Check correct use of if-then-else predicate annotation (cf bug 690) *) Check fun b : bool => if b as b0 return (if b0 then b0 = true else b0 = false) then refl_equal true else refl_equal false. coq-8.4pl4/test-suite/success/Decompose.v0000644000175000017500000000033212326224777017514 0ustar stephsteph(* This was a Decompose bug reported by Randy Pollack (29 Mar 2000) *) Goal 0 = 0 /\ (forall x : nat, x = x -> x = x /\ (forall y : nat, y = y -> y = y)) -> True. intro H. decompose [and] H. (* Was failing *) Abort. coq-8.4pl4/test-suite/success/Notations.v0000644000175000017500000000612312326224777017560 0ustar stephsteph(* Check that "where" clause behaves as if given independently of the *) (* definition (variant of bug #1132 submitted by Assia Mahboubi) *) Fixpoint plus1 (n m:nat) {struct n} : nat := match n with | O => m | S p => S (p+m) end where "n + m" := (plus1 n m) : nat_scope. (* Check behaviour wrt yet empty levels (see Stephane's bug #1850) *) Parameter P : Type -> Type -> Type -> Type. Notation "e |= t --> v" := (P e t v) (at level 100, t at level 54). Check (nat |= nat --> nat). (* Check that first non empty definition at an empty level can be of any associativity *) Module Type v1. Notation "x +1" := (S x) (at level 8, left associativity). End v1. Module Type v2. Notation "x +1" := (S x) (at level 8, right associativity). End v2. (* Check that empty levels (here 8 and 2 in pattern) are added in the right order *) Notation "' 'C_' G ( A )" := (A,G) (at level 8, G at level 2). (* Check import of notations from within a section *) Notation "+1 x" := (S x) (at level 25, x at level 9). Section A. Require Import make_notation. End A. (* Check use of "$" (see bug #1961) *) Notation "$ x" := (id x) (at level 30). Check ($ 5). (* Check regression of bug #2087 *) Notation "'exists' x , P" := (x, P) (at level 200, x ident, right associativity, only parsing). Definition foo P := let '(exists x, Q) := P in x = Q :> nat. (* Check empty levels when extending binder_constr *) Notation "'exists' x >= y , P" := (exists x, x >= y /\ P)%nat (at level 200, x ident, right associativity, y at level 69). (* This used to loop at some time before r12491 *) Notation R x := (@pair _ _ x). Check (fun x:nat*nat => match x with R x y => (x,y) end). (* Check multi-tokens recursive notations *) Local Notation "[ a # ; .. # ; b ]" := (a + .. (b + 0) ..). Check [ 0 ]. Check [ 0 # ; 1 ]. (* Check well-scoping of alpha-renaming of private binders *) (* see bug #2248 (thanks to Marc Lasson) *) Notation "{ q , r | P }" := (fun (p:nat*nat) => let (q, r) := p in P). Check (fun p => {q,r| q + r = p}). (* Check that declarations of empty levels are correctly backtracked *) Section B. Notation "*" := 5 (at level 0) : nat_scope. Notation "[ h ] p" := (h + p) (at level 8, p at level 9, h at level 7) : nat_scope. End B. (* Should succeed *) Definition n := 5 * 5. (* Check that lonely notations (here FOO) do not modify the visibility of scoped interpretations (bug #2634 fixed in r14819) *) Notation "x ++++ y" := (mult x y) (at level 40). Notation "x ++++ y" := (plus x y) : A_scope. Open Scope A_scope. Notation "'FOO' x" := (S x) (at level 40). Goal (2 ++++ 3) = 5. reflexivity. Abort. (* Check correct failure handling when a non-constructor notation is used in cases pattern (bug #2724 in 8.3 and 8.4beta) *) Notation "'FORALL' x .. y , P" := (forall x, .. (forall y, P) ..) (at level 200, x binder, y binder, right associativity) : type_scope. Fail Check fun x => match x with S (FORALL x, _) => 0 end. (* Bug #2708: don't check for scope of variables used as binder *) Parameter traverse : (nat -> unit) -> (nat -> unit). Notation traverse_var f l := (traverse (fun l => f l) l). coq-8.4pl4/test-suite/success/params_ind.v0000644000175000017500000000013512326224777017714 0ustar stephstephInductive list (A : Set) : Set := | nil : list A | cons : A -> list (A -> A) -> list A. coq-8.4pl4/test-suite/success/Require.v0000644000175000017500000000013012326224777017206 0ustar stephstephRequire Import Coq.Arith.Plus. Require Coq.Arith.Minus. Locate Library Coq.Arith.Minus. coq-8.4pl4/test-suite/success/Inversion.v0000644000175000017500000000717512326224777017566 0ustar stephstephAxiom magic : False. (* Submitted by Dachuan Yu (bug #220) *) Fixpoint T (n : nat) : Type := match n with | O => nat -> Prop | S n' => T n' end. Inductive R : forall n : nat, T n -> nat -> Prop := | RO : forall (Psi : T 0) (l : nat), Psi l -> R 0 Psi l | RS : forall (n : nat) (Psi : T (S n)) (l : nat), R n Psi l -> R (S n) Psi l. Definition Psi00 (n : nat) : Prop := False. Definition Psi0 : T 0 := Psi00. Lemma Inversion_RO : forall l : nat, R 0 Psi0 l -> Psi00 l. inversion 1. Abort. (* Submitted by Pierre Casteran (bug #540) *) Set Implicit Arguments. Unset Strict Implicit. Parameter rule : Set -> Type. Inductive extension (I : Set) : Type := | NL : extension I | add_rule : rule I -> extension I -> extension I. Inductive in_extension (I : Set) (r : rule I) : extension I -> Type := | in_first : forall e, in_extension r (add_rule r e) | in_rest : forall e r', in_extension r e -> in_extension r (add_rule r' e). Implicit Arguments NL [I]. Inductive super_extension (I : Set) (e : extension I) : extension I -> Type := | super_NL : super_extension e NL | super_add : forall r (e' : extension I), in_extension r e -> super_extension e e' -> super_extension e (add_rule r e'). Lemma super_def : forall (I : Set) (e1 e2 : extension I), super_extension e2 e1 -> forall ru, in_extension ru e1 -> in_extension ru e2. Proof. simple induction 1. inversion 1; auto. elim magic. Qed. (* Example from Norbert Schirmer on Coq-Club, Sep 2000 *) Set Strict Implicit. Unset Implicit Arguments. Definition Q (n m : nat) (prf : n <= m) := True. Goal forall (n m : nat) (H : S n <= m), Q (S n) m H = True. intros. dependent inversion_clear H. elim magic. elim magic. Qed. (* Submitted by Boris Yakobowski (bug #529) *) (* Check that Inversion does not fail due to unnormalized evars *) Set Implicit Arguments. Unset Strict Implicit. Require Import Bvector. Inductive I : nat -> Set := | C1 : I 1 | C2 : forall k i : nat, Vector.t (I i) k -> I i. Inductive SI : forall k : nat, I k -> Vector.t nat k -> nat -> Prop := SC2 : forall (k i vf : nat) (v : Vector.t (I i) k) (xi : Vector.t nat i), SI (C2 v) xi vf. Theorem SUnique : forall (k : nat) (f : I k) (c : Vector.t nat k) v v', SI f c v -> SI f c v' -> v = v'. Proof. induction 1. intros H; inversion H. Admitted. (* Used to failed at some time *) Set Strict Implicit. Unset Implicit Arguments. Parameter bar : forall p q : nat, p = q -> Prop. Inductive foo : nat -> nat -> Prop := C : forall (a b : nat) (Heq : a = b), bar a b Heq -> foo a b. Lemma depinv : forall a b, foo a b -> True. intros a b H. inversion H. Abort. (* Check non-regression of bug #1968 *) Inductive foo2 : option nat -> Prop := Foo : forall t, foo2 (Some t). Goal forall o, foo2 o -> 0 = 1. intros. eapply trans_eq. inversion H. (* Check that the part of "injection" that is called by "inversion" does the same number of intros as the number of equations introduced, even in presence of dependent equalities that "injection" renounces to split *) Fixpoint prodn (n : nat) := match n with | O => unit | (S m) => prod (prodn m) nat end. Inductive U : forall n : nat, prodn n -> bool -> Prop := | U_intro : U 0 tt true. Lemma foo3 : forall n (t : prodn n), U n t true -> False. Proof. (* used to fail because dEqThen thought there were 2 new equations but inject_at_positions actually introduced only one; leading then to an inconsistent state that disturbed "inversion" *) intros. inversion H. Abort. (* Bug #2314 (simplified): check that errors do not show as anomalies *) Goal True -> True. intro. Fail inversion H using False. Fail inversion foo using True_ind. coq-8.4pl4/test-suite/success/Import.v0000644000175000017500000000033212326224777017050 0ustar stephsteph(* Test visibility of imported objects *) Require Import make_local. (* Check local implicit arguments are not imported *) Check (f nat 0). (* Check local arguments scopes are not imported *) Check (f nat (0*0)). coq-8.4pl4/test-suite/success/Fixpoint.v0000644000175000017500000000444712326224777017411 0ustar stephsteph(* Playing with (co-)fixpoints with local definitions *) Inductive listn : nat -> Set := niln : listn 0 | consn : forall n:nat, nat -> listn n -> listn (S n). Fixpoint f (n:nat) (m:=pred n) (l:listn m) (p:=S n) {struct l} : nat := match n with O => p | _ => match l with niln => p | consn q _ l => f (S q) l end end. Eval compute in (f 2 (consn 0 0 niln)). CoInductive Stream : nat -> Set := Consn : forall n, nat -> Stream n -> Stream (S n). CoFixpoint g (n:nat) (m:=pred n) (l:Stream m) (p:=S n) : Stream p := match n return (let m:=pred n in forall l:Stream m, let p:=S n in Stream p) with | O => fun l:Stream 0 => Consn O 0 l | S n' => fun l:Stream n' => let l' := match l in Stream q return Stream (pred q) with Consn _ _ l => l end in let a := match l with Consn _ a l => a end in Consn (S n') (S a) (g n' l') end l. Eval compute in (fun l => match g 2 (Consn 0 6 l) with Consn _ a _ => a end). (* Check inference of simple types in presence of non ambiguous dependencies (needs revision 10125) *) Section folding. Inductive vector (A:Type) : nat -> Type := | Vnil : vector A 0 | Vcons : forall (a:A) (n:nat), vector A n -> vector A (S n). Variables (B C : Set) (g : B -> C -> C) (c : C). Fixpoint foldrn n bs := match bs with | Vnil => c | Vcons b _ tl => g b (foldrn _ tl) end. End folding. (* Check definition by tactics *) Set Automatic Introduction. Inductive even : nat -> Type := | even_O : even 0 | even_S : forall n, odd n -> even (S n) with odd : nat -> Type := odd_S : forall n, even n -> odd (S n). Fixpoint even_div2 n (H:even n) : nat := match H with | even_O => 0 | even_S n H => S (odd_div2 n H) end with odd_div2 n H : nat. destruct H. apply even_div2 with n. assumption. Qed. Fixpoint even_div2' n (H:even n) : nat with odd_div2' n (H:odd n) : nat. destruct H. exact 0. apply odd_div2' with n. assumption. destruct H. apply even_div2' with n. assumption. Qed. CoInductive Stream1 (A B:Type) := Cons1 : A -> Stream2 A B -> Stream1 A B with Stream2 (A B:Type) := Cons2 : B -> Stream1 A B -> Stream2 A B. CoFixpoint ex1 (n:nat) (b:bool) : Stream1 nat bool with ex2 (n:nat) (b:bool) : Stream2 nat bool. apply Cons1. exact n. apply (ex2 n b). apply Cons2. exact b. apply (ex1 (S n) (negb b)). Defined. coq-8.4pl4/test-suite/success/MatchFail.v0000644000175000017500000000150012326224777017424 0ustar stephstephRequire Export ZArith. Require Export ZArithRing. (* Cette tactique a pour objectif de remplacer toute instance de (POS (xI e)) ou de (POS (xO e)) par 2*(POS e)+1 ou 2*(POS e), pour rendre les expressions plus ā męme d'ętre utilisées par Ring, lorsque ces expressions contiennent des variables de type positive. *) Ltac compute_POS := match goal with | |- context [(Zpos (xI ?X1))] => let v := constr:X1 in match constr:v with | 1%positive => fail 1 | _ => rewrite (BinInt.Pos2Z.inj_xI v) end | |- context [(Zpos (xO ?X1))] => let v := constr:X1 in match constr:v with | 1%positive => fail 1 | _ => rewrite (BinInt.Pos2Z.inj_xO v) end end. Goal forall x : positive, Zpos (xI (xI x)) = (4 * Zpos x + 3)%Z. intros. repeat compute_POS. ring. Qed. coq-8.4pl4/test-suite/success/intros.v0000644000175000017500000000025012326224777017113 0ustar stephsteph(* Thinning introduction hypothesis must be done after all introductions *) (* Submitted by Guillaume Melquiond (bug #1000) *) Goal forall A, A -> True. intros _ _. coq-8.4pl4/test-suite/success/Case6.v0000644000175000017500000000110712326224777016540 0ustar stephstephParameter ff : forall n m : nat, n <> m -> S n <> S m. Parameter discr_r : forall n : nat, 0 <> S n. Parameter discr_l : forall n : nat, S n <> 0. Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m := match n, m return (n = m \/ n <> m) with | O, O => or_introl (0 <> 0) (refl_equal 0) | O, S x => or_intror (0 = S x) (discr_r x) | S x, O => or_intror _ (discr_l x) | S x as N, S y as M => match eqdec x y return (N = M \/ N <> M) with | or_introl h => or_introl (N <> M) (f_equal S h) | or_intror h => or_intror (N = M) (ff x y h) end end. coq-8.4pl4/test-suite/success/rewrite_iterated.v0000644000175000017500000000104112326224777021136 0ustar stephstephRequire Import Arith Omega. Lemma test : forall p:nat, p<>0 -> p-1+1=p. Proof. intros; omega. Qed. (** Test of new syntax for rewrite : ! ? and so on... *) Lemma but : forall a b c, a<>0 -> b<>0 -> c<>0 -> (a-1+1)+(b-1+1)+(c-1+1)=a+b+c. Proof. intros. rewrite test. Undo. rewrite test,test. Undo. rewrite 2 test. (* or rewrite 2test or rewrite 2!test *) Undo. rewrite 2!test,2?test. Undo. (*rewrite 4!test. --> error *) rewrite 3!test. Undo. rewrite <- 3?test. Undo. (*rewrite <-?test. --> loops*) rewrite !test by auto. reflexivity. Qed. coq-8.4pl4/test-suite/success/PPFix.v0000644000175000017500000000031712326224777016567 0ustar stephsteph (* To test PP of fixpoints *) Require Import Arith. Check fix a(n: nat): n<5 -> nat := match n return n<5 -> nat with | 0 => fun _ => 0 | S n => fun h => S (a n (lt_S_n _ _ (lt_S _ _ h))) end. coq-8.4pl4/test-suite/success/destruct.v0000644000175000017500000000356612326224777017447 0ustar stephsteph(* Submitted by Robert Schneck *) Parameters A B C D : Prop. Axiom X : A -> B -> C /\ D. Lemma foo : A -> B -> C. Proof. intros. destruct X. (* Should find axiom X and should handle arguments of X *) assumption. assumption. assumption. Qed. (* Simplification of bug 711 *) Parameter f : true = false. Goal let p := f in True. intro p. set (b := true) in *. (* Check that it doesn't fail with an anomaly *) (* Ultimately, adapt destruct to make it succeeding *) try destruct b. Abort. (* Used to fail with error "n is used in conclusion" before revision 9447 *) Goal forall n, n = S n. induction S. Abort. (* Check that elimination with remaining evars do not raise an bad error message *) Theorem Refl : forall P, P <-> P. tauto. Qed. Goal True. case Refl || ecase Refl. Abort. (* Submitted by B. Baydemir (bug #1882) *) Require Import List. Definition alist R := list (nat * R)%type. Section Properties. Variable A : Type. Variable a : A. Variable E : alist A. Lemma silly : E = E. Proof. clear. induction E. (* this fails. *) Abort. End Properties. (* This used not to work before revision 11944 *) Goal forall P:(forall n, 0=n -> Prop), forall H: 0=0, P 0 H. destruct H. Abort. (* The calls to "destruct" below did not work before revision 12356 *) Variable A0:Type. Variable P:A0->Type. Require Import JMeq. Goal forall a b (p:P a) (q:P b), forall H:a = b, eq_rect a P p b H = q -> JMeq (existT _ a p) (existT _ b q). intros. destruct H. destruct H0. reflexivity. Qed. (* These did not work before 8.4 *) Goal (exists x, x=0) -> True. destruct 1 as (_,_); exact I. Abort. Goal (exists x, x=0 /\ True) -> True. destruct 1 as (_,(_,H)); exact H. Abort. Goal (exists x, x=0 /\ True) -> True. destruct 1 as (_,(_,x)); exact x. Abort. Goal let T:=nat in forall (x:nat) (g:T -> nat), g x = 0. intros. destruct (g _). (* This was failing in at least r14571 *) Abort. coq-8.4pl4/test-suite/success/Hints.v0000644000175000017500000000305112326224777016664 0ustar stephsteph(* Checks syntax of Hints commands *) (* Checks that qualified names are accepted *) (* New-style syntax *) Hint Resolve eq_refl: core arith. Hint Immediate eq_trans. Hint Unfold eq_sym: core. Hint Constructors eq: foo bar. Hint Extern 3 (_ = _) => apply eq_refl: foo bar. (* Old-style syntax *) Hint Resolve eq_refl eq_sym. Hint Resolve eq_refl eq_sym: foo. Hint Immediate eq_refl eq_sym. Hint Immediate eq_refl eq_sym: foo. Hint Unfold fst eq_sym. Hint Unfold fst eq_sym: foo. (* Checks that local names are accepted *) Section A. Remark Refl : forall (A : Set) (x : A), x = x. Proof. exact @eq_refl. Defined. Definition Sym := eq_sym. Let Trans := eq_trans. Hint Resolve Refl: foo. Hint Resolve Sym: bar. Hint Resolve Trans: foo2. Hint Immediate Refl. Hint Immediate Sym. Hint Immediate Trans. Hint Unfold Refl. Hint Unfold Sym. Hint Unfold Trans. Hint Resolve Sym Trans Refl. Hint Immediate Sym Trans Refl. Hint Unfold Sym Trans Refl. End A. Axiom a : forall n, n=0 <-> n<=0. Hint Resolve -> a. Goal forall n, n=0 -> n<=0. auto. Qed. (* This example comes from Chlipala's ltamer *) (* It used to fail from r12902 to r13112 since type_of started to call *) (* e_cumul (instead of conv_leq) which was not able to unify "?id" and *) (* "(fun x => x) ?id" *) Notation "e :? pf" := (eq_rect _ (fun X : Set => X) e _ pf) (no associativity, at level 90). Axiom cast_coalesce : forall (T1 T2 T3 : Set) (e : T1) (pf1 : T1 = T2) (pf2 : T2 = T3), ((e :? pf1) :? pf2) = (e :? trans_eq pf1 pf2). Hint Rewrite cast_coalesce : ltamer. coq-8.4pl4/test-suite/success/Funind.v0000644000175000017500000002346712326224777017037 0ustar stephsteph Definition iszero (n : nat) : bool := match n with | O => true | _ => false end. Functional Scheme iszero_ind := Induction for iszero Sort Prop. Lemma toto : forall n : nat, n = 0 -> iszero n = true. intros x eg. functional induction iszero x; simpl. trivial. inversion eg. Qed. Function ftest (n m : nat) : nat := match n with | O => match m with | O => 0 | _ => 1 end | S p => 0 end. Lemma test1 : forall n m : nat, ftest n m <= 2. intros n m. functional induction ftest n m; auto. Qed. Lemma test2 : forall m n, ~ 2 = ftest n m. Proof. intros n m;intro H. functional inversion H ftest. Qed. Lemma test3 : forall n m, ftest n m = 0 -> (n = 0 /\ m = 0) \/ n <> 0. Proof. functional inversion 1 ftest;auto. Qed. Require Import Arith. Lemma test11 : forall m : nat, ftest 0 m <= 2. intros m. functional induction ftest 0 m. auto. auto. auto with *. Qed. Function lamfix (m n : nat) {struct n } : nat := match n with | O => m | S p => lamfix m p end. (* Parameter v1 v2 : nat. *) Lemma lamfix_lem : forall v1 v2 : nat, lamfix v1 v2 = v1. intros v1 v2. functional induction lamfix v1 v2. trivial. assumption. Defined. (* polymorphic function *) Require Import List. Functional Scheme app_ind := Induction for app Sort Prop. Lemma appnil : forall (A : Set) (l l' : list A), l' = nil -> l = l ++ l'. intros A l l'. functional induction app A l l'; intuition. rewrite <- H0; trivial. Qed. Require Export Arith. Function trivfun (n : nat) : nat := match n with | O => 0 | S m => trivfun m end. (* essaie de parametre variables non locaux:*) Parameter varessai : nat. Lemma first_try : trivfun varessai = 0. functional induction trivfun varessai. trivial. assumption. Defined. Functional Scheme triv_ind := Induction for trivfun Sort Prop. Lemma bisrepetita : forall n' : nat, trivfun n' = 0. intros n'. functional induction trivfun n'. trivial. assumption. Qed. Function iseven (n : nat) : bool := match n with | O => true | S (S m) => iseven m | _ => false end. Function funex (n : nat) : nat := match iseven n with | true => n | false => match n with | O => 0 | S r => funex r end end. Function nat_equal_bool (n m : nat) {struct n} : bool := match n with | O => match m with | O => true | _ => false end | S p => match m with | O => false | S q => nat_equal_bool p q end end. Require Export Div2. Functional Scheme div2_ind := Induction for div2 Sort Prop. Lemma div2_inf : forall n : nat, div2 n <= n. intros n. functional induction div2 n. auto. auto. apply le_S. apply le_n_S. exact IHn0. Qed. (* reuse this lemma as a scheme:*) Function nested_lam (n : nat) : nat -> nat := match n with | O => fun m : nat => 0 | S n' => fun m : nat => m + nested_lam n' m end. Lemma nest : forall n m : nat, nested_lam n m = n * m. intros n m. functional induction nested_lam n m; simpl;auto. Qed. Function essai (x : nat) (p : nat * nat) {struct x} : nat := let (n, m) := (p: nat*nat) in match n with | O => 0 | S q => match x with | O => 1 | S r => S (essai r (q, m)) end end. Lemma essai_essai : forall (x : nat) (p : nat * nat), let (n, m) := p in 0 < n -> 0 < essai x p. intros x p. functional induction essai x p; intros. inversion H. auto with arith. auto with arith. Qed. Function plus_x_not_five'' (n m : nat) {struct n} : nat := let x := nat_equal_bool m 5 in let y := 0 in match n with | O => y | S q => let recapp := plus_x_not_five'' q m in match x with | true => S recapp | false => S recapp end end. Lemma notplusfive'' : forall x y : nat, y = 5 -> plus_x_not_five'' x y = x. intros a b. functional induction plus_x_not_five'' a b; intros hyp; simpl; auto. Qed. Lemma iseq_eq : forall n m : nat, n = m -> nat_equal_bool n m = true. intros n m. functional induction nat_equal_bool n m; simpl; intros hyp; auto. rewrite <- hyp in y; simpl in y;tauto. inversion hyp. Qed. Lemma iseq_eq' : forall n m : nat, nat_equal_bool n m = true -> n = m. intros n m. functional induction nat_equal_bool n m; simpl; intros eg; auto. inversion eg. inversion eg. Qed. Inductive istrue : bool -> Prop := istrue0 : istrue true. Functional Scheme plus_ind := Induction for plus Sort Prop. Lemma inf_x_plusxy' : forall x y : nat, x <= x + y. intros n m. functional induction plus n m; intros. auto with arith. auto with arith. Qed. Lemma inf_x_plusxy'' : forall x : nat, x <= x + 0. intros n. unfold plus. functional induction plus n 0; intros. auto with arith. apply le_n_S. assumption. Qed. Lemma inf_x_plusxy''' : forall x : nat, x <= 0 + x. intros n. functional induction plus 0 n; intros; auto with arith. Qed. Function mod2 (n : nat) : nat := match n with | O => 0 | S (S m) => S (mod2 m) | _ => 0 end. Lemma princ_mod2 : forall n : nat, mod2 n <= n. intros n. functional induction mod2 n; simpl; auto with arith. Qed. Function isfour (n : nat) : bool := match n with | S (S (S (S O))) => true | _ => false end. Function isononeorfour (n : nat) : bool := match n with | S O => true | S (S (S (S O))) => true | _ => false end. Lemma toto'' : forall n : nat, istrue (isfour n) -> istrue (isononeorfour n). intros n. functional induction isononeorfour n; intros istr; simpl; inversion istr. apply istrue0. destruct n. inversion istr. destruct n. tauto. destruct n. inversion istr. destruct n. inversion istr. destruct n. tauto. simpl in *. inversion H0. Qed. Lemma toto' : forall n m : nat, n = 4 -> istrue (isononeorfour n). intros n. functional induction isononeorfour n; intros m istr; inversion istr. apply istrue0. rewrite H in y; simpl in y;tauto. Qed. Function ftest4 (n m : nat) : nat := match n with | O => match m with | O => 0 | S q => 1 end | S p => match m with | O => 0 | S r => 1 end end. Lemma test4 : forall n m : nat, ftest n m <= 2. intros n m. functional induction ftest n m; auto with arith. Qed. Lemma test4' : forall n m : nat, ftest4 (S n) m <= 2. intros n m. assert ({n0 | n0 = S n}). exists (S n);reflexivity. destruct H as [n0 H1]. rewrite <- H1;revert H1. functional induction ftest4 n0 m. inversion 1. inversion 1. auto with arith. auto with arith. Qed. Function ftest44 (x : nat * nat) (n m : nat) : nat := let (p, q) := (x: nat*nat) in match n with | O => match m with | O => 0 | S q => 1 end | S p => match m with | O => 0 | S r => 1 end end. Lemma test44 : forall (pq : nat * nat) (n m o r s : nat), ftest44 pq n (S m) <= 2. intros pq n m o r s. functional induction ftest44 pq n (S m). auto with arith. auto with arith. auto with arith. auto with arith. Qed. Function ftest2 (n m : nat) {struct n} : nat := match n with | O => match m with | O => 0 | S q => 0 end | S p => ftest2 p m end. Lemma test2' : forall n m : nat, ftest2 n m <= 2. intros n m. functional induction ftest2 n m; simpl; intros; auto. Qed. Function ftest3 (n m : nat) {struct n} : nat := match n with | O => 0 | S p => match m with | O => ftest3 p 0 | S r => 0 end end. Lemma test3' : forall n m : nat, ftest3 n m <= 2. intros n m. functional induction ftest3 n m. intros. auto. intros. auto. intros. simpl. auto. Qed. Function ftest5 (n m : nat) {struct n} : nat := match n with | O => 0 | S p => match m with | O => ftest5 p 0 | S r => ftest5 p r end end. Lemma test5 : forall n m : nat, ftest5 n m <= 2. intros n m. functional induction ftest5 n m. intros. auto. intros. auto. intros. simpl. auto. Qed. Function ftest7 (n : nat) : nat := match ftest5 n 0 with | O => 0 | S r => 0 end. Lemma essai7 : forall (Hrec : forall n : nat, ftest5 n 0 = 0 -> ftest7 n <= 2) (Hrec0 : forall n r : nat, ftest5 n 0 = S r -> ftest7 n <= 2) (n : nat), ftest7 n <= 2. intros hyp1 hyp2 n. functional induction ftest7 n; auto. Qed. Function ftest6 (n m : nat) {struct n} : nat := match n with | O => 0 | S p => match ftest5 p 0 with | O => ftest6 p 0 | S r => ftest6 p r end end. Lemma princ6 : (forall n m : nat, n = 0 -> ftest6 0 m <= 2) -> (forall n m p : nat, ftest6 p 0 <= 2 -> ftest5 p 0 = 0 -> n = S p -> ftest6 (S p) m <= 2) -> (forall n m p r : nat, ftest6 p r <= 2 -> ftest5 p 0 = S r -> n = S p -> ftest6 (S p) m <= 2) -> forall x y : nat, ftest6 x y <= 2. intros hyp1 hyp2 hyp3 n m. generalize hyp1 hyp2 hyp3. clear hyp1 hyp2 hyp3. functional induction ftest6 n m; auto. Qed. Lemma essai6 : forall n m : nat, ftest6 n m <= 2. intros n m. functional induction ftest6 n m; simpl; auto. Qed. (* Some tests with modules *) Module M. Function test_m (n:nat) : nat := match n with | 0 => 0 | S n => S (S (test_m n)) end. Lemma test_m_is_double : forall n, div2 (test_m n) = n. Proof. intros n. functional induction (test_m n). reflexivity. simpl;rewrite IHn0;reflexivity. Qed. End M. (* We redefine a new Function with the same name *) Function test_m (n:nat) : nat := pred n. Lemma test_m_is_pred : forall n, test_m n = pred n. Proof. intro n. functional induction (test_m n). (* the test_m_ind to use is the last defined saying that test_m = pred*) reflexivity. Qed. (* Checks if the dot notation are correctly treated in infos *) Lemma M_test_m_is_double : forall n, div2 (M.test_m n) = n. intro n. (* here we should apply M.test_m_ind *) functional induction (M.test_m n). reflexivity. simpl;rewrite IHn0;reflexivity. Qed. Import M. (* Now test_m is the one which defines double *) Lemma test_m_is_double : forall n, div2 (M.test_m n) = n. intro n. (* here we should apply M.test_m_ind *) functional induction (test_m n). reflexivity. simpl;rewrite IHn0;reflexivity. Qed. coq-8.4pl4/test-suite/success/LetPat.v0000644000175000017500000000332612326224777016775 0ustar stephsteph(* Simple let-patterns *) Variable A B : Type. Definition l1 (t : A * B * B) : A := let '(x, y, z) := t in x. Print l1. Definition l2 (t : (A * B) * B) : A := let '((x, y), z) := t in x. Definition l3 (t : A * (B * B)) : A := let '(x, (y, z)) := t in x. Print l3. Record someT (A : Type) := mkT { a : nat; b: A }. Definition l4 A (t : someT A) : nat := let 'mkT x y := t in x. Print l4. Print sigT. Definition l5 A (B : A -> Type) (t : sigT B) : B (projT1 t) := let 'existT x y := t return B (projT1 t) in y. Definition l6 A (B : A -> Type) (t : sigT B) : B (projT1 t) := let 'existT x y as t' := t return B (projT1 t') in y. Definition l7 A (B : A -> Type) (t : sigT B) : B (projT1 t) := let 'existT x y as t' in sigT _ := t return B (projT1 t') in y. Definition l8 A (B : A -> Type) (t : sigT B) : B (projT1 t) := match t with existT x y => y end. (** An example from algebra, using let' and inference of return clauses to deconstruct contexts. *) Record a_category (A : Type) (hom : A -> A -> Type) := { }. Definition category := { A : Type & { hom : A -> A -> Type & a_category A hom } }. Record a_functor (A : Type) (hom : A -> A -> Type) (C : a_category A hom) := { }. Notation " x :& y " := (@existT _ _ x y) (right associativity, at level 55) : core_scope. Definition functor (c d : category) := let ' A :& homA :& CA := c in let ' B :& homB :& CB := d in A -> B. Definition identity_functor (c : category) : functor c c := let 'A :& homA :& CA := c in fun x => x. Definition functor_composition (a b c : category) : functor a b -> functor b c -> functor a c := let 'A :& homA :& CA := a in let 'B :& homB :& CB := b in let 'C :& homB :& CB := c in fun f g => fun x => g (f x). coq-8.4pl4/test-suite/success/PCase.v0000644000175000017500000000275312326224777016602 0ustar stephsteph (** Some tests of patterns containing matchs ending with joker branches. Cf. the new form of the [constr_pattern] constructor [PCase] in [pretyping/pattern.ml] *) (* A universal match matcher *) Ltac kill_match := match goal with |- context [ match ?x with _ => _ end ] => destruct x end. (* A match matcher restricted to a given type : nat *) Ltac kill_match_nat := match goal with |- context [ match ?x in nat with _ => _ end ] => destruct x end. (* Another way to restrict to a given type : give a branch *) Ltac kill_match_nat2 := match goal with |- context [ match ?x with S _ => _ | _ => _ end ] => destruct x end. (* This should act only on empty match *) Ltac kill_match_empty := match goal with |- context [ match ?x with end ] => destruct x end. Lemma test1 (b:bool) : if b then True else O=O. Proof. Fail kill_match_nat. Fail kill_match_nat2. Fail kill_match_empty. kill_match. exact I. exact eq_refl. Qed. Lemma test2a (n:nat) : match n with O => True | S n => (n = n) end. Proof. Fail kill_match_empty. kill_match_nat. exact I. exact eq_refl. Qed. Lemma test2b (n:nat) : match n with O => True | S n => (n = n) end. Proof. kill_match_nat2. exact I. exact eq_refl. Qed. Lemma test2c (n:nat) : match n with O => True | S n => (n = n) end. Proof. kill_match. exact I. exact eq_refl. Qed. Lemma test3a (f:False) : match f return Prop with end. Proof. kill_match_empty. Qed. Lemma test3b (f:False) : match f return Prop with end. Proof. kill_match. Qed. coq-8.4pl4/test-suite/success/Case7.v0000644000175000017500000000073212326224777016544 0ustar stephstephInductive List (A : Set) : Set := | Nil : List A | Cons : A -> List A -> List A. Inductive Empty (A : Set) : List A -> Prop := intro_Empty : Empty A (Nil A). Parameter inv_Empty : forall (A : Set) (a : A) (x : List A), ~ Empty A (Cons A a x). Type (fun (A : Set) (l : List A) => match l return (Empty A l \/ ~ Empty A l) with | Nil => or_introl (~ Empty A (Nil A)) (intro_Empty A) | Cons a y as b => or_intror (Empty A b) (inv_Empty A a y) end). coq-8.4pl4/test-suite/success/Inductive.v0000644000175000017500000000562612326224777017543 0ustar stephsteph(* Test des definitions inductives imbriquees *) Require Import List. Inductive X : Set := cons1 : list X -> X. Inductive Y : Set := cons2 : list (Y * Y) -> Y. (* Test inductive types with local definitions (arity) *) Inductive eq1 : forall A:Type, let B:=A in A -> Prop := refl1 : eq1 True I. Check fun (P : forall A : Type, let B := A in A -> Type) (f : P True I) (A : Type) => let B := A in fun (a : A) (e : eq1 A a) => match e in (eq1 A0 B0 a0) return (P A0 a0) with | refl1 => f end. Inductive eq2 (A:Type) (a:A) : forall B C:Type, let D:=(A*B*C)%type in D -> Prop := refl2 : eq2 A a unit bool (a,tt,true). (* Check inductive types with local definitions (parameters) *) Inductive A (C D : Prop) (E:=C) (F:=D) (x y : E -> F) : E -> Set := I : forall z : E, A C D x y z. Check (fun C D : Prop => let E := C in let F := D in fun (x y : E -> F) (P : forall c : C, A C D x y c -> Type) (f : forall z : C, P z (I C D x y z)) (y0 : C) (a : A C D x y y0) => match a as a0 in (A _ _ _ _ _ _ y1) return (P y1 a0) with | I x0 => f x0 end). Record B (C D : Set) (E:=C) (F:=D) (x y : E -> F) : Set := {p : C; q : E}. Check (fun C D : Set => let E := C in let F := D in fun (x y : E -> F) (P : B C D x y -> Type) (f : forall p0 q0 : C, P (Build_B C D x y p0 q0)) (b : B C D x y) => match b as b0 return (P b0) with | Build_B x0 x1 => f x0 x1 end). (* Check inductive types with local definitions (constructors) *) Inductive I1 : Set := C1 (_:I1) (_:=0). Check (fun x:I1 => match x with | C1 i n => (i,n) end). (* Check implicit parameters of inductive types (submitted by Pierre Casteran and also implicit in #338) *) Set Implicit Arguments. Unset Strict Implicit. CoInductive LList (A : Set) : Set := | LNil : LList A | LCons : A -> LList A -> LList A. Implicit Arguments LNil [A]. Inductive Finite (A : Set) : LList A -> Prop := | Finite_LNil : Finite LNil | Finite_LCons : forall (a : A) (l : LList A), Finite l -> Finite (LCons a l). (* Check positivity modulo reduction (cf bug #983) *) Record P:Type := {PA:Set; PB:Set}. Definition F (p:P) := (PA p) -> (PB p). Inductive I_F:Set := c : (F (Build_P nat I_F)) -> I_F. (* Check that test for binders capturing implicit arguments is not stronger than needed (problem raised by Cedric Auger) *) Set Implicit Arguments. Inductive bool_comp2 (b: bool): bool -> Prop := | Opp2: forall q, (match b return Prop with | true => match q return Prop with true => False | false => True end | false => match q return Prop with true => True | false => False end end) -> bool_comp2 b q. (* This one is still to be made acceptable... Set Implicit Arguments. Inductive I A : A->Prop := C a : (forall A, A) -> I a. *) coq-8.4pl4/test-suite/success/induct.v0000644000175000017500000000336712326224777017077 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* X. Inductive Y : Set := cons2 : list (Y * Y) -> Y. (* Test inductive types with local definitions *) Inductive eq1 : forall A:Type, let B:=A in A -> Prop := refl1 : eq1 True I. Check fun (P : forall A : Type, let B := A in A -> Type) (f : P True I) (A : Type) => let B := A in fun (a : A) (e : eq1 A a) => match e in (eq1 A0 B0 a0) return (P A0 a0) with | refl1 => f end. Inductive eq2 (A:Type) (a:A) : forall B C:Type, let D:=(A*B*C)%type in D -> Prop := refl2 : eq2 A a unit bool (a,tt,true). (* Check that induction variables are cleared even with in clause *) Lemma foo : forall n m : nat, n + m = n + m. Proof. intros; induction m as [|m] in n |- *. auto. auto. Qed. (* Check selection of occurrences by pattern *) Goal forall x, S x = S (S x). intros. induction (S _) in |- * at -2. now_show (0=1). Undo 2. induction (S _) in |- * at 1 3. now_show (0=1). Undo 2. induction (S _) in |- * at 1. now_show (0=S (S x)). Undo 2. induction (S _) in |- * at 2. now_show (S x=0). Undo 2. induction (S _) in |- * at 3. now_show (S x=1). Undo 2. Fail induction (S _) in |- * at 4. Abort. coq-8.4pl4/test-suite/success/searchabout.v0000644000175000017500000000323212326224777020100 0ustar stephsteph (** Test of the different syntaxes of SearchAbout, in particular with and without the [ ... ] delimiters *) SearchAbout plus. SearchAbout plus mult. SearchAbout "plus_n". SearchAbout plus "plus_n". SearchAbout "*". SearchAbout "*" "+". SearchAbout plus inside Peano. SearchAbout plus mult inside Peano. SearchAbout "plus_n" inside Peano. SearchAbout plus "plus_n" inside Peano. SearchAbout "*" inside Peano. SearchAbout "*" "+" inside Peano. SearchAbout plus outside Peano Logic. SearchAbout plus mult outside Peano Logic. SearchAbout "plus_n" outside Peano Logic. SearchAbout plus "plus_n" outside Peano Logic. SearchAbout "*" outside Peano Logic. SearchAbout "*" "+" outside Peano Logic. SearchAbout -"*" "+" outside Logic. SearchAbout -"*"%nat "+"%nat outside Logic. SearchAbout [plus]. SearchAbout [plus mult]. SearchAbout ["plus_n"]. SearchAbout [plus "plus_n"]. SearchAbout ["*"]. SearchAbout ["*" "+"]. SearchAbout [plus] inside Peano. SearchAbout [plus mult] inside Peano. SearchAbout ["plus_n"] inside Peano. SearchAbout [plus "plus_n"] inside Peano. SearchAbout ["*"] inside Peano. SearchAbout ["*" "+"] inside Peano. SearchAbout [plus] outside Peano Logic. SearchAbout [plus mult] outside Peano Logic. SearchAbout ["plus_n"] outside Peano Logic. SearchAbout [plus "plus_n"] outside Peano Logic. SearchAbout ["*"] outside Peano Logic. SearchAbout ["*" "+"] outside Peano Logic. SearchAbout [-"*" "+"] outside Logic. SearchAbout [-"*"%nat "+"%nat] outside Logic. (** The example in the Reference Manual *) Require Import ZArith. SearchAbout Z.mul Z.add "distr". SearchAbout "+"%Z "*"%Z "distr" -positive -Prop. SearchAbout (?x * _ + ?x * _)%Z outside OmegaLemmas. coq-8.4pl4/test-suite/success/Case3.v0000644000175000017500000000132012326224777016532 0ustar stephstephInductive Le : nat -> nat -> Set := | LeO : forall n : nat, Le 0 n | LeS : forall n m : nat, Le n m -> Le (S n) (S m). Parameter discr_l : forall n : nat, S n <> 0. Type (fun n : nat => match n return (n = 0 \/ n <> 0) with | O => or_introl (0 <> 0) (refl_equal 0) | S O => or_intror (1 = 0) (discr_l 0) | S (S x) => or_intror (S (S x) = 0) (discr_l (S x)) end). Parameter iguales : forall (n m : nat) (h : Le n m), Prop. Type match LeO 0 as h in (Le n m) return Prop with | LeO O => True | LeS (S x) (S y) H => iguales (S x) (S y) H | _ => False end. Type match LeO 0 as h in (Le n m) return Prop with | LeO O => True | LeS (S x) O H => iguales (S x) 0 H | _ => False end. coq-8.4pl4/test-suite/success/CanonicalStructure.v0000644000175000017500000000131112326224777021404 0ustar stephsteph(* Bug #1172 *) Structure foo : Type := Foo { A : Set; Aopt := option A; unopt : Aopt -> A }. Canonical Structure unopt_nat := @Foo nat (fun _ => O). (* Granted wish #1187 *) Record Silly (X : Set) : Set := mkSilly { x : X }. Definition anotherMk := mkSilly. Definition struct := anotherMk nat 3. Canonical Structure struct. (* Intertwinning canonical structures and delta-expansion *) (* Assia's short example *) Open Scope bool_scope. Set Implicit Arguments. Structure test_struct : Type := mk_test {dom :> Type; f : dom -> dom -> bool}. Notation " x != y":= (f _ x y)(at level 10). Canonical Structure bool_test := mk_test (fun x y => x || y). Definition b := bool. Check (fun x : b => x != x). coq-8.4pl4/test-suite/success/Case12.v0000644000175000017500000000403012326224777016613 0ustar stephsteph(* This example was proposed by Cuihtlauac ALVARADO *) Require Import List. Fixpoint mult2 (n : nat) : nat := match n with | O => 0 | S n => S (S (mult2 n)) end. Inductive list : nat -> Set := | nil : list 0 | cons : forall n : nat, list (mult2 n) -> list (S (S (mult2 n))). Type (fun (P : forall n : nat, list n -> Prop) (f : P 0 nil) (f0 : forall (n : nat) (l : list (mult2 n)), P (mult2 n) l -> P (S (S (mult2 n))) (cons n l)) => fix F (n : nat) (l : list n) {struct l} : P n l := match l as x0 in (list x) return (P x x0) with | nil => f | cons n0 l0 => f0 n0 l0 (F (mult2 n0) l0) end). Inductive list' : nat -> Set := | nil' : list' 0 | cons' : forall n : nat, let m := mult2 n in list' m -> list' (S (S m)). Fixpoint length n (l : list' n) {struct l} : nat := match l with | nil' => 0 | cons' _ m l0 => S (length m l0) end. Type (fun (P : forall n : nat, list' n -> Prop) (f : P 0 nil') (f0 : forall n : nat, let m := mult2 n in forall l : list' m, P m l -> P (S (S m)) (cons' n l)) => fix F (n : nat) (l : list' n) {struct l} : P n l := match l as x0 in (list' x) return (P x x0) with | nil' => f | cons' n0 m l0 => f0 n0 l0 (F m l0) end). (* Check on-the-fly insertion of let-in patterns for compatibility *) Inductive list'' : nat -> Set := | nil'' : list'' 0 | cons'' : forall n : nat, let m := mult2 n in list'' m -> let p := S (S m) in list'' p. Check (fix length n (l : list'' n) {struct l} : nat := match l with | nil'' => 0 | cons'' n l0 => S (length (mult2 n) l0) end). (* Check let-in in both parameters and in constructors *) Inductive list''' (A:Set) (B:=(A*A)%type) (a:A) : B -> Set := | nil''' : list''' A a (a,a) | cons''' : forall a' : A, let m := (a',a) in list''' A a m -> list''' A a (a,a). Fixpoint length''' (A:Set) (B:=(A*A)%type) (a:A) (m:B) (l:list''' A a m) {struct l} : nat := match l with | nil''' => 0 | cons''' _ m l0 => S (length''' A a m l0) end. coq-8.4pl4/test-suite/success/Scheme.v0000644000175000017500000000012212326224777016777 0ustar stephsteph(* This failed in 8.3pl2 *) Scheme Induction for eq Sort Prop. Check eq_ind_dep. coq-8.4pl4/test-suite/success/Case10.v0000644000175000017500000000134212326224777016614 0ustar stephsteph(* ============================================== *) (* To test compilation of dependent case *) (* Multiple Patterns *) (* ============================================== *) Inductive skel : Type := | PROP : skel | PROD : skel -> skel -> skel. Parameter Can : skel -> Type. Parameter default_can : forall s : skel, Can s. Type (fun s1 s2 : skel => match s1, s2 return (Can s1) with | PROP, PROP => default_can PROP | s1, _ => default_can s1 end). Type (fun s1 s2 : skel => match s1, s2 return (Can s1) with | PROP, PROP => default_can PROP | PROP as s, _ => default_can s | PROD s1 s2 as s, PROP => default_can s | PROD s1 s2 as s, _ => default_can s end). coq-8.4pl4/test-suite/success/implicit.v0000644000175000017500000000531112326224777017412 0ustar stephsteph(* Testing the behavior of implicit arguments *) (* Implicit on section variables *) Set Implicit Arguments. Unset Strict Implicit. (* Example submitted by David Nowak *) Section Spec. Variable A : Set. Variable op : forall A : Set, A -> A -> Set. Infix "#" := op (at level 70). Check (forall x : A, x # x). (* Example submitted by Christine *) Record stack : Type := {type : Set; elt : type; empty : type -> bool; proof : empty elt = true}. Check (forall (type : Set) (elt : type) (empty : type -> bool), empty elt = true -> stack). (* Nested sections and manual/automatic implicit arguments *) Variable op' : forall A : Set, A -> A -> Set. Variable op'' : forall A : Set, A -> A -> Set. Section B. Definition eq1 := fun (A:Type) (x y:A) => x=y. Definition eq2 := fun (A:Type) (x y:A) => x=y. Definition eq3 := fun (A:Type) (x y:A) => x=y. Implicit Arguments op' []. Global Implicit Arguments op'' []. Implicit Arguments eq2 []. Global Implicit Arguments eq3 []. Check (op 0 0). Check (op' nat 0 0). Check (op'' nat 0 0). Check (eq1 0 0). Check (eq2 nat 0 0). Check (eq3 nat 0 0). End B. Check (op 0 0). Check (op' 0 0). Check (op'' nat 0 0). Check (eq1 0 0). Check (eq2 0 0). Check (eq3 nat 0 0). End Spec. Check (eq1 0 0). Check (eq2 0 0). Check (eq3 nat 0 0). (* Example submitted by Frédéric (interesting in v8 syntax) *) Parameter f : nat -> nat * nat. Notation lhs := fst. Check (fun x => fst (f x)). Check (fun x => fst (f x)). Notation rhs := snd. Check (fun x => snd (f x)). Check (fun x => @ rhs _ _ (f x)). (* Implicit arguments in fixpoints and inductive declarations *) Fixpoint g n := match n with O => true | S n => g n end. Inductive P n : nat -> Prop := c : P n n. (* Avoid evars in the computation of implicit arguments (cf r9827) *) Require Import List. Fixpoint plus n m {struct n} := match n with | 0 => m | S p => S (plus p m) end. (* Check multiple implicit arguments signatures *) Implicit Arguments eq_refl [[A] [x]] [[A]]. Check eq_refl : 0 = 0. (* Check that notations preserve implicit (since 8.3) *) Parameter p : forall A, A -> forall n, n = 0 -> True. Implicit Arguments p [A n]. Notation Q := (p 0). Check Q eq_refl. (* Check implicits with Context *) Section C. Context {A:Set}. Definition h (a:A) := a. End C. Check h 0. (* Check implicit arguments in arity of inductive types. The three following examples used to fail before r13671 *) Inductive I {A} (a:A) : forall {n:nat}, Prop := | C : I a (n:=0). Inductive I2 (x:=0) : Prop := | C2 {p:nat} : p = 0 -> I2. Check C2 eq_refl. Inductive I3 {A} (x:=0) (a:A) : forall {n:nat}, Prop := | C3 : I3 a (n:=0). (* Check global implicit declaration over ref not in section *) Section D. Global Arguments eq [A] _ _. End D. coq-8.4pl4/test-suite/success/mutual_ind.v0000644000175000017500000000310112326224777017734 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* sort -> bool; sort_beq_refl : forall f : sort, true = sort_beq f f; sort_beq_eq : forall f1 f2 : sort, true = sort_beq f1 f2 -> f1 = f2; fsym :> Set; fsym_type : fsym -> list sort * sort; fsym_beq : fsym -> fsym -> bool; fsym_beq_refl : forall f : fsym, true = fsym_beq f f; fsym_beq_eq : forall f1 f2 : fsym, true = fsym_beq f1 f2 -> f1 = f2}. Variable F : signature. Definition vsym := (sort F * nat)%type. Definition vsym_sort := fst (A:=sort F) (B:=nat). Definition vsym_nat := snd (A:=sort F) (B:=nat). Inductive term : sort F -> Set := | term_var : forall v : vsym, term (vsym_sort v) | term_app : forall f : F, list_term (fst (fsym_type F f)) -> term (snd (fsym_type F f)) with list_term : list (sort F) -> Set := | term_nil : list_term nil | term_cons : forall (s : sort F) (l : list (sort F)), term s -> list_term l -> list_term (s :: l). coq-8.4pl4/test-suite/success/cc.v0000644000175000017500000000443312326224777016171 0ustar stephsteph Theorem t1 : forall (A : Set) (a : A) (f : A -> A), f a = a -> f (f a) = a. intros. congruence. Qed. Theorem t2 : forall (A : Set) (a b : A) (f : A -> A) (g : A -> A -> A), a = f a -> g b (f a) = f (f a) -> g a b = f (g b a) -> g a b = a. intros. congruence. Qed. (* 15=0 /\ 10=0 /\ 6=0 -> 0=1 *) Theorem t3 : forall (N : Set) (o : N) (s d : N -> N), s (s (s (s (s (s (s (s (s (s (s (s (s (s (s o)))))))))))))) = o -> s (s (s (s (s (s (s (s (s (s o))))))))) = o -> s (s (s (s (s (s o))))) = o -> o = s o. intros. congruence. Qed. (* Examples that fail due to dependencies *) (* yields transitivity problem *) Theorem dep : forall (A : Set) (P : A -> Set) (f g : forall x : A, P x) (x y : A) (e : x = y) (e0 : f y = g y), f x = g x. intros; dependent rewrite e; exact e0. Qed. (* yields congruence problem *) Theorem dep2 : forall (A B : Set) (f : forall (A : Set) (b : bool), if b then unit else A -> unit) (e : A = B), f A true = f B true. intros; rewrite e; reflexivity. Qed. (* example that Congruence. can solve (dependent function applied to the same argument)*) Theorem dep3 : forall (A : Set) (P : A -> Set) (f g : forall x : A, P x), f = g -> forall x : A, f x = g x. intros. congruence. Qed. (* Examples with injection rule *) Theorem inj1 : forall (A : Set) (a b c d : A), (a, c) = (b, d) -> a = b /\ c = d. intros. split; congruence. Qed. Theorem inj2 : forall (A : Set) (a c d : A) (f : A -> A * A), f = pair (B:=A) a -> Some (f c) = Some (f d) -> c = d. intros. congruence. Qed. (* Examples with discrimination rule *) Theorem discr1 : true = false -> False. intros. congruence. Qed. Theorem discr2 : Some true = Some false -> False. intros. congruence. Qed. (* example with implications *) Theorem arrow : forall (A B: Prop) (C D:Set) , A=B -> C=D -> (A -> C) = (B -> D). congruence. Qed. Set Implicit Arguments. Parameter elt: Set. Parameter elt_eq: forall (x y: elt), {x = y} + {x <> y}. Definition t (A: Set) := elt -> A. Definition get (A: Set) (x: elt) (m: t A) := m x. Definition set (A: Set) (x: elt) (v: A) (m: t A) := fun (y: elt) => if elt_eq y x then v else m y. Lemma gsident: forall (A: Set) (i j: elt) (m: t A), get j (set i (get i m) m) = get j m. Proof. intros. unfold get, set. case (elt_eq j i); intro. congruence. auto. Qed. coq-8.4pl4/test-suite/success/simpl_tuning.v0000644000175000017500000000746712326224777020326 0ustar stephsteph(* as it is dynamically inferred by simpl *) Arguments minus !n / m. Lemma foo x y : S (S x) - S y = 0. simpl. match goal with |- (match y with O => S x | S _ => _ end = 0) => idtac end. Abort. (* we avoid exposing a match *) Arguments minus n m : simpl nomatch. Lemma foo x : minus 0 x = 0. simpl. match goal with |- (0 = 0) => idtac end. Abort. Lemma foo x y : S (S x) - S y = 0. simpl. match goal with |- (S x - y = 0) => idtac end. Abort. Lemma foo x y : S (S x) - (S (match y with O => O | S z => S z end)) = 0. simpl. match goal with |-(S x - (match y with O => _ | S _ => _ end) = 0) => idtac end. Abort. (* we unfold as soon as we have 1 args, but we avoid exposing a match *) Arguments minus n / m : simpl nomatch. Lemma foo : minus 0 = fun x => 0. simpl. match goal with |- minus 0 = _ => idtac end. Abort. (* This does not work as one may expect. The point is that simpl is implemented as "strong (whd_simpl_state)" and after unfolding minus you have (fun m => match 0 => 0 | S n => ...) that is already in whd and exposes a match, that of course "strong" would reduce away but at that stage we don't know, and reducing by hand under the lambda is against whd *) (* extra tuning for the usual heuristic *) Arguments minus !n / m : simpl nomatch. Lemma foo x y : S (S x) - S y = 0. simpl. match goal with |- (S x - y = 0) => idtac end. Abort. Lemma foo x y : S (S x) - (S (match y with O => O | S z => S z end)) = 0. simpl. match goal with |-(S x - (match y with O => _ | S _ => _ end) = 0) => idtac end. Abort. (* full control *) Arguments minus !n !m /. Lemma foo x y : S (S x) - S y = 0. simpl. match goal with |- (S x - y = 0) => idtac end. Abort. Lemma foo x y : S (S x) - (S (match y with O => O | S z => S z end)) = 0. simpl. match goal with |-(S x - (match y with O => _ | S _ => _ end) = 0) => idtac end. Abort. (* omitting /, that being immediately after the last ! is irrelevant *) Arguments minus !n !m. Lemma foo x y : S (S x) - S y = 0. simpl. match goal with |- (S x - y = 0) => idtac end. Abort. Lemma foo x y : S (S x) - (S (match y with O => O | S z => S z end)) = 0. simpl. match goal with |-(S x - (match y with O => _ | S _ => _ end) = 0) => idtac end. Abort. Definition pf (D1 C1 : Type) (f : D1 -> C1) (D2 C2 : Type) (g : D2 -> C2) := fun x => (f (fst x), g (snd x)). Delimit Scope foo_scope with F. Notation "@@" := nat (only parsing) : foo_scope. Notation "@@" := (fun x => x) (only parsing). Arguments pf {D1%F C1%type} f [D2 C2] g x : simpl never. Lemma foo x : @pf @@ nat @@ nat nat @@ x = pf @@ @@ x. Abort. Definition fcomp A B C f (g : A -> B) (x : A) : C := f (g x). (* fcomp is unfolded if applied to 6 args *) Arguments fcomp {A B C}%type f g x /. Notation "f \o g" := (fcomp f g) (at level 50). Lemma foo (f g h : nat -> nat) x : pf (f \o g) h x = pf f h (g (fst x), snd x). simpl. match goal with |- (pf (f \o g) h x = _) => idtac end. case x; intros x1 x2. simpl. match goal with |- (pf (f \o g) h _ = pf f h _) => idtac end. unfold pf; simpl. match goal with |- (f (g x1), h x2) = (f (g x1), h x2) => idtac end. Abort. Definition volatile := fun x : nat => x. Arguments volatile /. Lemma foo : volatile = volatile. simpl. match goal with |- (fun _ => _) = _ => idtac end. Abort. Set Implicit Arguments. Section S1. Variable T1 : Type. Section S2. Variable T2 : Type. Fixpoint f (x : T1) (y : T2) n (v : unit) m {struct n} : nat := match n, m with | 0,_ => 0 | S _, 0 => n | S n', S m' => f x y n' v m' end. Global Arguments f x y !n !v !m. Lemma foo x y n m : f x y (S n) tt m = f x y (S n) tt (S m). simpl. match goal with |- (f _ _ _ _ _ = f _ _ _ _ _) => idtac end. Abort. End S2. Lemma foo T x y n m : @f T x y (S n) tt m = @f T x y (S n) tt (S m). simpl. match goal with |- (f _ _ _ _ _ = f _ _ _ _ _) => idtac end. Abort. End S1. Arguments f : clear implicits and scopes. coq-8.4pl4/test-suite/success/univers.v0000644000175000017500000000304712326224777017277 0ustar stephsteph(* This requires cumulativity *) Definition Type2 := Type. Definition Type1 : Type2 := Type. Lemma lem1 : (True -> Type1) -> Type2. intro H. apply H. exact I. Qed. Lemma lem2 : forall (A : Type) (P : A -> Type) (x : A), (forall y : A, x = y -> P y) -> P x. auto. Qed. Lemma lem3 : forall P : Prop, P. intro P; pattern P. apply lem2. Abort. (* Check managing of universe constraints in inversion *) (* Bug report #855 *) Inductive dep_eq : forall X : Type, X -> X -> Prop := | intro_eq : forall (X : Type) (f : X), dep_eq X f f | intro_feq : forall (A : Type) (B : A -> Type), let T := forall x : A, B x in forall (f g : T) (x : A), dep_eq (B x) (f x) (g x) -> dep_eq T f g. Require Import Relations. Theorem dep_eq_trans : forall X : Type, transitive X (dep_eq X). Proof. unfold transitive. intros X f g h H1 H2. inversion H1. Abort. (* Submitted by Bas Spitters (bug report #935) *) (* This is a problem with the status of the type in LetIn: is it a user-provided one or an inferred one? At the current time, the kernel type-check the type in LetIn, which means that it must be considered as user-provided when calling the kernel. However, in practice it is inferred so that a universe refresh is needed to set its status as "user-provided". Especially, universe refreshing was not done for "set/pose" *) Lemma ind_unsec : forall Q : nat -> Type, True. intro. set (C := forall m, Q m -> Q m). exact I. Qed. (* Submitted by Danko Ilik (bug report #1507); related to LetIn *) Record U : Type := { A:=Type; a:A }. coq-8.4pl4/test-suite/success/rewrite_in.v0000644000175000017500000000022412326224777017745 0ustar stephstephRequire Import Setoid. Goal forall (P Q : Prop) (f:P->Prop) (p:P), (P<->Q) -> f p -> True. intros P Q f p H. rewrite H in p || trivial. Qed. coq-8.4pl4/test-suite/success/extraction.v0000644000175000017500000003355212326224777017770 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* nat) (x:nat) := f x. Extraction test2. (* let test2 f x = f x *) Definition test3 (f:nat -> Set -> nat) (x:nat) := f x nat. Extraction test3. (* let test3 f x = f x __ *) Definition test4 (f:(nat -> nat) -> nat) (x:nat) (g:nat -> nat) := f g. Extraction test4. (* let test4 f x g = f g *) Definition test5 := (1, 0). Extraction test5. (* let test5 = Pair ((S O), O) *) Definition cf (x:nat) (_:x <= 0) := S x. Extraction NoInline cf. Definition test6 := cf 0 (le_n 0). Extraction test6. (* let test6 = cf O *) Definition test7 := (fun (X:Set) (x:X) => x) nat. Extraction test7. (* let test7 x = x *) Definition d (X:Type) := X. Extraction d. (* type 'x d = 'x *) Definition d2 := d Set. Extraction d2. (* type d2 = __ d *) Definition d3 (x:d Set) := 0. Extraction d3. (* let d3 _ = O *) Definition d4 := d nat. Extraction d4. (* type d4 = nat d *) Definition d5 := (fun x:d Type => 0) Type. Extraction d5. (* let d5 = O *) Definition d6 (x:d Type) := x. Extraction d6. (* type 'x d6 = 'x *) Definition test8 := (fun (X:Type) (x:X) => x) Set nat. Extraction test8. (* type test8 = nat *) Definition test9 := let t := nat in id Set t. Extraction test9. (* type test9 = nat *) Definition test10 := (fun (X:Type) (x:X) => 0) Type Type. Extraction test10. (* let test10 = O *) Definition test11 := let n := 0 in let p := S n in S p. Extraction test11. (* let test11 = S (S O) *) Definition test12 := forall x:forall X:Type, X -> X, x Type Type. Extraction test12. (* type test12 = (__ -> __ -> __) -> __ *) Definition test13 := match @left True True I with | left x => 1 | right x => 0 end. Extraction test13. (* let test13 = S O *) (** example with more arguments that given by the type *) Definition test19 := nat_rec (fun n:nat => nat -> nat) (fun n:nat => 0) (fun (n:nat) (f:nat -> nat) => f) 0 0. Extraction test19. (* let test19 = let rec f = function | O -> (fun n0 -> O) | S n0 -> f n0 in f O O *) (** casts *) Definition test20 := True:Type. Extraction test20. (* type test20 = __ *) (** Simple inductive type and recursor. *) Extraction nat. (* type nat = | O | S of nat *) Extraction sumbool_rect. (* let sumbool_rect f f0 = function | Left -> f __ | Right -> f0 __ *) (** Less simple inductive type. *) Inductive c (x:nat) : nat -> Set := | refl : c x x | trans : forall y z:nat, c x y -> y <= z -> c x z. Extraction c. (* type c = | Refl | Trans of nat * nat * c *) Definition Ensemble (U:Type) := U -> Prop. Definition Empty_set (U:Type) (x:U) := False. Definition Add (U:Type) (A:Ensemble U) (x y:U) := A y \/ x = y. Inductive Finite (U:Type) : Ensemble U -> Type := | Empty_is_finite : Finite U (Empty_set U) | Union_is_finite : forall A:Ensemble U, Finite U A -> forall x:U, ~ A x -> Finite U (Add U A x). Extraction Finite. (* type 'u finite = | Empty_is_finite | Union_is_finite of 'u finite * 'u *) (** Mutual Inductive *) Inductive tree : Set := Node : nat -> forest -> tree with forest : Set := | Leaf : nat -> forest | Cons : tree -> forest -> forest. Extraction tree. (* type tree = | Node of nat * forest and forest = | Leaf of nat | Cons of tree * forest *) Fixpoint tree_size (t:tree) : nat := match t with | Node a f => S (forest_size f) end with forest_size (f:forest) : nat := match f with | Leaf b => 1 | Cons t f' => tree_size t + forest_size f' end. Extraction tree_size. (* let rec tree_size = function | Node (a, f) -> S (forest_size f) and forest_size = function | Leaf b -> S O | Cons (t, f') -> plus (tree_size t) (forest_size f') *) (** Eta-expansions of inductive constructor *) Inductive titi : Set := tata : nat -> nat -> nat -> nat -> titi. Definition test14 := tata 0. Extraction test14. (* let test14 x x0 x1 = Tata (O, x, x0, x1) *) Definition test15 := tata 0 1. Extraction test15. (* let test15 x x0 = Tata (O, (S O), x, x0) *) Inductive eta : Type := eta_c : nat -> Prop -> nat -> Prop -> eta. Extraction eta_c. (* type eta = | Eta_c of nat * nat *) Definition test16 := eta_c 0. Extraction test16. (* let test16 x = Eta_c (O, x) *) Definition test17 := eta_c 0 True. Extraction test17. (* let test17 x = Eta_c (O, x) *) Definition test18 := eta_c 0 True 0. Extraction test18. (* let test18 _ = Eta_c (O, O) *) (** Example of singleton inductive type *) Inductive bidon (A:Prop) (B:Type) : Type := tb : forall (x:A) (y:B), bidon A B. Definition fbidon (A B:Type) (f:A -> B -> bidon True nat) (x:A) (y:B) := f x y. Extraction bidon. (* type 'b bidon = 'b *) Extraction tb. (* tb : singleton inductive constructor *) Extraction fbidon. (* let fbidon f x y = f x y *) Definition fbidon2 := fbidon True nat (tb True nat). Extraction fbidon2. (* let fbidon2 y = y *) Extraction NoInline fbidon. Extraction fbidon2. (* let fbidon2 y = fbidon (fun _ x -> x) __ y *) (* NB: first argument of fbidon2 has type [True], so it disappears. *) (** mutual inductive on many sorts *) Inductive test_0 : Prop := ctest0 : test_0 with test_1 : Set := ctest1 : test_0 -> test_1. Extraction test_0. (* test0 : logical inductive *) Extraction test_1. (* type test1 = | Ctest1 *) (** logical singleton *) Extraction eq. (* eq : logical inductive *) Extraction eq_rect. (* let eq_rect x f y = f *) (** No more propagation of type parameters. Obj.t instead. *) Inductive tp1 : Type := T : forall (C:Set) (c:C), tp2 -> tp1 with tp2 : Type := T' : tp1 -> tp2. Extraction tp1. (* type tp1 = | T of __ * tp2 and tp2 = | T' of tp1 *) Inductive tp1bis : Type := Tbis : tp2bis -> tp1bis with tp2bis : Type := T'bis : forall (C:Set) (c:C), tp1bis -> tp2bis. Extraction tp1bis. (* type tp1bis = | Tbis of tp2bis and tp2bis = | T'bis of __ * tp1bis *) (** Strange inductive type. *) Inductive Truc : Set -> Type := | chose : forall A:Set, Truc A | machin : forall A:Set, A -> Truc bool -> Truc A. Extraction Truc. (* type 'x truc = | Chose | Machin of 'x * bool truc *) (** Dependant type over Type *) Definition test24 := sigT (fun a:Set => option a). Extraction test24. (* type test24 = (__, __ option) sigT *) (** Coq term non strongly-normalizable after extraction *) Require Import Gt. Definition loop (Ax:Acc gt 0) := (fix F (a:nat) (b:Acc gt a) {struct b} : nat := F (S a) (Acc_inv b (S a) (gt_Sn_n a))) 0 Ax. Extraction loop. (* let loop _ = let rec f a = f (S a) in f O *) (*** EXAMPLES NEEDING OBJ.MAGIC *) (** False conversion of type: *) Lemma oups : forall H:nat = list nat, nat -> nat. intros. generalize H0; intros. rewrite H in H1. case H1. exact H0. intros. exact n. Defined. Extraction oups. (* let oups h0 = match Obj.magic h0 with | Nil -> h0 | Cons0 (n, l) -> n *) (** hybrids *) Definition horibilis (b:bool) := if b as b return (if b then Type else nat) then Set else 0. Extraction horibilis. (* let horibilis = function | True -> Obj.magic __ | False -> Obj.magic O *) Definition PropSet (b:bool) := if b then Prop else Set. Extraction PropSet. (* type propSet = __ *) Definition natbool (b:bool) := if b then nat else bool. Extraction natbool. (* type natbool = __ *) Definition zerotrue (b:bool) := if b as x return natbool x then 0 else true. Extraction zerotrue. (* let zerotrue = function | True -> Obj.magic O | False -> Obj.magic True *) Definition natProp (b:bool) := if b return Type then nat else Prop. Definition natTrue (b:bool) := if b return Type then nat else True. Definition zeroTrue (b:bool) := if b as x return natProp x then 0 else True. Extraction zeroTrue. (* let zeroTrue = function | True -> Obj.magic O | False -> Obj.magic __ *) Definition natTrue2 (b:bool) := if b return Type then nat else True. Definition zeroprop (b:bool) := if b as x return natTrue x then 0 else I. Extraction zeroprop. (* let zeroprop = function | True -> Obj.magic O | False -> Obj.magic __ *) (** polymorphic f applied several times *) Definition test21 := (id nat 0, id bool true). Extraction test21. (* let test21 = Pair ((id O), (id True)) *) (** ok *) Definition test22 := (fun f:forall X:Type, X -> X => (f nat 0, f bool true)) (fun (X:Type) (x:X) => x). Extraction test22. (* let test22 = let f = fun x -> x in Pair ((f O), (f True)) *) (* still ok via optim beta -> let *) Definition test23 (f:forall X:Type, X -> X) := (f nat 0, f bool true). Extraction test23. (* let test23 f = Pair ((Obj.magic f __ O), (Obj.magic f __ True)) *) (* problem: fun f -> (f 0, f true) not legal in ocaml *) (* solution: magic ... *) (** Dummy constant __ can be applied.... *) Definition f (X:Type) (x:nat -> X) (y:X -> bool) : bool := y (x 0). Extraction f. (* let f x y = y (x O) *) Definition f_prop := f (0 = 0) (fun _ => refl_equal 0) (fun _ => true). Extraction NoInline f. Extraction f_prop. (* let f_prop = f (Obj.magic __) (fun _ -> True) *) Definition f_arity := f Set (fun _:nat => nat) (fun _:Set => true). Extraction f_arity. (* let f_arity = f (Obj.magic __) (fun _ -> True) *) Definition f_normal := f nat (fun x => x) (fun x => match x with | O => true | _ => false end). Extraction f_normal. (* let f_normal = f (fun x -> x) (fun x -> match x with | O -> True | S n -> False) *) (* inductive with magic needed *) Inductive Boite : Set := boite : forall b:bool, (if b then nat else (nat * nat)%type) -> Boite. Extraction Boite. (* type boite = | Boite of bool * __ *) Definition boite1 := boite true 0. Extraction boite1. (* let boite1 = Boite (True, (Obj.magic O)) *) Definition boite2 := boite false (0, 0). Extraction boite2. (* let boite2 = Boite (False, (Obj.magic (Pair (O, O)))) *) Definition test_boite (B:Boite) := match B return nat with | boite true n => n | boite false n => fst n + snd n end. Extraction test_boite. (* let test_boite = function | Boite (b0, n) -> (match b0 with | True -> Obj.magic n | False -> plus (fst (Obj.magic n)) (snd (Obj.magic n))) *) (* singleton inductive with magic needed *) Inductive Box : Type := box : forall A:Set, A -> Box. Extraction Box. (* type box = __ *) Definition box1 := box nat 0. Extraction box1. (* let box1 = Obj.magic O *) (* applied constant, magic needed *) Definition idzarb (b:bool) (x:if b then nat else bool) := x. Definition zarb := idzarb true 0. Extraction NoInline idzarb. Extraction zarb. (* let zarb = Obj.magic idzarb True (Obj.magic O) *) (** function of variable arity. *) (** Fun n = nat -> nat -> ... -> nat *) Fixpoint Fun (n:nat) : Set := match n with | O => nat | S n => nat -> Fun n end. Fixpoint Const (k n:nat) {struct n} : Fun n := match n as x return Fun x with | O => k | S n => fun p:nat => Const k n end. Fixpoint proj (k n:nat) {struct n} : Fun n := match n as x return Fun x with | O => 0 (* ou assert false ....*) | S n => match k with | O => fun x => Const x n | S k => fun x => proj k n end end. Definition test_proj := proj 2 4 0 1 2 3. Eval compute in test_proj. Recursive Extraction test_proj. (*** TO SUM UP: ***) (* Was previously producing a "test_extraction.ml" *) Recursive Extraction idnat id id' test2 test3 test4 test5 test6 test7 d d2 d3 d4 d5 d6 test8 id id' test9 test10 test11 test12 test13 test19 test20 nat sumbool_rect c Finite tree tree_size test14 test15 eta_c test16 test17 test18 bidon tb fbidon fbidon2 fbidon2 test_0 test_1 eq eq_rect tp1 tp1bis Truc oups test24 loop horibilis PropSet natbool zerotrue zeroTrue zeroprop test21 test22 test23 f f_prop f_arity f_normal Boite boite1 boite2 test_boite Box box1 zarb test_proj. Extraction Language Haskell. (* Was previously producing a "Test_extraction.hs" *) Recursive Extraction idnat id id' test2 test3 test4 test5 test6 test7 d d2 d3 d4 d5 d6 test8 id id' test9 test10 test11 test12 test13 test19 test20 nat sumbool_rect c Finite tree tree_size test14 test15 eta_c test16 test17 test18 bidon tb fbidon fbidon2 fbidon2 test_0 test_1 eq eq_rect tp1 tp1bis Truc oups test24 loop horibilis PropSet natbool zerotrue zeroTrue zeroprop test21 test22 test23 f f_prop f_arity f_normal Boite boite1 boite2 test_boite Box box1 zarb test_proj. Extraction Language Scheme. (* Was previously producing a "test_extraction.scm" *) Recursive Extraction idnat id id' test2 test3 test4 test5 test6 test7 d d2 d3 d4 d5 d6 test8 id id' test9 test10 test11 test12 test13 test19 test20 nat sumbool_rect c Finite tree tree_size test14 test15 eta_c test16 test17 test18 bidon tb fbidon fbidon2 fbidon2 test_0 test_1 eq eq_rect tp1 tp1bis Truc oups test24 loop horibilis PropSet natbool zerotrue zeroTrue zeroprop test21 test22 test23 f f_prop f_arity f_normal Boite boite1 boite2 test_boite Box box1 zarb test_proj. (*** Finally, a test more focused on everyday's life situations ***) Require Import ZArith. Recursive Extraction two_or_two_plus_one Zdiv_eucl_exist. coq-8.4pl4/test-suite/success/Case5.v0000644000175000017500000000055512326224777016545 0ustar stephsteph Parameter ff : forall n m : nat, n <> m -> S n <> S m. Parameter discr_r : forall n : nat, 0 <> S n. Parameter discr_l : forall n : nat, S n <> 0. Type (fun n : nat => match n return (n = 0 \/ n <> 0) with | O => or_introl (0 <> 0) (refl_equal 0) | S O => or_intror (1 = 0) (discr_l 0) | S (S x) => or_intror (S (S x) = 0) (discr_l (S x)) end). coq-8.4pl4/test-suite/success/setoid_ring_module.v0000644000175000017500000000163212326224777021455 0ustar stephstephRequire Import Setoid Ring Ring_theory. Module abs_ring. Parameters (Coef:Set)(c0 c1 : Coef) (cadd cmul csub: Coef -> Coef -> Coef) (copp : Coef -> Coef) (ceq : Coef -> Coef -> Prop) (ceq_sym : forall x y, ceq x y -> ceq y x) (ceq_trans : forall x y z, ceq x y -> ceq y z -> ceq x z) (ceq_refl : forall x, ceq x x). Add Relation Coef ceq reflexivity proved by ceq_refl symmetry proved by ceq_sym transitivity proved by ceq_trans as ceq_relation. Add Morphism cadd with signature ceq ==> ceq ==> ceq as cadd_Morphism. Admitted. Add Morphism cmul with signature ceq ==> ceq ==> ceq as cmul_Morphism. Admitted. Add Morphism copp with signature ceq ==> ceq as copp_Morphism. Admitted. Definition cRth : ring_theory c0 c1 cadd cmul csub copp ceq. Admitted. Add Ring CoefRing : cRth. End abs_ring. Import abs_ring. Theorem check_setoid_ring_modules : forall a b, ceq (cadd a b) (cadd b a). intros. ring. Qed. coq-8.4pl4/test-suite/success/Conjecture.v0000644000175000017500000000034712326224777017705 0ustar stephsteph(* Check keywords Conjecture and Admitted are recognized *) Conjecture c : forall n : nat, n = 0. Check c. Theorem d : forall n : nat, n = 0. Proof. induction n. reflexivity. assert (H : False). 2: destruct H. Admitted. coq-8.4pl4/test-suite/success/AdvancedTypeClasses.v0000644000175000017500000000431512326224777021470 0ustar stephstephGeneralizable All Variables. Open Scope type_scope. Section type_reification. Inductive term :Type := Fun : term -> term -> term | Prod : term -> term -> term | Bool : term | SET :term | PROP :term | TYPE :term | Var : Type -> term. Fixpoint interp (t:term) := match t with Bool => bool | SET => Set | PROP => Prop | TYPE => Type | Fun a b => interp a -> interp b | Prod a b => interp a * interp b | Var x => x end. Class interp_pair (abs : Type) := { repr : term; link: abs = interp repr }. Implicit Arguments repr [[interp_pair]]. Implicit Arguments link [[interp_pair]]. Lemma prod_interp `{interp_pair a, interp_pair b} : a * b = interp (Prod (repr a) (repr b)). simpl. intros. rewrite <- link. rewrite <- (link b). reflexivity. Qed. Lemma fun_interp :forall `{interp_pair a, interp_pair b}, (a -> b) = interp (Fun (repr a) (repr b)). simpl. intros. rewrite <- link. rewrite <- (link b). reflexivity. Qed. Coercion repr : interp_pair >-> term. Definition abs `{interp_pair a} : Type := a. Coercion abs : interp_pair >-> Sortclass. Lemma fun_interp' :forall `{ia : interp_pair, ib : interp_pair}, (ia -> ib) = interp (Fun ia ib). simpl. intros a ia b ib. rewrite <- link. rewrite <- (link b). reflexivity. Qed. Instance ProdCan `(interp_pair a, interp_pair b) : interp_pair (a * b) := { repr := Prod (repr a) (repr b) ; link := prod_interp }. Instance FunCan `(interp_pair a, interp_pair b) : interp_pair (a -> b) := { link := fun_interp }. Instance BoolCan : interp_pair bool := { repr := Bool ; link := refl_equal _ }. Instance VarCan x : interp_pair x | 10 := { repr := Var x ; link := refl_equal _ }. Instance SetCan : interp_pair Set := { repr := SET ; link := refl_equal _ }. Instance PropCan : interp_pair Prop := { repr := PROP ; link := refl_equal _ }. Instance TypeCan : interp_pair Type := { repr := TYPE ; link := refl_equal _ }. (* Print Canonical Projections. *) Variable A:Type. Variable Inhabited: term -> Prop. Variable Inhabited_correct: forall `{interp_pair p}, Inhabited (repr p) -> p. Lemma L : Prop * A -> bool * (Type -> Set) . apply (Inhabited_correct _ _). change (Inhabited (Fun (Prod PROP (Var A)) (Prod Bool (Fun TYPE SET)))). Admitted. End type_reification. coq-8.4pl4/test-suite/success/Case1.v0000644000175000017500000000051712326224777016537 0ustar stephsteph(* Testing eta-expansion of elimination predicate *) Section NATIND2. Variable P : nat -> Type. Variable H0 : P 0. Variable H1 : P 1. Variable H2 : forall n : nat, P n -> P (S (S n)). Fixpoint nat_ind2 (n : nat) : P n := match n as x return (P x) with | O => H0 | S O => H1 | S (S n) => H2 n (nat_ind2 n) end. End NATIND2. coq-8.4pl4/test-suite/success/RecTutorial.v0000644000175000017500000006107212326224777020043 0ustar stephstephModule Type LocalNat. Inductive nat : Set := | O : nat | S : nat->nat. Check nat. Check O. Check S. End LocalNat. Print nat. Print le. Theorem zero_leq_three: 0 <= 3. Proof. constructor 2. constructor 2. constructor 2. constructor 1. Qed. Print zero_leq_three. Lemma zero_leq_three': 0 <= 3. repeat constructor. Qed. Lemma zero_lt_three : 0 < 3. Proof. unfold lt. repeat constructor. Qed. Require Import List. Print list. Check list. Check (nil (A:=nat)). Check (nil (A:= nat -> nat)). Check (fun A: Set => (cons (A:=A))). Check (cons 3 (cons 2 nil)). Require Import Bvector. Print Vector.t. Check (Vector.nil nat). Check (fun (A:Set)(a:A)=> Vector.cons _ a _ (Vector.nil _)). Check (Vector.cons _ 5 _ (Vector.cons _ 3 _ (Vector.nil _))). Lemma eq_3_3 : 2 + 1 = 3. Proof. reflexivity. Qed. Print eq_3_3. Lemma eq_proof_proof : refl_equal (2*6) = refl_equal (3*4). Proof. reflexivity. Qed. Print eq_proof_proof. Lemma eq_lt_le : ( 2 < 4) = (3 <= 4). Proof. reflexivity. Qed. Lemma eq_nat_nat : nat = nat. Proof. reflexivity. Qed. Lemma eq_Set_Set : Set = Set. Proof. reflexivity. Qed. Lemma eq_Type_Type : Type = Type. Proof. reflexivity. Qed. Check (2 + 1 = 3). Check (Type = Type). Goal Type = Type. reflexivity. Qed. Print or. Print and. Print sumbool. Print ex. Require Import ZArith. Require Import Compare_dec. Check le_lt_dec. Definition max (n p :nat) := match le_lt_dec n p with | left _ => p | right _ => n end. Theorem le_max : forall n p, n <= p -> max n p = p. Proof. intros n p ; unfold max ; case (le_lt_dec n p); simpl. trivial. intros; absurd (p < p); eauto with arith. Qed. Extraction max. Inductive tree(A:Set) : Set := node : A -> forest A -> tree A with forest (A: Set) : Set := nochild : forest A | addchild : tree A -> forest A -> forest A. Inductive even : nat->Prop := evenO : even O | evenS : forall n, odd n -> even (S n) with odd : nat->Prop := oddS : forall n, even n -> odd (S n). Lemma odd_49 : odd (7 * 7). simpl; repeat constructor. Qed. Definition nat_case := fun (Q : Type)(g0 : Q)(g1 : nat -> Q)(n:nat) => match n return Q with | 0 => g0 | S p => g1 p end. Eval simpl in (nat_case nat 0 (fun p => p) 34). Eval simpl in (fun g0 g1 => nat_case nat g0 g1 34). Eval simpl in (fun g0 g1 => nat_case nat g0 g1 0). Definition pred (n:nat) := match n with O => O | S m => m end. Eval simpl in pred 56. Eval simpl in pred 0. Eval simpl in fun p => pred (S p). Definition xorb (b1 b2:bool) := match b1, b2 with | false, true => true | true, false => true | _ , _ => false end. Definition pred_spec (n:nat) := {m:nat | n=0 /\ m=0 \/ n = S m}. Definition predecessor : forall n:nat, pred_spec n. intro n;case n. unfold pred_spec;exists 0;auto. unfold pred_spec; intro n0;exists n0; auto. Defined. Print predecessor. Extraction predecessor. Theorem nat_expand : forall n:nat, n = match n with 0 => 0 | S p => S p end. intro n;case n;simpl;auto. Qed. Check (fun p:False => match p return 2=3 with end). Theorem fromFalse : False -> 0=1. intro absurd. contradiction. Qed. Section equality_elimination. Variables (A: Type) (a b : A) (p : a = b) (Q : A -> Type). Check (fun H : Q a => match p in (eq _ y) return Q y with refl_equal => H end). End equality_elimination. Theorem trans : forall n m p:nat, n=m -> m=p -> n=p. Proof. intros n m p eqnm. case eqnm. trivial. Qed. Lemma Rw : forall x y: nat, y = y * x -> y * x * x = y. intros x y e; do 2 rewrite <- e. reflexivity. Qed. Require Import Arith. Check mult_1_l. (* mult_1_l : forall n : nat, 1 * n = n *) Check mult_plus_distr_r. (* mult_plus_distr_r : forall n m p : nat, (n + m) * p = n * p + m * p *) Lemma mult_distr_S : forall n p : nat, n * p + p = (S n)* p. simpl;auto with arith. Qed. Lemma four_n : forall n:nat, n+n+n+n = 4*n. intro n;rewrite <- (mult_1_l n). Undo. intro n; pattern n at 1. rewrite <- mult_1_l. repeat rewrite mult_distr_S. trivial. Qed. Section Le_case_analysis. Variables (n p : nat) (H : n <= p) (Q : nat -> Prop) (H0 : Q n) (HS : forall m, n <= m -> Q (S m)). Check ( match H in (_ <= q) return (Q q) with | le_n => H0 | le_S m Hm => HS m Hm end ). End Le_case_analysis. Lemma predecessor_of_positive : forall n, 1 <= n -> exists p:nat, n = S p. Proof. intros n H; case H. exists 0; trivial. intros m Hm; exists m;trivial. Qed. Definition Vtail_total (A : Set) (n : nat) (v : Vector.t A n) : Vector.t A (pred n):= match v in (Vector.t _ n0) return (Vector.t A (pred n0)) with | Vector.nil => Vector.nil A | Vector.cons _ n0 v0 => v0 end. Definition Vtail' (A:Set)(n:nat)(v:Vector.t A n) : Vector.t A (pred n). case v. simpl. exact (Vector.nil A). simpl. auto. Defined. (* Inductive Lambda : Set := lambda : (Lambda -> False) -> Lambda. Error: Non strictly positive occurrence of "Lambda" in "(Lambda -> False) -> Lambda" *) Section Paradox. Variable Lambda : Set. Variable lambda : (Lambda -> False) ->Lambda. Variable matchL : Lambda -> forall Q:Prop, ((Lambda ->False) -> Q) -> Q. (* understand matchL Q l (fun h : Lambda -> False => t) as match l return Q with lambda h => t end *) Definition application (f x: Lambda) :False := matchL f False (fun h => h x). Definition Delta : Lambda := lambda (fun x : Lambda => application x x). Definition loop : False := application Delta Delta. Theorem two_is_three : 2 = 3. Proof. elim loop. Qed. End Paradox. Require Import ZArith. Inductive itree : Set := | ileaf : itree | inode : Z-> (nat -> itree) -> itree. Definition isingle l := inode l (fun i => ileaf). Definition t1 := inode 0 (fun n => isingle (Z.of_nat (2*n))). Definition t2 := inode 0 (fun n : nat => inode (Z.of_nat n) (fun p => isingle (Z.of_nat (n*p)))). Inductive itree_le : itree-> itree -> Prop := | le_leaf : forall t, itree_le ileaf t | le_node : forall l l' s s', Z.le l l' -> (forall i, exists j:nat, itree_le (s i) (s' j)) -> itree_le (inode l s) (inode l' s'). Theorem itree_le_trans : forall t t', itree_le t t' -> forall t'', itree_le t' t'' -> itree_le t t''. induction t. constructor 1. intros t'; case t'. inversion 1. intros z0 i0 H0. intro t'';case t''. inversion 1. intros. inversion_clear H1. constructor 2. inversion_clear H0;eauto with zarith. inversion_clear H0. intro i2; case (H4 i2). intros. generalize (H i2 _ H0). intros. case (H3 x);intros. generalize (H5 _ H6). exists x0;auto. Qed. Inductive itree_le' : itree-> itree -> Prop := | le_leaf' : forall t, itree_le' ileaf t | le_node' : forall l l' s s' g, Z.le l l' -> (forall i, itree_le' (s i) (s' (g i))) -> itree_le' (inode l s) (inode l' s'). Lemma t1_le_t2 : itree_le t1 t2. unfold t1, t2. constructor. auto with zarith. intro i; exists (2 * i). unfold isingle. constructor. auto with zarith. exists i;constructor. Qed. Lemma t1_le'_t2 : itree_le' t1 t2. unfold t1, t2. constructor 2 with (fun i : nat => 2 * i). auto with zarith. unfold isingle; intro i ; constructor 2 with (fun i :nat => i). auto with zarith. constructor . Qed. Require Import List. Inductive ltree (A:Set) : Set := lnode : A -> list (ltree A) -> ltree A. Inductive prop : Prop := prop_intro : Prop -> prop. Lemma prop_inject: prop. Proof prop_intro prop. Inductive ex_Prop (P : Prop -> Prop) : Prop := exP_intro : forall X : Prop, P X -> ex_Prop P. Lemma ex_Prop_inhabitant : ex_Prop (fun P => P -> P). Proof. exists (ex_Prop (fun P => P -> P)). trivial. Qed. Fail Check (fun (P:Prop->Prop)(p: ex_Prop P) => match p with exP_intro X HX => X end). (* Error: Incorrect elimination of "p" in the inductive type "ex_Prop", the return type has sort "Type" while it should be "Prop" Elimination of an inductive object of sort "Prop" is not allowed on a predicate in sort "Type" because proofs can be eliminated only to build proofs *) Fail Check (match prop_inject with (prop_intro p) => p end). (* Error: Incorrect elimination of "prop_inject" in the inductive type "prop", the return type has sort "Type" while it should be "Prop" Elimination of an inductive object of sort "Prop" is not allowed on a predicate in sort "Type" because proofs can be eliminated only to build proofs *) Print prop_inject. (* prop_inject = prop_inject = prop_intro prop : prop *) Inductive typ : Type := typ_intro : Type -> typ. Definition typ_inject: typ. split. exact typ. Fail Defined. (* Error: Universe Inconsistency. *) Abort. Fail Inductive aSet : Set := aSet_intro: Set -> aSet. (* User error: Large non-propositional inductive types must be in Type *) Inductive ex_Set (P : Set -> Prop) : Type := exS_intro : forall X : Set, P X -> ex_Set P. Module Type Version1. Inductive comes_from_the_left (P Q:Prop): P \/ Q -> Prop := c1 : forall p, comes_from_the_left P Q (or_introl (A:=P) Q p). Goal (comes_from_the_left _ _ (or_introl True I)). split. Qed. Goal ~(comes_from_the_left _ _ (or_intror True I)). red;inversion 1. (* discriminate H0. *) Abort. End Version1. Fail Definition comes_from_the_left (P Q:Prop)(H:P \/ Q): Prop := match H with | or_introl p => True | or_intror q => False end. (* Error: Incorrect elimination of "H" in the inductive type "or", the return type has sort "Type" while it should be "Prop" Elimination of an inductive object of sort "Prop" is not allowed on a predicate in sort "Type" because proofs can be eliminated only to build proofs *) Definition comes_from_the_left_sumbool (P Q:Prop)(x:{P}+{Q}): Prop := match x with | left p => True | right q => False end. Close Scope Z_scope. Theorem S_is_not_O : forall n, S n <> 0. Definition Is_zero (x:nat):= match x with | 0 => True | _ => False end. Lemma O_is_zero : forall m, m = 0 -> Is_zero m. Proof. intros m H; subst m. (* ============================ Is_zero 0 *) simpl;trivial. Qed. red; intros n Hn. apply O_is_zero with (m := S n). assumption. Qed. Theorem disc2 : forall n, S (S n) <> 1. Proof. intros n Hn; discriminate. Qed. Theorem disc3 : forall n, S (S n) = 0 -> forall Q:Prop, Q. Proof. intros n Hn Q. discriminate. Qed. Theorem inj_succ : forall n m, S n = S m -> n = m. Proof. Lemma inj_pred : forall n m, n = m -> pred n = pred m. Proof. intros n m eq_n_m. rewrite eq_n_m. trivial. Qed. intros n m eq_Sn_Sm. apply inj_pred with (n:= S n) (m := S m); assumption. Qed. Lemma list_inject : forall (A:Set)(a b :A)(l l':list A), a :: b :: l = b :: a :: l' -> a = b /\ l = l'. Proof. intros A a b l l' e. injection e. auto. Qed. Theorem not_le_Sn_0 : forall n:nat, ~ (S n <= 0). Proof. red; intros n H. case H. Undo. Lemma not_le_Sn_0_with_constraints : forall n p , S n <= p -> p = 0 -> False. Proof. intros n p H; case H ; intros; discriminate. Qed. eapply not_le_Sn_0_with_constraints; eauto. Qed. Theorem not_le_Sn_0' : forall n:nat, ~ (S n <= 0). Proof. red; intros n H ; inversion H. Qed. Derive Inversion le_Sn_0_inv with (forall n :nat, S n <= 0). Check le_Sn_0_inv. Theorem le_Sn_0'' : forall n p : nat, ~ S n <= 0 . Proof. intros n p H; inversion H using le_Sn_0_inv. Qed. Derive Inversion_clear le_Sn_0_inv' with (forall n :nat, S n <= 0). Check le_Sn_0_inv'. Theorem le_reverse_rules : forall n m:nat, n <= m -> n = m \/ exists p, n <= p /\ m = S p. Proof. intros n m H; inversion H. left;trivial. right; exists m0; split; trivial. Restart. intros n m H; inversion_clear H. left;trivial. right; exists m0; split; trivial. Qed. Inductive ArithExp : Set := Zero : ArithExp | Succ : ArithExp -> ArithExp | Plus : ArithExp -> ArithExp -> ArithExp. Inductive RewriteRel : ArithExp -> ArithExp -> Prop := RewSucc : forall e1 e2 :ArithExp, RewriteRel e1 e2 -> RewriteRel (Succ e1) (Succ e2) | RewPlus0 : forall e:ArithExp, RewriteRel (Plus Zero e) e | RewPlusS : forall e1 e2:ArithExp, RewriteRel e1 e2 -> RewriteRel (Plus (Succ e1) e2) (Succ (Plus e1 e2)). Fixpoint plus (n p:nat) {struct n} : nat := match n with | 0 => p | S m => S (plus m p) end. Fixpoint plus' (n p:nat) {struct p} : nat := match p with | 0 => n | S q => S (plus' n q) end. Fixpoint plus'' (n p:nat) {struct n} : nat := match n with | 0 => p | S m => plus'' m (S p) end. Module Type even_test_v1. Fixpoint even_test (n:nat) : bool := match n with 0 => true | 1 => false | S (S p) => even_test p end. End even_test_v1. Module even_test_v2. Fixpoint even_test (n:nat) : bool := match n with | 0 => true | S p => odd_test p end with odd_test (n:nat) : bool := match n with | 0 => false | S p => even_test p end. Eval simpl in even_test. Eval simpl in (fun x : nat => even_test x). Eval simpl in (fun x : nat => plus 5 x). Eval simpl in (fun x : nat => even_test (plus 5 x)). Eval simpl in (fun x : nat => even_test (plus x 5)). End even_test_v2. Section Principle_of_Induction. Variable P : nat -> Prop. Hypothesis base_case : P 0. Hypothesis inductive_step : forall n:nat, P n -> P (S n). Fixpoint nat_ind (n:nat) : (P n) := match n return P n with | 0 => base_case | S m => inductive_step m (nat_ind m) end. End Principle_of_Induction. Scheme Even_induction := Minimality for even Sort Prop with Odd_induction := Minimality for odd Sort Prop. Theorem even_plus_four : forall n:nat, even n -> even (4+n). Proof. intros n H. elim H using Even_induction with (P0 := fun n => odd (4+n)); simpl;repeat constructor;assumption. Qed. Section Principle_of_Double_Induction. Variable P : nat -> nat ->Prop. Hypothesis base_case1 : forall x:nat, P 0 x. Hypothesis base_case2 : forall x:nat, P (S x) 0. Hypothesis inductive_step : forall n m:nat, P n m -> P (S n) (S m). Fixpoint nat_double_ind (n m:nat){struct n} : P n m := match n, m return P n m with | 0 , x => base_case1 x | (S x), 0 => base_case2 x | (S x), (S y) => inductive_step x y (nat_double_ind x y) end. End Principle_of_Double_Induction. Section Principle_of_Double_Recursion. Variable P : nat -> nat -> Set. Hypothesis base_case1 : forall x:nat, P 0 x. Hypothesis base_case2 : forall x:nat, P (S x) 0. Hypothesis inductive_step : forall n m:nat, P n m -> P (S n) (S m). Fixpoint nat_double_rec (n m:nat){struct n} : P n m := match n, m return P n m with | 0 , x => base_case1 x | (S x), 0 => base_case2 x | (S x), (S y) => inductive_step x y (nat_double_rec x y) end. End Principle_of_Double_Recursion. Definition min : nat -> nat -> nat := nat_double_rec (fun (x y:nat) => nat) (fun (x:nat) => 0) (fun (y:nat) => 0) (fun (x y r:nat) => S r). Eval compute in (min 5 8). Eval compute in (min 8 5). Lemma not_circular : forall n:nat, n <> S n. Proof. intro n. apply nat_ind with (P:= fun n => n <> S n). discriminate. red; intros n0 Hn0 eqn0Sn0;injection eqn0Sn0;trivial. Qed. Definition eq_nat_dec : forall n p:nat , {n=p}+{n <> p}. Proof. intros n p. apply nat_double_rec with (P:= fun (n q:nat) => {q=p}+{q <> p}). Undo. pattern p,n. elim n using nat_double_rec. destruct x; auto. destruct x; auto. intros n0 m H; case H. intro eq; rewrite eq ; auto. intro neg; right; red ; injection 1; auto. Defined. Definition eq_nat_dec' : forall n p:nat, {n=p}+{n <> p}. decide equality. Defined. Print Acc. Require Import Minus. Fail Fixpoint div (x y:nat){struct x}: nat := if eq_nat_dec x 0 then 0 else if eq_nat_dec y 0 then x else S (div (x-y) y). (* Error: Recursive definition of div is ill-formed. In environment div : nat -> nat -> nat x : nat y : nat _ : x <> 0 _ : y <> 0 Recursive call to div has principal argument equal to "x - y" instead of a subterm of x *) Lemma minus_smaller_S: forall x y:nat, x - y < S x. Proof. intros x y; pattern y, x; elim x using nat_double_ind. destruct x0; auto with arith. simpl; auto with arith. simpl; auto with arith. Qed. Lemma minus_smaller_positive : forall x y:nat, x <>0 -> y <> 0 -> x - y < x. Proof. destruct x; destruct y; ( simpl;intros; apply minus_smaller_S || intros; absurd (0=0); auto). Qed. Definition minus_decrease : forall x y:nat, Acc lt x -> x <> 0 -> y <> 0 -> Acc lt (x-y). Proof. intros x y H; case H. intros Hz posz posy. apply Hz; apply minus_smaller_positive; assumption. Defined. Print minus_decrease. Fixpoint div_aux (x y:nat)(H: Acc lt x):nat. refine (if eq_nat_dec x 0 then 0 else if eq_nat_dec y 0 then y else div_aux (x-y) y _). apply (minus_decrease x y H);assumption. Defined. Print div_aux. (* div_aux = (fix div_aux (x y : nat) (H : Acc lt x) {struct H} : nat := match eq_nat_dec x 0 with | left _ => 0 | right _ => match eq_nat_dec y 0 with | left _ => y | right _0 => div_aux (x - y) y (minus_decrease x y H _ _0) end end) : forall x : nat, nat -> Acc lt x -> nat *) Require Import Wf_nat. Definition div x y := div_aux x y (lt_wf x). Extraction div. (* let div x y = div_aux x y *) Extraction div_aux. (* let rec div_aux x y = match eq_nat_dec x O with | Left -> O | Right -> (match eq_nat_dec y O with | Left -> y | Right -> div_aux (minus x y) y) *) Lemma vector0_is_vnil : forall (A:Set)(v:Vector.t A 0), v = Vector.nil A. Proof. intros A v;inversion v. Abort. Fail Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n), n= 0 -> v = Vector.nil A. (* Error: In environment A : Set n : nat v : Vector.t A n The term "[]" has type "Vector.t A 0" while it is expected to have type "Vector.t A n" *) Require Import JMeq. Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n), n= 0 -> JMeq v (Vector.nil A). Proof. destruct v. auto. intro; discriminate. Qed. Lemma vector0_is_vnil : forall (A:Set)(v:Vector.t A 0), v = Vector.nil A. Proof. intros a v;apply JMeq_eq. apply vector0_is_vnil_aux. trivial. Qed. Implicit Arguments Vector.cons [A n]. Implicit Arguments Vector.nil [A]. Implicit Arguments Vector.hd [A n]. Implicit Arguments Vector.tl [A n]. Definition Vid : forall (A : Type)(n:nat), Vector.t A n -> Vector.t A n. Proof. destruct n; intro v. exact Vector.nil. exact (Vector.cons (Vector.hd v) (Vector.tl v)). Defined. Eval simpl in (fun (A:Set)(v:Vector.t A 0) => (Vid _ _ v)). Eval simpl in (fun (A:Set)(v:Vector.t A 0) => v). Lemma Vid_eq : forall (n:nat) (A:Type)(v:Vector.t A n), v=(Vid _ n v). Proof. destruct v. reflexivity. reflexivity. Defined. Theorem zero_nil : forall A (v:Vector.t A 0), v = Vector.nil. Proof. intros. change (Vector.nil (A:=A)) with (Vid _ 0 v). apply Vid_eq. Defined. Theorem decomp : forall (A : Set) (n : nat) (v : Vector.t A (S n)), v = Vector.cons (Vector.hd v) (Vector.tl v). Proof. intros. change (Vector.cons (Vector.hd v) (Vector.tl v)) with (Vid _ (S n) v). apply Vid_eq. Defined. Definition vector_double_rect : forall (A:Set) (P: forall (n:nat),(Vector.t A n)->(Vector.t A n) -> Type), P 0 Vector.nil Vector.nil -> (forall n (v1 v2 : Vector.t A n) a b, P n v1 v2 -> P (S n) (Vector.cons a v1) (Vector.cons b v2)) -> forall n (v1 v2 : Vector.t A n), P n v1 v2. induction n. intros; rewrite (zero_nil _ v1); rewrite (zero_nil _ v2). auto. intros v1 v2; rewrite (decomp _ _ v1);rewrite (decomp _ _ v2). apply X0; auto. Defined. Require Import Bool. Definition bitwise_or n v1 v2 : Vector.t bool n := vector_double_rect bool (fun n v1 v2 => Vector.t bool n) Vector.nil (fun n v1 v2 a b r => Vector.cons (orb a b) r) n v1 v2. Fixpoint vector_nth (A:Set)(n:nat)(p:nat)(v:Vector.t A p){struct v} : option A := match n,v with _ , Vector.nil => None | 0 , Vector.cons b _ _ => Some b | S n', Vector.cons _ p' v' => vector_nth A n' p' v' end. Implicit Arguments vector_nth [A p]. Lemma nth_bitwise : forall (n:nat) (v1 v2: Vector.t bool n) i a b, vector_nth i v1 = Some a -> vector_nth i v2 = Some b -> vector_nth i (bitwise_or _ v1 v2) = Some (orb a b). Proof. intros n v1 v2; pattern n,v1,v2. apply vector_double_rect. simpl. destruct i; discriminate 1. destruct i; simpl;auto. injection 1; injection 2;intros; subst a; subst b; auto. Qed. Set Implicit Arguments. CoInductive Stream (A:Set) : Set := | Cons : A -> Stream A -> Stream A. CoInductive LList (A: Set) : Set := | LNil : LList A | LCons : A -> LList A -> LList A. Definition head (A:Set)(s : Stream A) := match s with Cons a s' => a end. Definition tail (A : Set)(s : Stream A) := match s with Cons a s' => s' end. CoFixpoint repeat (A:Set)(a:A) : Stream A := Cons a (repeat a). CoFixpoint iterate (A: Set)(f: A -> A)(a : A) : Stream A:= Cons a (iterate f (f a)). CoFixpoint map (A B:Set)(f: A -> B)(s : Stream A) : Stream B:= match s with Cons a tl => Cons (f a) (map f tl) end. Eval simpl in (fun (A:Set)(a:A) => repeat a). Eval simpl in (fun (A:Set)(a:A) => head (repeat a)). CoInductive EqSt (A: Set) : Stream A -> Stream A -> Prop := eqst : forall s1 s2: Stream A, head s1 = head s2 -> EqSt (tail s1) (tail s2) -> EqSt s1 s2. Section Parks_Principle. Variable A : Set. Variable R : Stream A -> Stream A -> Prop. Hypothesis bisim1 : forall s1 s2:Stream A, R s1 s2 -> head s1 = head s2. Hypothesis bisim2 : forall s1 s2:Stream A, R s1 s2 -> R (tail s1) (tail s2). CoFixpoint park_ppl : forall s1 s2:Stream A, R s1 s2 -> EqSt s1 s2 := fun s1 s2 (p : R s1 s2) => eqst s1 s2 (bisim1 p) (park_ppl (bisim2 p)). End Parks_Principle. Theorem map_iterate : forall (A:Set)(f:A->A)(x:A), EqSt (iterate f (f x)) (map f (iterate f x)). Proof. intros A f x. apply park_ppl with (R:= fun s1 s2 => exists x: A, s1 = iterate f (f x) /\ s2 = map f (iterate f x)). intros s1 s2 (x0,(eqs1,eqs2));rewrite eqs1;rewrite eqs2;reflexivity. intros s1 s2 (x0,(eqs1,eqs2)). exists (f x0);split;[rewrite eqs1|rewrite eqs2]; reflexivity. exists x;split; reflexivity. Qed. Ltac infiniteproof f := cofix f; constructor; [clear f| simpl; try (apply f; clear f)]. Theorem map_iterate' : forall (A:Set)(f:A->A)(x:A), EqSt (iterate f (f x)) (map f (iterate f x)). infiniteproof map_iterate'. reflexivity. Qed. Implicit Arguments LNil [A]. Lemma Lnil_not_Lcons : forall (A:Set)(a:A)(l:LList A), LNil <> (LCons a l). intros;discriminate. Qed. Lemma injection_demo : forall (A:Set)(a b : A)(l l': LList A), LCons a (LCons b l) = LCons b (LCons a l') -> a = b /\ l = l'. Proof. intros A a b l l' e; injection e; auto. Qed. Inductive Finite (A:Set) : LList A -> Prop := | Lnil_fin : Finite (LNil (A:=A)) | Lcons_fin : forall a l, Finite l -> Finite (LCons a l). CoInductive Infinite (A:Set) : LList A -> Prop := | LCons_inf : forall a l, Infinite l -> Infinite (LCons a l). Lemma LNil_not_Infinite : forall (A:Set), ~ Infinite (LNil (A:=A)). Proof. intros A H;inversion H. Qed. Lemma Finite_not_Infinite : forall (A:Set)(l:LList A), Finite l -> ~ Infinite l. Proof. intros A l H; elim H. apply LNil_not_Infinite. intros a l0 F0 I0' I1. case I0'; inversion_clear I1. trivial. Qed. Lemma Not_Finite_Infinite : forall (A:Set)(l:LList A), ~ Finite l -> Infinite l. Proof. cofix H. destruct l. intro; absurd (Finite (LNil (A:=A)));[auto|constructor]. constructor. apply H. red; intro H1;case H0. constructor. trivial. Qed. coq-8.4pl4/test-suite/success/auto.v0000644000175000017500000000104412326224777016547 0ustar stephsteph(* Wish #2154 by E. van der Weegen *) (* auto was not using f_equal-style lemmas with metavariables occuring only in the type of an evar of the concl, but not directly in the concl itself *) Parameters (F: Prop -> Prop) (G: forall T, (T -> Prop) -> Type) (L: forall A (P: A -> Prop), G A P -> forall x, F (P x)) (Q: unit -> Prop). Hint Resolve L. Goal G unit Q -> F (Q tt). intro. auto. Qed. (* Test implicit arguments in "using" clause *) Goal forall n:nat, nat * nat. auto using (pair O). Undo. eauto using (pair O). Qed. coq-8.4pl4/test-suite/success/Check.v0000644000175000017500000000143312326224777016616 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* I end. Definition try2 : False := match bad in (_ = b) return ((if b then False else True):Prop) with | refl_equal => I end. Definition try3 : False := match bad in (_ = b) return ((fun b' : bool => if b' then False else True) b) with | refl_equal => I end. coq-8.4pl4/test-suite/success/ROmega0.v0000644000175000017500000000475612326224777017046 0ustar stephstephRequire Import ZArith ROmega. Open Scope Z_scope. (* Pierre L: examples gathered while debugging romega. *) Lemma test_romega_0 : forall m m', 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros. romega. Qed. Lemma test_romega_0b : forall m m', 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros m m'. romega. Qed. Lemma test_romega_1 : forall (z z1 z2 : Z), z2 <= z1 -> z1 <= z2 -> z1 >= 0 -> z2 >= 0 -> z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 -> z >= 0. Proof. intros. romega. Qed. Lemma test_romega_1b : forall (z z1 z2 : Z), z2 <= z1 -> z1 <= z2 -> z1 >= 0 -> z2 >= 0 -> z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 -> z >= 0. Proof. intros z z1 z2. romega. Qed. Lemma test_romega_2 : forall a b c:Z, 0<=a-b<=1 -> b-c<=2 -> a-c<=3. Proof. intros. romega. Qed. Lemma test_romega_2b : forall a b c:Z, 0<=a-b<=1 -> b-c<=2 -> a-c<=3. Proof. intros a b c. romega. Qed. Lemma test_romega_3 : forall a b h hl hr ha hb, 0 <= ha - hl <= 1 -> -2 <= hl - hr <= 2 -> h =b+1 -> (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) -> (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) -> (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) -> (-2 <= ha-hr <=2 -> hb = a + 1) -> 0 <= hb - h <= 1. Proof. intros. romega. Qed. Lemma test_romega_3b : forall a b h hl hr ha hb, 0 <= ha - hl <= 1 -> -2 <= hl - hr <= 2 -> h =b+1 -> (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) -> (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) -> (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) -> (-2 <= ha-hr <=2 -> hb = a + 1) -> 0 <= hb - h <= 1. Proof. intros a b h hl hr ha hb. romega. Qed. Lemma test_romega_4 : forall hr ha, ha = 0 -> (ha = 0 -> hr =0) -> hr = 0. Proof. intros hr ha. romega. Qed. Lemma test_romega_5 : forall hr ha, ha = 0 -> (~ha = 0 \/ hr =0) -> hr = 0. Proof. intros hr ha. romega. Qed. Lemma test_romega_6 : forall z, z>=0 -> 0>z+2 -> False. Proof. intros. romega. Qed. Lemma test_romega_6b : forall z, z>=0 -> 0>z+2 -> False. Proof. intros z. romega. Qed. Lemma test_romega_7 : forall z, 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. Proof. intros. romega. Qed. Lemma test_romega_7b : forall z, 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. Proof. intros. romega. Qed. (* Magaud #240 *) Lemma test_romega_8 : forall x y:Z, x*x ~ y*y <= x*x. intros. romega. Qed. Lemma test_romega_8b : forall x y:Z, x*x ~ y*y <= x*x. intros x y. romega. Qed. (* Besson #1298 *) Lemma test_romega9 : forall z z':Z, z<>z' -> z'=z -> False. intros. romega. Qed. coq-8.4pl4/test-suite/success/unification.v0000644000175000017500000001326112326224777020113 0ustar stephsteph(* Test patterns unification *) Lemma l1 : (forall P, (exists x:nat, P x) -> False) -> forall P, (exists x:nat, P x /\ P x) -> False. Proof. intros; apply (H _ H0). Qed. Lemma l2 : forall A:Set, forall Q:A->Set, (forall (P: forall x:A, Q x -> Prop), (exists x:A, exists y:Q x, P x y) -> False) -> forall (P: forall x:A, Q x -> Prop), (exists x:A, exists y:Q x, P x y /\ P x y) -> False. Proof. intros; apply (H _ H0). Qed. Lemma l3 : (forall P, ~(exists x:nat, P x)) -> forall P:nat->Prop, ~(exists x:nat, P x -> P x). Proof. intros; apply H. Qed. (* Feature introduced June 2011 *) Lemma l7 : forall x (P:nat->Prop), (forall f, P (f x)) -> P (x+x). Proof. intros x P H; apply H. Qed. (* Example submitted for Zenon *) Axiom zenon_noteq : forall T : Type, forall t : T, ((t <> t) -> False). Axiom zenon_notall : forall T : Type, forall P : T -> Prop, (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False). (* Must infer "P := fun x => x=x" in zenon_notall *) Check (fun _h1 => (zenon_notall nat _ (fun _T_0 => (fun _h2 => (zenon_noteq _ _T_0 _h2))) _h1)). (* Core of an example submitted by Ralph Matthes (#849) It used to fail because of the K-variable x in the type of "sum_rec ..." which was not in the scope of the evar ?B. Solved by a head beta-reduction of the type "(fun _ : unit + unit => L unit) x" of "sum_rec ...". Shall we used more reduction when solving evars (in real_clean)?? Is there a risk of starting too long reductions? Note that the example originally came from a non re-typable pretty-printed term (the checked term is actually re-printed the same form it is checked). *) Set Implicit Arguments. Inductive L (A:Set) : Set := c : A -> L A. Parameter f: forall (A:Set)(B:Set), (A->B) -> L A -> L B. Parameter t: L (unit + unit). Check (f (fun x : unit + unit => sum_rec (fun _ : unit + unit => L unit) (fun y => c y) (fun y => c y) x) t). (* Test patterns unification in apply *) Require Import Arith. Parameter x y : nat. Parameter G:x=y->x=y->Prop. Parameter K:x<>y->x<>y->Prop. Lemma l4 : (forall f:x=y->Prop, forall g:x<>y->Prop, match eq_nat_dec x y with left a => f a | right a => g a end) -> match eq_nat_dec x y with left a => G a a | right a => K a a end. Proof. intros. apply H. Qed. (* Test unification modulo eta-expansion (if possible) *) (* In this example, two instances for ?P (argument of hypothesis H) can be inferred (one is by unifying the type [Q true] and [?P true] of the goal and type of [H]; the other is by unifying the argument of [f]); we need to unify both instances up to allowed eta-expansions of the instances (eta is allowed if the meta was applied to arguments) This used to fail before revision 9389 in trunk *) Lemma l5 : forall f : (forall P, P true), (forall P, f P = f P) -> forall Q, f (fun x => Q x) = f (fun x => Q x). Proof. intros. apply H. Qed. (* Feature deactivated in commit 14189 (see commit log) (* Test instanciation of evars by unification *) Goal (forall x, 0 + x = 0 -> True) -> True. intros; eapply H. rewrite <- plus_n_Sm. (* should refine ?x with S ?x' *) Abort. *) (* Check handling of identity equation between evars *) (* The example failed to pass until revision 10623 *) Lemma l6 : (forall y, (forall x, (forall z, y = 0 -> y + z = 0) -> y + x = 0) -> True) -> True. intros. eapply H. intros. apply H0. (* Check that equation ?n[H] = ?n[H] is correctly considered true *) reflexivity. Qed. (* Check treatment of metas erased by K-redexes at the time of turning them to evas *) Inductive nonemptyT (t : Type) : Prop := nonemptyT_intro : t -> nonemptyT t. Goal True. try case nonemptyT_intro. (* check that it fails w/o anomaly *) Abort. (* Test handling of return type and when it is decided to make the predicate dependent or not - see "bug" #1851 *) Goal forall X (a:X) (f':nat -> X), (exists f : nat -> X, True). intros. exists (fun n => match n with O => a | S n' => f' n' end). constructor. Qed. (* Check use of types in unification (see Andrej Bauer's mail on coq-club, June 1 2009; it did not work in 8.2, probably started to work after Sozeau improved support for the use of types in unification) *) Goal (forall (A B : Set) (f : A -> B), (fun x => f x) = f) -> forall (A B C : Set) (g : (A -> B) -> C) (f : A -> B), g (fun x => f x) = g f. Proof. intros. rewrite H with (f:=f0). Abort. (* Three tests provided by Dan Grayson as part of a custom patch he made for a more powerful "destruct" for handling Voevodsky's Univalent Foundations. The test checks if second-order matching in tactic unification is able to guess by itself on which dependent terms to abstract so that the elimination predicate is well-typed *) Definition test1 (X : Type) (x : X) (fxe : forall x1 : X, identity x1 x1) : identity (fxe x) (fxe x). Proof. destruct (fxe x). apply identity_refl. Defined. (* a harder example *) Definition UU := Type . Inductive paths {T:Type}(t:T): T -> UU := idpath: paths t t. Inductive foo (X0:UU) (x0:X0) : forall (X:UU)(x:X), UU := newfoo : foo x0 x0. Definition idonfoo {X0:UU} {x0:X0} {X1:UU} {x1:X1} : foo x0 x1 -> foo x0 x1. Proof. intros t. exact t. Defined. Lemma test2 (T:UU) (t:T) (k : foo t t) : paths k (idonfoo k). Proof. destruct k. apply idpath. Defined. (* an example with two constructors *) Inductive foo' (X0:UU) (x0:X0) : forall (X:UU)(x:X), UU := | newfoo1 : foo' x0 x0 | newfoo2 : foo' x0 x0 . Definition idonfoo' {X0:UU} {x0:X0} {X1:UU} {x1:X1} : foo' x0 x1 -> foo' x0 x1. Proof. intros t. exact t. Defined. Lemma test3 (T:UU) (t:T) (k : foo' t t) : paths k (idonfoo' k). Proof. destruct k. apply idpath. apply idpath. Defined. coq-8.4pl4/test-suite/success/Cases.v0000644000175000017500000011376712326224777016655 0ustar stephsteph(****************************************************************************) (* Pattern-matching when non inductive terms occur *) (* Dependent form of annotation *) Type match 0 as n, eq return nat with | O, x => 0 | S x, y => x end. Type match 0, eq, 0 return nat with | O, x, y => 0 | S x, y, z => x end. Type match 0, eq, 0 return _ with | O, x, y => 0 | S x, y, z => x end. (* Non dependent form of annotation *) Type match 0, eq return nat with | O, x => 0 | S x, y => x end. (* Combining dependencies and non inductive arguments *) Type (fun (A : Set) (a : A) (H : 0 = 0) => match H in (_ = x), a return (H = H) with | _, _ => refl_equal H end). (* Interaction with coercions *) Parameter bool2nat : bool -> nat. Coercion bool2nat : bool >-> nat. Definition foo : nat -> nat := fun x => match x with | O => true | S _ => 0 end. (****************************************************************************) (* All remaining examples come from Cristina Cornes' V6 TESTS/MultCases.v *) Inductive IFExpr : Set := | Var : nat -> IFExpr | Tr : IFExpr | Fa : IFExpr | IfE : IFExpr -> IFExpr -> IFExpr -> IFExpr. Inductive List (A : Set) : Set := | Nil : List A | Cons : A -> List A -> List A. Inductive listn : nat -> Set := | niln : listn 0 | consn : forall n : nat, nat -> listn n -> listn (S n). Inductive Listn (A : Set) : nat -> Set := | Niln : Listn A 0 | Consn : forall n : nat, nat -> Listn A n -> Listn A (S n). Inductive Le : nat -> nat -> Set := | LeO : forall n : nat, Le 0 n | LeS : forall n m : nat, Le n m -> Le (S n) (S m). Inductive LE (n : nat) : nat -> Set := | LE_n : LE n n | LE_S : forall m : nat, LE n m -> LE n (S m). Require Import Bool. Inductive PropForm : Set := | Fvar : nat -> PropForm | Or : PropForm -> PropForm -> PropForm. Section testIFExpr. Definition Assign := nat -> bool. Parameter Prop_sem : Assign -> PropForm -> bool. Type (fun (A : Assign) (F : PropForm) => match F return bool with | Fvar n => A n | Or F G => Prop_sem A F || Prop_sem A G end). Type (fun (A : Assign) (H : PropForm) => match H return bool with | Fvar n => A n | Or F G => Prop_sem A F || Prop_sem A G end). End testIFExpr. Type (fun x : nat => match x return nat with | O => 0 | x => x end). Module Type testlist. Parameter A : Set. Inductive list : Set := | nil : list | cons : A -> list -> list. Parameter inf : A -> A -> Prop. Definition list_Lowert2 (a : A) (l : list) := match l return Prop with | nil => True | cons b l => inf a b end. Definition titi (a : A) (l : list) := match l return list with | nil => l | cons b l => l end. End testlist. (* To test translation *) (* ------------------- *) Type match 0 return nat with | O => 0 | _ => 0 end. Type match 0 return nat with | O as b => b | S O => 0 | S (S x) => x end. Type match 0 with | O as b => b | S O => 0 | S (S x) => x end. Type (fun x : nat => match x return nat with | O as b => b | S x => x end). Type (fun x : nat => match x with | O as b => b | S x => x end). Type match 0 return nat with | O as b => b | S x => x end. Type match 0 return nat with | x => x end. Type match 0 with | x => x end. Type match 0 return nat with | O => 0 | S x as b => b end. Type (fun x : nat => match x return nat with | O => 0 | S x as b => b end). Type (fun x : nat => match x with | O => 0 | S x as b => b end). Type match 0 return nat with | O => 0 | S x => 0 end. Type match 0 return (nat * nat) with | O => (0, 0) | S x => (x, 0) end. Type match 0 with | O => (0, 0) | S x => (x, 0) end. Type match 0 return (nat -> nat) with | O => fun n : nat => 0 | S x => fun n : nat => 0 end. Type match 0 with | O => fun n : nat => 0 | S x => fun n : nat => 0 end. Type match 0 return (nat -> nat) with | O => fun n : nat => 0 | S x => fun n : nat => x + n end. Type match 0 with | O => fun n : nat => 0 | S x => fun n : nat => x + n end. Type match 0 return nat with | O => 0 | S x as b => b + x end. Type match 0 return nat with | O => 0 | S a as b => b + a end. Type match 0 with | O => 0 | S a as b => b + a end. Type match 0 with | O => 0 | _ => 0 end. Type match 0 return nat with | O => 0 | x => x end. Type match 0, 1 return nat with | x, y => x + y end. Type match 0, 1 with | x, y => x + y end. Type match 0, 1 return nat with | O, y => y | S x, y => x + y end. Type match 0, 1 with | O, y => y | S x, y => x + y end. Type match 0, 1 return nat with | O, x => x | S y, O => y | x, y => x + y end. Type match 0, 1 with | O, x => x + 0 | S y, O => y + 0 | x, y => x + y end. Type match 0, 1 return nat with | O, x => x + 0 | S y, O => y + 0 | x, y => x + y end. Type match 0, 1 return nat with | O, x => x | S x as b, S y => b + x + y | x, y => x + y end. Type match 0, 1 with | O, x => x | S x as b, S y => b + x + y | x, y => x + y end. Type (fun l : List nat => match l return (List nat) with | Nil => Nil nat | Cons a l => l end). Type (fun l : List nat => match l with | Nil => Nil nat | Cons a l => l end). Type match Nil nat return nat with | Nil => 0 | Cons a l => S a end. Type match Nil nat with | Nil => 0 | Cons a l => S a end. Type match Nil nat return (List nat) with | Cons a l => l | x => x end. Type match Nil nat with | Cons a l => l | x => x end. Type match Nil nat return (List nat) with | Nil => Nil nat | Cons a l => l end. Type match Nil nat with | Nil => Nil nat | Cons a l => l end. Type match 0 return nat with | O => 0 | S x => match Nil nat return nat with | Nil => x | Cons a l => x + a end end. Type match 0 with | O => 0 | S x => match Nil nat with | Nil => x | Cons a l => x + a end end. Type (fun y : nat => match y with | O => 0 | S x => match Nil nat with | Nil => x | Cons a l => x + a end end). Type match 0, Nil nat return nat with | O, x => 0 | S x, Nil => x | S x, Cons a l => x + a end. Type (fun (n : nat) (l : listn n) => match l return nat with | niln => 0 | x => 0 end). Type (fun (n : nat) (l : listn n) => match l with | niln => 0 | x => 0 end). Type match niln return nat with | niln => 0 | x => 0 end. Type match niln with | niln => 0 | x => 0 end. Type match niln return nat with | niln => 0 | consn n a l => a end. Type match niln with | niln => 0 | consn n a l => a end. Type match niln in (listn n) return nat with | consn m _ niln => m | _ => 1 end. Type (fun (n x : nat) (l : listn n) => match x, l return nat with | O, niln => 0 | y, x => 0 end). Type match 0, niln return nat with | O, niln => 0 | y, x => 0 end. Type match niln, 0 return nat with | niln, O => 0 | y, x => 0 end. Type match niln, 0 with | niln, O => 0 | y, x => 0 end. Type match niln, niln return nat with | niln, niln => 0 | x, y => 0 end. Type match niln, niln with | niln, niln => 0 | x, y => 0 end. Type match niln, niln, niln return nat with | niln, niln, niln => 0 | x, y, z => 0 end. Type match niln, niln, niln with | niln, niln, niln => 0 | x, y, z => 0 end. Type match niln return nat with | niln => 0 | consn n a l => 0 end. Type match niln with | niln => 0 | consn n a l => 0 end. Type match niln, niln return nat with | niln, niln => 0 | niln, consn n a l => n | consn n a l, x => a end. Type match niln, niln with | niln, niln => 0 | niln, consn n a l => n | consn n a l, x => a end. Type (fun (n : nat) (l : listn n) => match l return nat with | niln => 0 | x => 0 end). Type (fun (c : nat) (s : bool) => match c, s return nat with | O, _ => 0 | _, _ => c end). Type (fun (c : nat) (s : bool) => match c, s return nat with | O, _ => 0 | S _, _ => c end). (* Rows of pattern variables: some tricky cases *) Axioms (P : nat -> Prop) (f : forall n : nat, P n). Type (fun i : nat => match true, i as n return (P n) with | true, k => f k | _, k => f k end). Type (fun i : nat => match i as n, true return (P n) with | k, true => f k | k, _ => f k end). (* Nested Cases: the SYNTH of the Cases on n used to make Multcase believe * it has to synthesize the predicate on O (which he can't) *) Type match 0 as n return match n with | O => bool | S _ => nat end with | O => true | S _ => 0 end. Type (fun (n : nat) (l : listn n) => match l with | niln => 0 | x => 0 end). Type (fun (n : nat) (l : listn n) => match l return nat with | niln => 0 | consn n a niln => 0 | consn n a (consn m b l) => n + m end). Type (fun (n : nat) (l : listn n) => match l with | niln => 0 | consn n a niln => 0 | consn n a (consn m b l) => n + m end). Type (fun (n : nat) (l : listn n) => match l return nat with | niln => 0 | consn n a niln => 0 | consn n a (consn m b l) => n + m end). Type (fun (n : nat) (l : listn n) => match l with | niln => 0 | consn n a niln => 0 | consn n a (consn m b l) => n + m end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l return nat with | Niln => 0 | Consn n a Niln => 0 | Consn n a (Consn m b l) => n + m end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l with | Niln => 0 | Consn n a Niln => 0 | Consn n a (Consn m b l) => n + m end). (* This example was deactivated in Cristina's code Type (fun (A:Set) (n:nat) (l:Listn A n) => match l return Listn A O with | Niln as b => b | Consn n a (Niln as b) => (Niln A) | Consn n a (Consn m b l) => (Niln A) end). *) (* This one is (still) failing: too weak unification Type (fun (A:Set) (n:nat) (l:Listn A n) => match l with | Niln as b => b | Consn n a (Niln as b) => (Niln A) | Consn n a (Consn m b l) => (Niln A) end). *) (* This one is failing: alias L not chosen of the right type Type (fun (A:Set) (n:nat) (l:Listn A n) => match l return Listn A (S 0) with | Niln as b => Consn A O O b | Consn n a Niln as L => L | Consn n a _ => Consn A O O (Niln A) end). *) (******** This example (still) failed Type (fun (A:Set) (n:nat) (l:Listn A n) => match l return Listn A (S 0) with | Niln as b => Consn A O O b | Consn n a Niln as L => L | Consn n a _ => Consn A O O (Niln A) end). **********) (* To test treatment of as-patterns in depth *) Type (fun (A : Set) (l : List A) => match l with | Nil as b => Nil A | Cons a Nil as L => L | Cons a (Cons b m) as L => L end). Type (fun (n : nat) (l : listn n) => match l return (listn n) with | niln => l | consn n a c => l end). Type (fun (n : nat) (l : listn n) => match l with | niln => l | consn n a c => l end). Type (fun (n : nat) (l : listn n) => match l return (listn n) with | niln as b => l | _ => l end). Type (fun (n : nat) (l : listn n) => match l with | niln as b => l | _ => l end). Type (fun (n : nat) (l : listn n) => match l return (listn n) with | niln as b => l | x => l end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l with | Niln as b => l | _ => l end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l return (Listn A n) with | Niln => l | Consn n a Niln => l | Consn n a (Consn m b c) => l end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l with | Niln => l | Consn n a Niln => l | Consn n a (Consn m b c) => l end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l return (Listn A n) with | Niln as b => l | Consn n a (Niln as b) => l | Consn n a (Consn m b _) => l end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l with | Niln as b => l | Consn n a (Niln as b) => l | Consn n a (Consn m b _) => l end). Type match niln return nat with | niln => 0 | consn n a niln => 0 | consn n a (consn m b l) => n + m end. Type match niln with | niln => 0 | consn n a niln => 0 | consn n a (consn m b l) => n + m end. Type match LeO 0 return nat with | LeO x => x | LeS n m h => n + m end. Type match LeO 0 with | LeO x => x | LeS n m h => n + m end. Type (fun (n : nat) (l : Listn nat n) => match l return nat with | Niln => 0 | Consn n a l => 0 end). Type (fun (n : nat) (l : Listn nat n) => match l with | Niln => 0 | Consn n a l => 0 end). Type match Niln nat with | Niln => 0 | Consn n a l => 0 end. Type match LE_n 0 return nat with | LE_n => 0 | LE_S m h => 0 end. Type match LE_n 0 with | LE_n => 0 | LE_S m h => 0 end. Type match LE_n 0 with | LE_n => 0 | LE_S m h => 0 end. Type match niln return nat with | niln => 0 | consn n a niln => n | consn n a (consn m b l) => n + m end. Type match niln with | niln => 0 | consn n a niln => n | consn n a (consn m b l) => n + m end. Type match Niln nat return nat with | Niln => 0 | Consn n a Niln => n | Consn n a (Consn m b l) => n + m end. Type match Niln nat with | Niln => 0 | Consn n a Niln => n | Consn n a (Consn m b l) => n + m end. Type match LeO 0 return nat with | LeO x => x | LeS n m (LeO x) => x + m | LeS n m (LeS x y h) => n + x end. Type match LeO 0 with | LeO x => x | LeS n m (LeO x) => x + m | LeS n m (LeS x y h) => n + x end. Type match LeO 0 return nat with | LeO x => x | LeS n m (LeO x) => x + m | LeS n m (LeS x y h) => m end. Type match LeO 0 with | LeO x => x | LeS n m (LeO x) => x + m | LeS n m (LeS x y h) => m end. Type (fun (n m : nat) (h : Le n m) => match h return nat with | LeO x => x | x => 0 end). Type (fun (n m : nat) (h : Le n m) => match h with | LeO x => x | x => 0 end). Type (fun (n m : nat) (h : Le n m) => match h return nat with | LeS n m h => n | x => 0 end). Type (fun (n m : nat) (h : Le n m) => match h with | LeS n m h => n | x => 0 end). Type (fun (n m : nat) (h : Le n m) => match h return (nat * nat) with | LeO n => (0, n) | LeS n m _ => (S n, S m) end). Type (fun (n m : nat) (h : Le n m) => match h with | LeO n => (0, n) | LeS n m _ => (S n, S m) end). Module Type F_v1. Fixpoint F (n m : nat) (h : Le n m) {struct h} : Le n (S m) := match h in (Le n m) return (Le n (S m)) with | LeO m' => LeO (S m') | LeS n' m' h' => LeS n' (S m') (F n' m' h') end. End F_v1. Module Type F_v2. Fixpoint F (n m : nat) (h : Le n m) {struct h} : Le n (S m) := match h in (Le n m) return (Le n (S m)) with | LeS n m h => LeS n (S m) (F n m h) | LeO m => LeO (S m) end. End F_v2. (* Rend la longueur de la liste *) Module Type L1. Definition length (n : nat) (l : listn n) := match l return nat with | consn n _ (consn m _ _) => S (S m) | consn n _ _ => 1 | _ => 0 end. End L1. Module Type L1'. Definition length (n : nat) (l : listn n) := match l with | consn n _ (consn m _ _) => S (S m) | consn n _ _ => 1 | _ => 0 end. End L1'. Module Type L2. Definition length (n : nat) (l : listn n) := match l return nat with | consn n _ (consn m _ _) => S (S m) | consn n _ _ => S n | _ => 0 end. End L2. Module Type L2'. Definition length (n : nat) (l : listn n) := match l with | consn n _ (consn m _ _) => S (S m) | consn n _ _ => S n | _ => 0 end. End L2'. Module Type L3. Definition length (n : nat) (l : listn n) := match l return nat with | consn n _ (consn m _ l) => S n | consn n _ _ => 1 | _ => 0 end. End L3. Module Type L3'. Definition length (n : nat) (l : listn n) := match l with | consn n _ (consn m _ l) => S n | consn n _ _ => 1 | _ => 0 end. End L3'. Type match LeO 0 return nat with | LeS n m h => n + m | x => 0 end. Type match LeO 0 with | LeS n m h => n + m | x => 0 end. Type (fun (n m : nat) (h : Le n m) => match h return nat with | LeO x => x | LeS n m (LeO x) => x + m | LeS n m (LeS x y h) => n + (m + (x + y)) end). Type (fun (n m : nat) (h : Le n m) => match h with | LeO x => x | LeS n m (LeO x) => x + m | LeS n m (LeS x y h) => n + (m + (x + y)) end). Type match LeO 0 return nat with | LeO x => x | LeS n m (LeO x) => x + m | LeS n m (LeS x y h) => n + (m + (x + y)) end. Type match LeO 0 with | LeO x => x | LeS n m (LeO x) => x + m | LeS n m (LeS x y h) => n + (m + (x + y)) end. Type match LE_n 0 return nat with | LE_n => 0 | LE_S m LE_n => 0 + m | LE_S m (LE_S y h) => 0 + m end. Type match LE_n 0 with | LE_n => 0 | LE_S m LE_n => 0 + m | LE_S m (LE_S y h) => 0 + m end. Type (fun (n m : nat) (h : Le n m) => match h with | x => x end). Type (fun (n m : nat) (h : Le n m) => match h return nat with | LeO n => n | x => 0 end). Type (fun (n m : nat) (h : Le n m) => match h with | LeO n => n | x => 0 end). Type (fun n : nat => match niln return (nat -> nat) with | niln => fun _ : nat => 0 | consn n a niln => fun _ : nat => 0 | consn n a (consn m b l) => fun _ : nat => n + m end). Type (fun n : nat => match niln with | niln => fun _ : nat => 0 | consn n a niln => fun _ : nat => 0 | consn n a (consn m b l) => fun _ : nat => n + m end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l return (nat -> nat) with | Niln => fun _ : nat => 0 | Consn n a Niln => fun _ : nat => n | Consn n a (Consn m b l) => fun _ : nat => n + m end). Type (fun (A : Set) (n : nat) (l : Listn A n) => match l with | Niln => fun _ : nat => 0 | Consn n a Niln => fun _ : nat => n | Consn n a (Consn m b l) => fun _ : nat => n + m end). (* Also tests for multiple _ patterns *) Type (fun (A : Set) (n : nat) (l : Listn A n) => match l in (Listn _ n) return (Listn A n) with | Niln as b => b | Consn _ _ _ as b => b end). (** This one was said to raised once an "Horrible error message!" *) Type (fun (A:Set) (n:nat) (l:Listn A n) => match l with | Niln as b => b | Consn _ _ _ as b => b end). Type match niln in (listn n) return (listn n) with | niln as b => b | consn _ _ _ as b => b end. Type match niln in (listn n) return (listn n) with | niln as b => b | x => x end. Type (fun (n m : nat) (h : LE n m) => match h return (nat -> nat) with | LE_n => fun _ : nat => n | LE_S m LE_n => fun _ : nat => n + m | LE_S m (LE_S y h) => fun _ : nat => m + y end). Type (fun (n m : nat) (h : LE n m) => match h with | LE_n => fun _ : nat => n | LE_S m LE_n => fun _ : nat => n + m | LE_S m (LE_S y h) => fun _ : nat => m + y end). Type (fun (n m : nat) (h : LE n m) => match h return nat with | LE_n => n | LE_S m LE_n => n + m | LE_S m (LE_S y LE_n) => n + m + y | LE_S m (LE_S y (LE_S y' h)) => n + m + (y + y') end). Type (fun (n m : nat) (h : LE n m) => match h with | LE_n => n | LE_S m LE_n => n + m | LE_S m (LE_S y LE_n) => n + m + y | LE_S m (LE_S y (LE_S y' h)) => n + m + (y + y') end). Type (fun (n m : nat) (h : LE n m) => match h return nat with | LE_n => n | LE_S m LE_n => n + m | LE_S m (LE_S y h) => n + m + y end). Type (fun (n m : nat) (h : LE n m) => match h with | LE_n => n | LE_S m LE_n => n + m | LE_S m (LE_S y h) => n + m + y end). Type (fun n m : nat => match LeO 0 return nat with | LeS n m h => n + m | x => 0 end). Type (fun n m : nat => match LeO 0 with | LeS n m h => n + m | x => 0 end). Parameter test : forall n : nat, {0 <= n} + {False}. Type (fun n : nat => match test n return nat with | left _ => 0 | _ => 0 end). Type (fun n : nat => match test n return nat with | left _ => 0 | _ => 0 end). Type (fun n : nat => match test n with | left _ => 0 | _ => 0 end). Parameter compare : forall n m : nat, {n < m} + {n = m} + {n > m}. Type match compare 0 0 return nat with (* k 0 (* k=i *) | inleft _ => 0 (* k>i *) | inright _ => 0 end. Type match compare 0 0 with (* k 0 (* k=i *) | inleft _ => 0 (* k>i *) | inright _ => 0 end. CoInductive SStream (A : Set) : (nat -> A -> Prop) -> Type := scons : forall (P : nat -> A -> Prop) (a : A), P 0 a -> SStream A (fun n : nat => P (S n)) -> SStream A P. Parameter B : Set. Type (fun (P : nat -> B -> Prop) (x : SStream B P) => match x return B with | scons _ a _ _ => a end). Type (fun (P : nat -> B -> Prop) (x : SStream B P) => match x with | scons _ a _ _ => a end). Type match (0, 0) return (nat * nat) with | (x, y) => (S x, S y) end. Type match (0, 0) return (nat * nat) with | (b, y) => (S b, S y) end. Type match (0, 0) return (nat * nat) with | (x, y) => (S x, S y) end. Type match (0, 0) with | (x, y) => (S x, S y) end. Type match (0, 0) with | (b, y) => (S b, S y) end. Type match (0, 0) with | (x, y) => (S x, S y) end. Module Type test_concat. Parameter concat : forall A : Set, List A -> List A -> List A. Type match Nil nat, Nil nat return (List nat) with | Nil as b, x => concat nat b x | Cons _ _ as d, Nil as c => concat nat d c | _, _ => Nil nat end. Type match Nil nat, Nil nat with | Nil as b, x => concat nat b x | Cons _ _ as d, Nil as c => concat nat d c | _, _ => Nil nat end. End test_concat. Inductive redexes : Set := | VAR : nat -> redexes | Fun : redexes -> redexes | Ap : bool -> redexes -> redexes -> redexes. Fixpoint regular (U : redexes) : Prop := match U return Prop with | VAR n => True | Fun V => regular V | Ap true (Fun _ as V) W => regular V /\ regular W | Ap true _ W => False | Ap false V W => regular V /\ regular W end. Type (fun n : nat => match n with | O => 0 | S (S n as V) => V | _ => 0 end). Parameter concat : forall n : nat, listn n -> forall m : nat, listn m -> listn (n + m). Type (fun (n : nat) (l : listn n) (m : nat) (l' : listn m) => match l in (listn n), l' return (listn (n + m)) with | niln, x => x | consn n a l'', x => consn (n + m) a (concat n l'' m x) end). Type (fun (x y z : nat) (H : x = y) (H0 : y = z) => match H return (x = z) with | refl_equal => match H0 in (_ = n) return (x = n) with | refl_equal => H end end). Type (fun h : False => match h return False with end). Type (fun h : False => match h return True with end). Definition is_zero (n : nat) := match n with | O => True | _ => False end. Type (fun (n : nat) (h : 0 = S n) => match h in (_ = n) return (is_zero n) with | refl_equal => I end). Definition disc (n : nat) (h : 0 = S n) : False := match h in (_ = n) return (is_zero n) with | refl_equal => I end. Definition nlength3 (n : nat) (l : listn n) := match l with | niln => 0 | consn O _ _ => 1 | consn (S n) _ _ => S (S n) end. (* == Testing strategy elimintation predicate synthesis == *) Section titi. Variable h : False. Type match 0 with | O => 0 | _ => except h end. End titi. Type match niln with | consn _ a niln => a | consn n _ x => 0 | niln => 0 end. Inductive wsort : Set := | ws : wsort | wt : wsort. Inductive TS : wsort -> Set := | id : TS ws | lift : TS ws -> TS ws. Type (fun (b : wsort) (M N : TS b) => match M, N with | lift M1, id => False | _, _ => True end). (* ===================================================================== *) (* To test pattern matching over a non-dependent inductive type, but *) (* having constructors with some arguments that depend on others *) (* I.e. to test manipulation of elimination predicate *) (* ===================================================================== *) Module Type test_term. Parameter LTERM : nat -> Set. Inductive TERM : Type := | var : TERM | oper : forall op : nat, LTERM op -> TERM. Parameter t1 t2 : TERM. Type match t1, t2 with | var, var => True | oper op1 l1, oper op2 l2 => False | _, _ => False end. End test_term. Require Import Peano_dec. Parameter n : nat. Definition eq_prf := exists m : _, n = m. Parameter p : eq_prf. Type match p with | ex_intro c eqc => match eq_nat_dec c n with | right _ => refl_equal n | left y => (* c=n*) refl_equal n end end. Parameter ordre_total : nat -> nat -> Prop. Parameter N_cla : forall N : nat, {N = 0} + {N = 1} + {N >= 2}. Parameter exist_U2 : forall N : nat, N >= 2 -> {n : nat | forall m : nat, 0 < m /\ m <= N /\ ordre_total n m /\ 0 < n /\ n < N}. Type (fun N : nat => match N_cla N with | inright H => match exist_U2 N H with | exist a b => a end | _ => 0 end). (* ============================================== *) (* To test compilation of dependent case *) (* Nested patterns *) (* ============================================== *) (* == To test that terms named with AS are correctly absolutized before substitution in rhs == *) Type (fun n : nat => match n return nat with | O => 0 | S O => 0 | S (S n1) as N => N end). (* ========= *) Type match niln in (listn n) return Prop with | niln => True | consn (S O) _ _ => False | _ => True end. Type match niln in (listn n) return Prop with | niln => True | consn (S (S O)) _ _ => False | _ => True end. Type match LeO 0 as h in (Le n m) return nat with | LeO _ => 0 | LeS (S x) _ _ => x | _ => 1 end. Type match LeO 0 as h in (Le n m) return nat with | LeO _ => 0 | LeS (S x) (S y) _ => x | _ => 1 end. Type match LeO 0 as h in (Le n m) return nat with | LeO _ => 0 | LeS (S x as b) (S y) _ => b | _ => 1 end. Module Type ff. Parameter ff : forall n m : nat, n <> m -> S n <> S m. Parameter discr_r : forall n : nat, 0 <> S n. Parameter discr_l : forall n : nat, S n <> 0. Type (fun n : nat => match n return (n = 0 \/ n <> 0) with | O => or_introl (0 <> 0) (refl_equal 0) | S x => or_intror (S x = 0) (discr_l x) end). Module Type eqdec. Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m := match n, m return (n = m \/ n <> m) with | O, O => or_introl (0 <> 0) (refl_equal 0) | O, S x => or_intror (0 = S x) (discr_r x) | S x, O => or_intror _ (discr_l x) | S x, S y => match eqdec x y return (S x = S y \/ S x <> S y) with | or_introl h => or_introl (S x <> S y) (f_equal S h) | or_intror h => or_intror (S x = S y) (ff x y h) end end. End eqdec. Module Type eqdec'. Fixpoint eqdec (n : nat) : forall m : nat, n = m \/ n <> m := match n return (forall m : nat, n = m \/ n <> m) with | O => fun m : nat => match m return (0 = m \/ 0 <> m) with | O => or_introl (0 <> 0) (refl_equal 0) | S x => or_intror (0 = S x) (discr_r x) end | S x => fun m : nat => match m return (S x = m \/ S x <> m) with | O => or_intror (S x = 0) (discr_l x) | S y => match eqdec x y return (S x = S y \/ S x <> S y) with | or_introl h => or_introl (S x <> S y) (f_equal S h) | or_intror h => or_intror (S x = S y) (ff x y h) end end end. End eqdec'. Inductive empty : forall n : nat, listn n -> Prop := intro_empty : empty 0 niln. Parameter inv_empty : forall (n a : nat) (l : listn n), ~ empty (S n) (consn n a l). Type (fun (n : nat) (l : listn n) => match l in (listn n) return (empty n l \/ ~ empty n l) with | niln => or_introl (~ empty 0 niln) intro_empty | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y) end). End ff. Module Type ff'. Parameter ff : forall n m : nat, n <> m -> S n <> S m. Parameter discr_r : forall n : nat, 0 <> S n. Parameter discr_l : forall n : nat, S n <> 0. Type (fun n : nat => match n return (n = 0 \/ n <> 0) with | O => or_introl (0 <> 0) (refl_equal 0) | S x => or_intror (S x = 0) (discr_l x) end). Module Type eqdec. Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m := match n, m return (n = m \/ n <> m) with | O, O => or_introl (0 <> 0) (refl_equal 0) | O, S x => or_intror (0 = S x) (discr_r x) | S x, O => or_intror _ (discr_l x) | S x, S y => match eqdec x y return (S x = S y \/ S x <> S y) with | or_introl h => or_introl (S x <> S y) (f_equal S h) | or_intror h => or_intror (S x = S y) (ff x y h) end end. End eqdec. Module Type eqdec'. Fixpoint eqdec (n : nat) : forall m : nat, n = m \/ n <> m := match n return (forall m : nat, n = m \/ n <> m) with | O => fun m : nat => match m return (0 = m \/ 0 <> m) with | O => or_introl (0 <> 0) (refl_equal 0) | S x => or_intror (0 = S x) (discr_r x) end | S x => fun m : nat => match m return (S x = m \/ S x <> m) with | O => or_intror (S x = 0) (discr_l x) | S y => match eqdec x y return (S x = S y \/ S x <> S y) with | or_introl h => or_introl (S x <> S y) (f_equal S h) | or_intror h => or_intror (S x = S y) (ff x y h) end end end. End eqdec'. End ff'. (* ================================================== *) (* Pour tester parametres *) (* ================================================== *) Inductive Empty (A : Set) : List A -> Prop := intro_Empty : Empty A (Nil A). Parameter inv_Empty : forall (A : Set) (a : A) (x : List A), ~ Empty A (Cons A a x). Type match Nil nat as l return (Empty nat l \/ ~ Empty nat l) with | Nil => or_introl (~ Empty nat (Nil nat)) (intro_Empty nat) | Cons a y => or_intror (Empty nat (Cons nat a y)) (inv_Empty nat a y) end. (* ================================================== *) (* Sur les listes *) (* ================================================== *) Inductive empty : forall n : nat, listn n -> Prop := intro_empty : empty 0 niln. Parameter inv_empty : forall (n a : nat) (l : listn n), ~ empty (S n) (consn n a l). Type (fun (n : nat) (l : listn n) => match l in (listn n) return (empty n l \/ ~ empty n l) with | niln => or_introl (~ empty 0 niln) intro_empty | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y) end). (* ===================================== *) (* Test parametros: *) (* ===================================== *) Inductive eqlong : List nat -> List nat -> Prop := | eql_cons : forall (n m : nat) (x y : List nat), eqlong x y -> eqlong (Cons nat n x) (Cons nat m y) | eql_nil : eqlong (Nil nat) (Nil nat). Parameter V1 : eqlong (Nil nat) (Nil nat) \/ ~ eqlong (Nil nat) (Nil nat). Parameter V2 : forall (a : nat) (x : List nat), eqlong (Nil nat) (Cons nat a x) \/ ~ eqlong (Nil nat) (Cons nat a x). Parameter V3 : forall (a : nat) (x : List nat), eqlong (Cons nat a x) (Nil nat) \/ ~ eqlong (Cons nat a x) (Nil nat). Parameter V4 : forall (a : nat) (x : List nat) (b : nat) (y : List nat), eqlong (Cons nat a x) (Cons nat b y) \/ ~ eqlong (Cons nat a x) (Cons nat b y). Type match Nil nat as x, Nil nat as y return (eqlong x y \/ ~ eqlong x y) with | Nil, Nil => V1 | Nil, Cons a x => V2 a x | Cons a x, Nil => V3 a x | Cons a x, Cons b y => V4 a x b y end. Type (fun x y : List nat => match x, y return (eqlong x y \/ ~ eqlong x y) with | Nil, Nil => V1 | Nil, Cons a x => V2 a x | Cons a x, Nil => V3 a x | Cons a x, Cons b y => V4 a x b y end). (* ===================================== *) Inductive Eqlong : forall n : nat, listn n -> forall m : nat, listn m -> Prop := | Eql_cons : forall (n m : nat) (x : listn n) (y : listn m) (a b : nat), Eqlong n x m y -> Eqlong (S n) (consn n a x) (S m) (consn m b y) | Eql_niln : Eqlong 0 niln 0 niln. Parameter W1 : Eqlong 0 niln 0 niln \/ ~ Eqlong 0 niln 0 niln. Parameter W2 : forall (n a : nat) (x : listn n), Eqlong 0 niln (S n) (consn n a x) \/ ~ Eqlong 0 niln (S n) (consn n a x). Parameter W3 : forall (n a : nat) (x : listn n), Eqlong (S n) (consn n a x) 0 niln \/ ~ Eqlong (S n) (consn n a x) 0 niln. Parameter W4 : forall (n a : nat) (x : listn n) (m b : nat) (y : listn m), Eqlong (S n) (consn n a x) (S m) (consn m b y) \/ ~ Eqlong (S n) (consn n a x) (S m) (consn m b y). Type match niln as x in (listn n), niln as y in (listn m) return (Eqlong n x m y \/ ~ Eqlong n x m y) with | niln, niln => W1 | niln, consn n a x => W2 n a x | consn n a x, niln => W3 n a x | consn n a x, consn m b y => W4 n a x m b y end. Type (fun (n m : nat) (x : listn n) (y : listn m) => match x in (listn n), y in (listn m) return (Eqlong n x m y \/ ~ Eqlong n x m y) with | niln, niln => W1 | niln, consn n a x => W2 n a x | consn n a x, niln => W3 n a x | consn n a x, consn m b y => W4 n a x m b y end). Parameter Inv_r : forall (n a : nat) (x : listn n), ~ Eqlong 0 niln (S n) (consn n a x). Parameter Inv_l : forall (n a : nat) (x : listn n), ~ Eqlong (S n) (consn n a x) 0 niln. Parameter Nff : forall (n a : nat) (x : listn n) (m b : nat) (y : listn m), ~ Eqlong n x m y -> ~ Eqlong (S n) (consn n a x) (S m) (consn m b y). Fixpoint Eqlongdec (n : nat) (x : listn n) (m : nat) (y : listn m) {struct x} : Eqlong n x m y \/ ~ Eqlong n x m y := match x in (listn n), y in (listn m) return (Eqlong n x m y \/ ~ Eqlong n x m y) with | niln, niln => or_introl (~ Eqlong 0 niln 0 niln) Eql_niln | niln, consn n a x as L => or_intror (Eqlong 0 niln (S n) L) (Inv_r n a x) | consn n a x as L, niln => or_intror (Eqlong (S n) L 0 niln) (Inv_l n a x) | consn n a x as L1, consn m b y as L2 => match Eqlongdec n x m y return (Eqlong (S n) L1 (S m) L2 \/ ~ Eqlong (S n) L1 (S m) L2) with | or_introl h => or_introl (~ Eqlong (S n) L1 (S m) L2) (Eql_cons n m x y a b h) | or_intror h => or_intror (Eqlong (S n) L1 (S m) L2) (Nff n a x m b y h) end end. (* ============================================== *) (* To test compilation of dependent case *) (* Multiple Patterns *) (* ============================================== *) Inductive skel : Type := | PROP : skel | PROD : skel -> skel -> skel. Parameter Can : skel -> Type. Parameter default_can : forall s : skel, Can s. Type (fun s1 s2 s1 s2 : skel => match s1, s2 return (Can s1) with | PROP, PROP => default_can PROP | PROD x y, PROP => default_can (PROD x y) | PROD x y, _ => default_can (PROD x y) | PROP, _ => default_can PROP end). (* to test bindings in nested Cases *) (* ================================ *) Inductive Pair : Set := | pnil : Pair | pcons : Pair -> Pair -> Pair. Type (fun p q : Pair => match p with | pcons _ x => match q with | pcons _ (pcons _ x) => True | _ => False end | _ => False end). Type (fun p q : Pair => match p with | pcons _ x => match q with | pcons _ (pcons _ x) => match q with | pcons _ (pcons _ (pcons _ x)) => x | _ => pnil end | _ => pnil end | _ => pnil end). Type (fun (n : nat) (l : listn (S n)) => match l in (listn z) return (listn (pred z)) with | niln => niln | consn n _ l => match l in (listn m) return (listn m) with | niln => niln | b => b end end). (* Test de la syntaxe avec nombres *) Require Import Arith. Type (fun n => match n with | S (S O) => true | _ => false end). Require Import ZArith. Type (fun n => match n with | Z0 => true | _ => false end). (* Check that types with unknown sort, as A below, are not fatal to the pattern-matching compilation *) Definition transport {A} (P : A->Type) {x y : A} (p : x=y) (u : P x) : P y := match p with eq_refl => u end. coq-8.4pl4/test-suite/success/hyps_inclusion.v0000644000175000017500000000221012326224777020641 0ustar stephsteph(* Simplified example for bug #1325 *) (* Explanation: the proof engine see section variables as goal variables; especially, it can change their types so that, at type-checking, the section variables are not recognized (Typeops.check_hyps_inclusion raises "types do no match"). It worked before the introduction of polymorphic inductive types because tactics were using Typing.type_of and not Typeops.typing; the former was not checking hyps inclusion so that the discrepancy in the types of section variables seen as goal variables was not a problem (at the end, when the proof is completed, the section variable recovers its original type and all is correct for Typeops) *) Section A. Variable H:not True. Lemma f:nat->nat. destruct H. exact I. Defined. Goal f 0=f 1. red in H. (* next tactic was failing wrt bug #1325 because type-checking the goal detected a syntactically different type for the section variable H *) case 0. Abort. End A. (* Variant with polymorphic inductive types for bug #1325 *) Section B. Variable H:not True. Inductive I (n:nat) : Type := C : H=H -> I n. Goal I 0. red in H. case 0. Abort. End B. coq-8.4pl4/test-suite/success/CaseAlias.v0000644000175000017500000000504612326224777017432 0ustar stephsteph(*********************************************) (* This has been a bug reported by Y. Bertot *) Inductive expr : Set := | b : expr -> expr -> expr | u : expr -> expr | a : expr | var : nat -> expr. Fixpoint f (t : expr) : expr := match t with | b t1 t2 => b (f t1) (f t2) | a => a | x => b t a end. Fixpoint f2 (t : expr) : expr := match t with | b t1 t2 => b (f2 t1) (f2 t2) | a => a | x => b x a end. (*********************************************) (* Test expansion of aliases *) (* Originally taken from NMake_gen.v *) Local Notation SizePlus n := (S (S (S (S (S (S n)))))). Local Notation Size := (SizePlus O). Parameter zn2z : Type -> Type. Parameter w0 : Type. Fixpoint word (w : Type) (n : nat) {struct n} : Type := match n with | 0 => w | S n0 => zn2z (word w n0) end. Definition w1 := zn2z w0. Definition w2 := zn2z w1. Definition w3 := zn2z w2. Definition w4 := zn2z w3. Definition w5 := zn2z w4. Definition w6 := zn2z w5. Definition dom_t n := match n with | 0 => w0 | 1 => w1 | 2 => w2 | 3 => w3 | 4 => w4 | 5 => w5 | 6 => w6 | SizePlus n => word w6 n end. Parameter plus_t : forall n m : nat, word (dom_t n) m -> dom_t (m + n). (* This used to fail because of a bug in expansion of SizePlus wrongly reusing n as an alias for the subpattern *) Definition plus_t1 n : forall m, word (dom_t n) m -> dom_t (m+n) := match n return (forall m, word (dom_t n) m -> dom_t (m+n)) with | SizePlus (S n') as n => plus_t n | _ as n => fun m => match m return (word (dom_t n) m -> dom_t (m+n)) with | SizePlus (S (S m')) as m => plus_t n m | _ => fun x => x end end. (* Test (useless) intermediate alias *) Definition plus_t2 n : forall m, word (dom_t n) m -> dom_t (m+n) := match n return (forall m, word (dom_t n) m -> dom_t (m+n)) with | S (S (S (S (S (S (S n'))))) as n) as n'' => plus_t n'' | _ as n => fun m => match m return (word (dom_t n) m -> dom_t (m+n)) with | SizePlus (S (S m')) as m => plus_t n m | _ => fun x => x end end. (*****************************************************************************) (* Check that alias expansion behaves consistently from versions to versions *) Definition g m := match pred m with | 0 => 0 | n => n (* For compatibility, right-hand side should be (S n), not (pred m) *) end. Goal forall m, g m = match pred m with 0 => 0 | S n => S n end. intro; reflexivity. Abort. coq-8.4pl4/test-suite/success/Generalize.v0000644000175000017500000000026012326224777017663 0ustar stephsteph(* Check Generalize Dependent *) Lemma l1 : let a := 0 in let b := a in forall (c : b = b) (d : True -> b = b), d = d. intros. generalize dependent a. intros a b c d. Abort. coq-8.4pl4/test-suite/success/Cases-bug1834.v0000644000175000017500000000057312326224777017736 0ustar stephsteph(* Bug in the computation of generalization *) (* The following bug, elaborated by Bruno Barras, is solved from r11083 *) Parameter P : unit -> Prop. Definition T := sig P. Parameter Q : T -> Prop. Definition U := sig Q. Parameter a : U. Check (match a with exist (exist tt e2) e3 => e3=e3 end). (* There is still a form submitted by Pierre Corbineau (#1834) which fails *) coq-8.4pl4/test-suite/success/Rename.v0000644000175000017500000000033412326224777017007 0ustar stephstephGoal forall n : nat, n = 0 -> n = 0. intros. rename n into p. induction p; auto. Qed. (* Submitted by Iris Loeb (#842) *) Section rename. Variable A:Prop. Lemma Tauto: A->A. rename A into B. tauto. Qed. End rename. coq-8.4pl4/test-suite/success/Case8.v0000644000175000017500000000052212326224777016542 0ustar stephsteph(* Check dependencies in the matching predicate (was failing in V8.0pl1) *) Inductive t : forall x : 0 = 0, x = x -> Prop := c : forall x : 0 = 0, t x (refl_equal x). Definition a (x : t _ (refl_equal (refl_equal 0))) := match x return match x with | c y => Prop end with | c y => y = y end. coq-8.4pl4/test-suite/success/Case2.v0000644000175000017500000000046212326224777016537 0ustar stephsteph(* ============================================== *) (* To test compilation of dependent case *) (* Nested patterns *) (* ============================================== *) Type match 0 as n return (n = n) with | O => refl_equal 0 | m => refl_equal m end. coq-8.4pl4/test-suite/success/Remark.v0000644000175000017500000000025412326224777017022 0ustar stephsteph(* Test obsolete, Remark est maintenant global Section A. Section B. Section C. Remark t : True. Proof I. End C. Locate C.t. End B. Locate B.C.t. End A. Locate A.B.C.t. *) coq-8.4pl4/test-suite/success/OmegaPre.v0000644000175000017500000000422312326224777017300 0ustar stephstephRequire Import ZArith Nnat Omega. Open Scope Z_scope. (** Test of the zify preprocessor for (R)Omega *) (* More details in file PreOmega.v (r)omega with Z : starts with zify_op (r)omega with nat : starts with zify_nat (r)omega with positive : starts with zify_positive (r)omega with N : starts with uses zify_N (r)omega with * : starts zify (a saturation of the others) *) (* zify_op *) Goal forall a:Z, Z.max a a = a. intros. omega with *. Qed. Goal forall a b:Z, Z.max a b = Z.max b a. intros. omega with *. Qed. Goal forall a b c:Z, Z.max a (Z.max b c) = Z.max (Z.max a b) c. intros. omega with *. Qed. Goal forall a b:Z, Z.max a b + Z.min a b = a + b. intros. omega with *. Qed. Goal forall a:Z, (Z.abs a)*(Z.sgn a) = a. intros. zify. intuition; subst; omega. (* pure multiplication: omega alone can't do it *) Qed. Goal forall a:Z, Z.abs a = a -> a >= 0. intros. omega with *. Qed. Goal forall a:Z, Z.sgn a = a -> a = 1 \/ a = 0 \/ a = -1. intros. omega with *. Qed. (* zify_nat *) Goal forall m: nat, (m<2)%nat -> (0<= m+m <=2)%nat. intros. omega with *. Qed. Goal forall m:nat, (m<1)%nat -> (m=0)%nat. intros. omega with *. Qed. Goal forall m: nat, (m<=100)%nat -> (0<= m+m <=200)%nat. intros. omega with *. Qed. (* 2000 instead of 200: works, but quite slow *) Goal forall m: nat, (m*m>=0)%nat. intros. omega with *. Qed. (* zify_positive *) Goal forall m: positive, (m<2)%positive -> (2 <= m+m /\ m+m <= 2)%positive. intros. omega with *. Qed. Goal forall m:positive, (m<2)%positive -> (m=1)%positive. intros. omega with *. Qed. Goal forall m: positive, (m<=1000)%positive -> (2<=m+m/\m+m <=2000)%positive. intros. omega with *. Qed. Goal forall m: positive, (m*m>=1)%positive. intros. omega with *. Qed. (* zify_N *) Goal forall m:N, (m<2)%N -> (0 <= m+m /\ m+m <= 2)%N. intros. omega with *. Qed. Goal forall m:N, (m<1)%N -> (m=0)%N. intros. omega with *. Qed. Goal forall m:N, (m<=1000)%N -> (0<=m+m/\m+m <=2000)%N. intros. omega with *. Qed. Goal forall m:N, (m*m>=0)%N. intros. omega with *. Qed. (* mix of datatypes *) Goal forall p, Z.of_N (N.of_nat (N.to_nat (Npos p))) = Zpos p. intros. omega with *. Qed. coq-8.4pl4/test-suite/success/rewrite.v0000644000175000017500000000635212326224777017267 0ustar stephsteph(* Check that dependent rewrite applies on arbitrary terms *) Inductive listn : nat -> Set := | niln : listn 0 | consn : forall n : nat, nat -> listn n -> listn (S n). Axiom ax : forall (n n' : nat) (l : listn (n + n')) (l' : listn (n' + n)), existS _ (n + n') l = existS _ (n' + n) l'. Lemma lem : forall (n n' : nat) (l : listn (n + n')) (l' : listn (n' + n)), n + n' = n' + n /\ existT _ (n + n') l = existT _ (n' + n) l'. Proof. intros n n' l l'. dependent rewrite (ax n n' l l'). split; reflexivity. Qed. (* Used to raise an anomaly instead of an error in 8.1 *) (* Submitted by Y. Makarov *) Parameter N : Set. Parameter E : N -> N -> Prop. Axiom e : forall (A : Set) (EA : A -> A -> Prop) (a : A), EA a a. Theorem th : forall x : N, E x x. intro x. try rewrite e. Abort. (* Behavior of rewrite wrt conversion *) Require Import Arith. Goal forall n, 0 + n = n -> True. intros n H. rewrite plus_0_l in H. Abort. (* Rewrite dependent proofs from left-to-right *) Lemma l1 : forall x y (H:x = y:>nat) (P:forall x y, x=y -> Type), P x y H -> P x y H. intros x y H P H0. rewrite H. rewrite H in H0. assumption. Qed. (* Rewrite dependent proofs from right-to-left *) Lemma l2 : forall x y (H:x = y:>nat) (P:forall x y, x=y -> Type), P x y H -> P x y H. intros x y H P H0. rewrite <- H. rewrite <- H in H0. assumption. Qed. (* Check rewriting dependent proofs with non-symmetric equalities *) Lemma l3:forall x (H:eq_true x) (P:forall x, eq_true x -> Type), P x H -> P x H. intros x H P H0. rewrite H. rewrite H in H0. assumption. Qed. (* Dependent rewrite *) Require Import JMeq. Goal forall A B (a:A) (b:B), JMeq a b -> JMeq b a -> True. inversion 1; (* Goal is now [JMeq a a -> True] *) dependent rewrite H3. Undo. intros; inversion H; dependent rewrite H4 in H0. Undo. intros; inversion H; dependent rewrite <- H4 in H0. Abort. (* Test conversion between terms with evars that both occur in K-redexes and are elsewhere solvable. This is quite an artificial example, but it used to work in 8.2. Since rewrite supports conversion on terms without metas, it was successively unifying (id 0 ?y) and 0 where ?y was not a meta but, because coming from a "_", an evar. After commit r12440 which unified the treatment of metas and evars, it stopped to work. Chung-Kil Hur's Heq package used this feature. Solved in r13... *) Parameter g : nat -> nat -> nat. Definition K (x y:nat) := x. Goal (forall y, g y (K 0 y) = 0) -> g 0 0 = 0. intros. rewrite (H _). reflexivity. Qed. Goal (forall y, g (K 0 y) y = 0) -> g 0 0 = 0. intros. rewrite (H _). reflexivity. Qed. (* Example of rewriting of a degenerated pattern using the right-most argument of the goal. This is sometimes used in contribs, even if ad hoc. Here, we have the extra requirement that checking types needs delta-conversion *) Axiom s : forall (A B : Type) (p : A * B), p = (fst p, snd p). Definition P := (nat * nat)%type. Goal forall x:P, x = x. intros. rewrite s. Abort. (* Test second-order unification and failure of pattern-unification *) Goal forall (P: forall Y, Y -> Prop) Y a, Y = nat -> (True -> P Y a) -> False. intros. (* The next line used to succeed between June and November 2011 *) (* causing ill-typed rewriting *) Fail rewrite H in H0. Abort. coq-8.4pl4/test-suite/success/remember.v0000644000175000017500000000063112326224777017376 0ustar stephsteph(* Testing remember and co *) Lemma A : forall (P: forall X, X -> Prop), P nat 0 -> P nat 0. intros. Fail remember nat as X. Fail remember nat as X in H. (* This line used to succeed in 8.3 *) Fail remember nat as X. Abort. (* Testing Ltac interpretation of remember (was not working up to r16181) *) Goal (1 + 2 + 3 = 6). let name := fresh "fresh" in remember (1 + 2) as x eqn:name. rewrite fresh. Abort. coq-8.4pl4/test-suite/success/ROmega2.v0000644000175000017500000000172612326224777017042 0ustar stephstephRequire Import ZArith ROmega. (* Submitted by Yegor Bryukhov (#922) *) Open Scope Z_scope. (* First a simplified version used during debug of romega on Test46 *) Lemma Test46_simplified : forall v1 v2 v5 : Z, 0 = v2 + v5 -> 0 < v5 -> 0 < v2 -> 4*v2 <> 5*v1. intros. romega. Qed. (* The complete problem *) Lemma Test46 : forall v1 v2 v3 v4 v5 : Z, ((2 * v4) + (5)) + (8 * v2) <= ((4 * v4) + (3 * v4)) + (5 * v4) -> 9 * v4 > (1 * v4) + ((2 * v1) + (0 * v2)) -> ((9 * v3) + (2 * v5)) + (5 * v2) = 3 * v4 -> 0 > 6 * v1 -> (0 * v3) + (6 * v2) <> 2 -> (0 * v3) + (5 * v5) <> ((4 * v2) + (8 * v2)) + (2 * v5) -> 7 * v3 > 5 * v5 -> 0 * v4 >= ((5 * v1) + (4 * v1)) + ((6 * v5) + (3 * v5)) -> 7 * v2 = ((3 * v2) + (6 * v5)) + (7 * v2) -> 0 * v3 > 7 * v1 -> 9 * v2 < 9 * v5 -> (2 * v3) + (8 * v1) <= 5 * v4 -> 5 * v2 = ((5 * v1) + (0 * v5)) + (1 * v2) -> 0 * v5 <= 9 * v2 -> ((7 * v1) + (1 * v3)) + ((2 * v3) + (1 * v3)) >= ((6 * v5) + (4)) + ((1) + (9)) -> False. intros. romega. Qed. coq-8.4pl4/test-suite/success/Tauto.v0000644000175000017500000001203112326224777016671 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Prop. Parameter P : nat -> Prop. Lemma Ex_Wallen : (A -> B /\ C) -> (A -> B) \/ (A -> C). Proof. tauto. Qed. Lemma Ex_Klenne : ~ ~ (A \/ ~ A). Proof. tauto. Qed. Lemma Ex_Klenne' : forall n : nat, ~ ~ (even n \/ ~ even n). Proof. tauto. Qed. Lemma Ex_Klenne'' : ~ ~ ((forall n : nat, even n) \/ ~ (forall m : nat, even m)). Proof. tauto. Qed. Lemma tauto : (forall x : nat, P x) -> forall y : nat, P y. Proof. tauto. Qed. Lemma tauto1 : A -> A. Proof. tauto. Qed. Lemma tauto2 : (A -> B -> C) -> (A -> B) -> A -> C. Proof. tauto. Qed. Lemma a : forall (x0 : A \/ B) (x1 : B /\ C), A -> B. Proof. tauto. Qed. Lemma a2 : (A -> B /\ C) -> (A -> B) \/ (A -> C). Proof. tauto. Qed. Lemma a4 : ~ A -> ~ A. Proof. tauto. Qed. Lemma e2 : ~ ~ (A \/ ~ A). Proof. tauto. Qed. Lemma e4 : ~ ~ (A \/ B -> A \/ B). Proof. tauto. Qed. Lemma y0 : forall (x0 : A) (x1 : ~ A) (x2 : A -> B) (x3 : A \/ B) (x4 : A /\ B), A -> False. Proof. tauto. Qed. Lemma y1 : forall x0 : (A /\ B) /\ C, B. Proof. tauto. Qed. Lemma y2 : forall (x0 : A) (x1 : B), C \/ B. Proof. tauto. Qed. Lemma y3 : forall x0 : A /\ B, B /\ A. Proof. tauto. Qed. Lemma y5 : forall x0 : A \/ B, B \/ A. Proof. tauto. Qed. Lemma y6 : forall (x0 : A -> B) (x1 : A), B. Proof. tauto. Qed. Lemma y7 : forall (x0 : A /\ B -> C) (x1 : B) (x2 : A), C. Proof. tauto. Qed. Lemma y8 : forall (x0 : A \/ B -> C) (x1 : A), C. Proof. tauto. Qed. Lemma y9 : forall (x0 : A \/ B -> C) (x1 : B), C. Proof. tauto. Qed. Lemma y10 : forall (x0 : (A -> B) -> C) (x1 : B), C. Proof. tauto. Qed. (* This example took much time with the old version of Tauto *) Lemma critical_example0 : (~ ~ B -> B) -> (A -> B) -> ~ ~ A -> B. Proof. tauto. Qed. (* Same remark as previously *) Lemma critical_example1 : (~ ~ B -> B) -> (~ B -> ~ A) -> ~ ~ A -> B. Proof. tauto. Qed. (* This example took very much time (about 3mn on a PIII 450MHz in bytecode) with the old Tauto. Now, it's immediate (less than 1s). *) Lemma critical_example2 : (~ A <-> B) -> (~ B <-> A) -> (~ ~ A <-> A). Proof. tauto. Qed. (* This example was a bug *) Lemma old_bug0 : (~ A <-> B) -> (~ (C \/ E) <-> D /\ F) -> (~ (C \/ A \/ E) <-> D /\ B /\ F). Proof. tauto. Qed. (* Another bug *) Lemma old_bug1 : ((A -> B -> False) -> False) -> (B -> False) -> False. Proof. tauto. Qed. (* A bug again *) Lemma old_bug2 : ((((C -> False) -> A) -> ((B -> False) -> A) -> False) -> False) -> (((C -> B -> False) -> False) -> False) -> ~ A -> A. Proof. tauto. Qed. (* A bug from CNF form *) Lemma old_bug3 : ((~ A \/ B) /\ (~ B \/ B) /\ (~ A \/ ~ B) /\ (~ B \/ ~ B) -> False) -> ~ ((A -> B) -> B) -> False. Proof. tauto. Qed. (* sometimes, the behaviour of Tauto depends on the order of the hyps *) Lemma old_bug3bis : ~ ((A -> B) -> B) -> ((~ B \/ ~ B) /\ (~ B \/ ~ A) /\ (B \/ ~ B) /\ (B \/ ~ A) -> False) -> False. Proof. tauto. Qed. (* A bug found by Freek Wiedijk *) Lemma new_bug : ((A <-> B) -> (B <-> C)) -> ((B <-> C) -> (C <-> A)) -> ((C <-> A) -> (A <-> B)) -> (A <-> B). Proof. tauto. Qed. (* A private club has the following rules : * * . rule 1 : Every non-scottish member wears red socks * . rule 2 : Every member wears a kilt or doesn't wear red socks * . rule 3 : The married members don't go out on sunday * . rule 4 : A member goes out on sunday if and only if he is scottish * . rule 5 : Every member who wears a kilt is scottish and married * . rule 6 : Every scottish member wears a kilt * * Actually, no one can be accepted ! *) Section club. Variable Scottish RedSocks WearKilt Married GoOutSunday : Prop. Hypothesis rule1 : ~ Scottish -> RedSocks. Hypothesis rule2 : WearKilt \/ ~ RedSocks. Hypothesis rule3 : Married -> ~ GoOutSunday. Hypothesis rule4 : GoOutSunday <-> Scottish. Hypothesis rule5 : WearKilt -> Scottish /\ Married. Hypothesis rule6 : Scottish -> WearKilt. Lemma NoMember : False. tauto. Qed. End club. (**** Use of Intuition ****) Lemma intu0 : (forall x : nat, P x) /\ B -> (forall y : nat, P y) /\ P 0 \/ B /\ P 0. Proof. intuition. Qed. Lemma intu1 : (forall A : Prop, A \/ ~ A) -> forall x y : nat, x = y \/ x <> y. Proof. intuition. Qed. coq-8.4pl4/test-suite/success/ImplicitTactic.v0000644000175000017500000000104512326224777020502 0ustar stephsteph(* A Wiedijk-Cruz-Filipe style tactic for solving implicit arguments *) (* Declare a term expression with a hole *) Parameter quo : nat -> forall n:nat, n<>0 -> nat. Notation "x / y" := (quo x y _) : nat_scope. (* Declare the tactic for resolving implicit arguments still unresolved after type-checking; it must complete the subgoal to succeed *) Declare Implicit Tactic assumption. Goal forall n d, d<>0 -> { q:nat & { r:nat | d * q + r = n }}. intros. (* Here, assumption is used to solve the implicit argument of quo *) exists (n / d). coq-8.4pl4/test-suite/success/telescope_canonical.v0000644000175000017500000000453112326224777021575 0ustar stephstephStructure Inner := mkI { is :> Type }. Structure Outer := mkO { os :> Inner }. Canonical Structure natInner := mkI nat. Canonical Structure natOuter := mkO natInner. Definition hidden_nat := nat. Axiom P : forall S : Outer, is (os S) -> Prop. Lemma test1 (n : hidden_nat) : P _ n. Admitted. Structure Pnat := mkP { getp : nat }. Definition my_getp := getp. Axiom W : nat -> Prop. (* Fix *) Canonical Structure add1Pnat n := mkP (plus n 1). Definition test_fix n := (refl_equal _ : W (my_getp _) = W (n + 1)). (* Case *) Definition pred n := match n with 0 => 0 | S m => m end. Canonical Structure predSS n := mkP (pred n). Definition test_case x := (refl_equal _ : W (my_getp _) = W (pred x)). Fail Definition test_case' := (refl_equal _ : W (my_getp _) = W (pred 0)). Canonical Structure letPnat' := mkP 0. Definition letin := (let n := 0 in n). Definition test4 := (refl_equal _ : W (getp _) = W letin). Definition test41 := (refl_equal _ : W (my_getp _) = W letin). Definition letin2 (x : nat) := (let n := x in n). Canonical Structure letPnat'' x := mkP (letin2 x). Definition test42 x := (refl_equal _ : W (my_getp _) = W (letin2 x)). Fail Definition test42' x := (refl_equal _ : W (my_getp _) = W x). Structure Morph := mkM { f :> nat -> nat }. Definition my_f := f. Axiom Q : (nat -> nat) -> Prop. (* Lambda *) Canonical Structure addMorh x := mkM (plus x). Definition test_lam x := (refl_equal _ : Q (my_f _) = Q (plus x)). Definition test_lam' := (refl_equal _ : Q (my_f _) = Q (plus 0)). (* Simple tests to justify Sort and Prod as "named". They are already normal, so they cannot loose their names, but still... *) Structure Sot := mkS { T : Type }. Axiom R : Type -> Prop. Canonical Structure tsot := mkS (Type). Definition test_sort := (refl_equal _ : R (T _) = R Type). Canonical Structure tsot2 := mkS (nat -> nat). Definition test_prod := (refl_equal _ : R (T _) = R (nat -> nat)). (* Var *) Section Foo. Variable v : nat. Definition my_v := v. Canonical Structure vP := mkP my_v. Definition test_var := (refl_equal _ : W (getp _) = W my_v). Canonical Structure vP' := mkP v. Definition test_var' := (refl_equal _ : W (my_getp _) = W my_v). End Foo. (* Rel *) Definition test_rel v := (refl_equal _ : W (my_getp _) = W (my_v v)). Goal True. pose (x := test_rel 2). match goal with x := _ : W (my_getp (vP 2)) = _ |- _ => idtac end. apply I. Qed. coq-8.4pl4/test-suite/success/Mod_params.v0000644000175000017500000000253712326224777017671 0ustar stephsteph(* Syntax test - all possible kinds of module parameters *) Module Type SIG. End SIG. Module Type FSIG (X: SIG). End FSIG. Module F (X: SIG). End F. Module Q. End Q. (* #trace Nametab.push;; #trace Nametab.push_short_name;; #trace Nametab.freeze;; #trace Nametab.unfreeze;; #trace Nametab.exists_cci;; *) Module M01. End M01. Module M02 (X: SIG). End M02. Module M03 (X Y: SIG). End M03. Module M04 (X: SIG) (Y: SIG). End M04. Module M05 (X Y: SIG) (Z1 Z: SIG). End M05. Module M06 (X: SIG) (Y: SIG). End M06. Module M07 (X Y: SIG) (Z1 Z: SIG). End M07. Module M08 : SIG. End M08. Module M09 (X: SIG) : SIG. End M09. Module M10 (X Y: SIG) : SIG. End M10. Module M11 (X: SIG) (Y: SIG) : SIG. End M11. Module M12 (X Y: SIG) (Z1 Z: SIG) : SIG. End M12. Module M13 (X: SIG) (Y: SIG) : SIG. End M13. Module M14 (X Y: SIG) (Z1 Z: SIG) : SIG. End M14. Module M15 := F Q. Module M16 (X: FSIG) := X Q. Module M17 (X Y: FSIG) := X Q. Module M18 (X: FSIG) (Y: SIG) := X Y. Module M19 (X Y: FSIG) (Z1 Z: SIG) := X Z. Module M20 (X: FSIG) (Y: SIG) := X Y. Module M21 (X Y: FSIG) (Z1 Z: SIG) := X Z. Module M22 : SIG := F Q. Module M23 (X: FSIG) : SIG := X Q. Module M24 (X Y: FSIG) : SIG := X Q. Module M25 (X: FSIG) (Y: SIG) : SIG := X Y. Module M26 (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z. Module M27 (X: FSIG) (Y: SIG) : SIG := X Y. Module M28 (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z. coq-8.4pl4/test-suite/success/NatRing.v0000644000175000017500000000017512326224777017145 0ustar stephstephRequire Import ArithRing. Lemma l1 : 2 = 1 + 1. ring. Qed. Lemma l2 : forall x : nat, S (S x) = 1 + S x. intro. ring. Qed. coq-8.4pl4/test-suite/success/conv_pbs.v0000644000175000017500000001663312326224777017422 0ustar stephsteph(* A bit complex but realistic example whose last fixpoint definition used to fail in 8.1 because of wrong environment in conversion problems (see revision 9664) *) Require Import List. Require Import Arith. Parameter predicate : Set. Parameter function : Set. Definition variable := nat. Definition x0 := 0. Definition var_eq_dec := eq_nat_dec. Inductive term : Set := | App : function -> term -> term | Var : variable -> term. Definition atom := (predicate * term)%type. Inductive formula : Set := | Atom : atom -> formula | Imply : formula -> formula -> formula | Forall : variable -> formula -> formula. Notation "A --> B" := (Imply A B) (at level 40). Definition substitution range := list (variable * range). Fixpoint remove_assoc (A:Set)(x:variable)(rho: substitution A){struct rho} : substitution A := match rho with | nil => rho | (y,t) :: rho => if var_eq_dec x y then remove_assoc A x rho else (y,t) :: remove_assoc A x rho end. Fixpoint assoc (A:Set)(x:variable)(rho:substitution A){struct rho} : option A := match rho with | nil => None | (y,t) :: rho => if var_eq_dec x y then Some t else assoc A x rho end. Fixpoint subst_term (rho:substitution term)(t:term){struct t} : term := match t with | Var x => match assoc _ x rho with | Some a => a | None => Var x end | App f t' => App f (subst_term rho t') end. Fixpoint subst_formula (rho:substitution term)(A:formula){struct A}:formula := match A with | Atom (p,t) => Atom (p, subst_term rho t) | A --> B => subst_formula rho A --> subst_formula rho B | Forall y A => Forall y (subst_formula (remove_assoc _ y rho) A) (* assume t closed *) end. Definition subst A x t := subst_formula ((x,t):: nil) A. Record Kripke : Type := { worlds: Set; wle : worlds -> worlds -> Type; wle_refl : forall w, wle w w ; wle_trans : forall w w' w'', wle w w' -> wle w' w'' -> wle w w''; domain : Set; vars : variable -> domain; funs : function -> domain -> domain; atoms : worlds -> predicate * domain -> Type; atoms_mon : forall w w', wle w w' -> forall P, atoms w P -> atoms w' P }. Section Sem. Variable K : Kripke. Fixpoint sem (rho: substitution (domain K))(t:term){struct t} : domain K := match t with | Var x => match assoc _ x rho with | Some a => a | None => vars K x end | App f t' => funs K f (sem rho t') end. End Sem. Notation "w <= w'" := (wle _ w w'). Set Implicit Arguments. Reserved Notation "w ||- A" (at level 70). Definition context := list formula. Variable fresh : variable -> context -> Prop. Variable fresh_out : context -> variable. Axiom fresh_out_spec : forall Gamma, fresh (fresh_out Gamma) Gamma. Axiom fresh_peel : forall x A Gamma, fresh x (A::Gamma) -> fresh x Gamma. Fixpoint force (K:Kripke)(rho: substitution (domain K))(w:worlds K)(A:formula) {struct A} : Type := match A with | Atom (p,t) => atoms K w (p, sem K rho t) | A --> B => forall w', w <= w' -> force K rho w' A -> force K rho w' B | Forall x A => forall w', w <= w' -> forall t, force K ((x,t)::remove_assoc _ x rho) w' A end. Notation "w ||- A" := (force _ nil w A). Reserved Notation "Gamma |- A" (at level 70). Reserved Notation "Gamma ; A |- C" (at level 70, A at next level). Inductive context_prefix (Gamma:context) : context -> Type := | CtxPrefixRefl : context_prefix Gamma Gamma | CtxPrefixTrans : forall A Gamma', context_prefix Gamma Gamma' -> context_prefix Gamma (cons A Gamma'). Inductive in_context (A:formula) : list formula -> Prop := | InAxiom : forall Gamma, in_context A (cons A Gamma) | OmWeak : forall Gamma B, in_context A Gamma -> in_context A (cons B Gamma). Inductive prove : list formula -> formula -> Type := | ProofImplyR : forall A B Gamma, prove (cons A Gamma) B -> prove Gamma (A --> B) | ProofForallR : forall x A Gamma, (forall y, fresh y (A::Gamma) -> prove Gamma (subst A x (Var y))) -> prove Gamma (Forall x A) | ProofCont : forall A Gamma Gamma' C, context_prefix (A::Gamma) Gamma' -> (prove_stoup Gamma' A C) -> (Gamma' |- C) where "Gamma |- A" := (prove Gamma A) with prove_stoup : list formula -> formula -> formula -> Type := | ProofAxiom Gamma C: Gamma ; C |- C | ProofImplyL Gamma C : forall A B, (Gamma |- A) -> (prove_stoup Gamma B C) -> (prove_stoup Gamma (A --> B) C) | ProofForallL Gamma C : forall x t A, (prove_stoup Gamma (subst A x t) C) -> (prove_stoup Gamma (Forall x A) C) where " Gamma ; B |- A " := (prove_stoup Gamma B A). Axiom context_prefix_trans : forall Gamma Gamma' Gamma'', context_prefix Gamma Gamma' -> context_prefix Gamma' Gamma'' -> context_prefix Gamma Gamma''. Axiom Weakening : forall Gamma Gamma' A, context_prefix Gamma Gamma' -> Gamma |- A -> Gamma' |- A. Axiom universal_weakening : forall Gamma Gamma', context_prefix Gamma Gamma' -> forall P, Gamma |- Atom P -> Gamma' |- Atom P. Canonical Structure Universal := Build_Kripke context context_prefix CtxPrefixRefl context_prefix_trans term Var App (fun Gamma P => Gamma |- Atom P) universal_weakening. Axiom subst_commute : forall A rho x t, subst_formula ((x,t)::rho) A = subst (subst_formula rho A) x t. Axiom subst_formula_atom : forall rho p t, Atom (p, sem _ rho t) = subst_formula rho (Atom (p,t)). Fixpoint universal_completeness (Gamma:context)(A:formula){struct A} : forall rho:substitution term, force _ rho Gamma A -> Gamma |- subst_formula rho A := match A return forall rho, force _ rho Gamma A -> Gamma |- subst_formula rho A with | Atom (p,t) => fun rho H => eq_rect _ (fun A => Gamma |- A) H _ (subst_formula_atom rho p t) | A --> B => fun rho HImplyAB => let A' := subst_formula rho A in ProofImplyR (universal_completeness (A'::Gamma) B rho (HImplyAB (A'::Gamma)(CtxPrefixTrans A' (CtxPrefixRefl Gamma)) (universal_completeness_stoup A rho (fun C Gamma' Hle p => ProofCont Hle p)))) | Forall x A => fun rho HForallA => ProofForallR x (fun y Hfresh => eq_rect _ _ (universal_completeness Gamma A _ (HForallA Gamma (CtxPrefixRefl Gamma)(Var y))) _ (subst_commute _ _ _ _ )) end with universal_completeness_stoup (Gamma:context)(A:formula){struct A} : forall rho, (forall C Gamma', context_prefix Gamma Gamma' -> Gamma' ; subst_formula rho A |- C -> Gamma' |- C) -> force _ rho Gamma A := match A return forall rho, (forall C Gamma', context_prefix Gamma Gamma' -> Gamma' ; subst_formula rho A |- C -> Gamma' |- C) -> force _ rho Gamma A with | Atom (p,t) as C => fun rho H => H _ Gamma (CtxPrefixRefl Gamma)(ProofAxiom _ _) | A --> B => fun rho H => fun Gamma' Hle HA => universal_completeness_stoup B rho (fun C Gamma'' Hle' p => H C Gamma'' (context_prefix_trans Hle Hle') (ProofImplyL (Weakening Hle' (universal_completeness Gamma' A rho HA)) p)) | Forall x A => fun rho H => fun Gamma' Hle t => (universal_completeness_stoup A ((x,t)::remove_assoc _ x rho) (fun C Gamma'' Hle' p => H C Gamma'' (context_prefix_trans Hle Hle') (ProofForallL x t (subst_formula (remove_assoc _ x rho) A) (eq_rect _ (fun D => Gamma'' ; D |- C) p _ (subst_commute _ _ _ _))))) end. (* A simple example that raised an uncaught exception at some point *) Fail Check fun x => @eq_refl x <: true = true. coq-8.4pl4/test-suite/success/Typeclasses.v0000644000175000017500000000266212326224777020105 0ustar stephstephGeneralizable All Variables. Module mon. Reserved Notation "'return' t" (at level 0). Reserved Notation "x >>= y" (at level 65, left associativity). Record Monad {m : Type -> Type} := { unit : forall {Îą}, Îą -> m Îą where "'return' t" := (unit t) ; bind : forall {Îą Îē}, m Îą -> (Îą -> m Îē) -> m Îē where "x >>= y" := (bind x y) ; bind_unit_left : forall {Îą Îē} (a : Îą) (f : Îą -> m Îē), return a >>= f = f a }. Print Visibility. Print unit. Implicit Arguments unit [[m] [m0] [Îą]]. Implicit Arguments Monad []. Notation "'return' t" := (unit t). (* Test correct handling of existentials and defined fields. *) Class A `(e: T) := { a := True }. Class B `(e_: T) := { e := e_; sg_ass :> A e }. Goal forall `{B T}, a. intros. exact I. Defined. Class B' `(e_: T) := { e' := e_; sg_ass' :> A e_ }. Goal forall `{B' T}, a. intros. exact I. Defined. End mon. (* Correct treatment of dependent goals *) (* First some preliminaries: *) Section sec. Context {N: Type}. Class C (f: N->N) := {}. Class E := { e: N -> N }. Context (g: N -> N) `(E) `(C e) `(forall (f: N -> N), C f -> C (fun x => f x)) (U: forall f: N -> N, C f -> False). (* Now consider the following: *) Let foo := U (fun x => e x). Check foo _. (* This type checks fine, so far so good. But now let's try to get rid of the intermediate constant foo. Surely we can just expand it inline, right? Wrong!: *) Check U (fun x => e x) _. End sec.coq-8.4pl4/test-suite/success/Omega.v0000644000175000017500000000422512326224777016633 0ustar stephsteph Require Import Omega. (* Submitted by Xavier Urbain 18 Jan 2002 *) Lemma lem1 : forall x y : Z, (-5 < x < 5)%Z -> (-5 < y)%Z -> (-5 < x + y + 5)%Z. Proof. intros x y. omega. Qed. (* Proposed by Pierre CrÃĐgut *) Lemma lem2 : forall x : Z, (x < 4)%Z -> (x > 2)%Z -> x = 3%Z. intro. omega. Qed. (* Proposed by Jean-Christophe FilliÃĒtre *) Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z. Proof. intros. omega. Qed. (* Proposed by Jean-Christophe FilliÃĒtre: confusion between an Omega *) (* internal variable and a section variable (June 2001) *) Section A. Variable x y : Z. Hypothesis H : (x > y)%Z. Lemma lem4 : (x > y)%Z. omega. Qed. End A. (* Proposed by Yves Bertot: because a section var, L was wrongly renamed L0 *) (* May 2002 *) Section B. Variable R1 R2 S1 S2 H S : Z. Hypothesis I : (R1 < 0)%Z -> R2 = (R1 + (2 * S1 - 1))%Z. Hypothesis J : (R1 < 0)%Z -> S2 = (S1 - 1)%Z. Hypothesis K : (R1 >= 0)%Z -> R2 = R1. Hypothesis L : (R1 >= 0)%Z -> S2 = S1. Hypothesis M : (H <= 2 * S)%Z. Hypothesis N : (S < H)%Z. Lemma lem5 : (H > 0)%Z. omega. Qed. End B. (* From Nicolas Oury (bug #180): handling -> on Set (fixed Oct 2002) *) Lemma lem6 : forall (A : Set) (i : Z), (i <= 0)%Z -> ((i <= 0)%Z -> A) -> (i <= 0)%Z. intros. omega. Qed. (* Adapted from an example in Nijmegen/FTA/ftc/RefSeparating (Oct 2002) *) Require Import Omega. Section C. Parameter g : forall m : nat, m <> 0 -> Prop. Parameter f : forall (m : nat) (H : m <> 0), g m H. Variable n : nat. Variable ap_n : n <> 0. Let delta := f n ap_n. Lemma lem7 : n = n. omega. Qed. End C. (* Problem of dependencies *) Require Import Omega. Lemma lem8 : forall H : 0 = 0 -> 0 = 0, H = H -> 0 = 0. intros; omega. Qed. (* Bug that what caused by the use of intro_using in Omega *) Require Import Omega. Lemma lem9 : forall p q : nat, ~ (p <= q /\ p < q \/ q <= p /\ p < q) -> p < p \/ p <= p. intros; omega. Qed. (* Check that the interpretation of mult on nat enforces its positivity *) (* Submitted by Hubert Thierry (bug #743) *) (* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z" *) Lemma lem10 : forall n m:nat, le n (plus n (mult n m)). Proof. intros; omega with *. Qed. coq-8.4pl4/test-suite/success/Case15.v0000644000175000017500000000244312326224777016624 0ustar stephsteph(* Check compilation of multiple pattern-matching on terms non apparently of inductive type *) (* Check that the non dependency in y is OK both in V7 and V8 *) Check (fun x (y : Prop) z => match x, y, z return (x = x \/ z = z) with | O, y, z' => or_introl (z' = z') (refl_equal 0) | _, y, O => or_intror _ (refl_equal 0) | x, y, _ => or_introl _ (refl_equal x) end). (* Suggested by Pierre Letouzey (PR#207) *) Inductive Boite : Set := boite : forall b : bool, (if b then nat else (nat * nat)%type) -> Boite. Definition test (B : Boite) := match B return nat with | boite true n => n | boite false (n, m) => n + m end. (* Check lazyness of compilation ... future work Inductive I : Set := c : (b:bool)(if b then bool else nat)->I. Check [x] Cases x of (c (true as y) (true as x)) => (if x then y else true) | (c false O) => true | _ => false end. Check [x] Cases x of (c true true) => true | (c false O) => true | _ => false end. (* Devrait produire ceci mais trouver le type intermediaire est coton ! *) Check [x:I] Cases x of (c b y) => (<[b:bool](if b then bool else nat)->bool>if b then [y](if y then true else false) else [y]Cases y of O => true | (S _) => false end y) end. *) coq-8.4pl4/test-suite/success/Discriminate.v0000644000175000017500000000120412326224777020210 0ustar stephsteph(* Check the behaviour of Discriminate *) (* Check that Discriminate tries Intro until *) Lemma l1 : 0 = 1 -> False. discriminate 1. Qed. Lemma l2 : forall H : 0 = 1, H = H. discriminate H. Qed. (* Check the variants of discriminate *) Goal O = S O -> True. discriminate 1. Undo. intros. discriminate H. Undo. Ltac g x := discriminate x. g H. Abort. Goal (forall x y : nat, x = y -> x = S y) -> True. intros. try discriminate (H O) || exact I. Qed. Goal (forall x y : nat, x = y -> x = S y) -> True. intros. ediscriminate (H O). instantiate (1:=O). Abort. (* Check discriminate on identity *) Goal ~ identity 0 1. discriminate. Qed. coq-8.4pl4/test-suite/success/Case18.v0000644000175000017500000000100112326224777016614 0ustar stephsteph(* Check or-patterns *) Definition g x := match x with ((((1 as x),_) | (_,x)), (_,(2 as y))|(y,_)) => (x,y) end. Check (refl_equal _ : g ((1,2),(3,4)) = (1,3)). Check (refl_equal _ : g ((1,4),(3,2)) = (1,2)). Fixpoint max (n m:nat) {struct m} : nat := match n, m with | S n', S m' => S (max n' m') | 0, p | p, 0 => p end. (* Check bug #1477 *) Inductive I : Set := | A : nat -> nat -> I | B : nat -> nat -> I. Definition foo (x:I) : nat := match x with | A a b | B b a => S b end. coq-8.4pl4/test-suite/success/refine.v0000644000175000017500000000514512326224777017055 0ustar stephsteph (* Refine and let-in's *) Goal exists x : nat, x = 0. refine (let y := 0 + 0 in _). exists y; auto. Save test1. Goal exists x : nat, x = 0. refine (let y := 0 + 0 in ex_intro _ (y + y) _). auto. Save test2. Goal nat. refine (let y := 0 in 0 + _). exact 1. Save test3. (* Example submitted by Yves on coqdev *) Require Import List. Goal forall l : list nat, l = l. Proof. refine (fun l => match l return (l = l) with | nil => _ | O :: l0 => _ | S _ :: l0 => _ end). Abort. (* Submitted by Roland Zumkeller (bug #888) *) (* The Fix and CoFix rules expect a subgoal even for closed components of the (co-)fixpoint *) Goal nat -> nat. refine (fix f (n : nat) : nat := S _ with pred (n : nat) : nat := n for f). exact 0. Qed. (* Submitted by Roland Zumkeller (bug #889) *) (* The types of metas were in metamap and they were not updated when passing through a binder *) Goal forall n : nat, nat -> n = 0. refine (fun n => fix f (i : nat) : n = 0 := match i with | O => _ | S _ => _ end). Abort. (* Submitted by Roland Zumkeller (bug #931) *) (* Don't turn dependent evar into metas *) Goal (forall n : nat, n = 0 -> Prop) -> Prop. intro P. refine (P _ _). reflexivity. Abort. (* Submitted by Jacek Chrzaszcz (bug #1102) *) (* le problčme a été résolu ici par normalisation des evars présentes dans les types d'evars, mais le problčme reste a priori ouvert dans le cas plus général d'evars non instanciées dans les types d'autres evars *) Goal exists n:nat, n=n. refine (ex_intro _ _ _). Abort. (* Used to failed with error not clean *) Definition div : forall x:nat, (forall y:nat, forall n:nat, {q:nat | y = q*n}) -> forall n:nat, {q:nat | x = q*n}. refine (fun m div_rec n => match div_rec m n with | exist _ _ => _ end). Abort. (* Use to fail because sigma was not propagated to get_type_of *) (* Revealed by r9310, fixed in r9359 *) Goal forall f : forall a (H:a=a), Prop, (forall a (H:a = a :> nat), f a H -> True /\ True) -> True. intros. refine (@proj1 _ _ (H 0 _ _)). Abort. (* Use to fail because let-in with metas in the body where rejected because a priori considered as dependent *) Require Import Peano_dec. Definition fact_F : forall (n:nat), (forall m, m nat) -> nat. refine (fun n fact_rec => if eq_nat_dec n 0 then 1 else let fn := fact_rec (n-1) _ in n * fn). Abort. (* Wish 1988: that fun forces unfold in refine *) Goal (forall A : Prop, A -> ~~A). Proof. refine(fun A a f => _). coq-8.4pl4/test-suite/success/DiscrR.v0000644000175000017500000000066312326224777016773 0ustar stephstephRequire Import Reals. Require Import DiscrR. Lemma ex0 : 1%R <> 0%R. Proof. discrR. Qed. Lemma ex1 : 0%R <> 2%R. Proof. discrR. Qed. Lemma ex2 : 4%R <> 3%R. Proof. discrR. Qed. Lemma ex3 : 3%R <> 5%R. Proof. discrR. Qed. Lemma ex4 : (-1)%R <> 0%R. Proof. discrR. Qed. Lemma ex5 : (-2)%R <> (-3)%R. Proof. discrR. Qed. Lemma ex6 : 8%R <> (-3)%R. Proof. discrR. Qed. Lemma ex7 : (-8)%R <> 3%R. Proof. discrR. Qed. coq-8.4pl4/test-suite/success/LetIn.v0000644000175000017500000000054412326224777016616 0ustar stephsteph(* Simple let-in's *) Definition l1 := let P := 0 in P. Definition l2 := let P := nat in P. Definition l3 := let P := True in P. Definition l4 := let P := Prop in P. Definition l5 := let P := Type in P. (* Check casting of let-in *) Definition l6 := let P := 0:nat in P. Definition l7 := let P := True:Prop in P. Definition l8 := let P := True:Type in P. coq-8.4pl4/test-suite/success/Case17.v0000644000175000017500000000346412326224777016632 0ustar stephsteph(* Check the synthesis of predicate from a cast in case of matching of the first component (here [list bool]) of a dependent type (here [sigS]) (Simplification of an example from file parsing2.v of the Coq'Art exercises) *) Require Import List. Variable parse_rel : list bool -> list bool -> nat -> Prop. Variables (l0 : list bool) (rec : forall l' : list bool, length l' <= S (length l0) -> {l'' : list bool & {t : nat | parse_rel l' l'' t /\ length l'' <= length l'}} + {(forall (l'' : list bool) (t : nat), ~ parse_rel l' l'' t)}). Axiom HHH : forall A : Prop, A. Check (match rec l0 (HHH _) with | inleft (existS (false :: l1) _) => inright _ (HHH _) | inleft (existS (true :: l1) (exist t1 (conj Hp Hl))) => inright _ (HHH _) | inleft (existS _ _) => inright _ (HHH _) | inright Hnp => inright _ (HHH _) end :{l'' : list bool & {t : nat | parse_rel (true :: l0) l'' t /\ length l'' <= S (length l0)}} + {(forall (l'' : list bool) (t : nat), ~ parse_rel (true :: l0) l'' t)}). (* The same but with relative links to l0 and rec *) Check (fun (l0 : list bool) (rec : forall l' : list bool, length l' <= S (length l0) -> {l'' : list bool & {t : nat | parse_rel l' l'' t /\ length l'' <= length l'}} + {(forall (l'' : list bool) (t : nat), ~ parse_rel l' l'' t)}) => match rec l0 (HHH _) with | inleft (existS (false :: l1) _) => inright _ (HHH _) | inleft (existS (true :: l1) (exist t1 (conj Hp Hl))) => inright _ (HHH _) | inleft (existS _ _) => inright _ (HHH _) | inright Hnp => inright _ (HHH _) end :{l'' : list bool & {t : nat | parse_rel (true :: l0) l'' t /\ length l'' <= S (length l0)}} + {(forall (l'' : list bool) (t : nat), ~ parse_rel (true :: l0) l'' t)}). coq-8.4pl4/test-suite/success/Omega2.v0000644000175000017500000000137312326224777016716 0ustar stephstephRequire Import ZArith Omega. (* Submitted by Yegor Bryukhov (#922) *) Open Scope Z_scope. Lemma Test46 : forall v1 v2 v3 v4 v5 : Z, ((2 * v4) + (5)) + (8 * v2) <= ((4 * v4) + (3 * v4)) + (5 * v4) -> 9 * v4 > (1 * v4) + ((2 * v1) + (0 * v2)) -> ((9 * v3) + (2 * v5)) + (5 * v2) = 3 * v4 -> 0 > 6 * v1 -> (0 * v3) + (6 * v2) <> 2 -> (0 * v3) + (5 * v5) <> ((4 * v2) + (8 * v2)) + (2 * v5) -> 7 * v3 > 5 * v5 -> 0 * v4 >= ((5 * v1) + (4 * v1)) + ((6 * v5) + (3 * v5)) -> 7 * v2 = ((3 * v2) + (6 * v5)) + (7 * v2) -> 0 * v3 > 7 * v1 -> 9 * v2 < 9 * v5 -> (2 * v3) + (8 * v1) <= 5 * v4 -> 5 * v2 = ((5 * v1) + (0 * v5)) + (1 * v2) -> 0 * v5 <= 9 * v2 -> ((7 * v1) + (1 * v3)) + ((2 * v3) + (1 * v3)) >= ((6 * v5) + (4)) + ((1) + (9)) -> False. intros. omega. Qed. coq-8.4pl4/test-suite/success/import_mod.v0000644000175000017500000000174112326224777017754 0ustar stephsteph Definition p := 0. Definition m := 0. Module Test_Import. Module P. Definition p := 1. End P. Module M. Import P. Definition m := p. End M. Module N. Import M. Lemma th0 : p = 0. reflexivity. Qed. End N. (* M and P should be closed *) Lemma th1 : m = 0 /\ p = 0. split; reflexivity. Qed. Import N. (* M and P should still be closed *) Lemma th2 : m = 0 /\ p = 0. split; reflexivity. Qed. End Test_Import. (********************************************************************) Module Test_Export. Module P. Definition p := 1. End P. Module M. Export P. Definition m := p. End M. Module N. Export M. Lemma th0 : p = 1. reflexivity. Qed. End N. (* M and P should be closed *) Lemma th1 : m = 0 /\ p = 0. split; reflexivity. Qed. Import N. (* M and P should now be opened *) Lemma th2 : m = 1 /\ p = 1. split; reflexivity. Qed. End Test_Export. coq-8.4pl4/test-suite/success/Generalization.v0000644000175000017500000000043212326224777020552 0ustar stephstephGeneralizable All Variables. Check `(a = 0). Check `(a = 0)%type. Definition relation A := A -> A -> Prop. Definition equivalence `(R : relation A) := True. Check (`(@equivalence A R)). Definition a_eq_b : `( a = 0 /\ a = b /\ b > c \/ d = e /\ d = 1). Admitted. Print a_eq_b. coq-8.4pl4/test-suite/success/Nsatz.v0000644000175000017500000003366312326224777016712 0ustar stephsteph(* compile en user 3m39.915s sur cachalot *) Require Import Nsatz. (* Example with a generic domain *) Section test. Context {A:Type}`{Aid:Integral_domain A}. Lemma example3 : forall x y z, x+y+z==0 -> x*y+x*z+y*z==0-> x*y*z==0 -> x^3%Z==0. Proof. Time nsatz. Qed. Lemma example4 : forall x y z u, x+y+z+u==0 -> x*y+x*z+x*u+y*z+y*u+z*u==0-> x*y*z+x*y*u+x*z*u+y*z*u==0-> x*y*z*u==0 -> x^4%Z==0. Proof. Time nsatz. Qed. Lemma example5 : forall x y z u v, x+y+z+u+v==0 -> x*y+x*z+x*u+x*v+y*z+y*u+y*v+z*u+z*v+u*v==0-> x*y*z+x*y*u+x*y*v+x*z*u+x*z*v+x*u*v+y*z*u+y*z*v+y*u*v+z*u*v==0-> x*y*z*u+y*z*u*v+z*u*v*x+u*v*x*y+v*x*y*z==0 -> x*y*z*u*v==0 -> x^5%Z==0. Proof. Time nsatz. Qed. Goal forall x y:Z, x = y -> (x+0)%Z = (y*1+0)%Z. nsatz. Qed. Require Import Reals. Goal forall x y:R, x = y -> (x+0)%R = (y*1+0)%R. nsatz. Qed. Goal forall a b c x:R, a = b -> b = c -> (a*a)%R = (c*c)%R. nsatz. Qed. End test. Section Geometry. (* See the interactive pictures of Laurent ThÃĐry on http://www-sop.inria.fr/marelle/CertiGeo/ and research paper on https://docs.google.com/fileview?id=0ByhB3nPmbnjTYzFiZmIyNGMtYTkwNC00NWFiLWJiNzEtODM4NmVkYTc2NTVk&hl=fr *) Require Import List. Require Import Reals. Record point:Type:={ X:R; Y:R}. Definition collinear(A B C:point):= (X A - X B)*(Y C - Y B)-(Y A - Y B)*(X C - X B)=0. Definition parallel (A B C D:point):= ((X A)-(X B))*((Y C)-(Y D))=((Y A)-(Y B))*((X C)-(X D)). Definition notparallel (A B C D:point)(x:R):= x*(((X A)-(X B))*((Y C)-(Y D))-((Y A)-(Y B))*((X C)-(X D)))=1. Definition orthogonal (A B C D:point):= ((X A)-(X B))*((X C)-(X D))+((Y A)-(Y B))*((Y C)-(Y D))=0. Definition equal2(A B:point):= (X A)=(X B) /\ (Y A)=(Y B). Definition equal3(A B:point):= ((X A)-(X B))^2%Z+((Y A)-(Y B))^2%Z = 0. Definition nequal2(A B:point):= (X A)<>(X B) \/ (Y A)<>(Y B). Definition nequal3(A B:point):= not (((X A)-(X B))^2%Z+((Y A)-(Y B))^2%Z = 0). Definition middle(A B I:point):= 2%R*(X I)=(X A)+(X B) /\ 2%R*(Y I)=(Y A)+(Y B). Definition distance2(A B:point):= (X B - X A)^2%Z + (Y B - Y A)^2%Z. (* AB = CD *) Definition samedistance2(A B C D:point):= (X B - X A)^2%Z + (Y B - Y A)^2%Z = (X D - X C)^2%Z + (Y D - Y C)^2%Z. Definition determinant(A O B:point):= (X A - X O)*(Y B - Y O) - (Y A - Y O)*(X B - X O). Definition scalarproduct(A O B:point):= (X A - X O)*(X B - X O) + (Y A - Y O)*(Y B - Y O). Definition norm2(A O B:point):= ((X A - X O)^2%Z+(Y A - Y O)^2%Z)*((X B - X O)^2%Z+(Y B - Y O)^2%Z). Definition equaldistance(A B C D:point):= ((X B) - (X A))^2%Z + ((Y B) - (Y A))^2%Z = ((X D) - (X C))^2%Z + ((Y D) - (Y C))^2%Z. Definition equaltangente(A B C D E F:point):= let s1:= determinant A B C in let c1:= scalarproduct A B C in let s2:= determinant D E F in let c2:= scalarproduct D E F in s1 * c2 = s2 * c1. Ltac cnf2 f := match f with | ?A \/ (?B /\ ?C) => let c1 := cnf2 (A\/B) in let c2 := cnf2 (A\/C) in constr:(c1/\c2) | (?B /\ ?C) \/ ?A => let c1 := cnf2 (B\/A) in let c2 := cnf2 (C\/A) in constr:(c1/\c2) | (?A \/ ?B) \/ ?C => let c1 := cnf2 (B\/C) in cnf2 (A \/ c1) | _ => f end with cnf f := match f with | ?A \/ ?B => let c1 := cnf A in let c2 := cnf B in cnf2 (c1 \/ c2) | ?A /\ ?B => let c1 := cnf A in let c2 := cnf B in constr:(c1 /\ c2) | _ => f end. Ltac scnf := match goal with | |- ?f => let c := cnf f in assert c;[repeat split| tauto] end. Ltac disj_to_pol f := match f with | ?a = ?b \/ ?g => let p := disj_to_pol g in constr:((a - b)* p) | ?a = ?b => constr:(a - b) end. Lemma fastnsatz1:forall x y:R, x - y = 0 -> x = y. nsatz. Qed. Ltac fastnsatz:= try trivial; try apply fastnsatz1; try trivial; nsatz. Ltac proof_pol_disj := match goal with | |- ?g => let p := disj_to_pol g in let h := fresh "hp" in assert (h:p = 0); [idtac| prod_disj h p] | _ => idtac end with prod_disj h p := match goal with | |- ?a = ?b \/ ?g => match p with | ?q * ?p1 => let h0 := fresh "hp" in let h1 := fresh "hp" in let h2 := fresh "hp" in assert (h0:a - b = 0 \/ p1 = 0); [apply Rmult_integral; exact h| destruct h0 as [h1|h2]; [left; fastnsatz| right; prod_disj h2 p1]] end | _ => fastnsatz end. (* Goal forall a b c d e f:R, a=b \/ c=d \/ e=f \/ e=a. intros. scnf; proof_pol_disj . admit.*) Ltac geo_unfold := unfold collinear, parallel, notparallel, orthogonal, equal2, equal3, nequal2, nequal3, middle, samedistance2, determinant, scalarproduct, norm2, distance2, equaltangente, determinant, scalarproduct, equaldistance. Ltac geo_rewrite_hyps:= repeat (match goal with | h:X _ = _ |- _ => rewrite h in *; clear h | h:Y _ = _ |- _ => rewrite h in *; clear h end). Ltac geo_split_hyps:= repeat (match goal with | h:_ /\ _ |- _ => destruct h end). Ltac geo_begin:= geo_unfold; intros; geo_rewrite_hyps; geo_split_hyps; scnf; proof_pol_disj. (* Examples *) Lemma medians: forall A B C A1 B1 C1 H:point, middle B C A1 -> middle A C B1 -> middle A B C1 -> collinear A A1 H -> collinear B B1 H -> collinear C C1 H \/ collinear A B C. Proof. geo_begin. idtac "Medians". Time nsatz. (*Finished transaction in 2. secs (2.69359u,0.s) *) Qed. Lemma Pythagore: forall A B C:point, orthogonal A B A C -> distance2 A C + distance2 A B = distance2 B C. Proof. geo_begin. idtac "Pythagore". Time nsatz. (*Finished transaction in 0. secs (0.354946u,0.s) *) Qed. Lemma Thales: forall O A B C D:point, collinear O A C -> collinear O B D -> parallel A B C D -> (distance2 O B * distance2 O C = distance2 O D * distance2 O A /\ distance2 O B * distance2 C D = distance2 O D * distance2 A B) \/ collinear O A B. geo_begin. idtac "Thales". Time nsatz. (*Finished transaction in 2. secs (1.598757u,0.s)*) Time nsatz. Qed. Lemma segments_of_chords: forall A B C D M O:point, equaldistance O A O B -> equaldistance O A O C -> equaldistance O A O D -> collinear A B M -> collinear C D M -> (distance2 M A) * (distance2 M B) = (distance2 M C) * (distance2 M D) \/ parallel A B C D. Proof. geo_begin. idtac "segments_of_chords". Time nsatz. (*Finished transaction in 3. secs (2.704589u,0.s) *) Qed. Lemma isoceles: forall A B C:point, equaltangente A B C B C A -> distance2 A B = distance2 A C \/ collinear A B C. Proof. geo_begin. Time nsatz. (*Finished transaction in 1. secs (1.140827u,0.s)*) Qed. Lemma minh: forall A B C D O E H I:point, X A = 0 -> Y A = 0 -> Y O = 0 -> equaldistance O A O B -> equaldistance O A O C -> equaldistance O A O D -> orthogonal A C B D -> collinear A C E -> collinear B D E -> collinear A B H -> orthogonal E H A B -> collinear C D I -> middle C D I -> collinear H E I \/ (X C)^2%Z * (X B)^5%Z * (X O)^2%Z * (X C - 2%Z * X O)^3%Z * (-2%Z * X O + X B)=0 \/ parallel A C B D. Proof. geo_begin. idtac "minh". Time nsatz with radicalmax :=1%N strategy:=1%Z parameters:=(X O::X B::X C::nil) variables:= (@nil R). (*Finished transaction in 13. secs (10.102464u,0.s) *) Qed. Lemma Pappus: forall A B C A1 B1 C1 P Q S:point, X A = 0 -> Y A = 0 -> Y B = 0 -> Y C = 0 -> collinear A1 B1 C1 -> collinear A B1 P -> collinear A1 B P -> collinear A C1 Q -> collinear A1 C Q -> collinear B C1 S -> collinear B1 C S -> collinear P Q S \/ (Y A1 - Y B1)^2%Z=0 \/ (X A = X B1) \/ (X A1 = X C) \/ (X C = X B1) \/ parallel A B1 A1 B \/ parallel A C1 A1 C \/ parallel B C1 B1 C. Proof. geo_begin. idtac "Pappus". Time nsatz with radicalmax :=1%N strategy:=0%Z parameters:=(X B::X A1::Y A1::X B1::Y B1::X C::Y C1::nil) variables:= (X B :: X A1 :: Y A1 :: X B1 :: Y B1 :: X C :: Y C1 :: X C1 :: Y P :: X P :: Y Q :: X Q :: Y S :: X S :: nil). (*Finished transaction in 8. secs (7.795815u,0.000999999999999s) *) Qed. Lemma Simson: forall A B C O D E F G:point, X A = 0 -> Y A = 0 -> equaldistance O A O B -> equaldistance O A O C -> equaldistance O A O D -> orthogonal E D B C -> collinear B C E -> orthogonal F D A C -> collinear A C F -> orthogonal G D A B -> collinear A B G -> collinear E F G \/ (X C)^2%Z = 0 \/ (Y C)^2%Z = 0 \/ (X B)^2%Z = 0 \/ (Y B)^2%Z = 0 \/ (Y C - Y B)^2%Z = 0 \/ equal3 B A \/ equal3 A C \/ (X C - X B)^2%Z = 0 \/ equal3 B C. Proof. geo_begin. idtac "Simson". Time nsatz with radicalmax :=1%N strategy:=0%Z parameters:=(X B::Y B::X C::Y C::Y D::nil) variables:= (@nil R). (* compute -[X Y]. *) (*Finished transaction in 8. secs (7.550852u,0.s) *) Qed. Lemma threepoints: forall A B C A1 B1 A2 B2 H1 H2 H3:point, (* H1 intersection of bisections *) middle B C A1 -> orthogonal H1 A1 B C -> middle A C B1 -> orthogonal H1 B1 A C -> (* H2 intersection of medians *) collinear A A1 H2 -> collinear B B1 H2 -> (* H3 intersection of altitudes *) collinear B C A2 -> orthogonal A A2 B C -> collinear A C B2 -> orthogonal B B2 A C -> collinear A A1 H3 -> collinear B B1 H3 -> collinear H1 H2 H3 \/ collinear A B C. Proof. geo_begin. idtac "threepoints". Time nsatz. (*Finished transaction in 7. secs (6.282045u,0.s) *) Qed. Lemma Feuerbach: forall A B C A1 B1 C1 O A2 B2 C2 O2:point, forall r r2:R, X A = 0 -> Y A = 0 -> X B = 1 -> Y B = 0-> middle A B C1 -> middle B C A1 -> middle C A B1 -> distance2 O A1 = distance2 O B1 -> distance2 O A1 = distance2 O C1 -> collinear A B C2 -> orthogonal A B O2 C2 -> collinear B C A2 -> orthogonal B C O2 A2 -> collinear A C B2 -> orthogonal A C O2 B2 -> distance2 O2 A2 = distance2 O2 B2 -> distance2 O2 A2 = distance2 O2 C2 -> r^2%Z = distance2 O A1 -> r2^2%Z = distance2 O2 A2 -> distance2 O O2 = (r + r2)^2%Z \/ distance2 O O2 = (r - r2)^2%Z \/ collinear A B C. Proof. geo_begin. idtac "Feuerbach". Time nsatz. (*Finished transaction in 21. secs (19.021109u,0.s)*) Qed. Lemma Euler_circle: forall A B C A1 B1 C1 A2 B2 C2 O:point, middle A B C1 -> middle B C A1 -> middle C A B1 -> orthogonal A B C C2 -> collinear A B C2 -> orthogonal B C A A2 -> collinear B C A2 -> orthogonal A C B B2 -> collinear A C B2 -> distance2 O A1 = distance2 O B1 -> distance2 O A1 = distance2 O C1 -> (distance2 O A2 = distance2 O A1 /\distance2 O B2 = distance2 O A1 /\distance2 O C2 = distance2 O A1) \/ collinear A B C. Proof. geo_begin. idtac "Euler_circle 3 goals". Time nsatz. (*Finished transaction in 13. secs (11.208296u,0.124981s)*) Time nsatz. (*Finished transaction in 10. secs (8.846655u,0.s)*) Time nsatz. (*Finished transaction in 11. secs (9.186603u,0.s)*) Qed. Lemma Desargues: forall A B C A1 B1 C1 P Q R S:point, X S = 0 -> Y S = 0 -> Y A = 0 -> collinear A S A1 -> collinear B S B1 -> collinear C S C1 -> collinear B1 C1 P -> collinear B C P -> collinear A1 C1 Q -> collinear A C Q -> collinear A1 B1 R -> collinear A B R -> collinear P Q R \/ X A = X B \/ X A = X C \/ X B = X C \/ X A = 0 \/ Y B = 0 \/ Y C = 0 \/ collinear S B C \/ parallel A C A1 C1 \/ parallel A B A1 B1. Proof. geo_begin. idtac "Desargues". Time let lv := rev (X A :: X B :: Y B :: X C :: Y C :: Y A1 :: X A1 :: Y B1 :: Y C1 :: X R :: Y R :: X Q :: Y Q :: X P :: Y P :: X C1 :: X B1 :: nil) in nsatz with radicalmax :=1%N strategy:=0%Z parameters:=(X A::X B::Y B::X C::Y C::X A1::Y B1::Y C1::nil) variables:= lv. (*Finished transaction in 8. secs (8.02578u,0.001s)*) Qed. Lemma chords: forall O A B C D M:point, equaldistance O A O B -> equaldistance O A O C -> equaldistance O A O D -> collinear A B M -> collinear C D M -> scalarproduct A M B = scalarproduct C M D \/ parallel A B C D. Proof. geo_begin. idtac "chords". Time nsatz. (*Finished transaction in 4. secs (3.959398u,0.s)*) Qed. Lemma Ceva: forall A B C D E F M:point, collinear M A D -> collinear M B E -> collinear M C F -> collinear B C D -> collinear E A C -> collinear F A B -> (distance2 D B) * (distance2 E C) * (distance2 F A) = (distance2 D C) * (distance2 E A) * (distance2 F B) \/ collinear A B C. Proof. geo_begin. idtac "Ceva". Time nsatz. (*Finished transaction in 105. secs (104.121171u,0.474928s)*) Qed. Lemma bissectrices: forall A B C M:point, equaltangente C A M M A B -> equaltangente A B M M B C -> equaltangente B C M M C A \/ equal3 A B. Proof. geo_begin. idtac "bissectrices". Time nsatz. (*Finished transaction in 2. secs (1.937705u,0.s)*) Qed. Lemma bisections: forall A B C A1 B1 C1 H:point, middle B C A1 -> orthogonal H A1 B C -> middle A C B1 -> orthogonal H B1 A C -> middle A B C1 -> orthogonal H C1 A B \/ collinear A B C. Proof. geo_begin. idtac "bisections". Time nsatz. (*Finished transaction in 2. secs (2.024692u,0.002s)*) Qed. Lemma altitudes: forall A B C A1 B1 C1 H:point, collinear B C A1 -> orthogonal A A1 B C -> collinear A C B1 -> orthogonal B B1 A C -> collinear A B C1 -> orthogonal C C1 A B -> collinear A A1 H -> collinear B B1 H -> collinear C C1 H \/ equal2 A B \/ collinear A B C. Proof. geo_begin. idtac "altitudes". Time nsatz. (*Finished transaction in 3. secs (3.001544u,0.s)*) Time nsatz. (*Finished transaction in 4. secs (3.113527u,0.s)*) Qed. Lemma hauteurs:forall A B C A1 B1 C1 H:point, collinear B C A1 -> orthogonal A A1 B C -> collinear A C B1 -> orthogonal B B1 A C -> collinear A B C1 -> orthogonal C C1 A B -> collinear A A1 H -> collinear B B1 H -> collinear C C1 H \/ collinear A B C. geo_begin. idtac "hauteurs". Time let lv := constr:(Y A1 :: X A1 :: Y B1 :: X B1 :: Y A :: Y B :: X B :: X A :: X H :: Y C :: Y C1 :: Y H :: X C1 :: X C :: (@Datatypes.nil R)) in nsatz with radicalmax := 2%N strategy := 1%Z parameters := (@Datatypes.nil R) variables := lv. (*Finished transaction in 5. secs (4.360337u,0.008999s)*) Qed. End Geometry. coq-8.4pl4/test-suite/success/ltac.v0000644000175000017500000001412312326224777016524 0ustar stephsteph(* The tactic language *) (* Submitted by Pierre Crégut *) (* Checks substitution of x *) Ltac f x := unfold x; idtac. Lemma lem1 : 0 + 0 = 0. f plus. reflexivity. Qed. (* Submitted by Pierre Crégut *) (* Check syntactic correctness *) Ltac F x := idtac; G x with G y := idtac; F y. (* Check that Match Context keeps a closure *) Ltac U := let a := constr:I in match goal with | |- _ => apply a end. Lemma lem2 : True. U. Qed. (* Check that Match giving non-tactic arguments are evaluated at Let-time *) Ltac B := let y := (match goal with | z:_ |- _ => z end) in (intro H1; exact y). Lemma lem3 : True -> False -> True -> False. intros H H0. B. (* y is H0 if at let-time, H1 otherwise *) Qed. (* Checks the matching order of hypotheses *) Ltac Y := match goal with | x:_,y:_ |- _ => apply x end. Ltac Z := match goal with | y:_,x:_ |- _ => apply x end. Lemma lem4 : (True -> False) -> (False -> False) -> False. intros H H0. Z. (* Apply H0 *) Y. (* Apply H *) exact I. Qed. (* Check backtracking *) Lemma back1 : 0 = 1 -> 0 = 0 -> 1 = 1 -> 0 = 0. intros; match goal with | _:(0 = ?X1),_:(1 = 1) |- _ => exact (refl_equal X1) end. Qed. Lemma back2 : 0 = 0 -> 0 = 1 -> 1 = 1 -> 0 = 0. intros; match goal with | _:(0 = ?X1),_:(1 = 1) |- _ => exact (refl_equal X1) end. Qed. Lemma back3 : 0 = 0 -> 1 = 1 -> 0 = 1 -> 0 = 0. intros; match goal with | _:(0 = ?X1),_:(1 = 1) |- _ => exact (refl_equal X1) end. Qed. (* Check context binding *) Ltac sym t := match constr:t with | context C[(?X1 = ?X2)] => context C [X1 = X2] end. Lemma sym : 0 <> 1 -> 1 <> 0. intro H. let t := sym type of H in assert t. exact H. intro H1. apply H. symmetry . assumption. Qed. (* Check context binding in match goal *) (* This wasn't working in V8.0pl1, as the list of matched hyps wasn't empty *) Ltac sym' := match goal with | _:True |- context C[(?X1 = ?X2)] => let t := context C [X2 = X1] in assert t end. Lemma sym' : True -> 0 <> 1 -> 1 <> 0. intros Ht H. sym'. exact H. intro H1. apply H. symmetry . assumption. Qed. (* Check that fails abort the current match context *) Lemma decide : True \/ False. match goal with | _ => fail 1 | _ => right end || left. exact I. Qed. (* Check that "match c with" backtracks on subterms *) Lemma refl : 1 = 1. let t := (match constr:(1 = 2) with | context [(S ?X1)] => constr:(refl_equal X1:1 = 1) end) in assert (H := t). assumption. Qed. (* Note that backtracking in "match c with" is only on type-checking not on evaluation of tactics. E.g., this does not work Lemma refl : (1)=(1). Match (1)=(2) With [[(S ?1)]] -> Apply (refl_equal nat ?1). Qed. *) (* Check the precedences of rel context, ltac context and vars context *) (* (was wrong in V8.0) *) Ltac check_binding y := cut ((fun y => y) = S). Goal True. check_binding true. Abort. (* Check that variables explicitly parsed as ltac variables are not seen as intro pattern or constr (bug #984) *) Ltac afi tac := intros; tac. Goal 1 = 2. afi ltac:auto. Abort. (* Tactic Notation avec listes *) Tactic Notation "pat" hyp(id) "occs" integer_list(l) := pattern id at l. Goal forall x, x=0 -> x=x. intro x. pat x occs 1 3. Abort. Tactic Notation "revert" ne_hyp_list(l) := generalize l; clear l. Goal forall a b c, a=0 -> b=c+a. intros. revert a b c H. Abort. (* Used to fail until revision 9280 because of a parasitic App node with empty args *) Goal True. match constr:@None with @None => exact I end. Abort. (* Check second-order pattern unification *) Ltac to_exist := match goal with |- forall x y, @?P x y => let Q := eval lazy beta in (exists x, forall y, P x y) in assert (Q->Q) end. Goal forall x y : nat, x = y. to_exist. exact (fun H => H). Abort. (* Used to fail in V8.1 *) Tactic Notation "test" constr(t) integer(n) := set (k := t) at n. Goal forall x : nat, x = 1 -> x + x + x = 3. intros x H. test x 2. Abort. (* Utilisation de let rec sans arguments *) Ltac is := let rec i := match goal with |- ?A -> ?B => intro; i | _ => idtac end in i. Goal True -> True -> True. is. exact I. Abort. (* Interférence entre espaces des noms *) Ltac O := intro. Ltac Z1 t := set (x:=t). Ltac Z2 t := t. Goal True -> True. Z1 O. Z2 ltac:O. exact I. Qed. (* Illegal application used to make Ltac loop. *) Section LtacLoopTest. Ltac f x := idtac. Goal True. Timeout 1 try f()(). Abort. End LtacLoopTest. (* Test binding of open terms *) Ltac test_open_match z := match z with (forall y x, ?h = 0) => assert (forall x y, h = x + y) end. Goal True. test_open_match (forall z y, y + z = 0). reflexivity. apply I. Qed. (* Test binding of open terms with non linear matching *) Ltac f_non_linear t := match t with (forall x y, ?u = 0) -> (forall y x, ?u = 0) => assert (forall x y:nat, u = u) end. Goal True. f_non_linear ((forall x y, x+y = 0) -> (forall x y, y+x = 0)). reflexivity. f_non_linear ((forall a b, a+b = 0) -> (forall a b, b+a = 0)). reflexivity. f_non_linear ((forall a b, a+b = 0) -> (forall x y, y+x = 0)). reflexivity. f_non_linear ((forall x y, x+y = 0) -> (forall a b, b+a = 0)). reflexivity. f_non_linear ((forall x y, x+y = 0) -> (forall y x, x+y = 0)). reflexivity. f_non_linear ((forall x y, x+y = 0) -> (forall y x, y+x = 0)) (* should fail *) || exact I. Qed. (* Test regular failure when clear/intro breaks soundness of the interpretation of terms in current environment *) Ltac g y := clear y; assert (y=y). Goal forall x:nat, True. intro x. Fail g x. Abort. Ltac h y := assert (y=y). Goal forall x:nat, True. intro x. Fail clear x; f x. Abort. (* Do not consider evars as unification holes in Ltac matching (and at least not as holes unrelated to the original evars) [Example adapted from Ynot code] *) Ltac not_eq e1 e2 := match e1 with | e2 => fail 1 | _ => idtac end. Goal True. evar(foo:nat). let evval := eval compute in foo in not_eq evval 1. let evval := eval compute in foo in not_eq 1 evval. Abort. (* Check that this returns an error and not an anomaly (see r13667) *) Fail Local Tactic Notation "myintro" := intro. coq-8.4pl4/test-suite/success/Case9.v0000644000175000017500000000427512326224777016554 0ustar stephstephInductive List (A : Set) : Set := | Nil : List A | Cons : A -> List A -> List A. Inductive eqlong : List nat -> List nat -> Prop := | eql_cons : forall (n m : nat) (x y : List nat), eqlong x y -> eqlong (Cons nat n x) (Cons nat m y) | eql_nil : eqlong (Nil nat) (Nil nat). Parameter V1 : eqlong (Nil nat) (Nil nat) \/ ~ eqlong (Nil nat) (Nil nat). Parameter V2 : forall (a : nat) (x : List nat), eqlong (Nil nat) (Cons nat a x) \/ ~ eqlong (Nil nat) (Cons nat a x). Parameter V3 : forall (a : nat) (x : List nat), eqlong (Cons nat a x) (Nil nat) \/ ~ eqlong (Cons nat a x) (Nil nat). Parameter V4 : forall (a : nat) (x : List nat) (b : nat) (y : List nat), eqlong (Cons nat a x) (Cons nat b y) \/ ~ eqlong (Cons nat a x) (Cons nat b y). Parameter nff : forall (n m : nat) (x y : List nat), ~ eqlong x y -> ~ eqlong (Cons nat n x) (Cons nat m y). Parameter inv_r : forall (n : nat) (x : List nat), ~ eqlong (Nil nat) (Cons nat n x). Parameter inv_l : forall (n : nat) (x : List nat), ~ eqlong (Cons nat n x) (Nil nat). Fixpoint eqlongdec (x y : List nat) {struct x} : eqlong x y \/ ~ eqlong x y := match x, y return (eqlong x y \/ ~ eqlong x y) with | Nil, Nil => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil | Nil, Cons a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x) | Cons a x as L, Nil => or_intror (eqlong L (Nil nat)) (inv_l a x) | Cons a x as L1, Cons b y as L2 => match eqlongdec x y return (eqlong L1 L2 \/ ~ eqlong L1 L2) with | or_introl h => or_introl (~ eqlong L1 L2) (eql_cons a b x y h) | or_intror h => or_intror (eqlong L1 L2) (nff a b x y h) end end. Type match Nil nat as x, Nil nat as y return (eqlong x y \/ ~ eqlong x y) with | Nil, Nil => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil | Nil, Cons a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x) | Cons a x as L, Nil => or_intror (eqlong L (Nil nat)) (inv_l a x) | Cons a x as L1, Cons b y as L2 => match eqlongdec x y return (eqlong L1 L2 \/ ~ eqlong L1 L2) with | or_introl h => or_introl (~ eqlong L1 L2) (eql_cons a b x y h) | or_intror h => or_intror (eqlong L1 L2) (nff a b x y h) end end. coq-8.4pl4/test-suite/success/options.v0000644000175000017500000000126212326224777017274 0ustar stephsteph(* Check that the syntax for options works *) Set Implicit Arguments. Unset Strict Implicit. Set Strict Implicit. Unset Implicit Arguments. Test Implicit Arguments. Set Printing Coercions. Unset Printing Coercions. Test Printing Coercions. Set Silent. Unset Silent. Test Silent. Set Printing Depth 100. Test Printing Depth. Parameter i : bool -> nat. Coercion i : bool >-> nat. Add Printing Coercion i. Remove Printing Coercion i. Test Printing Coercion for i. Test Printing Let. Test Printing If. Remove Printing Let sig. Remove Printing If bool. Unset Printing Synth. Set Printing Synth. Test Printing Synth. Unset Printing Wildcard. Set Printing Wildcard. Test Printing Wildcard. coq-8.4pl4/test-suite/success/polymorphism.v0000644000175000017500000000033312326224777020341 0ustar stephsteph(* Some tests of sort-polymorphisme *) Section S. Variable A:Type. (* Definition f (B:Type) := (A * B)%type. *) Inductive I (B:Type) : Type := prod : A->B->I B. End S. (* Check f nat nat : Set. *) Check I nat nat : Set.coq-8.4pl4/test-suite/success/Projection.v0000644000175000017500000000217712326224777017723 0ustar stephstephStructure S : Type := {Dom : Type; Op : Dom -> Dom -> Dom}. Check (fun s : S => Dom s). Check (fun s : S => Op s). Check (fun (s : S) (a b : Dom s) => Op s a b). (* v8 Check fun s:S => s.(Dom). Check fun s:S => s.(Op). Check fun (s:S) (a b:s.(Dom)) => s.(Op) a b. *) Set Implicit Arguments. Unset Strict Implicit. Unset Strict Implicit. Structure S' (A : Set) : Type := {Dom' : Type; Op' : A -> Dom' -> Dom'}. Check (fun s : S' nat => Dom' s). Check (fun s : S' nat => Op' (s:=s)). Check (fun s : S' nat => Op' (A:=nat) (s:=s)). Check (fun (s : S' nat) (a : nat) (b : Dom' s) => Op' a b). Check (fun (s : S' nat) (a : nat) (b : Dom' s) => Op' (A:=nat) (s:=s) a b). (* v8 Check fun s:S' => s.(Dom'). Check fun s:S' => s.(Op'). Check fun (s:S') (a b:s.(Dom')) => _.(Op') a b. Check fun (s:S') (a b:s.(Dom')) => s.(Op') a b. Set Implicit Arguments. Unset Strict Implicits. Structure S' (A:Set) : Type := {Dom' : Type; Op' : A -> Dom' -> Dom'}. Check fun s:S' nat => s.(Dom'). Check fun s:S' nat => s.(Op'). Check fun (s:S' nat) (a:nat) (b:s.(Dom')) => _.(@Op' nat) a b. Check fun (s:S' nat) (a:nat) (b:s.(Dom')) => s.(Op') a b. *) coq-8.4pl4/test-suite/success/unfold.v0000644000175000017500000000145412326224777017073 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* titi | |- _ => idtac end. End ti. Import ti. Definition simple : forall a : nat, a = a. intro. equal. Qed. coq-8.4pl4/test-suite/success/Field.v0000644000175000017500000000367212326224777016633 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R) (x0 x1 : R), (f x1 - f x0) * (1 / (x1 - x0)) + (g x1 - g x0) * (1 / (x1 - x0)) = (f x1 + g x1 - (f x0 + g x0)) * (1 / (x1 - x0)). Proof. intros. field. Abort. (* Example 3 *) Goal forall a b : R, 1 / (a * b) * (1 / (1 / b)) = 1 / a. Proof. intros. field. Abort. Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a. Proof. intros. field_simplify_eq. Abort. Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a. Proof. intros. field_simplify (1 / (a * b) * (1 / 1 / b)). Abort. (* Example 4 *) Goal forall a b : R, a <> 0 -> b <> 0 -> 1 / (a * b) / (1 / b) = 1 / a. Proof. intros. field; auto. Qed. (* Example 5 *) Goal forall a : R, 1 = 1 * (1 / a) * a. Proof. intros. field. Abort. (* Example 6 *) Goal forall a b : R, b = b * / a * a. Proof. intros. field. Abort. (* Example 7 *) Goal forall a b : R, b = b * (1 / a) * a. Proof. intros. field. Abort. (* Example 8 *) Goal forall x y : R, x * (1 / x + x / (x + y)) = - (1 / y) * y * (- (x * (x / (x + y))) - 1). Proof. intros. field. Abort. (* Example 9 *) Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a -> False. Proof. intros. field_simplify_eq in H. Abort. coq-8.4pl4/test-suite/success/inds_type_sec.v0000644000175000017500000000112212326224777020424 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* T U. End S. coq-8.4pl4/test-suite/success/unicode_utf8.v0000644000175000017500000000417512326224777020203 0ustar stephsteph(** PARSER TESTS *) (** Check correct separation of identifiers followed by unicode symbols *) Notation "x ⊕ w" := (plus x w) (at level 30). Check fun x => x⊕x. (** Check Greek letters *) Definition test_greek : nat -> nat := fun Δ => Δ. Parameter ℝ : Set. Parameter π : ℝ. (** Check indices *) Definition test_indices : nat -> nat := fun x₁ => x₁. Definition π₂ := snd. (** More unicode in identifiers *) Definition ÎąÎē_ÃĄÃ _ŨŨ‘ := 0. (** UNICODE IN STRINGS *) Require Import List Ascii String. Open Scope string_scope. Definition test_string := "azertyÎąÎē∀ÃĐÃĐÃĐ". Eval compute in length test_string. (** last six "chars" are unicode, hence represented by 2 bytes, except the forall which is 3 bytes *) Fixpoint string_to_list s := match s with | EmptyString => nil | String c s => c :: string_to_list s end. Eval compute in (string_to_list test_string). (** for instance, Îą is \206\177 whereas ∀ is \226\136\128 *) Close Scope string_scope. (** INTERFACE TESTS *) Require Import Utf8. (** Printing of unicode notation, in *goals* *) Lemma test : forall A:Prop, A -> A. Proof. auto. Qed. (** Parsing of unicode notation, in *goals* *) Lemma test2 : ∀A:Prop, A → A. Proof. intro. intro. auto. Qed. (** Printing of unicode notation, in *response* *) Check fun (X:Type)(x:X) => x. (** Parsing of unicode notation, in *response* *) Check ∀Δ, Δ → Δ. Check ∀x, x=0 âˆĻ x=0 → x=0. (** ISSUES: *) Notation "x ≠ y" := (x<>y) (at level 70). Notation "x â‰Ī y" := (x<=y) (at level 70, no associativity). (** First Issue : â‰Ī is attached to "le" of nat, not to notation <= *) Require Import ZArith. Open Scope Z_scope. Locate "â‰Ī". (* still le, not Z.le *) Notation "x â‰Ī y" := (x<=y) (at level 70, no associativity). Locate "â‰Ī". Close Scope Z_scope. (** ==> How to proceed modularly ? *) (** Second Issue : notation for -> generates useless parenthesis if followed by a binder *) Check 0≠0 → ∀x:nat,x=x. (** Example of real situation : *) Definition pred : ∀x, x≠0 → ∃y, x = S y. Proof. destruct x. destruct 1; auto. intros _. exists x; auto. Defined. Print pred. coq-8.4pl4/test-suite/success/clear.v0000644000175000017500000000044212326224777016666 0ustar stephstephGoal forall x:nat, (forall x, x=0 -> True)->True. intros; eapply H. instantiate (1:=(fun y => _) (S x)). simpl. clear x. trivial. Qed. Goal forall y z, (forall x:nat, x=y -> True) -> y=z -> True. intros; eapply H. rename z into z'. clear H0. clear z'. reflexivity. Qed. coq-8.4pl4/test-suite/success/coqbugs0181.v0000644000175000017500000000032312326224777017553 0ustar stephsteph (* test the strength of pretyping unification *) Require Import List. Definition listn A n := {l : list A | length l = n}. Definition make_ln A n (l : list A) (h : (fun l => length l = n) l) := exist _ l h. coq-8.4pl4/test-suite/success/Section.v0000644000175000017500000000021012326224777017175 0ustar stephsteph(* Test bug 2168: ending section of some name was removing objects of the same name *) Require Import make_notation. Check add2 3. coq-8.4pl4/test-suite/success/Mod_type.v0000644000175000017500000000100712326224777017356 0ustar stephsteph(* Check bug #1025 submitted by Pierre-Luc Carmel Biron *) Module Type FOO. Parameter A : Type. End FOO. Module Type BAR. Declare Module Foo : FOO. End BAR. Module Bar : BAR. Module Fu : FOO. Definition A := Prop. End Fu. Module Foo := Fu. End Bar. (* Check bug #2809: correct printing of modules with notations *) Module C. Inductive test : Type := | c1 : test | c2 : nat -> test. Notation "! x" := (c2 x) (at level 50). End C. Print C. (* Should print test_rect without failing *) coq-8.4pl4/test-suite/success/Mod_strengthen.v0000644000175000017500000000170312326224777020561 0ustar stephstephModule Type Sub. Axiom Refl1 : forall x : nat, x = x. Axiom Refl2 : forall x : nat, x = x. Axiom Refl3 : forall x : nat, x = x. Inductive T : Set := A : T. End Sub. Module Type Main. Declare Module M: Sub. End Main. Module A <: Main. Module M <: Sub. Lemma Refl1 : forall x : nat, x = x. intros; reflexivity. Qed. Axiom Refl2 : forall x : nat, x = x. Lemma Refl3 : forall x : nat, x = x. intros; reflexivity. Defined. Inductive T : Set := A : T. End M. End A. (* first test *) Module F (S: Sub). Module M := S. End F. Module B <: Main with Module M:=A.M := F A.M. (* second test *) Lemma r1 : (A.M.Refl1 = B.M.Refl1). Proof. reflexivity. Qed. Lemma r2 : (A.M.Refl2 = B.M.Refl2). Proof. reflexivity. Qed. Lemma r3 : (A.M.Refl3 = B.M.Refl3). Proof. reflexivity. Qed. Lemma t : (A.M.T = B.M.T). Proof. reflexivity. Qed. Lemma a : (A.M.A = B.M.A). Proof. reflexivity. Qed. coq-8.4pl4/test-suite/success/specialize.v0000644000175000017500000000261012326224777017727 0ustar stephsteph Goal forall a b c : nat, a = b -> b = c -> forall d, a+d=c+d. intros. (* "compatibility" mode: specializing a global name means a kind of generalize *) specialize eq_trans. intros _. specialize eq_trans with (1:=H)(2:=H0). intros _. specialize eq_trans with (x:=a)(y:=b)(z:=c). intros _. specialize eq_trans with (1:=H)(z:=c). intros _. specialize eq_trans with nat a b c. intros _. specialize (@eq_trans nat). intros _. specialize (@eq_trans _ a b c). intros _. specialize (eq_trans (x:=a)). intros _. specialize (eq_trans (x:=a)(y:=b)). intros _. specialize (eq_trans H H0). intros _. specialize (eq_trans H0 (z:=b)). intros _. (* local "in place" specialization *) assert (Eq:=eq_trans). specialize Eq. specialize Eq with (1:=H)(2:=H0). Undo. specialize Eq with (x:=a)(y:=b)(z:=c). Undo. specialize Eq with (1:=H)(z:=c). Undo. specialize Eq with nat a b c. Undo. specialize (Eq nat). Undo. specialize (Eq _ a b c). Undo. (* no implicit argument for Eq, hence no (Eq (x:=a)) *) specialize (Eq _ _ _ _ H H0). Undo. specialize (Eq _ _ _ b H0). Undo. (* (** strange behavior to inspect more precisely *) (* 1) proof aspect : let H:= ... in (fun H => ..) H presque ok... *) (* 2) echoue moins lorsque zero premise de mangÃĐ *) specialize eq_trans with (1:=Eq). (* mal typÃĐ !! *) (* 3) *) specialize eq_trans with _ a b c. intros _. (* Anomaly: Evar ?88 was not declared. Please report. *) *) Abort.coq-8.4pl4/test-suite/success/TestRefine.v0000644000175000017500000001033312326224777017650 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* match x0 with | O => _ | S p => _ end)). Restart. refine (fun x0 : nat => match x0 as n return (n = n) with | O => _ | S p => _ end). (* OK *) Restart. refine (fun x0 : nat => match x0 as n return (n = n) with | O => _ | S p => _ end). (* OK *) Restart. (** Refine [x0:nat]Cases x0 of O => ? | (S p) => ? end. (* cannot be executed *) **) Abort. (************************************************************************) Lemma T : nat. refine (S _). Abort. (************************************************************************) Lemma essai2 : forall x : nat, x = x. refine (fix f (x : nat) : x = x := _). Restart. refine (fix f (x : nat) : x = x := match x as n return (n = n :>nat) with | O => _ | S p => _ end). Restart. refine (fix f (x : nat) : x = x := match x as n return (n = n) with | O => _ | S p => _ end). Restart. refine (fix f (x : nat) : x = x := match x as n return (n = n :>nat) with | O => _ | S p => f_equal S _ end). Restart. refine (fix f (x : nat) : x = x := match x as n return (n = n :>nat) with | O => _ | S p => f_equal S _ end). Abort. (************************************************************************) Parameter f : nat * nat -> nat -> nat. Lemma essai : nat. refine (f _ ((fun x : nat => _:nat) 0)). Restart. refine (f _ 0). Abort. (************************************************************************) Parameter P : nat -> Prop. Lemma essai : {x : nat | x = 1}. refine (exist _ 1 _). (* ECHEC *) Restart. (* mais si on contraint par le but alors ca marche : *) (* Remarque : on peut toujours faire įa *) refine (exist _ 1 _:{x : nat | x = 1}). Restart. refine (exist (fun x : nat => x = 1) 1 _). Abort. (************************************************************************) Lemma essai : forall n : nat, {x : nat | x = S n}. refine (fun n : nat => match n return {x : nat | x = S n} with | O => _ | S p => _ end). Restart. refine (fun n : nat => match n with | O => _ | S p => _ end). Restart. refine (fun n : nat => match n return {x : nat | x = S n} with | O => _ | S p => _ end). Restart. refine (fix f (n : nat) : {x : nat | x = S n} := match n return {x : nat | x = S n} with | O => _ | S p => _ end). Restart. refine (fix f (n : nat) : {x : nat | x = S n} := match n return {x : nat | x = S n} with | O => _ | S p => _ end). exists 1. trivial. elim (f0 p). refine (fun (x : nat) (h : x = S p) => exist (fun x : nat => x = S (S p)) (S x) _). rewrite h. auto. Qed. (* Quelques essais de recurrence bien fondée *) Require Import Wf. Require Import Wf_nat. Lemma essai_wf : nat -> nat. refine (fun x : nat => well_founded_induction _ (fun _ : nat => nat -> nat) (fun (phi0 : nat) (w : forall phi : nat, phi < phi0 -> nat -> nat) => w x _) x x). exact lt_wf. Abort. Require Import Compare_dec. Require Import Lt. Lemma fibo : nat -> nat. refine (well_founded_induction _ (fun _ : nat => nat) (fun (x0 : nat) (fib : forall x : nat, x < x0 -> nat) => match zerop x0 with | left _ => 1 | right h1 => match zerop (pred x0) with | left _ => 1 | right h2 => fib (pred x0) _ + fib (pred (pred x0)) _ end end)). exact lt_wf. auto with arith. apply lt_trans with (m := pred x0); auto with arith. Qed. coq-8.4pl4/test-suite/success/Record.v0000644000175000017500000000453712326224777017027 0ustar stephsteph(* Nijmegen expects redefinition of sorts *) Definition CProp := Prop. Record test : CProp := {n : nat ; m : bool ; _ : n <> 0 }. Require Import Program. Require Import List. Record vector {A : Type} {n : nat} := { vec_list : list A ; vec_len : length vec_list = n }. Implicit Arguments vector []. Coercion vec_list : vector >-> list. Hint Rewrite @vec_len : datatypes. Ltac crush := repeat (program_simplify ; autorewrite with list datatypes ; auto with *). Obligation Tactic := crush. Program Definition vnil {A} : vector A 0 := {| vec_list := [] |}. Program Definition vcons {A n} (a : A) (v : vector A n) : vector A (S n) := {| vec_list := cons a (vec_list v) |}. Hint Rewrite map_length rev_length : datatypes. Program Definition vmap {A B n} (f : A -> B) (v : vector A n) : vector B n := {| vec_list := map f v |}. Program Definition vreverse {A n} (v : vector A n) : vector A n := {| vec_list := rev v |}. Fixpoint va_list {A B} (v : list (A -> B)) (w : list A) : list B := match v, w with | nil, nil => nil | cons f fs, cons x xs => cons (f x) (va_list fs xs) | _, _ => nil end. Program Definition va {A B n} (v : vector (A -> B) n) (w : vector A n) : vector B n := {| vec_list := va_list v w |}. Next Obligation. destruct v as [v Hv]; destruct w as [w Hw] ; simpl. subst n. revert w Hw. induction v ; destruct w ; crush. rewrite IHv ; auto. Qed. (* Correct type inference of record notation. Initial example by Spiwack. *) Inductive Machin := { Bazar : option Machin }. Definition bli : Machin := {| Bazar := Some ({| Bazar := None |}:Machin) |}. Definition bli' : option (option Machin) := Some (Some {| Bazar := None |} ). Definition bli'' : Machin := {| Bazar := Some {| Bazar := None |} |}. Definition bli''' := {| Bazar := Some {| Bazar := None |} |}. (** Correctly use scoping information *) Require Import ZArith. Record Foo := { bar : Z }. Definition foo := {| bar := 0 |}. (** Notations inside records *) Require Import Relation_Definitions. Record DecidableOrder : Type := { A : Type ; le : relation A where "x <= y" := (le x y) ; le_refl : reflexive _ le ; le_antisym : antisymmetric _ le ; le_trans : transitive _ le ; le_total : forall x y, {x <= y}+{y <= x} }. (* Test syntactic sugar suggested by wish report #2138 *) Record R : Type := { P (A : Type) : Prop := exists x : A -> A, x = x; Q A : P A -> P A }. coq-8.4pl4/test-suite/success/ProgramWf.v0000644000175000017500000000433712326224777017513 0ustar stephsteph(* Before loading Program, check non-anomaly on missing library Program *) Fail Program Definition f n (e:n=n): {n|n=0} := match n,e with 0, refl => 0 | _, _ => 0 end. (* Then we test Program properly speaking *) Require Import Arith Program. Require Import ZArith Zwf. Set Implicit Arguments. (* Set Printing All. *) Print sigT_rect. Obligation Tactic := program_simplify ; auto with *. About MR. Program Fixpoint merge (n m : nat) {measure (n + m) (lt)} : nat := match n with | 0 => 0 | S n' => merge n' m end. Print merge. Print Z.lt. Print Zwf. Local Open Scope Z_scope. Program Fixpoint Zwfrec (n m : Z) {measure (n + m) (Zwf 0)} : Z := match n ?= m with | Lt => Zwfrec n (Z.pred m) | _ => 0 end. Next Obligation. red. Admitted. Close Scope Z_scope. Program Fixpoint merge_wf (n m : nat) {wf lt m} : nat := match n with | 0 => 0 | S n' => merge n' m end. Print merge_wf. Program Fixpoint merge_one (n : nat) {measure n} : nat := match n with | 0 => 0 | S n' => merge_one n' end. Print Hint well_founded. Print merge_one. Eval cbv delta [merge_one] beta zeta in merge_one. Import WfExtensionality. Lemma merge_unfold n m : merge n m = match n with | 0 => 0 | S n' => merge n' m end. Proof. intros. unfold merge at 1. unfold merge_func. unfold_sub merge (merge n m). simpl. destruct n ; reflexivity. Qed. Print merge. Require Import Arith. Unset Implicit Arguments. Time Program Fixpoint check_n (n : nat) (P : { i | i < n } -> bool) (p : nat) (H : forall (i : { i | i < n }), i < p -> P i = true) {measure (n - p)} : Exc (forall (p : { i | i < n}), P p = true) := match le_lt_dec n p with | left _ => value _ | right cmp => if dec (P p) then check_n n P (S p) _ else error end. Require Import Omega Setoid. Next Obligation. intros ; simpl in *. apply H. simpl in * ; omega. Qed. Next Obligation. simpl in *; intros. revert H0 ; clear_subset_proofs. intros. case (le_gt_dec p i) ; intro. simpl in *. assert(p = i) by omega. subst. revert H0 ; clear_subset_proofs ; tauto. apply H. simpl. omega. Qed. Program Fixpoint check_n' (n : nat) (m : nat | m = n) (p : nat) (q : nat | q = p) {measure (p - n) p} : nat := _. coq-8.4pl4/test-suite/success/change.v0000644000175000017500000000207112326224777017025 0ustar stephsteph(* A few tests of the syntax of clauses and of the interpretation of change *) Goal let a := 0+0 in a=a. intro. change 0 in (value of a). change ((fun A:Type => A) nat) in (type of a). Abort. Goal forall x, 2 + S x = 1 + S x. intro. change (?u + S x) with (S (u + x)). Abort. (* Check the combination of at, with and in (see bug #2146) *) Goal 3=3 -> 3=3. intro H. change 3 at 2 with (1+2). change 3 at 2 with (1+2) in H |-. change 3 with (1+2) in H at 1 |- * at 1. (* Now check that there are no more 3's *) change 3 with (1+2) in * || reflexivity. Qed. (* Note: the following is invalid and must fail change 3 at 1 with (1+2) at 3. change 3 at 1 with (1+2) in *. change 3 at 1 with (1+2) in H at 2 |-. change 3 at 1 with (1+2) at 3. change 3 at 1 with (1+2) in H |- *. change 3 at 1 with (1+2) in H, H|-. change 3 at 1. *) (* Test that pretyping checks allowed elimination sorts *) Goal True. Fail change True with (let (x,a) := ex_intro _ True (eq_refl True) in x). Fail change True with match ex_intro _ True (eq_refl True) with ex_intro x _ => x end. Abort. coq-8.4pl4/test-suite/success/Reordering.v0000644000175000017500000000057212326224777017704 0ustar stephsteph(* Testing the reordering of hypothesis required by pattern, fold and change. *) Goal forall (A:Set) (x:A) (A':=A), True. intros. fold A' in x. (* suceeds: x is moved after A' *) Undo. pattern A' in x. Undo. change A' in x. Abort. (* p and m should be moved before H *) Goal forall n:nat, n=n -> forall m:nat, let p := (m,n) in True. intros. change n with (snd p) in H. Abort. coq-8.4pl4/test-suite/success/Injection.v0000644000175000017500000000335012326224777017523 0ustar stephsteph(* Check the behaviour of Injection *) (* Check that Injection tries Intro until *) Lemma l1 : forall x : nat, S x = S (S x) -> False. injection 1. apply n_Sn. Qed. Lemma l2 : forall (x : nat) (H : S x = S (S x)), H = H -> False. injection H. intros. apply (n_Sn x H0). Qed. (* Check that no tuple needs to be built *) Lemma l3 : forall x y : nat, existS (fun n : nat => {n = n} + {n = n}) x (left _ (refl_equal x)) = existS (fun n : nat => {n = n} + {n = n}) y (left _ (refl_equal y)) -> x = y. intros x y H. injection H. exact (fun H => H). Qed. (* Check that a tuple is built (actually the same as the initial one) *) Lemma l4 : forall p1 p2 : {0 = 0} + {0 = 0}, existS (fun n : nat => {n = n} + {n = n}) 0 p1 = existS (fun n : nat => {n = n} + {n = n}) 0 p2 -> existS (fun n : nat => {n = n} + {n = n}) 0 p1 = existS (fun n : nat => {n = n} + {n = n}) 0 p2. intros. injection H. exact (fun H => H). Qed. (* Test injection as *) Lemma l5 : forall x y z t : nat, (x,y) = (z,t) -> x=z. intros; injection H as Hyt Hxz. exact Hxz. Qed. (* Check the variants of injection *) Goal forall x y, S x = S y -> True. injection 1 as H'. Undo. intros. injection H as H'. Undo. Ltac f x := injection x. f H. Abort. Goal (forall x y : nat, x = y -> S x = S y) -> True. intros. try injection (H O) || exact I. Qed. Goal (forall x y : nat, x = y -> S x = S y) -> True. intros. einjection (H O). instantiate (1:=O). Abort. (* Injection does not projects at positions in Prop... allow it? Inductive t (A:Prop) : Set := c : A -> t A. Goal forall p q : True\/True, c _ p = c _ q -> False. intros. injection H. Abort. *) (* Injection does not project on discriminable positions... allow it? Goal 1=2 -> 1=0. intro H. injection H. intro; assumption. Qed. *) coq-8.4pl4/test-suite/success/autorewrite.v0000644000175000017500000000137312326224777020156 0ustar stephstephVariable Ack : nat -> nat -> nat. Axiom Ack0 : forall m : nat, Ack 0 m = S m. Axiom Ack1 : forall n : nat, Ack (S n) 0 = Ack n 1. Axiom Ack2 : forall n m : nat, Ack (S n) (S m) = Ack n (Ack (S n) m). Hint Rewrite Ack0 Ack1 Ack2 : base0. Lemma ResAck0 : (Ack 2 2 = 7 -> False) -> False. Proof. intros. autorewrite with base0 in H using try (apply H; reflexivity). Qed. Lemma ResAck1 : forall H:(Ack 2 2 = 7 -> False), True -> False. Proof. intros. autorewrite with base0 in *. apply H;reflexivity. Qed. (* Check autorewrite does not solve existing evars *) (* See discussion started by A. Chargueraud in Oct 2010 on coqdev *) Hint Rewrite <- plus_n_O : base1. Goal forall y, exists x, y+x = y. eexists. autorewrite with base1. Fail reflexivity. coq-8.4pl4/test-suite/success/Case16.v0000644000175000017500000000062512326224777016625 0ustar stephsteph(**********************************************************************) (* Test dependencies in constructors *) (**********************************************************************) Check (fun x : {b : bool | if b then True else False} => match x return (let (b, _) := x in if b then True else False) with | exist true y => y | exist false z => z end). coq-8.4pl4/test-suite/success/decl_mode.v0000644000175000017500000001264112326224777017517 0ustar stephsteph(* \sqrt 2 is irrationnal, (c) 2006 Pierre Corbineau *) Set Firstorder Depth 1. Require Import ArithRing Wf_nat Peano_dec Div2 Even Lt. Lemma double_div2: forall n, div2 (double n) = n. proof. assume n:nat. per induction on n. suppose it is 0. suffices (0=0) to show thesis. thus thesis. suppose it is (S m) and Hrec:thesis for m. have (div2 (double (S m))= div2 (S (S (double m)))). ~= (S (div2 (double m))). thus ~= (S m) by Hrec. end induction. end proof. Show Script. Qed. Lemma double_inv : forall n m, double n = double m -> n = m . proof. let n, m be such that H:(double n = double m). have (n = div2 (double n)) by double_div2,H. ~= (div2 (double m)) by H. thus ~= m by double_div2. end proof. Qed. Lemma double_mult_l : forall n m, (double (n * m)=n * double m). proof. assume n:nat and m:nat. have (double (n * m) = n*m + n * m). ~= (n * (m+m)) by * using ring. thus ~= (n * double m). end proof. Qed. Lemma double_mult_r : forall n m, (double (n * m)=double n * m). proof. assume n:nat and m:nat. have (double (n * m) = n*m + n * m). ~= ((n + n) * m) by * using ring. thus ~= (double n * m). end proof. Qed. Lemma even_is_even_times_even: forall n, even (n*n) -> even n. proof. let n be such that H:(even (n*n)). per cases of (even n \/ odd n) by even_or_odd. suppose (odd n). hence thesis by H,even_mult_inv_r. end cases. end proof. Qed. Lemma main_thm_aux: forall n,even n -> double (double (div2 n *div2 n))=n*n. proof. given n such that H:(even n). *** have (double (double (div2 n * div2 n)) = double (div2 n) * double (div2 n)) by double_mult_l,double_mult_r. thus ~= (n*n) by H,even_double. end proof. Qed. Require Omega. Lemma even_double_n: (forall m, even (double m)). proof. assume m:nat. per induction on m. suppose it is 0. thus thesis. suppose it is (S mm) and thesis for mm. then H:(even (S (S (mm+mm)))). have (S (S (mm + mm)) = S mm + S mm) using omega. hence (even (S mm +S mm)) by H. end induction. end proof. Qed. Theorem main_theorem: forall n p, n*n=double (p*p) -> p=0. proof. assume n0:nat. define P n as (forall p, n*n=double (p*p) -> p=0). claim rec_step: (forall n, (forall m,m P m) -> P n). let n be such that H:(forall m : nat, m < n -> P m) and p:nat . per cases of ({n=0}+{n<>0}) by eq_nat_dec. suppose H1:(n=0). per cases on p. suppose it is (S p'). assume (n * n = double (S p' * S p')). =~ 0 by H1,mult_n_O. ~= (S ( p' + p' * S p' + S p'* S p')) by plus_n_Sm. hence thesis . suppose it is 0. thus thesis. end cases. suppose H1:(n<>0). assume H0:(n*n=double (p*p)). have (even (double (p*p))) by even_double_n . then (even (n*n)) by H0. then H2:(even n) by even_is_even_times_even. then (double (double (div2 n *div2 n))=n*n) by main_thm_aux. ~= (double (p*p)) by H0. then H':(double (div2 n *div2 n)= p*p) by double_inv. have (even (double (div2 n *div2 n))) by even_double_n. then (even (p*p)) by even_double_n,H'. then H3:(even p) by even_is_even_times_even. have (double(double (div2 n * div2 n)) = n*n) by H2,main_thm_aux. ~= (double (p*p)) by H0. ~= (double(double (double (div2 p * div2 p)))) by H3,main_thm_aux. then H'':(div2 n * div2 n = double (div2 p * div2 p)) by double_inv. then (div2 n < n) by lt_div2,neq_O_lt,H1. then H4:(div2 p=0) by (H (div2 n)),H''. then (double (div2 p) = double 0). =~ p by even_double,H3. thus ~= 0. end cases. end claim. hence thesis by (lt_wf_ind n0 P). end proof. Qed. Require Import Reals Field. (*Coercion INR: nat >->R. Coercion IZR: Z >->R.*) Open Scope R_scope. Lemma square_abs_square: forall p,(INR (Z.abs_nat p) * INR (Z.abs_nat p)) = (IZR p * IZR p). proof. assume p:Z. per cases on p. suppose it is (0%Z). thus thesis. suppose it is (Zpos z). thus thesis. suppose it is (Zneg z). have ((INR (Z.abs_nat (Zneg z)) * INR (Z.abs_nat (Zneg z))) = (IZR (Zpos z) * IZR (Zpos z))). ~= ((- IZR (Zpos z)) * (- IZR (Zpos z))). thus ~= (IZR (Zneg z) * IZR (Zneg z)). end cases. end proof. Qed. Definition irrational (x:R):Prop := forall (p:Z) (q:nat),q<>0%nat -> x<> (IZR p/INR q). Theorem irrationnal_sqrt_2: irrational (sqrt (INR 2%nat)). proof. let p:Z,q:nat be such that H:(q<>0%nat) and H0:(sqrt (INR 2%nat)=(IZR p/INR q)). have H_in_R:(INR q<>0:>R) by H. have triv:((IZR p/INR q* INR q) =IZR p :>R) by * using field. have sqrt2:((sqrt (INR 2%nat) * sqrt (INR 2%nat))= INR 2%nat:>R) by sqrt_def. have (INR (Z.abs_nat p * Z.abs_nat p) = (INR (Z.abs_nat p) * INR (Z.abs_nat p))) by mult_INR. ~= (IZR p* IZR p) by square_abs_square. ~= ((IZR p/INR q*INR q)*(IZR p/INR q*INR q)) by triv. (* we have to factor because field is too weak *) ~= ((IZR p/INR q)*(IZR p/INR q)*(INR q*INR q)) using ring. ~= (sqrt (INR 2%nat) * sqrt (INR 2%nat)*(INR q*INR q)) by H0. ~= (INR (2%nat * (q*q))) by sqrt2,mult_INR. then (Z.abs_nat p * Z.abs_nat p = 2* (q * q))%nat. ~= ((q*q)+(q*q))%nat. ~= (Div2.double (q*q)). then (q=0%nat) by main_theorem. hence thesis by H. end proof. Qed. coq-8.4pl4/test-suite/success/Omega0.v0000644000175000017500000000457312326224777016721 0ustar stephstephRequire Import ZArith Omega. Open Scope Z_scope. (* Pierre L: examples gathered while debugging romega. *) Lemma test_romega_0 : forall m m', 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros. omega. Qed. Lemma test_romega_0b : forall m m', 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros m m'. omega. Qed. Lemma test_romega_1 : forall (z z1 z2 : Z), z2 <= z1 -> z1 <= z2 -> z1 >= 0 -> z2 >= 0 -> z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 -> z >= 0. Proof. intros. omega. Qed. Lemma test_romega_1b : forall (z z1 z2 : Z), z2 <= z1 -> z1 <= z2 -> z1 >= 0 -> z2 >= 0 -> z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 -> z >= 0. Proof. intros z z1 z2. omega. Qed. Lemma test_romega_2 : forall a b c:Z, 0<=a-b<=1 -> b-c<=2 -> a-c<=3. Proof. intros. omega. Qed. Lemma test_romega_2b : forall a b c:Z, 0<=a-b<=1 -> b-c<=2 -> a-c<=3. Proof. intros a b c. omega. Qed. Lemma test_romega_3 : forall a b h hl hr ha hb, 0 <= ha - hl <= 1 -> -2 <= hl - hr <= 2 -> h =b+1 -> (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) -> (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) -> (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) -> (-2 <= ha-hr <=2 -> hb = a + 1) -> 0 <= hb - h <= 1. Proof. intros. omega. Qed. Lemma test_romega_3b : forall a b h hl hr ha hb, 0 <= ha - hl <= 1 -> -2 <= hl - hr <= 2 -> h =b+1 -> (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) -> (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) -> (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) -> (-2 <= ha-hr <=2 -> hb = a + 1) -> 0 <= hb - h <= 1. Proof. intros a b h hl hr ha hb. omega. Qed. Lemma test_romega_4 : forall hr ha, ha = 0 -> (ha = 0 -> hr =0) -> hr = 0. Proof. intros hr ha. omega. Qed. Lemma test_romega_5 : forall hr ha, ha = 0 -> (~ha = 0 \/ hr =0) -> hr = 0. Proof. intros hr ha. omega. Qed. Lemma test_romega_6 : forall z, z>=0 -> 0>z+2 -> False. Proof. intros. omega. Qed. Lemma test_romega_6b : forall z, z>=0 -> 0>z+2 -> False. Proof. intros z. omega. Qed. Lemma test_romega_7 : forall z, 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. Proof. intros. omega. Qed. Lemma test_romega_7b : forall z, 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. Proof. intros. omega. Qed. (* Magaud #240 *) Lemma test_romega_8 : forall x y:Z, x*x ~ y*y <= x*x. intros. omega. Qed. Lemma test_romega_8b : forall x y:Z, x*x ~ y*y <= x*x. intros x y. omega. Qed. coq-8.4pl4/test-suite/success/Scopes.v0000644000175000017500000000023612326224777017035 0ustar stephsteph(* Check exportation of Argument Scopes even without import of modules *) Require Import ZArith. Module A. Definition opp := Z.opp. End A. Check (A.opp 3). coq-8.4pl4/test-suite/success/Simplify_eq.v0000644000175000017500000000037412326224777020065 0ustar stephsteph(* Check the behaviour of Simplify_eq *) (* Check that Simplify_eq tries Intro until *) Lemma l1 : 0 = 1 -> False. simplify_eq 1. Qed. Lemma l2 : forall (x : nat) (H : S x = S (S x)), H = H -> False. simplify_eq H. intros. apply (n_Sn x H0). Qed. coq-8.4pl4/test-suite/success/import_lib.v0000644000175000017500000000652712326224777017752 0ustar stephstephDefinition le_trans := 0. Module Test_Read. Module M. Require Le. (* Reading without importing *) Check Le.le_trans. Lemma th0 : le_trans = 0. reflexivity. Qed. End M. Check Le.le_trans. Lemma th0 : le_trans = 0. reflexivity. Qed. Import M. Lemma th1 : le_trans = 0. reflexivity. Qed. End Test_Read. (****************************************************************) Definition le_decide := 1. (* from Arith/Compare *) Definition min := 0. (* from Arith/Min *) Module Test_Require. Module M. Require Import Compare. (* Imports Min as well *) Lemma th1 : le_decide = le_decide. reflexivity. Qed. Lemma th2 : min = min. reflexivity. Qed. End M. (* Checks that Compare and List are loaded *) Check Compare.le_decide. Check Min.min. (* Checks that Compare and List are _not_ imported *) Lemma th1 : le_decide = 1. reflexivity. Qed. Lemma th2 : min = 0. reflexivity. Qed. (* It should still be the case after Import M *) Import M. Lemma th3 : le_decide = 1. reflexivity. Qed. Lemma th4 : min = 0. reflexivity. Qed. End Test_Require. (****************************************************************) Module Test_Import. Module M. Import Compare. (* Imports Min as well *) Lemma th1 : le_decide = le_decide. reflexivity. Qed. Lemma th2 : min = min. reflexivity. Qed. End M. (* Checks that Compare and List are loaded *) Check Compare.le_decide. Check Min.min. (* Checks that Compare and List are _not_ imported *) Lemma th1 : le_decide = 1. reflexivity. Qed. Lemma th2 : min = 0. reflexivity. Qed. (* It should still be the case after Import M *) Import M. Lemma th3 : le_decide = 1. reflexivity. Qed. Lemma th4 : min = 0. reflexivity. Qed. End Test_Import. (************************************************************************) Module Test_Export. Module M. Export Compare. (* Exports Min as well *) Lemma th1 : le_decide = le_decide. reflexivity. Qed. Lemma th2 : min = min. reflexivity. Qed. End M. (* Checks that Compare and List are _not_ imported *) Lemma th1 : le_decide = 1. reflexivity. Qed. Lemma th2 : min = 0. reflexivity. Qed. (* After Import M they should be imported as well *) Import M. Lemma th3 : le_decide = le_decide. reflexivity. Qed. Lemma th4 : min = min. reflexivity. Qed. End Test_Export. (************************************************************************) Module Test_Require_Export. Definition mult_sym := 1. (* from Arith/Mult *) Definition plus_sym := 0. (* from Arith/Plus *) Module M. Require Export Mult. (* Exports Plus as well *) Lemma th1 : mult_comm = mult_comm. reflexivity. Qed. Lemma th2 : plus_comm = plus_comm. reflexivity. Qed. End M. (* Checks that Mult and Plus are _not_ imported *) Lemma th1 : mult_sym = 1. reflexivity. Qed. Lemma th2 : plus_sym = 0. reflexivity. Qed. (* After Import M they should be imported as well *) Import M. Lemma th3 : mult_comm = mult_comm. reflexivity. Qed. Lemma th4 : plus_comm = plus_comm. reflexivity. Qed. End Test_Require_Export. coq-8.4pl4/test-suite/success/Reg.v0000644000175000017500000000576612326224777016333 0ustar stephstephRequire Import Reals. Axiom y : R -> R. Axiom d_y : derivable y. Axiom n_y : forall x : R, y x <> 0%R. Axiom dy_0 : derive_pt y 0 (d_y 0%R) = 1%R. Lemma essai0 : continuity_pt (fun x : R => ((x + 2) / y x + x / y x)%R) 0. assert (H := d_y). assert (H0 := n_y). reg. Qed. Lemma essai1 : derivable_pt (fun x : R => (/ 2 * sin x)%R) 1. reg. Qed. Lemma essai2 : continuity (fun x : R => (Rsqr x * cos (x * x) + x)%R). reg. Qed. Lemma essai3 : derivable_pt (fun x : R => (x * (Rsqr x + 3))%R) 0. reg. Qed. Lemma essai4 : derivable (fun x : R => ((x + x) * sin x)%R). reg. Qed. Lemma essai5 : derivable (fun x : R => (1 + sin (2 * x + 3) * cos (cos x))%R). reg. Qed. Lemma essai6 : derivable (fun x : R => cos (x + 3)). reg. Qed. Lemma essai7 : derivable_pt (fun x : R => (cos (/ sqrt x) * Rsqr (sin x + 1))%R) 1. reg. apply Rlt_0_1. red; intro; rewrite sqrt_1 in H; assert (H0 := R1_neq_R0); elim H0; assumption. Qed. Lemma essai8 : derivable_pt (fun x : R => sqrt (Rsqr x + sin x + 1)) 0. reg. rewrite sin_0. rewrite Rsqr_0. replace (0 + 0 + 1)%R with 1%R; [ apply Rlt_0_1 | ring ]. Qed. Lemma essai9 : derivable_pt (id + sin) 1. reg. Qed. Lemma essai10 : derivable_pt (fun x : R => (x + 2)%R) 0. reg. Qed. Lemma essai11 : derive_pt (fun x : R => (x + 2)%R) 0 essai10 = 1%R. reg. Qed. Lemma essai12 : derivable (fun x : R => (x + Rsqr (x + 2))%R). reg. Qed. Lemma essai13 : derive_pt (fun x : R => (x + Rsqr (x + 2))%R) 0 (essai12 0%R) = 5%R. reg. Qed. Lemma essai14 : derivable_pt (fun x : R => (2 * x + x)%R) 2. reg. Qed. Lemma essai15 : derive_pt (fun x : R => (2 * x + x)%R) 2 essai14 = 3%R. reg. Qed. Lemma essai16 : derivable_pt (fun x : R => (x + sin x)%R) 0. reg. Qed. Lemma essai17 : derive_pt (fun x : R => (x + sin x)%R) 0 essai16 = 2%R. reg. rewrite cos_0. reflexivity. Qed. Lemma essai18 : derivable_pt (fun x : R => (x + y x)%R) 0. assert (H := d_y). reg. Qed. Lemma essai19 : derive_pt (fun x : R => (x + y x)%R) 0 essai18 = 2%R. assert (H := dy_0). assert (H0 := d_y). reg. Qed. Axiom z : R -> R. Axiom d_z : derivable z. Lemma essai20 : derivable_pt (fun x : R => z (y x)) 0. reg. apply d_y. apply d_z. Qed. Lemma essai21 : derive_pt (fun x : R => z (y x)) 0 essai20 = 1%R. assert (H := dy_0). reg. Abort. Lemma essai22 : derivable (fun x : R => (sin (z x) + Rsqr (z x) / y x)%R). assert (H := d_y). reg. apply n_y. apply d_z. Qed. (* Pour tester la continuite de sqrt en 0 *) Lemma essai23 : continuity_pt (fun x : R => (sin (sqrt (x - 1)) + exp (Rsqr (sqrt x + 3)))%R) 1. reg. left; apply Rlt_0_1. right; unfold Rminus; rewrite Rplus_opp_r; reflexivity. Qed. Lemma essai24 : derivable (fun x : R => (sqrt (x * x + 2 * x + 2) + Rabs (x * x + 1))%R). reg. replace (x * x + 2 * x + 2)%R with (Rsqr (x + 1) + 1)%R. apply Rplus_le_lt_0_compat; [ apply Rle_0_sqr | apply Rlt_0_1 ]. unfold Rsqr; ring. red; intro; cut (0 < x * x + 1)%R. intro; rewrite H in H0; elim (Rlt_irrefl _ H0). apply Rplus_le_lt_0_compat; [ replace (x * x)%R with (Rsqr x); [ apply Rle_0_sqr | reflexivity ] | apply Rlt_0_1 ]. Qed. coq-8.4pl4/test-suite/success/CasesDep.v0000644000175000017500000003424412326224777017276 0ustar stephsteph(* Check forward dependencies *) Check (fun (P : nat -> Prop) Q (A : P 0 -> Q) (B : forall n : nat, P (S n) -> Q) x => match x return Q with | exist O H => A H | exist (S n) H => B n H end). (* Check dependencies in anonymous arguments (from FTA/listn.v) *) Inductive listn (A : Set) : nat -> Set := | niln : listn A 0 | consn : forall (a : A) (n : nat), listn A n -> listn A (S n). Section Folding. Variable B C : Set. Variable g : B -> C -> C. Variable c : C. Fixpoint foldrn (n : nat) (bs : listn B n) {struct bs} : C := match bs with | niln => c | consn b _ tl => g b (foldrn _ tl) end. End Folding. (** Testing post-processing of nested dependencies *) Check fun x:{x|x=0}*nat+nat => match x with | inl ((exist 0 eq_refl),0) => None | _ => Some 0 end. Check fun x:{_:{x|x=0}|True}+nat => match x with | inl (exist (exist 0 eq_refl) I) => None | _ => Some 0 end. Check fun x:{_:{x|x=0}|True}+nat => match x with | inl (exist (exist 0 eq_refl) I) => None | _ => Some 0 end. Check fun x:{_:{x|x=0}|True}+nat => match x return option nat with | inl (exist (exist 0 eq_refl) I) => None | _ => Some 0 end. (* the next two examples were failing from r14703 (Nov 22 2011) to r14732 *) (* due to a bug in dependencies postprocessing (revealed by CoLoR) *) Check fun x:{x:nat*nat|fst x = 0 & True} => match x return option nat with | exist2 (x,y) eq_refl I => None end. Check fun x:{_:{x:nat*nat|fst x = 0 & True}|True}+nat => match x return option nat with | inl (exist (exist2 (x,y) eq_refl I) I) => None | _ => Some 0 end. (* -------------------------------------------------------------------- *) (* Example to test patterns matching on dependent families *) (* This exemple extracted from the developement done by Nacira Chabane *) (* (equipe Paris 6) *) (* -------------------------------------------------------------------- *) Require Import Prelude. Require Import Logic_Type. Section Orderings. Variable U : Type. Definition Relation := U -> U -> Prop. Variable R : Relation. Definition Reflexive : Prop := forall x : U, R x x. Definition Transitive : Prop := forall x y z : U, R x y -> R y z -> R x z. Definition Symmetric : Prop := forall x y : U, R x y -> R y x. Definition Antisymmetric : Prop := forall x y : U, R x y -> R y x -> x = y. Definition contains (R R' : Relation) : Prop := forall x y : U, R' x y -> R x y. Definition same_relation (R R' : Relation) : Prop := contains R R' /\ contains R' R. Inductive Equivalence : Prop := Build_Equivalence : Reflexive -> Transitive -> Symmetric -> Equivalence. Inductive PER : Prop := Build_PER : Symmetric -> Transitive -> PER. End Orderings. (***** Setoid *******) Inductive Setoid : Type := Build_Setoid : forall (S : Type) (R : Relation S), Equivalence _ R -> Setoid. Definition elem (A : Setoid) := let (S, R, e) := A in S. Definition equal (A : Setoid) := let (S, R, e) as s return (Relation (elem s)) := A in R. Axiom prf_equiv : forall A : Setoid, Equivalence (elem A) (equal A). Axiom prf_refl : forall A : Setoid, Reflexive (elem A) (equal A). Axiom prf_sym : forall A : Setoid, Symmetric (elem A) (equal A). Axiom prf_trans : forall A : Setoid, Transitive (elem A) (equal A). Section Maps. Variable A B : Setoid. Definition Map_law (f : elem A -> elem B) := forall x y : elem A, equal _ x y -> equal _ (f x) (f y). Inductive Map : Type := Build_Map : forall (f : elem A -> elem B) (p : Map_law f), Map. Definition explicit_ap (m : Map) := match m return (elem A -> elem B) with | Build_Map f p => f end. Axiom pres : forall m : Map, Map_law (explicit_ap m). Definition ext (f g : Map) := forall x : elem A, equal _ (explicit_ap f x) (explicit_ap g x). Axiom Equiv_map_eq : Equivalence Map ext. Definition Map_setoid := Build_Setoid Map ext Equiv_map_eq. End Maps. Notation ap := (explicit_ap _ _). (* : Grammar is replaced by Notation *) Definition ap2 (A B C : Setoid) (f : elem (Map_setoid A (Map_setoid B C))) (a : elem A) := ap (ap f a). (***** posint ******) Inductive posint : Type := | Z : posint | Suc : posint -> posint. Axiom f_equal : forall (A B : Type) (f : A -> B) (x y : A), x = y -> f x = f y. Axiom eq_Suc : forall n m : posint, n = m -> Suc n = Suc m. (* The predecessor function *) Definition pred (n : posint) : posint := match n return posint with | Z => (* Z *) Z (* Suc u *) | Suc u => u end. Axiom pred_Sucn : forall m : posint, m = pred (Suc m). Axiom eq_add_Suc : forall n m : posint, Suc n = Suc m -> n = m. Axiom not_eq_Suc : forall n m : posint, n <> m -> Suc n <> Suc m. Definition IsSuc (n : posint) : Prop := match n return Prop with | Z => (* Z *) False (* Suc p *) | Suc p => True end. Definition IsZero (n : posint) : Prop := match n with | Z => True | Suc _ => False end. Axiom Z_Suc : forall n : posint, Z <> Suc n. Axiom Suc_Z : forall n : posint, Suc n <> Z. Axiom n_Sucn : forall n : posint, n <> Suc n. Axiom Sucn_n : forall n : posint, Suc n <> n. Axiom eqT_symt : forall a b : posint, a <> b -> b <> a. (******* Dsetoid *****) Definition Decidable (A : Type) (R : Relation A) := forall x y : A, R x y \/ ~ R x y. Record DSetoid : Type := {Set_of : Setoid; prf_decid : Decidable (elem Set_of) (equal Set_of)}. (* example de Dsetoide d'entiers *) Axiom eqT_equiv : Equivalence posint (eq (A:=posint)). Axiom Eq_posint_deci : Decidable posint (eq (A:=posint)). (* Dsetoide des posint*) Definition Set_of_posint := Build_Setoid posint (eq (A:=posint)) eqT_equiv. Definition Dposint := Build_DSetoid Set_of_posint Eq_posint_deci. (**************************************) (* Definition des signatures *) (* une signature est un ensemble d'operateurs muni de l'arite de chaque operateur *) Module Sig. Record Signature : Type := {Sigma : DSetoid; Arity : Map (Set_of Sigma) (Set_of Dposint)}. Variable S : Signature. Variable Var : DSetoid. Inductive TERM : Type := | var : elem (Set_of Var) -> TERM | oper : forall op : elem (Set_of (Sigma S)), LTERM (ap (Arity S) op) -> TERM with LTERM : posint -> Type := | nil : LTERM Z | cons : TERM -> forall n : posint, LTERM n -> LTERM (Suc n). (* -------------------------------------------------------------------- *) (* Examples *) (* -------------------------------------------------------------------- *) Parameter t1 t2 : TERM. Type match t1, t2 with | var v1, var v2 => True | oper op1 l1, oper op2 l2 => False | _, _ => False end. Parameter n2 : posint. Parameter l1 l2 : LTERM n2. Type match l1, l2 with | nil, nil => True | cons v m y, nil => False | _, _ => False end. Type match l1, l2 with | nil, nil => True | cons u n x, cons v m y => False | _, _ => False end. Module Type Version1. Definition equalT (t1 t2 : TERM) : Prop := match t1, t2 with | var v1, var v2 => True | oper op1 l1, oper op2 l2 => False | _, _ => False end. Definition EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint) (l2 : LTERM n2) : Prop := match l1, l2 with | nil, nil => True | cons t1 n1' l1', cons t2 n2' l2' => False | _, _ => False end. End Version1. (* ------------------------------------------------------------------*) (* Initial exemple (without patterns) *) (*-------------------------------------------------------------------*) Module Version2. Fixpoint equalT (t1 : TERM) : TERM -> Prop := match t1 return (TERM -> Prop) with | var v1 => (*var*) fun t2 : TERM => match t2 return Prop with | var v2 => (*var*) equal _ v1 v2 (*oper*) | oper op2 _ => False end (*oper*) | oper op1 l1 => fun t2 : TERM => match t2 return Prop with | var v2 => (*var*) False (*oper*) | oper op2 l2 => equal _ op1 op2 /\ EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2 end end with EqListT (n1 : posint) (l1 : LTERM n1) {struct l1} : forall n2 : posint, LTERM n2 -> Prop := match l1 in (LTERM _) return (forall n2 : posint, LTERM n2 -> Prop) with | nil => (*nil*) fun (n2 : posint) (l2 : LTERM n2) => match l2 in (LTERM _) return Prop with | nil => (*nil*) True (*cons*) | cons t2 n2' l2' => False end (*cons*) | cons t1 n1' l1' => fun (n2 : posint) (l2 : LTERM n2) => match l2 in (LTERM _) return Prop with | nil => (*nil*) False (*cons*) | cons t2 n2' l2' => equalT t1 t2 /\ EqListT n1' l1' n2' l2' end end. End Version2. (* ---------------------------------------------------------------- *) (* Version with simple patterns *) (* ---------------------------------------------------------------- *) Module Version3. Fixpoint equalT (t1 : TERM) : TERM -> Prop := match t1 with | var v1 => fun t2 : TERM => match t2 with | var v2 => equal _ v1 v2 | oper op2 _ => False end | oper op1 l1 => fun t2 : TERM => match t2 with | var _ => False | oper op2 l2 => equal _ op1 op2 /\ EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2 end end with EqListT (n1 : posint) (l1 : LTERM n1) {struct l1} : forall n2 : posint, LTERM n2 -> Prop := match l1 return (forall n2 : posint, LTERM n2 -> Prop) with | nil => fun (n2 : posint) (l2 : LTERM n2) => match l2 with | nil => True | _ => False end | cons t1 n1' l1' => fun (n2 : posint) (l2 : LTERM n2) => match l2 with | nil => False | cons t2 n2' l2' => equalT t1 t2 /\ EqListT n1' l1' n2' l2' end end. End Version3. Module Version4. Fixpoint equalT (t1 : TERM) : TERM -> Prop := match t1 with | var v1 => fun t2 : TERM => match t2 with | var v2 => equal _ v1 v2 | oper op2 _ => False end | oper op1 l1 => fun t2 : TERM => match t2 with | var _ => False | oper op2 l2 => equal _ op1 op2 /\ EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2 end end with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint) (l2 : LTERM n2) {struct l1} : Prop := match l1 with | nil => match l2 with | nil => True | _ => False end | cons t1 n1' l1' => match l2 with | nil => False | cons t2 n2' l2' => equalT t1 t2 /\ EqListT n1' l1' n2' l2' end end. End Version4. (* ---------------------------------------------------------------- *) (* Version with multiple patterns *) (* ---------------------------------------------------------------- *) Module Version5. Fixpoint equalT (t1 t2 : TERM) {struct t1} : Prop := match t1, t2 with | var v1, var v2 => equal _ v1 v2 | oper op1 l1, oper op2 l2 => equal _ op1 op2 /\ EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2 | _, _ => False end with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint) (l2 : LTERM n2) {struct l1} : Prop := match l1, l2 with | nil, nil => True | cons t1 n1' l1', cons t2 n2' l2' => equalT t1 t2 /\ EqListT n1' l1' n2' l2' | _, _ => False end. End Version5. (* ------------------------------------------------------------------ *) End Sig. (* Exemple soumis par Bruno *) Definition bProp (b : bool) : Prop := if b then True else False. Definition f0 (F : False) (ty : bool) : bProp ty := match ty as _, ty return (bProp ty) with | true, true => I | _, false => F | _, true => I end. (* Simplification of bug/wish #1671 *) Inductive I : unit -> Type := | C : forall a, I a -> I tt. (* Definition F (l:I tt) : l = l := match l return l = l with | C tt (C _ l') => refl_equal (C tt (C _ l')) end. one would expect that the compilation of F (this involves some kind of pattern-unification) would produce: *) Definition F (l:I tt) : l = l := match l return l = l with | C tt l' => match l' return C _ l' = C _ l' with C _ l'' => refl_equal (C tt (C _ l'')) end end. Inductive J : nat -> Type := | D : forall a, J (S a) -> J a. (* Definition G (l:J O) : l = l := match l return l = l with | D O (D 1 l') => refl_equal (D O (D 1 l')) | D _ _ => refl_equal _ end. one would expect that the compilation of G (this involves inversion) would produce: *) Definition G (l:J O) : l = l := match l return l = l with | D 0 l'' => match l'' as _l'' in J n return match n return forall l:J n, Prop with | O => fun _ => l = l | S p => fun l'' => D p l'' = D p l'' end _l'' with | D 1 l' => refl_equal (D O (D 1 l')) | _ => refl_equal _ end | _ => refl_equal _ end. Fixpoint app {A} {n m} (v : listn A n) (w : listn A m) : listn A (n + m) := match v with | niln => w | consn a n' v' => consn _ a _ (app v' w) end. (* Testing regression of bug 2106 *) Set Implicit Arguments. Require Import List. Inductive nt := E. Definition root := E. Inductive ctor : list nt -> nt -> Type := Plus : ctor (cons E (cons E nil)) E. Inductive term : nt -> Type := | Term : forall s n, ctor s n -> spine s -> term n with spine : list nt -> Type := | EmptySpine : spine nil | ConsSpine : forall n s, term n -> spine s -> spine (n :: s). Inductive step : nt -> nt -> Type := | Step : forall l n r n' (c:ctor (l++n::r) n'), spine l -> spine r -> step n n'. Definition test (s:step E E) := match s with | Step nil _ (cons E nil) _ Plus l l' => true | _ => false end. (* Testing regression of bug 2454 ("get" used not be type-checkable when defined with its type constraint) *) Inductive K : nat -> Type := KC : forall (p q:nat), K p. Definition get : K O -> nat := fun x => match x with KC p q => q end. (* Checking correct order of substitution of realargs *) (* (was broken from revision 14664 to 14669) *) (* Example extracted from contrib CoLoR *) Inductive EQ : nat -> nat -> Prop := R x y : EQ x y. Check fun e t (d1 d2:EQ e t) => match d1 in EQ e1 t1, d2 in EQ e2 t2 return (e1,t1) = (e2,t2) -> (e1,t1) = (e,t) -> 0=0 with | R _ _, R _ _ => fun _ _ => eq_refl end. coq-8.4pl4/test-suite/success/set.v0000644000175000017500000000063012326224777016372 0ustar stephsteph(* This used to fail in 8.0pl1 *) Goal forall n, n+n=0->0=n+n. intros. set n in * |-. Abort. (* This works from 8.4pl1, since merging of different instances of the same metavariable in a pattern is done modulo conversion *) Notation "p .+1" := (S p) (at level 1, left associativity, format "p .+1"). Goal forall (f:forall n, n=0 -> Prop) n (H:(n+n).+1=0), f (n.+1+n) H. intros. set (f _ _). Abort. coq-8.4pl4/test-suite/success/DHyp.v0000644000175000017500000000000112326224777016433 0ustar stephsteph coq-8.4pl4/test-suite/success/Case11.v0000644000175000017500000000052512326224777016617 0ustar stephsteph(* L'algo d'inférence du prédicat doit gérer le K-rédex dans le type de b *) (* Problčme rapporté par Solange Coupet *) Section A. Variables (Alpha : Set) (Beta : Set). Definition nodep_prod_of_dep (c : sigS (fun a : Alpha => Beta)) : Alpha * Beta := match c with | existS a b => (a, b) end. End A. coq-8.4pl4/test-suite/success/evars.v0000644000175000017500000002754012326224777016730 0ustar stephsteph(* The "?" of cons and eq should be inferred *) Variable list : Set -> Set. Variable cons : forall T : Set, T -> list T -> list T. Check (forall n : list nat, exists l : _, (exists x : _, n = cons _ x l)). (* Examples provided by Eduardo Gimenez *) Definition c A (Q : (nat * A -> Prop) -> Prop) P := Q (fun p : nat * A => let (i, v) := p in P i v). (* What does this test ? *) Require Import List. Definition list_forall_bool (A : Set) (p : A -> bool) (l : list A) : bool := fold_right (fun a r => if p a then r else false) true l. (* Checks that solvable ? in the lambda prefix of the definition are harmless*) Parameter A1 A2 F B C : Set. Parameter f : F -> A1 -> B. Definition f1 frm0 a1 : B := f frm0 a1. (* Checks that solvable ? in the type part of the definition are harmless *) Definition f2 frm0 a1 : B := f frm0 a1. (* Checks that sorts that are evars are handled correctly (bug 705) *) Require Import List. Fixpoint build (nl : list nat) : match nl with | nil => True | _ => False end -> unit := match nl return (match nl with | nil => True | _ => False end -> unit) with | nil => fun _ => tt | n :: rest => match n with | O => fun _ => tt | S m => fun a => build rest (False_ind _ a) end end. (* Checks that disjoint contexts are correctly set by restrict_hyp *) (* Bug de 1999 corrigé en déc 2004 *) Check (let p := fun (m : nat) f (n : nat) => match f m n with | exist a b => exist _ a b end in p :forall x : nat, (forall y n : nat, {q : nat | y = q * n}) -> forall n : nat, {q : nat | x = q * n}). (* Check instantiation of nested evars (bug #1089) *) Check (fun f:(forall (v:Type->Type), v (v nat) -> nat) => f _ (Some (Some O))). (* This used to fail with anomaly "evar was not declared" in V8.0pl3 *) Theorem contradiction : forall p, ~ p -> p -> False. Proof. trivial. Qed. Hint Resolve contradiction. Goal False. eauto. Abort. (* This used to fail in V8.1beta because first-order unification was used before using type information *) Check (exist _ O (refl_equal 0) : {n:nat|n=0}). Check (exist _ O I : {n:nat|True}). (* An example (initially from Marseille/Fairisle) that involves an evar with different solutions (Input, Output or bool) that may or may not be considered distinct depending on which kind of conversion is used *) Section A. Definition STATE := (nat * bool)%type. Let Input := bool. Let Output := bool. Parameter Out : STATE -> Output. Check fun (s : STATE) (reg : Input) => reg = Out s. End A. (* The return predicate found should be: "in _=U return U" *) (* (feature already available in V8.0) *) Definition g (T1 T2:Type) (x:T1) (e:T1=T2) : T2 := match e with | refl_equal => x end. (* An example extracted from FMapAVL which (may) test restriction on evars problems of the form ?n[args1]=?n[args2] with distinct args1 and args2 *) Set Implicit Arguments. Parameter t:Set->Set. Parameter map:forall elt elt' : Set, (elt -> elt') -> t elt -> t elt'. Parameter avl: forall elt : Set, t elt -> Prop. Parameter bst: forall elt : Set, t elt -> Prop. Parameter map_avl: forall (elt elt' : Set) (f : elt -> elt') (m : t elt), avl m -> avl (map f m). Parameter map_bst: forall (elt elt' : Set) (f : elt -> elt') (m : t elt), bst m -> bst (map f m). Record bbst (elt:Set) : Set := Bbst {this :> t elt; is_bst : bst this; is_avl: avl this}. Definition t' := bbst. Section B. Variables elt elt': Set. Definition map' f (m:t' elt) : t' elt' := Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)). End B. Unset Implicit Arguments. (* An example from Lexicographic_Exponentiation that tests the contraction of reducible fixpoints in type inference *) Require Import List. Check (fun (A:Set) (a b x:A) (l:list A) (H : l ++ cons x nil = cons b (cons a nil)) => app_inj_tail l (cons b nil) _ _ H). (* An example from NMake (simplified), that uses restriction in solve_refl *) Parameter h:(nat->nat)->(nat->nat). Fixpoint G p cont {struct p} := h (fun n => match p with O => cont | S p => G p cont end n). (* An example from Bordeaux/Cantor that applies evar restriction below a binder *) Require Import Relations. Parameter lex : forall (A B : Set), (forall (a1 a2:A), {a1=a2}+{a1<>a2}) -> relation A -> relation B -> A * B -> A * B -> Prop. Check forall (A B : Set) eq_A_dec o1 o2, antisymmetric A o1 -> transitive A o1 -> transitive B o2 -> transitive _ (lex _ _ eq_A_dec o1 o2). (* Another example from Julien Forest that tests unification below binders *) Require Import List. Set Implicit Arguments. Parameter merge : forall (A B : Set) (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2}) (eqB : forall (b1 b2 : B), {b1=b2}+{b1<>b2}) (partial_res l : list (A*B)), option (list (A*B)). Axiom merge_correct : forall (A B : Set) eqA eqB (l1 l2 : list (A*B)), (forall a2 b2 c2, In (a2,b2) l2 -> In (a2,c2) l2 -> b2 = c2) -> match merge eqA eqB l1 l2 with _ => True end. Unset Implicit Arguments. (* An example from Bordeaux/Additions that tests restriction below binders *) Section Additions_while. Variable A : Set. Variables P Q : A -> Prop. Variable le : A -> A -> Prop. Hypothesis Q_dec : forall s : A, P s -> {Q s} + {~ Q s}. Hypothesis le_step : forall s : A, ~ Q s -> P s -> {s' | P s' /\ le s' s}. Hypothesis le_wf : well_founded le. Lemma loopexec : forall s : A, P s -> {s' : A | P s' /\ Q s'}. refine (well_founded_induction_type le_wf (fun s => _ -> {s' : A | _ /\ _}) (fun s hr i => match Q_dec s i with | left _ => _ | right _ => match le_step s _ _ with | exist s' h' => match hr s' _ _ with | exist s'' _ => exist _ s'' _ end end end)). Abort. End Additions_while. (* Two examples from G. Melquiond (bugs #1878 and #1884) *) Parameter F1 G1 : nat -> Prop. Goal forall x : nat, F1 x -> G1 x. refine (fun x H => proj2 (_ x H)). Abort. Goal forall x : nat, F1 x -> G1 x. refine (fun x H => proj2 (_ x H) _). Abort. (* An example from y-not that was failing in 8.2rc1 *) Fixpoint filter (A:nat->Set) (l:list (sigT A)) : list (sigT A) := match l with | nil => nil | (existT k v)::l' => (existT _ k v):: (filter A l') end. (* Bug #2000: used to raise Out of memory in 8.2 while it should fail by lack of information on the conclusion of the type of j *) Goal True. set (p:=fun j => j (or_intror _ (fun a:True => j (or_introl _ a)))) || idtac. Abort. (* Remark: the following example stopped succeeding at some time in the development of 8.2 but it works again (this was because 8.2 algorithm was more general and did not exclude a solution that it should have excluded for typing reason; handling of types and backtracking is still to be done) *) Section S. Variables A B : nat -> Prop. Goal forall x : nat, A x -> B x. refine (fun x H => proj2 (_ x H) _). Abort. End S. (* Check that constraints are taken into account by tactics that instantiate *) Lemma inj : forall n m, S n = S m -> n = m. intros n m H. eapply f_equal with (* should fail because ill-typed *) (f := fun n => match n return match n with S _ => nat | _ => unit end with | S n => n | _ => tt end) in H || injection H. Abort. (* A legitimate simple eapply that was failing in coq <= 8.3. Cf. in Unification.w_merge the addition of an extra pose_all_metas_as_evars on 30/9/2010 *) Lemma simple_eapply_was_failing : (forall f:nat->nat, exists g, f = g) -> True. Proof. assert (modusponens : forall P Q, P -> (P->Q) -> Q) by auto. intros. eapply modusponens. simple eapply H. (* error message with V8.3 : Impossible to unify "?18" with "fun g : nat -> nat => ?6 = g". *) Abort. (* Regression test *) Definition fo : option nat -> nat := option_rec _ (fun a => 0) 0. (* This example revealed an incorrect evar restriction at some time around October 2011 *) Goal forall (A:Type) (a:A) (P:forall A, A -> Prop), (P A a) /\ (P A a). intros. refine ((fun H => conj (proj1 H) (proj2 H)) _). Abort. (* The argument of e below failed to be inferred from r14219 (Oct 2011) to *) (* r14753 after the restrictions made on detecting Miller's pattern in the *) (* presence of alias, only the second-order unification procedure was *) (* able to solve this problem but it was deactivated for 8.4 in r14219 *) Definition k0 (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat) (j : forall a, exists n : nat, n = a) o := match o with (* note: match introduces an alias! *) | Some a => e _ (j a) | None => O end. Definition k1 (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat) (j : forall a, exists n : nat, n = a) a (b:=a) := e _ (j a). Definition k2 (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat) (j : forall a, exists n : nat, n = a) a (b:=a) := e _ (j b). (* Other examples about aliases involved in pattern unification *) Definition k3 (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat) (j : forall a, exists n : nat, let a' := a in n = a') a (b:=a) := e _ (j b). Definition k4 (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat) (j : forall a, exists n : nat, let a' := S a in n = a') a (b:=a) := e _ (j b). Definition k5 (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat) (j : forall a, let a' := S a in exists n : nat, n = a') a (b:=a) := e _ (j b). Definition k6 (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat) (j : forall a, exists n : nat, let n' := S n in n' = a) a (b:=a) := e _ (j b). Definition k7 (e:forall P : nat -> Prop, (exists n : nat, let n' := n in P n') -> nat) (j : forall a, exists n : nat, n = a) a (b:=a) := e _ (j b). (* An example that uses materialize_evar under binders *) (* Extracted from bigop.v in the mathematical components library *) Section Bigop. Variable bigop : forall R I: Type, R -> (R -> R -> R) -> list I -> (I->Prop) -> (I -> R) -> R. Hypothesis eq_bigr : forall (R : Type) (idx : R) (op : R -> R -> R) (I : Type) (r : list I) (P : I -> Prop) (F1 F2 : I -> R), (forall i : I, P i -> F1 i = F2 i) -> bigop R I idx op r (fun i : I => P i) (fun i : I => F1 i) = idx. Hypothesis big_tnth : forall (R : Type) (idx : R) (op : R -> R -> R) (I : Type) (r : list I) (P : I -> Prop) (F : I -> R), bigop R I idx op r (fun i : I => P i) (fun i : I => F i) = idx. Hypothesis big_tnth_with_letin : forall (R : Type) (idx : R) (op : R -> R -> R) (I : Type) (r : list I) (P : I -> Prop) (F : I -> R), bigop R I idx op r (fun i : I => let i:=i in P i) (fun i : I => F i) = idx. Variable R : Type. Variable idx : R. Variable op : R -> R -> R. Variable I : Type. Variable J : Type. Variable rI : list I. Variable rJ : list J. Variable xQ : J -> Prop. Variable P : I -> Prop. Variable Q : I -> J -> Prop. Variable F : I -> J -> R. (* Check unification under binders *) Check (eq_bigr _ _ _ _ _ _ _ _ (fun _ _ => big_tnth _ _ _ _ rI _ _)) : (bigop R J idx op rJ (fun j : J => let k:=j in xQ k) (fun j : J => let k:=j in bigop R I idx op rI (fun i : I => P i /\ Q i k) (fun i : I => let k:=j in F i k))) = idx. (* Check also with let-in *) Check (eq_bigr _ _ _ _ _ _ _ _ (fun _ _ => big_tnth_with_letin _ _ _ _ rI _ _)) : (bigop R J idx op rJ (fun j : J => let k:=j in xQ k) (fun j : J => let k:=j in bigop R I idx op rI (fun i : I => P i /\ Q i k) (fun i : I => let k:=j in F i k))) = idx. End Bigop. (* Check the use of (at least) an heuristic to solve problems of the form "?x[t] = ?y" where ?y occurs in t without easily knowing if ?y can eventually be erased in t *) Section evar_evar_occur. Variable id : nat -> nat. Variable f : forall x, id x = 0 -> id x = 0 -> x = 1 /\ x = 2. Variable g : forall y, id y = 0 /\ id y = 0. (* Still evars in the resulting type, but constraints should be solved *) Check match g _ with conj a b => f _ a b end. End evar_evar_occur. coq-8.4pl4/test-suite/success/setoid_test_function_space.v0000644000175000017500000000213512326224777023207 0ustar stephstephRequire Export Setoid. Set Implicit Arguments. Section feq. Variables A B:Type. Definition feq (f g: A -> B):=forall a, (f a)=(g a). Infix "=f":= feq (at level 80, right associativity). Hint Unfold feq. Lemma feq_refl: forall f, f =f f. intuition. Qed. Lemma feq_sym: forall f g, f =f g-> g =f f. intuition. Qed. Lemma feq_trans: forall f g h, f =f g-> g =f h -> f =f h. unfold feq. intuition. rewrite H. auto. Qed. End feq. Infix "=f":= feq (at level 80, right associativity). Hint Unfold feq. Hint Resolve feq_refl feq_sym feq_trans. Variable K:(nat -> nat)->Prop. Variable K_ext:forall a b, (K a)->(a =f b)->(K b). Add Parametric Relation (A B : Type) : (A -> B) (@feq A B) reflexivity proved by (@feq_refl A B) symmetry proved by (@feq_sym A B) transitivity proved by (@feq_trans A B) as funsetoid. Add Morphism K with signature (@feq nat nat) ==> iff as K_ext1. intuition. apply (K_ext H0 H). intuition. assert (y =f x);auto. apply (K_ext H0 H1). Qed. Lemma three:forall n, forall a, (K a)->(a =f (fun m => (a (n+m))))-> (K (fun m => (a (n+m)))). intuition. setoid_rewrite <- H0. assumption. Qed. coq-8.4pl4/test-suite/success/AdvancedCanonicalStructure.v0000644000175000017500000000543412326224777023044 0ustar stephstephSection group_morphism. (* An example with default canonical structures *) Variable A B : Type. Variable plusA : A -> A -> A. Variable plusB : B -> B -> B. Variable zeroA : A. Variable zeroB : B. Variable eqA : A -> A -> Prop. Variable eqB : B -> B -> Prop. Variable phi : A -> B. Record img := { ia : A; ib :> B; prf : phi ia = ib }. Parameter eq_img : forall (i1:img) (i2:img), eqB (ib i1) (ib i2) -> eqA (ia i1) (ia i2). Lemma phi_img (a:A) : img. exists a (phi a). refine ( refl_equal _). Defined. Canonical Structure phi_img. Lemma zero_img : img. exists zeroA zeroB. admit. Defined. Canonical Structure zero_img. Lemma plus_img : img -> img -> img. intros i1 i2. exists (plusA (ia i1) (ia i2)) (plusB (ib i1) (ib i2)). admit. Defined. Canonical Structure plus_img. (* Print Canonical Projections. *) Goal forall a1 a2, eqA (plusA a1 zeroA) a2. intros a1 a2. refine (eq_img _ _ _). change (eqB (plusB (phi a1) zeroB) (phi a2)). Admitted. End group_morphism. Open Scope type_scope. Section type_reification. Inductive term :Type := Fun : term -> term -> term | Prod : term -> term -> term | Bool : term | SET :term | PROP :term | TYPE :term | Var : Type -> term. Fixpoint interp (t:term) := match t with Bool => bool | SET => Set | PROP => Prop | TYPE => Type | Fun a b => interp a -> interp b | Prod a b => interp a * interp b | Var x => x end. Record interp_pair :Type := { repr:>term; abs:>Type; link: abs = interp repr }. Lemma prod_interp :forall (a b:interp_pair),a * b = interp (Prod a b) . Proof. intros a b. change (a * b = interp a * interp b). rewrite (link a), (link b); reflexivity. Qed. Lemma fun_interp :forall (a b:interp_pair), (a -> b) = interp (Fun a b). Proof. intros a b. change ((a -> b) = (interp a -> interp b)). rewrite (link a), (link b); reflexivity. Qed. Canonical Structure ProdCan (a b:interp_pair) := Build_interp_pair (Prod a b) (a * b) (prod_interp a b). Canonical Structure FunCan (a b:interp_pair) := Build_interp_pair (Fun a b) (a -> b) (fun_interp a b). Canonical Structure BoolCan := Build_interp_pair Bool bool (refl_equal _). Canonical Structure VarCan (x:Type) := Build_interp_pair (Var x) x (refl_equal _). Canonical Structure SetCan := Build_interp_pair SET Set (refl_equal _). Canonical Structure PropCan := Build_interp_pair PROP Prop (refl_equal _). Canonical Structure TypeCan := Build_interp_pair TYPE Type (refl_equal _). (* Print Canonical Projections. *) Variable A:Type. Variable Inhabited: term -> Prop. Variable Inhabited_correct: forall p, Inhabited (repr p) -> abs p. Lemma L : Prop * A -> bool * (Type -> Set) . refine (Inhabited_correct _ _). change (Inhabited (Fun (Prod PROP (Var A)) (Prod Bool (Fun TYPE SET)))). Admitted. Check L : abs _ . End type_reification. coq-8.4pl4/test-suite/success/proof_using.v0000644000175000017500000000130412326224777020130 0ustar stephstephSection Foo. Variable a : nat. Lemma l1 : True. Fail Proof using non_existing. Proof using a. exact I. Qed. Lemma l2 : True. Proof using a. Admitted. Lemma l3 : True. Proof using a. admit. Qed. End Foo. Check (l1 3). Check (l2 3). Check (l3 3). Section Bar. Variable T : Type. Variable a b : T. Variable H : a = b. Lemma l4 : a = b. Proof using H. exact H. Qed. End Bar. Check (l4 _ 1 1 _ : 1 = 1). Section S1. Variable v1 : nat. Section S2. Variable v2 : nat. Lemma deep : v1 = v2. Proof using v1 v2. admit. Qed. Lemma deep2 : v1 = v2. Proof using v1 v2. Admitted. End S2. Check (deep 3 : v1 = 3). Check (deep2 3 : v1 = 3). End S1. Check (deep 3 4 : 3 = 4). Check (deep2 3 4 : 3 = 4). coq-8.4pl4/test-suite/success/PrintSortedUniverses.v0000644000175000017500000000004712326224777021762 0ustar stephstephRequire Reals. Print Sorted Universes. coq-8.4pl4/test-suite/success/simpl.v0000644000175000017500000000232012326224777016721 0ustar stephsteph(* Check that inversion of names of mutual inductive fixpoints works *) (* (cf bug #1031) *) Inductive tree : Set := | node : nat -> forest -> tree with forest : Set := | leaf : forest | cons : tree -> forest -> forest . Definition copy_of_compute_size_forest := fix copy_of_compute_size_forest (f:forest) : nat := match f with | leaf => 1 | cons t f0 => copy_of_compute_size_forest f0 + copy_of_compute_size_tree t end with copy_of_compute_size_tree (t:tree) : nat := match t with | node _ f => 1 + copy_of_compute_size_forest f end for copy_of_compute_size_forest . Eval simpl in (copy_of_compute_size_forest leaf). (* Another interesting case: Hrec has to occurrences: one cannot be folded back to f while the second can. *) Parameter g : (nat->nat)->nat->nat->nat. Definition f (n n':nat) := nat_rec (fun _ => nat -> nat) (fun x => x) (fun k Hrec => g Hrec (Hrec k)) n n'. Goal forall a b, f (S a) b = b. intros. simpl. admit. Qed. (* Qed will fail if simpl performs eta-expansion *) (* Yet another example. *) Require Import List. Goal forall A B (a:A) l f (i:B), fold_right f i ((a :: l))=i. simpl. admit. Qed. (* Qed will fail if simplification is incorrect (de Bruijn!) *) coq-8.4pl4/test-suite/success/coercions.v0000644000175000017500000000725512326224777017575 0ustar stephsteph(* Interaction between coercions and casts *) (* Example provided by Eduardo Gimenez *) Parameter Z S : Set. Parameter f : S -> Z. Coercion f : S >-> Z. Parameter g : Z -> Z. Check (fun s => g (s:S)). (* Check uniform inheritance condition *) Parameter h : nat -> nat -> Prop. Parameter i : forall n m : nat, h n m -> nat. Coercion i : h >-> nat. (* Check coercion to funclass when the source occurs in the target *) Parameter C : nat -> nat -> nat. Coercion C : nat >-> Funclass. (* Remark: in the following example, it cannot be decided whether C is from nat to Funclass or from A to nat. An explicit Coercion command is expected Parameter A : nat -> Prop. Parameter C:> forall n:nat, A n -> nat. *) (* Check coercion between products based on eta-expansion *) (* (there was a de Bruijn bug until rev 9254) *) Section P. Variable E : Set. Variables C D : E -> Prop. Variable G :> forall x, C x -> D x. Check fun (H : forall y:E, y = y -> C y) => (H : forall y:E, y = y -> D y). End P. (* Check that class arguments are computed the same when looking for a coercion and when applying it (class_args_of) (failed until rev 9255) *) Section Q. Variable bool : Set. Variables C D : bool -> Prop. Variable G :> forall x, C x -> D x. Variable f : nat -> bool. Definition For_all (P : nat -> Prop) := forall x, P x. Check fun (H : For_all (fun x => C (f x))) => H : forall x, D (f x). Check fun (H : For_all (fun x => C (f x))) x => H x : D (f x). Check fun (H : For_all (fun x => C (f x))) => H : For_all (fun x => D (f x)). End Q. (* Combining class lookup and path lookup so that if a lookup fails, another descent in the class can be found (see wish #1934) *) Record Setoid : Type := { car :> Type }. Record Morphism (X Y:Setoid) : Type := {evalMorphism :> X -> Y}. Definition extSetoid (X Y:Setoid) : Setoid. constructor. exact (Morphism X Y). Defined. Definition ClaimA := forall (X Y:Setoid) (f: extSetoid X Y) x, f x= f x. Coercion irrelevent := (fun _ => I) : True -> car (Build_Setoid True). Definition ClaimB := forall (X Y:Setoid) (f: extSetoid X Y) (x:X), f x= f x. (* Check that coercions are made visible only when modules are imported *) Module A. Module B. Coercion b2n (b:bool) := if b then 0 else 1. End B. Fail Check S true. End A. Import A. Fail Check S true. (* Tests after the inheritance condition constraint is relaxed *) Inductive list (A : Type) : Type := nil : list A | cons : A -> list A -> list A. Inductive vect (A : Type) : nat -> Type := vnil : vect A 0 | vcons : forall n, A -> vect A n -> vect A (1+n). Fixpoint size A (l : list A) : nat := match l with nil => 0 | cons _ tl => 1+size _ tl end. Section test_non_unif_but_complete. Fixpoint l2v A (l : list A) : vect A (size A l) := match l as l return vect A (size A l) with | nil => vnil A | cons x xs => vcons A (size A xs) x (l2v A xs) end. Local Coercion l2v : list >-> vect. Check (fun l : list nat => (l : vect _ _)). End test_non_unif_but_complete. Section what_we_could_do. Variables T1 T2 : Type. Variable c12 : T1 -> T2. Class coercion (A B : Type) : Type := cast : A -> B. Instance atom : coercion T1 T2 := c12. Instance pair A B C D (c1 : coercion A B) (c2 : coercion C D) : coercion (A * C) (B * D) := fun x => (c1 (fst x), c2 (snd x)). Fixpoint l2v2 {A B} {c : coercion A B} (l : list A) : (vect B (size A l)) := match l as l return vect B (size A l) with | nil => vnil B | cons x xs => vcons _ _ (c x) (l2v2 xs) end. Local Coercion l2v2 : list >-> vect. (* This shows that there is still something to do to take full profit of coercions *) Fail Check (fun l : list (T1 * T1) => (l : vect _ _)). Check (fun l : list (T1 * T1) => (l2v2 l : vect _ _)). Section what_we_could_do.coq-8.4pl4/test-suite/success/Abstract.v0000644000175000017500000000067512326224777017353 0ustar stephsteph (* Cf coqbugs #546 *) Require Import Omega. Section S. Variables n m : nat. Variable H : n Set := | Dummy0 : Dummy 0 | Dummy2 : Dummy 2 | DummyApp : forall i j, Dummy i -> Dummy j -> Dummy (i+j). Definition Bug : Dummy (2*n). Proof. induction n. simpl ; apply Dummy0. replace (2 * S n0) with (2*n0 + 2) ; auto with arith. apply DummyApp. 2:exact Dummy2. apply IHn0 ; abstract omega. Defined. End S. coq-8.4pl4/test-suite/success/universes-coercion.v0000644000175000017500000000162512326224777021426 0ustar stephsteph(* This example used to emphasize the absence of LEGO-style universe polymorphism; Matthieu's improvements of typing on 2011/3/11 now makes (apparently) that Amokrane's automatic eta-expansion in the coercion mechanism works; this makes its illustration as a "weakness" of universe polymorphism obsolete (example submitted by Randy Pollack). Note that this example is not an evidence that the current non-kernel eta-expansion behavior is the most expected one. *) Parameter K : forall T : Type, T -> T. Check (K (forall T : Type, T -> T) K). (* note that the inferred term is "(K (forall T (* u1 *) : Type, T -> T) (fun T:Type (* u1 *) => K T))" which is not eta-equivalent to "(K (forall T : Type, T -> T) K" because the eta-expansion of the latter "(K (forall T : Type, T -> T) (fun T:Type (* u2 *) => K T)" assuming K of type "forall T (* u2 *) : Type, T -> T" *) coq-8.4pl4/test-suite/success/autointros.v0000644000175000017500000000071612326224777020013 0ustar stephstephSet Automatic Introduction. Inductive even : nat -> Prop := | even_0 : even 0 | even_odd : forall n, odd n -> even (S n) with odd : nat -> Prop := | odd_1 : odd 1 | odd_even : forall n, even n -> odd (S n). Lemma foo {n : nat} (E : even n) : even (S (S n)) with bar {n : nat} (O : odd n) : odd (S (S n)). Proof. destruct E. constructor. constructor. apply even_odd. apply (bar _ H). destruct O. repeat constructor. apply odd_even. apply (foo _ H). Defined. coq-8.4pl4/test-suite/success/Print.v0000644000175000017500000000043212326224777016673 0ustar stephstephPrint Tables. Print ML Path. Print ML Modules. Print LoadPath. Print Graph. Print Coercions. Print Classes. Print nat. Print Term O. Print All. Print Grammar constr. Inspect 10. Section A. Coercion f (x : nat) : Prop := True. Print Coercion Paths nat Sortclass. Print Section A. coq-8.4pl4/test-suite/success/LegacyField.v0000644000175000017500000000325212326224777017752 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R) (x0 x1 : R), ((f x1 - f x0) * (1 / (x1 - x0)) + (g x1 - g x0) * (1 / (x1 - x0)))%R = ((f x1 + g x1 - (f x0 + g x0)) * (1 / (x1 - x0)))%R. Proof. intros. legacy field. Abort. (* Example 3 *) Goal forall a b : R, (1 / (a * b) * (1 / 1 / b))%R = (1 / a)%R. Proof. intros. legacy field. Abort. (* Example 4 *) Goal forall a b : R, a <> 0%R -> b <> 0%R -> (1 / (a * b) / 1 / b)%R = (1 / a)%R. Proof. intros. legacy field. Abort. (* Example 5 *) Goal forall a : R, 1%R = (1 * (1 / a) * a)%R. Proof. intros. legacy field. Abort. (* Example 6 *) Goal forall a b : R, b = (b * / a * a)%R. Proof. intros. legacy field. Abort. (* Example 7 *) Goal forall a b : R, b = (b * (1 / a) * a)%R. Proof. intros. legacy field. Abort. (* Example 8 *) Goal forall x y : R, (x * (1 / x + x / (x + y)))%R = (- (1 / y) * y * (- (x * (x / (x + y))) - 1))%R. Proof. intros. legacy field. Abort. coq-8.4pl4/test-suite/success/ROmega.v0000644000175000017500000000430212326224777016751 0ustar stephsteph Require Import ZArith ROmega. (* Submitted by Xavier Urbain 18 Jan 2002 *) Lemma lem1 : forall x y : Z, (-5 < x < 5)%Z -> (-5 < y)%Z -> (-5 < x + y + 5)%Z. Proof. intros x y. romega. Qed. (* Proposed by Pierre CrÃĐgut *) Lemma lem2 : forall x : Z, (x < 4)%Z -> (x > 2)%Z -> x = 3%Z. intro. romega. Qed. (* Proposed by Jean-Christophe FilliÃĒtre *) Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z. Proof. intros. romega. Qed. (* Proposed by Jean-Christophe FilliÃĒtre: confusion between an Omega *) (* internal variable and a section variable (June 2001) *) Section A. Variable x y : Z. Hypothesis H : (x > y)%Z. Lemma lem4 : (x > y)%Z. romega. Qed. End A. (* Proposed by Yves Bertot: because a section var, L was wrongly renamed L0 *) (* May 2002 *) Section B. Variable R1 R2 S1 S2 H S : Z. Hypothesis I : (R1 < 0)%Z -> R2 = (R1 + (2 * S1 - 1))%Z. Hypothesis J : (R1 < 0)%Z -> S2 = (S1 - 1)%Z. Hypothesis K : (R1 >= 0)%Z -> R2 = R1. Hypothesis L : (R1 >= 0)%Z -> S2 = S1. Hypothesis M : (H <= 2 * S)%Z. Hypothesis N : (S < H)%Z. Lemma lem5 : (H > 0)%Z. romega. Qed. End B. (* From Nicolas Oury (bug #180): handling -> on Set (fixed Oct 2002) *) Lemma lem6 : forall (A : Set) (i : Z), (i <= 0)%Z -> ((i <= 0)%Z -> A) -> (i <= 0)%Z. intros. romega. Qed. (* Adapted from an example in Nijmegen/FTA/ftc/RefSeparating (Oct 2002) *) Require Import Omega. Section C. Parameter g : forall m : nat, m <> 0 -> Prop. Parameter f : forall (m : nat) (H : m <> 0), g m H. Variable n : nat. Variable ap_n : n <> 0. Let delta := f n ap_n. Lemma lem7 : n = n. romega with nat. Qed. End C. (* Problem of dependencies *) Require Import Omega. Lemma lem8 : forall H : 0 = 0 -> 0 = 0, H = H -> 0 = 0. intros. romega with nat. Qed. (* Bug that what caused by the use of intro_using in Omega *) Require Import Omega. Lemma lem9 : forall p q : nat, ~ (p <= q /\ p < q \/ q <= p /\ p < q) -> p < p \/ p <= p. intros. romega with nat. Qed. (* Check that the interpretation of mult on nat enforces its positivity *) (* Submitted by Hubert Thierry (bug #743) *) (* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z" *) Lemma lem10 : forall n m : nat, le n (plus n (mult n m)). Proof. intros; romega with nat. Qed. coq-8.4pl4/test-suite/success/ImplicitArguments.v0000644000175000017500000000104112326224777021234 0ustar stephstephInductive vector {A : Type} : nat -> Type := | vnil : vector 0 | vcons : A -> forall {n'}, vector n' -> vector (S n'). Implicit Arguments vector []. Require Import Coq.Program.Program. Program Definition head {A : Type} {n : nat} (v : vector A (S n)) : vector A n := match v with | vnil => ! | vcons a n' v' => v' end. Fixpoint app {A : Type} {n m : nat} (v : vector A n) (w : vector A m) : vector A (n + m) := match v in vector _ n return vector A (n + m) with | vnil => w | vcons a n' v' => vcons a (app v' w) end. coq-8.4pl4/test-suite/success/eta.v0000644000175000017500000000112312326224777016346 0ustar stephsteph(* Kernel test (head term is a constant) *) Check (fun a : S = S => a : S = fun x => S x). (* Kernel test (head term is a variable) *) Check (fun (f:nat->nat) (a : f = f) => a : f = fun x => f x). (* Test type inference (head term is syntactically rigid) *) Check (fun (a : list = list) => a : list = fun A => _ A). (* Test type inference (head term is a variable) *) (* This one is still to be done... Check (fun (f:nat->nat) (a : f = f) => a : f = fun x => _ x). *) (* Test tactic unification *) Goal (forall f:nat->nat, (fun x => f x) = (fun x => f x)) -> S = S. intro H; apply H. Qed. coq-8.4pl4/test-suite/success/dependentind.v0000644000175000017500000000753412326224777020252 0ustar stephstephRequire Import Coq.Program.Program Coq.Program.Equality. Goal forall (H: forall n m : nat, n = m -> n = 0) x, x = tt. intros. dependent destruction x. reflexivity. Qed. Variable A : Set. Inductive vector : nat -> Type := vnil : vector 0 | vcons : A -> forall {n}, vector n -> vector (S n). Goal forall n, forall v : vector (S n), vector n. Proof. intros n H. dependent destruction H. assumption. Save. Require Import ProofIrrelevance. Goal forall n, forall v : vector (S n), exists v' : vector n, exists a : A, v = vcons a v'. Proof. intros n v. dependent destruction v. exists v ; exists a. reflexivity. Save. (* Extraction Unnamed_thm. *) Inductive type : Type := | base : type | arrow : type -> type -> type. Notation " t --> t' " := (arrow t t') (at level 20, t' at next level). Inductive ctx : Type := | empty : ctx | snoc : ctx -> type -> ctx. Bind Scope context_scope with ctx. Delimit Scope context_scope with ctx. Arguments Scope snoc [context_scope]. Notation " Γ , τ " := (snoc Γ τ) (at level 25, τ at next level, left associativity) : context_scope. Fixpoint conc (Δ Γ : ctx) : ctx := match Δ with | empty => Γ | snoc Δ' x => snoc (conc Δ' Γ) x end. Notation " Γ ; Δ " := (conc Δ Γ) (at level 25, left associativity) : context_scope. Reserved Notation " Γ âŠĒ τ " (at level 30, no associativity). Generalizable All Variables. Inductive term : ctx -> type -> Type := | ax : `(Γ, τ âŠĒ τ) | weak : `{Γ âŠĒ τ -> Γ, τ' âŠĒ τ} | abs : `{Γ, τ âŠĒ τ' -> Γ âŠĒ τ --> τ'} | app : `{Γ âŠĒ τ --> τ' -> Γ âŠĒ τ -> Γ âŠĒ τ'} where " Γ âŠĒ τ " := (term Γ τ) : type_scope. Hint Constructors term : lambda. Local Open Scope context_scope. Ltac eqns := subst ; reverse ; simplify_dep_elim ; simplify_IH_hyps. Lemma weakening : forall Γ Δ τ, Γ ; Δ âŠĒ τ -> forall τ', Γ , τ' ; Δ âŠĒ τ. Proof with simpl in * ; eqns ; eauto with lambda. intros Γ Δ τ H. dependent induction H. destruct Δ as [|Δ τ'']... destruct Δ as [|Δ τ'']... destruct Δ as [|Δ τ'']... apply abs. specialize (IHterm Γ (Δ, τ'', τ))... intro. eapply app... Defined. Lemma weakening_ctx : forall Γ Δ τ, Γ ; Δ âŠĒ τ -> forall Δ', Γ ; Δ' ; Δ âŠĒ τ. Proof with simpl in * ; eqns ; eauto with lambda. intros Γ Δ τ H. dependent induction H. destruct Δ as [|Δ τ'']... induction Δ'... destruct Δ as [|Δ τ'']... induction Δ'... destruct Δ as [|Δ τ'']... apply abs. specialize (IHterm Γ (empty, τ))... apply abs. specialize (IHterm Γ (Δ, τ'', τ))... intro. eapply app... Defined. Lemma exchange : forall Γ Δ Îą Îē τ, term (Γ, Îą, Îē ; Δ) τ -> term (Γ, Îē, Îą ; Δ) τ. Proof with simpl in * ; eqns ; eauto. intros until 1. dependent induction H. destruct Δ ; eqns. apply weak ; apply ax. apply ax. destruct Δ... pose (weakening Γ (empty, Îą))... apply weak... apply abs... specialize (IHterm Γ (Δ, τ))... eapply app... Defined. (** Example by Andrew Kenedy, uses simplification of the first component of dependent pairs. *) Set Implicit Arguments. Inductive Ty := | Nat : Ty | Prod : Ty -> Ty -> Ty. Inductive Exp : Ty -> Type := | Const : nat -> Exp Nat | Pair : forall t1 t2, Exp t1 -> Exp t2 -> Exp (Prod t1 t2) | Fst : forall t1 t2, Exp (Prod t1 t2) -> Exp t1. Inductive Ev : forall t, Exp t -> Exp t -> Prop := | EvConst : forall n, Ev (Const n) (Const n) | EvPair : forall t1 t2 (e1:Exp t1) (e2:Exp t2) e1' e2', Ev e1 e1' -> Ev e2 e2' -> Ev (Pair e1 e2) (Pair e1' e2') | EvFst : forall t1 t2 (e:Exp (Prod t1 t2)) e1 e2, Ev e (Pair e1 e2) -> Ev (Fst e) e1. Lemma EvFst_inversion : forall t1 t2 (e:Exp (Prod t1 t2)) e1, Ev (Fst e) e1 -> exists e2, Ev e (Pair e1 e2). intros t1 t2 e e1 ev. dependent destruction ev. exists e2 ; assumption. Qed. coq-8.4pl4/test-suite/interactive/0000755000175000017500000000000012365131023016236 5ustar stephstephcoq-8.4pl4/test-suite/interactive/Back.v0000644000175000017500000000030412326224777017302 0ustar stephsteph(* Check that reset remains synchronised with the compilation unit cache *) (* See bug #1030 *) Section multiset_defs. Require Import Plus. End multiset_defs. Unset Implicit Arguments. Back 1. coq-8.4pl4/test-suite/interactive/Evar.v0000644000175000017500000000026212326224777017342 0ustar stephsteph(* Check that no toplevel "unresolved evar" flees through Declare Implicit Tactic support (bug #1229) *) Goal True. (* should raise an error, not an anomaly *) set (x := _). coq-8.4pl4/test-suite/complexity/0000755000175000017500000000000012365131024016117 5ustar stephstephcoq-8.4pl4/test-suite/complexity/injection.v0000644000175000017500000000674612326224777020324 0ustar stephsteph(* This example, submitted by A. Appel, checks the efficiency of injection (see bug #1173) *) (* Expected time < 1.50s *) Set Implicit Arguments. Record joinable (t: Type) : Type := Joinable { is_empty: t -> Prop; join: t -> t -> t -> Prop; join_com: forall a b c, join a b c -> join b a c; join_empty: forall e a b, is_empty e -> join e a b -> a=b; exists_empty: forall a, exists e, is_empty e /\ join e a a; join_empty2: forall a b c, join a b c -> is_empty c -> is_empty a; join_empty3: forall e a, join e a a -> is_empty e; join_assoc: forall a b c d e, join a b d -> join d c e -> exists f, join b c f /\ join a f e; join_eq: forall x y z z', join x y z -> join x y z' -> z = z'; cancellation: forall a1 a2 b c, join a1 b c -> join a2 b c -> a1=a2 }. Record joinmap (key: Type) (t: Type) (j : joinable t) : Type := Joinmap { jm_t : Type; jm_j : joinable jm_t; lookup: jm_t -> key -> t; prim : forall (f: key -> t) (e: t), (forall k, j.(join) e (f k) (f k)) -> jm_t; join_rule: forall s1 s2 s, jm_j.(join) s1 s2 s <-> forall x, j.(join) (lookup s1 x) (lookup s2 x) (lookup s x); empty_rule: forall e x, jm_j.(is_empty) e -> j.(is_empty) (lookup e x); prim_rule: forall f e pf k, lookup (prim f e pf) k = f k; ext: forall s1 s2, (forall x, lookup s1 x = lookup s2 x) <-> s1 = s2; can_join: forall s1 s2, (forall x, exists v, j.(join) (lookup s1 x) (lookup s2 x) v) -> exists s3, jm_j.(join) s1 s2 s3; can_split: forall s1 s3, (forall x, exists v, j.(join) (lookup s1 x) v (lookup s3 x)) -> exists s2, jm_j.(join) s1 s2 s3 }. Parameter mkJoinmap : forall (key: Type) (t: Type) (j: joinable t), joinmap key j. Parameter ADMIT: forall p: Prop, p. Implicit Arguments ADMIT [p]. Module Share. Parameter jb : joinable bool. Definition jm: joinmap nat jb := mkJoinmap nat jb. Definition t := jm.(jm_t). Definition j := jm.(jm_j). Parameter nonempty: t -> Prop. End Share. Section Own. Variable inv : Type. Inductive own : Type := | NO | VAL' : forall sh, Share.nonempty sh -> own | LK : forall sh, Share.nonempty sh -> Share.t -> inv -> own | CT : forall sh, Share.nonempty sh -> own | FUN: forall sh, Share.nonempty sh -> inv -> own. Definition own_join (a b c: own) : Prop := match a , b , c with | NO , _ , _ => b=c | _ , NO , _ => a=c | VAL' sa _ , VAL' sb _, VAL' sc _ => Share.j.(join) sa sb sc | LK sa pa ha fa, LK sb pb hb fb, LK sc pc hc fc => Share.j.(join) sa sb sc /\ Share.j.(join) ha hb hc /\ fa=fc /\ fb=fc | CT sa pa , CT sb pb, CT sc pc => Share.j.(join) sa sb sc | FUN sa pa fa, FUN sb pb fb, FUN sc pc fc => Share.j.(join) sa sb sc /\ fa=fc /\ fb=fc | _ , _ , _ => False end. Definition own_is_empty (a: own) := a=NO. Definition jown : joinable own := Joinable own_is_empty own_join ADMIT ADMIT ADMIT ADMIT ADMIT ADMIT ADMIT ADMIT . End Own. Fixpoint sinv (n: nat) : Type := match n with | O => unit | S n => prodT (sinv n) (own (sinv n) -> unit -> Prop) end. Parameter address: Set. Definition jm (n: nat) := mkJoinmap address (jown (sinv n)). Definition worldfun (n: nat) := (jm n).(jm_t). Inductive world : Type := mk_world: forall n, worldfun n -> world. Lemma test: forall n1 w1 n2 w2, mk_world n1 w1 = mk_world n2 w2 -> n1 = n2. Proof. intros. Timeout 10 Time injection H. coq-8.4pl4/test-suite/complexity/lettuple.v0000644000175000017500000000113612326224777020164 0ustar stephsteph(* This example checks if printing nested let-in's stays in linear time *) (* Expected time < 1.00s *) Definition f (x : nat * nat) := let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in let (a,b) := x in 0. Timeout 5 Time Print f. coq-8.4pl4/test-suite/complexity/pretyping.v0000644000175000017500000037305612326224777020364 0ustar stephsteph(* Test parsing/interpretation/pretyping on a large example *) (* Expected time < 1.50s *) Require Import Reals. Require Import Ring_tac. Open Scope R_scope. Timeout 5 Time Goal forall x1 x2 x3 y1 y2 y3 e1 e2 e3 e4 e5 e6 e7: R, (e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * 1) * ((- (y1 - y2) * (e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x1) - e2 * y1 - e2 * y3) * ((- (y1 - y2) * (e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x1) - e2 * y1 - e2 * y3) * 1)) * e3 - (e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * ((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * 1) * ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * 1)) * (e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1) * e3 - (e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * ((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * 1) * ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * 1)) * x3 * e1 * e3 - (- (y2 - y3) * (e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x2) - e4 * y2 - e4 * y1) * ((- (y2 - y3) * (e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x2) - e4 * y2 - e4 * y1) * 1) * ((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * ((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * 1)) * e1 + (e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * ((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * 1) * ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * 1)) * (e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3) * e1 + (e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * ((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * 1) * ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * 1)) * x1 * e1 * e3 = 3 * e1 * e6 ^ 4 * e7 + e1 * e6 ^ 2 * e7 ^ 3 + e3 * e6 ^ 4 * y1 ^ 2 + 3 * e1 * e6 ^ 3 * e7 ^ 2 - 2 * e6 ^ 4 * x2 * e1 ^ 2 + 2 * e1 * e6 ^ 4 * e5 - 2 * e3 * e6 ^ 4 * e7 - 2 * e6 ^ 4 * x1 * e1 ^ 2 + e1 ^ 3 * x3 ^ 2 * e6 ^ 3 - 2 * e6 ^ 4 * e1 ^ 2 * x3 + x2 ^ 4 * e3 ^ 3 * y1 ^ 2 * e1 ^ 2 + x2 ^ 4 * e3 ^ 3 * y2 ^ 2 * e1 ^ 2 + x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 ^ 2 + x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 ^ 2 + 4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 4 * y2 ^ 2 + x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 ^ 2 + x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 ^ 2 + 4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 4 * y2 ^ 2 + 4 * e3 ^ 3 * x1 ^ 4 * y1 ^ 2 * e1 ^ 2 + 4 * e3 ^ 3 * x1 ^ 4 * y2 ^ 2 * e1 ^ 2 + e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 ^ 2 + e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e6 ^ 2 + 4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 4 * y2 ^ 2 + x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 ^ 2 + x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * e6 ^ 2 + 4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 ^ 4 + x2 ^ 2 * e3 ^ 3 * e2 ^ 2 * y1 ^ 2 + x2 ^ 2 * e3 ^ 3 * e2 ^ 2 * y3 ^ 2 + x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 ^ 2 + x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e6 ^ 2 + 4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 ^ 4 + x3 ^ 2 * e3 ^ 3 * e2 ^ 2 * y1 ^ 2 + x3 ^ 2 * e3 ^ 3 * e2 ^ 2 * y3 ^ 2 + e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e5 ^ 2 + e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e6 ^ 2 + 4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * y2 ^ 4 + e3 ^ 3 * x1 ^ 2 * e2 ^ 2 * y1 ^ 2 + e3 ^ 3 * x1 ^ 2 * e2 ^ 2 * y3 ^ 2 - 2 * e6 ^ 3 * x2 * e3 ^ 2 * y1 ^ 2 - 2 * e6 ^ 3 * x3 * e3 ^ 2 * y1 ^ 2 - 2 * e6 ^ 3 * e3 ^ 2 * x1 * y1 ^ 2 - 2 * e6 ^ 3 * x2 * e3 ^ 2 * y2 ^ 2 - 2 * e6 ^ 3 * x3 * e3 ^ 2 * y2 ^ 2 - 2 * e6 ^ 3 * e3 ^ 2 * x1 * y2 ^ 2 + 2 * e3 * e6 ^ 3 * y1 ^ 2 * e5 - 4 * e3 * e6 ^ 3 * y1 ^ 3 * y2 + 4 * e3 * e6 ^ 4 * y1 * y2 - 4 * e3 * e6 ^ 3 * y1 ^ 2 * y2 ^ 2 + 2 * e3 * e6 ^ 3 * y1 ^ 2 * e2 + 2 * e3 * e6 ^ 3 * y2 ^ 2 * e5 - 4 * e3 * e6 ^ 3 * y2 ^ 3 * y1 + e3 * e6 ^ 2 * y1 ^ 2 * e5 ^ 2 + 4 * e3 * e6 ^ 2 * y1 ^ 4 * y2 ^ 2 + 2 * e3 * e6 ^ 3 * e7 * y1 ^ 2 + e3 * e7 ^ 2 * y1 ^ 2 * e5 ^ 2 + e3 * e7 ^ 2 * y1 ^ 2 * e6 ^ 2 + 4 * e3 * e7 ^ 2 * y1 ^ 4 * y2 ^ 2 + 16 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 4 + e3 * e6 ^ 2 * y2 ^ 2 * e5 ^ 2 + 4 * e3 * e6 ^ 2 * y1 ^ 2 * y2 ^ 4 + e3 * e6 ^ 2 * e2 ^ 2 * y1 ^ 2 + e3 * e6 ^ 2 * e2 ^ 2 * y3 ^ 2 + 2 * e3 * e6 ^ 3 * e7 * y2 ^ 2 + e3 * e7 ^ 2 * y2 ^ 2 * e5 ^ 2 + e3 * e7 ^ 2 * y2 ^ 2 * e6 ^ 2 + x1 ^ 2 * e1 ^ 3 * e6 ^ 3 + x2 ^ 2 * e1 ^ 3 * e6 ^ 3 + e1 * e5 ^ 2 * e7 ^ 3 + e3 * e6 ^ 4 * y2 ^ 2 - 24 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 - 8 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e5 * e1 + 32 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 * e5 * e6 + 8 * y2 * y3 ^ 2 * x2 * e3 ^ 2 * y1 * e5 * e2 - 24 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e6 * x1 * e1 - 8 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e6 * e1 + 16 * y2 ^ 2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 ^ 3 * e1 + 8 * y2 * y3 ^ 2 * x2 * e3 ^ 2 * y1 * e6 * e2 + 48 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 ^ 3 * x1 * e1 - 16 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * x1 * e1 + 24 * y2 ^ 3 * y3 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e1 - 16 * y2 ^ 2 * y3 ^ 2 * x2 * e3 ^ 2 * y1 ^ 2 * e2 + 8 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * e6 - 16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 ^ 3 * e5 + 16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 * e5 ^ 2 - 16 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e5 + 8 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * e2 - 16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 ^ 3 * e6 + 16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 * e6 ^ 2 - 16 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e6 + 16 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e6 * e2 - 16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 ^ 3 * e2 + 32 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + 4 * y2 * y3 * x2 ^ 3 * e3 ^ 2 * y1 ^ 2 * e1 ^ 2 + 8 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * e5 * e6 - 16 * y2 ^ 4 * y3 * x2 * e3 ^ 2 * e5 * y1 - 16 * y2 ^ 4 * y3 * x2 * e3 ^ 2 * e6 * y1 + 16 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e2 + 32 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * x1 ^ 2 * e1 ^ 2 + 4 * y2 ^ 3 * y3 * x2 ^ 3 * e3 ^ 2 * e1 ^ 2 + 8 * y2 * y3 ^ 2 * x2 * e3 ^ 2 * e2 ^ 2 * y1 + 4 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 + 4 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e6 ^ 2 + 16 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * y1 ^ 4 - 16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 - 8 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x2 * e1 + 32 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e5 * e6 + 8 * y2 * y3 ^ 2 * x3 * e3 ^ 2 * y1 * e5 * e2 - 16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * x1 * e1 - 8 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * x2 * e1 + 8 * y2 * y3 ^ 2 * x3 * e3 ^ 2 * y1 * e6 * e2 + 32 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 ^ 3 * x1 * e1 + 16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 ^ 3 * x2 * e1 - 16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 + 16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x2 * e1 - 16 * y2 ^ 2 * y3 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * e2 + 8 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * e6 - 16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 ^ 3 * e5 + 16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e5 ^ 2 - 16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 + 8 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * e2 - 16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 ^ 3 * e6 + 16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e6 ^ 2 - 16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e6 + 16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * e2 - 16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 ^ 3 * e2 + 16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + 4 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 + 8 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e5 * e6 - 16 * y2 ^ 4 * y3 * x3 * e3 ^ 2 * e5 * y1 - 16 * y2 ^ 4 * y3 * x3 * e3 ^ 2 * e6 * y1 + 16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e2 + 16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * x1 ^ 2 * e1 ^ 2 + 4 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * x2 ^ 2 * e1 ^ 2 + 8 * y2 * y3 ^ 2 * x3 * e3 ^ 2 * e2 ^ 2 * y1 + 4 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 + 4 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e6 ^ 2 + 16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 4 - 16 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e5 * e1 + 32 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 * e5 * e6 + 8 * y2 * y3 ^ 2 * e3 ^ 2 * x1 * y1 * e5 * e2 - 16 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e6 * e1 + 8 * y2 * y3 ^ 2 * e3 ^ 2 * x1 * y1 * e6 * e2 + 32 * y2 ^ 2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 ^ 3 * e1 - 8 * y2 ^ 3 * y3 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e1 - 16 * y2 ^ 2 * y3 ^ 2 * e3 ^ 2 * x1 * y1 ^ 2 * e2 + 8 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * e6 - 16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 ^ 3 * e5 + 16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 * e5 ^ 2 - 16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e5 + 8 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * e2 - 16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 ^ 3 * e6 + 16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 * e6 ^ 2 - 16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e6 + 16 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e6 * e2 - 16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 ^ 3 * e2 + 16 * y2 * y3 * e3 ^ 2 * x1 ^ 3 * y1 ^ 2 * e1 ^ 2 + 20 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 + 8 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * e5 * e6 - 16 * y2 ^ 4 * y3 * e3 ^ 2 * x1 * e5 * y1 - 16 * y2 ^ 4 * y3 * e3 ^ 2 * x1 * e6 * y1 + 16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e2 + 16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 ^ 3 * e1 ^ 2 + 20 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * x2 ^ 2 * e1 ^ 2 + 8 * y2 * y3 ^ 2 * e3 ^ 2 * x1 * e2 ^ 2 * y1 + 4 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e5 ^ 2 + 4 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e6 ^ 2 + 16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * y1 ^ 4 - 8 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * x1 * e1 - 2 * x2 ^ 3 * e3 ^ 3 * y1 ^ 2 * e5 * e1 + 8 * x2 ^ 2 * e3 ^ 3 * y1 * e5 * y2 * e6 + 2 * x2 ^ 2 * e3 ^ 3 * y1 * e5 * e2 * y3 - 8 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * x1 * e1 - 2 * x2 ^ 3 * e3 ^ 3 * y1 ^ 2 * e6 * e1 + 2 * x2 ^ 2 * e3 ^ 3 * y1 * e6 * e2 * y3 + 16 * x2 ^ 2 * e3 ^ 3 * y1 ^ 3 * y2 * x1 * e1 + 4 * x2 ^ 3 * e3 ^ 3 * y1 ^ 3 * y2 * e1 - 4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 * e2 * y3 + 2 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * e6 - 4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 3 * e5 * y2 + 4 * x2 ^ 2 * e3 ^ 3 * y1 * e5 ^ 2 * y2 - 4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * y2 ^ 2 + 2 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * e2 - 4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 3 * e6 * y2 + 4 * x2 ^ 2 * e3 ^ 3 * y1 * e6 ^ 2 * y2 - 4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * y2 ^ 2 + 2 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * e2 - 4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 3 * y2 * e2 + 13 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + 2 * x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 * e6 - 4 * x2 ^ 2 * e3 ^ 3 * y2 ^ 3 * e5 * y1 - 4 * x2 ^ 2 * e3 ^ 3 * y2 ^ 3 * e6 * y1 + 4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 ^ 2 * e2 + 13 * x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 + 2 * x2 ^ 2 * e3 ^ 3 * e2 ^ 2 * y1 * y3 - 4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * x1 * e1 - 2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * x2 * e1 + 8 * x3 ^ 2 * e3 ^ 3 * y1 * e5 * y2 * e6 + 2 * x3 ^ 2 * e3 ^ 3 * y1 * e5 * e2 * y3 - 4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * x1 * e1 - 2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * x2 * e1 + 2 * x3 ^ 2 * e3 ^ 3 * y1 * e6 * e2 * y3 + 8 * x3 ^ 2 * e3 ^ 3 * y1 ^ 3 * y2 * x1 * e1 + 4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 3 * y2 * x2 * e1 - 4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 * e2 * y3 + 2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * e6 - 4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 3 * e5 * y2 + 4 * x3 ^ 2 * e3 ^ 3 * y1 * e5 ^ 2 * y2 - 4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * y2 ^ 2 + 2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * e2 - 4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 3 * e6 * y2 + 4 * x3 ^ 2 * e3 ^ 3 * y1 * e6 ^ 2 * y2 - 4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * y2 ^ 2 + 2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * e2 - 4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 3 * y2 * e2 + 4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 + 2 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 * e6 - 4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 3 * e5 * y1 - 4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 3 * e6 * y1 + 4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 ^ 2 * e2 + 4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 + x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 + 2 * x3 ^ 2 * e3 ^ 3 * e2 ^ 2 * y1 * y3 - 4 * e3 ^ 3 * x1 ^ 3 * y1 ^ 2 * e5 * e1 - 10 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 * x2 * e1 + 8 * e3 ^ 3 * x1 ^ 2 * y1 * e5 * y2 * e6 + 2 * e3 ^ 3 * x1 ^ 2 * y1 * e5 * e2 * y3 - 4 * e3 ^ 3 * x1 ^ 3 * y1 ^ 2 * e6 * e1 - 10 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e6 * x2 * e1 + 2 * e3 ^ 3 * x1 ^ 2 * y1 * e6 * e2 * y3 + 8 * e3 ^ 3 * x1 ^ 3 * y1 ^ 3 * y2 * e1 + 20 * e3 ^ 3 * x1 ^ 2 * y1 ^ 3 * y2 * x2 * e1 - 4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * y2 * e2 * y3 + 2 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 * e6 - 4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 3 * e5 * y2 + 4 * e3 ^ 3 * x1 ^ 2 * y1 * e5 ^ 2 * y2 - 4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 + 2 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 * e2 - 4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 3 * e6 * y2 + 4 * e3 ^ 3 * x1 ^ 2 * y1 * e6 ^ 2 * y2 - 4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e6 * y2 ^ 2 + 2 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e6 * e2 - 4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 3 * y2 * e2 + 2 * e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e5 * e6 - 4 * e3 ^ 3 * x1 ^ 2 * y2 ^ 3 * e5 * y1 - 4 * e3 ^ 3 * x1 ^ 2 * y2 ^ 3 * e6 * y1 + 4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 + 2 * e3 ^ 3 * x1 ^ 2 * e2 ^ 2 * y1 * y3 + 4 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * e5 ^ 2 + 4 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * e6 ^ 2 + 16 * y2 ^ 5 * y3 * x2 * e3 ^ 2 * y1 ^ 2 + 4 * y2 * y3 * x2 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 + 4 * y2 * y3 ^ 3 * x2 * e3 ^ 2 * e2 ^ 2 - 32 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 * e5 * x1 * e1 - 40 * y2 ^ 2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 * e5 * e1 - 32 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 * e6 * x1 * e1 - 40 * y2 ^ 2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 * e6 * e1 - 24 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 + 24 * y2 ^ 2 * y3 * x2 ^ 3 * e3 ^ 2 * y1 * e1 ^ 2 - 8 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e1 * e2 - 24 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * e5 * x1 * e1 - 8 * y2 ^ 3 * y3 * x2 ^ 2 * e3 ^ 2 * e5 * e1 - 8 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * e5 * e2 * y1 - 8 * y2 ^ 2 * y3 ^ 2 * x2 * e3 ^ 2 * e5 * e2 - 24 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * e6 * x1 * e1 - 8 * y2 ^ 3 * y3 * x2 ^ 2 * e3 ^ 2 * e6 * e1 - 16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * e6 * e2 * y1 - 8 * y2 ^ 2 * y3 ^ 2 * x2 * e3 ^ 2 * e6 * e2 + 48 * y2 ^ 4 * y3 * x2 * e3 ^ 2 * y1 * x1 * e1 + 16 * y2 ^ 4 * y3 * x2 ^ 2 * e3 ^ 2 * y1 * e1 + 16 * y2 ^ 3 * y3 ^ 2 * x2 * e3 ^ 2 * y1 * e2 + 24 * y2 ^ 2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 * x1 * e1 ^ 2 - 24 * y2 * y3 ^ 2 * x2 * e3 ^ 2 * y1 * x1 * e1 * e2 - 8 * y2 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 * e1 * e2 + 24 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * x1 * e1 * e2 * y1 + 24 * y2 ^ 2 * y3 ^ 2 * x2 * e3 ^ 2 * x1 * e1 * e2 + 8 * y2 ^ 2 * y3 * x2 ^ 2 * e3 ^ 2 * e1 * e2 * y1 + 8 * y2 ^ 2 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e1 * e2 + 4 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e5 ^ 2 + 4 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e6 ^ 2 + 16 * y2 ^ 5 * y3 * x3 * e3 ^ 2 * y1 ^ 2 + 4 * y2 * y3 * x3 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 + 4 * y2 * y3 ^ 3 * x3 * e3 ^ 2 * e2 ^ 2 - 16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e5 * x1 * e1 - 32 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e5 * x2 * e1 - 16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e6 * x1 * e1 - 32 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e6 * x2 * e1 + 16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 - 16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 + 24 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 - 8 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x2 * e1 * e2 - 16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e5 * x1 * e1 - 8 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e5 * x2 * e1 - 8 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * e5 * e2 * y1 - 8 * y2 ^ 2 * y3 ^ 2 * x3 * e3 ^ 2 * e5 * e2 - 16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e6 * x1 * e1 - 8 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e6 * x2 * e1 - 16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * e6 * e2 * y1 - 8 * y2 ^ 2 * y3 ^ 2 * x3 * e3 ^ 2 * e6 * e2 + 32 * y2 ^ 4 * y3 * x3 * e3 ^ 2 * y1 * x1 * e1 + 16 * y2 ^ 4 * y3 * x3 * e3 ^ 2 * y1 * x2 * e1 + 16 * y2 ^ 3 * y3 ^ 2 * x3 * e3 ^ 2 * y1 * e2 + 16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * x1 * e1 ^ 2 * x2 - 16 * y2 * y3 ^ 2 * x3 * e3 ^ 2 * y1 * x1 * e1 * e2 - 8 * y2 * y3 ^ 2 * x3 * e3 ^ 2 * y1 * x2 * e1 * e2 + 16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * x1 * e1 * e2 * y1 + 16 * y2 ^ 2 * y3 ^ 2 * x3 * e3 ^ 2 * x1 * e1 * e2 + 8 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * x2 * e1 * e2 * y1 + 8 * y2 ^ 2 * y3 ^ 2 * x3 * e3 ^ 2 * x2 * e1 * e2 + 4 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * e5 ^ 2 + 4 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * e6 ^ 2 + 16 * y2 ^ 5 * y3 * e3 ^ 2 * x1 * y1 ^ 2 + 4 * y2 * y3 * e3 ^ 2 * x1 * e2 ^ 2 * y1 ^ 2 + 4 * y2 * y3 ^ 3 * e3 ^ 2 * x1 * e2 ^ 2 - 24 * y2 ^ 2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 * e5 * e1 - 24 * y2 ^ 2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 * e6 * e1 - 16 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e1 * e2 - 16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 ^ 2 * e5 * e1 - 8 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * e5 * e2 * y1 - 8 * y2 ^ 2 * y3 ^ 2 * e3 ^ 2 * x1 * e5 * e2 - 16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 ^ 2 * e6 * e1 - 16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * e6 * e2 * y1 - 8 * y2 ^ 2 * y3 ^ 2 * e3 ^ 2 * x1 * e6 * e2 + 32 * y2 ^ 4 * y3 * e3 ^ 2 * x1 ^ 2 * y1 * e1 + 16 * y2 ^ 3 * y3 ^ 2 * e3 ^ 2 * x1 * y1 * e2 - 16 * y2 * y3 ^ 2 * e3 ^ 2 * x1 ^ 2 * y1 * e1 * e2 + 16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 ^ 2 * e1 * e2 * y1 + 16 * y2 ^ 2 * y3 ^ 2 * e3 ^ 2 * x1 ^ 2 * e1 * e2 - 16 * x2 ^ 2 * e3 ^ 3 * y1 * e5 * y2 * x1 * e1 - 4 * x2 ^ 3 * e3 ^ 3 * y1 * e5 * y2 * e1 - 16 * x2 ^ 2 * e3 ^ 3 * y1 * e6 * y2 * x1 * e1 - 4 * x2 ^ 3 * e3 ^ 3 * y1 * e6 * y2 * e1 + 6 * x2 ^ 3 * e3 ^ 3 * y1 ^ 2 * x1 * e1 ^ 2 + 10 * x2 ^ 2 * e3 ^ 3 * y1 * x1 ^ 2 * e1 ^ 2 * y2 - 8 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * x1 * e1 * e2 - 2 * x2 ^ 3 * e3 ^ 3 * y1 ^ 2 * e1 * e2 - 8 * x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 * x1 * e1 - 2 * x2 ^ 3 * e3 ^ 3 * y2 ^ 2 * e5 * e1 - 2 * x2 ^ 2 * e3 ^ 3 * y2 * e5 * e2 * y1 - 2 * x2 ^ 2 * e3 ^ 3 * y2 * e5 * e2 * y3 - 8 * x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * e6 * x1 * e1 - 2 * x2 ^ 3 * e3 ^ 3 * y2 ^ 2 * e6 * e1 - 2 * x2 ^ 2 * e3 ^ 3 * y2 * e6 * e2 * y1 - 2 * x2 ^ 2 * e3 ^ 3 * y2 * e6 * e2 * y3 + 16 * x2 ^ 2 * e3 ^ 3 * y1 * y2 ^ 3 * x1 * e1 + 4 * x2 ^ 3 * e3 ^ 3 * y1 * y2 ^ 3 * e1 + 4 * x2 ^ 2 * e3 ^ 3 * y1 * y2 ^ 2 * e2 * y3 + 6 * x2 ^ 3 * e3 ^ 3 * y2 ^ 2 * x1 * e1 ^ 2 + 4 * x2 ^ 3 * e3 ^ 3 * y1 * x1 * e1 ^ 2 * y2 - 8 * x2 ^ 2 * e3 ^ 3 * y1 * x1 * e1 * e2 * y3 - 2 * x2 ^ 3 * e3 ^ 3 * y1 * e1 * e2 * y3 + 8 * x2 ^ 2 * e3 ^ 3 * y2 * x1 * e1 * e2 * y1 + 8 * x2 ^ 2 * e3 ^ 3 * y2 * x1 * e1 * e2 * y3 + 2 * x2 ^ 3 * e3 ^ 3 * y2 * e1 * e2 * y1 + 2 * x2 ^ 3 * e3 ^ 3 * y2 * e1 * e2 * y3 - 8 * x3 ^ 2 * e3 ^ 3 * y1 * e5 * y2 * x1 * e1 - 4 * x3 ^ 2 * e3 ^ 3 * y1 * e5 * y2 * x2 * e1 - 8 * x3 ^ 2 * e3 ^ 3 * y1 * e6 * y2 * x1 * e1 - 4 * x3 ^ 2 * e3 ^ 3 * y1 * e6 * y2 * x2 * e1 + 4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * x1 * e1 ^ 2 * x2 + 4 * x3 ^ 2 * e3 ^ 3 * y1 * x1 ^ 2 * e1 ^ 2 * y2 - 4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * x1 * e1 * e2 - 14 * x3 ^ 2 * e3 ^ 3 * y1 * x2 ^ 2 * e1 ^ 2 * y2 - 2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * x2 * e1 * e2 - 4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 * x1 * e1 - 2 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 * x2 * e1 - 2 * x3 ^ 2 * e3 ^ 3 * y2 * e5 * e2 * y1 - 2 * x3 ^ 2 * e3 ^ 3 * y2 * e5 * e2 * y3 - 4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e6 * x1 * e1 - 2 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e6 * x2 * e1 - 2 * x3 ^ 2 * e3 ^ 3 * y2 * e6 * e2 * y1 - 2 * x3 ^ 2 * e3 ^ 3 * y2 * e6 * e2 * y3 + 8 * x3 ^ 2 * e3 ^ 3 * y1 * y2 ^ 3 * x1 * e1 + 4 * x3 ^ 2 * e3 ^ 3 * y1 * y2 ^ 3 * x2 * e1 + 4 * x3 ^ 2 * e3 ^ 3 * y1 * y2 ^ 2 * e2 * y3 + 4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * x1 * e1 ^ 2 * x2 - 8 * x3 ^ 2 * e3 ^ 3 * y1 * x1 * e1 ^ 2 * y2 * x2 - 4 * x3 ^ 2 * e3 ^ 3 * y1 * x1 * e1 * e2 * y3 - 2 * x3 ^ 2 * e3 ^ 3 * y1 * x2 * e1 * e2 * y3 + 4 * x3 ^ 2 * e3 ^ 3 * y2 * x1 * e1 * e2 * y1 + 4 * x3 ^ 2 * e3 ^ 3 * y2 * x1 * e1 * e2 * y3 + 2 * x3 ^ 2 * e3 ^ 3 * y2 * x2 * e1 * e2 * y1 + 2 * x3 ^ 2 * e3 ^ 3 * y2 * x2 * e1 * e2 * y3 - 8 * e3 ^ 3 * x1 ^ 3 * y1 * e5 * y2 * e1 - 20 * e3 ^ 3 * x1 ^ 2 * y1 * e5 * y2 * x2 * e1 - 8 * e3 ^ 3 * x1 ^ 3 * y1 * e6 * y2 * e1 - 20 * e3 ^ 3 * x1 ^ 2 * y1 * e6 * y2 * x2 * e1 + 12 * e3 ^ 3 * x1 ^ 3 * y1 ^ 2 * e1 ^ 2 * x2 + 2 * e3 ^ 3 * x1 ^ 4 * y1 * e1 ^ 2 * y2 - 4 * e3 ^ 3 * x1 ^ 3 * y1 ^ 2 * e1 * e2 - 10 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * x2 * e1 * e2 - 4 * e3 ^ 3 * x1 ^ 3 * y2 ^ 2 * e5 * e1 - 10 * e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e5 * x2 * e1 - 2 * e3 ^ 3 * x1 ^ 2 * y2 * e5 * e2 * y1 - 2 * e3 ^ 3 * x1 ^ 2 * y2 * e5 * e2 * y3 - 4 * e3 ^ 3 * x1 ^ 3 * y2 ^ 2 * e6 * e1 - 10 * e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e6 * x2 * e1 - 2 * e3 ^ 3 * x1 ^ 2 * y2 * e6 * e2 * y1 - 2 * e3 ^ 3 * x1 ^ 2 * y2 * e6 * e2 * y3 + 8 * e3 ^ 3 * x1 ^ 3 * y1 * y2 ^ 3 * e1 + 20 * e3 ^ 3 * x1 ^ 2 * y1 * y2 ^ 3 * x2 * e1 + 4 * e3 ^ 3 * x1 ^ 2 * y1 * y2 ^ 2 * e2 * y3 + 12 * e3 ^ 3 * x1 ^ 3 * y2 ^ 2 * e1 ^ 2 * x2 + 8 * e3 ^ 3 * x1 ^ 3 * y1 * e1 ^ 2 * y2 * x2 - 4 * e3 ^ 3 * x1 ^ 3 * y1 * e1 * e2 * y3 - 10 * e3 ^ 3 * x1 ^ 2 * y1 * x2 * e1 * e2 * y3 + 4 * e3 ^ 3 * x1 ^ 3 * y2 * e1 * e2 * y1 + 4 * e3 ^ 3 * x1 ^ 3 * y2 * e1 * e2 * y3 + 10 * e3 ^ 3 * x1 ^ 2 * y2 * x2 * e1 * e2 * y1 + 10 * e3 ^ 3 * x1 ^ 2 * y2 * x2 * e1 * e2 * y3 + 2 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * e5 ^ 2 - 12 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 * x1 * e1 - 4 * x2 ^ 2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 * e1 + 16 * x2 * e3 ^ 3 * x3 * y1 * e5 * y2 * e6 + 4 * x2 * e3 ^ 3 * x3 * y1 * e5 * e2 * y3 - 12 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e6 * x1 * e1 - 4 * x2 ^ 2 * e3 ^ 3 * x3 * y1 ^ 2 * e6 * e1 + 4 * x2 * e3 ^ 3 * x3 * y1 * e6 * e2 * y3 + 24 * x2 * e3 ^ 3 * x3 * y1 ^ 3 * y2 * x1 * e1 + 8 * x2 ^ 2 * e3 ^ 3 * x3 * y1 ^ 3 * y2 * e1 - 8 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * y2 * e2 * y3 + 4 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 * e6 - 8 * x2 * e3 ^ 3 * x3 * y1 ^ 3 * e5 * y2 + 8 * x2 * e3 ^ 3 * x3 * y1 * e5 ^ 2 * y2 - 8 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 * y2 ^ 2 + 4 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 * e2 - 8 * x2 * e3 ^ 3 * x3 * y1 ^ 3 * e6 * y2 + 8 * x2 * e3 ^ 3 * x3 * y1 * e6 ^ 2 * y2 - 8 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e6 * y2 ^ 2 + 4 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e6 * e2 - 8 * x2 * e3 ^ 3 * x3 * y1 ^ 3 * y2 * e2 + 16 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + 2 * x2 ^ 3 * e3 ^ 3 * x3 * y1 ^ 2 * e1 ^ 2 + 4 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * e5 * e6 - 8 * x2 * e3 ^ 3 * x3 * y2 ^ 3 * e5 * y1 - 8 * x2 * e3 ^ 3 * x3 * y2 ^ 3 * e6 * y1 + 8 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * y2 ^ 2 * e2 + 16 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 + 2 * x2 ^ 3 * e3 ^ 3 * x3 * y2 ^ 2 * e1 ^ 2 + 4 * x2 * e3 ^ 3 * x3 * e2 ^ 2 * y1 * y3 + 2 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 ^ 2 + 2 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e6 ^ 2 + 8 * x2 * e3 ^ 3 * x3 * y1 ^ 4 * y2 ^ 2 + 16 * x2 * e3 ^ 3 * x1 * y1 * e5 * y2 * e6 + 4 * x2 * e3 ^ 3 * x1 * y1 * e5 * e2 * y3 + 4 * x2 * e3 ^ 3 * x1 * y1 * e6 * e2 * y3 - 8 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * y2 * e2 * y3 + 4 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * e6 - 8 * x2 * e3 ^ 3 * x1 * y1 ^ 3 * e5 * y2 + 8 * x2 * e3 ^ 3 * x1 * y1 * e5 ^ 2 * y2 - 8 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * y2 ^ 2 + 4 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * e2 - 8 * x2 * e3 ^ 3 * x1 * y1 ^ 3 * e6 * y2 + 8 * x2 * e3 ^ 3 * x1 * y1 * e6 ^ 2 * y2 - 8 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e6 * y2 ^ 2 + 4 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e6 * e2 - 8 * x2 * e3 ^ 3 * x1 * y1 ^ 3 * y2 * e2 + 4 * x2 * e3 ^ 3 * x1 * y2 ^ 2 * e5 * e6 - 8 * x2 * e3 ^ 3 * x1 * y2 ^ 3 * e5 * y1 - 8 * x2 * e3 ^ 3 * x1 * y2 ^ 3 * e6 * y1 + 8 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * y2 ^ 2 * e2 + 4 * x2 * e3 ^ 3 * x1 * e2 ^ 2 * y1 * y3 + 2 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e5 ^ 2 + 2 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e6 ^ 2 + 8 * x2 * e3 ^ 3 * x1 * y1 ^ 4 * y2 ^ 2 - 8 * x3 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 * e1 + 16 * x3 * e3 ^ 3 * x1 * y1 * e5 * y2 * e6 + 4 * x3 * e3 ^ 3 * x1 * y1 * e5 * e2 * y3 - 8 * x3 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e6 * e1 + 4 * x3 * e3 ^ 3 * x1 * y1 * e6 * e2 * y3 + 16 * x3 * e3 ^ 3 * x1 ^ 2 * y1 ^ 3 * y2 * e1 - 8 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * y2 * e2 * y3 + 4 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * e6 - 8 * x3 * e3 ^ 3 * x1 * y1 ^ 3 * e5 * y2 + 8 * x3 * e3 ^ 3 * x1 * y1 * e5 ^ 2 * y2 - 8 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * y2 ^ 2 + 4 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * e2 - 8 * x3 * e3 ^ 3 * x1 * y1 ^ 3 * e6 * y2 + 8 * x3 * e3 ^ 3 * x1 * y1 * e6 ^ 2 * y2 - 8 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e6 * y2 ^ 2 + 4 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e6 * e2 - 8 * x3 * e3 ^ 3 * x1 * y1 ^ 3 * y2 * e2 + 8 * x3 * e3 ^ 3 * x1 ^ 3 * y1 ^ 2 * e1 ^ 2 + 10 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 + 4 * x3 * e3 ^ 3 * x1 * y2 ^ 2 * e5 * e6 - 8 * x3 * e3 ^ 3 * x1 * y2 ^ 3 * e5 * y1 - 8 * x3 * e3 ^ 3 * x1 * y2 ^ 3 * e6 * y1 + 8 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * y2 ^ 2 * e2 + 8 * x3 * e3 ^ 3 * x1 ^ 3 * y2 ^ 2 * e1 ^ 2 + 10 * x3 * e3 ^ 3 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 + 4 * x3 * e3 ^ 3 * x1 * e2 ^ 2 * y1 * y3 + 2 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e5 ^ 2 + 2 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e6 ^ 2 + 8 * x3 * e3 ^ 3 * x1 * y1 ^ 4 * y2 ^ 2 + 12 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 + 4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e5 * e1 - 16 * e6 ^ 2 * x2 * e3 ^ 2 * y1 * e5 * y2 - 4 * e6 * x2 * e3 ^ 2 * y1 * e5 * e2 * y3 + 12 * e6 ^ 2 * x2 * e3 ^ 2 * y1 ^ 2 * x1 * e1 + 4 * e6 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e1 - 4 * e6 ^ 2 * x2 * e3 ^ 2 * y1 * e2 * y3 - 24 * e6 * x2 * e3 ^ 2 * y1 ^ 3 * y2 * x1 * e1 - 8 * e6 * x2 ^ 2 * e3 ^ 2 * y1 ^ 3 * y2 * e1 + 8 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 + 4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e1 - 4 * e6 ^ 2 * x2 * e3 ^ 2 * y1 ^ 2 * e5 + 8 * e6 * x2 * e3 ^ 2 * y1 ^ 3 * e5 * y2 - 8 * e6 * x2 * e3 ^ 2 * y1 * e5 ^ 2 * y2 + 8 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 - 4 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * e2 + 8 * e6 ^ 2 * x2 * e3 ^ 2 * y1 ^ 3 * y2 - 8 * e6 ^ 3 * x2 * e3 ^ 2 * y1 * y2 + 8 * e6 ^ 2 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 - 4 * e6 ^ 2 * x2 * e3 ^ 2 * y1 ^ 2 * e2 + 8 * e6 * x2 * e3 ^ 2 * y1 ^ 3 * y2 * e2 - 16 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 - 2 * e6 * x2 ^ 3 * e3 ^ 2 * y1 ^ 2 * e1 ^ 2 - 4 * e6 ^ 2 * x2 * e3 ^ 2 * y2 ^ 2 * e5 + 8 * e6 * x2 * e3 ^ 2 * y2 ^ 3 * e5 * y1 + 8 * e6 ^ 2 * x2 * e3 ^ 2 * y2 ^ 3 * y1 - 8 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 - 16 * e6 * x2 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 + 6 * e6 * x2 ^ 3 * e3 ^ 2 * y2 ^ 2 * e1 ^ 2 - 4 * e6 * x2 * e3 ^ 2 * e2 ^ 2 * y1 * y3 - 2 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 - 8 * e6 * x2 * e3 ^ 2 * y1 ^ 4 * y2 ^ 2 + 8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 + 4 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x2 * e1 - 16 * e6 ^ 2 * x3 * e3 ^ 2 * y1 * e5 * y2 - 4 * e6 * x3 * e3 ^ 2 * y1 * e5 * e2 * y3 + 8 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 + 4 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * x2 * e1 - 4 * e6 ^ 2 * x3 * e3 ^ 2 * y1 * e2 * y3 - 16 * e6 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * x1 * e1 - 8 * e6 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * x2 * e1 + 8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 + 8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x2 * e1 - 4 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * e5 + 8 * e6 * x3 * e3 ^ 2 * y1 ^ 3 * e5 * y2 - 8 * e6 * x3 * e3 ^ 2 * y1 * e5 ^ 2 * y2 + 8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 - 4 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * e2 + 8 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 3 * y2 - 8 * e6 ^ 3 * x3 * e3 ^ 2 * y1 * y2 + 8 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 - 4 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * e2 + 8 * e6 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * e2 - 8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 - 2 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 - 4 * e6 ^ 2 * x3 * e3 ^ 2 * y2 ^ 2 * e5 + 8 * e6 * x3 * e3 ^ 2 * y2 ^ 3 * e5 * y1 + 8 * e6 ^ 2 * x3 * e3 ^ 2 * y2 ^ 3 * y1 - 8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 - 8 * e6 * x3 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 + 14 * e6 * x3 * e3 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 - 4 * e6 * x3 * e3 ^ 2 * e2 ^ 2 * y1 * y3 - 2 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 - 8 * e6 * x3 * e3 ^ 2 * y1 ^ 4 * y2 ^ 2 + 8 * e6 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e5 * e1 - 16 * e6 ^ 2 * e3 ^ 2 * x1 * y1 * e5 * y2 - 4 * e6 * e3 ^ 2 * x1 * y1 * e5 * e2 * y3 + 8 * e6 ^ 2 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e1 - 4 * e6 ^ 2 * e3 ^ 2 * x1 * y1 * e2 * y3 - 16 * e6 * e3 ^ 2 * x1 ^ 2 * y1 ^ 3 * y2 * e1 + 4 * e6 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * y2 ^ 2 * e1 - 4 * e6 ^ 2 * e3 ^ 2 * x1 * y1 ^ 2 * e5 + 8 * e6 * e3 ^ 2 * x1 * y1 ^ 3 * e5 * y2 - 8 * e6 * e3 ^ 2 * x1 * y1 * e5 ^ 2 * y2 + 8 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * y2 ^ 2 - 4 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * e2 + 8 * e6 ^ 2 * e3 ^ 2 * x1 * y1 ^ 3 * y2 - 8 * e6 ^ 3 * e3 ^ 2 * x1 * y1 * y2 + 8 * e6 ^ 2 * e3 ^ 2 * x1 * y1 ^ 2 * y2 ^ 2 - 4 * e6 ^ 2 * e3 ^ 2 * x1 * y1 ^ 2 * e2 + 8 * e6 * e3 ^ 2 * x1 * y1 ^ 3 * y2 * e2 - 8 * e6 * e3 ^ 2 * x1 ^ 3 * y1 ^ 2 * e1 ^ 2 - 10 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 - 4 * e6 ^ 2 * e3 ^ 2 * x1 * y2 ^ 2 * e5 + 8 * e6 * e3 ^ 2 * x1 * y2 ^ 3 * e5 * y1 + 8 * e6 ^ 2 * e3 ^ 2 * x1 * y2 ^ 3 * y1 - 8 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * y2 ^ 2 * e2 - 8 * e6 * e3 ^ 2 * x1 ^ 3 * y2 ^ 2 * e1 ^ 2 - 2 * e6 * e3 ^ 2 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 - 4 * e6 * e3 ^ 2 * x1 * e2 ^ 2 * y1 * y3 - 2 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * e5 ^ 2 - 8 * e6 * e3 ^ 2 * x1 * y1 ^ 4 * y2 ^ 2 + 12 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 + 4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e5 * e1 - 16 * e7 * x2 * e3 ^ 2 * y1 * e5 * y2 * e6 - 4 * e7 * x2 * e3 ^ 2 * y1 * e5 * e2 * y3 + 12 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e6 * x1 * e1 + 4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e6 * e1 - 4 * e7 * x2 * e3 ^ 2 * y1 * e6 * e2 * y3 - 24 * e7 * x2 * e3 ^ 2 * y1 ^ 3 * y2 * x1 * e1 - 8 * e7 * x2 ^ 2 * e3 ^ 2 * y1 ^ 3 * y2 * e1 + 8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 + 4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e1 + 8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * y2 * e2 * y3 - 4 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * e6 + 8 * e7 * x2 * e3 ^ 2 * y1 ^ 3 * e5 * y2 - 8 * e7 * x2 * e3 ^ 2 * y1 * e5 ^ 2 * y2 + 8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 - 4 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * e2 + 8 * e7 * x2 * e3 ^ 2 * y1 ^ 3 * e6 * y2 - 8 * e7 * x2 * e3 ^ 2 * y1 * e6 ^ 2 * y2 + 8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e6 * y2 ^ 2 - 4 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e6 * e2 + 8 * e7 * x2 * e3 ^ 2 * y1 ^ 3 * y2 * e2 - 16 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 - 2 * e7 * x2 ^ 3 * e3 ^ 2 * y1 ^ 2 * e1 ^ 2 - 4 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * e5 * e6 + 8 * e7 * x2 * e3 ^ 2 * y2 ^ 3 * e5 * y1 + 8 * e7 * x2 * e3 ^ 2 * y2 ^ 3 * e6 * y1 - 8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 - 16 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 - 2 * e7 * x2 ^ 3 * e3 ^ 2 * y2 ^ 2 * e1 ^ 2 - 4 * e7 * x2 * e3 ^ 2 * e2 ^ 2 * y1 * y3 - 2 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 - 2 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e6 ^ 2 - 8 * e7 * x2 * e3 ^ 2 * y1 ^ 4 * y2 ^ 2 + 8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 + 4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x2 * e1 - 16 * e7 * x3 * e3 ^ 2 * y1 * e5 * y2 * e6 - 4 * e7 * x3 * e3 ^ 2 * y1 * e5 * e2 * y3 + 8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * x1 * e1 + 4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * x2 * e1 - 4 * e7 * x3 * e3 ^ 2 * y1 * e6 * e2 * y3 - 16 * e7 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * x1 * e1 - 8 * e7 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * x2 * e1 + 8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 + 8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x2 * e1 + 8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * y2 * e2 * y3 - 4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * e6 + 8 * e7 * x3 * e3 ^ 2 * y1 ^ 3 * e5 * y2 - 8 * e7 * x3 * e3 ^ 2 * y1 * e5 ^ 2 * y2 + 8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 - 4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * e2 + 8 * e7 * x3 * e3 ^ 2 * y1 ^ 3 * e6 * y2 - 8 * e7 * x3 * e3 ^ 2 * y1 * e6 ^ 2 * y2 + 8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * y2 ^ 2 - 4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * e2 + 8 * e7 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * e2 - 8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 - 2 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 - 4 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e5 * e6 + 8 * e7 * x3 * e3 ^ 2 * y2 ^ 3 * e5 * y1 + 8 * e7 * x3 * e3 ^ 2 * y2 ^ 3 * e6 * y1 - 8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 - 8 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 - 2 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 - 4 * e7 * x3 * e3 ^ 2 * e2 ^ 2 * y1 * y3 - 2 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 - 2 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e6 ^ 2 - 8 * e7 * x3 * e3 ^ 2 * y1 ^ 4 * y2 ^ 2 + 8 * e7 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e5 * e1 - 16 * e7 * e3 ^ 2 * x1 * y1 * e5 * y2 * e6 - 4 * e7 * e3 ^ 2 * x1 * y1 * e5 * e2 * y3 + 8 * e7 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e6 * e1 - 4 * e7 * e3 ^ 2 * x1 * y1 * e6 * e2 * y3 - 16 * e7 * e3 ^ 2 * x1 ^ 2 * y1 ^ 3 * y2 * e1 + 4 * e7 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * y2 ^ 2 * e1 + 8 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * y2 * e2 * y3 - 4 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * e6 + 8 * e7 * e3 ^ 2 * x1 * y1 ^ 3 * e5 * y2 - 8 * e7 * e3 ^ 2 * x1 * y1 * e5 ^ 2 * y2 + 8 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * y2 ^ 2 - 4 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * e2 + 8 * e7 * e3 ^ 2 * x1 * y1 ^ 3 * e6 * y2 - 8 * e7 * e3 ^ 2 * x1 * y1 * e6 ^ 2 * y2 + 8 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e6 * y2 ^ 2 - 4 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e6 * e2 + 8 * e7 * e3 ^ 2 * x1 * y1 ^ 3 * y2 * e2 - 8 * e7 * e3 ^ 2 * x1 ^ 3 * y1 ^ 2 * e1 ^ 2 - 10 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 - 4 * e7 * e3 ^ 2 * x1 * y2 ^ 2 * e5 * e6 + 8 * e7 * e3 ^ 2 * x1 * y2 ^ 3 * e5 * y1 + 8 * e7 * e3 ^ 2 * x1 * y2 ^ 3 * e6 * y1 - 8 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * y2 ^ 2 * e2 - 8 * e7 * e3 ^ 2 * x1 ^ 3 * y2 ^ 2 * e1 ^ 2 - 10 * e7 * e3 ^ 2 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 - 4 * e7 * e3 ^ 2 * x1 * e2 ^ 2 * y1 * y3 - 2 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e5 ^ 2 - 2 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e6 ^ 2 - 8 * e7 * e3 ^ 2 * x1 * y1 ^ 4 * y2 ^ 2 + 2 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * e6 ^ 2 + 8 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * y2 ^ 4 + 2 * x2 * e3 ^ 3 * x3 * e2 ^ 2 * y1 ^ 2 + 2 * x2 * e3 ^ 3 * x3 * e2 ^ 2 * y3 ^ 2 - 24 * x2 * e3 ^ 3 * x3 * y1 * e5 * y2 * x1 * e1 - 8 * x2 ^ 2 * e3 ^ 3 * x3 * y1 * e5 * y2 * e1 - 24 * x2 * e3 ^ 3 * x3 * y1 * e6 * y2 * x1 * e1 - 8 * x2 ^ 2 * e3 ^ 3 * x3 * y1 * e6 * y2 * e1 + 16 * x2 * e3 ^ 3 * x3 * y1 * x1 ^ 2 * e1 ^ 2 * y2 - 12 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * x1 * e1 * e2 - 4 * x2 ^ 3 * e3 ^ 3 * x3 * y1 * e1 ^ 2 * y2 - 4 * x2 ^ 2 * e3 ^ 3 * x3 * y1 ^ 2 * e1 * e2 - 12 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * e5 * x1 * e1 - 4 * x2 ^ 2 * e3 ^ 3 * x3 * y2 ^ 2 * e5 * e1 - 4 * x2 * e3 ^ 3 * x3 * y2 * e5 * e2 * y1 - 4 * x2 * e3 ^ 3 * x3 * y2 * e5 * e2 * y3 - 12 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * e6 * x1 * e1 - 4 * x2 ^ 2 * e3 ^ 3 * x3 * y2 ^ 2 * e6 * e1 - 4 * x2 * e3 ^ 3 * x3 * y2 * e6 * e2 * y1 - 4 * x2 * e3 ^ 3 * x3 * y2 * e6 * e2 * y3 + 24 * x2 * e3 ^ 3 * x3 * y1 * y2 ^ 3 * x1 * e1 + 8 * x2 ^ 2 * e3 ^ 3 * x3 * y1 * y2 ^ 3 * e1 + 8 * x2 * e3 ^ 3 * x3 * y1 * y2 ^ 2 * e2 * y3 + 4 * x2 ^ 2 * e3 ^ 3 * x3 * y1 * x1 * e1 ^ 2 * y2 - 12 * x2 * e3 ^ 3 * x3 * y1 * x1 * e1 * e2 * y3 - 4 * x2 ^ 2 * e3 ^ 3 * x3 * y1 * e1 * e2 * y3 + 12 * x2 * e3 ^ 3 * x3 * y2 * x1 * e1 * e2 * y1 + 12 * x2 * e3 ^ 3 * x3 * y2 * x1 * e1 * e2 * y3 + 4 * x2 ^ 2 * e3 ^ 3 * x3 * y2 * e1 * e2 * y1 + 4 * x2 ^ 2 * e3 ^ 3 * x3 * y2 * e1 * e2 * y3 + 2 * x2 * e3 ^ 3 * x1 * y2 ^ 2 * e5 ^ 2 + 2 * x2 * e3 ^ 3 * x1 * y2 ^ 2 * e6 ^ 2 + 8 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * y2 ^ 4 + 2 * x2 * e3 ^ 3 * x1 * e2 ^ 2 * y1 ^ 2 + 2 * x2 * e3 ^ 3 * x1 * e2 ^ 2 * y3 ^ 2 - 4 * x2 * e3 ^ 3 * x1 * y2 * e5 * e2 * y1 - 4 * x2 * e3 ^ 3 * x1 * y2 * e5 * e2 * y3 - 4 * x2 * e3 ^ 3 * x1 * y2 * e6 * e2 * y1 - 4 * x2 * e3 ^ 3 * x1 * y2 * e6 * e2 * y3 + 8 * x2 * e3 ^ 3 * x1 * y1 * y2 ^ 2 * e2 * y3 + 2 * x3 * e3 ^ 3 * x1 * y2 ^ 2 * e5 ^ 2 + 2 * x3 * e3 ^ 3 * x1 * y2 ^ 2 * e6 ^ 2 + 8 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * y2 ^ 4 + 2 * x3 * e3 ^ 3 * x1 * e2 ^ 2 * y1 ^ 2 + 2 * x3 * e3 ^ 3 * x1 * e2 ^ 2 * y3 ^ 2 - 16 * x3 * e3 ^ 3 * x1 ^ 2 * y1 * e5 * y2 * e1 - 16 * x3 * e3 ^ 3 * x1 ^ 2 * y1 * e6 * y2 * e1 + 8 * x3 * e3 ^ 3 * x1 ^ 3 * y1 * e1 ^ 2 * y2 - 8 * x3 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e1 * e2 - 8 * x3 * e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e5 * e1 - 4 * x3 * e3 ^ 3 * x1 * y2 * e5 * e2 * y1 - 4 * x3 * e3 ^ 3 * x1 * y2 * e5 * e2 * y3 - 8 * x3 * e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e6 * e1 - 4 * x3 * e3 ^ 3 * x1 * y2 * e6 * e2 * y1 - 4 * x3 * e3 ^ 3 * x1 * y2 * e6 * e2 * y3 + 16 * x3 * e3 ^ 3 * x1 ^ 2 * y1 * y2 ^ 3 * e1 + 8 * x3 * e3 ^ 3 * x1 * y1 * y2 ^ 2 * e2 * y3 - 8 * x3 * e3 ^ 3 * x1 ^ 2 * y1 * e1 * e2 * y3 + 8 * x3 * e3 ^ 3 * x1 ^ 2 * y2 * e1 * e2 * y1 + 8 * x3 * e3 ^ 3 * x1 ^ 2 * y2 * e1 * e2 * y3 - 2 * e6 * x2 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 - 8 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 - 2 * e6 * x2 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 - 2 * e6 * x2 * e3 ^ 2 * e2 ^ 2 * y3 ^ 2 + 16 * e6 * x2 * e3 ^ 2 * y1 * e5 * y2 * x1 * e1 + 4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 * e5 * y2 * e1 + 16 * e6 ^ 2 * x2 * e3 ^ 2 * y1 * y2 * x1 * e1 + 4 * e6 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 * y2 * e1 + 12 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 + 4 * e6 * x2 ^ 3 * e3 ^ 2 * y1 * e1 ^ 2 * y2 + 4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e1 * e2 + 12 * e6 * x2 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 - 4 * e6 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * e1 + 4 * e6 * x2 * e3 ^ 2 * y2 * e5 * e2 * y1 + 4 * e6 * x2 * e3 ^ 2 * y2 * e5 * e2 * y3 + 12 * e6 ^ 2 * x2 * e3 ^ 2 * y2 ^ 2 * x1 * e1 + 4 * e6 ^ 2 * x2 * e3 ^ 2 * y2 * e2 * y1 + 4 * e6 ^ 2 * x2 * e3 ^ 2 * y2 * e2 * y3 - 24 * e6 * x2 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 + 8 * e6 * x2 ^ 2 * e3 ^ 2 * y1 * y2 ^ 3 * e1 + 4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 * x1 * e1 ^ 2 * y2 + 12 * e6 * x2 * e3 ^ 2 * y1 * x1 * e1 * e2 * y3 + 4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 * e1 * e2 * y3 - 12 * e6 * x2 * e3 ^ 2 * y2 * x1 * e1 * e2 * y1 - 12 * e6 * x2 * e3 ^ 2 * y2 * x1 * e1 * e2 * y3 - 4 * e6 * x2 ^ 2 * e3 ^ 2 * y2 * e1 * e2 * y1 - 4 * e6 * x2 ^ 2 * e3 ^ 2 * y2 * e1 * e2 * y3 - 2 * e6 * x3 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 - 8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 - 2 * e6 * x3 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 - 2 * e6 * x3 * e3 ^ 2 * e2 ^ 2 * y3 ^ 2 + 8 * e6 * x3 * e3 ^ 2 * y1 * e5 * y2 * x1 * e1 + 8 * e6 ^ 2 * x3 * e3 ^ 2 * y1 * y2 * x1 * e1 - 8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 + 8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 + 20 * e6 * x3 * e3 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 * y2 + 4 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * x2 * e1 * e2 + 8 * e6 * x3 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 - 4 * e6 * x3 * e3 ^ 2 * y2 ^ 2 * e5 * x2 * e1 + 4 * e6 * x3 * e3 ^ 2 * y2 * e5 * e2 * y1 + 4 * e6 * x3 * e3 ^ 2 * y2 * e5 * e2 * y3 + 8 * e6 ^ 2 * x3 * e3 ^ 2 * y2 ^ 2 * x1 * e1 + 4 * e6 ^ 2 * x3 * e3 ^ 2 * y2 * e2 * y1 + 4 * e6 ^ 2 * x3 * e3 ^ 2 * y2 * e2 * y3 - 16 * e6 * x3 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 + 8 * e6 * x3 * e3 ^ 2 * y1 * y2 ^ 3 * x2 * e1 + 16 * e6 * x3 * e3 ^ 2 * y1 * x1 * e1 ^ 2 * y2 * x2 + 8 * e6 * x3 * e3 ^ 2 * y1 * x1 * e1 * e2 * y3 + 4 * e6 * x3 * e3 ^ 2 * y1 * x2 * e1 * e2 * y3 - 8 * e6 * x3 * e3 ^ 2 * y2 * x1 * e1 * e2 * y1 - 8 * e6 * x3 * e3 ^ 2 * y2 * x1 * e1 * e2 * y3 - 4 * e6 * x3 * e3 ^ 2 * y2 * x2 * e1 * e2 * y1 - 4 * e6 * x3 * e3 ^ 2 * y2 * x2 * e1 * e2 * y3 - 2 * e6 * e3 ^ 2 * x1 * y2 ^ 2 * e5 ^ 2 - 8 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * y2 ^ 4 - 2 * e6 * e3 ^ 2 * x1 * e2 ^ 2 * y1 ^ 2 - 2 * e6 * e3 ^ 2 * x1 * e2 ^ 2 * y3 ^ 2 + 12 * e6 * e3 ^ 2 * x1 ^ 2 * y1 * e5 * y2 * e1 + 12 * e6 ^ 2 * e3 ^ 2 * x1 ^ 2 * y1 * y2 * e1 + 8 * e6 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e1 * e2 + 8 * e6 * e3 ^ 2 * x1 ^ 2 * y2 ^ 2 * e5 * e1 + 4 * e6 * e3 ^ 2 * x1 * y2 * e5 * e2 * y1 + 4 * e6 * e3 ^ 2 * x1 * y2 * e5 * e2 * y3 + 8 * e6 ^ 2 * e3 ^ 2 * x1 ^ 2 * y2 ^ 2 * e1 + 4 * e6 ^ 2 * e3 ^ 2 * x1 * y2 * e2 * y1 + 4 * e6 ^ 2 * e3 ^ 2 * x1 * y2 * e2 * y3 - 16 * e6 * e3 ^ 2 * x1 ^ 2 * y1 * y2 ^ 3 * e1 + 8 * e6 * e3 ^ 2 * x1 ^ 2 * y1 * e1 * e2 * y3 - 8 * e6 * e3 ^ 2 * x1 ^ 2 * y2 * e1 * e2 * y1 - 8 * e6 * e3 ^ 2 * x1 ^ 2 * y2 * e1 * e2 * y3 - 2 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 - 2 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * e6 ^ 2 - 8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 - 2 * e7 * x2 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 - 2 * e7 * x2 * e3 ^ 2 * e2 ^ 2 * y3 ^ 2 + 16 * e7 * x2 * e3 ^ 2 * y1 * e5 * y2 * x1 * e1 + 4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 * e5 * y2 * e1 + 16 * e7 * x2 * e3 ^ 2 * y1 * e6 * y2 * x1 * e1 + 4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 * e6 * y2 * e1 + 12 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 + 4 * e7 * x2 ^ 3 * e3 ^ 2 * y1 * e1 ^ 2 * y2 + 4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e1 * e2 + 12 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 + 4 * e7 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * e1 + 4 * e7 * x2 * e3 ^ 2 * y2 * e5 * e2 * y1 + 4 * e7 * x2 * e3 ^ 2 * y2 * e5 * e2 * y3 + 12 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * e6 * x1 * e1 + 4 * e7 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * e6 * e1 + 4 * e7 * x2 * e3 ^ 2 * y2 * e6 * e2 * y1 + 4 * e7 * x2 * e3 ^ 2 * y2 * e6 * e2 * y3 - 24 * e7 * x2 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 - 8 * e7 * x2 ^ 2 * e3 ^ 2 * y1 * y2 ^ 3 * e1 - 8 * e7 * x2 * e3 ^ 2 * y1 * y2 ^ 2 * e2 * y3 + 4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 * x1 * e1 ^ 2 * y2 + 12 * e7 * x2 * e3 ^ 2 * y1 * x1 * e1 * e2 * y3 + 4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 * e1 * e2 * y3 - 12 * e7 * x2 * e3 ^ 2 * y2 * x1 * e1 * e2 * y1 - 12 * e7 * x2 * e3 ^ 2 * y2 * x1 * e1 * e2 * y3 - 4 * e7 * x2 ^ 2 * e3 ^ 2 * y2 * e1 * e2 * y1 - 4 * e7 * x2 ^ 2 * e3 ^ 2 * y2 * e1 * e2 * y3 - 2 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 - 2 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e6 ^ 2 - 8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 - 2 * e7 * x3 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 - 2 * e7 * x3 * e3 ^ 2 * e2 ^ 2 * y3 ^ 2 + 8 * e7 * x3 * e3 ^ 2 * y1 * e5 * y2 * x1 * e1 + 8 * e7 * x3 * e3 ^ 2 * y1 * e6 * y2 * x1 * e1 - 8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 + 8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 + 20 * e7 * x3 * e3 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 * y2 + 4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * x2 * e1 * e2 + 8 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 + 4 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e5 * x2 * e1 + 4 * e7 * x3 * e3 ^ 2 * y2 * e5 * e2 * y1 + 4 * e7 * x3 * e3 ^ 2 * y2 * e5 * e2 * y3 + 8 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e6 * x1 * e1 + 4 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e6 * x2 * e1 + 4 * e7 * x3 * e3 ^ 2 * y2 * e6 * e2 * y1 + 4 * e7 * x3 * e3 ^ 2 * y2 * e6 * e2 * y3 - 16 * e7 * x3 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 - 8 * e7 * x3 * e3 ^ 2 * y1 * y2 ^ 3 * x2 * e1 - 8 * e7 * x3 * e3 ^ 2 * y1 * y2 ^ 2 * e2 * y3 - 8 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * x1 * e1 ^ 2 * x2 + 16 * e7 * x3 * e3 ^ 2 * y1 * x1 * e1 ^ 2 * y2 * x2 + 8 * e7 * x3 * e3 ^ 2 * y1 * x1 * e1 * e2 * y3 + 4 * e7 * x3 * e3 ^ 2 * y1 * x2 * e1 * e2 * y3 - 8 * e7 * x3 * e3 ^ 2 * y2 * x1 * e1 * e2 * y1 - 8 * e7 * x3 * e3 ^ 2 * y2 * x1 * e1 * e2 * y3 - 4 * e7 * x3 * e3 ^ 2 * y2 * x2 * e1 * e2 * y1 - 4 * e7 * x3 * e3 ^ 2 * y2 * x2 * e1 * e2 * y3 - 2 * e7 * e3 ^ 2 * x1 * y2 ^ 2 * e5 ^ 2 - 2 * e7 * e3 ^ 2 * x1 * y2 ^ 2 * e6 ^ 2 - 8 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * y2 ^ 4 - 2 * e7 * e3 ^ 2 * x1 * e2 ^ 2 * y1 ^ 2 - 2 * e7 * e3 ^ 2 * x1 * e2 ^ 2 * y3 ^ 2 + 12 * e7 * e3 ^ 2 * x1 ^ 2 * y1 * e5 * y2 * e1 + 12 * e7 * e3 ^ 2 * x1 ^ 2 * y1 * e6 * y2 * e1 + 8 * e7 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e1 * e2 + 8 * e7 * e3 ^ 2 * x1 ^ 2 * y2 ^ 2 * e5 * e1 + 4 * e7 * e3 ^ 2 * x1 * y2 * e5 * e2 * y1 + 4 * e7 * e3 ^ 2 * x1 * y2 * e5 * e2 * y3 + 8 * e7 * e3 ^ 2 * x1 ^ 2 * y2 ^ 2 * e6 * e1 + 4 * e7 * e3 ^ 2 * x1 * y2 * e6 * e2 * y1 + 4 * e7 * e3 ^ 2 * x1 * y2 * e6 * e2 * y3 - 16 * e7 * e3 ^ 2 * x1 ^ 2 * y1 * y2 ^ 3 * e1 - 8 * e7 * e3 ^ 2 * x1 * y1 * y2 ^ 2 * e2 * y3 + 8 * e7 * e3 ^ 2 * x1 ^ 2 * y1 * e1 * e2 * y3 - 8 * e7 * e3 ^ 2 * x1 ^ 2 * y2 * e1 * e2 * y1 - 8 * e7 * e3 ^ 2 * x1 ^ 2 * y2 * e1 * e2 * y3 + 8 * e3 * e6 ^ 3 * y1 * e5 * y2 - 4 * e3 * e6 ^ 3 * y1 ^ 2 * x1 * e1 - 2 * e3 * e6 ^ 3 * y1 ^ 2 * x2 * e1 + 2 * e3 * e6 ^ 3 * y1 * e2 * y3 - 4 * e3 * e6 ^ 2 * y1 ^ 3 * e5 * y2 + x1 ^ 2 * e1 ^ 3 * e7 ^ 3 + 4 * e3 * e6 ^ 2 * y1 * e5 ^ 2 * y2 - 4 * e3 * e6 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 + 2 * e3 * e6 ^ 2 * y1 ^ 2 * e5 * e2 - 4 * e3 * e6 ^ 2 * y1 ^ 3 * y2 * e2 + 4 * e3 * e6 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + e3 * e6 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 - 4 * e3 * e6 ^ 2 * y2 ^ 3 * e5 * y1 + 4 * e3 * e6 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 + 4 * e3 * e6 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 - 7 * e3 * e6 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 + 2 * e3 * e6 ^ 2 * e2 ^ 2 * y1 * y3 + 4 * e3 * e6 ^ 2 * e7 * y1 ^ 2 * e5 - 8 * e3 * e6 ^ 2 * e7 * y1 ^ 3 * y2 + 8 * e3 * e6 ^ 3 * e7 * y1 * y2 - 8 * e3 * e6 ^ 2 * e7 * y1 ^ 2 * y2 ^ 2 + 4 * e3 * e6 ^ 2 * e7 * y1 ^ 2 * e2 + 4 * e3 * e6 ^ 2 * e7 * y2 ^ 2 * e5 - 8 * e3 * e6 ^ 2 * e7 * y2 ^ 3 * y1 + 2 * e3 * e6 * e7 * y1 ^ 2 * e5 ^ 2 + 8 * e3 * e6 * e7 * y1 ^ 4 * y2 ^ 2 + 2 * e3 * e7 ^ 2 * y1 ^ 2 * e5 * e6 - 4 * e3 * e7 ^ 2 * y1 ^ 3 * e5 * y2 + 4 * e3 * e7 ^ 2 * y1 * e5 ^ 2 * y2 - 4 * e3 * e6 ^ 2 * y1 ^ 2 * e5 * x1 * e1 - 2 * e3 * e6 ^ 2 * y1 ^ 2 * e5 * x2 * e1 + 2 * e3 * e6 ^ 2 * y1 * e5 * e2 * y3 + 8 * e3 * e6 ^ 2 * y1 ^ 3 * y2 * x1 * e1 + 4 * e3 * e6 ^ 2 * y1 ^ 3 * y2 * x2 * e1 - 8 * e3 * e6 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 - 8 * e3 * e6 ^ 2 * y1 ^ 2 * y2 ^ 2 * x2 * e1 - 12 * e3 * e6 ^ 2 * y1 ^ 2 * y2 * e2 * y3 + e1 * e5 ^ 2 * e6 ^ 3 - 8 * e3 * e6 * e7 * y1 ^ 2 * e5 * x1 * e1 - 4 * e3 * e6 * e7 * y1 ^ 2 * e5 * x2 * e1 + 16 * e3 * e6 ^ 2 * e7 * y1 * e5 * y2 + 4 * e3 * e6 * e7 * y1 * e5 * e2 * y3 - 8 * e3 * e6 ^ 2 * e7 * y1 ^ 2 * x1 * e1 - 4 * e3 * e6 ^ 2 * e7 * y1 ^ 2 * x2 * e1 + 4 * e3 * e6 ^ 2 * e7 * y1 * e2 * y3 + 16 * e3 * e6 * e7 * y1 ^ 3 * y2 * x1 * e1 + 8 * e3 * e6 * e7 * y1 ^ 3 * y2 * x2 * e1 - 16 * e3 * e6 * e7 * y1 ^ 2 * y2 ^ 2 * x1 * e1 - 16 * e3 * e6 * e7 * y1 ^ 2 * y2 ^ 2 * x2 * e1 - 16 * e3 * e6 * e7 * y1 ^ 2 * y2 * e2 * y3 - 8 * e3 * e6 * e7 * y1 ^ 3 * e5 * y2 + 8 * e3 * e6 * e7 * y1 * e5 ^ 2 * y2 - 8 * e3 * e6 * e7 * y1 ^ 2 * e5 * y2 ^ 2 + 4 * e3 * e6 * e7 * y1 ^ 2 * e5 * e2 - 8 * e3 * e6 * e7 * y1 ^ 3 * y2 * e2 + 8 * e3 * e6 * e7 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + 2 * e3 * e6 * e7 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 - 8 * e3 * e6 * e7 * y2 ^ 3 * e5 * y1 + 8 * e3 * e6 * e7 * y1 ^ 2 * y2 ^ 2 * e2 + 8 * e3 * e6 * e7 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 - 6 * e3 * e6 * e7 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 + 4 * e3 * e6 * e7 * e2 ^ 2 * y1 * y3 - 4 * e3 * e7 ^ 2 * y1 ^ 2 * e5 * x1 * e1 - 2 * e3 * e7 ^ 2 * y1 ^ 2 * e5 * x2 * e1 + 8 * e3 * e7 ^ 2 * y1 * e5 * y2 * e6 + 2 * e3 * e7 ^ 2 * y1 * e5 * e2 * y3 - 4 * e3 * e7 ^ 2 * y1 ^ 2 * e6 * x1 * e1 - 2 * e3 * e7 ^ 2 * y1 ^ 2 * e6 * x2 * e1 + 2 * e3 * e7 ^ 2 * y1 * e6 * e2 * y3 + 8 * e3 * e7 ^ 2 * y1 ^ 3 * y2 * x1 * e1 + 4 * e3 * e7 ^ 2 * y1 ^ 3 * y2 * x2 * e1 - 8 * e3 * e7 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 - 8 * e3 * e7 ^ 2 * y1 ^ 2 * y2 ^ 2 * x2 * e1 - 4 * e3 * e7 ^ 2 * y1 ^ 2 * y2 * e2 * y3 - 4 * e3 * e7 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 + 2 * e3 * e7 ^ 2 * y1 ^ 2 * e5 * e2 - 4 * e3 * e7 ^ 2 * y1 ^ 3 * e6 * y2 + 4 * e3 * e7 ^ 2 * y1 * e6 ^ 2 * y2 - 4 * e3 * e7 ^ 2 * y1 ^ 2 * e6 * y2 ^ 2 + 2 * e3 * e7 ^ 2 * y1 ^ 2 * e6 * e2 - 4 * e3 * e7 ^ 2 * y1 ^ 3 * y2 * e2 + 4 * e3 * e7 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + e3 * e7 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 + 2 * e3 * e7 ^ 2 * y2 ^ 2 * e5 * e6 - 4 * e3 * e7 ^ 2 * y2 ^ 3 * e5 * y1 - 4 * e3 * e7 ^ 2 * y2 ^ 3 * e6 * y1 + 4 * e3 * e7 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 + 4 * e3 * e7 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 + e3 * e7 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 + 2 * e3 * e7 ^ 2 * e2 ^ 2 * y1 * y3 - 16 * e3 * y2 ^ 3 * y3 ^ 3 * y1 ^ 2 * e2 - 16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 ^ 3 * e5 + 16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * e5 ^ 2 - 16 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * e5 - 16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 ^ 3 * e6 + 16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * e6 ^ 2 - 16 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * e6 - 16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 ^ 3 * e2 + 8 * e3 * y2 ^ 4 * y3 ^ 2 * e5 * e6 - 16 * e3 * y2 ^ 5 * y3 ^ 2 * e5 * y1 - 16 * e3 * y2 ^ 5 * y3 ^ 2 * e6 * y1 + 16 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * e2 + 16 * e3 * y2 ^ 4 * y3 ^ 2 * x1 ^ 2 * e1 ^ 2 + 4 * e3 * y2 ^ 4 * y3 ^ 2 * x2 ^ 2 * e1 ^ 2 + 8 * e3 * y2 ^ 2 * y3 ^ 3 * e2 ^ 2 * y1 + 4 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e5 ^ 2 + 4 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e6 ^ 2 - 4 * e3 * e6 ^ 3 * y2 ^ 2 * x1 * e1 + 2 * e3 * e6 ^ 3 * y2 ^ 2 * x2 * e1 - 2 * e3 * e6 ^ 3 * y2 * e2 * y1 - 2 * e3 * e6 ^ 3 * y2 * e2 * y3 + 2 * e3 * e6 * e7 * y2 ^ 2 * e5 ^ 2 + 8 * e3 * e6 * e7 * y1 ^ 2 * y2 ^ 4 + 2 * e3 * e6 * e7 * e2 ^ 2 * y1 ^ 2 + 2 * e3 * e6 * e7 * e2 ^ 2 * y3 ^ 2 + 4 * e3 * y2 ^ 2 * y3 ^ 2 * e2 ^ 2 * y1 ^ 2 - 8 * e3 * y2 ^ 3 * y3 ^ 3 * e5 * e2 - 8 * e3 * y2 ^ 3 * y3 ^ 3 * e6 * e2 + 16 * e3 * y2 ^ 4 * y3 ^ 3 * y1 * e2 + 16 * e3 * e6 ^ 2 * y2 ^ 2 * y3 * y1 ^ 3 - 16 * e3 * e6 ^ 3 * y2 ^ 2 * y3 * y1 + 16 * e3 * e6 ^ 2 * y2 ^ 3 * y3 * y1 ^ 2 - 8 * e3 * e6 ^ 2 * y2 ^ 3 * y3 * e5 - 16 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 - 8 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e5 * x2 * e1 + 32 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * e5 * e6 + 8 * e3 * y2 ^ 2 * y3 ^ 3 * y1 * e5 * e2 - 16 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e6 * x1 * e1 + 8 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e6 * x2 * e1 + 8 * e3 * y2 ^ 2 * y3 ^ 3 * y1 * e6 * e2 + 32 * e3 * y2 ^ 3 * y3 ^ 2 * y1 ^ 3 * x1 * e1 + 16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 ^ 3 * x2 * e1 - 32 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * x1 * e1 + 32 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * x2 * e1 + 8 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e5 * e6 + 8 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e5 * e2 + x2 ^ 2 * e1 ^ 3 * e7 ^ 3 + 24 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e6 * e2 + 16 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 + 4 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 + 4 * e3 * e7 ^ 2 * y1 ^ 2 * y2 ^ 4 + e3 * e7 ^ 2 * e2 ^ 2 * y1 ^ 2 + e3 * e7 ^ 2 * e2 ^ 2 * y3 ^ 2 + 4 * e3 * y2 ^ 4 * y3 ^ 2 * e5 ^ 2 + 4 * e3 * y2 ^ 4 * y3 ^ 2 * e6 ^ 2 + 16 * e3 * y2 ^ 6 * y3 ^ 2 * y1 ^ 2 + 4 * e3 * y2 ^ 2 * y3 ^ 4 * e2 ^ 2 - 4 * e3 * e6 ^ 3 * y2 ^ 3 * y3 + 4 * e3 * e6 ^ 2 * y1 * e5 * y2 * x2 * e1 + 4 * e3 * e6 ^ 3 * y1 * y2 * x2 * e1 + 4 * e3 * e6 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 - 6 * e3 * e6 ^ 2 * y1 * x1 ^ 2 * e1 ^ 2 * y2 - 4 * e3 * e6 ^ 2 * y1 ^ 2 * x1 * e1 * e2 - 8 * e3 * e6 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 * y2 - 2 * e3 * e6 ^ 2 * y1 ^ 2 * x2 * e1 * e2 - 4 * e3 * e6 ^ 2 * y2 ^ 2 * e5 * x1 * e1 + 6 * e3 * e6 ^ 2 * y2 ^ 2 * e5 * x2 * e1 - 2 * e3 * e6 ^ 2 * y2 * e5 * e2 * y1 - 2 * e3 * e6 ^ 2 * y2 * e5 * e2 * y3 + 8 * e3 * e6 ^ 2 * y1 * y2 ^ 3 * x1 * e1 - 12 * e3 * e6 ^ 2 * y1 * y2 ^ 3 * x2 * e1 + 12 * e3 * e6 ^ 2 * y1 * y2 ^ 2 * e2 * y3 - 4 * e3 * e6 ^ 2 * y2 ^ 2 * x1 * e1 ^ 2 * x2 - 12 * e3 * e6 ^ 2 * y1 * x1 * e1 ^ 2 * y2 * x2 - 4 * e3 * e6 ^ 2 * y1 * x1 * e1 * e2 * y3 - 2 * e3 * e6 ^ 2 * y1 * x2 * e1 * e2 * y3 + 4 * e3 * e6 ^ 2 * y2 * x1 * e1 * e2 * y1 + 4 * e3 * e6 ^ 2 * y2 * x1 * e1 * e2 * y3 + 2 * e3 * e6 ^ 2 * y2 * x2 * e1 * e2 * y1 + 2 * e3 * e6 ^ 2 * y2 * x2 * e1 * e2 * y3 + 8 * e3 * e6 * e7 * y1 * e5 * y2 * x2 * e1 + 8 * e3 * e6 ^ 2 * e7 * y1 * y2 * x2 * e1 + 8 * e3 * e6 * e7 * y1 ^ 2 * x1 * e1 ^ 2 * x2 - 12 * e3 * e6 * e7 * y1 * x1 ^ 2 * e1 ^ 2 * y2 - 8 * e3 * e6 * e7 * y1 ^ 2 * x1 * e1 * e2 - 16 * e3 * e6 * e7 * y1 * x2 ^ 2 * e1 ^ 2 * y2 - 4 * e3 * e6 * e7 * y1 ^ 2 * x2 * e1 * e2 - 8 * e3 * e6 * e7 * y2 ^ 2 * e5 * x1 * e1 + 4 * e3 * e6 * e7 * y2 ^ 2 * e5 * x2 * e1 - 4 * e3 * e6 * e7 * y2 * e5 * e2 * y1 - 4 * e3 * e6 * e7 * y2 * e5 * e2 * y3 - 8 * e3 * e6 ^ 2 * e7 * y2 ^ 2 * x1 * e1 - 4 * e3 * e6 ^ 2 * e7 * y2 * e2 * y1 - 4 * e3 * e6 ^ 2 * e7 * y2 * e2 * y3 + 16 * e3 * e6 * e7 * y1 * y2 ^ 3 * x1 * e1 - 8 * e3 * e6 * e7 * y1 * y2 ^ 3 * x2 * e1 + 16 * e3 * e6 * e7 * y1 * y2 ^ 2 * e2 * y3 - 24 * e3 * e6 * e7 * y1 * x1 * e1 ^ 2 * y2 * x2 - 8 * e3 * e6 * e7 * y1 * x1 * e1 * e2 * y3 - 4 * e3 * e6 * e7 * y1 * x2 * e1 * e2 * y3 + 8 * e3 * e6 * e7 * y2 * x1 * e1 * e2 * y1 + 8 * e3 * e6 * e7 * y2 * x1 * e1 * e2 * y3 + 4 * e3 * e6 * e7 * y2 * x2 * e1 * e2 * y1 + 4 * e3 * e6 * e7 * y2 * x2 * e1 * e2 * y3 + 4 * e3 * e7 ^ 2 * y1 * e5 * y2 * x2 * e1 + 4 * e3 * e7 ^ 2 * y1 * e6 * y2 * x2 * e1 + 4 * e3 * e7 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 - 6 * e3 * e7 ^ 2 * y1 * x1 ^ 2 * e1 ^ 2 * y2 - 4 * e3 * e7 ^ 2 * y1 ^ 2 * x1 * e1 * e2 - 8 * e3 * e7 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 * y2 - 2 * e3 * e7 ^ 2 * y1 ^ 2 * x2 * e1 * e2 - 4 * e3 * e7 ^ 2 * y2 ^ 2 * e5 * x1 * e1 - 2 * e3 * e7 ^ 2 * y2 ^ 2 * e5 * x2 * e1 - 2 * e3 * e7 ^ 2 * y2 * e5 * e2 * y1 - 2 * e3 * e7 ^ 2 * y2 * e5 * e2 * y3 - 4 * e3 * e7 ^ 2 * y2 ^ 2 * e6 * x1 * e1 - 2 * e3 * e7 ^ 2 * y2 ^ 2 * e6 * x2 * e1 - 2 * e3 * e7 ^ 2 * y2 * e6 * e2 * y1 - 2 * e3 * e7 ^ 2 * y2 * e6 * e2 * y3 + 8 * e3 * e7 ^ 2 * y1 * y2 ^ 3 * x1 * e1 + 4 * e3 * e7 ^ 2 * y1 * y2 ^ 3 * x2 * e1 + 4 * e3 * e7 ^ 2 * y1 * y2 ^ 2 * e2 * y3 + 4 * e3 * e7 ^ 2 * y2 ^ 2 * x1 * e1 ^ 2 * x2 - 12 * e3 * e7 ^ 2 * y1 * x1 * e1 ^ 2 * y2 * x2 - 4 * e3 * e7 ^ 2 * y1 * x1 * e1 * e2 * y3 - 2 * e3 * e7 ^ 2 * y1 * x2 * e1 * e2 * y3 + 4 * e3 * e7 ^ 2 * y2 * x1 * e1 * e2 * y1 + 4 * e3 * e7 ^ 2 * y2 * x1 * e1 * e2 * y3 + 2 * e3 * e7 ^ 2 * y2 * x2 * e1 * e2 * y1 + 2 * e3 * e7 ^ 2 * y2 * x2 * e1 * e2 * y3 - 48 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * e5 * x2 * e1 - 48 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * e6 * x2 * e1 + 16 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 - 24 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * x1 ^ 2 * e1 ^ 2 - 16 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 + 32 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 - 8 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * x2 * e1 * e2 - 16 * e3 * y2 ^ 4 * y3 ^ 2 * e5 * x1 * e1 - 8 * e3 * y2 ^ 4 * y3 ^ 2 * e5 * x2 * e1 - 8 * e3 * y2 ^ 3 * y3 ^ 2 * e5 * e2 * y1 - 16 * e3 * y2 ^ 4 * y3 ^ 2 * e6 * x1 * e1 - 8 * e3 * y2 ^ 4 * y3 ^ 2 * e6 * x2 * e1 - 24 * e3 * y2 ^ 3 * y3 ^ 2 * e6 * e2 * y1 + 32 * e3 * y2 ^ 5 * y3 ^ 2 * y1 * x1 * e1 + 16 * e3 * y2 ^ 5 * y3 ^ 2 * y1 * x2 * e1 + 16 * e3 * y2 ^ 4 * y3 ^ 2 * x1 * e1 ^ 2 * x2 + 16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * x1 * e1 ^ 2 * x2 - 16 * e3 * y2 ^ 2 * y3 ^ 3 * y1 * x1 * e1 * e2 - 8 * e3 * y2 ^ 2 * y3 ^ 3 * y1 * x2 * e1 * e2 + 16 * e3 * y2 ^ 3 * y3 ^ 2 * x1 * e1 * e2 * y1 + 16 * e3 * y2 ^ 3 * y3 ^ 3 * x1 * e1 * e2 + 8 * e3 * y2 ^ 3 * y3 ^ 2 * x2 * e1 * e2 * y1 + 8 * e3 * y2 ^ 3 * y3 ^ 3 * x2 * e1 * e2 - e3 * e6 ^ 3 * e7 ^ 2 + 16 * e3 * e6 * y2 * y3 * y1 ^ 2 * e5 * x1 * e1 + 8 * e3 * e6 * y2 * y3 * y1 ^ 2 * e5 * x2 * e1 - 32 * e3 * e6 ^ 2 * y2 ^ 2 * y3 * y1 * e5 - 8 * e3 * e6 * y2 * y3 ^ 2 * y1 * e5 * e2 + 16 * e3 * e6 ^ 2 * y2 * y3 * y1 ^ 2 * x1 * e1 + 8 * e3 * e6 ^ 2 * y2 * y3 * y1 ^ 2 * x2 * e1 - 8 * e3 * e6 ^ 2 * y2 * y3 ^ 2 * y1 * e2 - 32 * e3 * e6 * y2 ^ 2 * y3 * y1 ^ 3 * x1 * e1 - 16 * e3 * e6 * y2 ^ 2 * y3 * y1 ^ 3 * x2 * e1 + 32 * e3 * e6 * y2 ^ 3 * y3 * y1 ^ 2 * x1 * e1 - 8 * e3 * e6 ^ 2 * y2 * y3 * y1 ^ 2 * e5 + 16 * e3 * e6 * y2 ^ 2 * y3 * y1 ^ 3 * e5 - 16 * e3 * e6 * y2 ^ 2 * y3 * y1 * e5 ^ 2 + 16 * e3 * e6 * y2 ^ 3 * y3 * y1 ^ 2 * e5 - 8 * e3 * e6 * y2 * y3 * y1 ^ 2 * e5 * e2 + 16 * e3 * e6 * y2 ^ 2 * y3 * y1 ^ 3 * e2 - 16 * e3 * e6 * y2 * y3 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 - 4 * e3 * e6 * y2 * y3 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 + 16 * e3 * e6 * y2 ^ 4 * y3 * e5 * y1 + 16 * e3 * e6 ^ 2 * y2 ^ 4 * y3 * y1 - 4 * e3 * e6 ^ 3 * y2 * y3 * y1 ^ 2 - 16 * e3 * e6 * y2 ^ 3 * y3 * y1 ^ 4 - 16 * e3 * e7 * y2 ^ 3 * y3 * y1 ^ 4 - 4 * e3 * e6 * y2 ^ 3 * y3 * e5 ^ 2 - 16 * e3 * e6 * y2 ^ 5 * y3 * y1 ^ 2 - 4 * e3 * e6 * y2 * y3 ^ 3 * e2 ^ 2 + 8 * e3 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 * e2 - 4 * e3 * e7 * y2 ^ 3 * y3 * e5 ^ 2 - 4 * e3 * e7 * y2 ^ 3 * y3 * e6 ^ 2 - 16 * e3 * e7 * y2 ^ 5 * y3 * y1 ^ 2 - 4 * e3 * e7 * y2 * y3 ^ 3 * e2 ^ 2 - 16 * e3 * e6 * y2 ^ 3 * y3 * y1 ^ 2 * e2 - 16 * e3 * e6 * y2 ^ 3 * y3 * x1 ^ 2 * e1 ^ 2 + 12 * e3 * e6 * y2 ^ 3 * y3 * x2 ^ 2 * e1 ^ 2 - 8 * e3 * e6 * y2 * y3 ^ 2 * e2 ^ 2 * y1 - 4 * e3 * e6 * y2 * y3 * y1 ^ 2 * e5 ^ 2 + 16 * e3 * e7 * y2 * y3 * y1 ^ 2 * e5 * x1 * e1 + 8 * e3 * e7 * y2 * y3 * y1 ^ 2 * e5 * x2 * e1 - 32 * e3 * e7 * y2 ^ 2 * y3 * y1 * e5 * e6 - 8 * e3 * e7 * y2 * y3 ^ 2 * y1 * e5 * e2 + 16 * e3 * e7 * y2 * y3 * y1 ^ 2 * e6 * x1 * e1 + 8 * e3 * e7 * y2 * y3 * y1 ^ 2 * e6 * x2 * e1 - 8 * e3 * e7 * y2 * y3 ^ 2 * y1 * e6 * e2 - 32 * e3 * e7 * y2 ^ 2 * y3 * y1 ^ 3 * x1 * e1 - 16 * e3 * e7 * y2 ^ 2 * y3 * y1 ^ 3 * x2 * e1 + 32 * e3 * e7 * y2 ^ 3 * y3 * y1 ^ 2 * x1 * e1 + 16 * e3 * e7 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e2 - 8 * e3 * e7 * y2 * y3 * y1 ^ 2 * e5 * e6 + 16 * e3 * e7 * y2 ^ 2 * y3 * y1 ^ 3 * e5 - 16 * e3 * e7 * y2 ^ 2 * y3 * y1 * e5 ^ 2 + 16 * e3 * e7 * y2 ^ 3 * y3 * y1 ^ 2 * e5 - 8 * e3 * e7 * y2 * y3 * y1 ^ 2 * e5 * e2 + 16 * e3 * e7 * y2 ^ 2 * y3 * y1 ^ 3 * e6 - 16 * e3 * e7 * y2 ^ 2 * y3 * y1 * e6 ^ 2 + 16 * e3 * e7 * y2 ^ 3 * y3 * y1 ^ 2 * e6 + 16 * e3 * e7 * y2 ^ 2 * y3 * y1 ^ 3 * e2 - 16 * e3 * e7 * y2 * y3 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 - 4 * e3 * e7 * y2 * y3 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 - 8 * e3 * e7 * y2 ^ 3 * y3 * e5 * e6 + 16 * e3 * e7 * y2 ^ 4 * y3 * e5 * y1 + 16 * e3 * e7 * y2 ^ 4 * y3 * e6 * y1 - 16 * e3 * e7 * y2 ^ 3 * y3 * y1 ^ 2 * e2 - 16 * e3 * e7 * y2 ^ 3 * y3 * x1 ^ 2 * e1 ^ 2 - 4 * e3 * e7 * y2 ^ 3 * y3 * x2 ^ 2 * e1 ^ 2 - 8 * e3 * e7 * y2 * y3 ^ 2 * e2 ^ 2 * y1 - 4 * e3 * e7 * y2 * y3 * y1 ^ 2 * e5 ^ 2 - 4 * e3 * e7 * y2 * y3 * y1 ^ 2 * e6 ^ 2 + e1 ^ 3 * x3 ^ 2 * e7 ^ 3 - 4 * e3 * e6 * y2 * y3 * e2 ^ 2 * y1 ^ 2 + 16 * e3 * e6 * y2 ^ 2 * y3 * y1 * e5 * x2 * e1 + 16 * e3 * e6 ^ 2 * y2 ^ 2 * y3 * y1 * x2 * e1 - 16 * e3 * e6 * y2 * y3 * y1 ^ 2 * x1 * e1 ^ 2 * x2 + 24 * e3 * e6 * y2 ^ 2 * y3 * y1 * x1 ^ 2 * e1 ^ 2 + 16 * e3 * e6 * y2 * y3 * y1 ^ 2 * x1 * e1 * e2 + 8 * e3 * e6 * y2 * y3 * y1 ^ 2 * x2 * e1 * e2 + 16 * e3 * e6 * y2 ^ 3 * y3 * e5 * x1 * e1 - 8 * e3 * e6 * y2 ^ 3 * y3 * e5 * x2 * e1 + 8 * e3 * e6 * y2 ^ 2 * y3 * e5 * e2 * y1 + 8 * e3 * e6 * y2 ^ 2 * y3 ^ 2 * e5 * e2 + 16 * e3 * e6 ^ 2 * y2 ^ 3 * y3 * x1 * e1 - 32 * e3 * e6 * y2 ^ 4 * y3 * y1 * x1 * e1 + 16 * e3 * e6 * y2 ^ 4 * y3 * y1 * x2 * e1 + 16 * e3 * e6 * y2 ^ 2 * y3 * y1 * x1 * e1 ^ 2 * x2 + 16 * e3 * e6 * y2 * y3 ^ 2 * y1 * x1 * e1 * e2 + 8 * e3 * e6 * y2 * y3 ^ 2 * y1 * x2 * e1 * e2 - 16 * e3 * e6 * y2 ^ 2 * y3 * x1 * e1 * e2 * y1 - 16 * e3 * e6 * y2 ^ 2 * y3 ^ 2 * x1 * e1 * e2 - 8 * e3 * e6 * y2 ^ 2 * y3 * x2 * e1 * e2 * y1 - 8 * e3 * e6 * y2 ^ 2 * y3 ^ 2 * x2 * e1 * e2 - e1 * y3 ^ 2 * e6 ^ 4 - 4 * e3 * e7 * y2 * y3 * e2 ^ 2 * y1 ^ 2 + 16 * e3 * e7 * y2 ^ 2 * y3 * y1 * e5 * x2 * e1 + 16 * e3 * e7 * y2 ^ 2 * y3 * y1 * e6 * x2 * e1 - 16 * e3 * e7 * y2 * y3 * y1 ^ 2 * x1 * e1 ^ 2 * x2 + 24 * e3 * e7 * y2 ^ 2 * y3 * y1 * x1 ^ 2 * e1 ^ 2 + 16 * e3 * e7 * y2 * y3 * y1 ^ 2 * x1 * e1 * e2 + 8 * e3 * e7 * y2 * y3 * y1 ^ 2 * x2 * e1 * e2 + 16 * e3 * e7 * y2 ^ 3 * y3 * e5 * x1 * e1 + 8 * e3 * e7 * y2 ^ 3 * y3 * e5 * x2 * e1 + 8 * e3 * e7 * y2 ^ 2 * y3 * e5 * e2 * y1 + 8 * e3 * e7 * y2 ^ 2 * y3 ^ 2 * e5 * e2 + 16 * e3 * e7 * y2 ^ 3 * y3 * e6 * x1 * e1 + 8 * e3 * e7 * y2 ^ 3 * y3 * e6 * x2 * e1 + 8 * e3 * e7 * y2 ^ 2 * y3 ^ 2 * e6 * e2 - 32 * e3 * e7 * y2 ^ 4 * y3 * y1 * x1 * e1 - 16 * e3 * e7 * y2 ^ 4 * y3 * y1 * x2 * e1 - 16 * e3 * e7 * y2 ^ 3 * y3 ^ 2 * y1 * e2 - 16 * e3 * e7 * y2 ^ 3 * y3 * x1 * e1 ^ 2 * x2 + 16 * e3 * e7 * y2 ^ 2 * y3 * y1 * x1 * e1 ^ 2 * x2 + 16 * e3 * e7 * y2 * y3 ^ 2 * y1 * x1 * e1 * e2 + 8 * e3 * e7 * y2 * y3 ^ 2 * y1 * x2 * e1 * e2 - 16 * e3 * e7 * y2 ^ 2 * y3 * x1 * e1 * e2 * y1 - 16 * e3 * e7 * y2 ^ 2 * y3 ^ 2 * x1 * e1 * e2 - 8 * e3 * e7 * y2 ^ 2 * y3 * x2 * e1 * e2 * y1 - 8 * e3 * e7 * y2 ^ 2 * y3 ^ 2 * x2 * e1 * e2 - e6 ^ 3 * x3 ^ 2 * e3 ^ 3 - 16 * e1 * y2 ^ 3 * y3 ^ 2 * e4 * y1 ^ 3 - e6 ^ 3 * e3 ^ 3 * x1 ^ 2 + 2 * e6 ^ 4 * x2 * e3 ^ 2 + 2 * e6 ^ 4 * x3 * e3 ^ 2 + 2 * e6 ^ 4 * e3 ^ 2 * x1 - e5 ^ 3 * x2 ^ 2 * e3 ^ 3 - e5 ^ 3 * x3 ^ 2 * e3 ^ 3 - e5 ^ 3 * e3 ^ 3 * x1 ^ 2 + 2 * x1 ^ 5 * e1 ^ 3 * e3 ^ 3 - 3 * e3 * e6 ^ 4 * e5 - e3 * e5 ^ 3 * e6 ^ 2 - 3 * e3 * e5 ^ 2 * e6 ^ 3 - e3 * e5 ^ 3 * e7 ^ 2 - e6 ^ 3 * x2 ^ 2 * e3 ^ 3 - 2 * e6 ^ 3 * x2 * e3 ^ 3 * x3 - 2 * e6 ^ 3 * x2 * e3 ^ 3 * x1 - 2 * e6 ^ 3 * x3 * e3 ^ 3 * x1 + 2 * e6 ^ 3 * e7 * x2 * e3 ^ 2 + 2 * e6 ^ 3 * e7 * x3 * e3 ^ 2 + 2 * e6 ^ 3 * e7 * e3 ^ 2 * x1 - 2 * e5 ^ 3 * x2 * e3 ^ 3 * x3 - 2 * e5 ^ 3 * x2 * e3 ^ 3 * x1 - 2 * e5 ^ 3 * x3 * e3 ^ 3 * x1 + 2 * e5 ^ 3 * e6 * x2 * e3 ^ 2 + 6 * e5 ^ 2 * e6 ^ 2 * x2 * e3 ^ 2 + 2 * e5 ^ 3 * e6 * x3 * e3 ^ 2 + 6 * e5 ^ 2 * e6 ^ 2 * x3 * e3 ^ 2 + 2 * e5 ^ 3 * e6 * e3 ^ 2 * x1 + 6 * e5 ^ 2 * e6 ^ 2 * e3 ^ 2 * x1 + 2 * e5 ^ 3 * e7 * x2 * e3 ^ 2 + 2 * e5 ^ 3 * e7 * x3 * e3 ^ 2 + 2 * e5 ^ 3 * e7 * e3 ^ 2 * x1 - 3 * e5 ^ 2 * e6 * x2 ^ 2 * e3 ^ 3 - 3 * e5 * e6 ^ 2 * x2 ^ 2 * e3 ^ 3 - 3 * e5 ^ 2 * e6 * x3 ^ 2 * e3 ^ 3 - 3 * e5 * e6 ^ 2 * x3 ^ 2 * e3 ^ 3 - 3 * e5 ^ 2 * e6 * e3 ^ 3 * x1 ^ 2 - 3 * e5 * e6 ^ 2 * e3 ^ 3 * x1 ^ 2 + 6 * e5 * e6 ^ 3 * x2 * e3 ^ 2 + 6 * e5 * e6 ^ 3 * x3 * e3 ^ 2 + 6 * e5 * e6 ^ 3 * e3 ^ 2 * x1 + 8 * x1 ^ 3 * e1 ^ 2 * e6 ^ 2 * e3 ^ 2 - 8 * e1 ^ 2 * x3 ^ 3 * e6 ^ 2 * e3 ^ 2 + 4 * e5 ^ 2 * x1 ^ 3 * e1 * e3 ^ 3 + 2 * e5 ^ 2 * x2 ^ 3 * e1 * e3 ^ 3 - 5 * x1 ^ 4 * e1 ^ 2 * e3 ^ 3 * e5 - 5 * x1 ^ 4 * e1 ^ 2 * e3 ^ 3 * e6 - x2 ^ 4 * e1 ^ 2 * e3 ^ 3 * e5 - x2 ^ 4 * e1 ^ 2 * e3 ^ 3 * e6 + 3 * e1 ^ 2 * x3 ^ 4 * e3 ^ 3 * e5 + 3 * e1 ^ 2 * x3 ^ 4 * e3 ^ 3 * e6 + 8 * x1 ^ 2 * e1 ^ 3 * x2 ^ 3 * e3 ^ 3 + 2 * x1 * e1 ^ 3 * x2 ^ 4 * e3 ^ 3 + 8 * x1 ^ 4 * e1 ^ 3 * x2 * e3 ^ 3 + 12 * x1 ^ 3 * e1 ^ 3 * x2 ^ 2 * e3 ^ 3 + 4 * x1 ^ 3 * e1 ^ 3 * x3 ^ 2 * e3 ^ 3 + 6 * x1 ^ 4 * e1 ^ 3 * x3 * e3 ^ 3 - 3 * x1 ^ 4 * e1 ^ 3 * e6 * e3 ^ 2 - 3 * x1 ^ 4 * e1 ^ 3 * e7 * e3 ^ 2 - 8 * x2 ^ 3 * e1 ^ 3 * x3 ^ 2 * e3 ^ 3 - 2 * x2 ^ 4 * e1 ^ 3 * e3 ^ 3 * x3 + x2 ^ 4 * e1 ^ 3 * e6 * e3 ^ 2 + x2 ^ 4 * e1 ^ 3 * e7 * e3 ^ 2 - 12 * e1 ^ 3 * x3 ^ 3 * x2 ^ 2 * e3 ^ 3 - 4 * e1 ^ 3 * x3 ^ 3 * e3 ^ 3 * x1 ^ 2 + 2 * e6 ^ 2 * x2 ^ 3 * e3 ^ 3 * e1 + 4 * e6 ^ 2 * e3 ^ 3 * x1 ^ 3 * e1 - 3 * e6 ^ 3 * x2 ^ 2 * e3 ^ 2 * e1 - 7 * e6 ^ 3 * e3 ^ 2 * x1 ^ 2 * e1 - 6 * e1 ^ 3 * x3 ^ 4 * e3 ^ 3 * x1 - 8 * e1 ^ 3 * x3 ^ 4 * e3 ^ 3 * x2 + e6 ^ 3 * e1 * x3 ^ 2 * e3 ^ 2 - 6 * e3 * e6 ^ 3 * e7 * e5 - 4 * e3 * e6 ^ 3 * y2 ^ 2 * y3 ^ 2 + 4 * e3 * e6 ^ 4 * y2 * y3 - 2 * e3 * e5 ^ 3 * e6 * e7 - 6 * e3 * e5 ^ 2 * e6 ^ 2 * e7 - 4 * e3 * e5 ^ 3 * y2 ^ 2 * y3 ^ 2 - 3 * e3 * e5 ^ 2 * e6 * e7 ^ 2 - 3 * e3 * e5 * e6 ^ 2 * e7 ^ 2 - e3 * e6 ^ 5 + 12 * e6 ^ 2 * x2 * e3 ^ 3 * x3 * x1 * e1 + 4 * e6 ^ 2 * x2 ^ 2 * e3 ^ 3 * x3 * e1 + 10 * e6 ^ 2 * x2 * e3 ^ 3 * x1 ^ 2 * e1 + 8 * e6 ^ 2 * x2 ^ 2 * e3 ^ 3 * x1 * e1 - 4 * e6 ^ 3 * y2 * y3 * x2 * e3 ^ 2 - 4 * e6 ^ 3 * y2 * y3 * x3 * e3 ^ 2 - 4 * e6 ^ 3 * y2 * y3 * e3 ^ 2 * x1 + 8 * x1 * e1 ^ 2 * x2 ^ 2 * e6 ^ 2 * e3 ^ 2 + 16 * x1 ^ 2 * e1 ^ 2 * x2 * e6 ^ 2 * e3 ^ 2 - 4 * e5 ^ 3 * y2 * y3 * x2 * e3 ^ 2 - 4 * e5 ^ 3 * y2 * y3 * x3 * e3 ^ 2 - 4 * e5 ^ 3 * y2 * y3 * e3 ^ 2 * x1 + 8 * x1 ^ 2 * e1 ^ 2 * e6 ^ 2 * x3 * e3 ^ 2 - 8 * x2 ^ 2 * e1 ^ 2 * e6 ^ 2 * x3 * e3 ^ 2 - 16 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * x2 * e3 ^ 2 - 6 * e6 ^ 2 * x2 * e3 ^ 3 * x3 * e5 - 6 * e6 ^ 2 * x2 * e3 ^ 3 * x1 * e5 - 6 * e6 ^ 2 * x3 * e3 ^ 3 * x1 * e5 + 6 * e6 ^ 2 * e7 * x2 * e3 ^ 2 * e5 + 6 * e6 ^ 2 * e7 * x3 * e3 ^ 2 * e5 + 6 * e6 ^ 2 * e7 * e3 ^ 2 * x1 * e5 - 8 * x1 * e1 ^ 2 * x2 ^ 3 * e3 ^ 3 * e5 - 8 * x1 * e1 ^ 2 * x2 ^ 3 * e3 ^ 3 * e6 - 16 * x1 ^ 3 * e1 ^ 2 * x2 * e3 ^ 3 * e5 - 16 * x1 ^ 3 * e1 ^ 2 * x2 * e3 ^ 3 * e6 - 18 * x1 ^ 2 * e1 ^ 2 * x2 ^ 2 * e3 ^ 3 * e5 - 18 * x1 ^ 2 * e1 ^ 2 * x2 ^ 2 * e3 ^ 3 * e6 - 6 * e5 ^ 2 * x2 * e3 ^ 3 * x3 * e6 - 6 * e5 ^ 2 * x2 * e3 ^ 3 * x1 * e6 - 6 * e5 ^ 2 * x3 * e3 ^ 3 * x1 * e6 + 6 * e5 ^ 2 * e7 * x2 * e3 ^ 2 * e6 + 6 * e5 ^ 2 * e7 * x3 * e3 ^ 2 * e6 + 6 * e5 ^ 2 * e7 * e3 ^ 2 * x1 * e6 - 6 * x1 ^ 2 * e1 ^ 2 * x3 ^ 2 * e3 ^ 3 * e5 - 6 * x1 ^ 2 * e1 ^ 2 * x3 ^ 2 * e3 ^ 3 * e6 - 12 * x1 ^ 3 * e1 ^ 2 * x3 * e3 ^ 3 * e5 - 12 * x1 ^ 3 * e1 ^ 2 * x3 * e3 ^ 3 * e6 + 8 * x1 ^ 3 * e1 ^ 2 * e6 * e3 ^ 2 * e5 + 8 * x1 ^ 3 * e1 ^ 2 * e7 * e3 ^ 2 * e5 + 8 * x1 ^ 3 * e1 ^ 2 * e7 * e3 ^ 2 * e6 + 6 * x2 ^ 2 * e1 ^ 2 * x3 ^ 2 * e3 ^ 3 * e5 + 6 * x2 ^ 2 * e1 ^ 2 * x3 ^ 2 * e3 ^ 3 * e6 + 8 * e1 ^ 2 * x3 ^ 3 * x2 * e3 ^ 3 * e5 + 8 * e1 ^ 2 * x3 ^ 3 * x2 * e3 ^ 3 * e6 + 4 * e1 ^ 2 * x3 ^ 3 * e3 ^ 3 * x1 * e5 + 4 * e1 ^ 2 * x3 ^ 3 * e3 ^ 3 * x1 * e6 - 12 * e6 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * e5 - 12 * e6 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e5 - 12 * e6 ^ 2 * y2 * y3 * e3 ^ 2 * x1 * e5 - 32 * x1 * e1 ^ 2 * x2 ^ 2 * y2 * y3 * e3 ^ 2 * e5 - 32 * x1 * e1 ^ 2 * x2 ^ 2 * y2 * y3 * e3 ^ 2 * e6 - 16 * x1 * e1 ^ 2 * x2 * y2 * y3 * x3 * e3 ^ 2 * e5 - 16 * x1 * e1 ^ 2 * x2 * y2 * y3 * x3 * e3 ^ 2 * e6 - 32 * x1 ^ 2 * e1 ^ 2 * x2 * y2 * y3 * e3 ^ 2 * e5 - 32 * x1 ^ 2 * e1 ^ 2 * x2 * y2 * y3 * e3 ^ 2 * e6 - 12 * x1 * e1 ^ 2 * x2 ^ 2 * e3 ^ 3 * x3 * e5 - 12 * x1 * e1 ^ 2 * x2 ^ 2 * e3 ^ 3 * x3 * e6 - 24 * x1 ^ 2 * e1 ^ 2 * x2 * x3 * e3 ^ 3 * e5 - 24 * x1 ^ 2 * e1 ^ 2 * x2 * x3 * e3 ^ 3 * e6 + 8 * x1 * e1 ^ 2 * x2 ^ 2 * e6 * e3 ^ 2 * e5 + 16 * x1 ^ 2 * e1 ^ 2 * x2 * e6 * e3 ^ 2 * e5 + 8 * x1 * e1 ^ 2 * x2 ^ 2 * e7 * e3 ^ 2 * e5 + 8 * x1 * e1 ^ 2 * x2 ^ 2 * e7 * e3 ^ 2 * e6 + 16 * x1 ^ 2 * e1 ^ 2 * x2 * e7 * e3 ^ 2 * e5 + 16 * x1 ^ 2 * e1 ^ 2 * x2 * e7 * e3 ^ 2 * e6 - 12 * e5 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * e6 - 12 * e5 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e6 - 12 * e5 ^ 2 * y2 * y3 * e3 ^ 2 * x1 * e6 - 16 * x1 ^ 2 * e1 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e5 - 16 * x1 ^ 2 * e1 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e6 - 16 * x1 ^ 3 * e1 ^ 2 * y2 * y3 * e3 ^ 2 * e5 - 16 * x1 ^ 3 * e1 ^ 2 * y2 * y3 * e3 ^ 2 * e6 + 8 * x1 ^ 2 * e1 ^ 2 * e6 * x3 * e3 ^ 2 * e5 + 8 * x1 ^ 2 * e1 ^ 2 * e7 * x3 * e3 ^ 2 * e5 + 8 * x1 ^ 2 * e1 ^ 2 * e7 * x3 * e3 ^ 2 * e6 - 16 * x2 ^ 3 * e1 ^ 2 * y2 * y3 * e3 ^ 2 * e5 - 16 * x2 ^ 3 * e1 ^ 2 * y2 * y3 * e3 ^ 2 * e6 - 16 * x2 ^ 2 * e1 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e5 - 16 * x2 ^ 2 * e1 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e6 - 8 * x2 ^ 2 * e1 ^ 2 * e6 * x3 * e3 ^ 2 * e5 - 8 * x2 ^ 2 * e1 ^ 2 * e7 * x3 * e3 ^ 2 * e5 - 8 * x2 ^ 2 * e1 ^ 2 * e7 * x3 * e3 ^ 2 * e6 + 12 * e1 ^ 2 * x3 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * e5 + 12 * e1 ^ 2 * x3 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * e6 + 12 * e1 ^ 2 * x3 ^ 3 * y2 * y3 * e3 ^ 2 * e5 + 12 * e1 ^ 2 * x3 ^ 3 * y2 * y3 * e3 ^ 2 * e6 + 12 * e1 ^ 2 * x3 ^ 2 * y2 * y3 * e3 ^ 2 * x1 * e5 + 12 * e1 ^ 2 * x3 ^ 2 * y2 * y3 * e3 ^ 2 * x1 * e6 - 16 * e1 ^ 2 * x3 ^ 2 * e6 * x2 * e3 ^ 2 * e5 - 8 * e1 ^ 2 * x3 ^ 3 * e6 * e3 ^ 2 * e5 - 8 * e1 ^ 2 * x3 ^ 3 * e7 * e3 ^ 2 * e5 - 8 * e1 ^ 2 * x3 ^ 3 * e7 * e3 ^ 2 * e6 + 8 * e5 * x1 ^ 3 * e1 * e3 ^ 3 * e6 + 4 * e5 * x2 ^ 3 * e1 * e3 ^ 3 * e6 - 8 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * e3 ^ 2 * x1 + 8 * e6 ^ 2 * x3 * e3 ^ 3 * x1 ^ 2 * e1 - 10 * e6 ^ 2 * e7 * x2 * e3 ^ 2 * x1 * e1 - 3 * e6 ^ 2 * e7 * x2 ^ 2 * e3 ^ 2 * e1 - 6 * e6 ^ 2 * e7 * x3 * e3 ^ 2 * x1 * e1 - 2 * e6 ^ 2 * e7 * x3 * e3 ^ 2 * x2 * e1 - 7 * e6 ^ 2 * e7 * e3 ^ 2 * x1 ^ 2 * e1 + 12 * e5 ^ 2 * x2 * e3 ^ 3 * x3 * x1 * e1 + 4 * e5 ^ 2 * x2 ^ 2 * e3 ^ 3 * x3 * e1 + 10 * e5 ^ 2 * x2 * e3 ^ 3 * x1 ^ 2 * e1 + 8 * e5 ^ 2 * x2 ^ 2 * e3 ^ 3 * x1 * e1 + 8 * e5 ^ 2 * x3 * e3 ^ 3 * x1 ^ 2 * e1 - 10 * e5 ^ 2 * e6 * x2 * e3 ^ 2 * x1 * e1 - 3 * e5 ^ 2 * e6 * x2 ^ 2 * e3 ^ 2 * e1 - 6 * e5 ^ 2 * e6 * x3 * e3 ^ 2 * x1 * e1 - 2 * e5 ^ 2 * e6 * x3 * e3 ^ 2 * x2 * e1 - 7 * e5 ^ 2 * e6 * e3 ^ 2 * x1 ^ 2 * e1 - 10 * e5 ^ 2 * e7 * x2 * e3 ^ 2 * x1 * e1 - 3 * e5 ^ 2 * e7 * x2 ^ 2 * e3 ^ 2 * e1 - 6 * e5 ^ 2 * e7 * x3 * e3 ^ 2 * x1 * e1 - 2 * e5 ^ 2 * e7 * x3 * e3 ^ 2 * x2 * e1 - 7 * e5 ^ 2 * e7 * e3 ^ 2 * x1 ^ 2 * e1 + 16 * e5 * e6 * x2 ^ 2 * e3 ^ 3 * x1 * e1 + 8 * e5 * e6 * x3 ^ 2 * e3 ^ 3 * x1 * e1 + 4 * e5 * e6 * x3 ^ 2 * e3 ^ 3 * x2 * e1 + 20 * e5 * e6 * e3 ^ 3 * x1 ^ 2 * x2 * e1 - 20 * e5 * e6 ^ 2 * x2 * e3 ^ 2 * x1 * e1 - 6 * e5 * e6 ^ 2 * x2 ^ 2 * e3 ^ 2 * e1 - 12 * e5 * e6 ^ 2 * x3 * e3 ^ 2 * x1 * e1 - 4 * e5 * e6 ^ 2 * x3 * e3 ^ 2 * x2 * e1 - 14 * e5 * e6 ^ 2 * e3 ^ 2 * x1 ^ 2 * e1 + 16 * x1 ^ 3 * e1 ^ 3 * x3 * e3 ^ 3 * x2 - 8 * x1 ^ 3 * e1 ^ 3 * e6 * e3 ^ 2 * x2 - 8 * x1 ^ 3 * e1 ^ 3 * e7 * e3 ^ 2 * x2 - 12 * x2 ^ 2 * e1 ^ 3 * x3 ^ 2 * e3 ^ 3 * x1 - 16 * e1 ^ 2 * x3 ^ 3 * x2 * e3 ^ 3 * y1 * y2 - 16 * e1 ^ 3 * x3 ^ 3 * x2 * e3 ^ 3 * x1 - 8 * e1 ^ 2 * x3 ^ 3 * e3 ^ 3 * x1 * y1 * y2 + 20 * e6 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * x1 * e1 + 14 * e6 ^ 2 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * e1 + 12 * e6 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * x1 * e1 + 12 * e6 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * x2 * e1 + 4 * e6 ^ 2 * x3 ^ 2 * e3 ^ 3 * x1 * e1 + 2 * e6 ^ 2 * x3 ^ 2 * e3 ^ 3 * x2 * e1 - 10 * e6 ^ 3 * x2 * e3 ^ 2 * x1 * e1 - 6 * e6 ^ 3 * x3 * e3 ^ 2 * x1 * e1 - 2 * e6 ^ 3 * x3 * e3 ^ 2 * x2 * e1 + 4 * e5 ^ 2 * x3 ^ 2 * e3 ^ 3 * x1 * e1 + 2 * e5 ^ 2 * x3 ^ 2 * e3 ^ 3 * x2 * e1 - 6 * e1 ^ 2 * x3 ^ 4 * e3 ^ 3 * y1 * y2 + 14 * e6 ^ 2 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * e1 + 20 * x1 ^ 2 * e1 ^ 3 * x2 ^ 2 * y2 * y3 * e3 ^ 2 + 16 * x1 * e1 ^ 3 * x2 ^ 3 * y2 * y3 * e3 ^ 2 + 8 * x1 ^ 2 * e1 ^ 3 * x2 * y2 * y3 * x3 * e3 ^ 2 + 8 * x1 * e1 ^ 3 * x2 ^ 2 * y2 * y3 * x3 * e3 ^ 2 + 16 * x1 ^ 3 * e1 ^ 3 * x2 * y2 * y3 * e3 ^ 2 + 12 * x1 ^ 2 * e1 ^ 3 * x2 ^ 2 * e3 ^ 3 * x3 - 6 * x1 ^ 2 * e1 ^ 3 * x2 ^ 2 * e6 * e3 ^ 2 + 12 * x1 * e1 ^ 3 * x2 ^ 2 * e6 * x3 * e3 ^ 2 - 6 * x1 ^ 2 * e1 ^ 3 * x2 ^ 2 * e7 * e3 ^ 2 + 12 * x1 * e1 ^ 3 * x2 ^ 2 * e7 * x3 * e3 ^ 2 + 20 * e5 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * x1 * e1 + 14 * e5 ^ 2 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * e1 + 12 * e5 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * x1 * e1 + 12 * e5 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * x2 * e1 + 14 * e5 ^ 2 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * e1 + 40 * e5 * e6 * y2 * y3 * x2 * e3 ^ 2 * x1 * e1 + 28 * e5 * e6 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * e1 + 24 * e5 * e6 * y2 * y3 * x3 * e3 ^ 2 * x1 * e1 + 24 * e5 * e6 * y2 * y3 * x3 * e3 ^ 2 * x2 * e1 + 28 * e5 * e6 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * e1 + 24 * e5 * e6 * x2 * e3 ^ 3 * x3 * x1 * e1 + 8 * e5 * e6 * x2 ^ 2 * e3 ^ 3 * x3 * e1 + 16 * e5 * e6 * x3 * e3 ^ 3 * x1 ^ 2 * e1 - 20 * e5 * e6 * e7 * x2 * e3 ^ 2 * x1 * e1 - 6 * e5 * e6 * e7 * x2 ^ 2 * e3 ^ 2 * e1 - 12 * e5 * e6 * e7 * x3 * e3 ^ 2 * x1 * e1 - 4 * e5 * e6 * e7 * x3 * e3 ^ 2 * x2 * e1 - 14 * e5 * e6 * e7 * e3 ^ 2 * x1 ^ 2 * e1 + 8 * x1 ^ 3 * e1 ^ 3 * y2 * y3 * x3 * e3 ^ 2 + 6 * x1 ^ 4 * e1 ^ 3 * y2 * y3 * e3 ^ 2 - 4 * x1 ^ 3 * e1 ^ 3 * e6 * x3 * e3 ^ 2 - 4 * x1 ^ 3 * e1 ^ 3 * e7 * x3 * e3 ^ 2 + 6 * x2 ^ 4 * e1 ^ 3 * y2 * y3 * e3 ^ 2 + 8 * x2 ^ 3 * e1 ^ 3 * y2 * y3 * x3 * e3 ^ 2 + 8 * x2 ^ 3 * e1 ^ 3 * e6 * x3 * e3 ^ 2 + 8 * x2 ^ 3 * e1 ^ 3 * e7 * x3 * e3 ^ 2 - 24 * e1 ^ 2 * x3 ^ 2 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 - 28 * e1 ^ 3 * x3 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * x1 - 10 * e1 ^ 3 * x3 ^ 2 * y2 * y3 * x2 ^ 2 * e3 ^ 2 - 24 * e1 ^ 2 * x3 ^ 3 * y2 ^ 2 * y3 * e3 ^ 2 * y1 - 20 * e1 ^ 3 * x3 ^ 3 * y2 * y3 * e3 ^ 2 * x1 - 20 * e1 ^ 3 * x3 ^ 3 * y2 * y3 * e3 ^ 2 * x2 - 24 * e1 ^ 2 * x3 ^ 2 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 - 10 * e1 ^ 3 * x3 ^ 2 * y2 * y3 * e3 ^ 2 * x1 ^ 2 + 32 * e1 ^ 2 * x3 ^ 2 * e6 * x2 * e3 ^ 2 * y1 * y2 + 24 * e1 ^ 3 * x3 ^ 2 * e6 * x2 * e3 ^ 2 * x1 + 18 * e1 ^ 3 * x3 ^ 2 * e6 * x2 ^ 2 * e3 ^ 2 + 16 * e1 ^ 2 * x3 ^ 3 * e6 * e3 ^ 2 * y1 * y2 + 12 * e1 ^ 3 * x3 ^ 3 * e6 * e3 ^ 2 * x1 + 16 * e1 ^ 3 * x3 ^ 3 * e6 * e3 ^ 2 * x2 + 16 * e1 ^ 2 * x3 ^ 3 * e7 * e3 ^ 2 * y1 * y2 + 12 * e1 ^ 3 * x3 ^ 3 * e7 * e3 ^ 2 * x1 + 16 * e1 ^ 3 * x3 ^ 3 * e7 * e3 ^ 2 * x2 - 4 * y1 * y2 * e1 * x3 ^ 2 * e6 ^ 2 * e3 ^ 2 + e5 ^ 2 * e1 * x3 ^ 2 * e6 * e3 ^ 2 + e5 ^ 2 * e1 * x3 ^ 2 * e7 * e3 ^ 2 + e6 ^ 2 * e1 * x3 ^ 2 * e7 * e3 ^ 2 + 2 * e6 ^ 2 * e1 * x3 ^ 2 * e3 ^ 2 * e5 - 8 * e1 ^ 2 * x3 ^ 2 * e6 * e3 ^ 2 * x1 * e5 - 16 * e1 ^ 2 * x3 ^ 2 * e7 * x2 * e3 ^ 2 * e5 - 16 * e1 ^ 2 * x3 ^ 2 * e7 * x2 * e3 ^ 2 * e6 - 8 * e1 ^ 2 * x3 ^ 2 * e7 * e3 ^ 2 * x1 * e5 - 8 * e1 ^ 2 * x3 ^ 2 * e7 * e3 ^ 2 * x1 * e6 - 4 * y1 * y2 * e1 * x3 ^ 2 * e6 * e3 ^ 2 * e5 - 4 * y1 * y2 * e1 * x3 ^ 2 * e7 * e3 ^ 2 * e5 - 4 * y1 * y2 * e1 * x3 ^ 2 * e7 * e3 ^ 2 * e6 + 2 * e5 * e1 * x3 ^ 2 * e7 * e3 ^ 2 * e6 + 16 * e1 ^ 2 * x3 ^ 2 * e6 * e3 ^ 2 * x1 * y1 * y2 + 6 * e1 ^ 3 * x3 ^ 2 * e6 * e3 ^ 2 * x1 ^ 2 + 32 * e1 ^ 2 * x3 ^ 2 * e7 * x2 * e3 ^ 2 * y1 * y2 + 24 * e1 ^ 3 * x3 ^ 2 * e7 * x2 * e3 ^ 2 * x1 + 18 * e1 ^ 3 * x3 ^ 2 * e7 * x2 ^ 2 * e3 ^ 2 + 16 * e1 ^ 2 * x3 ^ 2 * e7 * e3 ^ 2 * x1 * y1 * y2 + 6 * e1 ^ 3 * x3 ^ 2 * e7 * e3 ^ 2 * x1 ^ 2 + 4 * y1 ^ 2 * y2 ^ 2 * e1 * x3 ^ 2 * e6 * e3 ^ 2 + 4 * y1 ^ 2 * y2 ^ 2 * e1 * x3 ^ 2 * e7 * e3 ^ 2 + 4 * e3 * e6 ^ 3 * e7 * y2 * y3 + 2 * e3 * x1 * e1 ^ 2 * x2 * e6 ^ 3 + 4 * e3 * e5 ^ 3 * e6 * y2 * y3 + 12 * e3 * e5 ^ 2 * e6 ^ 2 * y2 * y3 + 4 * e3 * e5 ^ 3 * e7 * y2 * y3 - 12 * e3 * e5 ^ 2 * e6 * y2 ^ 2 * y3 ^ 2 - 12 * e3 * e5 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 + 12 * e3 * e5 * e6 ^ 3 * y2 * y3 - e3 * x1 ^ 2 * e1 ^ 2 * e6 ^ 3 + 3 * e3 * x2 ^ 2 * e1 ^ 2 * e6 ^ 3 + 7 * e3 * e1 ^ 2 * x3 ^ 2 * e6 ^ 3 + 2 * e3 * e6 ^ 4 * x1 * e1 - 2 * e3 * e6 ^ 4 * e1 * x3 - 2 * e3 * x2 ^ 3 * e1 ^ 3 * e6 ^ 2 - 2 * e3 * x2 ^ 3 * e1 ^ 3 * e7 ^ 2 - 2 * e3 * x1 ^ 2 * e1 ^ 2 * e6 ^ 2 * e7 + 6 * e3 * x2 ^ 2 * e1 ^ 2 * e6 ^ 2 * e7 + 14 * e3 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * e7 + 6 * e3 * x1 * e1 ^ 2 * x3 * e6 ^ 3 + 10 * e3 * x2 * e1 ^ 2 * x3 * e6 ^ 3 + 2 * e3 * e5 ^ 2 * x1 * e1 * e6 ^ 2 + 2 * e3 * e5 ^ 2 * x1 * e1 * e7 ^ 2 - 2 * e3 * e5 ^ 2 * e1 * x3 * e6 ^ 2 - 2 * e3 * e5 ^ 2 * e1 * x3 * e7 ^ 2 - e3 * x1 ^ 2 * e1 ^ 2 * e6 ^ 2 * e5 - e3 * x1 ^ 2 * e1 ^ 2 * e7 ^ 2 * e5 - e3 * x1 ^ 2 * e1 ^ 2 * e7 ^ 2 * e6 + 3 * e3 * x2 ^ 2 * e1 ^ 2 * e6 ^ 2 * e5 + 3 * e3 * x2 ^ 2 * e1 ^ 2 * e7 ^ 2 * e5 + 3 * e3 * x2 ^ 2 * e1 ^ 2 * e7 ^ 2 * e6 + 7 * e3 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * e5 + 7 * e3 * e1 ^ 2 * x3 ^ 2 * e7 ^ 2 * e5 + 7 * e3 * e1 ^ 2 * x3 ^ 2 * e7 ^ 2 * e6 + 4 * e3 * e6 ^ 3 * x1 * e1 * e5 - 4 * e3 * e6 ^ 3 * e1 * x3 * e5 - 2 * e3 * x1 ^ 2 * e1 ^ 3 * x2 * e6 ^ 2 - 4 * e3 * x1 * e1 ^ 3 * x2 ^ 2 * e6 ^ 2 - 2 * e3 * x1 ^ 2 * e1 ^ 3 * x2 * e7 ^ 2 - 4 * e3 * x1 * e1 ^ 3 * x2 ^ 2 * e7 ^ 2 + 4 * e3 * x1 * e1 ^ 2 * x2 * e6 ^ 2 * e7 + 8 * e3 * x1 * e1 ^ 2 * x2 * e6 ^ 2 * y2 * y3 + 4 * e3 * x1 ^ 2 * e1 ^ 2 * e6 ^ 2 * y2 * y3 + 4 * e3 * x2 ^ 2 * e1 ^ 2 * e6 ^ 2 * y2 * y3 - 20 * e3 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * y2 * y3 + 12 * e3 * e6 ^ 2 * e7 * y2 * y3 * e5 + 2 * e3 * x1 * e1 ^ 2 * x2 * e6 ^ 2 * e5 + 2 * e3 * x1 * e1 ^ 2 * x2 * e7 ^ 2 * e5 + 2 * e3 * x1 * e1 ^ 2 * x2 * e7 ^ 2 * e6 + 12 * e3 * e5 ^ 2 * e7 * y2 * y3 * e6 - 2 * e3 * x1 ^ 2 * e1 ^ 2 * e6 * e7 * e5 - 4 * e3 * x1 ^ 2 * e1 ^ 2 * y2 ^ 2 * y3 ^ 2 * e5 - 4 * e3 * x1 ^ 2 * e1 ^ 2 * y2 ^ 2 * y3 ^ 2 * e6 + 6 * e3 * x2 ^ 2 * e1 ^ 2 * e6 * e7 * e5 - 20 * e3 * x2 ^ 2 * e1 ^ 2 * y2 ^ 2 * y3 ^ 2 * e5 - 20 * e3 * x2 ^ 2 * e1 ^ 2 * y2 ^ 2 * y3 ^ 2 * e6 + 14 * e3 * e1 ^ 2 * x3 ^ 2 * e6 * e7 * e5 + 12 * e3 * e1 ^ 2 * x3 ^ 2 * y2 ^ 2 * y3 ^ 2 * e5 + 12 * e3 * e1 ^ 2 * x3 ^ 2 * y2 ^ 2 * y3 ^ 2 * e6 + 4 * e3 * x1 * e1 ^ 2 * x2 * e6 * e7 * e5 - 24 * e3 * x1 * e1 ^ 2 * x2 * y2 ^ 2 * y3 ^ 2 * e5 - 24 * e3 * x1 * e1 ^ 2 * x2 * y2 ^ 2 * y3 ^ 2 * e6 + 8 * e3 * x1 * e1 ^ 2 * x2 * e6 * y2 * y3 * e5 + 8 * e3 * x1 * e1 ^ 2 * x2 * e7 * y2 * y3 * e5 + 8 * e3 * x1 * e1 ^ 2 * x2 * e7 * y2 * y3 * e6 + 4 * e3 * x1 ^ 2 * e1 ^ 2 * e6 * y2 * y3 * e5 + 4 * e3 * x1 ^ 2 * e1 ^ 2 * e7 * y2 * y3 * e5 + 4 * e3 * x1 ^ 2 * e1 ^ 2 * e7 * y2 * y3 * e6 + 4 * e3 * x2 ^ 2 * e1 ^ 2 * e6 * y2 * y3 * e5 + 4 * e3 * x2 ^ 2 * e1 ^ 2 * e7 * y2 * y3 * e5 + 4 * e3 * x2 ^ 2 * e1 ^ 2 * e7 * y2 * y3 * e6 - 20 * e3 * e1 ^ 2 * x3 ^ 2 * e6 * y2 * y3 * e5 + 6 * e3 * x1 * e1 ^ 2 * x3 * e6 ^ 2 * e5 + 6 * e3 * x1 * e1 ^ 2 * x3 * e7 ^ 2 * e5 + 6 * e3 * x1 * e1 ^ 2 * x3 * e7 ^ 2 * e6 + 10 * e3 * x2 * e1 ^ 2 * x3 * e6 ^ 2 * e5 + 10 * e3 * x2 * e1 ^ 2 * x3 * e7 ^ 2 * e5 + 10 * e3 * x2 * e1 ^ 2 * x3 * e7 ^ 2 * e6 + 4 * e3 * e5 * x1 * e1 * e7 ^ 2 * e6 - 4 * e3 * e5 * e1 * x3 * e7 ^ 2 * e6 - 8 * e3 * e6 ^ 2 * e7 * y2 * y3 * x1 * e1 - 8 * e3 * e6 ^ 2 * e7 * y2 * y3 * x2 * e1 - 8 * e3 * e5 ^ 2 * e6 * y2 * y3 * x1 * e1 - 8 * e3 * e5 ^ 2 * e6 * y2 * y3 * x2 * e1 - 8 * e3 * e5 ^ 2 * e7 * y2 * y3 * x1 * e1 - 8 * e3 * e5 ^ 2 * e7 * y2 * y3 * x2 * e1 + 16 * e3 * e5 * e6 * y2 ^ 2 * y3 ^ 2 * x1 * e1 + 32 * e3 * e5 * e6 * y2 ^ 2 * y3 ^ 2 * x2 * e1 - 16 * e3 * e5 * e6 ^ 2 * y2 * y3 * x1 * e1 - 16 * e3 * e5 * e6 ^ 2 * y2 * y3 * x2 * e1 - 4 * e3 * x1 ^ 2 * e1 ^ 3 * e6 * e7 * x2 + 8 * e3 * x1 ^ 2 * e1 ^ 3 * y2 ^ 2 * y3 ^ 2 * x2 - 4 * e3 * x2 ^ 3 * e1 ^ 3 * e6 * e7 + 8 * e3 * x2 ^ 3 * e1 ^ 3 * y2 ^ 2 * y3 ^ 2 + 4 * e3 * e6 ^ 3 * e7 * x1 * e1 - 8 * e3 * e1 ^ 3 * x3 ^ 2 * e6 ^ 2 * x1 - 10 * e3 * e1 ^ 3 * x3 ^ 2 * e6 ^ 2 * x2 - 8 * e3 * e1 ^ 3 * x3 ^ 2 * e7 ^ 2 * x1 - 10 * e3 * e1 ^ 3 * x3 ^ 2 * e7 ^ 2 * x2 + 2 * e3 * e6 ^ 2 * e7 ^ 2 * x1 * e1 - 4 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * e6 ^ 2 - 4 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * e7 ^ 2 - 8 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * e6 ^ 2 - 8 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * e7 ^ 2 - 4 * e3 * e6 ^ 3 * e1 * x3 * e7 - 2 * e3 * e6 ^ 2 * e1 * x3 * e7 ^ 2 - 8 * e3 * x2 ^ 2 * e1 ^ 3 * e6 * e7 * x1 + 16 * e3 * x2 ^ 2 * e1 ^ 3 * y2 ^ 2 * y3 ^ 2 * x1 - 28 * e3 * e1 ^ 2 * x3 ^ 2 * e6 * e7 * y1 * y2 - 16 * e3 * e1 ^ 3 * x3 ^ 2 * e6 * e7 * x1 - 20 * e3 * e1 ^ 3 * x3 ^ 2 * e6 * e7 * x2 - 24 * e3 * e1 ^ 2 * x3 ^ 2 * y2 ^ 3 * y3 ^ 2 * y1 - 16 * e3 * e1 ^ 3 * x3 ^ 2 * y2 ^ 2 * y3 ^ 2 * x1 - 8 * e3 * e1 ^ 3 * x3 ^ 2 * y2 ^ 2 * y3 ^ 2 * x2 + 8 * e3 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 * x1 * e1 + 16 * e3 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 * x2 * e1 - 8 * e3 * e6 ^ 3 * y2 * y3 * x1 * e1 - 8 * e3 * e6 ^ 3 * y2 * y3 * x2 * e1 + 4 * e3 * e5 ^ 2 * e6 * e7 * x1 * e1 + 8 * e3 * e5 ^ 2 * y2 ^ 2 * y3 ^ 2 * x1 * e1 + 16 * e3 * e5 ^ 2 * y2 ^ 2 * y3 ^ 2 * x2 * e1 + 8 * e3 * e5 * e6 ^ 2 * e7 * x1 * e1 - 14 * e3 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * y1 * y2 - 14 * e3 * e1 ^ 2 * x3 ^ 2 * e7 ^ 2 * y1 * y2 + 8 * e3 * e6 ^ 3 * e1 * x3 * y1 * y2 - 16 * e3 * e5 * e6 * e7 * y2 * y3 * x1 * e1 - 16 * e3 * e5 * e6 * e7 * y2 * y3 * x2 * e1 + 40 * e3 * e1 ^ 2 * x3 ^ 2 * e6 * y2 ^ 2 * y3 * y1 + 24 * e3 * e1 ^ 3 * x3 ^ 2 * e6 * y2 * y3 * x1 + 24 * e3 * e1 ^ 3 * x3 ^ 2 * e6 * y2 * y3 * x2 - 12 * e3 * x1 * e1 ^ 2 * x3 * e6 ^ 2 * y1 * y2 - 12 * e3 * x1 * e1 ^ 3 * x3 * e6 ^ 2 * x2 - 12 * e3 * x1 * e1 ^ 2 * x3 * e7 ^ 2 * y1 * y2 - 12 * e3 * x1 * e1 ^ 3 * x3 * e7 ^ 2 * x2 - 20 * e3 * x2 * e1 ^ 2 * x3 * e6 ^ 2 * y1 * y2 - 20 * e3 * x2 * e1 ^ 2 * x3 * e7 ^ 2 * y1 * y2 + 8 * e3 * e5 * e1 * x3 * e6 ^ 2 * y1 * y2 + 8 * e3 * e5 * e1 * x3 * e7 ^ 2 * y1 * y2 + 16 * e3 * y1 * y2 * e1 * x3 * e6 ^ 2 * e7 - 16 * e3 * y1 * y2 ^ 2 * e1 * x3 * e6 ^ 2 * y3 + 12 * e3 * x1 * e1 ^ 2 * x3 * e6 ^ 2 * e7 - 16 * e3 * x1 * e1 ^ 2 * x3 * e6 ^ 2 * y2 * y3 + 20 * e3 * x2 * e1 ^ 2 * x3 * e6 ^ 2 * e7 - 16 * e3 * x2 * e1 ^ 2 * x3 * e6 ^ 2 * y2 * y3 - 4 * e3 * e5 ^ 2 * e1 * x3 * e6 * e7 + 4 * e3 * e5 ^ 2 * e1 * x3 * e6 * y2 * y3 + 8 * e3 * e5 * e1 * x3 * e6 ^ 2 * y2 * y3 + 4 * e3 * e5 ^ 2 * e1 * x3 * e7 * y2 * y3 + 4 * e3 * e6 ^ 3 * e1 * x3 * y2 * y3 + 4 * e3 * e6 ^ 2 * e1 * x3 * e7 * y2 * y3 - 8 * e3 * e6 ^ 2 * e1 * x3 * e7 * e5 - 20 * e3 * e1 ^ 2 * x3 ^ 2 * e7 * y2 * y3 * e5 - 20 * e3 * e1 ^ 2 * x3 ^ 2 * e7 * y2 * y3 * e6 + 16 * e3 * y1 * y2 * e1 * x3 * e6 * e7 * e5 + 8 * e3 * y1 * y2 * e1 * x3 * e7 ^ 2 * e6 - 16 * e3 * y1 * y2 ^ 2 * e1 * x3 * e6 * y3 * e5 - 16 * e3 * y1 * y2 ^ 2 * e1 * x3 * e7 * y3 * e5 - 16 * e3 * y1 * y2 ^ 2 * e1 * x3 * e7 * y3 * e6 + 12 * e3 * x1 * e1 ^ 2 * x3 * e6 * e7 * e5 + 8 * e3 * x1 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 * e5 + 8 * e3 * x1 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 * e6 - 16 * e3 * x1 * e1 ^ 2 * x3 * e6 * y2 * y3 * e5 - 16 * e3 * x1 * e1 ^ 2 * x3 * e7 * y2 * y3 * e5 - 16 * e3 * x1 * e1 ^ 2 * x3 * e7 * y2 * y3 * e6 + 20 * e3 * x2 * e1 ^ 2 * x3 * e6 * e7 * e5 - 8 * e3 * x2 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 * e5 - 8 * e3 * x2 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 * e6 - 16 * e3 * x2 * e1 ^ 2 * x3 * e6 * y2 * y3 * e5 - 16 * e3 * x2 * e1 ^ 2 * x3 * e7 * y2 * y3 * e5 - 16 * e3 * x2 * e1 ^ 2 * x3 * e7 * y2 * y3 * e6 + 8 * e3 * e5 * e1 * x3 * e7 * y2 * y3 * e6 + 40 * e3 * e1 ^ 2 * x3 ^ 2 * e7 * y2 ^ 2 * y3 * y1 + 24 * e3 * e1 ^ 3 * x3 ^ 2 * e7 * y2 * y3 * x1 + 24 * e3 * e1 ^ 3 * x3 ^ 2 * e7 * y2 * y3 * x2 - 8 * e3 * y1 ^ 2 * y2 ^ 2 * e1 * x3 * e6 ^ 2 - 16 * e3 * y1 ^ 2 * y2 ^ 2 * e1 * x3 * e6 * e7 - 24 * e3 * y1 * y2 * e1 ^ 2 * x3 * e6 * e7 * x1 - 40 * e3 * y1 * y2 * e1 ^ 2 * x3 * e6 * e7 * x2 - 8 * e3 * y1 ^ 2 * y2 ^ 2 * e1 * x3 * e7 ^ 2 - 16 * e3 * y1 * y2 ^ 3 * e1 ^ 2 * x3 * y3 ^ 2 * x1 + 16 * e3 * y1 * y2 ^ 3 * e1 ^ 2 * x3 * y3 ^ 2 * x2 + 16 * e3 * y1 ^ 2 * y2 ^ 3 * e1 * x3 * e6 * y3 + 32 * e3 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e6 * y3 * x1 + 32 * e3 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e6 * y3 * x2 + 16 * e3 * y1 ^ 2 * y2 ^ 3 * e1 * x3 * e7 * y3 + 32 * e3 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e7 * y3 * x1 + 32 * e3 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e7 * y3 * x2 - 8 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * e6 * e7 - 24 * e3 * x1 * e1 ^ 3 * x3 * e6 * e7 * x2 - 8 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * y2 ^ 2 * y3 ^ 2 + 12 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * e6 * y2 * y3 + 24 * e3 * x1 * e1 ^ 3 * x3 * e6 * y2 * y3 * x2 + 12 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * e7 * y2 * y3 + 24 * e3 * x1 * e1 ^ 3 * x3 * e7 * y2 * y3 * x2 - 16 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * e6 * e7 + 8 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * y2 ^ 2 * y3 ^ 2 + 12 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * e6 * y2 * y3 + 12 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * e7 * y2 * y3 - 2 * x3 ^ 5 * e1 ^ 3 * e3 ^ 3 - 4 * x3 ^ 3 * e1 ^ 3 * e3 * e6 ^ 2 - 4 * x3 ^ 3 * e1 ^ 3 * e3 * e7 ^ 2 + 5 * x3 ^ 4 * e1 ^ 3 * e3 ^ 2 * e6 + 5 * x3 ^ 4 * e1 ^ 3 * e3 ^ 2 * e7 - 8 * x3 ^ 3 * e1 ^ 3 * e3 * e6 * e7 - 8 * x3 ^ 3 * e1 ^ 3 * e3 * y2 ^ 2 * y3 ^ 2 - 8 * x3 ^ 4 * e1 ^ 3 * e3 ^ 2 * y2 * y3 + 12 * x3 ^ 3 * e1 ^ 3 * e3 * e6 * y2 * y3 + 12 * x3 ^ 3 * e1 ^ 3 * e3 * e7 * y2 * y3 - 8 * y2 ^ 3 * y3 * x2 * e3 * x1 ^ 2 * e1 ^ 3 - e6 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 - e6 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 - e7 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 - e7 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 - 4 * y2 ^ 4 * y3 ^ 2 * x1 ^ 2 * e1 ^ 3 - 4 * y2 ^ 4 * y3 ^ 2 * x2 ^ 2 * e1 ^ 3 - 4 * x2 ^ 4 * e3 ^ 2 * y2 ^ 2 * e1 ^ 3 + 2 * e6 ^ 3 * y2 ^ 2 * x1 * e1 ^ 2 + 2 * e6 ^ 3 * y2 ^ 2 * x2 * e1 ^ 2 - y2 ^ 2 * e7 ^ 2 * e1 ^ 3 * x3 ^ 2 - 4 * y2 ^ 4 * y3 ^ 2 * e1 ^ 3 * x3 ^ 2 - y3 ^ 2 * e6 ^ 2 * x1 ^ 2 * e1 ^ 3 - y3 ^ 2 * e6 ^ 2 * x2 ^ 2 * e1 ^ 3 - y3 ^ 2 * e6 ^ 2 * e1 ^ 3 * x3 ^ 2 - y3 ^ 2 * e7 ^ 2 * x1 ^ 2 * e1 ^ 3 - y3 ^ 2 * e7 ^ 2 * x2 ^ 2 * e1 ^ 3 - y3 ^ 2 * e7 ^ 2 * e1 ^ 3 * x3 ^ 2 - 4 * y2 ^ 2 * y3 ^ 4 * x1 ^ 2 * e1 ^ 3 - 4 * y2 ^ 2 * y3 ^ 4 * x2 ^ 2 * e1 ^ 3 - 4 * y2 ^ 2 * y3 ^ 4 * e1 ^ 3 * x3 ^ 2 - e4 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 - e4 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 - e4 ^ 2 * y2 ^ 2 * e1 ^ 3 * x3 ^ 2 - e4 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 3 - e4 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 3 - e4 ^ 2 * y1 ^ 2 * e1 ^ 3 * x3 ^ 2 - y2 ^ 2 * x3 ^ 4 * e3 ^ 2 * e1 ^ 3 - 4 * y3 ^ 2 * x2 ^ 4 * e3 ^ 2 * e1 ^ 3 - y3 ^ 2 * x3 ^ 4 * e3 ^ 2 * e1 ^ 3 + 2 * y2 ^ 2 * e6 ^ 3 * e1 ^ 2 * x3 + 2 * y3 ^ 2 * e6 ^ 3 * x1 * e1 ^ 2 + 2 * y3 ^ 2 * e6 ^ 3 * x2 * e1 ^ 2 + 2 * y3 ^ 2 * e6 ^ 3 * e1 ^ 2 * x3 - 2 * e1 * e6 ^ 3 * y2 ^ 2 * e5 + 4 * e1 * e6 ^ 3 * y2 ^ 3 * y1 - e1 * e6 ^ 2 * y2 ^ 2 * e5 ^ 2 - 4 * e1 * e6 ^ 2 * y1 ^ 2 * y2 ^ 4 - 2 * e1 * e6 ^ 3 * e7 * y2 ^ 2 - e1 * e7 ^ 2 * y2 ^ 2 * e5 ^ 2 - e1 * e7 ^ 2 * y2 ^ 2 * e6 ^ 2 - 4 * e1 * e7 ^ 2 * y1 ^ 2 * y2 ^ 4 - 4 * e1 * y2 ^ 4 * y3 ^ 2 * e5 ^ 2 - 4 * e1 * y2 ^ 4 * y3 ^ 2 * e6 ^ 2 - 16 * e1 * y2 ^ 6 * y3 ^ 2 * y1 ^ 2 + 4 * e1 * e6 ^ 3 * y2 ^ 3 * y3 - 8 * e1 * e4 ^ 2 * y2 ^ 3 * y1 ^ 3 + 4 * e1 * e6 ^ 3 * y2 ^ 2 * y3 ^ 2 - 4 * e1 * e6 ^ 4 * y2 * y3 - e1 * y3 ^ 2 * e6 ^ 2 * e5 ^ 2 - 2 * e1 * y3 ^ 2 * e6 ^ 3 * e5 - e1 * y3 ^ 2 * e7 ^ 2 * e6 ^ 2 - e1 * y3 ^ 2 * e7 ^ 2 * e5 ^ 2 - 4 * e1 * y2 ^ 2 * y3 ^ 4 * e6 ^ 2 - 4 * e1 * y2 ^ 2 * y3 ^ 4 * e5 ^ 2 - 8 * y2 ^ 3 * y3 * x2 ^ 3 * e3 * e1 ^ 3 - e1 * e6 ^ 4 * y2 ^ 2 - 4 * y2 ^ 3 * y3 * x3 * e3 * x1 ^ 2 * e1 ^ 3 - 20 * y2 ^ 3 * y3 * x3 * e3 * x2 ^ 2 * e1 ^ 3 - 16 * y2 ^ 3 * y3 * e3 * x1 * x2 ^ 2 * e1 ^ 3 - 2 * e6 * e7 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 - 2 * e6 * e7 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 - 4 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 - x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 - 13 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 + 16 * y2 ^ 3 * y3 * x2 * e3 * e5 * x1 * e1 ^ 2 + 16 * y2 ^ 3 * y3 * x2 ^ 2 * e3 * e5 * e1 ^ 2 + 2 * e6 ^ 2 * y2 ^ 2 * e5 * x1 * e1 ^ 2 - 32 * y2 ^ 4 * y3 * x2 * e3 * y1 * x1 * e1 ^ 2 - 32 * y2 ^ 4 * y3 * x2 ^ 2 * e3 * y1 * e1 ^ 2 + 8 * y2 ^ 3 * y3 * x3 * e3 * e5 * x1 * e1 ^ 2 + 24 * y2 ^ 3 * y3 * x3 * e3 * e5 * x2 * e1 ^ 2 + 8 * y2 ^ 3 * y3 * x3 * e3 * e6 * x1 * e1 ^ 2 + 24 * y2 ^ 3 * y3 * x3 * e3 * e6 * x2 * e1 ^ 2 - 16 * y2 ^ 4 * y3 * x3 * e3 * y1 * x1 * e1 ^ 2 - 48 * y2 ^ 4 * y3 * x3 * e3 * y1 * x2 * e1 ^ 2 - 24 * y2 ^ 3 * y3 * x3 * e3 * x1 * e1 ^ 3 * x2 + 2 * e6 ^ 2 * y2 ^ 2 * e5 * x2 * e1 ^ 2 - 4 * e6 ^ 2 * y1 * y2 ^ 3 * x1 * e1 ^ 2 - 4 * e6 ^ 2 * y1 * y2 ^ 3 * x2 * e1 ^ 2 - 2 * e6 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 * x2 + 4 * e6 * e7 * y2 ^ 2 * e5 * x1 * e1 ^ 2 + 4 * e6 * e7 * y2 ^ 2 * e5 * x2 * e1 ^ 2 + 4 * e6 ^ 2 * e7 * y2 ^ 2 * x1 * e1 ^ 2 + 4 * e6 ^ 2 * e7 * y2 ^ 2 * x2 * e1 ^ 2 - 8 * e6 * e7 * y1 * y2 ^ 3 * x1 * e1 ^ 2 - 8 * e6 * e7 * y1 * y2 ^ 3 * x2 * e1 ^ 2 - 4 * e6 * e7 * y2 ^ 2 * x1 * e1 ^ 3 * x2 + 2 * e7 ^ 2 * y2 ^ 2 * e5 * x1 * e1 ^ 2 + 2 * e7 ^ 2 * y2 ^ 2 * e5 * x2 * e1 ^ 2 + 2 * e7 ^ 2 * y2 ^ 2 * e6 * x1 * e1 ^ 2 + 2 * e7 ^ 2 * y2 ^ 2 * e6 * x2 * e1 ^ 2 - y2 ^ 2 * e6 ^ 2 * e1 ^ 3 * x3 ^ 2 - 4 * e7 ^ 2 * y1 * y2 ^ 3 * x1 * e1 ^ 2 - 4 * e7 ^ 2 * y1 * y2 ^ 3 * x2 * e1 ^ 2 - 2 * e7 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 * x2 + 16 * y2 ^ 3 * y3 ^ 2 * y1 * e6 * x1 * e1 ^ 2 + 16 * y2 ^ 3 * y3 ^ 2 * y1 * e6 * x2 * e1 ^ 2 + 8 * y2 ^ 4 * y3 ^ 2 * e5 * x1 * e1 ^ 2 + 8 * y2 ^ 4 * y3 ^ 2 * e5 * x2 * e1 ^ 2 + 8 * y2 ^ 4 * y3 ^ 2 * e6 * x1 * e1 ^ 2 + 8 * y2 ^ 4 * y3 ^ 2 * e6 * x2 * e1 ^ 2 - 16 * y2 ^ 5 * y3 ^ 2 * y1 * x1 * e1 ^ 2 - 16 * y2 ^ 5 * y3 ^ 2 * y1 * x2 * e1 ^ 2 - 8 * y2 ^ 4 * y3 ^ 2 * x1 * e1 ^ 3 * x2 + 8 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 ^ 2 + 8 * x2 ^ 3 * e3 ^ 2 * y2 ^ 2 * e5 * e1 ^ 2 - 16 * x2 ^ 2 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 ^ 2 - 16 * x2 ^ 3 * e3 ^ 2 * y1 * y2 ^ 3 * e1 ^ 2 - 8 * x2 ^ 3 * e3 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 + 2 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 ^ 2 + 10 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * x2 * e1 ^ 2 + 2 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e6 * x1 * e1 ^ 2 + 10 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e6 * x2 * e1 ^ 2 - 4 * x3 ^ 2 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 ^ 2 - 20 * x3 ^ 2 * e3 ^ 2 * y1 * y2 ^ 3 * x2 * e1 ^ 2 - 10 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 * x2 - 4 * x2 * e3 ^ 2 * x3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 - 12 * x2 ^ 3 * e3 ^ 2 * x3 * y2 ^ 2 * e1 ^ 3 - 16 * x3 * e3 ^ 2 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 + 4 * e6 * y2 ^ 3 * y3 * x1 ^ 2 * e1 ^ 3 + 4 * e6 * y2 ^ 3 * y3 * x2 ^ 2 * e1 ^ 3 + 4 * e6 * x2 * e3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 + 4 * e6 * x2 ^ 3 * e3 * y2 ^ 2 * e1 ^ 3 + 2 * e6 * x3 * e3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 + 10 * e6 * x3 * e3 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 + 8 * e6 * e3 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 + 4 * e7 * y2 ^ 3 * y3 * x1 ^ 2 * e1 ^ 3 + 4 * e7 * y2 ^ 3 * y3 * x2 ^ 2 * e1 ^ 3 + 4 * e7 * x2 * e3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 + 4 * e7 * x2 ^ 3 * e3 * y2 ^ 2 * e1 ^ 3 + 2 * e7 * x3 * e3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 + 10 * e7 * x3 * e3 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 + 8 * e7 * e3 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 + 8 * x2 * e3 ^ 2 * x3 * y2 ^ 2 * e5 * x1 * e1 ^ 2 + 16 * x2 ^ 2 * e3 ^ 2 * x3 * y2 ^ 2 * e5 * e1 ^ 2 - 16 * x2 * e3 ^ 2 * x3 * y1 * y2 ^ 3 * x1 * e1 ^ 2 - 32 * x2 ^ 2 * e3 ^ 2 * x3 * y1 * y2 ^ 3 * e1 ^ 2 - 16 * e6 ^ 2 * y2 ^ 2 * y3 * y1 * x1 * e1 ^ 2 - 16 * e6 ^ 2 * y2 ^ 2 * y3 * y1 * x2 * e1 ^ 2 - 8 * e6 * y2 ^ 3 * y3 * e5 * x1 * e1 ^ 2 - 8 * e6 * y2 ^ 3 * y3 * e5 * x2 * e1 ^ 2 - 8 * e6 ^ 2 * y2 ^ 3 * y3 * x1 * e1 ^ 2 - 8 * e6 ^ 2 * y2 ^ 3 * y3 * x2 * e1 ^ 2 + 16 * e6 * y2 ^ 4 * y3 * y1 * x1 * e1 ^ 2 + 16 * e6 * y2 ^ 4 * y3 * y1 * x2 * e1 ^ 2 + 8 * e6 * y2 ^ 3 * y3 * x1 * e1 ^ 3 * x2 - 8 * e6 * x2 * e3 * y2 ^ 2 * e5 * x1 * e1 ^ 2 - 8 * e6 * x2 ^ 2 * e3 * y2 ^ 2 * e5 * e1 ^ 2 + 16 * e6 * x2 * e3 * y1 * y2 ^ 3 * x1 * e1 ^ 2 + 16 * e6 * x2 ^ 2 * e3 * y1 * y2 ^ 3 * e1 ^ 2 - 4 * e6 * x3 * e3 * y2 ^ 2 * e5 * x1 * e1 ^ 2 - 12 * e6 * x3 * e3 * y2 ^ 2 * e5 * x2 * e1 ^ 2 - 4 * e6 ^ 2 * x3 * e3 * y2 ^ 2 * x1 * e1 ^ 2 - 12 * e6 ^ 2 * x3 * e3 * y2 ^ 2 * x2 * e1 ^ 2 + 8 * e6 * x3 * e3 * y1 * y2 ^ 3 * x1 * e1 ^ 2 + 24 * e6 * x3 * e3 * y1 * y2 ^ 3 * x2 * e1 ^ 2 + 12 * e6 * x3 * e3 * y2 ^ 2 * x1 * e1 ^ 3 * x2 - 32 * e7 * y2 ^ 2 * y3 * y1 * e6 * x1 * e1 ^ 2 - 32 * e7 * y2 ^ 2 * y3 * y1 * e6 * x2 * e1 ^ 2 - 8 * e7 * y2 ^ 3 * y3 * e5 * x1 * e1 ^ 2 - 8 * e7 * y2 ^ 3 * y3 * e5 * x2 * e1 ^ 2 - 8 * e7 * y2 ^ 3 * y3 * e6 * x1 * e1 ^ 2 - 8 * e7 * y2 ^ 3 * y3 * e6 * x2 * e1 ^ 2 + 16 * e7 * y2 ^ 4 * y3 * y1 * x1 * e1 ^ 2 + 16 * e7 * y2 ^ 4 * y3 * y1 * x2 * e1 ^ 2 + 8 * e7 * y2 ^ 3 * y3 * x1 * e1 ^ 3 * x2 - 8 * e7 * x2 * e3 * y2 ^ 2 * e5 * x1 * e1 ^ 2 - 8 * e7 * x2 ^ 2 * e3 * y2 ^ 2 * e5 * e1 ^ 2 + 16 * e7 * x2 * e3 * y1 * y2 ^ 3 * x1 * e1 ^ 2 + 16 * e7 * x2 ^ 2 * e3 * y1 * y2 ^ 3 * e1 ^ 2 - 4 * e7 * x3 * e3 * y2 ^ 2 * e5 * x1 * e1 ^ 2 - 12 * e7 * x3 * e3 * y2 ^ 2 * e5 * x2 * e1 ^ 2 - 4 * e7 * x3 * e3 * y2 ^ 2 * e6 * x1 * e1 ^ 2 - 12 * e7 * x3 * e3 * y2 ^ 2 * e6 * x2 * e1 ^ 2 + 8 * e7 * x3 * e3 * y1 * y2 ^ 3 * x1 * e1 ^ 2 + 24 * e7 * x3 * e3 * y1 * y2 ^ 3 * x2 * e1 ^ 2 + 12 * e7 * x3 * e3 * y2 ^ 2 * x1 * e1 ^ 3 * x2 - 8 * x1 * e1 ^ 3 * x2 * e6 ^ 2 * y2 * y3 - 4 * x1 ^ 2 * e1 ^ 3 * e6 ^ 2 * y2 * y3 - 4 * x2 ^ 2 * e1 ^ 3 * e6 ^ 2 * y2 * y3 - 4 * e1 ^ 3 * x3 ^ 2 * e6 ^ 2 * y2 * y3 + 4 * x1 ^ 2 * e1 ^ 3 * y2 ^ 2 * y3 ^ 2 * e6 + 4 * x2 ^ 2 * e1 ^ 3 * y2 ^ 2 * y3 ^ 2 * e6 + 4 * e1 ^ 3 * x3 ^ 2 * y2 ^ 2 * y3 ^ 2 * e6 + 8 * x1 * e1 ^ 3 * x2 * y2 ^ 2 * y3 ^ 2 * e6 - 16 * x1 * e1 ^ 3 * x2 * e7 * y2 * y3 * e6 - 8 * x1 ^ 2 * e1 ^ 3 * e7 * y2 * y3 * e6 - 8 * x2 ^ 2 * e1 ^ 3 * e7 * y2 * y3 * e6 + 16 * e6 ^ 2 * e7 * y2 * y3 * x1 * e1 ^ 2 + 16 * e6 ^ 2 * e7 * y2 * y3 * x2 * e1 ^ 2 - 8 * e5 * e6 * y2 ^ 2 * y3 ^ 2 * x1 * e1 ^ 2 - 8 * e5 * e6 * y2 ^ 2 * y3 ^ 2 * x2 * e1 ^ 2 + 8 * e5 * e6 ^ 2 * y2 * y3 * x1 * e1 ^ 2 + 8 * e5 * e6 ^ 2 * y2 * y3 * x2 * e1 ^ 2 - 8 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 * x1 * e1 ^ 2 - 8 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 * x2 * e1 ^ 2 + 8 * e6 ^ 3 * y2 * y3 * x1 * e1 ^ 2 + 8 * e6 ^ 3 * y2 * y3 * x2 * e1 ^ 2 + 16 * e5 * e6 * e7 * y2 * y3 * x1 * e1 ^ 2 + 16 * e5 * e6 * e7 * y2 * y3 * x2 * e1 ^ 2 - 16 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e6 ^ 2 * y3 - 8 * x1 * e1 ^ 3 * x3 * e6 ^ 2 * y2 * y3 - 8 * x2 * e1 ^ 3 * x3 * e6 ^ 2 * y2 * y3 + 8 * e5 * e1 ^ 2 * x3 * e6 ^ 2 * y2 * y3 - 8 * e6 ^ 2 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 + 8 * e6 ^ 3 * e1 ^ 2 * x3 * y2 * y3 + 16 * e6 ^ 2 * e1 ^ 2 * x3 * e7 * y2 * y3 - 8 * e1 ^ 3 * x3 ^ 2 * e7 * y2 * y3 * e6 + 16 * y1 * y2 ^ 3 * e1 ^ 2 * x3 * y3 ^ 2 * e6 - 32 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e7 * y3 * e6 + 8 * x1 * e1 ^ 3 * x3 * y2 ^ 2 * y3 ^ 2 * e6 - 16 * x1 * e1 ^ 3 * x3 * e7 * y2 * y3 * e6 + 8 * x2 * e1 ^ 3 * x3 * y2 ^ 2 * y3 ^ 2 * e6 - 16 * x2 * e1 ^ 3 * x3 * e7 * y2 * y3 * e6 - 8 * e5 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 * e6 + 16 * e5 * e1 ^ 2 * x3 * e7 * y2 * y3 * e6 - 2 * y3 ^ 2 * e6 ^ 2 * x1 * e1 ^ 3 * x2 - 4 * y3 ^ 2 * e6 ^ 2 * y1 * y2 * x1 * e1 ^ 2 - 4 * y3 ^ 2 * e6 ^ 2 * y1 * y2 * x2 * e1 ^ 2 - 2 * y3 ^ 2 * e7 ^ 2 * x1 * e1 ^ 3 * x2 - 4 * y3 ^ 2 * e7 ^ 2 * y1 * y2 * x1 * e1 ^ 2 - 4 * y3 ^ 2 * e7 ^ 2 * y1 * y2 * x2 * e1 ^ 2 - 8 * y2 ^ 2 * y3 ^ 4 * x1 * e1 ^ 3 * x2 - 16 * y2 ^ 3 * y3 ^ 4 * y1 * x1 * e1 ^ 2 - 16 * y2 ^ 3 * y3 ^ 4 * y1 * x2 * e1 ^ 2 - 2 * e4 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 * x2 - 4 * e4 ^ 2 * y2 ^ 3 * y1 * x1 * e1 ^ 2 - 4 * e4 ^ 2 * y2 ^ 3 * y1 * x2 * e1 ^ 2 - 2 * e4 ^ 2 * y1 ^ 2 * x1 * e1 ^ 3 * x2 - 4 * e4 ^ 2 * y1 ^ 3 * y2 * x1 * e1 ^ 2 - 4 * e4 ^ 2 * y1 ^ 3 * y2 * x2 * e1 ^ 2 - 2 * y2 ^ 2 * e6 * e7 * e1 ^ 3 * x3 ^ 2 + 4 * y2 ^ 3 * e6 * y3 * e1 ^ 3 * x3 ^ 2 - 4 * y2 ^ 2 * e6 * e4 * x1 * e1 ^ 3 * x2 - 2 * y2 ^ 2 * e6 * e4 * x1 ^ 2 * e1 ^ 3 - 2 * y2 ^ 2 * e6 * e4 * x2 ^ 2 * e1 ^ 3 - 2 * y2 ^ 2 * e6 * e4 * e1 ^ 3 * x3 ^ 2 - 8 * y2 ^ 3 * e6 * e4 * y1 * x1 * e1 ^ 2 - 8 * y2 ^ 3 * e6 * e4 * y1 * x2 * e1 ^ 2 + 4 * y2 ^ 3 * e7 * y3 * e1 ^ 3 * x3 ^ 2 - 8 * y2 * e7 ^ 2 * y3 * x1 * e1 ^ 3 * x2 - 4 * y2 * e7 ^ 2 * y3 * x1 ^ 2 * e1 ^ 3 - 4 * y2 * e7 ^ 2 * y3 * x2 ^ 2 * e1 ^ 3 - 4 * y2 * e7 ^ 2 * y3 * e1 ^ 3 * x3 ^ 2 - 16 * y2 ^ 2 * e7 ^ 2 * y3 * y1 * x1 * e1 ^ 2 - 16 * y2 ^ 2 * e7 ^ 2 * y3 * y1 * x2 * e1 ^ 2 + 8 * y2 ^ 2 * e7 * y3 ^ 2 * x1 * e1 ^ 3 * x2 + 4 * y2 ^ 2 * e7 * y3 ^ 2 * x1 ^ 2 * e1 ^ 3 + 4 * y2 ^ 2 * e7 * y3 ^ 2 * x2 ^ 2 * e1 ^ 3 + 4 * y2 ^ 2 * e7 * y3 ^ 2 * e1 ^ 3 * x3 ^ 2 + 16 * y2 ^ 3 * e7 * y3 ^ 2 * y1 * x1 * e1 ^ 2 + 16 * y2 ^ 3 * e7 * y3 ^ 2 * y1 * x2 * e1 ^ 2 - 4 * y2 ^ 2 * e7 * e4 * x1 * e1 ^ 3 * x2 - 2 * y2 ^ 2 * e7 * e4 * x1 ^ 2 * e1 ^ 3 - 2 * y2 ^ 2 * e7 * e4 * x2 ^ 2 * e1 ^ 3 - 2 * y2 ^ 2 * e7 * e4 * e1 ^ 3 * x3 ^ 2 - 8 * y2 ^ 3 * e7 * e4 * y1 * x1 * e1 ^ 2 - 8 * y2 ^ 3 * e7 * e4 * y1 * x2 * e1 ^ 2 + 8 * y2 ^ 3 * y3 * e4 * x1 * e1 ^ 3 * x2 + 4 * y2 ^ 3 * y3 * e4 * x1 ^ 2 * e1 ^ 3 + 4 * y2 ^ 3 * y3 * e4 * x2 ^ 2 * e1 ^ 3 + 4 * y2 ^ 3 * y3 * e4 * e1 ^ 3 * x3 ^ 2 + 16 * y2 ^ 4 * y3 * e4 * y1 * x1 * e1 ^ 2 + 16 * y2 ^ 4 * y3 * e4 * y1 * x2 * e1 ^ 2 - 4 * y3 ^ 2 * e6 * e7 * x1 * e1 ^ 3 * x2 - 2 * y3 ^ 2 * e6 * e7 * x1 ^ 2 * e1 ^ 3 - 2 * y3 ^ 2 * e6 * e7 * x2 ^ 2 * e1 ^ 3 - 2 * y3 ^ 2 * e6 * e7 * e1 ^ 3 * x3 ^ 2 - 8 * y3 ^ 2 * e6 * e7 * y1 * y2 * x1 * e1 ^ 2 - 8 * y3 ^ 2 * e6 * e7 * y1 * y2 * x2 * e1 ^ 2 + 8 * y3 ^ 3 * e6 * y2 * x1 * e1 ^ 3 * x2 + 4 * y3 ^ 3 * e6 * y2 * x1 ^ 2 * e1 ^ 3 + 4 * y3 ^ 3 * e6 * y2 * x2 ^ 2 * e1 ^ 3 + 4 * y3 ^ 3 * e6 * y2 * e1 ^ 3 * x3 ^ 2 + 16 * y3 ^ 3 * e6 * y2 ^ 2 * y1 * x1 * e1 ^ 2 + 16 * y3 ^ 3 * e6 * y2 ^ 2 * y1 * x2 * e1 ^ 2 + 8 * y3 ^ 3 * e7 * y2 * x1 * e1 ^ 3 * x2 + 4 * y3 ^ 3 * e7 * y2 * x1 ^ 2 * e1 ^ 3 + 4 * y3 ^ 3 * e7 * y2 * x2 ^ 2 * e1 ^ 3 + 4 * y3 ^ 3 * e7 * y2 * e1 ^ 3 * x3 ^ 2 + 16 * y3 ^ 3 * e7 * y2 ^ 2 * y1 * x1 * e1 ^ 2 + 16 * y3 ^ 3 * e7 * y2 ^ 2 * y1 * x2 * e1 ^ 2 - 8 * y2 ^ 2 * y3 ^ 2 * e4 * x1 * e1 ^ 3 * x2 - 4 * y2 ^ 2 * y3 ^ 2 * e4 * x1 ^ 2 * e1 ^ 3 - 4 * y2 ^ 2 * y3 ^ 2 * e4 * x2 ^ 2 * e1 ^ 3 - 4 * y2 ^ 2 * y3 ^ 2 * e4 * e1 ^ 3 * x3 ^ 2 - 16 * y2 ^ 3 * y3 ^ 2 * e4 * y1 * x1 * e1 ^ 2 - 16 * y2 ^ 3 * y3 ^ 2 * e4 * y1 * x2 * e1 ^ 2 - 8 * y3 ^ 2 * x2 ^ 3 * e3 ^ 2 * x1 * e1 ^ 3 - 4 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * x1 ^ 2 * e1 ^ 3 - 13 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e1 ^ 3 * x3 ^ 2 - 16 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 * y2 * x1 * e1 ^ 2 - 16 * y3 ^ 2 * x2 ^ 3 * e3 ^ 2 * y1 * y2 * e1 ^ 2 - 10 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * x1 * e1 ^ 3 * x2 - y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * x1 ^ 2 * e1 ^ 3 - 4 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * y1 * y2 * x1 * e1 ^ 2 - 20 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * y1 * y2 * x2 * e1 ^ 2 + 8 * y2 ^ 2 * e6 * x2 * e3 * e1 ^ 3 * x3 ^ 2 + 2 * y2 ^ 2 * e6 * x3 ^ 3 * e3 * e1 ^ 3 - 4 * y2 * e6 * e4 * y1 * x1 * e1 ^ 3 * x2 - 2 * y2 * e6 * e4 * y1 * x1 ^ 2 * e1 ^ 3 - 2 * y2 * e6 * e4 * y1 * x2 ^ 2 * e1 ^ 3 - 2 * y2 * e6 * e4 * y1 * e1 ^ 3 * x3 ^ 2 - 8 * y2 ^ 2 * e6 * e4 * y1 ^ 2 * x1 * e1 ^ 2 - 8 * y2 ^ 2 * e6 * e4 * y1 ^ 2 * x2 * e1 ^ 2 + 8 * y2 ^ 2 * e7 * x2 * e3 * e1 ^ 3 * x3 ^ 2 + 2 * y2 ^ 2 * e7 * x3 ^ 3 * e3 * e1 ^ 3 - 4 * y2 * e7 * e4 * y1 * x1 * e1 ^ 3 * x2 - 2 * y2 * e7 * e4 * y1 * x1 ^ 2 * e1 ^ 3 - 2 * y2 * e7 * e4 * y1 * x2 ^ 2 * e1 ^ 3 - 2 * y2 * e7 * e4 * y1 * e1 ^ 3 * x3 ^ 2 - 8 * y2 ^ 2 * e7 * e4 * y1 ^ 2 * x1 * e1 ^ 2 - 8 * y2 ^ 2 * e7 * e4 * y1 ^ 2 * x2 * e1 ^ 2 - 4 * y2 ^ 3 * e6 ^ 2 * y1 * e1 ^ 2 * x3 - 2 * y2 ^ 2 * e6 ^ 2 * x1 * e1 ^ 3 * x3 - 2 * y2 ^ 2 * e6 ^ 2 * x2 * e1 ^ 3 * x3 + 2 * y2 ^ 2 * e6 ^ 2 * e5 * e1 ^ 2 * x3 - 4 * y2 ^ 3 * e7 ^ 2 * y1 * e1 ^ 2 * x3 - 2 * y2 ^ 2 * e7 ^ 2 * x1 * e1 ^ 3 * x3 - 2 * y2 ^ 2 * e7 ^ 2 * x2 * e1 ^ 3 * x3 + 2 * y2 ^ 2 * e7 ^ 2 * e5 * e1 ^ 2 * x3 + 2 * y2 ^ 2 * e7 ^ 2 * e6 * e1 ^ 2 * x3 - 16 * y2 ^ 5 * y3 ^ 2 * y1 * e1 ^ 2 * x3 - 8 * y2 ^ 4 * y3 ^ 2 * x1 * e1 ^ 3 * x3 - 8 * y2 ^ 4 * y3 ^ 2 * x2 * e1 ^ 3 * x3 + 8 * y2 ^ 4 * y3 ^ 2 * e5 * e1 ^ 2 * x3 + 8 * y2 ^ 4 * y3 ^ 2 * e6 * e1 ^ 2 * x3 - 4 * y3 ^ 2 * e6 ^ 2 * y1 * y2 * e1 ^ 2 * x3 - 2 * y3 ^ 2 * e6 ^ 2 * x1 * e1 ^ 3 * x3 - 2 * y3 ^ 2 * e6 ^ 2 * x2 * e1 ^ 3 * x3 + 2 * y3 ^ 2 * e6 ^ 2 * e5 * x1 * e1 ^ 2 + 2 * y3 ^ 2 * e6 ^ 2 * e5 * x2 * e1 ^ 2 + 2 * y3 ^ 2 * e6 ^ 2 * e5 * e1 ^ 2 * x3 - 4 * y3 ^ 2 * e7 ^ 2 * y1 * y2 * e1 ^ 2 * x3 - 2 * y3 ^ 2 * e7 ^ 2 * x1 * e1 ^ 3 * x3 - 2 * y3 ^ 2 * e7 ^ 2 * x2 * e1 ^ 3 * x3 + 2 * y3 ^ 2 * e7 ^ 2 * e5 * x1 * e1 ^ 2 + 2 * y3 ^ 2 * e7 ^ 2 * e5 * x2 * e1 ^ 2 + 2 * y3 ^ 2 * e7 ^ 2 * e5 * e1 ^ 2 * x3 + 2 * y3 ^ 2 * e7 ^ 2 * e6 * x1 * e1 ^ 2 + 2 * y3 ^ 2 * e7 ^ 2 * e6 * x2 * e1 ^ 2 + 2 * y3 ^ 2 * e7 ^ 2 * e6 * e1 ^ 2 * x3 - 16 * y2 ^ 3 * y3 ^ 4 * y1 * e1 ^ 2 * x3 - 8 * y2 ^ 2 * y3 ^ 4 * x1 * e1 ^ 3 * x3 - 8 * y2 ^ 2 * y3 ^ 4 * x2 * e1 ^ 3 * x3 + 8 * y2 ^ 2 * y3 ^ 4 * e5 * x1 * e1 ^ 2 + 8 * y2 ^ 2 * y3 ^ 4 * e5 * x2 * e1 ^ 2 + 8 * y2 ^ 2 * y3 ^ 4 * e5 * e1 ^ 2 * x3 + 8 * y2 ^ 2 * y3 ^ 4 * e6 * x1 * e1 ^ 2 + 8 * y2 ^ 2 * y3 ^ 4 * e6 * x2 * e1 ^ 2 + 8 * y2 ^ 2 * y3 ^ 4 * e6 * e1 ^ 2 * x3 - 4 * e4 ^ 2 * y2 ^ 3 * y1 * e1 ^ 2 * x3 - 2 * e4 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 * x3 - 2 * e4 ^ 2 * y2 ^ 2 * x2 * e1 ^ 3 * x3 + 2 * e4 ^ 2 * y2 ^ 2 * e5 * x1 * e1 ^ 2 + 2 * e4 ^ 2 * y2 ^ 2 * e5 * x2 * e1 ^ 2 + 2 * e4 ^ 2 * y2 ^ 2 * e5 * e1 ^ 2 * x3 + 2 * e4 ^ 2 * y2 ^ 2 * e6 * x1 * e1 ^ 2 + 2 * e4 ^ 2 * y2 ^ 2 * e6 * x2 * e1 ^ 2 + 2 * e4 ^ 2 * y2 ^ 2 * e6 * e1 ^ 2 * x3 - 4 * e4 ^ 2 * y1 ^ 3 * y2 * e1 ^ 2 * x3 - 2 * e4 ^ 2 * y1 ^ 2 * x1 * e1 ^ 3 * x3 - 2 * e4 ^ 2 * y1 ^ 2 * x2 * e1 ^ 3 * x3 + 2 * e4 ^ 2 * y1 ^ 2 * e5 * x1 * e1 ^ 2 + 2 * e4 ^ 2 * y1 ^ 2 * e5 * x2 * e1 ^ 2 + 2 * e4 ^ 2 * y1 ^ 2 * e5 * e1 ^ 2 * x3 + 2 * e4 ^ 2 * y1 ^ 2 * e6 * x1 * e1 ^ 2 + 2 * e4 ^ 2 * y1 ^ 2 * e6 * x2 * e1 ^ 2 + 2 * e4 ^ 2 * y1 ^ 2 * e6 * e1 ^ 2 * x3 - 8 * y2 ^ 3 * e6 * e7 * y1 * e1 ^ 2 * x3 - 4 * y2 ^ 2 * e6 * e7 * x1 * e1 ^ 3 * x3 - 4 * y2 ^ 2 * e6 * e7 * x2 * e1 ^ 3 * x3 + 4 * y2 ^ 2 * e6 * e7 * e5 * e1 ^ 2 * x3 + 4 * y2 ^ 2 * e6 ^ 2 * e7 * e1 ^ 2 * x3 + 16 * y2 ^ 4 * e6 * y3 * y1 * e1 ^ 2 * x3 + 8 * y2 ^ 3 * e6 * y3 * x1 * e1 ^ 3 * x3 + 8 * y2 ^ 3 * e6 * y3 * x2 * e1 ^ 3 * x3 - 8 * y2 ^ 3 * e6 * y3 * e5 * e1 ^ 2 * x3 - 8 * y2 ^ 3 * e6 ^ 2 * y3 * e1 ^ 2 * x3 - 8 * y2 ^ 3 * e6 * e4 * y1 * e1 ^ 2 * x3 - 4 * y2 ^ 2 * e6 * e4 * x1 * e1 ^ 3 * x3 - 4 * y2 ^ 2 * e6 * e4 * x2 * e1 ^ 3 * x3 + 4 * y2 ^ 2 * e6 * e4 * e5 * x1 * e1 ^ 2 + 4 * y2 ^ 2 * e6 * e4 * e5 * x2 * e1 ^ 2 + 4 * y2 ^ 2 * e6 * e4 * e5 * e1 ^ 2 * x3 + 4 * y2 ^ 2 * e6 ^ 2 * e4 * x1 * e1 ^ 2 + 4 * y2 ^ 2 * e6 ^ 2 * e4 * x2 * e1 ^ 2 + 4 * y2 ^ 2 * e6 ^ 2 * e4 * e1 ^ 2 * x3 + 16 * y2 ^ 4 * e7 * y3 * y1 * e1 ^ 2 * x3 + 8 * y2 ^ 3 * e7 * y3 * x1 * e1 ^ 3 * x3 + 8 * y2 ^ 3 * e7 * y3 * x2 * e1 ^ 3 * x3 - 8 * y2 ^ 3 * e7 * y3 * e5 * e1 ^ 2 * x3 - 8 * y2 ^ 3 * e7 * y3 * e6 * e1 ^ 2 * x3 - 16 * y2 ^ 2 * e7 ^ 2 * y3 * y1 * e1 ^ 2 * x3 - 8 * y2 * e7 ^ 2 * y3 * x1 * e1 ^ 3 * x3 - 8 * y2 * e7 ^ 2 * y3 * x2 * e1 ^ 3 * x3 + 8 * y2 * e7 ^ 2 * y3 * e5 * x1 * e1 ^ 2 + 8 * y2 * e7 ^ 2 * y3 * e5 * x2 * e1 ^ 2 + 8 * y2 * e7 ^ 2 * y3 * e5 * e1 ^ 2 * x3 + 8 * y2 * e7 ^ 2 * y3 * e6 * x1 * e1 ^ 2 + 8 * y2 * e7 ^ 2 * y3 * e6 * x2 * e1 ^ 2 + 8 * y2 * e7 ^ 2 * y3 * e6 * e1 ^ 2 * x3 + 16 * y2 ^ 3 * e7 * y3 ^ 2 * y1 * e1 ^ 2 * x3 + 8 * y2 ^ 2 * e7 * y3 ^ 2 * x1 * e1 ^ 3 * x3 + 8 * y2 ^ 2 * e7 * y3 ^ 2 * x2 * e1 ^ 3 * x3 - 8 * y2 ^ 2 * e7 * y3 ^ 2 * e5 * x1 * e1 ^ 2 - 8 * y2 ^ 2 * e7 * y3 ^ 2 * e5 * x2 * e1 ^ 2 - 8 * y2 ^ 2 * e7 * y3 ^ 2 * e5 * e1 ^ 2 * x3 - 8 * y2 ^ 2 * e7 * y3 ^ 2 * e6 * x1 * e1 ^ 2 - 8 * y2 ^ 2 * e7 * y3 ^ 2 * e6 * x2 * e1 ^ 2 - 8 * y2 ^ 2 * e7 * y3 ^ 2 * e6 * e1 ^ 2 * x3 - 8 * y2 ^ 3 * e7 * e4 * y1 * e1 ^ 2 * x3 - 4 * y2 ^ 2 * e7 * e4 * x1 * e1 ^ 3 * x3 - 4 * y2 ^ 2 * e7 * e4 * x2 * e1 ^ 3 * x3 + 4 * y2 ^ 2 * e7 * e4 * e5 * x1 * e1 ^ 2 + 4 * y2 ^ 2 * e7 * e4 * e5 * x2 * e1 ^ 2 + 4 * y2 ^ 2 * e7 * e4 * e5 * e1 ^ 2 * x3 + 4 * y2 ^ 2 * e7 * e4 * e6 * x1 * e1 ^ 2 + 4 * y2 ^ 2 * e7 * e4 * e6 * x2 * e1 ^ 2 + 4 * y2 ^ 2 * e7 * e4 * e6 * e1 ^ 2 * x3 + 16 * y2 ^ 4 * y3 * e4 * y1 * e1 ^ 2 * x3 + 8 * y2 ^ 3 * y3 * e4 * x1 * e1 ^ 3 * x3 + 8 * y2 ^ 3 * y3 * e4 * x2 * e1 ^ 3 * x3 - 8 * y2 ^ 3 * y3 * e4 * e5 * x1 * e1 ^ 2 - 8 * y2 ^ 3 * y3 * e4 * e5 * x2 * e1 ^ 2 - 8 * y2 ^ 3 * y3 * e4 * e5 * e1 ^ 2 * x3 - 8 * y2 ^ 3 * y3 * e4 * e6 * x1 * e1 ^ 2 - 8 * y2 ^ 3 * y3 * e4 * e6 * x2 * e1 ^ 2 - 8 * y2 ^ 3 * y3 * e4 * e6 * e1 ^ 2 * x3 - 4 * y2 ^ 3 * x3 ^ 3 * e3 ^ 2 * y1 * e1 ^ 2 - 2 * y2 ^ 2 * x3 ^ 3 * e3 ^ 2 * x1 * e1 ^ 3 - 6 * y2 ^ 2 * x3 ^ 3 * e3 ^ 2 * x2 * e1 ^ 3 + 2 * y2 ^ 2 * x3 ^ 3 * e3 ^ 2 * e5 * e1 ^ 2 + 2 * y2 ^ 2 * x3 ^ 3 * e3 ^ 2 * e6 * e1 ^ 2 - 8 * y3 ^ 2 * e6 * e7 * y1 * y2 * e1 ^ 2 * x3 - 4 * y3 ^ 2 * e6 * e7 * x1 * e1 ^ 3 * x3 - 4 * y3 ^ 2 * e6 * e7 * x2 * e1 ^ 3 * x3 + 4 * y3 ^ 2 * e6 * e7 * e5 * x1 * e1 ^ 2 + 4 * y3 ^ 2 * e6 * e7 * e5 * x2 * e1 ^ 2 + 4 * y3 ^ 2 * e6 * e7 * e5 * e1 ^ 2 * x3 + 4 * y3 ^ 2 * e6 ^ 2 * e7 * x1 * e1 ^ 2 + 4 * y3 ^ 2 * e6 ^ 2 * e7 * x2 * e1 ^ 2 + 4 * y3 ^ 2 * e6 ^ 2 * e7 * e1 ^ 2 * x3 + 16 * y3 ^ 3 * e6 * y2 ^ 2 * y1 * e1 ^ 2 * x3 + 8 * y3 ^ 3 * e6 * y2 * x1 * e1 ^ 3 * x3 + 8 * y3 ^ 3 * e6 * y2 * x2 * e1 ^ 3 * x3 - 8 * y3 ^ 3 * e6 * y2 * e5 * x1 * e1 ^ 2 - 8 * y3 ^ 3 * e6 * y2 * e5 * x2 * e1 ^ 2 - 8 * y3 ^ 3 * e6 * y2 * e5 * e1 ^ 2 * x3 - 8 * y3 ^ 3 * e6 ^ 2 * y2 * x1 * e1 ^ 2 - 8 * y3 ^ 3 * e6 ^ 2 * y2 * x2 * e1 ^ 2 - 8 * y3 ^ 3 * e6 ^ 2 * y2 * e1 ^ 2 * x3 + 16 * y3 ^ 3 * e7 * y2 ^ 2 * y1 * e1 ^ 2 * x3 + 8 * y3 ^ 3 * e7 * y2 * x1 * e1 ^ 3 * x3 + 8 * y3 ^ 3 * e7 * y2 * x2 * e1 ^ 3 * x3 - 8 * y3 ^ 3 * e7 * y2 * e5 * x1 * e1 ^ 2 - 8 * y3 ^ 3 * e7 * y2 * e5 * x2 * e1 ^ 2 - 8 * y3 ^ 3 * e7 * y2 * e5 * e1 ^ 2 * x3 - 8 * y3 ^ 3 * e7 * y2 * e6 * x1 * e1 ^ 2 - 8 * y3 ^ 3 * e7 * y2 * e6 * x2 * e1 ^ 2 - 8 * y3 ^ 3 * e7 * y2 * e6 * e1 ^ 2 * x3 - 16 * y2 ^ 3 * y3 ^ 2 * e4 * y1 * e1 ^ 2 * x3 - 8 * y2 ^ 2 * y3 ^ 2 * e4 * x1 * e1 ^ 3 * x3 - 8 * y2 ^ 2 * y3 ^ 2 * e4 * x2 * e1 ^ 3 * x3 + 8 * y2 ^ 2 * y3 ^ 2 * e4 * e5 * x1 * e1 ^ 2 + 8 * y2 ^ 2 * y3 ^ 2 * e4 * e5 * x2 * e1 ^ 2 + 8 * y2 ^ 2 * y3 ^ 2 * e4 * e5 * e1 ^ 2 * x3 + 8 * y2 ^ 2 * y3 ^ 2 * e4 * e6 * x1 * e1 ^ 2 + 8 * y2 ^ 2 * y3 ^ 2 * e4 * e6 * x2 * e1 ^ 2 + 8 * y2 ^ 2 * y3 ^ 2 * e4 * e6 * e1 ^ 2 * x3 - 32 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 * y2 * e1 ^ 2 * x3 - 16 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * x1 * e1 ^ 3 * x3 - 12 * y3 ^ 2 * x2 ^ 3 * e3 ^ 2 * e1 ^ 3 * x3 + 8 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e5 * x1 * e1 ^ 2 + 8 * y3 ^ 2 * x2 ^ 3 * e3 ^ 2 * e5 * e1 ^ 2 + 16 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e5 * e1 ^ 2 * x3 + 8 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e6 * x1 * e1 ^ 2 + 8 * y3 ^ 2 * x2 ^ 3 * e3 ^ 2 * e6 * e1 ^ 2 + 16 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e6 * e1 ^ 2 * x3 - 4 * y3 ^ 2 * x3 ^ 3 * e3 ^ 2 * y1 * y2 * e1 ^ 2 - 2 * y3 ^ 2 * x3 ^ 3 * e3 ^ 2 * x1 * e1 ^ 3 - 6 * y3 ^ 2 * x3 ^ 3 * e3 ^ 2 * x2 * e1 ^ 3 + 2 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e5 * x1 * e1 ^ 2 + 10 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e5 * x2 * e1 ^ 2 + 2 * y3 ^ 2 * x3 ^ 3 * e3 ^ 2 * e5 * e1 ^ 2 + 2 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e6 * x1 * e1 ^ 2 + 10 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e6 * x2 * e1 ^ 2 + 2 * y3 ^ 2 * x3 ^ 3 * e3 ^ 2 * e6 * e1 ^ 2 + 8 * y2 ^ 3 * e6 * x3 ^ 2 * e3 * y1 * e1 ^ 2 + 4 * y2 ^ 2 * e6 * x3 ^ 2 * e3 * x1 * e1 ^ 3 - 4 * y2 ^ 2 * e6 * x3 ^ 2 * e3 * e5 * e1 ^ 2 - 4 * y2 ^ 2 * e6 ^ 2 * x3 ^ 2 * e3 * e1 ^ 2 - 8 * y2 ^ 2 * e6 * e4 * y1 ^ 2 * e1 ^ 2 * x3 - 4 * y2 * e6 * e4 * y1 * x1 * e1 ^ 3 * x3 - 4 * y2 * e6 * e4 * y1 * x2 * e1 ^ 3 * x3 + 4 * y2 * e6 * e4 * y1 * e5 * x1 * e1 ^ 2 + 4 * y2 * e6 * e4 * y1 * e5 * x2 * e1 ^ 2 + 4 * y2 * e6 * e4 * y1 * e5 * e1 ^ 2 * x3 + 4 * y2 * e6 ^ 2 * e4 * y1 * x1 * e1 ^ 2 + 4 * y2 * e6 ^ 2 * e4 * y1 * x2 * e1 ^ 2 + 4 * y2 * e6 ^ 2 * e4 * y1 * e1 ^ 2 * x3 + 8 * y2 ^ 3 * e7 * x3 ^ 2 * e3 * y1 * e1 ^ 2 + 4 * y2 ^ 2 * e7 * x3 ^ 2 * e3 * x1 * e1 ^ 3 - 4 * y2 ^ 2 * e7 * x3 ^ 2 * e3 * e5 * e1 ^ 2 - 4 * y2 ^ 2 * e7 * x3 ^ 2 * e3 * e6 * e1 ^ 2 - 8 * y2 ^ 2 * e7 * e4 * y1 ^ 2 * e1 ^ 2 * x3 - 4 * y2 * e7 * e4 * y1 * x1 * e1 ^ 3 * x3 - 4 * y2 * e7 * e4 * y1 * x2 * e1 ^ 3 * x3 + 4 * y2 * e7 * e4 * y1 * e5 * x1 * e1 ^ 2 + 4 * y2 * e7 * e4 * y1 * e5 * x2 * e1 ^ 2 + 4 * y2 * e7 * e4 * y1 * e5 * e1 ^ 2 * x3 + 4 * y2 * e7 * e4 * y1 * e6 * x1 * e1 ^ 2 + 4 * y2 * e7 * e4 * y1 * e6 * x2 * e1 ^ 2 + 4 * y2 * e7 * e4 * y1 * e6 * e1 ^ 2 * x3 - 16 * y2 ^ 3 * y3 * x2 * e3 * e1 ^ 3 * x3 ^ 2 - 4 * y2 ^ 3 * y3 * x3 ^ 3 * e3 * e1 ^ 3 + 8 * y2 ^ 2 * y3 * e4 * y1 * x1 * e1 ^ 3 * x2 + 4 * y2 ^ 2 * y3 * e4 * y1 * x1 ^ 2 * e1 ^ 3 + 4 * y2 ^ 2 * y3 * e4 * y1 * x2 ^ 2 * e1 ^ 3 + 4 * y2 ^ 2 * y3 * e4 * y1 * e1 ^ 3 * x3 ^ 2 + 16 * y2 ^ 3 * y3 * e4 * y1 ^ 2 * x1 * e1 ^ 2 + 16 * y2 ^ 3 * y3 * e4 * y1 ^ 2 * x2 * e1 ^ 2 + 8 * y2 ^ 2 * x2 ^ 2 * e3 * e4 * x1 * e1 ^ 3 + 4 * y2 ^ 2 * x2 * e3 * e4 * x1 ^ 2 * e1 ^ 3 + 4 * y2 ^ 2 * x2 ^ 3 * e3 * e4 * e1 ^ 3 + 8 * y2 ^ 2 * x2 * e3 * e4 * e1 ^ 3 * x3 ^ 2 + 16 * y2 ^ 3 * x2 * e3 * e4 * y1 * x1 * e1 ^ 2 + 16 * y2 ^ 3 * x2 ^ 2 * e3 * e4 * y1 * e1 ^ 2 + 8 * y2 * x2 ^ 2 * e3 * e4 * y1 * x1 * e1 ^ 3 + 4 * y2 * x2 * e3 * e4 * y1 * x1 ^ 2 * e1 ^ 3 + 4 * y2 * x2 ^ 3 * e3 * e4 * y1 * e1 ^ 3 + 8 * y2 * x2 * e3 * e4 * y1 * e1 ^ 3 * x3 ^ 2 + 16 * y2 ^ 2 * x2 * e3 * e4 * y1 ^ 2 * x1 * e1 ^ 2 + 16 * y2 ^ 2 * x2 ^ 2 * e3 * e4 * y1 ^ 2 * e1 ^ 2 + 12 * y2 ^ 2 * x3 * e3 * e4 * x1 * e1 ^ 3 * x2 + 2 * y2 ^ 2 * x3 * e3 * e4 * x1 ^ 2 * e1 ^ 3 + 10 * y2 ^ 2 * x3 * e3 * e4 * x2 ^ 2 * e1 ^ 3 + 2 * y2 ^ 2 * x3 ^ 3 * e3 * e4 * e1 ^ 3 + 8 * y2 ^ 3 * x3 * e3 * e4 * y1 * x1 * e1 ^ 2 + 24 * y2 ^ 3 * x3 * e3 * e4 * y1 * x2 * e1 ^ 2 + 8 * y3 ^ 2 * e6 * x2 ^ 2 * e3 * x1 * e1 ^ 3 + 4 * y3 ^ 2 * e6 * x2 * e3 * x1 ^ 2 * e1 ^ 3 + 4 * y3 ^ 2 * e6 * x2 ^ 3 * e3 * e1 ^ 3 + 8 * y3 ^ 2 * e6 * x2 * e3 * e1 ^ 3 * x3 ^ 2 + 16 * y3 ^ 2 * e6 * x2 * e3 * y1 * y2 * x1 * e1 ^ 2 + 16 * y3 ^ 2 * e6 * x2 ^ 2 * e3 * y1 * y2 * e1 ^ 2 + 12 * y3 ^ 2 * e6 * x3 * e3 * x1 * e1 ^ 3 * x2 + 2 * y3 ^ 2 * e6 * x3 * e3 * x1 ^ 2 * e1 ^ 3 + 10 * y3 ^ 2 * e6 * x3 * e3 * x2 ^ 2 * e1 ^ 3 + 2 * y3 ^ 2 * e6 * x3 ^ 3 * e3 * e1 ^ 3 + 8 * y3 ^ 2 * e6 * x3 * e3 * y1 * y2 * x1 * e1 ^ 2 + 24 * y3 ^ 2 * e6 * x3 * e3 * y1 * y2 * x2 * e1 ^ 2 + 4 * y3 * e6 * e4 * y2 * x1 * e1 ^ 3 * x2 + 2 * y3 * e6 * e4 * y2 * x1 ^ 2 * e1 ^ 3 + 2 * y3 * e6 * e4 * y2 * x2 ^ 2 * e1 ^ 3 + 2 * y3 * e6 * e4 * y2 * e1 ^ 3 * x3 ^ 2 + 4 * y3 * e6 * e4 * y1 * x1 * e1 ^ 3 * x2 + 2 * y3 * e6 * e4 * y1 * x1 ^ 2 * e1 ^ 3 + 2 * y3 * e6 * e4 * y1 * x2 ^ 2 * e1 ^ 3 + 2 * y3 * e6 * e4 * y1 * e1 ^ 3 * x3 ^ 2 + 8 * y3 * e6 * e4 * y1 ^ 2 * y2 * x1 * e1 ^ 2 + 8 * y3 * e6 * e4 * y1 ^ 2 * y2 * x2 * e1 ^ 2 + 8 * y3 ^ 2 * e7 * x2 ^ 2 * e3 * x1 * e1 ^ 3 + 4 * y3 ^ 2 * e7 * x2 * e3 * x1 ^ 2 * e1 ^ 3 + 4 * y3 ^ 2 * e7 * x2 ^ 3 * e3 * e1 ^ 3 + 8 * y3 ^ 2 * e7 * x2 * e3 * e1 ^ 3 * x3 ^ 2 + 16 * y3 ^ 2 * e7 * x2 * e3 * y1 * y2 * x1 * e1 ^ 2 + 16 * y3 ^ 2 * e7 * x2 ^ 2 * e3 * y1 * y2 * e1 ^ 2 + 12 * y3 ^ 2 * e7 * x3 * e3 * x1 * e1 ^ 3 * x2 + 2 * y3 ^ 2 * e7 * x3 * e3 * x1 ^ 2 * e1 ^ 3 + 10 * y3 ^ 2 * e7 * x3 * e3 * x2 ^ 2 * e1 ^ 3 + 2 * y3 ^ 2 * e7 * x3 ^ 3 * e3 * e1 ^ 3 + 8 * y3 ^ 2 * e7 * x3 * e3 * y1 * y2 * x1 * e1 ^ 2 + 24 * y3 ^ 2 * e7 * x3 * e3 * y1 * y2 * x2 * e1 ^ 2 + 4 * y3 * e7 * e4 * y2 * x1 * e1 ^ 3 * x2 + 2 * y3 * e7 * e4 * y2 * x1 ^ 2 * e1 ^ 3 + 2 * y3 * e7 * e4 * y2 * x2 ^ 2 * e1 ^ 3 + 2 * y3 * e7 * e4 * y2 * e1 ^ 3 * x3 ^ 2 + 8 * y3 * e7 * e4 * y2 ^ 2 * y1 * x1 * e1 ^ 2 + 8 * y3 * e7 * e4 * y2 ^ 2 * y1 * x2 * e1 ^ 2 + 4 * y3 * e7 * e4 * y1 * x1 * e1 ^ 3 * x2 + 2 * y3 * e7 * e4 * y1 * x1 ^ 2 * e1 ^ 3 + 2 * y3 * e7 * e4 * y1 * x2 ^ 2 * e1 ^ 3 + 2 * y3 * e7 * e4 * y1 * e1 ^ 3 * x3 ^ 2 + 8 * y3 * e7 * e4 * y1 ^ 2 * y2 * x1 * e1 ^ 2 + 8 * y3 * e7 * e4 * y1 ^ 2 * y2 * x2 * e1 ^ 2 - 16 * y2 * y3 ^ 3 * x2 ^ 2 * e3 * x1 * e1 ^ 3 - 8 * y2 * y3 ^ 3 * x2 * e3 * x1 ^ 2 * e1 ^ 3 - 8 * y2 * y3 ^ 3 * x2 ^ 3 * e3 * e1 ^ 3 - 16 * y2 * y3 ^ 3 * x2 * e3 * e1 ^ 3 * x3 ^ 2 - 32 * y2 ^ 2 * y3 ^ 3 * x2 * e3 * y1 * x1 * e1 ^ 2 - 32 * y2 ^ 2 * y3 ^ 3 * x2 ^ 2 * e3 * y1 * e1 ^ 2 - 24 * y2 * y3 ^ 3 * x3 * e3 * x1 * e1 ^ 3 * x2 - 4 * y2 * y3 ^ 3 * x3 * e3 * x1 ^ 2 * e1 ^ 3 - 20 * y2 * y3 ^ 3 * x3 * e3 * x2 ^ 2 * e1 ^ 3 - 4 * y2 * y3 ^ 3 * x3 ^ 3 * e3 * e1 ^ 3 - 16 * y2 ^ 2 * y3 ^ 3 * x3 * e3 * y1 * x1 * e1 ^ 2 - 48 * y2 ^ 2 * y3 ^ 3 * x3 * e3 * y1 * x2 * e1 ^ 2 - 8 * y2 * y3 ^ 2 * e4 * y1 * x1 * e1 ^ 3 * x2 - 4 * y2 * y3 ^ 2 * e4 * y1 * x1 ^ 2 * e1 ^ 3 - 4 * y2 * y3 ^ 2 * e4 * y1 * x2 ^ 2 * e1 ^ 3 - 4 * y2 * y3 ^ 2 * e4 * y1 * e1 ^ 3 * x3 ^ 2 - 16 * y2 ^ 2 * y3 ^ 2 * e4 * y1 ^ 2 * x1 * e1 ^ 2 - 16 * y2 ^ 2 * y3 ^ 2 * e4 * y1 ^ 2 * x2 * e1 ^ 2 - 4 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * x1 ^ 2 * e1 ^ 3 - 16 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * y1 * y2 * x1 * e1 ^ 2 + 12 * y2 * x3 * e3 * e4 * y1 * x1 * e1 ^ 3 * x2 + 2 * y2 * x3 * e3 * e4 * y1 * x1 ^ 2 * e1 ^ 3 + 10 * y2 * x3 * e3 * e4 * y1 * x2 ^ 2 * e1 ^ 3 + 2 * y2 * x3 ^ 3 * e3 * e4 * y1 * e1 ^ 3 + 8 * y2 ^ 2 * x3 * e3 * e4 * y1 ^ 2 * x1 * e1 ^ 2 + 24 * y2 ^ 2 * x3 * e3 * e4 * y1 ^ 2 * x2 * e1 ^ 2 - 8 * y3 * x2 ^ 2 * e3 * e4 * y2 * x1 * e1 ^ 3 - 4 * y3 * x2 * e3 * e4 * y2 * x1 ^ 2 * e1 ^ 3 - 4 * y3 * x2 ^ 3 * e3 * e4 * y2 * e1 ^ 3 - 8 * y3 * x2 * e3 * e4 * y2 * e1 ^ 3 * x3 ^ 2 - 16 * y3 * x2 * e3 * e4 * y2 ^ 2 * y1 * x1 * e1 ^ 2 - 16 * y3 * x2 ^ 2 * e3 * e4 * y2 ^ 2 * y1 * e1 ^ 2 - 8 * y3 * x2 ^ 2 * e3 * e4 * y1 * x1 * e1 ^ 3 - 4 * y3 * x2 * e3 * e4 * y1 * x1 ^ 2 * e1 ^ 3 - 4 * y3 * x2 ^ 3 * e3 * e4 * y1 * e1 ^ 3 - 8 * y3 * x2 * e3 * e4 * y1 * e1 ^ 3 * x3 ^ 2 - 16 * y3 * x2 * e3 * e4 * y1 ^ 2 * y2 * x1 * e1 ^ 2 - 16 * y3 * x2 ^ 2 * e3 * e4 * y1 ^ 2 * y2 * e1 ^ 2 - 12 * y3 * x3 * e3 * e4 * y2 * x1 * e1 ^ 3 * x2 - 2 * y3 * x3 * e3 * e4 * y2 * x1 ^ 2 * e1 ^ 3 - 10 * y3 * x3 * e3 * e4 * y2 * x2 ^ 2 * e1 ^ 3 - 2 * y3 * x3 ^ 3 * e3 * e4 * y2 * e1 ^ 3 - 8 * y3 * x3 * e3 * e4 * y2 ^ 2 * y1 * x1 * e1 ^ 2 - 24 * y3 * x3 * e3 * e4 * y2 ^ 2 * y1 * x2 * e1 ^ 2 - 12 * y3 * x3 * e3 * e4 * y1 * x1 * e1 ^ 3 * x2 - 2 * y3 * x3 * e3 * e4 * y1 * x1 ^ 2 * e1 ^ 3 - 10 * y3 * x3 * e3 * e4 * y1 * x2 ^ 2 * e1 ^ 3 - 2 * y3 * x3 ^ 3 * e3 * e4 * y1 * e1 ^ 3 - 8 * y3 * x3 * e3 * e4 * y1 ^ 2 * y2 * x1 * e1 ^ 2 - 24 * y3 * x3 * e3 * e4 * y1 ^ 2 * y2 * x2 * e1 ^ 2 - 4 * e4 ^ 2 * y2 * y1 * x1 * e1 ^ 3 * x2 - 2 * e4 ^ 2 * y2 * y1 * x1 ^ 2 * e1 ^ 3 - 2 * e4 ^ 2 * y2 * y1 * x2 ^ 2 * e1 ^ 3 - 2 * e4 ^ 2 * y2 * y1 * e1 ^ 3 * x3 ^ 2 - 8 * e4 ^ 2 * y2 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 - 8 * e4 ^ 2 * y2 ^ 2 * y1 ^ 2 * x2 * e1 ^ 2 - 16 * y2 ^ 4 * y3 * x3 ^ 2 * e3 * y1 * e1 ^ 2 - 8 * y2 ^ 3 * y3 * x3 ^ 2 * e3 * x1 * e1 ^ 3 + 8 * y2 ^ 3 * y3 * x3 ^ 2 * e3 * e5 * e1 ^ 2 + 8 * y2 ^ 3 * y3 * x3 ^ 2 * e3 * e6 * e1 ^ 2 + 16 * y2 ^ 3 * y3 * e4 * y1 ^ 2 * e1 ^ 2 * x3 + 8 * y2 ^ 2 * y3 * e4 * y1 * x1 * e1 ^ 3 * x3 + 8 * y2 ^ 2 * y3 * e4 * y1 * x2 * e1 ^ 3 * x3 - 8 * y2 ^ 2 * y3 * e4 * y1 * e5 * x1 * e1 ^ 2 - 8 * y2 ^ 2 * y3 * e4 * y1 * e5 * x2 * e1 ^ 2 - 8 * y2 ^ 2 * y3 * e4 * y1 * e5 * e1 ^ 2 * x3 - 8 * y2 ^ 2 * x2 * e3 * e4 * e5 * x1 * e1 ^ 2 - 8 * y2 ^ 2 * x2 ^ 2 * e3 * e4 * e5 * e1 ^ 2 - 12 * y2 ^ 2 * x2 * e3 * e4 * e5 * e1 ^ 2 * x3 - 8 * y2 ^ 2 * x2 * e3 * e4 * e6 * x1 * e1 ^ 2 - 8 * y2 ^ 2 * x2 ^ 2 * e3 * e4 * e6 * e1 ^ 2 - 12 * y2 ^ 2 * x2 * e3 * e4 * e6 * e1 ^ 2 * x3 - 8 * y2 * x2 * e3 * e4 * y1 * e5 * x1 * e1 ^ 2 - 8 * y2 * x2 ^ 2 * e3 * e4 * y1 * e5 * e1 ^ 2 - 12 * y2 * x2 * e3 * e4 * y1 * e5 * e1 ^ 2 * x3 - 8 * y2 * x2 * e3 * e4 * y1 * e6 * x1 * e1 ^ 2 - 8 * y2 * x2 ^ 2 * e3 * e4 * y1 * e6 * e1 ^ 2 - 12 * y2 * x2 * e3 * e4 * y1 * e6 * e1 ^ 2 * x3 + 8 * y2 ^ 3 * x3 ^ 2 * e3 * e4 * y1 * e1 ^ 2 + 4 * y2 ^ 2 * x3 ^ 2 * e3 * e4 * x1 * e1 ^ 3 - 4 * y2 ^ 2 * x3 * e3 * e4 * e5 * x1 * e1 ^ 2 - 4 * y2 ^ 2 * x3 ^ 2 * e3 * e4 * e5 * e1 ^ 2 - 4 * y2 ^ 2 * x3 * e3 * e4 * e6 * x1 * e1 ^ 2 - 4 * y2 ^ 2 * x3 ^ 2 * e3 * e4 * e6 * e1 ^ 2 - 8 * y3 ^ 2 * e6 * x2 * e3 * e5 * x1 * e1 ^ 2 - 8 * y3 ^ 2 * e6 * x2 ^ 2 * e3 * e5 * e1 ^ 2 - 12 * y3 ^ 2 * e6 * x2 * e3 * e5 * e1 ^ 2 * x3 - 8 * y3 ^ 2 * e6 ^ 2 * x2 * e3 * x1 * e1 ^ 2 - 8 * y3 ^ 2 * e6 ^ 2 * x2 ^ 2 * e3 * e1 ^ 2 - 12 * y3 ^ 2 * e6 ^ 2 * x2 * e3 * e1 ^ 2 * x3 + 8 * y3 ^ 2 * e6 * x3 ^ 2 * e3 * y1 * y2 * e1 ^ 2 + 4 * y3 ^ 2 * e6 * x3 ^ 2 * e3 * x1 * e1 ^ 3 - 4 * y3 ^ 2 * e6 * x3 * e3 * e5 * x1 * e1 ^ 2 - 4 * y3 ^ 2 * e6 * x3 ^ 2 * e3 * e5 * e1 ^ 2 - 4 * y3 ^ 2 * e6 ^ 2 * x3 * e3 * x1 * e1 ^ 2 - 4 * y3 ^ 2 * e6 ^ 2 * x3 ^ 2 * e3 * e1 ^ 2 + 4 * y3 * e6 * e4 * y2 * x1 * e1 ^ 3 * x3 + 4 * y3 * e6 * e4 * y2 * x2 * e1 ^ 3 * x3 - 4 * y3 * e6 * e4 * y2 * e5 * x1 * e1 ^ 2 - 4 * y3 * e6 * e4 * y2 * e5 * x2 * e1 ^ 2 - 4 * y3 * e6 * e4 * y2 * e5 * e1 ^ 2 * x3 - 4 * y3 * e6 ^ 2 * e4 * y2 * x1 * e1 ^ 2 - 4 * y3 * e6 ^ 2 * e4 * y2 * x2 * e1 ^ 2 - 4 * y3 * e6 ^ 2 * e4 * y2 * e1 ^ 2 * x3 + 8 * y3 * e6 * e4 * y1 ^ 2 * y2 * e1 ^ 2 * x3 + 4 * y3 * e6 * e4 * y1 * x1 * e1 ^ 3 * x3 + 4 * y3 * e6 * e4 * y1 * x2 * e1 ^ 3 * x3 - 4 * y3 * e6 * e4 * y1 * e5 * x1 * e1 ^ 2 - 4 * y3 * e6 * e4 * y1 * e5 * x2 * e1 ^ 2 - 4 * y3 * e6 * e4 * y1 * e5 * e1 ^ 2 * x3 - 4 * y3 * e6 ^ 2 * e4 * y1 * x1 * e1 ^ 2 - 4 * y3 * e6 ^ 2 * e4 * y1 * x2 * e1 ^ 2 - 4 * y3 * e6 ^ 2 * e4 * y1 * e1 ^ 2 * x3 - 8 * y3 ^ 2 * e7 * x2 * e3 * e5 * x1 * e1 ^ 2 - 8 * y3 ^ 2 * e7 * x2 ^ 2 * e3 * e5 * e1 ^ 2 - 12 * y3 ^ 2 * e7 * x2 * e3 * e5 * e1 ^ 2 * x3 - 8 * y3 ^ 2 * e7 * x2 * e3 * e6 * x1 * e1 ^ 2 - 8 * y3 ^ 2 * e7 * x2 ^ 2 * e3 * e6 * e1 ^ 2 - 12 * y3 ^ 2 * e7 * x2 * e3 * e6 * e1 ^ 2 * x3 + 8 * y3 ^ 2 * e7 * x3 ^ 2 * e3 * y1 * y2 * e1 ^ 2 + 4 * y3 ^ 2 * e7 * x3 ^ 2 * e3 * x1 * e1 ^ 3 - 4 * y3 ^ 2 * e7 * x3 * e3 * e5 * x1 * e1 ^ 2 - 4 * y3 ^ 2 * e7 * x3 ^ 2 * e3 * e5 * e1 ^ 2 - 4 * y3 ^ 2 * e7 * x3 * e3 * e6 * x1 * e1 ^ 2 - 4 * y3 ^ 2 * e7 * x3 ^ 2 * e3 * e6 * e1 ^ 2 + 8 * y3 * e7 * e4 * y2 ^ 2 * y1 * e1 ^ 2 * x3 + 4 * y3 * e7 * e4 * y2 * x1 * e1 ^ 3 * x3 + 4 * y3 * e7 * e4 * y2 * x2 * e1 ^ 3 * x3 - 4 * y3 * e7 * e4 * y2 * e5 * x1 * e1 ^ 2 - 4 * y3 * e7 * e4 * y2 * e5 * x2 * e1 ^ 2 - 4 * y3 * e7 * e4 * y2 * e5 * e1 ^ 2 * x3 - 4 * y3 * e7 * e4 * y2 * e6 * x1 * e1 ^ 2 - 4 * y3 * e7 * e4 * y2 * e6 * x2 * e1 ^ 2 - 4 * y3 * e7 * e4 * y2 * e6 * e1 ^ 2 * x3 + 8 * y3 * e7 * e4 * y1 ^ 2 * y2 * e1 ^ 2 * x3 + 4 * y3 * e7 * e4 * y1 * x1 * e1 ^ 3 * x3 + 4 * y3 * e7 * e4 * y1 * x2 * e1 ^ 3 * x3 - 4 * y3 * e7 * e4 * y1 * e5 * x1 * e1 ^ 2 - 4 * y3 * e7 * e4 * y1 * e5 * x2 * e1 ^ 2 - 4 * y3 * e7 * e4 * y1 * e5 * e1 ^ 2 * x3 - 4 * y3 * e7 * e4 * y1 * e6 * x1 * e1 ^ 2 - 4 * y3 * e7 * e4 * y1 * e6 * x2 * e1 ^ 2 - 4 * y3 * e7 * e4 * y1 * e6 * e1 ^ 2 * x3 + 16 * y2 * y3 ^ 3 * x2 * e3 * e5 * x1 * e1 ^ 2 + 16 * y2 * y3 ^ 3 * x2 ^ 2 * e3 * e5 * e1 ^ 2 + 24 * y2 * y3 ^ 3 * x2 * e3 * e5 * e1 ^ 2 * x3 + 16 * y2 * y3 ^ 3 * x2 * e3 * e6 * x1 * e1 ^ 2 + 16 * y2 * y3 ^ 3 * x2 ^ 2 * e3 * e6 * e1 ^ 2 + 24 * y2 * y3 ^ 3 * x2 * e3 * e6 * e1 ^ 2 * x3 - 16 * y2 ^ 2 * y3 ^ 3 * x3 ^ 2 * e3 * y1 * e1 ^ 2 - 8 * y2 * y3 ^ 3 * x3 ^ 2 * e3 * x1 * e1 ^ 3 + 8 * y2 * y3 ^ 3 * x3 * e3 * e5 * x1 * e1 ^ 2 + 8 * y2 * y3 ^ 3 * x3 ^ 2 * e3 * e5 * e1 ^ 2 + 8 * y2 * y3 ^ 3 * x3 * e3 * e6 * x1 * e1 ^ 2 + 8 * y2 * y3 ^ 3 * x3 ^ 2 * e3 * e6 * e1 ^ 2 - 16 * y2 ^ 2 * y3 ^ 2 * e4 * y1 ^ 2 * e1 ^ 2 * x3 - 8 * y2 * y3 ^ 2 * e4 * y1 * x1 * e1 ^ 3 * x3 - 8 * y2 * y3 ^ 2 * e4 * y1 * x2 * e1 ^ 3 * x3 + 8 * y2 * y3 ^ 2 * e4 * y1 * e5 * x1 * e1 ^ 2 + 8 * y2 * y3 ^ 2 * e4 * y1 * e5 * x2 * e1 ^ 2 + 8 * y2 * y3 ^ 2 * e4 * y1 * e5 * e1 ^ 2 * x3 + 8 * y2 * y3 ^ 2 * e4 * y1 * e6 * x1 * e1 ^ 2 + 8 * y2 * y3 ^ 2 * e4 * y1 * e6 * x2 * e1 ^ 2 + 8 * y2 * y3 ^ 2 * e4 * y1 * e6 * e1 ^ 2 * x3 + 8 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e5 * x1 * e1 ^ 2 + 8 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e6 * x1 * e1 ^ 2 + 8 * y2 ^ 2 * x3 ^ 2 * e3 * e4 * y1 ^ 2 * e1 ^ 2 + 4 * y2 * x3 ^ 2 * e3 * e4 * y1 * x1 * e1 ^ 3 - 4 * y2 * x3 * e3 * e4 * y1 * e5 * x1 * e1 ^ 2 - 4 * y2 * x3 ^ 2 * e3 * e4 * y1 * e5 * e1 ^ 2 - 4 * y2 * x3 * e3 * e4 * y1 * e6 * x1 * e1 ^ 2 - 4 * y2 * x3 ^ 2 * e3 * e4 * y1 * e6 * e1 ^ 2 + 8 * y3 * x2 * e3 * e4 * y2 * e5 * x1 * e1 ^ 2 + 8 * y3 * x2 ^ 2 * e3 * e4 * y2 * e5 * e1 ^ 2 + 12 * y3 * x2 * e3 * e4 * y2 * e5 * e1 ^ 2 * x3 + 8 * y3 * x2 * e3 * e4 * y2 * e6 * x1 * e1 ^ 2 + 8 * y3 * x2 ^ 2 * e3 * e4 * y2 * e6 * e1 ^ 2 + 12 * y3 * x2 * e3 * e4 * y2 * e6 * e1 ^ 2 * x3 + 8 * y3 * x2 * e3 * e4 * y1 * e5 * x1 * e1 ^ 2 + 8 * y3 * x2 ^ 2 * e3 * e4 * y1 * e5 * e1 ^ 2 + 12 * y3 * x2 * e3 * e4 * y1 * e5 * e1 ^ 2 * x3 + 8 * y3 * x2 * e3 * e4 * y1 * e6 * x1 * e1 ^ 2 + 8 * y3 * x2 ^ 2 * e3 * e4 * y1 * e6 * e1 ^ 2 + 12 * y3 * x2 * e3 * e4 * y1 * e6 * e1 ^ 2 * x3 - 8 * y3 * x3 ^ 2 * e3 * e4 * y2 ^ 2 * y1 * e1 ^ 2 - 4 * y3 * x3 ^ 2 * e3 * e4 * y2 * x1 * e1 ^ 3 + 4 * y3 * x3 * e3 * e4 * y2 * e5 * x1 * e1 ^ 2 + 4 * y3 * x3 ^ 2 * e3 * e4 * y2 * e5 * e1 ^ 2 + 4 * y3 * x3 * e3 * e4 * y2 * e6 * x1 * e1 ^ 2 + 4 * y3 * x3 ^ 2 * e3 * e4 * y2 * e6 * e1 ^ 2 - 8 * y3 * x3 ^ 2 * e3 * e4 * y1 ^ 2 * y2 * e1 ^ 2 - 4 * y3 * x3 ^ 2 * e3 * e4 * y1 * x1 * e1 ^ 3 + 4 * y3 * x3 * e3 * e4 * y1 * e5 * x1 * e1 ^ 2 + 4 * y3 * x3 ^ 2 * e3 * e4 * y1 * e5 * e1 ^ 2 + 4 * y3 * x3 * e3 * e4 * y1 * e6 * x1 * e1 ^ 2 + 4 * y3 * x3 ^ 2 * e3 * e4 * y1 * e6 * e1 ^ 2 - 8 * e4 ^ 2 * y2 ^ 2 * y1 ^ 2 * e1 ^ 2 * x3 - 4 * e4 ^ 2 * y2 * y1 * x1 * e1 ^ 3 * x3 - 4 * e4 ^ 2 * y2 * y1 * x2 * e1 ^ 3 * x3 + 4 * e4 ^ 2 * y2 * y1 * e5 * x1 * e1 ^ 2 + 4 * e4 ^ 2 * y2 * y1 * e5 * x2 * e1 ^ 2 + 4 * e4 ^ 2 * y2 * y1 * e5 * e1 ^ 2 * x3 + 4 * e4 ^ 2 * y2 * y1 * e6 * x1 * e1 ^ 2 + 4 * e4 ^ 2 * y2 * y1 * e6 * x2 * e1 ^ 2 + 4 * e4 ^ 2 * y2 * y1 * e6 * e1 ^ 2 * x3 + 4 * e1 * e6 ^ 2 * y2 ^ 3 * e5 * y1 - 4 * e1 * e6 ^ 2 * e7 * y2 ^ 2 * e5 + 8 * e1 * e6 ^ 2 * e7 * y2 ^ 3 * y1 + 32 * e1 * y2 ^ 4 * y3 * x2 * e3 * e5 * y1 - 8 * e1 * y2 ^ 3 * y3 * x3 * e3 * e5 * e6 + 16 * e1 * y2 ^ 4 * y3 * x3 * e3 * e5 * y1 + 16 * e1 * y2 ^ 4 * y3 * x3 * e3 * e6 * y1 + 8 * e1 * e6 * e7 * y2 ^ 3 * e5 * y1 - 2 * e1 * e7 ^ 2 * y2 ^ 2 * e5 * e6 + 4 * e1 * e7 ^ 2 * y2 ^ 3 * e5 * y1 + 4 * e1 * e7 ^ 2 * y2 ^ 3 * e6 * y1 - 16 * e1 * y2 ^ 3 * y3 ^ 2 * y1 * e6 ^ 2 + 16 * e1 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * e6 - 8 * e1 * y2 ^ 4 * y3 ^ 2 * e5 * e6 + 16 * e1 * y2 ^ 5 * y3 ^ 2 * e5 * y1 + 16 * e1 * y2 ^ 5 * y3 ^ 2 * e6 * y1 - 4 * e1 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e6 ^ 2 - 2 * e1 * e6 * e7 * y2 ^ 2 * e5 ^ 2 - 8 * e1 * e6 * e7 * y1 ^ 2 * y2 ^ 4 - 4 * e1 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 - 16 * e1 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 - e1 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 - e1 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e6 ^ 2 - 4 * e1 * x3 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 + 16 * e1 * e6 ^ 3 * y2 ^ 2 * y3 * y1 - 16 * e1 * e6 ^ 2 * y2 ^ 3 * y3 * y1 ^ 2 + 8 * e1 * e6 ^ 2 * y2 ^ 3 * y3 * e5 - 16 * e1 * y2 ^ 3 * y3 ^ 2 * y1 * e5 * e6 + 16 * e1 * x2 ^ 2 * e3 ^ 2 * y2 ^ 3 * e5 * y1 - 2 * e1 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * e6 + 4 * e1 * x3 ^ 2 * e3 ^ 2 * y2 ^ 3 * e5 * y1 + 4 * e1 * x3 ^ 2 * e3 ^ 2 * y2 ^ 3 * e6 * y1 - 8 * e1 * y2 ^ 3 * y3 * x2 * e3 * e5 ^ 2 - 32 * e1 * y2 ^ 5 * y3 * x2 * e3 * y1 ^ 2 - 4 * e1 * y2 ^ 3 * y3 * x3 * e3 * e5 ^ 2 - 4 * e1 * y2 ^ 3 * y3 * x3 * e3 * e6 ^ 2 - 16 * e1 * y2 ^ 5 * y3 * x3 * e3 * y1 ^ 2 - 4 * e1 * x2 * e3 ^ 2 * x3 * y2 ^ 2 * e5 ^ 2 + 16 * e1 * x2 * e3 ^ 2 * x3 * y2 ^ 3 * e5 * y1 + 16 * e1 * e6 ^ 2 * y2 ^ 2 * y3 * y1 * e5 - 16 * e1 * e6 * y2 ^ 4 * y3 * e5 * y1 - 16 * e1 * e6 ^ 2 * y2 ^ 4 * y3 * y1 + 4 * e1 * e6 * y2 ^ 3 * y3 * e5 ^ 2 + 16 * e1 * e6 * y2 ^ 5 * y3 * y1 ^ 2 + 2 * e1 * e6 ^ 3 * x3 * e3 * y2 ^ 2 + 4 * e1 * e7 * y2 ^ 3 * y3 * e5 ^ 2 + 4 * e1 * e7 * y2 ^ 3 * y3 * e6 ^ 2 + 16 * e1 * e7 * y2 ^ 5 * y3 * y1 ^ 2 - 16 * e1 * e6 * x2 * e3 * y2 ^ 3 * e5 * y1 + 4 * e1 * e6 ^ 2 * x3 * e3 * y2 ^ 2 * e5 - 8 * e1 * e6 * x3 * e3 * y2 ^ 3 * e5 * y1 - 8 * e1 * e6 ^ 2 * x3 * e3 * y2 ^ 3 * y1 + 32 * e1 * e7 * y2 ^ 2 * y3 * y1 * e5 * e6 + 32 * e1 * e7 * y2 ^ 2 * y3 * y1 * e6 ^ 2 - 32 * e1 * e7 * y2 ^ 3 * y3 * y1 ^ 2 * e6 + 8 * e1 * e7 * y2 ^ 3 * y3 * e5 * e6 - 16 * e1 * e7 * y2 ^ 4 * y3 * e5 * y1 - 16 * e1 * e7 * y2 ^ 4 * y3 * e6 * y1 - 16 * e1 * e7 * x2 * e3 * y2 ^ 3 * e5 * y1 + 4 * e1 * e7 * x3 * e3 * y2 ^ 2 * e5 * e6 - 8 * e1 * e7 * x3 * e3 * y2 ^ 3 * e5 * y1 - 8 * e1 * e7 * x3 * e3 * y2 ^ 3 * e6 * y1 - 16 * e1 * x2 * e3 ^ 2 * x3 * y1 ^ 2 * y2 ^ 4 + 4 * e1 * e6 * x2 * e3 * y2 ^ 2 * e5 ^ 2 + 16 * e1 * e6 * x2 * e3 * y1 ^ 2 * y2 ^ 4 + 2 * e1 * e6 * x3 * e3 * y2 ^ 2 * e5 ^ 2 + 8 * e1 * e6 * x3 * e3 * y1 ^ 2 * y2 ^ 4 + 4 * e1 * e7 * x2 * e3 * y2 ^ 2 * e5 ^ 2 + 16 * e1 * e7 * x2 * e3 * y1 ^ 2 * y2 ^ 4 + 2 * e1 * e7 * x3 * e3 * y2 ^ 2 * e5 ^ 2 + 2 * e1 * e7 * x3 * e3 * y2 ^ 2 * e6 ^ 2 + 8 * e1 * e7 * x3 * e3 * y1 ^ 2 * y2 ^ 4 - 8 * e1 * e6 ^ 3 * e7 * y2 * y3 - 4 * e1 * e5 ^ 2 * e6 ^ 2 * y2 * y3 + 4 * e1 * e5 ^ 2 * e6 * y2 ^ 2 * y3 ^ 2 + 8 * e1 * e5 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 - 8 * e1 * e5 * e6 ^ 3 * y2 * y3 - 16 * e1 * e6 ^ 2 * e7 * y2 * y3 * e5 - 8 * e1 * e5 ^ 2 * e7 * y2 * y3 * e6 - 2 * e1 * y3 ^ 2 * e7 ^ 2 * e5 * e6 - 4 * e1 * y3 ^ 2 * e7 ^ 2 * y1 ^ 2 * y2 ^ 2 - 8 * e1 * y2 ^ 2 * y3 ^ 4 * e5 * e6 - 2 * e1 * e4 ^ 2 * y2 ^ 2 * e5 * e6 - 2 * e1 * e4 ^ 2 * y1 ^ 2 * e5 * e6 - 16 * e1 * y2 ^ 4 * y3 ^ 4 * y1 ^ 2 - e1 * e4 ^ 2 * y2 ^ 2 * e6 ^ 2 - e1 * e4 ^ 2 * y2 ^ 2 * e5 ^ 2 - 4 * e1 * e4 ^ 2 * y2 ^ 4 * y1 ^ 2 - e1 * e4 ^ 2 * y1 ^ 2 * e6 ^ 2 - e1 * e4 ^ 2 * y1 ^ 2 * e5 ^ 2 - 4 * e1 * e4 ^ 2 * y1 ^ 4 * y2 ^ 2 - 2 * e1 * y2 ^ 2 * e6 ^ 3 * e4 - 2 * e1 * y3 ^ 2 * e6 ^ 3 * e7 + 4 * e1 * y3 ^ 3 * e6 ^ 3 * y2 - 2 * e1 * y2 ^ 2 * e6 * e4 * e5 ^ 2 - 4 * e1 * y2 ^ 2 * e6 ^ 2 * e4 * e5 - 8 * e1 * y2 ^ 4 * e6 * e4 * y1 ^ 2 - 4 * e1 * y2 * e7 ^ 2 * y3 * e6 ^ 2 - 4 * e1 * y2 * e7 ^ 2 * y3 * e5 ^ 2 - 16 * e1 * y2 ^ 3 * e7 ^ 2 * y3 * y1 ^ 2 + 4 * e1 * y2 ^ 2 * e7 * y3 ^ 2 * e6 ^ 2 + 4 * e1 * y2 ^ 2 * e7 * y3 ^ 2 * e5 ^ 2 + 16 * e1 * y2 ^ 4 * e7 * y3 ^ 2 * y1 ^ 2 - 2 * e1 * y2 ^ 2 * e7 * e4 * e6 ^ 2 - 2 * e1 * y2 ^ 2 * e7 * e4 * e5 ^ 2 - 8 * e1 * y2 ^ 4 * e7 * e4 * y1 ^ 2 + 4 * e1 * y2 ^ 3 * y3 * e4 * e6 ^ 2 + 4 * e1 * y2 ^ 3 * y3 * e4 * e5 ^ 2 + 16 * e1 * y2 ^ 5 * y3 * e4 * y1 ^ 2 - 2 * e1 * y3 ^ 2 * e6 * e7 * e5 ^ 2 - 4 * e1 * y3 ^ 2 * e6 ^ 2 * e7 * e5 + 4 * e1 * y3 ^ 3 * e6 * y2 * e5 ^ 2 + 8 * e1 * y3 ^ 3 * e6 ^ 2 * y2 * e5 + 16 * e1 * y3 ^ 3 * e6 * y2 ^ 3 * y1 ^ 2 + 4 * e1 * y3 ^ 3 * e7 * y2 * e6 ^ 2 + 4 * e1 * y3 ^ 3 * e7 * y2 * e5 ^ 2 + 16 * e1 * y3 ^ 3 * e7 * y2 ^ 3 * y1 ^ 2 - 4 * e1 * y2 ^ 2 * y3 ^ 2 * e4 * e6 ^ 2 - 4 * e1 * y2 ^ 2 * y3 ^ 2 * e4 * e5 ^ 2 - 16 * e1 * y2 ^ 4 * y3 ^ 2 * e4 * y1 ^ 2 - 4 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e6 ^ 2 - 4 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e5 ^ 2 - e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e6 ^ 2 - e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e5 ^ 2 - 2 * e1 * y2 * e6 ^ 3 * e4 * y1 - 8 * e1 * y2 ^ 3 * e6 * e4 * y1 ^ 3 - 8 * e1 * y2 ^ 3 * e7 * e4 * y1 ^ 3 + 4 * e1 * y3 ^ 2 * e6 ^ 3 * y1 * y2 + 16 * e1 * y2 ^ 3 * y3 ^ 4 * e5 * y1 + 16 * e1 * y2 ^ 3 * y3 ^ 4 * e6 * y1 + 4 * e1 * e4 ^ 2 * y2 ^ 3 * e5 * y1 - 8 * e1 * y2 * e7 ^ 2 * y3 * e5 * e6 + 8 * e1 * y2 ^ 2 * e7 * y3 ^ 2 * e5 * e6 - 4 * e1 * y2 ^ 2 * e7 * e4 * e5 * e6 + 8 * e1 * y2 ^ 3 * y3 * e4 * e5 * e6 - 8 * e1 * y3 ^ 2 * e6 * e7 * y1 ^ 2 * y2 ^ 2 + 8 * e1 * y3 ^ 3 * e7 * y2 * e5 * e6 - 8 * e1 * y2 ^ 2 * y3 ^ 2 * e4 * e5 * e6 - 8 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e5 * e6 - 16 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 - 2 * e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e5 * e6 - 4 * e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 - 2 * e1 * y2 * e6 * e4 * y1 * e5 ^ 2 - 4 * e1 * y2 * e6 ^ 2 * e4 * y1 * e5 - 2 * e1 * y2 * e7 * e4 * y1 * e6 ^ 2 - 2 * e1 * y2 * e7 * e4 * y1 * e5 ^ 2 - 4 * e1 * y2 * e7 * e4 * y1 * e5 * e6 + 4 * e1 * y3 ^ 2 * e6 ^ 2 * e5 * y1 * y2 + 4 * e1 * y3 ^ 2 * e7 ^ 2 * e5 * y1 * y2 + 4 * e1 * y3 ^ 2 * e7 ^ 2 * e6 * y1 * y2 + 4 * e1 * e4 ^ 2 * y2 ^ 3 * e6 * y1 + 4 * e1 * e4 ^ 2 * y1 ^ 3 * e5 * y2 + 4 * e1 * e4 ^ 2 * y1 ^ 3 * e6 * y2 + 8 * e1 * y2 ^ 3 * e6 ^ 2 * e4 * y1 - 16 * e1 * y3 ^ 3 * e6 ^ 2 * y2 ^ 2 * y1 + 8 * e1 * y2 ^ 2 * e6 ^ 2 * e4 * y1 ^ 2 + 16 * e1 * y2 ^ 4 * y3 * e4 * y1 ^ 3 + 4 * e1 * y3 ^ 2 * e6 ^ 3 * x2 * e3 + 2 * e1 * y3 ^ 2 * e6 ^ 3 * x3 * e3 + 2 * e1 * y3 * e6 ^ 3 * e4 * y2 + 2 * e1 * y3 * e6 ^ 3 * e4 * y1 - 2 * e1 * e4 ^ 2 * y2 * y1 * e6 ^ 2 - 2 * e1 * e4 ^ 2 * y2 * y1 * e5 ^ 2 + 8 * e1 * e4 ^ 2 * y2 ^ 2 * y1 ^ 2 * e5 + 8 * e1 * e4 ^ 2 * y2 ^ 2 * y1 ^ 2 * e6 + 8 * e1 * y2 ^ 3 * e6 * e4 * e5 * y1 + 16 * e1 * y2 ^ 2 * e7 ^ 2 * y3 * e5 * y1 + 16 * e1 * y2 ^ 2 * e7 ^ 2 * y3 * e6 * y1 - 16 * e1 * y2 ^ 3 * e7 * y3 ^ 2 * e5 * y1 - 16 * e1 * y2 ^ 3 * e7 * y3 ^ 2 * e6 * y1 + 8 * e1 * y2 ^ 3 * e7 * e4 * e5 * y1 + 8 * e1 * y2 ^ 3 * e7 * e4 * e6 * y1 - 16 * e1 * y2 ^ 4 * y3 * e4 * e5 * y1 - 16 * e1 * y2 ^ 4 * y3 * e4 * e6 * y1 + 8 * e1 * y3 ^ 2 * e6 * e7 * e5 * y1 * y2 + 8 * e1 * y3 ^ 2 * e6 ^ 2 * e7 * y1 * y2 - 16 * e1 * y3 ^ 3 * e6 * y2 ^ 2 * e5 * y1 - 16 * e1 * y3 ^ 3 * e7 * y2 ^ 2 * e5 * y1 - 16 * e1 * y3 ^ 3 * e7 * y2 ^ 2 * e6 * y1 + 16 * e1 * y2 ^ 3 * y3 ^ 2 * e4 * e5 * y1 + 16 * e1 * y2 ^ 3 * y3 ^ 2 * e4 * e6 * y1 + 16 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e5 * y1 * y2 + 16 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e6 * y1 * y2 + 4 * e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e5 * y1 * y2 + 4 * e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e6 * y1 * y2 + 8 * e1 * y2 ^ 2 * e6 * e4 * y1 ^ 2 * e5 + 8 * e1 * y2 ^ 2 * e7 * e4 * y1 ^ 2 * e5 + 8 * e1 * y2 ^ 2 * e7 * e4 * y1 ^ 2 * e6 - 4 * e1 * y2 ^ 2 * y3 * e4 * y1 * e6 ^ 2 + 4 * e1 * y2 ^ 2 * y3 * e4 * y1 * e5 ^ 2 + 4 * e1 * y2 ^ 2 * x2 * e3 * e4 * e6 ^ 2 + 4 * e1 * y2 ^ 2 * x2 * e3 * e4 * e5 ^ 2 + 8 * e1 * y2 ^ 2 * x2 * e3 * e4 * e5 * e6 + 16 * e1 * y2 ^ 4 * x2 * e3 * e4 * y1 ^ 2 + 4 * e1 * y2 * x2 * e3 * e4 * y1 * e6 ^ 2 + 4 * e1 * y2 * x2 * e3 * e4 * y1 * e5 ^ 2 + 8 * e1 * y2 * x2 * e3 * e4 * y1 * e5 * e6 + 16 * e1 * y2 ^ 3 * x2 * e3 * e4 * y1 ^ 3 + 2 * e1 * y2 ^ 2 * x3 * e3 * e4 * e6 ^ 2 + 2 * e1 * y2 ^ 2 * x3 * e3 * e4 * e5 ^ 2 + 4 * e1 * y2 ^ 2 * x3 * e3 * e4 * e5 * e6 + 8 * e1 * y2 ^ 4 * x3 * e3 * e4 * y1 ^ 2 + 4 * e1 * y3 ^ 2 * e6 * x2 * e3 * e5 ^ 2 + 8 * e1 * y3 ^ 2 * e6 ^ 2 * x2 * e3 * e5 + 2 * e1 * y3 ^ 2 * e6 * x3 * e3 * e5 ^ 2 + 4 * e1 * y3 ^ 2 * e6 ^ 2 * x3 * e3 * e5 + 8 * e1 * y3 ^ 2 * e6 * x3 * e3 * y1 ^ 2 * y2 ^ 2 + 2 * e1 * y3 * e6 * e4 * y2 * e5 ^ 2 + 4 * e1 * y3 * e6 ^ 2 * e4 * y2 * e5 - 8 * e1 * y3 * e6 * e4 * y2 ^ 3 * y1 ^ 2 + 2 * e1 * y3 * e6 * e4 * y1 * e5 ^ 2 + 4 * e1 * y3 * e6 ^ 2 * e4 * y1 * e5 + 8 * e1 * y3 * e6 * e4 * y1 ^ 3 * y2 ^ 2 + 4 * e1 * y3 ^ 2 * e7 * x2 * e3 * e6 ^ 2 + 4 * e1 * y3 ^ 2 * e7 * x2 * e3 * e5 ^ 2 + 8 * e1 * y3 ^ 2 * e7 * x2 * e3 * e5 * e6 + 16 * e1 * y3 ^ 2 * e7 * x2 * e3 * y1 ^ 2 * y2 ^ 2 + 2 * e1 * y3 ^ 2 * e7 * x3 * e3 * e6 ^ 2 + 2 * e1 * y3 ^ 2 * e7 * x3 * e3 * e5 ^ 2 + 4 * e1 * y3 ^ 2 * e7 * x3 * e3 * e5 * e6 + 8 * e1 * y3 ^ 2 * e7 * x3 * e3 * y1 ^ 2 * y2 ^ 2 + 2 * e1 * y3 * e7 * e4 * y2 * e6 ^ 2 + 2 * e1 * y3 * e7 * e4 * y2 * e5 ^ 2 + 4 * e1 * y3 * e7 * e4 * y2 * e5 * e6 + 8 * e1 * y3 * e7 * e4 * y2 ^ 3 * y1 ^ 2 + 2 * e1 * y3 * e7 * e4 * y1 * e6 ^ 2 + 2 * e1 * y3 * e7 * e4 * y1 * e5 ^ 2 + 4 * e1 * y3 * e7 * e4 * y1 * e5 * e6 + 8 * e1 * y3 * e7 * e4 * y1 ^ 3 * y2 ^ 2 - 8 * e1 * y2 * y3 ^ 3 * x2 * e3 * e6 ^ 2 - 8 * e1 * y2 * y3 ^ 3 * x2 * e3 * e5 ^ 2 - 16 * e1 * y2 * y3 ^ 3 * x2 * e3 * e5 * e6 - 32 * e1 * y2 ^ 3 * y3 ^ 3 * x2 * e3 * y1 ^ 2 - 4 * e1 * y2 * y3 ^ 3 * x3 * e3 * e6 ^ 2 - 4 * e1 * y2 * y3 ^ 3 * x3 * e3 * e5 ^ 2 - 8 * e1 * y2 * y3 ^ 3 * x3 * e3 * e5 * e6 - 16 * e1 * y2 ^ 3 * y3 ^ 3 * x3 * e3 * y1 ^ 2 - 4 * e1 * y2 * y3 ^ 2 * e4 * y1 * e6 ^ 2 - 4 * e1 * y2 * y3 ^ 2 * e4 * y1 * e5 ^ 2 - 8 * e1 * y2 * y3 ^ 2 * e4 * y1 * e5 * e6 - 4 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e6 ^ 2 - 4 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e5 ^ 2 - 8 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e5 * e6 - 16 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * y1 ^ 2 * y2 ^ 2 + 2 * e1 * y2 * x3 * e3 * e4 * y1 * e6 ^ 2 + 2 * e1 * y2 * x3 * e3 * e4 * y1 * e5 ^ 2 + 4 * e1 * y2 * x3 * e3 * e4 * y1 * e5 * e6 + 8 * e1 * y2 ^ 3 * x3 * e3 * e4 * y1 ^ 3 - 4 * e1 * y3 * x2 * e3 * e4 * y2 * e6 ^ 2 - 4 * e1 * y3 * x2 * e3 * e4 * y2 * e5 ^ 2 - 8 * e1 * y3 * x2 * e3 * e4 * y2 * e5 * e6 - 16 * e1 * y3 * x2 * e3 * e4 * y2 ^ 3 * y1 ^ 2 - 4 * e1 * y3 * x2 * e3 * e4 * y1 * e6 ^ 2 - 4 * e1 * y3 * x2 * e3 * e4 * y1 * e5 ^ 2 - 8 * e1 * y3 * x2 * e3 * e4 * y1 * e5 * e6 - 16 * e1 * y3 * x2 * e3 * e4 * y1 ^ 3 * y2 ^ 2 - 2 * e1 * y3 * x3 * e3 * e4 * y2 * e6 ^ 2 - 2 * e1 * y3 * x3 * e3 * e4 * y2 * e5 ^ 2 - 4 * e1 * y3 * x3 * e3 * e4 * y2 * e5 * e6 - 8 * e1 * y3 * x3 * e3 * e4 * y2 ^ 3 * y1 ^ 2 - 2 * e1 * y3 * x3 * e3 * e4 * y1 * e6 ^ 2 - 2 * e1 * y3 * x3 * e3 * e4 * y1 * e5 ^ 2 - 4 * e1 * y3 * x3 * e3 * e4 * y1 * e5 * e6 - 8 * e1 * y3 * x3 * e3 * e4 * y1 ^ 3 * y2 ^ 2 - 4 * e1 * e4 ^ 2 * y2 * y1 * e5 * e6 - 16 * e1 * y2 ^ 3 * y3 * e4 * y1 ^ 2 * e5 - 16 * e1 * y2 ^ 3 * x2 * e3 * e4 * e5 * y1 - 16 * e1 * y2 ^ 3 * x2 * e3 * e4 * e6 * y1 - 16 * e1 * y2 ^ 2 * x2 * e3 * e4 * y1 ^ 2 * e5 - 16 * e1 * y2 ^ 2 * x2 * e3 * e4 * y1 ^ 2 * e6 - 8 * e1 * y2 ^ 3 * x3 * e3 * e4 * e5 * y1 - 8 * e1 * y2 ^ 3 * x3 * e3 * e4 * e6 * y1 - 16 * e1 * y3 ^ 2 * e6 * x2 * e3 * e5 * y1 * y2 - 16 * e1 * y3 ^ 2 * e6 ^ 2 * x2 * e3 * y1 * y2 - 8 * e1 * y3 ^ 2 * e6 * x3 * e3 * e5 * y1 * y2 - 8 * e1 * y3 ^ 2 * e6 ^ 2 * x3 * e3 * y1 * y2 - 8 * e1 * y3 * e6 * e4 * y1 ^ 2 * e5 * y2 - 8 * e1 * y3 * e6 ^ 2 * e4 * y1 ^ 2 * y2 - 16 * e1 * y3 ^ 2 * e7 * x2 * e3 * e5 * y1 * y2 - 16 * e1 * y3 ^ 2 * e7 * x2 * e3 * e6 * y1 * y2 - 8 * e1 * y3 ^ 2 * e7 * x3 * e3 * e5 * y1 * y2 - 8 * e1 * y3 ^ 2 * e7 * x3 * e3 * e6 * y1 * y2 - 8 * e1 * y3 * e7 * e4 * y2 ^ 2 * e5 * y1 - 8 * e1 * y3 * e7 * e4 * y2 ^ 2 * e6 * y1 - 8 * e1 * y3 * e7 * e4 * y1 ^ 2 * e5 * y2 - 8 * e1 * y3 * e7 * e4 * y1 ^ 2 * e6 * y2 + 32 * e1 * y2 ^ 2 * y3 ^ 3 * x2 * e3 * e5 * y1 + 32 * e1 * y2 ^ 2 * y3 ^ 3 * x2 * e3 * e6 * y1 + 16 * e1 * y2 ^ 2 * y3 ^ 3 * x3 * e3 * e5 * y1 + 16 * e1 * y2 ^ 2 * y3 ^ 3 * x3 * e3 * e6 * y1 + 16 * e1 * y2 ^ 2 * y3 ^ 2 * e4 * y1 ^ 2 * e5 + 16 * e1 * y2 ^ 2 * y3 ^ 2 * e4 * y1 ^ 2 * e6 + 16 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e5 * y1 * y2 + 16 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e6 * y1 * y2 - 8 * e1 * y2 ^ 2 * x3 * e3 * e4 * y1 ^ 2 * e5 - 8 * e1 * y2 ^ 2 * x3 * e3 * e4 * y1 ^ 2 * e6 + 16 * e1 * y3 * x2 * e3 * e4 * y2 ^ 2 * e5 * y1 + 16 * e1 * y3 * x2 * e3 * e4 * y2 ^ 2 * e6 * y1 + 16 * e1 * y3 * x2 * e3 * e4 * y1 ^ 2 * e5 * y2 + 16 * e1 * y3 * x2 * e3 * e4 * y1 ^ 2 * e6 * y2 + 8 * e1 * y3 * x3 * e3 * e4 * y2 ^ 2 * e5 * y1 + 8 * e1 * y3 * x3 * e3 * e4 * y2 ^ 2 * e6 * y1 + 8 * e1 * y3 * x3 * e3 * e4 * y1 ^ 2 * e5 * y2 + 8 * e1 * y3 * x3 * e3 * e4 * y1 ^ 2 * e6 * y2 + 12 * e6 ^ 2 * e7 * y1 * y2 * x1 * e1 ^ 2 + 2 * x1 * e1 ^ 3 * x2 * e6 ^ 3 + 3 * x1 ^ 2 * e1 ^ 3 * e6 ^ 2 * e7 + 3 * x2 ^ 2 * e1 ^ 3 * e6 ^ 2 * e7 + 3 * e1 ^ 3 * x3 ^ 2 * e6 ^ 2 * e7 + 2 * x1 * e1 ^ 3 * x3 * e6 ^ 3 + 2 * x2 * e1 ^ 3 * x3 * e6 ^ 3 + 3 * x1 ^ 2 * e1 ^ 3 * e7 ^ 2 * e6 + 3 * x2 ^ 2 * e1 ^ 3 * e7 ^ 2 * e6 + 4 * e6 ^ 3 * y1 * y2 * x1 * e1 ^ 2 + 4 * e6 ^ 3 * y1 * y2 * x2 * e1 ^ 2 + 12 * e6 ^ 2 * e7 * y1 * y2 * x2 * e1 ^ 2 + 12 * e7 ^ 2 * y1 * e6 * y2 * x1 * e1 ^ 2 + 12 * e7 ^ 2 * y1 * e6 * y2 * x2 * e1 ^ 2 + e1 * e6 ^ 5 + 3 * e1 ^ 3 * x3 ^ 2 * e7 ^ 2 * e6 - 2 * e6 ^ 3 * x1 * e1 ^ 2 * e5 - 2 * e6 ^ 3 * x2 * e1 ^ 2 * e5 - 2 * e6 ^ 3 * e1 ^ 2 * x3 * e5 - 6 * e6 ^ 3 * e7 * x1 * e1 ^ 2 - 6 * e6 ^ 3 * e7 * x2 * e1 ^ 2 - 6 * e6 ^ 2 * e7 ^ 2 * x1 * e1 ^ 2 - 6 * e6 ^ 2 * e7 ^ 2 * x2 * e1 ^ 2 - 6 * e6 ^ 3 * e1 ^ 2 * x3 * e7 - 6 * e6 ^ 2 * e1 ^ 2 * x3 * e7 ^ 2 + 6 * x1 * e1 ^ 3 * x2 * e6 ^ 2 * e7 + 6 * x1 * e1 ^ 3 * x2 * e7 ^ 2 * e6 + 6 * x1 * e1 ^ 3 * x3 * e7 ^ 2 * e6 + 6 * x2 * e1 ^ 3 * x3 * e7 ^ 2 * e6 - 6 * e5 * x1 * e1 ^ 2 * e7 ^ 2 * e6 - 6 * e5 * x2 * e1 ^ 2 * e7 ^ 2 * e6 - 6 * e5 * e1 ^ 2 * x3 * e7 ^ 2 * e6 - 6 * e5 * e6 ^ 2 * e7 * x1 * e1 ^ 2 - 6 * e5 * e6 ^ 2 * e7 * x2 * e1 ^ 2 + 4 * e6 ^ 3 * e1 ^ 2 * x3 * y1 * y2 + 12 * y1 * y2 * e1 ^ 2 * x3 * e6 ^ 2 * e7 + 6 * x1 * e1 ^ 3 * x3 * e6 ^ 2 * e7 + 6 * x2 * e1 ^ 3 * x3 * e6 ^ 2 * e7 - 6 * e6 ^ 2 * e1 ^ 2 * x3 * e7 * e5 + 12 * y1 * y2 * e1 ^ 2 * x3 * e7 ^ 2 * e6 + 2 * x1 * e1 ^ 3 * x2 * e7 ^ 3 + 2 * x1 * e1 ^ 3 * x3 * e7 ^ 3 + 2 * x2 * e1 ^ 3 * x3 * e7 ^ 3 - 2 * e5 * x1 * e1 ^ 2 * e7 ^ 3 - 2 * e5 * x2 * e1 ^ 2 * e7 ^ 3 - 2 * e5 * e1 ^ 2 * x3 * e7 ^ 3 - 2 * e6 * e1 ^ 2 * x3 * e7 ^ 3 - 2 * e6 * x1 * e1 ^ 2 * e7 ^ 3 - 2 * e6 * x2 * e1 ^ 2 * e7 ^ 3 - 4 * e1 * e6 ^ 4 * y1 * y2 + 4 * e1 * e6 ^ 3 * y1 ^ 2 * y2 ^ 2 + 6 * e1 * e6 ^ 3 * e7 * e5 + 3 * e1 * e5 ^ 2 * e6 ^ 2 * e7 + 3 * e1 * e5 ^ 2 * e6 * e7 ^ 2 + 6 * e1 * e5 * e6 ^ 2 * e7 ^ 2 + 2 * e1 * e5 * e6 * e7 ^ 3 + 4 * e1 * y1 ^ 2 * y2 ^ 2 * e7 ^ 3 + 4 * y1 * y2 * x1 * e1 ^ 2 * e7 ^ 3 + 4 * y1 * y2 * x2 * e1 ^ 2 * e7 ^ 3 + 4 * y1 * y2 * e1 ^ 2 * x3 * e7 ^ 3 - 4 * e1 * e6 ^ 3 * y1 * e5 * y2 - 12 * e1 * e6 ^ 3 * e7 * y1 * y2 + 12 * e1 * e6 ^ 2 * e7 * y1 ^ 2 * y2 ^ 2 - 12 * e1 * e6 ^ 2 * e7 * y1 * e5 * y2 - 12 * e1 * e7 ^ 2 * y1 * e5 * y2 * e6 - 12 * e1 * e7 ^ 2 * y1 * e6 ^ 2 * y2 + 12 * e1 * e7 ^ 2 * y1 ^ 2 * e6 * y2 ^ 2 - 4 * e1 * e5 * y1 * y2 * e7 ^ 3 - 4 * e1 * e6 * y1 * y2 * e7 ^ 3. coq-8.4pl4/test-suite/complexity/guard.v0000644000175000017500000000101312326224777017422 0ustar stephsteph(* Examples to check that the guard condition does not evaluate irrelevant subterms *) (* Expected time < 1.00s *) Require Import Bool. Fixpoint slow n := match n with | 0 => true | S k => andb (slow k) (slow k) end. Timeout 5 Time Fixpoint F n := match n with | 0 => 0 | S k => if slow 100 then F k else 0 end. Fixpoint slow2 n := match n with | 0 => 0 | S k => slow2 k + slow2 k end. Timeout 5 Time Fixpoint F' n := match n with | 0 => 0 | S k => if slow2 100 then F' k else 0 end. coq-8.4pl4/test-suite/complexity/patternmatching.v0000644000175000017500000000254412326224777021522 0ustar stephsteph(* This example checks the efficiency of pattern-matching compilation on simple cases *) (* Expected time < 1.00s *) Time Definition a400 n := match n with S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S x))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) => x | _ => 0 end. coq-8.4pl4/test-suite/complexity/Notations.v0000644000175000017500000000054512326224777020307 0ustar stephsteph(* Last line should not loop, even in the presence of eta-expansion in the *) (* printing mechanism *) (* Expected time < 1.00s *) Notation "'bind' x <- y ; z" :=(y (fun x => z)) (at level 99, x at level 0, y at level 0,format "'[hv' 'bind' x <- y ; '/' z ']'"). Definition f (g : (nat -> nat) -> nat) := g (fun x => 0). Time Check (fun g => f g). coq-8.4pl4/test-suite/complexity/unification.v0000644000175000017500000000262212326224777020637 0ustar stephsteph(* Test parsing/interpretation/pretyping on a large example *) (* Expected time < 0.10s *) (* Complexity of unification used to be exponential in the number of nested constants, as pointed out by Georges Gonthier and Nicolas Tabareau (a.o.) The problem is that unification of id^n+1(0) and id^n+1(1) proceeds as: - try not unfold the outermost id by trying to unify its arguments: 1st rec. call on id^n(0) id^n(1), which fails - Coq then tries to unfold id^n+1(k) which produces id^n(k) - 2nd rec. call on id^n(0) id^n(1), which also fails Complexity is thus at least exponential. This is fixed (in the ground case), by the fact that when we try to unify two ground terms (ie. without unsolved evars), we call kernel conversion and if this fails, then the terms are not unifiable. Hopefully, kernel conversion is not exponential on cases like the one below thanks to sharing (as long as unfolding the fonction does not use its argument under a binder). There are probably still many cases where unification goes astray. *) Definition id (n:nat) := n. Goal (id (id (id (id (id (id (id (id (id (id (id (id (id (id (id (id (id (id (id (id 0 )))) )))) )))) )))) )))) = (id (id (id (id (id (id (id (id (id (id (id (id (id (id (id (id (id (id (id (id 1 )))) )))) )))) )))) )))) . Timeout 2 Time try refine (refl_equal _). coq-8.4pl4/test-suite/complexity/ring.v0000644000175000017500000000034412326224777017265 0ustar stephsteph(* This example, checks the efficiency of the abstract machine used by ring *) (* Expected time < 1.00s *) Require Import ZArith. Open Scope Z_scope. Goal forall a, a+a+a+a+a+a+a+a+a+a+a+a+a = a*13. Timeout 5 Time intro; ring. coq-8.4pl4/test-suite/complexity/setoid_rewrite.v0000644000175000017500000000027512326224777021361 0ustar stephsteph(* Check bug #1176 *) (* Expected time < 0.50s *) Require Import Setoid. Variable f : nat -> Prop. Goal forall U:Prop, f 100 <-> U. intros U. Timeout 5 Time setoid_replace U with False. coq-8.4pl4/test-suite/complexity/ring2.v0000644000175000017500000000202112326224777017341 0ustar stephsteph(* This example checks the efficiency of the abstract machine used by ring *) (* Expected time < 1.00s *) Require Import BinInt Zbool. Definition Zadd x y := match x with | 0%Z => y | Zpos x' => match y with | 0%Z => x | Zpos y' => Zpos (x' + y') | Zneg y' => match (x' ?= y')%positive with | Eq => 0%Z | Lt => Zneg (y' - x') | Gt => Zpos (x' - y') end end | Zneg x' => match y with | 0%Z => x | Zpos y' => match (x' ?= y')%positive with | Eq => 0%Z | Lt => Zpos (y' - x') | Gt => Zneg (x' - y') end | Zneg y' => Zneg (x' + y') end end. Require Import Ring. Lemma Zth : ring_theory Z0 (Zpos xH) Zadd Z.mul Z.sub Z.opp (@eq Z). Admitted. Ltac Zcst t := match isZcst t with true => t | _ => constr:NotConstant end. Add Ring Zr : Zth (decidable Zeq_bool_eq, constants [Zcst]). Open Scope Z_scope. Infix "+" := Zadd : Z_scope. Goal forall a, a+a+a+a+a+a+a+a+a+a+a+a+a = a*13. Timeout 5 Time intro; ring. coq-8.4pl4/test-suite/complexity/evar_instance.v0000644000175000017500000000744712326224777021162 0ustar stephsteph(* Checks behavior of unification with respect to the size of evar instances *) (* Expected time < 2.00s *) (* Note that the exact example chosen is not important as soon as it involves a few of each part of the unification algorithme (and especially evar-evar unification and evar-term instantiation) *) (* In 8.2, the example was in O(n^3) in the number of section variables; From current commit it is in O(n^2) *) (* For the record: with coqtop.byte on a Dual Core 2: Nb of extra T i m e variables 8.1 8.2 8.3beta current 800 1.6s 188s 185s 1.6s 400 0.5s 24s 24s 0.43s 200 0.17s 3s 3.2s 0.12s 100 0.06s 0.5s 0.48s 0.04s 50 0.02s 0.08s 0.08s 0.016s n 12*a*n^2 a*n^3 a*n^3 8*a*n^2 *) Set Implicit Arguments. Parameter t:Set->Set. Parameter map:forall elt elt' : Set, (elt -> elt') -> t elt -> t elt'. Parameter avl: forall elt : Set, t elt -> Prop. Parameter bst: forall elt : Set, t elt -> Prop. Parameter map_avl: forall (elt elt' : Set) (f : elt -> elt') (m : t elt), avl m -> avl (map f m). Parameter map_bst: forall (elt elt' : Set) (f : elt -> elt') (m : t elt), bst m -> bst (map f m). Record bbst (elt:Set) : Set := Bbst {this :> t elt; is_bst : bst this; is_avl: avl this}. Definition t' := bbst. Section B. Variables a b c d e f g h i j k m n o p q r s u v w x y z a0 b0 c0 d0 e0 f0 g0 h0 i0 j0 k0 m0 n0 o0 p0 q0 r0 s0 u0 v0 w0 x0 y0 z0 a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 m1 n1 o1 p1 q1 r1 s1 u1 v1 w1 x1 y1 z1 a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 m2 n2 o2 p2 q2 r2 s2 u2 v2 w2 x2 y2 z2 a3 b3 c3 d3 e3 f3 g3 h3 i3 j3 k3 m3 n3 o3 p3 q3 r3 s3 u3 v3 w3 x3 y3 z3 a4 b4 c4 d4 e4 f4 g4 h4 i4 j4 k4 m4 n4 o4 p4 q4 r4 s4 u4 v4 w4 x4 y4 z4 a5 b5 c5 d5 e5 f5 g5 h5 i5 j5 k5 m5 n5 o5 p5 q5 r5 s5 u5 v5 w5 x5 y5 z5 a6 b6 c6 d6 e6 f6 g6 h6 i6 j6 k6 m6 n6 o6 p6 q6 r6 s6 u6 v6 w6 x6 y6 z6 a7 b7 c7 d7 e7 f7 g7 h7 i7 j7 k7 m7 n7 o7 p7 q7 r7 s7 u7 v7 w7 x7 y7 z7 a8 b8 c8 d8 e8 f8 g8 h8 i8 j8 k8 m8 n8 o8 p8 q8 r8 s8 u8 v8 w8 x8 y8 z8 a9 b9 c9 d9 e9 f9 g9 h9 i9 j9 k9 m9 n9 o9 p9 q9 r9 s9 u9 v9 w9 x9 y9 z9 aA bA cA dA eA fA gA hA iA jA kA mA nA oA pA qA rA sA uA vA wA xA yA zA aB bB cB dB eB fB gB hB iB jB kB mB nB oB pB qB rB sB uB vB wB xB yB zB aC bC cC dC eC fC gC hC iC jC kC mC nC oC pC qC rC sC uC vC wC xC yC zC aD bD cD dD eD fD gD hD iD jD kD mD nD oD pD qD rD sD uD vD wD xD yD zD aE bE cE dE eE fE gE hE iE jE kE mE nE oE pE qE rE sE uE vE wE xE yE zE aF bF cF dF eF fF gF hF iF jF kF mF nF oF pF qF rF sF uF vF wF xF yF zF aG bG cG dG eG fG gG hG iG jG kG mG nG oG pG qG rG sG uG vG wG xG yG zG aH bH cH dH eH fH gH hH iH jH kH mH nH oH pH qH rH sH uH vH wH xH yH zH aI bI cI dI eI fI gI hI iI jI kI mI nI oI pI qI rI sI uI vI wI xI yI zI aJ bJ cJ dJ eJ fJ gJ hJ iJ jJ kJ mJ nJ oJ pJ qJ rJ sJ uJ vJ wJ xJ yJ zJ aK bK cK dK eK fK gK hK iK jK kK mK nK oK pK qK rK sK uK vK wK xK yK zK aL bL cL dL eL fL gL hL iL jL kL mL nL oL pL qL rL sL uL vL wL xL yL zL aM bM cM dM eM fM gM hM iM jM kM mM nM oM pM qM rM sM uM vM wM xM yM zM aN bN cN dN eN fN gN hN iN jN kN mN nN oN pN qN rN sN uN vN wN xN yN zN aO bO cO dO eO fO gO hO iO jO kO mO nO oO pO qO rO sO uO vO wO xO yO zO aP bP cP dP eP fP gP hP iP jP kP mP nP oP pP qP rP sP uP vP wP xP yP zP aQ bQ cQ dQ eQ fQ gQ hQ iQ jQ kQ mQ nQ oQ pQ qQ rQ sQ uQ vQ wQ xQ yQ zQ aR bR cR dR eR fR gR hR iR jR kR mR nR oR pR qR rR sR uR vR wR xR yR zR aS bS cS dS eS fS gS hS iS jS kS mS nS oS pS qS rS sS uS vS wS xS yS zS aT bT cT dT eT fT gT hT iT jT kT mT nT oT pT qT rT sT uT vT wT xT yT zT aU bU cU dU eU fU gU hU iU jU kU mU nU oU pU qU rU sU uU vU wU xU yU zU : nat . Variables elt elt': Set. Timeout 5 Time Definition map' f (m:t' elt) : t' elt' := Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)). coq-8.4pl4/test-suite/prerequisite/0000755000175000017500000000000012365131023016442 5ustar stephstephcoq-8.4pl4/test-suite/prerequisite/make_local.v0000644000175000017500000000042412326224777020740 0ustar stephsteph(* Used in Import.v to test the locality flag *) Definition f (A:Type) (a:A) := a. Local Arguments Scope f [type_scope type_scope]. Local Implicit Arguments f [A]. (* Used in ImportedCoercion.v to test the locality flag *) Local Coercion g (b:bool) := if b then 0 else 1. coq-8.4pl4/test-suite/prerequisite/make_notation.v0000644000175000017500000000056112326224777021503 0ustar stephsteph(* Used in Notation.v to test import of notations from files in sections *) Notation "'Z'" := O (at level 9). Notation plus := plus. Notation succ := S. Notation mult := mult (only parsing). Notation less := le (only parsing). (* Test bug 2168: ending section of some name was removing objects of the same name *) Notation add2 n:=(S n). Section add2. End add2. coq-8.4pl4/test-suite/Makefile0000644000175000017500000003452712326224777015414 0ustar stephsteph####################################################################### # v # The Coq Proof Assistant / The Coq Development Team # # /dev/null 2>&1) bogomips := ifneq (,$(wildcard /proc/cpuinfo)) sedbogo := -e "s/bogomips.*: \([0-9]*\).*/\1/p" # i386, ppc sedbogo += -e "s/Cpu0Bogo.*: \([0-9]*\).*/\1/p" # sparc sedbogo += -e "s/BogoMIPS.*: \([0-9]*\).*/\1/p" # alpha bogomips := $(shell sed -n $(sedbogo) /proc/cpuinfo | head -1) endif ifeq (,$(bogomips)) $(warning cannot run complexity tests (no bogomips found)) endif log_success = "==========> SUCCESS <==========" log_failure = "==========> FAILURE <==========" log_intro = "==========> TESTING $(1) <==========" ####################################################################### # Testing subsystems ####################################################################### # Apart so that it can be easily skipped with overriding COMPLEXITY := $(if $(bogomips),complexity) BUGS := bugs/opened/shouldnotfail bugs/opened/shouldnotsucceed \ bugs/closed/shouldsucceed bugs/closed/shouldfail VSUBSYSTEMS := prerequisite success failure $(BUGS) output \ interactive micromega $(COMPLEXITY) modules # All subsystems SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide ####################################################################### # Phony targets ####################################################################### .DELETE_ON_ERROR: .PHONY: all run clean $(SUBSYSTEMS) all: run $(MAKE) --quiet summary.log run: $(SUBSYSTEMS) bugs: $(BUGS) clean: rm -f trace lia.cache $(SHOW) "RM <**/*.stamp> <**/*.vo> <**/*.log>" $(HIDE)find . \( \ -name '*.stamp' -o -name '*.vo' -o -name '*.log' \ \) -print0 | xargs -0 rm -f ####################################################################### # Per-subsystem targets ####################################################################### define mkstamp $(1): $(1).stamp ; @true $(1).stamp: $(patsubst %.v,%.v.log,$(wildcard $(1)/*.v)) ; \ $(HIDE)touch $$@ endef $(foreach S,$(VSUBSYSTEMS),$(eval $(call mkstamp,$(S)))) ####################################################################### # Summary ####################################################################### summary_dir = echo $(1); find $(2) -name '*.log' -print0 | xargs -0 -n 1 tail -n1 | sort -g .PHONY: summary summary.log summary: @{ \ $(call summary_dir, "Preparing tests", prerequisite); \ $(call summary_dir, "Success tests", success); \ $(call summary_dir, "Failure tests", failure); \ $(call summary_dir, "Bugs tests", bugs); \ $(call summary_dir, "Output tests", output); \ $(call summary_dir, "Interactive tests", interactive); \ $(call summary_dir, "Micromega tests", micromega); \ $(call summary_dir, "Miscellaneous tests", misc); \ $(call summary_dir, "Complexity tests", complexity); \ $(call summary_dir, "Module tests", modules); \ $(call summary_dir, "IDE tests", ide); \ nb_success=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_success) | wc -l`; \ nb_failure=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_failure) | wc -l`; \ nb_tests=`expr $$nb_success + $$nb_failure`; \ pourcentage=`expr 100 \* $$nb_success / $$nb_tests`; \ echo; \ echo "$$nb_success tests passed over $$nb_tests, i.e. $$pourcentage %"; \ } summary.log: $(SHOW) SUMMARY $(HIDE)$(MAKE) --quiet summary > "$@" ####################################################################### # Regression (and progression) tests ####################################################################### # Process verifications concerning submitted bugs. A message is # printed for all opened bugs (still active or seems to be closed). # For closed bugs that behave as expected, no message is printed # All files are assumed to have <# of the bug>.v as a name # Opened bugs that should not succeed (FIXME: there were no such tests # at the time of writing this Makefile, but the possibility was in the # original shellscript... so left it here, but untested) $(addsuffix .log,$(wildcard bugs/opened/shouldnotsucceed/*.v)): %.v.log: %.v @echo "TEST $<" $(HIDE){ \ $(call test_intro,$<); \ $(command) "$<" 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...still active"; \ else \ echo $(log_failure); \ echo " $<...Error! (bug seems to be closed, please check)"; fi; } > "$@" # Opened bugs that should not fail $(addsuffix .log,$(wildcard bugs/opened/shouldnotfail/*.v)): %.v.log: %.v @echo "TEST $<" $(HIDE){ \ echo $(call log_intro,$<); \ $(command) "$<" 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_success); \ echo " $<...still active"; \ else \ echo $(log_failure); \ echo " $<...Error! (bug seems to be closed, please check)"; \ fi; \ } > "$@" # Closed bugs that should succeed $(addsuffix .log,$(wildcard bugs/closed/shouldsucceed/*.v)): %.v.log: %.v @echo "TEST $<" $(HIDE){ \ echo $(call log_intro,$<); \ $(command) "$<" 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ else \ echo $(log_failure); \ echo " $<...Error! (bug seems to be opened, please check)"; \ fi; \ } > "$@" # Closed bugs that should fail $(addsuffix .log,$(wildcard bugs/closed/shouldfail/*.v)): %.v.log: %.v @echo "TEST $<" $(HIDE){ \ echo $(call log_intro,$<); \ $(command) "$<" 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ else \ echo $(log_failure); \ echo " $<...Error! (bug seems to be opened, please check)"; \ fi; \ } > "$@" ####################################################################### # Other generic tests ####################################################################### $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v @echo "TEST $<" $(HIDE){ \ echo $(call log_intro,$<); \ $(coqc) "$*" 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be prepared" ; \ else \ echo $(log_success); \ echo " $<...correctly prepared" ; \ fi; \ } > "$@" $(addsuffix .log,$(wildcard success/*.v micromega/*.v modules/*.v)): %.v.log: %.v @echo "TEST $<" $(HIDE){ \ opts="$(if $(findstring modules/,$<),-I modules -impredicative-set)"; \ echo $(call log_intro,$<); \ $(command) "$<" $$opts 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ else \ echo $(log_failure); \ echo " $<...Error! (should be accepted)"; \ fi; \ } > "$@" $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v @echo "TEST $<" $(HIDE){ \ echo $(call log_intro,$<); \ $(command) "$<" 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ else \ echo $(log_failure); \ echo " $<...Error! (should be rejected)"; \ fi; \ } > "$@" $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v @echo "TEST $<" $(HIDE){ \ echo $(call log_intro,$<); \ tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`; \ $(command) "$<" 2>&1 \ | grep -v "Welcome to Coq" \ | grep -v "Skipping rcfile loading" \ > $$tmpoutput; \ diff -u $*.out $$tmpoutput 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ else \ echo $(log_failure); \ echo " $<...Error! (unexpected output)"; \ fi; \ rm $$tmpoutput; \ } > "$@" $(addsuffix .log,$(wildcard interactive/*.v)): %.v.log: %.v @echo "TEST $<" $(HIDE){ \ echo $(call log_intro,$<); \ $(coqtop) < "$<" 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ else \ echo $(log_failure); \ echo " $<...Error! (should be accepted)"; \ fi; \ } > "$@" # Complexity test. Expects a line "(* Expected time < XXX.YYs *)" in # the .v file with exactly two digits after the dot. The reference for # time is a 6120 bogomips cpu. ifneq (,$(bogomips)) $(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v @echo "TEST $<" $(HIDE){ \ echo $(call log_intro,$<); \ true "extract effective user time"; \ res=`$(command) "$<" 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1`; \ R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...Error! (should be accepted)" ; \ elif [ "$$res" = "" ]; then \ echo $(log_failure); \ echo " $<...Error! (couldn't find a time measure)"; \ else \ true "express effective time in centiseconds"; \ res=`echo "$$res"00 | sed -n -e "s/\([0-9]*\)\.\([0-9][0-9]\).*/\1\2/p"`; \ true "find expected time * 100"; \ exp=`sed -n -e "s/(\*.*Expected time < \([0-9]\).\([0-9][0-9]\)s.*\*)/\1\2/p" "$<"`; \ ok=`expr \( $$res \* $(bogomips) \) "<" \( $$exp \* 6120 \)`; \ if [ "$$ok" = 1 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ else \ echo $(log_failure); \ echo " $<...Error! (should run faster)"; \ fi; \ fi; \ } > "$@" endif # Ideal-features tests $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v @echo "TEST $<" $(HIDE){ \ echo $(call log_intro,$<); \ $(command) "$<" 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_success); \ echo " $<...still wished"; \ else \ echo $(log_failure); \ echo " $<...Good news! (wish seems to be granted, please check)"; \ fi; \ } > "$@" # Additionnal dependencies for module tests $(addsuffix .log,$(wildcard modules/*.v)): %.v.log: modules/Nat.vo modules/plik.vo %.vo: %.v $(HIDE)$(coqtop) -compile $* ####################################################################### # Miscellaneous tests ####################################################################### misc: misc/xml.log misc/deps-order.log misc/universes.log # Test xml compilation xml: misc/xml.log misc/xml.log: @echo "TEST misc/xml" $(HIDE){ \ echo $(call log_intro,xml); \ rm -rf misc/xml; \ COQ_XML_LIBRARY_ROOT=misc/xml \ $(bincoqc) -xml misc/berardi_test 2>&1; times; \ if [ ! -d misc/xml ]; then \ echo $(log_failure); \ echo " misc/xml... failed"; \ else \ echo $(log_success); \ echo " misc/xml...apparently ok"; \ fi; rm -rf misc/xml; \ } > "$@" # Check that both coqdep and coqtop/coqc takes the later -I/-R # Check that both coqdep and coqtop/coqc supports both -R and -I dir -as lib # See bugs 2242, 2337, 2339 deps-order: misc/deps-order.log misc/deps-order.log: @echo "TEST misc/deps-order" $(HIDE){ \ echo $(call log_intro,deps-order); \ rm -f misc/deps/*/*.vo; \ tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`; \ $(coqdep) -I misc/deps/lib -as lib -R misc/deps/client client misc/deps/client/bar.v 2>&1 \ | head -n 1 > $$tmpoutput; \ diff -u misc/deps/deps.out $$tmpoutput 2>&1; R=$$?; times; \ $(bincoqc) -I misc/deps/lib -as lib misc/deps/lib/foo.v 2>&1; \ $(bincoqc) -I misc/deps/lib -as lib -R misc/deps/client client misc/deps/client/foo.v 2>&1; \ $(coqtop) -I misc/deps/lib -as lib -R misc/deps/client client -load-vernac-source misc/deps/client/bar.v 2>&1; \ S=$$?; times; \ if [ $$R = 0 -a $$S = 0 ]; then \ echo $(log_success); \ echo " misc/deps-order...Ok"; \ else \ echo $(log_failure); \ echo " misc/deps-order...Error! (unexpected order)"; \ fi; \ rm $$tmpoutput; \ } > "$@" # Sort universes for the whole standard library EXPECTED_UNIVERSES := 3 universes: misc/universes.log misc/universes.log: misc/universes/all_stdlib.v @echo "TEST misc/universes" $(HIDE){ \ $(bincoqc) -I misc/universes misc/universes/all_stdlib 2>&1; \ $(bincoqc) -I misc/universes misc/universes/universes 2>&1; \ mv universes.txt misc/universes; \ N=`awk '{print $$3}' misc/universes/universes.txt | sort -u | wc -l`; \ times; \ if [ "$$N" -eq $(EXPECTED_UNIVERSES) ]; then \ echo $(log_success); \ echo " misc/universes...Ok ($(EXPECTED_UNIVERSES) universes)"; \ else \ echo $(log_failure); \ echo " misc/universes...Error! ($$N/$(EXPECTED_UNIVERSES) universes)"; \ fi; \ } > "$@" misc/universes/all_stdlib.v: cd .. && $(MAKE) test-suite/$@ # IDE : some tests of backtracking for coqtop -ideslave ide : $(patsubst %.fake,%.fake.log,$(wildcard ide/*.fake)) %.fake.log : %.fake @echo "TEST $<" $(HIDE){ \ echo $(call log_intro,$<); \ $(BIN)fake_ide "$(BIN)coqtop -boot" < $< 2>&1; \ if [ $$? = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ else \ echo $(log_failure); \ echo " $<...Error!"; \ fi; \ } > "$@" coq-8.4pl4/test-suite/micromega/0000755000175000017500000000000012365131023015664 5ustar stephstephcoq-8.4pl4/test-suite/micromega/zomicron.v0000644000175000017500000000113212326224777017730 0ustar stephstephRequire Import ZArith. Require Import Psatz. Open Scope Z_scope. Lemma two_x_eq_1 : forall x, 2 * x = 1 -> False. Proof. intros. lia. Qed. Lemma two_x_y_eq_1 : forall x y, 2 * x + 2 * y = 1 -> False. Proof. intros. lia. Qed. Lemma two_x_y_z_eq_1 : forall x y z, 2 * x + 2 * y + 2 * z= 1 -> False. Proof. intros. lia. Qed. Lemma omega_nightmare : forall x y, 27 <= 11 * x + 13 * y <= 45 -> -10 <= 7 * x - 9 * y <= 4 -> False. Proof. intros ; intuition auto. lia. Qed. Lemma compact_proof : forall z, (z < 0) -> (z >= 0) -> (0 >= z \/ 0 < z) -> False. Proof. intros. lia. Qed.coq-8.4pl4/test-suite/micromega/square.v0000644000175000017500000000423212326224777017374 0ustar stephsteph(************************************************************************) (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) (* FrÃĐdÃĐric Besson (Irisa/Inria) 2006-2008 *) (* *) (************************************************************************) Require Import ZArith Zwf Psatz QArith. Open Scope Z_scope. Lemma Zabs_square : forall x, (Z.abs x)^2 = x^2. Proof. intros ; case (Zabs_dec x) ; intros ; psatz Z 2. Qed. Hint Resolve Z.abs_nonneg Zabs_square. Lemma integer_statement : ~exists n, exists p, n^2 = 2*p^2 /\ n <> 0. Proof. intros [n [p [Heq Hnz]]]; pose (n' := Z.abs n); pose (p':=Z.abs p). assert (facts : 0 <= Z.abs n /\ 0 <= Z.abs p /\ Z.abs n^2=n^2 /\ Z.abs p^2 = p^2) by auto. assert (H : (0 < n' /\ 0 <= p' /\ n' ^2 = 2* p' ^2)) by (destruct facts as [Hf1 [Hf2 [Hf3 Hf4]]]; unfold n', p' ; psatz Z 2). generalize p' H; elim n' using (well_founded_ind (Zwf_well_founded 0)); clear. intros n IHn p [Hn [Hp Heq]]. assert (Hzwf : Zwf 0 (2*p-n) n) by (unfold Zwf; psatz Z 2). assert (Hdecr : 0 < 2*p-n /\ 0 <= n-p /\ (2*p-n)^2=2*(n-p)^2) by psatz Z 2. apply (IHn (2*p-n) Hzwf (n-p) Hdecr). Qed. Open Scope Q_scope. Lemma QnumZpower : forall x : Q, Qnum (x ^ 2)%Q = ((Qnum x) ^ 2) %Z. Proof. intros. destruct x. cbv beta iota zeta delta - [Z.mul]. ring. Qed. Lemma QdenZpower : forall x : Q, ' Qden (x ^ 2)%Q = ('(Qden x) ^ 2) %Z. Proof. intros. destruct x. simpl. unfold Z.pow_pos. simpl. rewrite Pos.mul_1_r. reflexivity. Qed. Theorem sqrt2_not_rational : ~exists x:Q, x^2==2#1. Proof. unfold Qeq; intros [x]; simpl (Qden (2#1)); rewrite Z.mul_1_r. intros HQeq. assert (Heq : (Qnum x ^ 2 = 2 * ' Qden x ^ 2%Q)%Z) by (rewrite QnumZpower in HQeq ; rewrite QdenZpower in HQeq ; auto). assert (Hnx : (Qnum x <> 0)%Z) by (intros Hx; simpl in HQeq; rewrite Hx in HQeq; discriminate HQeq). apply integer_statement; exists (Qnum x); exists (' Qden x); auto. Qed. coq-8.4pl4/test-suite/micromega/example.v0000644000175000017500000001667012326224777017540 0ustar stephsteph(************************************************************************) (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) (* Frédéric Besson (Irisa/Inria) 2006-2008 *) (* *) (************************************************************************) Require Import ZArith. Require Import Psatz. Require Import Ring_normalize. Open Scope Z_scope. Require Import ZMicromega. Require Import VarMap. (* false in Q : x=1/2 and n=1 *) Lemma not_so_easy : forall x n : Z, 2*x + 1 <= 2 *n -> x <= n-1. Proof. intros. lia. Qed. (* From Laurent Théry *) Lemma some_pol : forall x, 4 * x ^ 2 + 3 * x + 2 >= 0. Proof. intros. psatz Z 2. Qed. Lemma Zdiscr: forall a b c x, a * x ^ 2 + b * x + c = 0 -> b ^ 2 - 4 * a * c >= 0. Proof. intros ; psatz Z 4. Qed. Lemma plus_minus : forall x y, 0 = x + y -> 0 = x -y -> 0 = x /\ 0 = y. Proof. intros. lia. Qed. Lemma mplus_minus : forall x y, x + y >= 0 -> x -y >= 0 -> x^2 - y^2 >= 0. Proof. intros; psatz Z 2. Qed. Lemma pol3: forall x y, 0 <= x + y -> x^3 + 3*x^2*y + 3*x* y^2 + y^3 >= 0. Proof. intros; psatz Z 4. Qed. (* Motivating example from: Expressiveness + Automation + Soundness: Towards COmbining SMT Solvers and Interactive Proof Assistants *) Parameter rho : Z. Parameter rho_ge : rho >= 0. Parameter correct : Z -> Z -> Prop. Definition rbound1 (C:Z -> Z -> Z) : Prop := forall p s t, correct p t /\ s <= t -> C p t - C p s <= (1-rho)*(t-s). Definition rbound2 (C:Z -> Z -> Z) : Prop := forall p s t, correct p t /\ s <= t -> (1-rho)*(t-s) <= C p t - C p s. Lemma bounded_drift : forall s t p q C D, s <= t /\ correct p t /\ correct q t /\ rbound1 C /\ rbound2 C /\ rbound1 D /\ rbound2 D -> Z.abs (C p t - D q t) <= Z.abs (C p s - D q s) + 2 * rho * (t- s). Proof. intros. generalize (Z.abs_eq (C p t - D q t)). generalize (Z.abs_neq (C p t - D q t)). generalize (Z.abs_eq (C p s -D q s)). generalize (Z.abs_neq (C p s - D q s)). unfold rbound2 in H. unfold rbound1 in H. intuition. generalize (H6 _ _ _ (conj H H4)). generalize (H7 _ _ _ (conj H H4)). generalize (H8 _ _ _ (conj H H4)). generalize (H10 _ _ _ (conj H H4)). generalize (H6 _ _ _ (conj H5 H4)). generalize (H7 _ _ _ (conj H5 H4)). generalize (H8 _ _ _ (conj H5 H4)). generalize (H10 _ _ _ (conj H5 H4)). generalize rho_ge. psatz Z 2. Qed. (* Rule of signs *) Lemma sign_pos_pos: forall x y, x > 0 -> y > 0 -> x*y > 0. Proof. intros; psatz Z 2. Qed. Lemma sign_pos_zero: forall x y, x > 0 -> y = 0 -> x*y = 0. Proof. intros; psatz Z 2. Qed. Lemma sign_pos_neg: forall x y, x > 0 -> y < 0 -> x*y < 0. Proof. intros; psatz Z 2. Qed. Lemma sign_zer_pos: forall x y, x = 0 -> y > 0 -> x*y = 0. Proof. intros; psatz Z 2. Qed. Lemma sign_zero_zero: forall x y, x = 0 -> y = 0 -> x*y = 0. Proof. intros; psatz Z 2. Qed. Lemma sign_zero_neg: forall x y, x = 0 -> y < 0 -> x*y = 0. Proof. intros; psatz Z 2. Qed. Lemma sign_neg_pos: forall x y, x < 0 -> y > 0 -> x*y < 0. Proof. intros; psatz Z 2. Qed. Lemma sign_neg_zero: forall x y, x < 0 -> y = 0 -> x*y = 0. Proof. intros; psatz Z 2. Qed. Lemma sign_neg_neg: forall x y, x < 0 -> y < 0 -> x*y > 0. Proof. intros; psatz Z 2. Qed. (* Other (simple) examples *) Lemma binomial : forall x y, (x+y)^2 = x^2 + 2*x*y + y^2. Proof. intros. lia. Qed. Lemma product : forall x y, x >= 0 -> y >= 0 -> x * y >= 0. Proof. intros. psatz Z 2. Qed. Lemma product_strict : forall x y, x > 0 -> y > 0 -> x * y > 0. Proof. intros. psatz Z 2. Qed. Lemma pow_2_pos : forall x, x ^ 2 + 1 = 0 -> False. Proof. intros ; psatz Z 2. Qed. (* Found in Parrilo's talk *) (* BUG?: certificate with **very** big coefficients *) Lemma parrilo_ex : forall x y, x - y^2 + 3 >= 0 -> y + x^2 + 2 = 0 -> False. Proof. intros. psatz Z 2. Qed. (* from hol_light/Examples/sos.ml *) Lemma hol_light1 : forall a1 a2 b1 b2, a1 >= 0 -> a2 >= 0 -> (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) -> (a1 * b1 + a2 * b2 = 0) -> a1 * a2 - b1 * b2 >= 0. Proof. intros ; psatz Z 4. Qed. Lemma hol_light2 : forall x a, 3 * x + 7 * a < 4 -> 3 < 2 * x -> a < 0. Proof. intros ; psatz Z 2. Qed. Lemma hol_light3 : forall b a c x, b ^ 2 < 4 * a * c -> (a * x ^2 + b * x + c = 0) -> False. Proof. intros ; psatz Z 4. Qed. Lemma hol_light4 : forall a c b x, a * x ^ 2 + b * x + c = 0 -> b ^ 2 >= 4 * a * c. Proof. intros ; psatz Z 4. Qed. Lemma hol_light5 : forall x y, 0 <= x /\ x <= 1 /\ 0 <= y /\ y <= 1 -> x ^ 2 + y ^ 2 < 1 \/ (x - 1) ^ 2 + y ^ 2 < 1 \/ x ^ 2 + (y - 1) ^ 2 < 1 \/ (x - 1) ^ 2 + (y - 1) ^ 2 < 1. Proof. intros; psatz Z 3. Qed. Lemma hol_light7 : forall x y z, 0<= x /\ 0 <= y /\ 0 <= z /\ x + y + z <= 3 -> x * y + x * z + y * z >= 3 * x * y * z. Proof. intros ; psatz Z 3. Qed. Lemma hol_light8 : forall x y z, x ^ 2 + y ^ 2 + z ^ 2 = 1 -> (x + y + z) ^ 2 <= 3. Proof. intros ; psatz Z 2. Qed. Lemma hol_light9 : forall w x y z, w ^ 2 + x ^ 2 + y ^ 2 + z ^ 2 = 1 -> (w + x + y + z) ^ 2 <= 4. Proof. intros; psatz Z 2. Qed. Lemma hol_light10 : forall x y, x >= 1 /\ y >= 1 -> x * y >= x + y - 1. Proof. intros ; psatz Z 2. Qed. Lemma hol_light11 : forall x y, x > 1 /\ y > 1 -> x * y > x + y - 1. Proof. intros ; psatz Z 2. Qed. Lemma hol_light12: forall x y z, 2 <= x /\ x <= 125841 / 50000 /\ 2 <= y /\ y <= 125841 / 50000 /\ 2 <= z /\ z <= 125841 / 50000 -> 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= 0. Proof. intros x y z ; set (e:= (125841 / 50000)). compute in e. unfold e ; intros ; psatz Z 2. Qed. Lemma hol_light14 : forall x y z, 2 <= x /\ x <= 4 /\ 2 <= y /\ y <= 4 /\ 2 <= z /\ z <= 4 -> 12 <= 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z). Proof. intros ;psatz Z 2. Qed. (* ------------------------------------------------------------------------- *) (* Inequality from sci.math (see "Leon-Sotelo, por favor"). *) (* ------------------------------------------------------------------------- *) Lemma hol_light16 : forall x y, 0 <= x /\ 0 <= y /\ (x * y = 1) -> x + y <= x ^ 2 + y ^ 2. Proof. intros ; psatz Z 2. Qed. Lemma hol_light17 : forall x y, 0 <= x /\ 0 <= y /\ (x * y = 1) -> x * y * (x + y) <= x ^ 2 + y ^ 2. Proof. intros ; psatz Z 3. Qed. Lemma hol_light18 : forall x y, 0 <= x /\ 0 <= y -> x * y * (x + y) ^ 2 <= (x ^ 2 + y ^ 2) ^ 2. Proof. intros ; psatz Z 4. Qed. (* ------------------------------------------------------------------------- *) (* Some examples over integers and natural numbers. *) (* ------------------------------------------------------------------------- *) Lemma hol_light19 : forall m n, 2 * m + n = (n + m) + m. Proof. intros ; lia. Qed. Lemma hol_light22 : forall n, n >= 0 -> n <= n * n. Proof. intros. psatz Z 2. Qed. Lemma hol_light24 : forall x1 y1 x2 y2, x1 >= 0 -> x2 >= 0 -> y1 >= 0 -> y2 >= 0 -> ((x1 + y1) ^2 + x1 + 1 = (x2 + y2) ^ 2 + x2 + 1) -> (x1 + y1 = x2 + y2). Proof. intros. psatz Z 2. Qed. Lemma motzkin' : forall x y, (x^2+y^2+1)*(x^2*y^4 + x^4*y^2 + 1 - 3*x^2*y^2) >= 0. Proof. intros. psatz Z 1. Qed. Lemma motzkin : forall x y, (x^2*y^4 + x^4*y^2 + 1 - 3*x^2*y^2) >= 0. Proof. intros. generalize (motzkin' x y). psatz Z 8. Qed. coq-8.4pl4/test-suite/micromega/rexample.v0000644000175000017500000000410412326224777017707 0ustar stephsteph(************************************************************************) (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) (* FrÃĐdÃĐric Besson (Irisa/Inria) 2006-2008 *) (* *) (************************************************************************) Require Import Psatz. Require Import Reals. Require Import Ring_normalize. Open Scope R_scope. Lemma yplus_minus : forall x y, 0 = x + y -> 0 = x -y -> 0 = x /\ 0 = y. Proof. intros. psatzl R. Qed. (* Other (simple) examples *) Lemma binomial : forall x y, ((x+y)^2 = x^2 + 2 *x*y + y^2). Proof. intros. psatzl R. Qed. Lemma hol_light19 : forall m n, 2 * m + n = (n + m) + m. Proof. intros ; psatzl R. Qed. Lemma vcgen_25 : forall (n : R) (m : R) (jt : R) (j : R) (it : R) (i : R) (H0 : 1 * it + (-2%R ) * i + (-1%R ) = 0) (H : 1 * jt + (-2 ) * j + (-1 ) = 0) (H1 : 1 * n + (-10 ) = 0) (H2 : 0 <= (-4028 ) * i + (6222 ) * j + (705 ) * m + (-16674 )) (H3 : 0 <= (-418 ) * i + (651 ) * j + (94 ) * m + (-1866 )) (H4 : 0 <= (-209 ) * i + (302 ) * j + (47 ) * m + (-839 )) (H5 : 0 <= (-1 ) * i + 1 * j + (-1 )) (H6 : 0 <= (-1 ) * j + 1 * m + (0 )) (H7 : 0 <= (1 ) * j + (5 ) * m + (-27 )) (H8 : 0 <= (2 ) * j + (-1 ) * m + (2 )) (H9 : 0 <= (7 ) * j + (10 ) * m + (-74 )) (H10 : 0 <= (18 ) * j + (-139 ) * m + (1188 )) (H11 : 0 <= 1 * i + (0 )) (H13 : 0 <= (121 ) * i + (810 ) * j + (-7465 ) * m + (64350 )), (( 1 ) = (-2 ) * i + it). Proof. intros. psatzl R. Qed. Goal forall x, -x^2 >= 0 -> x - 1 >= 0 -> False. Proof. intros. psatz R 3. Qed. Lemma motzkin' : forall x y, (x^2+y^2+1)*(x^2*y^4 + x^4*y^2 + 1 - (3 ) *x^2*y^2) >= 0. Proof. intros ; psatz R 2. Qed. Lemma l1 : forall x y z : R, Rabs (x - z) <= Rabs (x - y) + Rabs (y - z). intros; split_Rabs; psatzl R. Qed.coq-8.4pl4/test-suite/micromega/bertot.v0000644000175000017500000000144212326224777017373 0ustar stephsteph(************************************************************************) (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) (* FrÃĐdÃĐric Besson (Irisa/Inria) 2006-2008 *) (* *) (************************************************************************) Require Import ZArith. Require Import Psatz. Open Scope Z_scope. Goal (forall x y n, ( ~ x < n /\ x <= n /\ 2 * y = x*(x+1) -> 2 * y = n*(n+1)) /\ (x < n /\ x <= n /\ 2 * y = x * (x+1) -> x + 1 <= n /\ 2 *(x+1+y) = (x+1)*(x+2))). Proof. intros. psatz Z 3. Qed. coq-8.4pl4/test-suite/micromega/heap3_vcgen_25.v0000644000175000017500000000235712326224777020572 0ustar stephsteph(************************************************************************) (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) (* FrÃĐdÃĐric Besson (Irisa/Inria) 2006-2008 *) (* *) (************************************************************************) Require Import ZArith. Require Import Psatz. Open Scope Z_scope. Lemma vcgen_25 : forall (n : Z) (m : Z) (jt : Z) (j : Z) (it : Z) (i : Z) (H0 : 1 * it + -2 * i + -1 = 0) (H : 1 * jt + -2 * j + -1 = 0) (H1 : 1 * n + -10 = 0) (H2 : 0 <= -4028 * i + 6222 * j + 705 * m + -16674) (H3 : 0 <= -418 * i + 651 * j + 94 * m + -1866) (H4 : 0 <= -209 * i + 302 * j + 47 * m + -839) (H5 : 0 <= -1 * i + 1 * j + -1) (H6 : 0 <= -1 * j + 1 * m + 0) (H7 : 0 <= 1 * j + 5 * m + -27) (H8 : 0 <= 2 * j + -1 * m + 2) (H9 : 0 <= 7 * j + 10 * m + -74) (H10 : 0 <= 18 * j + -139 * m + 1188) (H11 : 0 <= 1 * i + 0) (H13 : 0 <= 121 * i + 810 * j + -7465 * m + 64350), (1 = -2 * i + it). Proof. intros ; lia. Qed. coq-8.4pl4/test-suite/micromega/qexample.v0000644000175000017500000000415112326224777017710 0ustar stephsteph(************************************************************************) (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) (* FrÃĐdÃĐric Besson (Irisa/Inria) 2006-2008 *) (* *) (************************************************************************) Require Import Psatz. Require Import QArith. Require Import Ring_normalize. Lemma plus_minus : forall x y, 0 == x + y -> 0 == x -y -> 0 == x /\ 0 == y. Proof. intros. psatzl Q. Qed. (* Other (simple) examples *) Open Scope Q_scope. Lemma binomial : forall x y:Q, ((x+y)^2 == x^2 + (2 # 1) *x*y + y^2). Proof. intros. psatzl Q. Qed. Lemma hol_light19 : forall m n, (2 # 1) * m + n == (n + m) + m. Proof. intros ; psatzl Q. Qed. Open Scope Z_scope. Open Scope Q_scope. Lemma vcgen_25 : forall (n : Q) (m : Q) (jt : Q) (j : Q) (it : Q) (i : Q) (H0 : 1 * it + (-2 # 1) * i + (-1 # 1) == 0) (H : 1 * jt + (-2 # 1) * j + (-1 # 1) == 0) (H1 : 1 * n + (-10 # 1) = 0) (H2 : 0 <= (-4028 # 1) * i + (6222 # 1) * j + (705 # 1) * m + (-16674 # 1)) (H3 : 0 <= (-418 # 1) * i + (651 # 1) * j + (94 # 1) * m + (-1866 # 1)) (H4 : 0 <= (-209 # 1) * i + (302 # 1) * j + (47 # 1) * m + (-839 # 1)) (H5 : 0 <= (-1 # 1) * i + 1 * j + (-1 # 1)) (H6 : 0 <= (-1 # 1) * j + 1 * m + (0 # 1)) (H7 : 0 <= (1 # 1) * j + (5 # 1) * m + (-27 # 1)) (H8 : 0 <= (2 # 1) * j + (-1 # 1) * m + (2 # 1)) (H9 : 0 <= (7 # 1) * j + (10 # 1) * m + (-74 # 1)) (H10 : 0 <= (18 # 1) * j + (-139 # 1) * m + (1188 # 1)) (H11 : 0 <= 1 * i + (0 # 1)) (H13 : 0 <= (121 # 1) * i + (810 # 1) * j + (-7465 # 1) * m + (64350 # 1)), (( 1# 1) == (-2 # 1) * i + it). Proof. intros. psatzl Q. Qed. Goal forall x, -x^2 >= 0 -> x - 1 >= 0 -> False. Proof. intros. psatz Q 3. Qed. Lemma motzkin' : forall x y, (x^2+y^2+1)*(x^2*y^4 + x^4*y^2 + 1 - (3 # 1) *x^2*y^2) >= 0. Proof. intros ; psatz Q 3. Qed. coq-8.4pl4/test-suite/typeclasses/0000755000175000017500000000000012326224777016300 5ustar stephstephcoq-8.4pl4/test-suite/typeclasses/unification_delta.v0000644000175000017500000000205012326224777022145 0ustar stephstephRequire Import Coq.Classes.Equivalence. Require Import Coq.Program.Program. Ltac obligations_tactic ::= program_simpl ; simpl_relation. Lemma bla : forall [ ! Equivalence A (eqA : relation A) ] x y, eqA x y -> eqA y x. Proof. intros. rewrite H0. reflexivity. Defined. Lemma bla' : forall [ ! Equivalence A (eqA : relation A) ] x y, eqA x y -> eqA y x. Proof. intros. (* Need delta on [relation] to unify with the right lemmas. *) rewrite <- H0. reflexivity. Qed. Axiom euclid : nat -> { x : nat | x > 0 } -> nat. Definition eq_proj {A} {s : A -> Prop} : relation (sig s) := fun x y => `x = `y. Program Instance {A : Type} {s : A -> Prop} => Equivalence (sig s) eq_proj. Next Obligation. Proof. constructor ; red ; intros. reflexivity. Qed. Admit Obligations. Instance Morphism (eq ==> eq_proj ==> eq) euclid. Proof. Admitted. Goal forall (x : nat) (y : nat | y > 0) (z : nat | z > 0), eq_proj y z -> euclid x y = euclid x z. Proof. intros. (* Breaks if too much delta in unification *) rewrite H. reflexivity. Qed.coq-8.4pl4/test-suite/typeclasses/NewSetoid.v0000644000175000017500000000347212326224777020376 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ((not True -> True)) \/ True. intros. clrewrite H. clrewrite <- H. right ; auto. Defined. Definition reduced_thm := Eval compute in Unnamed_thm. (* Print reduced_thm. *) Lemma foo [ Setoid a R ] : True. (* forall x y, R x y -> x -> y. *) Proof. intros. Print respect2. pose setoid_morphism. pose (respect2 (b0:=b)). simpl in b0. unfold binary_respectful in b0. pose (arrow_morphism R). pose (respect2 (b0:=b1)). unfold binary_respectful in b2. pose (eq_morphism (A:=a)). pose (respect2 (b0:=b3)). unfold binary_respectful in b4. exact I. Qed. Goal forall A B C (H : A <-> B) (H' : B <-> C), A /\ B <-> B /\ C. intros. Set Printing All. Print iff_morphism. clrewrite H. clrewrite H'. reflexivity. Defined. Goal forall A B C (H : A <-> B) (H' : B <-> C), A /\ B <-> B /\ C. intros. rewrite H. rewrite H'. reflexivity. Defined. Require Import Setoid_tac. Require Import Setoid_Prop. (* Print Unnamed_thm0. *) (* Print Unnamed_thm1. *) coq-8.4pl4/test-suite/typeclasses/clrewrite.v0000644000175000017500000000352112326224777020470 0ustar stephsteph Set Implicit Arguments. Unset Strict Implicit. Require Import Coq.Classes.Equivalence. Section Equiv. Context [ Equivalence A eqA ]. Variables x y z w : A. Goal eqA x y -> eqA y x. intros H ; clrewrite H. refl. Qed. Tactic Notation "simpl" "*" := auto || relation_tac. Goal eqA x y -> eqA y x /\ True. intros H ; clrewrite H. split ; simpl*. Qed. Goal eqA x y -> eqA y x /\ eqA x x. intros H ; clrewrite H. split ; simpl*. Qed. Goal eqA x y -> eqA y z -> eqA x y. intros H. clrewrite H. intro. refl. Qed. Goal eqA x y -> eqA z y -> eqA x y. intros H. clrewrite <- H at 2. clrewrite <- H at 1. intro. refl. Qed. Opaque complement. Print iff_inverse_impl_binary_morphism. Goal eqA x y -> eqA x y -> eqA x y. intros H. clrewrite H. intro. refl. Qed. Goal eqA x y -> eqA x y -> eqA x y. intros H. clrewrite <- H. refl. Qed. Goal eqA x y -> True /\ True /\ False /\ eqA x x -> True /\ True /\ False /\ eqA x y. Proof. intros. clrewrite <- H. apply H0. Qed. End Equiv. Section Trans. Context [ Transitive A R ]. Variables x y z w : A. Tactic Notation "simpl" "*" := auto || relation_tac. (* Typeclasses eauto := debug. *) Goal R x y -> R y x -> R y y -> R x x. Proof with auto. intros H H' H''. clrewrite <- H' at 2. clrewrite H at 1... Qed. Goal R x y -> R y z -> R x z. intros H. clrewrite H. refl. Qed. Goal R x y -> R z y -> R x y. intros H. clrewrite <- H at 2. intro. clrewrite H at 1. Abort. Goal R x y -> True /\ R y z -> True /\ R x z. Proof. intros. clrewrite H. apply H0. Qed. Goal R x y -> True /\ True /\ False /\ R y z -> True /\ True /\ False /\ R x z. Proof. intros. clrewrite H. apply H0. Qed. End Trans. coq-8.4pl4/test-suite/bench/0000755000175000017500000000000012365131024015001 5ustar stephstephcoq-8.4pl4/test-suite/bench/lists-100.v0000644000175000017500000001774512326224777016661 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* list0 -> list0. Inductive list1 : Set := nil1 : list1 | cons1 : Set -> list1 -> list1. Inductive list2 : Set := nil2 : list2 | cons2 : Set -> list2 -> list2. Inductive list3 : Set := nil3 : list3 | cons3 : Set -> list3 -> list3. Inductive list4 : Set := nil4 : list4 | cons4 : Set -> list4 -> list4. Inductive list5 : Set := nil5 : list5 | cons5 : Set -> list5 -> list5. Inductive list6 : Set := nil6 : list6 | cons6 : Set -> list6 -> list6. Inductive list7 : Set := nil7 : list7 | cons7 : Set -> list7 -> list7. Inductive list8 : Set := nil8 : list8 | cons8 : Set -> list8 -> list8. Inductive list9 : Set := nil9 : list9 | cons9 : Set -> list9 -> list9. Inductive list10 : Set := nil10 : list10 | cons10 : Set -> list10 -> list10. Inductive list11 : Set := nil11 : list11 | cons11 : Set -> list11 -> list11. Inductive list12 : Set := nil12 : list12 | cons12 : Set -> list12 -> list12. Inductive list13 : Set := nil13 : list13 | cons13 : Set -> list13 -> list13. Inductive list14 : Set := nil14 : list14 | cons14 : Set -> list14 -> list14. Inductive list15 : Set := nil15 : list15 | cons15 : Set -> list15 -> list15. Inductive list16 : Set := nil16 : list16 | cons16 : Set -> list16 -> list16. Inductive list17 : Set := nil17 : list17 | cons17 : Set -> list17 -> list17. Inductive list18 : Set := nil18 : list18 | cons18 : Set -> list18 -> list18. Inductive list19 : Set := nil19 : list19 | cons19 : Set -> list19 -> list19. Inductive list20 : Set := nil20 : list20 | cons20 : Set -> list20 -> list20. Inductive list21 : Set := nil21 : list21 | cons21 : Set -> list21 -> list21. Inductive list22 : Set := nil22 : list22 | cons22 : Set -> list22 -> list22. Inductive list23 : Set := nil23 : list23 | cons23 : Set -> list23 -> list23. Inductive list24 : Set := nil24 : list24 | cons24 : Set -> list24 -> list24. Inductive list25 : Set := nil25 : list25 | cons25 : Set -> list25 -> list25. Inductive list26 : Set := nil26 : list26 | cons26 : Set -> list26 -> list26. Inductive list27 : Set := nil27 : list27 | cons27 : Set -> list27 -> list27. Inductive list28 : Set := nil28 : list28 | cons28 : Set -> list28 -> list28. Inductive list29 : Set := nil29 : list29 | cons29 : Set -> list29 -> list29. Inductive list30 : Set := nil30 : list30 | cons30 : Set -> list30 -> list30. Inductive list31 : Set := nil31 : list31 | cons31 : Set -> list31 -> list31. Inductive list32 : Set := nil32 : list32 | cons32 : Set -> list32 -> list32. Inductive list33 : Set := nil33 : list33 | cons33 : Set -> list33 -> list33. Inductive list34 : Set := nil34 : list34 | cons34 : Set -> list34 -> list34. Inductive list35 : Set := nil35 : list35 | cons35 : Set -> list35 -> list35. Inductive list36 : Set := nil36 : list36 | cons36 : Set -> list36 -> list36. Inductive list37 : Set := nil37 : list37 | cons37 : Set -> list37 -> list37. Inductive list38 : Set := nil38 : list38 | cons38 : Set -> list38 -> list38. Inductive list39 : Set := nil39 : list39 | cons39 : Set -> list39 -> list39. Inductive list40 : Set := nil40 : list40 | cons40 : Set -> list40 -> list40. Inductive list41 : Set := nil41 : list41 | cons41 : Set -> list41 -> list41. Inductive list42 : Set := nil42 : list42 | cons42 : Set -> list42 -> list42. Inductive list43 : Set := nil43 : list43 | cons43 : Set -> list43 -> list43. Inductive list44 : Set := nil44 : list44 | cons44 : Set -> list44 -> list44. Inductive list45 : Set := nil45 : list45 | cons45 : Set -> list45 -> list45. Inductive list46 : Set := nil46 : list46 | cons46 : Set -> list46 -> list46. Inductive list47 : Set := nil47 : list47 | cons47 : Set -> list47 -> list47. Inductive list48 : Set := nil48 : list48 | cons48 : Set -> list48 -> list48. Inductive list49 : Set := nil49 : list49 | cons49 : Set -> list49 -> list49. Inductive list50 : Set := nil50 : list50 | cons50 : Set -> list50 -> list50. Inductive list51 : Set := nil51 : list51 | cons51 : Set -> list51 -> list51. Inductive list52 : Set := nil52 : list52 | cons52 : Set -> list52 -> list52. Inductive list53 : Set := nil53 : list53 | cons53 : Set -> list53 -> list53. Inductive list54 : Set := nil54 : list54 | cons54 : Set -> list54 -> list54. Inductive list55 : Set := nil55 : list55 | cons55 : Set -> list55 -> list55. Inductive list56 : Set := nil56 : list56 | cons56 : Set -> list56 -> list56. Inductive list57 : Set := nil57 : list57 | cons57 : Set -> list57 -> list57. Inductive list58 : Set := nil58 : list58 | cons58 : Set -> list58 -> list58. Inductive list59 : Set := nil59 : list59 | cons59 : Set -> list59 -> list59. Inductive list60 : Set := nil60 : list60 | cons60 : Set -> list60 -> list60. Inductive list61 : Set := nil61 : list61 | cons61 : Set -> list61 -> list61. Inductive list62 : Set := nil62 : list62 | cons62 : Set -> list62 -> list62. Inductive list63 : Set := nil63 : list63 | cons63 : Set -> list63 -> list63. Inductive list64 : Set := nil64 : list64 | cons64 : Set -> list64 -> list64. Inductive list65 : Set := nil65 : list65 | cons65 : Set -> list65 -> list65. Inductive list66 : Set := nil66 : list66 | cons66 : Set -> list66 -> list66. Inductive list67 : Set := nil67 : list67 | cons67 : Set -> list67 -> list67. Inductive list68 : Set := nil68 : list68 | cons68 : Set -> list68 -> list68. Inductive list69 : Set := nil69 : list69 | cons69 : Set -> list69 -> list69. Inductive list70 : Set := nil70 : list70 | cons70 : Set -> list70 -> list70. Inductive list71 : Set := nil71 : list71 | cons71 : Set -> list71 -> list71. Inductive list72 : Set := nil72 : list72 | cons72 : Set -> list72 -> list72. Inductive list73 : Set := nil73 : list73 | cons73 : Set -> list73 -> list73. Inductive list74 : Set := nil74 : list74 | cons74 : Set -> list74 -> list74. Inductive list75 : Set := nil75 : list75 | cons75 : Set -> list75 -> list75. Inductive list76 : Set := nil76 : list76 | cons76 : Set -> list76 -> list76. Inductive list77 : Set := nil77 : list77 | cons77 : Set -> list77 -> list77. Inductive list78 : Set := nil78 : list78 | cons78 : Set -> list78 -> list78. Inductive list79 : Set := nil79 : list79 | cons79 : Set -> list79 -> list79. Inductive list80 : Set := nil80 : list80 | cons80 : Set -> list80 -> list80. Inductive list81 : Set := nil81 : list81 | cons81 : Set -> list81 -> list81. Inductive list82 : Set := nil82 : list82 | cons82 : Set -> list82 -> list82. Inductive list83 : Set := nil83 : list83 | cons83 : Set -> list83 -> list83. Inductive list84 : Set := nil84 : list84 | cons84 : Set -> list84 -> list84. Inductive list85 : Set := nil85 : list85 | cons85 : Set -> list85 -> list85. Inductive list86 : Set := nil86 : list86 | cons86 : Set -> list86 -> list86. Inductive list87 : Set := nil87 : list87 | cons87 : Set -> list87 -> list87. Inductive list88 : Set := nil88 : list88 | cons88 : Set -> list88 -> list88. Inductive list89 : Set := nil89 : list89 | cons89 : Set -> list89 -> list89. Inductive list90 : Set := nil90 : list90 | cons90 : Set -> list90 -> list90. Inductive list91 : Set := nil91 : list91 | cons91 : Set -> list91 -> list91. Inductive list92 : Set := nil92 : list92 | cons92 : Set -> list92 -> list92. Inductive list93 : Set := nil93 : list93 | cons93 : Set -> list93 -> list93. Inductive list94 : Set := nil94 : list94 | cons94 : Set -> list94 -> list94. Inductive list95 : Set := nil95 : list95 | cons95 : Set -> list95 -> list95. Inductive list96 : Set := nil96 : list96 | cons96 : Set -> list96 -> list96. Inductive list97 : Set := nil97 : list97 | cons97 : Set -> list97 -> list97. Inductive list98 : Set := nil98 : list98 | cons98 : Set -> list98 -> list98. Inductive list99 : Set := nil99 : list99 | cons99 : Set -> list99 -> list99. coq-8.4pl4/test-suite/bench/lists_100.v0000644000175000017500000001774512326224777016743 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* list0 -> list0. Inductive list1 : Set := nil1 : list1 | cons1 : Set -> list1 -> list1. Inductive list2 : Set := nil2 : list2 | cons2 : Set -> list2 -> list2. Inductive list3 : Set := nil3 : list3 | cons3 : Set -> list3 -> list3. Inductive list4 : Set := nil4 : list4 | cons4 : Set -> list4 -> list4. Inductive list5 : Set := nil5 : list5 | cons5 : Set -> list5 -> list5. Inductive list6 : Set := nil6 : list6 | cons6 : Set -> list6 -> list6. Inductive list7 : Set := nil7 : list7 | cons7 : Set -> list7 -> list7. Inductive list8 : Set := nil8 : list8 | cons8 : Set -> list8 -> list8. Inductive list9 : Set := nil9 : list9 | cons9 : Set -> list9 -> list9. Inductive list10 : Set := nil10 : list10 | cons10 : Set -> list10 -> list10. Inductive list11 : Set := nil11 : list11 | cons11 : Set -> list11 -> list11. Inductive list12 : Set := nil12 : list12 | cons12 : Set -> list12 -> list12. Inductive list13 : Set := nil13 : list13 | cons13 : Set -> list13 -> list13. Inductive list14 : Set := nil14 : list14 | cons14 : Set -> list14 -> list14. Inductive list15 : Set := nil15 : list15 | cons15 : Set -> list15 -> list15. Inductive list16 : Set := nil16 : list16 | cons16 : Set -> list16 -> list16. Inductive list17 : Set := nil17 : list17 | cons17 : Set -> list17 -> list17. Inductive list18 : Set := nil18 : list18 | cons18 : Set -> list18 -> list18. Inductive list19 : Set := nil19 : list19 | cons19 : Set -> list19 -> list19. Inductive list20 : Set := nil20 : list20 | cons20 : Set -> list20 -> list20. Inductive list21 : Set := nil21 : list21 | cons21 : Set -> list21 -> list21. Inductive list22 : Set := nil22 : list22 | cons22 : Set -> list22 -> list22. Inductive list23 : Set := nil23 : list23 | cons23 : Set -> list23 -> list23. Inductive list24 : Set := nil24 : list24 | cons24 : Set -> list24 -> list24. Inductive list25 : Set := nil25 : list25 | cons25 : Set -> list25 -> list25. Inductive list26 : Set := nil26 : list26 | cons26 : Set -> list26 -> list26. Inductive list27 : Set := nil27 : list27 | cons27 : Set -> list27 -> list27. Inductive list28 : Set := nil28 : list28 | cons28 : Set -> list28 -> list28. Inductive list29 : Set := nil29 : list29 | cons29 : Set -> list29 -> list29. Inductive list30 : Set := nil30 : list30 | cons30 : Set -> list30 -> list30. Inductive list31 : Set := nil31 : list31 | cons31 : Set -> list31 -> list31. Inductive list32 : Set := nil32 : list32 | cons32 : Set -> list32 -> list32. Inductive list33 : Set := nil33 : list33 | cons33 : Set -> list33 -> list33. Inductive list34 : Set := nil34 : list34 | cons34 : Set -> list34 -> list34. Inductive list35 : Set := nil35 : list35 | cons35 : Set -> list35 -> list35. Inductive list36 : Set := nil36 : list36 | cons36 : Set -> list36 -> list36. Inductive list37 : Set := nil37 : list37 | cons37 : Set -> list37 -> list37. Inductive list38 : Set := nil38 : list38 | cons38 : Set -> list38 -> list38. Inductive list39 : Set := nil39 : list39 | cons39 : Set -> list39 -> list39. Inductive list40 : Set := nil40 : list40 | cons40 : Set -> list40 -> list40. Inductive list41 : Set := nil41 : list41 | cons41 : Set -> list41 -> list41. Inductive list42 : Set := nil42 : list42 | cons42 : Set -> list42 -> list42. Inductive list43 : Set := nil43 : list43 | cons43 : Set -> list43 -> list43. Inductive list44 : Set := nil44 : list44 | cons44 : Set -> list44 -> list44. Inductive list45 : Set := nil45 : list45 | cons45 : Set -> list45 -> list45. Inductive list46 : Set := nil46 : list46 | cons46 : Set -> list46 -> list46. Inductive list47 : Set := nil47 : list47 | cons47 : Set -> list47 -> list47. Inductive list48 : Set := nil48 : list48 | cons48 : Set -> list48 -> list48. Inductive list49 : Set := nil49 : list49 | cons49 : Set -> list49 -> list49. Inductive list50 : Set := nil50 : list50 | cons50 : Set -> list50 -> list50. Inductive list51 : Set := nil51 : list51 | cons51 : Set -> list51 -> list51. Inductive list52 : Set := nil52 : list52 | cons52 : Set -> list52 -> list52. Inductive list53 : Set := nil53 : list53 | cons53 : Set -> list53 -> list53. Inductive list54 : Set := nil54 : list54 | cons54 : Set -> list54 -> list54. Inductive list55 : Set := nil55 : list55 | cons55 : Set -> list55 -> list55. Inductive list56 : Set := nil56 : list56 | cons56 : Set -> list56 -> list56. Inductive list57 : Set := nil57 : list57 | cons57 : Set -> list57 -> list57. Inductive list58 : Set := nil58 : list58 | cons58 : Set -> list58 -> list58. Inductive list59 : Set := nil59 : list59 | cons59 : Set -> list59 -> list59. Inductive list60 : Set := nil60 : list60 | cons60 : Set -> list60 -> list60. Inductive list61 : Set := nil61 : list61 | cons61 : Set -> list61 -> list61. Inductive list62 : Set := nil62 : list62 | cons62 : Set -> list62 -> list62. Inductive list63 : Set := nil63 : list63 | cons63 : Set -> list63 -> list63. Inductive list64 : Set := nil64 : list64 | cons64 : Set -> list64 -> list64. Inductive list65 : Set := nil65 : list65 | cons65 : Set -> list65 -> list65. Inductive list66 : Set := nil66 : list66 | cons66 : Set -> list66 -> list66. Inductive list67 : Set := nil67 : list67 | cons67 : Set -> list67 -> list67. Inductive list68 : Set := nil68 : list68 | cons68 : Set -> list68 -> list68. Inductive list69 : Set := nil69 : list69 | cons69 : Set -> list69 -> list69. Inductive list70 : Set := nil70 : list70 | cons70 : Set -> list70 -> list70. Inductive list71 : Set := nil71 : list71 | cons71 : Set -> list71 -> list71. Inductive list72 : Set := nil72 : list72 | cons72 : Set -> list72 -> list72. Inductive list73 : Set := nil73 : list73 | cons73 : Set -> list73 -> list73. Inductive list74 : Set := nil74 : list74 | cons74 : Set -> list74 -> list74. Inductive list75 : Set := nil75 : list75 | cons75 : Set -> list75 -> list75. Inductive list76 : Set := nil76 : list76 | cons76 : Set -> list76 -> list76. Inductive list77 : Set := nil77 : list77 | cons77 : Set -> list77 -> list77. Inductive list78 : Set := nil78 : list78 | cons78 : Set -> list78 -> list78. Inductive list79 : Set := nil79 : list79 | cons79 : Set -> list79 -> list79. Inductive list80 : Set := nil80 : list80 | cons80 : Set -> list80 -> list80. Inductive list81 : Set := nil81 : list81 | cons81 : Set -> list81 -> list81. Inductive list82 : Set := nil82 : list82 | cons82 : Set -> list82 -> list82. Inductive list83 : Set := nil83 : list83 | cons83 : Set -> list83 -> list83. Inductive list84 : Set := nil84 : list84 | cons84 : Set -> list84 -> list84. Inductive list85 : Set := nil85 : list85 | cons85 : Set -> list85 -> list85. Inductive list86 : Set := nil86 : list86 | cons86 : Set -> list86 -> list86. Inductive list87 : Set := nil87 : list87 | cons87 : Set -> list87 -> list87. Inductive list88 : Set := nil88 : list88 | cons88 : Set -> list88 -> list88. Inductive list89 : Set := nil89 : list89 | cons89 : Set -> list89 -> list89. Inductive list90 : Set := nil90 : list90 | cons90 : Set -> list90 -> list90. Inductive list91 : Set := nil91 : list91 | cons91 : Set -> list91 -> list91. Inductive list92 : Set := nil92 : list92 | cons92 : Set -> list92 -> list92. Inductive list93 : Set := nil93 : list93 | cons93 : Set -> list93 -> list93. Inductive list94 : Set := nil94 : list94 | cons94 : Set -> list94 -> list94. Inductive list95 : Set := nil95 : list95 | cons95 : Set -> list95 -> list95. Inductive list96 : Set := nil96 : list96 | cons96 : Set -> list96 -> list96. Inductive list97 : Set := nil97 : list97 | cons97 : Set -> list97 -> list97. Inductive list98 : Set := nil98 : list98 | cons98 : Set -> list98 -> list98. Inductive list99 : Set := nil99 : list99 | cons99 : Set -> list99 -> list99. coq-8.4pl4/test-suite/failure/0000755000175000017500000000000012365131024015351 5ustar stephstephcoq-8.4pl4/test-suite/failure/evarclear2.v0000644000175000017500000000031512326224777017604 0ustar stephstephSet Printing Existential Instances. Set Printing All. Goal let y:=0 in exists x:y=y, x = x. intros. eexists. rename y into z. unfold z at 1 2. (* should fail because the evar type depends on z *) clear z. coq-8.4pl4/test-suite/failure/prop-set-proof-irrelevance.v0000644000175000017500000000046712326224777022757 0ustar stephstephRequire Import ProofIrrelevance. Lemma proof_irrelevance_set : forall (P : Set) (p1 p2 : P), p1 = p2. exact proof_irrelevance. Qed. Lemma paradox : False. assert (H : 0 <> 1) by discriminate. apply H. Fail apply proof_irrelevance. (* inlined version is rejected *) apply proof_irrelevance_set. Qed. coq-8.4pl4/test-suite/failure/guard.v0000644000175000017500000000153012326224777016660 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* nat) := f1 in let _ := 0 in let _ := 0 in let g (f1 f2:nat->nat) := f2 in let h := f in (* h = Rel 4 *) fix F (n:nat) : nat := h F S n. (* here Rel 4 = g *) coq-8.4pl4/test-suite/failure/subtyping.v0000644000175000017500000000037312326224777017606 0ustar stephsteph(* A variant of bug #1302 that must fail *) Module Type T. Parameter A : Type. Inductive L : Prop := | L0 | L1 : (A -> Prop) -> L. End T. Module TT : T. Parameter A : Type. Inductive L : Type := | L0 | L1 : (A -> Prop) -> L. End TT. coq-8.4pl4/test-suite/failure/Case4.v0000644000175000017500000000021012326224777016507 0ustar stephsteph Definition Berry (x y z : bool) := match x, y, z with | true, false, _ => 0 | false, _, true => 1 | _, true, false => 2 end. coq-8.4pl4/test-suite/failure/Case13.v0000644000175000017500000000021412326224777016573 0ustar stephstephType (fun x : nat => match x return nat with | S x as b => match x with | x => S b x end end). coq-8.4pl4/test-suite/failure/clashes.v0000644000175000017500000000030612326224777017200 0ustar stephsteph(* Submitted by David Nowak *) (* Simpler to forbid the definition of n as a global than to write it S.n to keep n accessible... *) Section S. Variable n : nat. Inductive P : Set := n : P. coq-8.4pl4/test-suite/failure/pattern.v0000644000175000017500000000030312326224777017230 0ustar stephsteph(* Check that untypable beta-expansion are trapped *) Variable A : nat -> Type. Variable n : nat. Variable P : forall m : nat, m = n -> Prop. Goal forall p : n = n, P n p. intro. pattern n, p. coq-8.4pl4/test-suite/failure/inductive3.v0000644000175000017500000000037512326224777017641 0ustar stephsteph(* Check that the nested inductive types positivity check avoids recursively non uniform parameters (at least if these parameters break positivity) *) Inductive t (A:Type) : Type := c : t (A -> A) -> t A. Inductive u : Type := d : u | e : t u -> u. coq-8.4pl4/test-suite/failure/circular_subtyping2.v0000644000175000017500000000035312326224777021552 0ustar stephsteph(*subtyping verification in presence of pseudo-circularity at functor application *) Module Type S. End S. Module Type T. Declare Module M:S. End T. Module N:S. End N. Module F (X:S) (Y:T with Module M:=X). End F. Module G := F N N.coq-8.4pl4/test-suite/failure/universes-sections2.v0000644000175000017500000000033212326224777021507 0ustar stephsteph(* Check that constraints on locals are preserved by discharging *) Definition Type2 := Type. Section A. Let Type1 : Type2 := Type. Definition Type1' := Type1. End A. Definition Inconsistency : Type1' := Type2. coq-8.4pl4/test-suite/failure/Notations.v0000644000175000017500000000021712326224777017535 0ustar stephsteph(* Submitted by Roland Zumkeller *) Notation "! A" := (forall i:nat, A) (at level 60). (* Should fail: no dynamic capture *) Check ! (i=i). coq-8.4pl4/test-suite/failure/Sections.v0000644000175000017500000000004312326224777017343 0ustar stephstephModule A. Section B. End A. End A. coq-8.4pl4/test-suite/failure/ltac2.v0000644000175000017500000000023012326224777016557 0ustar stephsteph(* Check that Match arguments are forbidden *) Ltac E x := apply x. Goal True -> True. E ltac:(match goal with | |- _ => intro H end). coq-8.4pl4/test-suite/failure/inductive1.v0000644000175000017500000000026312326224777017633 0ustar stephsteph(* A check that sort-polymorphic product is not set too low *) Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B. Check (fun (A:Type) (B:Prop) => (prod A B : Prop)). coq-8.4pl4/test-suite/failure/Case6.v0000644000175000017500000000027312326224777016522 0ustar stephstephInductive List (A : Set) : Set := | Nil : List A | Cons : A -> List A -> List A. Type (match Nil nat return List nat with | NIL => NIL | (CONS _ _) => NIL end). coq-8.4pl4/test-suite/failure/circular_subtyping1.v0000644000175000017500000000033712326224777021553 0ustar stephsteph(* subtyping verification in presence of pseudo-circularity*) Module Type S. End S. Module Type T. Declare Module M:S. End T. Module N:S. End N. Module NN <: T. Module M:=N. End NN. Module P <: T with Module M:=NN := NN. coq-8.4pl4/test-suite/failure/Case7.v0000644000175000017500000000070312326224777016521 0ustar stephstephInductive listn : nat -> Set := | niln : listn 0 | consn : forall n : nat, nat -> listn n -> listn (S n). Definition length1 (n : nat) (l : listn n) := match l with | consn n _ (consn m _ _) => S (S m) | consn n _ _ => 1 | _ => 0 end. Type (fun (n : nat) (l : listn n) => match n return nat with | O => 0 | S n => match l return nat with | niln => 1 | l' => length1 (S n) l' end end). coq-8.4pl4/test-suite/failure/rewrite_in_hyp.v0000644000175000017500000000016312326224777020606 0ustar stephstephGoal forall (T1 T2 : Type) (f:T1 -> Prop) (x:T1) (H:T1=T2), f x -> 0=1. intros T1 T2 f x H fx. rewrite H in x. coq-8.4pl4/test-suite/failure/Case3.v0000644000175000017500000000027512326224777016521 0ustar stephstephInductive List (A : Set) : Set := | Nil : List A | Cons : A -> List A -> List A. Type (fun l : List nat => match l return nat with | Nil nat => 0 | Cons a l => S a end). coq-8.4pl4/test-suite/failure/Case12.v0000644000175000017500000000021112326224777016567 0ustar stephsteph Type (fun x : nat => match x return nat with | S x as b => match x with | x => x end end). coq-8.4pl4/test-suite/failure/Case10.v0000644000175000017500000000015712326224777016576 0ustar stephstephType (fun x : nat => match x return nat with | S x as b => S b end). coq-8.4pl4/test-suite/failure/rewrite_in_hyp2.v0000644000175000017500000000050112326224777020664 0ustar stephsteph(* Until revision 10221, rewriting in hypotheses of the form "(fun x => phi(x)) t" with "t" not rewritable used to behave as a beta-normalization tactic instead of raising the expected message "nothing to rewrite" *) Goal forall b, S b = O -> (fun a => 0 = (S a)) b -> True. intros b H H0. rewrite H in H0. coq-8.4pl4/test-suite/failure/inductive2.v0000644000175000017500000000026312326224777017634 0ustar stephsteph(* A check that sort-polymorphic product is not set too low *) Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B. Check (fun (A:Prop) (B:Type) => (prod A B : Prop)). coq-8.4pl4/test-suite/failure/univ_include.v0000644000175000017500000000101312326224777020236 0ustar stephstephDefinition T := Type. Definition U := Type. Module Type MT. Parameter t : T. End MT. Module Type MU. Parameter t : U. End MU. Module F (E : MT). Definition elt :T := E.t. End F. Module G (E : MU). Include F E. Print Universes. (* U <= T *) End G. Print Universes. (* Check if constraint is lost *) Module Mt. Definition t := T. End Mt. Module P := G Mt. (* should yield Universe inconsistency *) (* ... otherwise the following command will show that T has type T! *) Eval cbv delta [P.elt Mt.t] in P.elt. coq-8.4pl4/test-suite/failure/Case5.v0000644000175000017500000000023712326224777016521 0ustar stephstephInductive MS : Set := | X : MS -> MS | Y : MS -> MS. Type (fun p : MS => match p return nat with | X x => 0 end). coq-8.4pl4/test-suite/failure/universes3.v0000644000175000017500000000223712326224777017671 0ustar stephsteph(* This example (found by coqchk) checks that an inductive cannot be polymorphic if its constructors induce upper universe constraints. Here: I cannot be polymorphic because its type is less than the type of the argument of impl. *) Definition Type1 := Type. Definition Type3 : Type1 := Type. (* Type3 < Type1 *) Definition Type4 := Type. Definition impl (A B:Type3) : Type4 := A->B. (* Type3 <= Type4 *) Inductive I (B:Type (*6*)) := C : B -> impl Prop (I B). (* Type(6) <= Type(7) because I contains, via C, elements in B Type(7) <= Type3 because (I B) is argument of impl Type(4) <= Type(7) because type of C less than I (see remark below) where Type(7) is the auxiliary level used to infer the type of I *) (* We cannot enforce Type1 < Type(6) while we already have Type(6) <= Type(7) < Type3 < Type1 *) Definition J := I Type1. (* Open question: should the type of an inductive be the max of the types of the _arguments_ of its constructors (here B and Prop, after unfolding of impl), or of the max of types of the constructors itself (here B -> impl Prop (I B)), as done above. *) coq-8.4pl4/test-suite/failure/Case1.v0000644000175000017500000000007012326224777016510 0ustar stephstephType match 0 with | x => 0 | O => 1 end. coq-8.4pl4/test-suite/failure/Case14.v0000644000175000017500000000030712326224777016577 0ustar stephstephInductive List (A : Set) : Set := | Nil : List A | Cons : A -> List A -> List A. Definition NIL := Nil nat. Type match Nil nat return (List nat) with | NIL => NIL | _ => NIL end. coq-8.4pl4/test-suite/failure/cases.v0000644000175000017500000000022612326224777016655 0ustar stephsteph(* Non exhaustive pattern-matching *) Check (fun x => match x, x with | O, S (S y) => true | O, S x => false | S y, O => true end). coq-8.4pl4/test-suite/failure/Case8.v0000644000175000017500000000025512326224777016524 0ustar stephstephInductive List (A : Set) : Set := | Nil : List A | Cons : A -> List A -> List A. Type match Nil nat return nat with | b => b | Cons _ _ _ as d => d end. coq-8.4pl4/test-suite/failure/Case2.v0000644000175000017500000000040612326224777016514 0ustar stephstephInductive IFExpr : Set := | Var : nat -> IFExpr | Tr : IFExpr | Fa : IFExpr | IfE : IFExpr -> IFExpr -> IFExpr -> IFExpr. Type (fun F : IFExpr => match F return Prop with | IfE (Var _) H I => True | IfE _ _ _ => False | _ => True end). coq-8.4pl4/test-suite/failure/evarlemma.v0000644000175000017500000000013012326224777017522 0ustar stephsteph(* Check success of inference of evars in the context of lemmas *) Lemma foo x : True. coq-8.4pl4/test-suite/failure/illtype1.v0000644000175000017500000000103212326224777017316 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* X0 -> Prop}. (* X0: Type_j' *) Variable i0' : forall X0 : Type, (X0 -> X0 -> Prop) -> A0. End S. Module M. Record A0 : Type := (* Type_i' *) i0 {X0 : Type; R0 : X0 -> X0 -> Prop}. (* X0: Type_j' *) Definition i0' := i0 : forall X0 : Type, (X0 -> X0 -> Prop) -> A0. End M. (* The rest of this file formalizes Burali-Forti paradox *) (* (if the constraint between i0' and A0 is lost, the proof goes through) *) Inductive ACC (A : Type) (R : A -> A -> Prop) : A -> Prop := ACC_intro : forall x : A, (forall y : A, R y x -> ACC A R y) -> ACC A R x. Lemma ACC_nonreflexive : forall (A : Type) (R : A -> A -> Prop) (x : A), ACC A R x -> R x x -> False. simple induction 1; intros. exact (H1 x0 H2 H2). Qed. Definition WF (A : Type) (R : A -> A -> Prop) := forall x : A, ACC A R x. Section Inverse_Image. Variables (A B : Type) (R : B -> B -> Prop) (f : A -> B). Definition Rof (x y : A) : Prop := R (f x) (f y). Remark ACC_lemma : forall y : B, ACC B R y -> forall x : A, y = f x -> ACC A Rof x. simple induction 1; intros. constructor; intros. apply (H1 (f y0)); trivial. elim H2 using eq_ind_r; trivial. Qed. Lemma ACC_inverse_image : forall x : A, ACC B R (f x) -> ACC A Rof x. intros; apply (ACC_lemma (f x)); trivial. Qed. Lemma WF_inverse_image : WF B R -> WF A Rof. red; intros; apply ACC_inverse_image; auto. Qed. End Inverse_Image. Section Burali_Forti_Paradox. Definition morphism (A : Type) (R : A -> A -> Prop) (B : Type) (S : B -> B -> Prop) (f : A -> B) := forall x y : A, R x y -> S (f x) (f y). (* The hypothesis of the paradox: assumes there exists an universal system of notations, i.e: - A type A0 - An injection i0 from relations on any type into A0 - The proof that i0 is injective modulo morphism *) Variable A0 : Type. (* Type_i *) Variable i0 : forall X : Type, (X -> X -> Prop) -> A0. (* X: Type_j *) Hypothesis inj : forall (X1 : Type) (R1 : X1 -> X1 -> Prop) (X2 : Type) (R2 : X2 -> X2 -> Prop), i0 X1 R1 = i0 X2 R2 -> exists f : X1 -> X2, morphism X1 R1 X2 R2 f. (* Embedding of x in y: x and y are images of 2 well founded relations R1 and R2, the ordinal of R2 being strictly greater than that of R1. *) Record emb (x y : A0) : Prop := {X1 : Type; R1 : X1 -> X1 -> Prop; eqx : x = i0 X1 R1; X2 : Type; R2 : X2 -> X2 -> Prop; eqy : y = i0 X2 R2; W2 : WF X2 R2; f : X1 -> X2; fmorph : morphism X1 R1 X2 R2 f; maj : X2; majf : forall z : X1, R2 (f z) maj}. Lemma emb_trans : forall x y z : A0, emb x y -> emb y z -> emb x z. intros. case H; intros. case H0; intros. generalize eqx0; clear eqx0. elim eqy using eq_ind_r; intro. case (inj _ _ _ _ eqx0); intros. exists X1 R1 X3 R3 (fun x : X1 => f0 (x0 (f x))) maj0; trivial. red; auto. Defined. Lemma ACC_emb : forall (X : Type) (R : X -> X -> Prop) (x : X), ACC X R x -> forall (Y : Type) (S : Y -> Y -> Prop) (f : Y -> X), morphism Y S X R f -> (forall y : Y, R (f y) x) -> ACC A0 emb (i0 Y S). simple induction 1; intros. constructor; intros. case H4; intros. elim eqx using eq_ind_r. case (inj X2 R2 Y S). apply sym_eq; assumption. intros. apply H1 with (y := f (x1 maj)) (f := fun x : X1 => f (x1 (f0 x))); try red; auto. Defined. (* The embedding relation is well founded *) Lemma WF_emb : WF A0 emb. constructor; intros. case H; intros. elim eqx using eq_ind_r. apply ACC_emb with (X := X2) (R := R2) (x := maj) (f := f); trivial. Defined. (* The following definition enforces Type_j >= Type_i *) Definition Omega : A0 := i0 A0 emb. Section Subsets. Variable a : A0. (* We define the type of elements of A0 smaller than a w.r.t embedding. The Record is in Type, but it is possible to avoid such structure. *) Record sub : Type := {witness : A0; emb_wit : emb witness a}. (* F is its image through i0 *) Definition F : A0 := i0 sub (Rof _ _ emb witness). (* F is embedded in Omega: - the witness projection is a morphism - a is an upper bound because emb_wit proves that witness is smaller than a. *) Lemma F_emb_Omega : emb F Omega. exists sub (Rof _ _ emb witness) A0 emb witness a; trivial. exact WF_emb. red; trivial. exact emb_wit. Defined. End Subsets. Definition fsub (a b : A0) (H : emb a b) (x : sub a) : sub b := Build_sub _ (witness _ x) (emb_trans _ _ _ (emb_wit _ x) H). (* F is a morphism: a < b => F(a) < F(b) - the morphism from F(a) to F(b) is fsub above - the upper bound is a, which is in F(b) since a < b *) Lemma F_morphism : morphism A0 emb A0 emb F. red; intros. exists (sub x) (Rof _ _ emb (witness x)) (sub y) (Rof _ _ emb (witness y)) (fsub x y H) (Build_sub _ x H); trivial. apply WF_inverse_image. exact WF_emb. unfold morphism, Rof, fsub; simpl; intros. trivial. unfold Rof, fsub; simpl; intros. apply emb_wit. Defined. (* Omega is embedded in itself: - F is a morphism - Omega is an upper bound of the image of F *) Lemma Omega_refl : emb Omega Omega. exists A0 emb A0 emb F Omega; trivial. exact WF_emb. exact F_morphism. exact F_emb_Omega. Defined. (* The paradox is that Omega cannot be embedded in itself, since the embedding relation is well founded. *) Theorem Burali_Forti : False. apply ACC_nonreflexive with A0 emb Omega. apply WF_emb. exact Omega_refl. Defined. End Burali_Forti_Paradox. Import M. (* Note: this proof uses a large elimination of A0. *) Lemma inj : forall (X1 : Type) (R1 : X1 -> X1 -> Prop) (X2 : Type) (R2 : X2 -> X2 -> Prop), i0' X1 R1 = i0' X2 R2 -> exists f : X1 -> X2, morphism X1 R1 X2 R2 f. intros. change match i0' X1 R1, i0' X2 R2 with | i0 x1 r1, i0 x2 r2 => exists f : _, morphism x1 r1 x2 r2 f end. case H; simpl. exists (fun x : X1 => x). red; trivial. Defined. (* The following command raises 'Error: Universe Inconsistency'. To allow large elimination of A0, i0 must not be a large constructor. Hence, the constraint Type_j' < Type_i' is added, which is incompatible with the constraint j >= i in the paradox. *) Definition Paradox : False := Burali_Forti A0 i0' inj. coq-8.4pl4/test-suite/failure/ClearBody.v0000644000175000017500000000035212326224777017423 0ustar stephsteph(* ClearBody must check that removing the body of definition does not invalidate the well-typabilility of the visible goal *) Goal True. set (n := 0) in *. set (I := refl_equal 0) in *. change (n = 0) in (type of I). clearbody n. coq-8.4pl4/test-suite/failure/inductive4.v0000644000175000017500000000101112326224777017626 0ustar stephsteph(* This used to succeed in versions 8.1 to 8.3 *) Require Import Logic. Require Hurkens. Definition Ti := Type. Inductive prod (X Y:Ti) := pair : X -> Y -> prod X Y. Definition B : Prop := let F := prod True in F Prop. (* Aie! *) Definition p2b (P:Prop) : B := pair True Prop I P. Definition b2p (b:B) : Prop := match b with pair _ P => P end. Lemma L1 : forall A : Prop, b2p (p2b A) -> A. Proof (fun A x => x). Lemma L2 : forall A : Prop, A -> b2p (p2b A). Proof (fun A x => x). Check Hurkens.paradox B p2b b2p L1 L2. coq-8.4pl4/test-suite/failure/Tauto.v0000644000175000017500000000162612326224777016660 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* forall x y : nat, x = y \/ x <> y. Proof. tauto. coq-8.4pl4/test-suite/failure/rewrite_in_goal.v0000644000175000017500000000014312326224777020726 0ustar stephstephGoal forall T1 T2 (H:T1=T2) (f:T1->Prop) (x:T1) , f x -> Type. intros until x. rewrite H in x. coq-8.4pl4/test-suite/failure/autorewritein.v0000644000175000017500000000060412326224777020460 0ustar stephstephVariable Ack : nat -> nat -> nat. Axiom Ack0 : forall m : nat, Ack 0 m = S m. Axiom Ack1 : forall n : nat, Ack (S n) 0 = Ack n 1. Axiom Ack2 : forall n m : nat, Ack (S n) (S m) = Ack n (Ack (S n) m). Hint Rewrite Ack0 Ack1 Ack2 : base0. Lemma ResAck2 : forall H:(Ack 2 2 = 7 -> False), H=H -> False. Proof. intros. autorewrite with base0 in * using try (apply H1;reflexivity). coq-8.4pl4/test-suite/failure/redef.v0000644000175000017500000000107512326224777016647 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* match x, x with | O, S (S y) => true | O, S x => false | S y, O => true end). coq-8.4pl4/test-suite/failure/universes-buraliforti-redef.v0000644000175000017500000001525112326224777023211 0ustar stephsteph(* A variant of Burali-Forti that used to pass in V8.1beta, because of a bug in the instantiation of sort-polymorphic inductive types *) (* The following type seems to satisfy the hypothesis of the paradox below *) (* It should infer constraints forbidding the paradox to go through, but via *) (* a redefinition that did not propagate constraints correctly in V8.1beta *) (* it was exploitable to derive an inconsistency *) (* We keep the file as a non regression test of the bug *) Record A1 (B:Type) (g:B->Type) : Type := (* Type_i' *) i1 {X0 : B; R0 : g X0 -> g X0 -> Prop}. (* X0: Type_j' *) Definition A2 := A1. (* here was the bug *) Definition A0 := (A2 Type (fun x => x)). Definition i0 := (i1 Type (fun x => x)). (* The rest is as in universes-buraliforti.v *) (* Some properties about relations on objects in Type *) Inductive ACC (A : Type) (R : A -> A -> Prop) : A -> Prop := ACC_intro : forall x : A, (forall y : A, R y x -> ACC A R y) -> ACC A R x. Lemma ACC_nonreflexive : forall (A : Type) (R : A -> A -> Prop) (x : A), ACC A R x -> R x x -> False. simple induction 1; intros. exact (H1 x0 H2 H2). Qed. Definition WF (A : Type) (R : A -> A -> Prop) := forall x : A, ACC A R x. Section Inverse_Image. Variables (A B : Type) (R : B -> B -> Prop) (f : A -> B). Definition Rof (x y : A) : Prop := R (f x) (f y). Remark ACC_lemma : forall y : B, ACC B R y -> forall x : A, y = f x -> ACC A Rof x. simple induction 1; intros. constructor; intros. apply (H1 (f y0)); trivial. elim H2 using eq_ind_r; trivial. Qed. Lemma ACC_inverse_image : forall x : A, ACC B R (f x) -> ACC A Rof x. intros; apply (ACC_lemma (f x)); trivial. Qed. Lemma WF_inverse_image : WF B R -> WF A Rof. red; intros; apply ACC_inverse_image; auto. Qed. End Inverse_Image. (* Remark: the paradox is written in Type, but also works in Prop or Set. *) Section Burali_Forti_Paradox. Definition morphism (A : Type) (R : A -> A -> Prop) (B : Type) (S : B -> B -> Prop) (f : A -> B) := forall x y : A, R x y -> S (f x) (f y). (* The hypothesis of the paradox: assumes there exists an universal system of notations, i.e: - A type A0 - An injection i0 from relations on any type into A0 - The proof that i0 is injective modulo morphism *) Variable A0 : Type. (* Type_i *) Variable i0 : forall X : Type, (X -> X -> Prop) -> A0. (* X: Type_j *) Hypothesis inj : forall (X1 : Type) (R1 : X1 -> X1 -> Prop) (X2 : Type) (R2 : X2 -> X2 -> Prop), i0 X1 R1 = i0 X2 R2 -> exists f : X1 -> X2, morphism X1 R1 X2 R2 f. (* Embedding of x in y: x and y are images of 2 well founded relations R1 and R2, the ordinal of R2 being strictly greater than that of R1. *) Record emb (x y : A0) : Prop := {X1 : Type; R1 : X1 -> X1 -> Prop; eqx : x = i0 X1 R1; X2 : Type; R2 : X2 -> X2 -> Prop; eqy : y = i0 X2 R2; W2 : WF X2 R2; f : X1 -> X2; fmorph : morphism X1 R1 X2 R2 f; maj : X2; majf : forall z : X1, R2 (f z) maj}. Lemma emb_trans : forall x y z : A0, emb x y -> emb y z -> emb x z. intros. case H; intros X1 R1 eqx X2 R2 eqy; intros. case H0; intros X3 R3 eqx0 X4 R4 eqy0; intros. generalize eqx0; clear eqx0. elim eqy using eq_ind_r; intro. case (inj _ _ _ _ eqx0); intros. exists X1 R1 X4 R4 (fun x : X1 => f0 (x0 (f x))) maj0; trivial. red; auto. Defined. Lemma ACC_emb : forall (X : Type) (R : X -> X -> Prop) (x : X), ACC X R x -> forall (Y : Type) (S : Y -> Y -> Prop) (f : Y -> X), morphism Y S X R f -> (forall y : Y, R (f y) x) -> ACC A0 emb (i0 Y S). simple induction 1; intros. constructor; intros. case H4; intros. elim eqx using eq_ind_r. case (inj X2 R2 Y S). apply sym_eq; assumption. intros. apply H1 with (y := f (x1 maj)) (f := fun x : X1 => f (x1 (f0 x))); try red; auto. Defined. (* The embedding relation is well founded *) Lemma WF_emb : WF A0 emb. constructor; intros. case H; intros. elim eqx using eq_ind_r. apply ACC_emb with (X := X2) (R := R2) (x := maj) (f := f); trivial. Defined. (* The following definition enforces Type_j >= Type_i *) Definition Omega : A0 := i0 A0 emb. Section Subsets. Variable a : A0. (* We define the type of elements of A0 smaller than a w.r.t embedding. The Record is in Type, but it is possible to avoid such structure. *) Record sub : Type := {witness : A0; emb_wit : emb witness a}. (* F is its image through i0 *) Definition F : A0 := i0 sub (Rof _ _ emb witness). (* F is embedded in Omega: - the witness projection is a morphism - a is an upper bound because emb_wit proves that witness is smaller than a. *) Lemma F_emb_Omega : emb F Omega. exists sub (Rof _ _ emb witness) A0 emb witness a; trivial. exact WF_emb. red; trivial. exact emb_wit. Defined. End Subsets. Definition fsub (a b : A0) (H : emb a b) (x : sub a) : sub b := Build_sub _ (witness _ x) (emb_trans _ _ _ (emb_wit _ x) H). (* F is a morphism: a < b => F(a) < F(b) - the morphism from F(a) to F(b) is fsub above - the upper bound is a, which is in F(b) since a < b *) Lemma F_morphism : morphism A0 emb A0 emb F. red; intros. exists (sub x) (Rof _ _ emb (witness x)) (sub y) (Rof _ _ emb (witness y)) (fsub x y H) (Build_sub _ x H); trivial. apply WF_inverse_image. exact WF_emb. unfold morphism, Rof, fsub; simpl; intros. trivial. unfold Rof, fsub; simpl; intros. apply emb_wit. Defined. (* Omega is embedded in itself: - F is a morphism - Omega is an upper bound of the image of F *) Lemma Omega_refl : emb Omega Omega. exists A0 emb A0 emb F Omega; trivial. exact WF_emb. exact F_morphism. exact F_emb_Omega. Defined. (* The paradox is that Omega cannot be embedded in itself, since the embedding relation is well founded. *) Theorem Burali_Forti : False. apply ACC_nonreflexive with A0 emb Omega. apply WF_emb. exact Omega_refl. Defined. End Burali_Forti_Paradox. (* Note: this proof uses a large elimination of A0. *) Lemma inj : forall (X1 : Type) (R1 : X1 -> X1 -> Prop) (X2 : Type) (R2 : X2 -> X2 -> Prop), i0 X1 R1 = i0 X2 R2 -> exists f : X1 -> X2, morphism X1 R1 X2 R2 f. intros. change match i0 X1 R1, i0 X2 R2 with | i1 x1 r1, i1 x2 r2 => exists f : _, morphism x1 r1 x2 r2 f end. case H; simpl. exists (fun x : X1 => x). red; trivial. Defined. (* The following command raises 'Error: Universe Inconsistency'. To allow large elimination of A0, i0 must not be a large constructor. Hence, the constraint Type_j' < Type_i' is added, which is incompatible with the constraint j >= i in the paradox. *) Definition Paradox : False := Burali_Forti A0 i0 inj. coq-8.4pl4/test-suite/failure/fixpoint4.v0000644000175000017500000000105012326224777017477 0ustar stephsteph(* Check that arguments of impredicative types are not considered subterms even through commutative cuts on functional arguments (example prepared by Bruno) *) Inductive IMP : Prop := CIMP : (forall A:Prop, A->A) -> IMP | LIMP : (nat->IMP)->IMP. Definition i0 := (LIMP (fun _ => CIMP (fun _ x => x))). Definition Paradox : False := (fix F y o {struct o} : False := match y with | tt => fun f => match f 0 with | CIMP h => F y (h _ o) | _ => F y (f 0) end end match o with LIMP f => f | _ => fun _ => o end) tt i0. coq-8.4pl4/test-suite/failure/search.v0000644000175000017500000000107212326224777017024 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* prop. Definition up (p:prop) : Prop := let (A) := p in A. Lemma p2p1 : forall A:Prop, up (down A) -> A. Proof. exact (fun A x => x). Qed. Lemma p2p2 : forall A:Prop, A -> up (down A). Proof. exact (fun A x => x). Qed. (** Hurkens' paradox *) Definition V := forall A:Prop, ((A -> prop) -> A -> prop) -> A -> prop. Definition U := V -> prop. Definition sb (z:V) : V := fun A r a => r (z A r) a. Definition le (i:U -> prop) (x:U) : prop := x (fun A r a => i (fun v => sb v A r a)). Definition induct (i:U -> prop) : Prop := forall x:U, up (le i x) -> up (i x). Definition WF : U := fun z => down (induct (z U le)). Definition I (x:U) : Prop := (forall i:U -> prop, up (le i x) -> up (i (fun v => sb v U le x))) -> False. Lemma Omega : forall i:U -> prop, induct i -> up (i WF). Proof. intros i y. apply y. unfold le, WF, induct. intros x H0. apply y. exact H0. Qed. Lemma lemma1 : induct (fun u => down (I u)). Proof. unfold induct. intros x p. intro q. apply (q (fun u => down (I u)) p). intro i. apply q with (i := fun y => i (fun v:V => sb v U le y)). Qed. Lemma lemma2 : (forall i:U -> prop, induct i -> up (i WF)) -> False. Proof. intro x. apply (x (fun u => down (I u)) lemma1). intros i H0. apply (x (fun y => i (fun v => sb v U le y))). apply H0. Qed. Theorem paradox : False. Proof. exact (lemma2 Omega). Qed. coq-8.4pl4/test-suite/failure/coqbugs0266.v0000644000175000017500000000023712326224777017542 0ustar stephsteph(* It is forbidden to erase a variable (or a local def) that is used in the current goal. *) Section S. Let a := 0. Definition b := a. Goal b = b. clear a. coq-8.4pl4/test-suite/failure/clash_cons.v0000644000175000017500000000121712326224777017674 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* m}. Type match compare 0 0 return nat with (* k 0 (* k=i *) | left _ _ _ => 0 (* k>i *) | right _ _ _ => 0 end. coq-8.4pl4/test-suite/failure/universes-buraliforti.v0000644000175000017500000001422312326224777022124 0ustar stephsteph(* Check that Burali-Forti paradox does not go through *) (* Source: contrib/Rocq/PARADOX/{Logics,BuraliForti},v *) (* Some properties about relations on objects in Type *) Inductive ACC (A : Type) (R : A -> A -> Prop) : A -> Prop := ACC_intro : forall x : A, (forall y : A, R y x -> ACC A R y) -> ACC A R x. Lemma ACC_nonreflexive : forall (A : Type) (R : A -> A -> Prop) (x : A), ACC A R x -> R x x -> False. simple induction 1; intros. exact (H1 x0 H2 H2). Qed. Definition WF (A : Type) (R : A -> A -> Prop) := forall x : A, ACC A R x. Section Inverse_Image. Variables (A B : Type) (R : B -> B -> Prop) (f : A -> B). Definition Rof (x y : A) : Prop := R (f x) (f y). Remark ACC_lemma : forall y : B, ACC B R y -> forall x : A, y = f x -> ACC A Rof x. simple induction 1; intros. constructor; intros. apply (H1 (f y0)); trivial. elim H2 using eq_ind_r; trivial. Qed. Lemma ACC_inverse_image : forall x : A, ACC B R (f x) -> ACC A Rof x. intros; apply (ACC_lemma (f x)); trivial. Qed. Lemma WF_inverse_image : WF B R -> WF A Rof. red; intros; apply ACC_inverse_image; auto. Qed. End Inverse_Image. (* Remark: the paradox is written in Type, but also works in Prop or Set. *) Section Burali_Forti_Paradox. Definition morphism (A : Type) (R : A -> A -> Prop) (B : Type) (S : B -> B -> Prop) (f : A -> B) := forall x y : A, R x y -> S (f x) (f y). (* The hypothesis of the paradox: assumes there exists an universal system of notations, i.e: - A type A0 - An injection i0 from relations on any type into A0 - The proof that i0 is injective modulo morphism *) Variable A0 : Type. (* Type_i *) Variable i0 : forall X : Type, (X -> X -> Prop) -> A0. (* X: Type_j *) Hypothesis inj : forall (X1 : Type) (R1 : X1 -> X1 -> Prop) (X2 : Type) (R2 : X2 -> X2 -> Prop), i0 X1 R1 = i0 X2 R2 -> exists f : X1 -> X2, morphism X1 R1 X2 R2 f. (* Embedding of x in y: x and y are images of 2 well founded relations R1 and R2, the ordinal of R2 being strictly greater than that of R1. *) Record emb (x y : A0) : Prop := {X1 : Type; R1 : X1 -> X1 -> Prop; eqx : x = i0 X1 R1; X2 : Type; R2 : X2 -> X2 -> Prop; eqy : y = i0 X2 R2; W2 : WF X2 R2; f : X1 -> X2; fmorph : morphism X1 R1 X2 R2 f; maj : X2; majf : forall z : X1, R2 (f z) maj}. Lemma emb_trans : forall x y z : A0, emb x y -> emb y z -> emb x z. intros. case H; intros. case H0; intros. generalize eqx0; clear eqx0. elim eqy using eq_ind_r; intro. case (inj _ _ _ _ eqx0); intros. exists X1 R1 X3 R3 (fun x : X1 => f0 (x0 (f x))) maj0; trivial. red; auto. Defined. Lemma ACC_emb : forall (X : Type) (R : X -> X -> Prop) (x : X), ACC X R x -> forall (Y : Type) (S : Y -> Y -> Prop) (f : Y -> X), morphism Y S X R f -> (forall y : Y, R (f y) x) -> ACC A0 emb (i0 Y S). simple induction 1; intros. constructor; intros. case H4; intros. elim eqx using eq_ind_r. case (inj X2 R2 Y S). apply sym_eq; assumption. intros. apply H1 with (y := f (x1 maj)) (f := fun x : X1 => f (x1 (f0 x))); try red; auto. Defined. (* The embedding relation is well founded *) Lemma WF_emb : WF A0 emb. constructor; intros. case H; intros. elim eqx using eq_ind_r. apply ACC_emb with (X := X2) (R := R2) (x := maj) (f := f); trivial. Defined. (* The following definition enforces Type_j >= Type_i *) Definition Omega : A0 := i0 A0 emb. Section Subsets. Variable a : A0. (* We define the type of elements of A0 smaller than a w.r.t embedding. The Record is in Type, but it is possible to avoid such structure. *) Record sub : Type := {witness : A0; emb_wit : emb witness a}. (* F is its image through i0 *) Definition F : A0 := i0 sub (Rof _ _ emb witness). (* F is embedded in Omega: - the witness projection is a morphism - a is an upper bound because emb_wit proves that witness is smaller than a. *) Lemma F_emb_Omega : emb F Omega. exists sub (Rof _ _ emb witness) A0 emb witness a; trivial. exact WF_emb. red; trivial. exact emb_wit. Defined. End Subsets. Definition fsub (a b : A0) (H : emb a b) (x : sub a) : sub b := Build_sub _ (witness _ x) (emb_trans _ _ _ (emb_wit _ x) H). (* F is a morphism: a < b => F(a) < F(b) - the morphism from F(a) to F(b) is fsub above - the upper bound is a, which is in F(b) since a < b *) Lemma F_morphism : morphism A0 emb A0 emb F. red; intros. exists (sub x) (Rof _ _ emb (witness x)) (sub y) (Rof _ _ emb (witness y)) (fsub x y H) (Build_sub _ x H); trivial. apply WF_inverse_image. exact WF_emb. unfold morphism, Rof, fsub; simpl; intros. trivial. unfold Rof, fsub; simpl; intros. apply emb_wit. Defined. (* Omega is embedded in itself: - F is a morphism - Omega is an upper bound of the image of F *) Lemma Omega_refl : emb Omega Omega. exists A0 emb A0 emb F Omega; trivial. exact WF_emb. exact F_morphism. exact F_emb_Omega. Defined. (* The paradox is that Omega cannot be embedded in itself, since the embedding relation is well founded. *) Theorem Burali_Forti : False. apply ACC_nonreflexive with A0 emb Omega. apply WF_emb. exact Omega_refl. Defined. End Burali_Forti_Paradox. (* The following type seems to satisfy the hypothesis of the paradox. But it does not! *) Record A0 : Type := (* Type_i' *) i0 {X0 : Type; R0 : X0 -> X0 -> Prop}. (* X0: Type_j' *) (* Note: this proof uses a large elimination of A0. *) Lemma inj : forall (X1 : Type) (R1 : X1 -> X1 -> Prop) (X2 : Type) (R2 : X2 -> X2 -> Prop), i0 X1 R1 = i0 X2 R2 -> exists f : X1 -> X2, morphism X1 R1 X2 R2 f. intros. change match i0 X1 R1, i0 X2 R2 with | i0 x1 r1, i0 x2 r2 => exists f : _, morphism x1 r1 x2 r2 f end. case H; simpl. exists (fun x : X1 => x). red; trivial. Defined. (* The following command raises 'Error: Universe Inconsistency'. To allow large elimination of A0, i0 must not be a large constructor. Hence, the constraint Type_j' < Type_i' is added, which is incompatible with the constraint j >= i in the paradox. *) Definition Paradox : False := Burali_Forti A0 i0 inj. coq-8.4pl4/test-suite/failure/fixpoint1.v0000644000175000017500000000115312326224777017500 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* nat) -> t. coq-8.4pl4/test-suite/failure/Reordering.v0000644000175000017500000000026112326224777017656 0ustar stephsteph(* Testing that hypothesis order (following a conversion/folding) is checked *) Goal forall (A:Set) (x:A) (A':=A), True. intros. change ((fun (_:A') => Set) x) in (type of A). coq-8.4pl4/test-suite/failure/Case16.v0000644000175000017500000000030212326224777016574 0ustar stephsteph(* Check for redundant clauses *) Check (fun x => match x, x with | O, S (S y) => true | S _, S (S y) => true | _, S (S x) => false | S y, O => true | _, _ => true end). coq-8.4pl4/test-suite/failure/evar1.v0000644000175000017500000000017412326224777016577 0ustar stephsteph(* This used to succeed by producing an ill-typed term in v8.2 *) Lemma u: forall A : Prop, (exist _ A A) = (exist _ A A). coq-8.4pl4/test-suite/failure/universes-sections1.v0000644000175000017500000000031012326224777021502 0ustar stephsteph(* Check that constraints on definitions are preserved by discharging *) Section A. Definition Type2 := Type. Definition Type1 : Type2 := Type. End A. Definition Inconsistency : Type1 := Type2. coq-8.4pl4/test-suite/failure/ltac4.v0000644000175000017500000000022312326224777016563 0ustar stephsteph(* Check static globalisation of tactic names *) (* Proposed by Benjamin (mars 2002) *) Goal forall n : nat, n = n. induction n; try REflexivity. coq-8.4pl4/test-suite/failure/Case11.v0000644000175000017500000000016112326224777016572 0ustar stephstephType (fun x : nat => match x return nat with | S x as b => S b x end). coq-8.4pl4/test-suite/failure/evarclear1.v0000644000175000017500000000035712326224777017611 0ustar stephstephSet Printing Existential Instances. Set Printing All. Goal forall y, let z := S y in exists x, x = 0. intros. eexists. unfold z. clear y z. (* should fail because the evar should no longer be allowed to depend on z *) instantiate (1:=z). coq-8.4pl4/test-suite/failure/proofirrelevance.v0000644000175000017500000000063312326224777021126 0ustar stephsteph(* This was working in version 8.1beta (bug in the Sort-polymorphism of inductive types), but this is inconsistent with classical logic in Prop *) Inductive bool_in_prop : Type := hide : bool -> bool_in_prop with bool : Type := true : bool | false : bool. Lemma not_proof_irrelevance : ~ forall (P:Prop) (p p':P), p=p'. intro H; pose proof (H bool_in_prop (hide true) (hide false)); discriminate. Qed. coq-8.4pl4/test-suite/failure/fixpoint2.v0000644000175000017500000000013412326224777017477 0ustar stephsteph(* Check Guard in proofs *) Goal nat->nat. fix f 1. intro n; apply f; assumption. Guarded. coq-8.4pl4/test-suite/failure/ltac1.v0000644000175000017500000000025012326224777016560 0ustar stephsteph(* Check all variables are different in a Context *) Ltac X := match goal with | x:_,x:_ |- _ => apply x end. Goal True -> True -> True. intros. X. coq-8.4pl4/test-suite/failure/fixpoint3.v0000644000175000017500000000051212326224777017500 0ustar stephsteph(* Check that arguments of impredicative types are not considered subterms for the guard condition (an example by Thierry Coquand) *) Inductive I : Prop := | C: (forall P:Prop, P->P) -> I. Definition i0 := C (fun _ x => x). Definition Paradox : False := (fix ni i : False := match i with | C f => ni (f _ i) end) i0. coq-8.4pl4/test-suite/kernel/0000755000175000017500000000000012365131023015201 5ustar stephstephcoq-8.4pl4/test-suite/kernel/inds.mv0000644000175000017500000000014412326224777016521 0ustar stephstephInductive [] nat : Set := O : nat | S : nat->nat. Check Construct nat 0 1. Check Construct nat 0 2. coq-8.4pl4/test-suite/check0000755000175000017500000000023612326224777014745 0ustar stephsteph#!/bin/sh MAKE="${MAKE:=make}" if [ "$1" = -byte ]; then export BEST=byte fi ${MAKE} clean > /dev/null 2>&1 ${MAKE} all > /dev/null 2>&1 cat summary.log coq-8.4pl4/test-suite/misc/0000755000175000017500000000000012365131023014654 5ustar stephstephcoq-8.4pl4/test-suite/misc/deps/0000755000175000017500000000000012365131023015607 5ustar stephstephcoq-8.4pl4/test-suite/misc/deps/client/0000755000175000017500000000000012365131023017065 5ustar stephstephcoq-8.4pl4/test-suite/misc/deps/client/foo.v0000644000175000017500000000002312326224777020052 0ustar stephstephDefinition a := 1. coq-8.4pl4/test-suite/misc/deps/client/bar.v0000644000175000017500000000036412326224777020043 0ustar stephsteph(* We assume the file compiled with -R ../lib lib -R . client *) (* foo alone should refer to client.foo because -R . client comes last *) Require Import foo. Goal a = 1. reflexivity. Qed. Require Import lib.foo. Goal a = 0. reflexivity. Qed. coq-8.4pl4/test-suite/misc/deps/lib/0000755000175000017500000000000012326224777016375 5ustar stephstephcoq-8.4pl4/test-suite/misc/deps/lib/foo.v0000644000175000017500000000002312326224777017342 0ustar stephstephDefinition a := 0. coq-8.4pl4/test-suite/misc/deps/deps.out0000644000175000017500000000023112326224777017307 0ustar stephstephmisc/deps/client/bar.vo misc/deps/client/bar.glob misc/deps/client/bar.v.beautified: misc/deps/client/bar.v misc/deps/client/foo.vo misc/deps/lib/foo.vo coq-8.4pl4/test-suite/misc/universes/0000755000175000017500000000000012326224777016717 5ustar stephstephcoq-8.4pl4/test-suite/misc/universes/universes.v0000644000175000017500000000007412326224777021132 0ustar stephstephRequire all_stdlib. Print Sorted Universes "universes.txt". coq-8.4pl4/test-suite/misc/berardi_test.v0000644000175000017500000001013112326224777017526 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* > *) Set Implicit Arguments. Section Berardis_paradox. (** Excluded middle *) Hypothesis EM : forall P:Prop, P \/ ~ P. (** Conditional on any proposition. *) Definition IFProp (P B:Prop) (e1 e2:P) := match EM B with | or_introl _ => e1 | or_intror _ => e2 end. (** Axiom of choice applied to disjunction. Provable in Coq because of dependent elimination. *) Lemma AC_IF : forall (P B:Prop) (e1 e2:P) (Q:P -> Prop), (B -> Q e1) -> (~ B -> Q e2) -> Q (IFProp B e1 e2). Proof. intros P B e1 e2 Q p1 p2. unfold IFProp. case (EM B); assumption. Qed. (** We assume a type with two elements. They play the role of booleans. The main theorem under the current assumptions is that [T=F] *) Variable Bool : Prop. Variable T : Bool. Variable F : Bool. (** The powerset operator *) Definition pow (P:Prop) := P -> Bool. (** A piece of theory about retracts *) Section Retracts. Variables A B : Prop. Record retract : Prop := {i : A -> B; j : B -> A; inv : forall a:A, j (i a) = a}. Record retract_cond : Prop := {i2 : A -> B; j2 : B -> A; inv2 : retract -> forall a:A, j2 (i2 a) = a}. (** The dependent elimination above implies the axiom of choice: *) Lemma AC : forall r:retract_cond, retract -> forall a:A, j2 r (i2 r a) = a. Proof. intros r. case r; simpl. trivial. Qed. End Retracts. (** This lemma is basically a commutation of implication and existential quantification: (EX x | A -> P(x)) <=> (A -> EX x | P(x)) which is provable in classical logic ( => is already provable in intuitionnistic logic). *) Lemma L1 : forall A B:Prop, retract_cond (pow A) (pow B). Proof. intros A B. destruct (EM (retract (pow A) (pow B))) as [(f0,g0,e) | hf]. exists f0 g0; trivial. exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros; destruct hf; auto. Qed. (** The paradoxical set *) Definition U := forall P:Prop, pow P. (** Bijection between [U] and [(pow U)] *) Definition f (u:U) : pow U := u U. Definition g (h:pow U) : U := fun X => let lX := j2 (L1 X U) in let rU := i2 (L1 U U) in lX (rU h). (** We deduce that the powerset of [U] is a retract of [U]. This lemma is stated in Berardi's article, but is not used afterwards. *) Lemma retract_pow_U_U : retract (pow U) U. Proof. exists g f. intro a. unfold f, g; simpl. apply AC. exists (fun x:pow U => x) (fun x:pow U => x). trivial. Qed. (** Encoding of Russel's paradox *) (** The boolean negation. *) Definition Not_b (b:Bool) := IFProp (b = T) F T. (** the set of elements not belonging to itself *) Definition R : U := g (fun u:U => Not_b (u U u)). Lemma not_has_fixpoint : R R = Not_b (R R). Proof. unfold R at 1. unfold g. rewrite AC with (r := L1 U U) (a := fun u:U => Not_b (u U u)). trivial. exists (fun x:pow U => x) (fun x:pow U => x); trivial. Qed. Theorem classical_proof_irrelevence : T = F. Proof. generalize not_has_fixpoint. unfold Not_b. apply AC_IF. intros is_true is_false. elim is_true; elim is_false; trivial. intros not_true is_true. elim not_true; trivial. Qed. End Berardis_paradox. coq-8.4pl4/proofs/0000755000175000017500000000000012365131025013125 5ustar stephstephcoq-8.4pl4/proofs/tacmach.mli0000644000175000017500000001304712326224777015253 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a val project : goal sigma -> evar_map val re_sig : 'a -> evar_map -> 'a sigma val unpackage : 'a sigma -> evar_map ref * 'a val repackage : evar_map ref -> 'a -> 'a sigma val apply_sig_tac : evar_map ref -> (goal sigma -> (goal list) sigma) -> goal -> (goal list) val pf_concl : goal sigma -> types val pf_env : goal sigma -> env val pf_hyps : goal sigma -> named_context (*i val pf_untyped_hyps : goal sigma -> (identifier * constr) list i*) val pf_hyps_types : goal sigma -> (identifier * types) list val pf_nth_hyp_id : goal sigma -> int -> identifier val pf_last_hyp : goal sigma -> named_declaration val pf_ids_of_hyps : goal sigma -> identifier list val pf_global : goal sigma -> identifier -> constr val pf_parse_const : goal sigma -> string -> constr val pf_type_of : goal sigma -> constr -> types val pf_check_type : goal sigma -> constr -> types -> unit val pf_hnf_type_of : goal sigma -> constr -> types val pf_get_hyp : goal sigma -> identifier -> named_declaration val pf_get_hyp_typ : goal sigma -> identifier -> types val pf_get_new_id : identifier -> goal sigma -> identifier val pf_get_new_ids : identifier list -> goal sigma -> identifier list val pf_reduction_of_red_expr : goal sigma -> red_expr -> constr -> constr val pf_apply : (env -> evar_map -> 'a) -> goal sigma -> 'a val pf_reduce : (env -> evar_map -> constr -> constr) -> goal sigma -> constr -> constr val pf_whd_betadeltaiota : goal sigma -> constr -> constr val pf_whd_betadeltaiota_stack : goal sigma -> constr -> constr * constr list val pf_hnf_constr : goal sigma -> constr -> constr val pf_red_product : goal sigma -> constr -> constr val pf_nf : goal sigma -> constr -> constr val pf_nf_betaiota : goal sigma -> constr -> constr val pf_reduce_to_quantified_ind : goal sigma -> types -> inductive * types val pf_reduce_to_atomic_ind : goal sigma -> types -> inductive * types val pf_compute : goal sigma -> constr -> constr val pf_unfoldn : (Termops.occurrences * evaluable_global_reference) list -> goal sigma -> constr -> constr val pf_const_value : goal sigma -> constant -> constr val pf_conv_x : goal sigma -> constr -> constr -> bool val pf_conv_x_leq : goal sigma -> constr -> constr -> bool val pf_matches : goal sigma -> constr_pattern -> constr -> patvar_map val pf_is_matching : goal sigma -> constr_pattern -> constr -> bool (** {6 The most primitive tactics. } *) val refiner : rule -> tactic val introduction_no_check : identifier -> tactic val internal_cut_no_check : bool -> identifier -> types -> tactic val internal_cut_rev_no_check : bool -> identifier -> types -> tactic val refine_no_check : constr -> tactic val convert_concl_no_check : types -> cast_kind -> tactic val convert_hyp_no_check : named_declaration -> tactic val thin_no_check : identifier list -> tactic val thin_body_no_check : identifier list -> tactic val move_hyp_no_check : bool -> identifier -> identifier move_location -> tactic val rename_hyp_no_check : (identifier*identifier) list -> tactic val order_hyps : identifier list -> tactic val mutual_fix : identifier -> int -> (identifier * int * constr) list -> int -> tactic val mutual_cofix : identifier -> (identifier * constr) list -> int -> tactic (** {6 The most primitive tactics with consistency and type checking } *) val introduction : identifier -> tactic val internal_cut : bool -> identifier -> types -> tactic val internal_cut_rev : bool -> identifier -> types -> tactic val refine : constr -> tactic val convert_concl : types -> cast_kind -> tactic val convert_hyp : named_declaration -> tactic val thin : identifier list -> tactic val thin_body : identifier list -> tactic val move_hyp : bool -> identifier -> identifier move_location -> tactic val rename_hyp : (identifier*identifier) list -> tactic (** {6 Tactics handling a list of goals. } *) type validation_list = proof_tree list -> proof_tree list type tactic_list = Refiner.tactic_list val first_goal : 'a list sigma -> 'a sigma val goal_goal_list : 'a sigma -> 'a list sigma val apply_tac_list : tactic -> tactic_list val then_tactic_list : tactic_list -> tactic_list -> tactic_list val tactic_list_tactic : tactic_list -> tactic val tclFIRSTLIST : tactic_list list -> tactic_list val tclIDTAC_list : tactic_list (** {6 Pretty-printing functions (debug only). } *) val pr_gls : goal sigma -> Pp.std_ppcmds val pr_glls : goal list sigma -> Pp.std_ppcmds coq-8.4pl4/proofs/refiner.mli0000644000175000017500000001630412326224777015304 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a val project : 'a sigma -> evar_map val pf_env : goal sigma -> Environ.env val pf_hyps : goal sigma -> named_context val unpackage : 'a sigma -> evar_map ref * 'a val repackage : evar_map ref -> 'a -> 'a sigma val apply_sig_tac : evar_map ref -> (goal sigma -> goal list sigma) -> goal -> goal list (** {6 Hiding the implementation of tactics. } *) (** [abstract_tactic tac] hides the (partial) proof produced by [tac] under a single proof node. The boolean tells if the default tactic is used. *) (* spiwack: currently here for compatibility, abstract_operation is a second projection *) val abstract_operation : compound_rule -> tactic -> tactic val abstract_tactic : ?dflt:bool -> atomic_tactic_expr -> tactic -> tactic val abstract_tactic_expr : ?dflt:bool -> tactic_expr -> tactic -> tactic val abstract_extended_tactic : ?dflt:bool -> string -> typed_generic_argument list -> tactic -> tactic val refiner : rule -> tactic (** {6 Tacticals. } *) (** [tclNORMEVAR] forces propagation of evar constraints *) val tclNORMEVAR : tactic (** [tclIDTAC] is the identity tactic without message printing*) val tclIDTAC : tactic val tclIDTAC_MESSAGE : Pp.std_ppcmds -> tactic (** [tclEVARS sigma] changes the current evar map *) val tclEVARS : evar_map -> tactic (** [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies [tac2] to every resulting subgoals *) val tclTHEN : tactic -> tactic -> tactic (** [tclTHENLIST [t1;..;tn]] applies [t1] THEN [t2] ... THEN [tn]. More convenient than [tclTHEN] when [n] is large *) val tclTHENLIST : tactic list -> tactic (** [tclMAP f [x1..xn]] builds [(f x1);(f x2);...(f xn)] *) val tclMAP : ('a -> tactic) -> 'a list -> tactic (** [tclTHEN_i tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies [(tac2 i)] to the [i]{^ th} resulting subgoal (starting from 1) *) val tclTHEN_i : tactic -> (int -> tactic) -> tactic (** [tclTHENLAST tac1 tac2 gls] applies the tactic [tac1] to [gls] and [tac2] to the last resulting subgoal (previously called [tclTHENL]) *) val tclTHENLAST : tactic -> tactic -> tactic (** [tclTHENFIRST tac1 tac2 gls] applies the tactic [tac1] to [gls] and [tac2] to the first resulting subgoal *) val tclTHENFIRST : tactic -> tactic -> tactic (** [tclTHENS tac1 [|t1 ; ... ; tn|] gls] applies the tactic [tac1] to [gls] and applies [t1],..., [tn] to the [n] resulting subgoals. Raises an error if the number of resulting subgoals is not [n] *) val tclTHENSV : tactic -> tactic array -> tactic (** Same with a list of tactics *) val tclTHENS : tactic -> tactic list -> tactic (** [tclTHENST] is renamed [tclTHENSFIRSTn] val tclTHENST : tactic -> tactic array -> tactic -> tactic *) (** [tclTHENS3PARTS tac1 [|t1 ; ... ; tn|] tac2 [|t'1 ; ... ; t'm|] gls] applies the tactic [tac1] to [gls] then, applies [t1], ..., [tn] to the first [n] resulting subgoals, [t'1], ..., [t'm] to the last [m] subgoals and [tac2] to the rest of the subgoals in the middle. Raises an error if the number of resulting subgoals is strictly less than [n+m] *) val tclTHENS3PARTS : tactic -> tactic array -> tactic -> tactic array -> tactic (** [tclTHENSLASTn tac1 [t1 ; ... ; tn] tac2 gls] applies [t1],...,[tn] on the last [n] resulting subgoals and [tac2] on the remaining first subgoals *) val tclTHENSLASTn : tactic -> tactic -> tactic array -> tactic (** [tclTHENSFIRSTn tac1 [t1 ; ... ; tn] tac2 gls] first applies [tac1], then applies [t1],...,[tn] on the first [n] resulting subgoals and [tac2] for the remaining last subgoals (previously called tclTHENST) *) val tclTHENSFIRSTn : tactic -> tactic array -> tactic -> tactic (** [tclTHENLASTn tac1 [t1 ; ... ; tn] gls] first applies [tac1] then, applies [t1],...,[tn] on the last [n] resulting subgoals and leaves unchanged the other subgoals *) val tclTHENLASTn : tactic -> tactic array -> tactic (** [tclTHENFIRSTn tac1 [t1 ; ... ; tn] gls] first applies [tac1] then, applies [t1],...,[tn] on the first [n] resulting subgoals and leaves unchanged the other subgoals (previously called [tclTHENSI]) *) val tclTHENFIRSTn : tactic -> tactic array -> tactic (** A special exception for levels for the Fail tactic *) exception FailError of int * Pp.std_ppcmds Lazy.t (** Takes an exception and either raise it at the next level or do nothing. *) val catch_failerror : exn -> unit val tclORELSE0 : tactic -> tactic -> tactic val tclORELSE : tactic -> tactic -> tactic val tclREPEAT : tactic -> tactic val tclREPEAT_MAIN : tactic -> tactic val tclFIRST : tactic list -> tactic val tclSOLVE : tactic list -> tactic val tclTRY : tactic -> tactic val tclTHENTRY : tactic -> tactic -> tactic val tclCOMPLETE : tactic -> tactic val tclAT_LEAST_ONCE : tactic -> tactic val tclFAIL : int -> Pp.std_ppcmds -> tactic val tclFAIL_lazy : int -> Pp.std_ppcmds Lazy.t -> tactic val tclDO : int -> tactic -> tactic val tclTIMEOUT : int -> tactic -> tactic val tclWEAK_PROGRESS : tactic -> tactic val tclPROGRESS : tactic -> tactic val tclNOTSAMEGOAL : tactic -> tactic (** [tclIFTHENELSE tac1 tac2 tac3 gls] first applies [tac1] to [gls] then, if it succeeds, applies [tac2] to the resulting subgoals, and if not applies [tac3] to the initial goal [gls] *) val tclIFTHENELSE : tactic -> tactic -> tactic -> tactic val tclIFTHENSELSE : tactic -> tactic list -> tactic ->tactic val tclIFTHENSVELSE : tactic -> tactic array -> tactic ->tactic (** [tclIFTHENTRYELSEMUST tac1 tac2 gls] applies [tac1] then [tac2]. If [tac1] has been successful, then [tac2] may fail. Otherwise, [tac2] must succeed. Equivalent to [(tac1;try tac2)||tac2] *) val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic (** {6 Tactics handling a list of goals. } *) type tactic_list = goal list sigma -> goal list sigma val tclFIRSTLIST : tactic_list list -> tactic_list val tclIDTAC_list : tactic_list val first_goal : 'a list sigma -> 'a sigma val apply_tac_list : tactic -> tactic_list val then_tactic_list : tactic_list -> tactic_list -> tactic_list val tactic_list_tactic : tactic_list -> tactic val goal_goal_list : 'a sigma -> 'a list sigma (** [tclWITHHOLES solve_holes tac (sigma,c)] applies [tac] to [c] which may have unresolved holes; if [solve_holes] these holes must be resolved after application of the tactic; [sigma] must be an extension of the sigma of the goal *) val tclWITHHOLES : bool -> ('a -> tactic) -> evar_map -> 'a -> tactic coq-8.4pl4/proofs/redexpr.mli0000644000175000017500000000316412326224777015323 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* occurrences * 'a val reduction_of_red_expr : red_expr -> reduction_function * cast_kind (** [true] if we should use the vm to verify the reduction *) (** Adding a custom reduction (function to be use at the ML level) NB: the effect is permanent. *) val declare_reduction : string -> reduction_function -> unit (** Adding a custom reduction (function to be called a vernac command). The boolean flag is the locality. *) val declare_red_expr : bool -> string -> red_expr -> unit (** Opaque and Transparent commands. *) (** Sets the expansion strategy of a constant. When the boolean is true, the effect is non-synchronous (i.e. it does not survive section and module closure). *) val set_strategy : bool -> (Conv_oracle.level * evaluable_global_reference list) list -> unit (** call by value normalisation function using the virtual machine *) val cbv_vm : reduction_function coq-8.4pl4/proofs/proofs.mllib0000644000175000017500000000020312326224777015467 0ustar stephstephGoal Evar_refiner Proofview Proof Proof_global Tacexpr Proof_type Redexpr Logic Refiner Tacmach Pfedit Tactic_debug Clenv Clenvtac coq-8.4pl4/proofs/proof.ml0000644000175000017500000003632012326224777014626 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Proofview.proofview -> unfocusable) * (_focus_kind -> bool) type 'a focus_condition = _focus_condition let next_kind = ref 0 let new_focus_kind () = let r = !next_kind in incr next_kind; r (* Auxiliary function to define conditions. *) let check kind1 kind2 = kind1=kind2 (* To be authorized to unfocus one must meet the condition prescribed by the action which focused.*) (* spiwack: we could consider having a list of authorized focus_kind instead of just one, if anyone needs it *) (* [no_cond] only checks that the unfocusing command uses the right [focus_kind]. *) module Cond = struct (* first attempt at an algebra of condition *) (* semantics: - [Cannot] means that the condition is not met - [Strict] that the condition is met - [Loose] that the condition is not quite met but authorises to unfocus provided a condition of a previous focus on the stack is (strictly) met. [Loose] focuses are those, like bullets, which do not have a closing command and are hence closed by unfocusing actions unrelated to their focus_kind. *) let bool e b = if b then fun _ _ -> Strict else fun _ _ -> Cannot e let loose c k p = match c k p with | Cannot _ -> Loose | c -> c let cloose l c = if l then loose c else c let (&&&) c1 c2 k p= match c1 k p , c2 k p with | Cannot e , _ | _ , Cannot e -> Cannot e | Strict, Strict -> Strict | _ , _ -> Loose let kind e k0 k p = bool e (k0=k) k p let pdone e k p = bool e (Proofview.finished p) k p end (* Unfocus command. Fails if the proof is not focused. *) exception CannotUnfocusThisWay let _ = Errors.register_handler begin function | CannotUnfocusThisWay -> Util.error "This proof is focused, but cannot be unfocused this way" | _ -> raise Errors.Unhandled end open Cond let no_cond_gen e ~loose_end k0 = cloose loose_end (kind e k0) let no_cond_gen e ?(loose_end=false) k = no_cond_gen e ~loose_end k , check k let no_cond ?loose_end = no_cond_gen CannotUnfocusThisWay ?loose_end (* [done_cond] checks that the unfocusing command uses the right [focus_kind] and that the focused proofview is complete. *) let done_cond_gen e ~loose_end k0 = (cloose loose_end (kind e k0)) &&& pdone e let done_cond_gen e ?(loose_end=false) k = done_cond_gen e ~loose_end k , check k let done_cond ?loose_end = done_cond_gen CannotUnfocusThisWay ?loose_end (* Subpart of the type of proofs. It contains the parts of the proof which are under control of the undo mechanism *) type proof_state = { (* Current focused proofview *) proofview: Proofview.proofview; (* History of the focusings, provides information on how to unfocus the proof and the extra information stored while focusing. The list is empty when the proof is fully unfocused. *) focus_stack: (_focus_condition*focus_info*Proofview.focus_context) list; (* Extra information which can be freely used to create new behaviours. *) intel: Store.t } type proof_info = { mutable endline_tactic : unit Proofview.tactic ; mutable section_vars : Sign.section_context option; initial_conclusions : Term.types list } type undo_action = | State of proof_state | Effect of (unit -> unit) type proof = { (* current proof_state *) mutable state : proof_state; (* The undo stack *) mutable undo_stack : undo_action list; (* secondary undo stacks used for transactions *) mutable transactions : undo_action list list; info : proof_info } (*** General proof functions ***) let proof { state = p } = let (goals,sigma) = Proofview.proofview p.proofview in (* spiwack: beware, the bottom of the stack is used by [Proof] internally, and should not be exposed. *) let rec map_minus_one f = function | [] -> assert false | [_] -> [] | a::l -> f a :: (map_minus_one f l) in let stack = map_minus_one (fun (_,_,c) -> Proofview.focus_context c) p.focus_stack in (goals,stack,sigma) let rec unroll_focus pv = function | (_,_,ctx)::stk -> unroll_focus (Proofview.unfocus ctx pv) stk | [] -> pv (* spiwack: a proof is considered completed even if its still focused, if the focus doesn't hide any goal. Unfocusing is handled in {!return}. *) let is_done p = Proofview.finished p.state.proofview && Proofview.finished (unroll_focus p.state.proofview p.state.focus_stack) (* spiwack: for compatibility with <= 8.2 proof engine *) let has_unresolved_evar p = Proofview.V82.has_unresolved_evar p.state.proofview (* Returns the list of partial proofs to initial goals *) let partial_proof p = List.map fst (Proofview.return p.state.proofview) (*** The following functions implement the basic internal mechanisms of proofs, they are not meant to be exported in the .mli ***) (* An auxiliary function to push a {!focus_context} on the focus stack. *) let push_focus cond inf context pr = pr.state <- { pr.state with focus_stack = (cond,inf,context)::pr.state.focus_stack } exception FullyUnfocused let _ = Errors.register_handler begin function | FullyUnfocused -> Util.error "The proof is not focused" | _ -> raise Errors.Unhandled end (* An auxiliary function to read the kind of the next focusing step *) let cond_of_focus pr = match pr.state.focus_stack with | (cond,_,_)::_ -> cond | _ -> raise FullyUnfocused (* An auxiliary function to pop and read the last {!Proofview.focus_context} on the focus stack. *) let pop_focus pr = match pr.state.focus_stack with | focus::other_focuses -> pr.state <- { pr.state with focus_stack = other_focuses }; focus | _ -> raise FullyUnfocused (* Auxiliary function to push a [proof_state] onto the undo stack. *) let push_undo save pr = match pr.transactions with | [] -> pr.undo_stack <- save::pr.undo_stack | stack::trans' -> pr.transactions <- (save::stack)::trans' (* Auxiliary function to pop and read a [save_state] from the undo stack. *) exception EmptyUndoStack let _ = Errors.register_handler begin function | EmptyUndoStack -> Util.error "Cannot undo: no more undo information" | _ -> raise Errors.Unhandled end let pop_undo pr = match pr.transactions , pr.undo_stack with | [] , state::stack -> pr.undo_stack <- stack; state | (state::stack)::trans', _ -> pr.transactions <- stack::trans'; state | _ -> raise EmptyUndoStack (* This function focuses the proof [pr] between indices [i] and [j] *) let _focus cond inf i j pr = let (focused,context) = Proofview.focus i j pr.state.proofview in push_focus cond inf context pr; pr.state <- { pr.state with proofview = focused } (* This function unfocuses the proof [pr], it raises [FullyUnfocused], if the proof is already fully unfocused. This function does not care about the condition of the current focus. *) let _unfocus pr = let (_,_,fc) = pop_focus pr in pr.state <- { pr.state with proofview = Proofview.unfocus fc pr.state.proofview } let set_used_variables l p = p.info.section_vars <- Some l let get_used_variables p = p.info.section_vars (*** Endline tactic ***) (* spiwack this is an information about the UI, it might be a good idea to move it to the Proof_global module *) (* Sets the tactic to be used when a tactic line is closed with [...] *) let set_endline_tactic tac p = p.info.endline_tactic <- tac let with_end_tac pr tac = Proofview.tclTHEN tac pr.info.endline_tactic (*** The following functions define the safety mechanism of the proof system, they may be unsafe if not used carefully. There is currently no reason to export them in the .mli ***) (* This functions saves the current state into a [proof_state]. *) let save_state { state = ps } = State ps (* This function stores the current proof state in the undo stack. *) let save pr = push_undo (save_state pr) pr (* This function restores a state, presumably from the top of the undo stack. *) let restore_state save pr = match save with | State save -> pr.state <- save | Effect undo -> undo () (* Interpretes the Undo command. *) let undo pr = (* On a single line, since the effects commute *) restore_state (pop_undo pr) pr (* Adds an undo effect to the undo stack. Use it with care, errors here might result in inconsistent states. *) let add_undo effect pr = push_undo (Effect effect) pr (*** Transactions ***) let init_transaction pr = pr.transactions <- []::pr.transactions let commit_stack pr stack = let push s = push_undo s pr in List.iter push (List.rev stack) (* Invariant: [commit] should be called only when a transaction is open. It closes the current transaction. *) let commit pr = match pr.transactions with | stack::trans' -> pr.transactions <- trans'; commit_stack pr stack | [] -> assert false (* Invariant: [rollback] should be called only when a transaction is open. It closes the current transaction. *) let rec rollback pr = try undo pr; rollback pr with EmptyUndoStack -> match pr.transactions with | []::trans' -> pr.transactions <- trans' | _ -> assert false let transaction pr t = init_transaction pr; try t (); commit pr with reraise -> rollback pr; raise reraise (* Focus command (focuses on the [i]th subgoal) *) (* spiwack: there could also, easily be a focus-on-a-range tactic, is there a need for it? *) let focus cond inf i pr = save pr; _focus cond (Obj.repr inf) i i pr let rec unfocus kind pr () = let starting_point = save_state pr in let cond = cond_of_focus pr in match fst cond kind pr.state.proofview with | Cannot e -> raise e | Strict -> (_unfocus pr; push_undo starting_point pr) | Loose -> begin try _unfocus pr; push_undo starting_point pr; unfocus kind pr () with FullyUnfocused -> raise CannotUnfocusThisWay end let unfocus kind pr = transaction pr (unfocus kind pr) exception NoSuchFocus (* no handler: should not be allowed to reach toplevel. *) let rec get_in_focus_stack kind stack = match stack with | ((_,check),inf,_)::stack -> if check kind then inf else get_in_focus_stack kind stack | [] -> raise NoSuchFocus let get_at_focus kind pr = Obj.magic (get_in_focus_stack kind pr.state.focus_stack) let is_last_focus kind pr = let ((_,check),_,_) = List.hd pr.state.focus_stack in check kind let no_focused_goal p = Proofview.finished p.state.proofview (*** Proof Creation/Termination ***) (* [end_of_stack] is unfocused by return to close every loose focus. *) let end_of_stack_kind = new_focus_kind () let end_of_stack = done_cond_gen FullyUnfocused end_of_stack_kind let unfocused = is_last_focus end_of_stack_kind let start goals = let pr = { state = { proofview = Proofview.init goals ; focus_stack = [] ; intel = Store.empty} ; undo_stack = [] ; transactions = [] ; info = { endline_tactic = Proofview.tclUNIT (); initial_conclusions = List.map snd goals; section_vars = None } } in _focus end_of_stack (Obj.repr ()) 1 (List.length goals) pr; pr exception UnfinishedProof exception HasUnresolvedEvar let _ = Errors.register_handler begin function | UnfinishedProof -> Util.error "Some goals have not been solved." | HasUnresolvedEvar -> Util.error "Some existential variables are uninstantiated." | _ -> raise Errors.Unhandled end let return p = if not (is_done p) then raise UnfinishedProof else if has_unresolved_evar p then (* spiwack: for compatibility with <= 8.3 proof engine *) raise HasUnresolvedEvar else unfocus end_of_stack_kind p; Proofview.return p.state.proofview (*** Function manipulation proof extra informations ***) let get_proof_info pr = pr.state.intel let set_proof_info info pr = save pr; pr.state <- { pr.state with intel=info } (*** Tactics ***) let run_tactic env tac pr = let starting_point = save_state pr in let sp = pr.state.proofview in try let tacticced_proofview = Proofview.apply env tac sp in pr.state <- { pr.state with proofview = tacticced_proofview }; push_undo starting_point pr with reraise -> restore_state starting_point pr; raise reraise (*** Commands ***) let in_proof p k = Proofview.in_proofview p.state.proofview k (*** Compatibility layer with <=v8.2 ***) module V82 = struct let subgoals p = Proofview.V82.goals p.state.proofview let background_subgoals p = Proofview.V82.goals (unroll_focus p.state.proofview p.state.focus_stack) let get_initial_conclusions p = p.info.initial_conclusions let depth p = List.length p.undo_stack let top_goal p = let { Evd.it=gls ; sigma=sigma } = Proofview.V82.top_goals p.state.proofview in { Evd.it=List.hd gls ; sigma=sigma } let top_evars p = Proofview.V82.top_evars p.state.proofview let grab_evars p = if not (is_done p) then raise UnfinishedProof else save p; p.state <- { p.state with proofview = Proofview.V82.grab p.state.proofview } let instantiate_evar n com pr = let starting_point = save_state pr in let sp = pr.state.proofview in try let new_proofview = Proofview.V82.instantiate_evar n com sp in pr.state <- { pr.state with proofview = new_proofview }; push_undo starting_point pr with reraise -> restore_state starting_point pr; raise reraise end coq-8.4pl4/proofs/proof_type.ml0000644000175000017500000000521512326224777015666 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* goal list sigma type prim_rule = | Intro of identifier | Cut of bool * bool * identifier * types | FixRule of identifier * int * (identifier * int * constr) list * int | Cofix of identifier * (identifier * constr) list * int | Refine of constr | Convert_concl of types * cast_kind | Convert_hyp of named_declaration | Thin of identifier list | ThinBody of identifier list | Move of bool * identifier * identifier move_location | Order of identifier list | Rename of identifier * identifier | Change_evars type proof_tree = { goal : goal; ref : (rule * proof_tree list) option } and rule = | Prim of prim_rule | Nested of compound_rule * proof_tree | Decl_proof of bool | Daimon and compound_rule= | Tactic of tactic_expr * bool and tactic_expr = (constr, constr_pattern, evaluable_global_reference, inductive, ltac_constant, identifier, glob_tactic_expr, tlevel) Tacexpr.gen_tactic_expr and atomic_tactic_expr = (constr, constr_pattern, evaluable_global_reference, inductive, ltac_constant, identifier, glob_tactic_expr, tlevel) Tacexpr.gen_atomic_tactic_expr and tactic_arg = (constr, constr_pattern, evaluable_global_reference, inductive, ltac_constant, identifier, glob_tactic_expr, tlevel) Tacexpr.gen_tactic_arg type ltac_call_kind = | LtacNotationCall of string | LtacNameCall of ltac_constant | LtacAtomCall of glob_atomic_tactic_expr * atomic_tactic_expr option ref | LtacVarCall of identifier * glob_tactic_expr | LtacConstrInterp of glob_constr * (extended_patvar_map * (identifier * identifier option) list) type ltac_trace = (int * loc * ltac_call_kind) list exception LtacLocated of (int * ltac_call_kind * ltac_trace * loc) * exn let abstract_tactic_box = ref (ref None) coq-8.4pl4/proofs/logic.ml0000644000175000017500000006140712326224777014602 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* catchable_exception e | LtacLocated(_,e) -> catchable_exception e | Util.UserError _ | TypeError _ | PretypeError (_,_,TypingError _) | RefinerError _ | Indrec.RecursionSchemeError _ | Nametab.GlobalizationError _ | PretypeError (_,_,VarNotFound _) (* reduction errors *) | Tacred.ReductionTacticError _ (* unification errors *) | PretypeError(_,_,(CannotUnify _|CannotUnifyLocal _|CannotGeneralize _ |NoOccurrenceFound _|CannotUnifyBindingType _|NotClean _ |CannotFindWellTypedAbstraction _|OccurCheck _ |UnsolvableImplicit _|AbstractionOverMeta _)) -> true | Typeclasses_errors.TypeClassError (_, Typeclasses_errors.UnsatisfiableConstraints _) -> true | _ -> false let error_no_such_hypothesis id = error ("No such hypothesis: " ^ string_of_id id ^ ".") (* Tells if the refiner should check that the submitted rules do not produce invalid subgoals *) let check = ref false let with_check = Flags.with_option check (* [apply_to_hyp sign id f] splits [sign] into [tail::[id,_,_]::head] and returns [tail::(f head (id,_,_) (rev tail))] *) let apply_to_hyp sign id f = try apply_to_hyp sign id f with Hyp_not_found -> if !check then error "No such assumption." else sign let apply_to_hyp_and_dependent_on sign id f g = try apply_to_hyp_and_dependent_on sign id f g with Hyp_not_found -> if !check then error "No such assumption." else sign let check_typability env sigma c = if !check then let _ = type_of env sigma c in () (************************************************************************) (************************************************************************) (* Implementation of the structural rules (moving and deleting hypotheses around) *) (* The Clear tactic: it scans the context for hypotheses to be removed (instead of iterating on the list of identifier to be removed, which forces the user to give them in order). *) let clear_hyps sigma ids sign cl = let evdref = ref (Evd.create_goal_evar_defs sigma) in let (hyps,concl) = Evarutil.clear_hyps_in_evi evdref sign cl ids in (hyps,concl, !evdref) (* The ClearBody tactic *) let recheck_typability (what,id) env sigma t = try check_typability env sigma t with e when Errors.noncritical e -> let s = match what with | None -> "the conclusion" | Some id -> "hypothesis "^(string_of_id id) in error ("The correctness of "^s^" relies on the body of "^(string_of_id id)) let remove_hyp_body env sigma id = let sign = apply_to_hyp_and_dependent_on (named_context_val env) id (fun (_,c,t) _ -> match c with | None -> error ((string_of_id id)^" is not a local definition.") | Some c ->(id,None,t)) (fun (id',c,t as d) sign -> (if !check then begin let env = reset_with_named_context sign env in match c with | None -> recheck_typability (Some id',id) env sigma t | Some b -> let b' = mkCast (b,DEFAULTcast, t) in recheck_typability (Some id',id) env sigma b' end;d)) in reset_with_named_context sign env (* Reordering of the context *) (* faire le minimum d'echanges pour que l'ordre donne soit un *) (* sous-ordre du resultat. Par exemple, 2 hyps non mentionnee ne sont *) (* pas echangees. Choix: les hyps mentionnees ne peuvent qu'etre *) (* reculees par rapport aux autres (faire le contraire!) *) let mt_q = (Idmap.empty,[]) let push_val y = function (_,[] as q) -> q | (m, (x,l)::q) -> (m, (x,Idset.add y l)::q) let push_item x v (m,l) = (Idmap.add x v m, (x,Idset.empty)::l) let mem_q x (m,_) = Idmap.mem x m let rec find_q x (m,q) = let v = Idmap.find x m in let m' = Idmap.remove x m in let rec find accs acc = function [] -> raise Not_found | [(x',l)] -> if x=x' then ((v,Idset.union accs l),(m',List.rev acc)) else raise Not_found | (x',l as i)::((x'',l'')::q as itl) -> if x=x' then ((v,Idset.union accs l), (m',List.rev acc@(x'',Idset.add x (Idset.union l l''))::q)) else find (Idset.union l accs) (i::acc) itl in find Idset.empty [] q let occur_vars_in_decl env hyps d = if Idset.is_empty hyps then false else let ohyps = global_vars_set_of_decl env d in Idset.exists (fun h -> Idset.mem h ohyps) hyps let reorder_context env sign ord = let ords = List.fold_right Idset.add ord Idset.empty in if List.length ord <> Idset.cardinal ords then error "Order list has duplicates"; let rec step ord expected ctxt_head moved_hyps ctxt_tail = match ord with | [] -> List.rev ctxt_tail @ ctxt_head | top::ord' when mem_q top moved_hyps -> let ((d,h),mh) = find_q top moved_hyps in if occur_vars_in_decl env h d then errorlabstrm "reorder_context" (str "Cannot move declaration " ++ pr_id top ++ spc() ++ str "before " ++ prlist_with_sep pr_spc pr_id (Idset.elements (Idset.inter h (global_vars_set_of_decl env d)))); step ord' expected ctxt_head mh (d::ctxt_tail) | _ -> (match ctxt_head with | [] -> error_no_such_hypothesis (List.hd ord) | (x,_,_ as d) :: ctxt -> if Idset.mem x expected then step ord (Idset.remove x expected) ctxt (push_item x d moved_hyps) ctxt_tail else step ord expected ctxt (push_val x moved_hyps) (d::ctxt_tail)) in step ord ords sign mt_q [] let reorder_val_context env sign ord = val_of_named_context (reorder_context env (named_context_of_val sign) ord) let check_decl_position env sign (x,_,_ as d) = let needed = global_vars_set_of_decl env d in let deps = dependency_closure env (named_context_of_val sign) needed in if List.mem x deps then error ("Cannot create self-referring hypothesis "^string_of_id x); x::deps (* Auxiliary functions for primitive MOVE tactic * * [move_hyp with_dep toleft (left,(hfrom,typfrom),right) hto] moves * hyp [hfrom] at location [hto] which belongs to the hyps on the * left side [left] of the full signature if [toleft=true] or to the hyps * on the right side [right] if [toleft=false]. * If [with_dep] then dependent hypotheses are moved accordingly. *) let rec get_hyp_after h = function | [] -> error_no_such_hypothesis h | (hyp,_,_) :: right -> if hyp = h then match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveToEnd false else get_hyp_after h right let split_sign hfrom hto l = let rec splitrec left toleft = function | [] -> error_no_such_hypothesis hfrom | (hyp,c,typ) as d :: right -> if hyp = hfrom then (left,right,d, toleft or hto = MoveToEnd true) else splitrec (d::left) (toleft or hto = MoveAfter hyp or hto = MoveBefore hyp) right in splitrec [] false l let hyp_of_move_location = function | MoveAfter id -> id | MoveBefore id -> id | _ -> assert false let move_hyp with_dep toleft (left,(idfrom,_,_ as declfrom),right) hto = let env = Global.env() in let test_dep (hyp,c,typ as d) (hyp2,c,typ2 as d2) = if toleft then occur_var_in_decl env hyp2 d else occur_var_in_decl env hyp d2 in let rec moverec first middle = function | [] -> if match hto with MoveToEnd _ -> false | _ -> true then error_no_such_hypothesis (hyp_of_move_location hto); List.rev first @ List.rev middle | (hyp,_,_) :: _ as right when hto = MoveBefore hyp -> List.rev first @ List.rev middle @ right | (hyp,_,_) as d :: right -> let (first',middle') = if List.exists (test_dep d) middle then if with_dep & hto <> MoveAfter hyp then (first, d::middle) else errorlabstrm "move_hyp" (str "Cannot move " ++ pr_id idfrom ++ pr_move_location pr_id hto ++ str (if toleft then ": it occurs in " else ": it depends on ") ++ pr_id hyp ++ str ".") else (d::first, middle) in if hto = MoveAfter hyp then List.rev first' @ List.rev middle' @ right else moverec first' middle' right in if toleft then let right = List.fold_right push_named_context_val right empty_named_context_val in List.fold_left (fun sign d -> push_named_context_val d sign) right (moverec [] [declfrom] left) else let right = List.fold_right push_named_context_val (moverec [] [declfrom] right) empty_named_context_val in List.fold_left (fun sign d -> push_named_context_val d sign) right left let rename_hyp id1 id2 sign = apply_to_hyp_and_dependent_on sign id1 (fun (_,b,t) _ -> (id2,b,t)) (fun d _ -> map_named_declaration (replace_vars [id1,mkVar id2]) d) (************************************************************************) (************************************************************************) (* Implementation of the logical rules *) (* Will only be used on terms given to the Refine rule which have meta variables only in Application and Case *) let error_unsupported_deep_meta c = errorlabstrm "" (strbrk "Application of lemmas whose beta-iota normal " ++ strbrk "form contains metavariables deep inside the term is not " ++ strbrk "supported; try \"refine\" instead.") let collect_meta_variables c = let rec collrec deep acc c = match kind_of_term c with | Meta mv -> if deep then error_unsupported_deep_meta () else mv::acc | Cast(c,_,_) -> collrec deep acc c | (App _| Case _) -> fold_constr (collrec deep) acc c | _ -> fold_constr (collrec true) acc c in List.rev (collrec false [] c) let check_meta_variables c = if not (list_distinct (collect_meta_variables c)) then raise (RefinerError (NonLinearProof c)) let check_conv_leq_goal env sigma arg ty conclty = if !check & not (is_conv_leq env sigma ty conclty) then raise (RefinerError (BadType (arg,ty,conclty))) let goal_type_of env sigma c = if !check then type_of env sigma c else Retyping.get_type_of ~refresh:true env sigma c let rec mk_refgoals sigma goal goalacc conclty trm = let env = Goal.V82.env sigma goal in let hyps = Goal.V82.hyps sigma goal in let mk_goal hyps concl = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in match kind_of_term trm with | Meta _ -> let conclty = nf_betaiota sigma conclty in if !check && occur_meta conclty then raise (RefinerError (MetaInType conclty)); let (gl,ev,sigma) = mk_goal hyps conclty in gl::goalacc, conclty, sigma, ev | Cast (t,k, ty) -> check_typability env sigma ty; check_conv_leq_goal env sigma trm ty conclty; let res = mk_refgoals sigma goal goalacc ty t in (** we keep the casts (in particular VMcast) except when they are annotating metas *) if isMeta t then begin assert (k <> VMcast); res end else let (gls,cty,sigma,trm) = res in (gls,cty,sigma,mkCast(trm,k,ty)) | App (f,l) -> let (acc',hdty,sigma,applicand) = match kind_of_term f with | Ind _ | Const _ when (isInd f or has_polymorphic_type (destConst f)) -> (* Sort-polymorphism of definition and inductive types *) goalacc, type_of_global_reference_knowing_conclusion env sigma f conclty, sigma, f | _ -> mk_hdgoals sigma goal goalacc f in let (acc'',conclty',sigma, args) = mk_arggoals sigma goal acc' hdty (Array.to_list l) in check_conv_leq_goal env sigma trm conclty' conclty; (acc'',conclty',sigma, Term.mkApp (applicand, Array.of_list args)) | Case (ci,p,c,lf) -> let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in check_conv_leq_goal env sigma trm conclty' conclty; let (acc'',sigma, rbranches) = array_fold_left2 (fun (lacc,sigma,bacc) ty fi -> let (r,_,s,b') = mk_refgoals sigma goal lacc ty fi in r,s,(b'::bacc)) (acc',sigma,[]) lbrty lf in (acc'',conclty',sigma, Term.mkCase (ci,p',c',Array.of_list (List.rev rbranches))) | _ -> if occur_meta trm then anomaly "refiner called with a meta in non app/case subterm"; let t'ty = goal_type_of env sigma trm in check_conv_leq_goal env sigma trm t'ty conclty; (goalacc,t'ty,sigma, trm) (* Same as mkREFGOALS but without knowing the type of the term. Therefore, * Metas should be casted. *) and mk_hdgoals sigma goal goalacc trm = let env = Goal.V82.env sigma goal in let hyps = Goal.V82.hyps sigma goal in let mk_goal hyps concl = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in match kind_of_term trm with | Cast (c,_, ty) when isMeta c -> check_typability env sigma ty; let (gl,ev,sigma) = mk_goal hyps (nf_betaiota sigma ty) in gl::goalacc,ty,sigma,ev | Cast (t,_, ty) -> check_typability env sigma ty; mk_refgoals sigma goal goalacc ty t | App (f,l) -> let (acc',hdty,sigma,applicand) = if isInd f or isConst f & not (array_exists occur_meta l) (* we could be finer *) then (goalacc,type_of_global_reference_knowing_parameters env sigma f l,sigma,f) else mk_hdgoals sigma goal goalacc f in let (acc'',conclty',sigma, args) = mk_arggoals sigma goal acc' hdty (Array.to_list l) in (acc'',conclty',sigma, Term.mkApp (applicand, Array.of_list args)) | Case (ci,p,c,lf) -> let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in let (acc'',sigma,rbranches) = array_fold_left2 (fun (lacc,sigma,bacc) ty fi -> let (r,_,s,b') = mk_refgoals sigma goal lacc ty fi in r,s,(b'::bacc)) (acc',sigma,[]) lbrty lf in (acc'',conclty',sigma, Term.mkCase (ci,p',c',Array.of_list (List.rev rbranches))) | _ -> if !check && occur_meta trm then anomaly "refine called with a dependent meta"; goalacc, goal_type_of env sigma trm, sigma, trm and mk_arggoals sigma goal goalacc funty = function | [] -> goalacc,funty,sigma, [] | harg::tlargs as allargs -> let t = whd_betadeltaiota (Goal.V82.env sigma goal) sigma funty in match kind_of_term t with | Prod (_,c1,b) -> let (acc',hargty,sigma,arg') = mk_refgoals sigma goal goalacc c1 harg in let (acc'',fty, sigma', args) = mk_arggoals sigma goal acc' (subst1 harg b) tlargs in (acc'',fty,sigma',arg'::args) | LetIn (_,c1,_,b) -> mk_arggoals sigma goal goalacc (subst1 c1 b) allargs | _ -> raise (RefinerError (CannotApply (t,harg))) and mk_casegoals sigma goal goalacc p c = let env = Goal.V82.env sigma goal in let (acc',ct,sigma,c') = mk_hdgoals sigma goal goalacc c in let (acc'',pt,sigma,p') = mk_hdgoals sigma goal acc' p in let indspec = try Tacred.find_hnf_rectype env sigma ct with Not_found -> anomaly "mk_casegoals" in let (lbrty,conclty) = type_case_branches_with_names env indspec p c in (acc'',lbrty,conclty,sigma,p',c') let convert_hyp sign sigma (id,b,bt as d) = let env = Global.env() in let reorder = ref [] in let sign' = apply_to_hyp sign id (fun _ (_,c,ct) _ -> let env = Global.env_of_context sign in if !check && not (is_conv env sigma bt ct) then error ("Incorrect change of the type of "^(string_of_id id)^"."); if !check && not (Option.Misc.compare (is_conv env sigma) b c) then error ("Incorrect change of the body of "^(string_of_id id)^"."); if !check then reorder := check_decl_position env sign d; d) in reorder_val_context env sign' !reorder (************************************************************************) (************************************************************************) (* Primitive tactics are handled here *) let prim_refiner r sigma goal = let env = Goal.V82.env sigma goal in let sign = Goal.V82.hyps sigma goal in let cl = Goal.V82.concl sigma goal in let mk_goal hyps concl = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in match r with (* Logical rules *) | Intro id -> if !check && mem_named_context id (named_context_of_val sign) then error ("Variable " ^ string_of_id id ^ " is already declared."); (match kind_of_term (strip_outer_cast cl) with | Prod (_,c1,b) -> let (sg,ev,sigma) = mk_goal (push_named_context_val (id,None,c1) sign) (subst1 (mkVar id) b) in let sigma = Goal.V82.partial_solution sigma goal (mkNamedLambda id c1 ev) in ([sg], sigma) | LetIn (_,c1,t1,b) -> let (sg,ev,sigma) = mk_goal (push_named_context_val (id,Some c1,t1) sign) (subst1 (mkVar id) b) in let sigma = Goal.V82.partial_solution sigma goal (mkNamedLetIn id c1 t1 ev) in ([sg], sigma) | _ -> raise (RefinerError IntroNeedsProduct)) | Cut (b,replace,id,t) -> let (sg1,ev1,sigma) = mk_goal sign (nf_betaiota sigma t) in let sign,cl,sigma = if replace then let nexthyp = get_hyp_after id (named_context_of_val sign) in let sign,cl,sigma = clear_hyps sigma [id] sign cl in move_hyp true false ([],(id,None,t),named_context_of_val sign) nexthyp, cl,sigma else (if !check && mem_named_context id (named_context_of_val sign) then error ("Variable " ^ string_of_id id ^ " is already declared."); push_named_context_val (id,None,t) sign,cl,sigma) in let (sg2,ev2,sigma) = Goal.V82.mk_goal sigma sign cl (Goal.V82.extra sigma goal) in let oterm = Term.mkApp (Term.mkNamedLambda id t ev2 , [| ev1 |]) in let sigma = Goal.V82.partial_solution sigma goal oterm in if b then ([sg1;sg2],sigma) else ([sg2;sg1],sigma) | FixRule (f,n,rest,j) -> let rec check_ind env k cl = match kind_of_term (strip_outer_cast cl) with | Prod (na,c1,b) -> if k = 1 then try fst (find_inductive env sigma c1) with Not_found -> error "Cannot do a fixpoint on a non inductive type." else check_ind (push_rel (na,None,c1) env) (k-1) b | _ -> error "Not enough products." in let (sp,_) = check_ind env n cl in let firsts,lasts = list_chop j rest in let all = firsts@(f,n,cl)::lasts in let rec mk_sign sign = function | (f,n,ar)::oth -> let (sp',_) = check_ind env n ar in if not (sp=sp') then error ("Fixpoints should be on the same " ^ "mutual inductive declaration."); if !check && mem_named_context f (named_context_of_val sign) then error ("Name "^string_of_id f^" already used in the environment"); mk_sign (push_named_context_val (f,None,ar) sign) oth | [] -> Goal.list_map (fun sigma (_,_,c) -> let (gl,ev,sig')= Goal.V82.mk_goal sigma sign c (Goal.V82.extra sigma goal) in ((gl,ev),sig')) all sigma in let (gls_evs,sigma) = mk_sign sign all in let (gls,evs) = List.split gls_evs in let ids = List.map pi1 all in let evs = List.map (Term.subst_vars (List.rev ids)) evs in let indxs = Array.of_list (List.map (fun n -> n-1) (List.map pi2 all)) in let funnames = Array.of_list (List.map (fun i -> Name i) ids) in let typarray = Array.of_list (List.map pi3 all) in let bodies = Array.of_list evs in let oterm = Term.mkFix ((indxs,0),(funnames,typarray,bodies)) in let sigma = Goal.V82.partial_solution sigma goal oterm in (gls,sigma) | Cofix (f,others,j) -> let rec check_is_coind env cl = let b = whd_betadeltaiota env sigma cl in match kind_of_term b with | Prod (na,c1,b) -> check_is_coind (push_rel (na,None,c1) env) b | _ -> try let _ = find_coinductive env sigma b in () with Not_found -> error ("All methods must construct elements " ^ "in coinductive types.") in let firsts,lasts = list_chop j others in let all = firsts@(f,cl)::lasts in List.iter (fun (_,c) -> check_is_coind env c) all; let rec mk_sign sign = function | (f,ar)::oth -> (try (let _ = lookup_named_val f sign in error "Name already used in the environment.") with | Not_found -> mk_sign (push_named_context_val (f,None,ar) sign) oth) | [] -> Goal.list_map (fun sigma(_,c) -> let (gl,ev,sigma) = Goal.V82.mk_goal sigma sign c (Goal.V82.extra sigma goal) in ((gl,ev),sigma)) all sigma in let (gls_evs,sigma) = mk_sign sign all in let (gls,evs) = List.split gls_evs in let (ids,types) = List.split all in let evs = List.map (Term.subst_vars (List.rev ids)) evs in let funnames = Array.of_list (List.map (fun i -> Name i) ids) in let typarray = Array.of_list types in let bodies = Array.of_list evs in let oterm = Term.mkCoFix (0,(funnames,typarray,bodies)) in let sigma = Goal.V82.partial_solution sigma goal oterm in (gls,sigma) | Refine c -> check_meta_variables c; let (sgl,cl',sigma,oterm) = mk_refgoals sigma goal [] cl c in let sgl = List.rev sgl in let sigma = Goal.V82.partial_solution sigma goal oterm in (sgl, sigma) (* Conversion rules *) | Convert_concl (cl',k) -> check_typability env sigma cl'; if (not !check) || is_conv_leq env sigma cl' cl then let (sg,ev,sigma) = mk_goal sign cl' in let ev = if k<>DEFAULTcast then mkCast(ev,k,cl) else ev in let sigma = Goal.V82.partial_solution sigma goal ev in ([sg], sigma) else error "convert-concl rule passed non-converting term" | Convert_hyp (id,copt,ty) -> let (gl,ev,sigma) = mk_goal (convert_hyp sign sigma (id,copt,ty)) cl in let sigma = Goal.V82.partial_solution sigma goal ev in ([gl], sigma) (* And now the structural rules *) | Thin ids -> let (hyps,concl,nsigma) = clear_hyps sigma ids sign cl in let (gl,ev,sigma) = Goal.V82.mk_goal nsigma hyps concl (Goal.V82.extra nsigma goal) in let sigma = Goal.V82.partial_solution sigma goal ev in ([gl], sigma) | ThinBody ids -> let clear_aux env id = let env' = remove_hyp_body env sigma id in if !check then recheck_typability (None,id) env' sigma cl; env' in let sign' = named_context_val (List.fold_left clear_aux env ids) in let (sg,ev,sigma) = mk_goal sign' cl in let sigma = Goal.V82.partial_solution sigma goal ev in ([sg], sigma) | Move (withdep, hfrom, hto) -> let (left,right,declfrom,toleft) = split_sign hfrom hto (named_context_of_val sign) in let hyps' = move_hyp withdep toleft (left,declfrom,right) hto in let (gl,ev,sigma) = mk_goal hyps' cl in let sigma = Goal.V82.partial_solution sigma goal ev in ([gl], sigma) | Order ord -> let hyps' = reorder_val_context env sign ord in let (gl,ev,sigma) = mk_goal hyps' cl in let sigma = Goal.V82.partial_solution sigma goal ev in ([gl], sigma) | Rename (id1,id2) -> if !check & id1 <> id2 && List.mem id2 (ids_of_named_context (named_context_of_val sign)) then error ((string_of_id id2)^" is already used."); let sign' = rename_hyp id1 id2 sign in let cl' = replace_vars [id1,mkVar id2] cl in let (gl,ev,sigma) = mk_goal sign' cl' in let ev = Term.replace_vars [(id2,mkVar id1)] ev in let sigma = Goal.V82.partial_solution sigma goal ev in ([gl], sigma) | Change_evars -> (* Normalises evars in goals. Used by instantiate. *) let (goal,sigma) = Goal.V82.nf_evar sigma goal in ([goal],sigma) (************************************************************************) (************************************************************************) (* Extracting a proof term from the proof tree *) (* Util *) type variable_proof_status = ProofVar | SectionVar of identifier type proof_variable = name * variable_proof_status let proof_variable_index x = let rec aux n = function | (Name id,ProofVar)::l when x = id -> n | _::l -> aux (n+1) l | [] -> raise Not_found in aux 1 coq-8.4pl4/proofs/proof_global.mli0000644000175000017500000001211712326224777016315 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit ; reset : unit -> unit } (** Registers a new proof mode which can then be adressed by name in [set_default_proof_mode]. One mode is already registered - the standard mode - named "No", It corresponds to Coq default setting are they are set when coqtop starts. *) val register_proof_mode : proof_mode -> unit val there_is_a_proof : unit -> bool val there_are_pending_proofs : unit -> bool val check_no_pending_proof : unit -> unit val get_current_proof_name : unit -> Names.identifier val get_all_proof_names : unit -> Names.identifier list val discard : Names.identifier Util.located -> unit val discard_current : unit -> unit val discard_all : unit -> unit (** [set_proof_mode] sets the proof mode to be used after it's called. It is typically called by the Proof Mode command. *) val set_proof_mode : string -> unit exception NoCurrentProof val give_me_the_proof : unit -> Proof.proof (** [start_proof s str goals ~init_tac ~compute_guard hook] starts a proof of name [s] and conclusion [t]; [hook] is optionally a function to be applied at proof end (e.g. to declare the built constructions as a coercion or a setoid morphism). *) type lemma_possible_guards = int list list val start_proof : Names.identifier -> Decl_kinds.goal_kind -> (Environ.env * Term.types) list -> ?compute_guard:lemma_possible_guards -> Tacexpr.declaration_hook -> unit val close_proof : unit -> Names.identifier * (Entries.definition_entry list * lemma_possible_guards * Decl_kinds.goal_kind * Tacexpr.declaration_hook) exception NoSuchProof (** Runs a tactic on the current proof. Raises [NoCurrentProof] is there is no current proof. *) val run_tactic : unit Proofview.tactic -> unit (** Sets the tactic to be used when a tactic line is closed with [...] *) val set_endline_tactic : unit Proofview.tactic -> unit (** Sets the section variables assumed by the proof *) val set_used_variables : Names.identifier list -> unit val get_used_variables : unit -> Sign.section_context option (** Appends the endline tactic of the current proof to a tactic. *) val with_end_tac : unit Proofview.tactic -> unit Proofview.tactic (**********************************************************) (* *) (* Utility functions *) (* *) (**********************************************************) (** [maximal_unfocus k p] unfocuses [p] until [p] has at least a focused goal or that the last focus isn't of kind [k]. *) val maximal_unfocus : 'a Proof.focus_kind -> Proof.proof -> unit (**********************************************************) (* *) (* Bullets *) (* *) (**********************************************************) module Bullet : sig type t = Vernacexpr.bullet (** A [behavior] is the data of a put function which is called when a bullet prefixes a tactic, together with a name to identify it. *) type behavior = { name : string; put : Proof.proof -> t -> unit } (** A registered behavior can then be accessed in Coq through the command [Set Bullet Behavior "name"]. Two modes are registered originally: * "Strict Subproofs": - If this bullet follows another one of its kind, defocuses then focuses (which fails if the focused subproof is not complete). - If it is the first bullet of its kind, then focuses a new subproof. * "None": bullets don't do anything *) val register_behavior : behavior -> unit (** Handles focusing/defocusing with bullets: *) val put : Proof.proof -> t -> unit end module V82 : sig val get_current_initial_conclusions : unit -> Names.identifier *(Term.types list * Decl_kinds.goal_kind * Tacexpr.declaration_hook) end coq-8.4pl4/proofs/redexpr.ml0000644000175000017500000001742612326224777015160 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ConstKey sp | EvalVarRef id -> VarKey id in Conv_oracle.set_strategy k l; match k,l with ConstKey sp, Conv_oracle.Opaque -> Csymtable.set_opaque_const sp | ConstKey sp, _ -> let cb = Global.lookup_constant sp in (match cb.const_body with | OpaqueDef _ -> errorlabstrm "set_transparent_const" (str "Cannot make" ++ spc () ++ Nametab.pr_global_env Idset.empty (ConstRef sp) ++ spc () ++ str "transparent because it was declared opaque."); | _ -> Csymtable.set_transparent_const sp) | _ -> () let cache_strategy (_,str) = List.iter (fun (lev,ql) -> List.iter (fun q -> set_strategy_one q lev) ql) str let subst_strategy (subs,(local,obj)) = local, list_smartmap (fun (k,ql as entry) -> let ql' = list_smartmap (Mod_subst.subst_evaluable_reference subs) ql in if ql==ql' then entry else (k,ql')) obj let map_strategy f l = let l' = List.fold_right (fun (lev,ql) str -> let ql' = List.fold_right (fun q ql -> match f q with Some q' -> q' :: ql | None -> ql) ql [] in if ql'=[] then str else (lev,ql')::str) l [] in if l'=[] then None else Some (false,l') let classify_strategy (local,_ as obj) = if local then Dispose else Substitute obj let disch_ref ref = match ref with EvalConstRef c -> let c' = Lib.discharge_con c in if c==c' then Some ref else Some (EvalConstRef c') | EvalVarRef id -> if Lib.is_in_section (VarRef id) then None else Some ref let discharge_strategy (_,(local,obj)) = if local then None else map_strategy disch_ref obj type strategy_obj = bool * (Conv_oracle.level * evaluable_global_reference list) list let inStrategy : strategy_obj -> obj = declare_object {(default_object "STRATEGY") with cache_function = (fun (_,obj) -> cache_strategy obj); load_function = (fun _ (_,obj) -> cache_strategy obj); subst_function = subst_strategy; discharge_function = discharge_strategy; classify_function = classify_strategy } let set_strategy local str = Lib.add_anonymous_leaf (inStrategy (local,str)) let _ = declare_summary "Transparent constants and variables" { freeze_function = Conv_oracle.freeze; unfreeze_function = Conv_oracle.unfreeze; init_function = Conv_oracle.init } (* Generic reduction: reduction functions used in reduction tactics *) type red_expr = (constr, evaluable_global_reference, constr_pattern) red_expr_gen let make_flag_constant = function | EvalVarRef id -> fVAR id | EvalConstRef sp -> fCONST sp let make_flag f = let red = no_red in let red = if f.rBeta then red_add red fBETA else red in let red = if f.rIota then red_add red fIOTA else red in let red = if f.rZeta then red_add red fZETA else red in let red = if f.rDelta then (* All but rConst *) let red = red_add red fDELTA in let red = red_add_transparent red (Conv_oracle.get_transp_state()) in List.fold_right (fun v red -> red_sub red (make_flag_constant v)) f.rConst red else (* Only rConst *) let red = red_add_transparent (red_add red fDELTA) all_opaque in List.fold_right (fun v red -> red_add red (make_flag_constant v)) f.rConst red in red let is_reference = function PRef _ | PVar _ -> true | _ -> false (* table of custom reductino fonctions, not synchronized, filled via ML calls to [declare_reduction] *) let reduction_tab = ref Stringmap.empty (* table of custom reduction expressions, synchronized, filled by command Declare Reduction *) let red_expr_tab = ref Stringmap.empty let declare_reduction s f = if Stringmap.mem s !reduction_tab || Stringmap.mem s !red_expr_tab then error ("There is already a reduction expression of name "^s) else reduction_tab := Stringmap.add s f !reduction_tab let check_custom = function | ExtraRedExpr s -> if not (Stringmap.mem s !reduction_tab || Stringmap.mem s !red_expr_tab) then error ("Reference to undefined reduction expression "^s) |_ -> () let decl_red_expr s e = if Stringmap.mem s !reduction_tab || Stringmap.mem s !red_expr_tab then error ("There is already a reduction expression of name "^s) else begin check_custom e; red_expr_tab := Stringmap.add s e !red_expr_tab end let out_arg = function | ArgVar _ -> anomaly "Unevaluated or_var variable" | ArgArg x -> x let out_with_occurrences ((b,l),c) = ((b,List.map out_arg l), c) let rec reduction_of_red_expr = function | Red internal -> if internal then (try_red_product,DEFAULTcast) else (red_product,DEFAULTcast) | Hnf -> (hnf_constr,DEFAULTcast) | Simpl (Some (_,c as lp)) -> (contextually (is_reference c) (out_with_occurrences lp) (fun _ -> simpl),DEFAULTcast) | Simpl None -> (simpl,DEFAULTcast) | Cbv f -> (cbv_norm_flags (make_flag f),DEFAULTcast) | Lazy f -> (clos_norm_flags (make_flag f),DEFAULTcast) | Unfold ubinds -> (unfoldn (List.map out_with_occurrences ubinds),DEFAULTcast) | Fold cl -> (fold_commands cl,DEFAULTcast) | Pattern lp -> (pattern_occs (List.map out_with_occurrences lp),DEFAULTcast) | ExtraRedExpr s -> (try (Stringmap.find s !reduction_tab,DEFAULTcast) with Not_found -> (try reduction_of_red_expr (Stringmap.find s !red_expr_tab) with Not_found -> error("unknown user-defined reduction \""^s^"\""))) | CbvVm -> (cbv_vm ,VMcast) let subst_flags subs flags = { flags with rConst = List.map subs flags.rConst } let subst_occs subs (occ,e) = (occ,subs e) let subst_gen_red_expr subs_a subs_b subs_c = function | Fold l -> Fold (List.map subs_a l) | Pattern occs_l -> Pattern (List.map (subst_occs subs_a) occs_l) | Simpl occs_o -> Simpl (Option.map (subst_occs subs_c) occs_o) | Unfold occs_l -> Unfold (List.map (subst_occs subs_b) occs_l) | Cbv flags -> Cbv (subst_flags subs_b flags) | Lazy flags -> Lazy (subst_flags subs_b flags) | e -> e let subst_red_expr subs e = subst_gen_red_expr (Mod_subst.subst_mps subs) (Mod_subst.subst_evaluable_reference subs) (Pattern.subst_pattern subs) e let inReduction : bool * string * red_expr -> obj = declare_object {(default_object "REDUCTION") with cache_function = (fun (_,(_,s,e)) -> decl_red_expr s e); load_function = (fun _ (_,(_,s,e)) -> decl_red_expr s e); subst_function = (fun (subs,(b,s,e)) -> b,s,subst_red_expr subs e); classify_function = (fun ((b,_,_) as obj) -> if b then Dispose else Substitute obj) } let declare_red_expr locality s expr = Lib.add_anonymous_leaf (inReduction (locality,s,expr)) let _ = declare_summary "Declare Reduction" { freeze_function = (fun () -> !red_expr_tab); unfreeze_function = ((:=) red_expr_tab); init_function = (fun () -> red_expr_tab := Stringmap.empty) } coq-8.4pl4/proofs/clenv.mli0000644000175000017500000001231612326224777014760 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* clausenv -> clausenv (** subject of clenv (instantiated) *) val clenv_value : clausenv -> constr (** type of clenv (instantiated) *) val clenv_type : clausenv -> types (** substitute resolved metas *) val clenv_nf_meta : clausenv -> constr -> constr (** type of a meta in clenv context *) val clenv_meta_type : clausenv -> metavariable -> types val mk_clenv_from : Goal.goal sigma -> constr * types -> clausenv val mk_clenv_from_n : Goal.goal sigma -> int option -> constr * types -> clausenv val mk_clenv_type_of : Goal.goal sigma -> constr -> clausenv val mk_clenv_from_env : env -> evar_map -> int option -> constr * types -> clausenv (** {6 linking of clenvs } *) val connect_clenv : Goal.goal sigma -> clausenv -> clausenv val clenv_fchain : ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv (** {6 Unification with clenvs } *) (** Unifies two terms in a clenv. The boolean is [allow_K] (see [Unification]) *) val clenv_unify : ?flags:unify_flags -> conv_pb -> constr -> constr -> clausenv -> clausenv (** unifies the concl of the goal with the type of the clenv *) val clenv_unique_resolver : ?flags:unify_flags -> clausenv -> Goal.goal sigma -> clausenv (** same as above ([allow_K=false]) but replaces remaining metas with fresh evars if [evars_flag] is [true] *) val evar_clenv_unique_resolver : ?flags:unify_flags -> clausenv -> Goal.goal sigma -> clausenv val clenv_dependent : clausenv -> metavariable list val clenv_pose_metas_as_evars : clausenv -> metavariable list -> clausenv (** {6 Bindings } *) type arg_bindings = constr explicit_bindings (** bindings where the key is the position in the template of the clenv (dependent or not). Positions can be negative meaning to start from the rightmost argument of the template. *) val clenv_independent : clausenv -> metavariable list val clenv_missing : clausenv -> metavariable list (** for the purpose of inversion tactics *) exception NoSuchBinding val clenv_constrain_last_binding : constr -> clausenv -> clausenv (** defines metas corresponding to the name of the bindings *) val clenv_match_args : arg_bindings -> clausenv -> clausenv val clenv_unify_meta_types : ?flags:unify_flags -> clausenv -> clausenv (** start with a clenv to refine with a given term with bindings *) (** the arity of the lemma is fixed the optional int tells how many prods of the lemma have to be used use all of them if None *) val make_clenv_binding_env_apply : env -> evar_map -> int option -> constr * constr -> constr bindings -> clausenv val make_clenv_binding_apply : Goal.goal sigma -> int option -> constr * constr -> constr bindings -> clausenv val make_clenv_binding : Goal.goal sigma -> constr * constr -> constr bindings -> clausenv (** [clenv_environments sigma n t] returns [sigma',lmeta,ccl] where [lmetas] is a list of metas to be applied to a proof of [t] so that it produces the unification pattern [ccl]; [sigma'] is [sigma] extended with [lmetas]; if [n] is defined, it limits the size of the list even if [ccl] is still a product; otherwise, it stops when [ccl] is not a product; example: if [t] is [forall x y, x=y -> y=x] and [n] is [None], then [lmetas] is [Meta n1;Meta n2;Meta n3] and [ccl] is [Meta n1=Meta n2]; if [n] is [Some 1], [lmetas] is [Meta n1] and [ccl] is [forall y, Meta n1=y -> y=Meta n1] *) val clenv_environments : evar_map -> int option -> types -> evar_map * constr list * types (** [clenv_environments_evars env sigma n t] does the same but returns a list of Evar's defined in [env] and extends [sigma] accordingly *) val clenv_environments_evars : env -> evar_map -> int option -> types -> evar_map * constr list * types (** [clenv_conv_leq env sigma t c n] looks for c1...cn s.t. [t <= c c1...cn] *) val clenv_conv_leq : env -> evar_map -> types -> constr -> int -> constr list (** if the clause is a product, add an extra meta for this product *) exception NotExtensibleClause val clenv_push_prod : clausenv -> clausenv (** {6 Pretty-print (debug only) } *) val pr_clenv : clausenv -> Pp.std_ppcmds coq-8.4pl4/proofs/proof_type.mli0000644000175000017500000001057312326224777016042 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* goal list sigma type prim_rule = | Intro of identifier | Cut of bool * bool * identifier * types | FixRule of identifier * int * (identifier * int * constr) list * int | Cofix of identifier * (identifier * constr) list * int | Refine of constr | Convert_concl of types * cast_kind | Convert_hyp of named_declaration | Thin of identifier list | ThinBody of identifier list | Move of bool * identifier * identifier move_location | Order of identifier list | Rename of identifier * identifier | Change_evars (** The type [goal sigma] is the type of subgoal. It has the following form {v it = \{ evar_concl = [the conclusion of the subgoal] evar_hyps = [the hypotheses of the subgoal] evar_body = Evar_Empty; evar_info = \{ pgm : [The Realizer pgm if any] lc : [Set of evar num occurring in subgoal] \}\} sigma = \{ stamp = [an int chardacterizing the ed field, for quick compare] ed : [A set of existential variables depending in the subgoal] number of first evar, it = \{ evar_concl = [the type of first evar] evar_hyps = [the context of the evar] evar_body = [the body of the Evar if any] evar_info = \{ pgm : [Useless ??] lc : [Set of evars occurring in the type of evar] \} \}; ... number of last evar, it = \{ evar_concl = [the type of evar] evar_hyps = [the context of the evar] evar_body = [the body of the Evar if any] evar_info = \{ pgm : [Useless ??] lc : [Set of evars occurring in the type of evar] \} \} \} v} *) (** {6 ... } *) (** Proof trees. [ref] = [None] if the goal has still to be proved, and [Some (r,l)] if the rule [r] was applied to the goal and gave [l] as subproofs to be completed. if [ref = (Some(Nested(Tactic t,p),l))] then [p] is the proof that the goal can be proven if the goals in [l] are solved. *) type proof_tree = { goal : goal; ref : (rule * proof_tree list) option } and rule = | Prim of prim_rule | Nested of compound_rule * proof_tree | Decl_proof of bool | Daimon and compound_rule= (** the boolean of Tactic tells if the default tactic is used *) | Tactic of tactic_expr * bool and tactic_expr = (constr, constr_pattern, evaluable_global_reference, inductive, ltac_constant, identifier, glob_tactic_expr, tlevel) Tacexpr.gen_tactic_expr and atomic_tactic_expr = (constr, constr_pattern, evaluable_global_reference, inductive, ltac_constant, identifier, glob_tactic_expr, tlevel) Tacexpr.gen_atomic_tactic_expr and tactic_arg = (constr, constr_pattern, evaluable_global_reference, inductive, ltac_constant, identifier, glob_tactic_expr, tlevel) Tacexpr.gen_tactic_arg type ltac_call_kind = | LtacNotationCall of string | LtacNameCall of ltac_constant | LtacAtomCall of glob_atomic_tactic_expr * atomic_tactic_expr option ref | LtacVarCall of identifier * glob_tactic_expr | LtacConstrInterp of glob_constr * (extended_patvar_map * (identifier * identifier option) list) type ltac_trace = (int * loc * ltac_call_kind) list exception LtacLocated of (int * ltac_call_kind * ltac_trace * loc) * exn val abstract_tactic_box : atomic_tactic_expr option ref ref coq-8.4pl4/proofs/clenv.ml0000644000175000017500000004453412326224777014616 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* clrec t | Prod (na,t,u) -> let mv = new_meta () in let dep = dependent (mkRel 1) u in let na' = if dep then na else Anonymous in let e' = meta_declare mv t ~name:na' cl.evd in let concl = if dep then subst1 (mkMeta mv) u else u in let def = applist (cl.templval.rebus,[mkMeta mv]) in { templval = mk_freelisted def; templtyp = mk_freelisted concl; evd = e'; env = cl.env } | _ -> raise NotExtensibleClause in clrec typ (* Instantiate the first [bound] products of [t] with metas (all products if [bound] is [None]; unfold local defs *) let clenv_environments evd bound t = let rec clrec (e,metas) n t = match n, kind_of_term t with | (Some 0, _) -> (e, List.rev metas, t) | (n, Cast (t,_,_)) -> clrec (e,metas) n t | (n, Prod (na,t1,t2)) -> let mv = new_meta () in let dep = dependent (mkRel 1) t2 in let na' = if dep then na else Anonymous in let e' = meta_declare mv t1 ~name:na' e in clrec (e', (mkMeta mv)::metas) (Option.map ((+) (-1)) n) (if dep then (subst1 (mkMeta mv) t2) else t2) | (n, LetIn (na,b,_,t)) -> clrec (e,metas) n (subst1 b t) | (n, _) -> (e, List.rev metas, t) in clrec (evd,[]) bound t (* Instantiate the first [bound] products of [t] with evars (all products if [bound] is [None]; unfold local defs *) let clenv_environments_evars env evd bound t = let rec clrec (e,ts) n t = match n, kind_of_term t with | (Some 0, _) -> (e, List.rev ts, t) | (n, Cast (t,_,_)) -> clrec (e,ts) n t | (n, Prod (na,t1,t2)) -> let e',constr = Evarutil.new_evar e env t1 in let dep = dependent (mkRel 1) t2 in clrec (e', constr::ts) (Option.map ((+) (-1)) n) (if dep then (subst1 constr t2) else t2) | (n, LetIn (na,b,_,t)) -> clrec (e,ts) n (subst1 b t) | (n, _) -> (e, List.rev ts, t) in clrec (evd,[]) bound t let clenv_conv_leq env sigma t c bound = let ty = Retyping.get_type_of env sigma c in let evd = Evd.create_goal_evar_defs sigma in let evars,args,_ = clenv_environments_evars env evd (Some bound) ty in let evars = Evarconv.the_conv_x_leq env t (applist (c,args)) evars in let evars = Evarconv.consider_remaining_unif_problems env evars in let args = List.map (whd_evar evars) args in check_evars env sigma evars (applist (c,args)); args let mk_clenv_from_env environ sigma n (c,cty) = let evd = create_goal_evar_defs sigma in let (evd,args,concl) = clenv_environments evd n cty in { templval = mk_freelisted (match args with [] -> c | _ -> applist (c,args)); templtyp = mk_freelisted concl; evd = evd; env = environ } let mk_clenv_from_n gls n (c,cty) = mk_clenv_from_env (pf_env gls) gls.sigma n (c, cty) let mk_clenv_from gls = mk_clenv_from_n gls None let mk_clenv_type_of gls t = mk_clenv_from gls (t,pf_type_of gls t) (******************************************************************) (* [mentions clenv mv0 mv1] is true if mv1 is defined and mentions * mv0, or if one of the free vars on mv1's freelist mentions * mv0 *) let mentions clenv mv0 = let rec menrec mv1 = mv0 = mv1 || let mlist = try match meta_opt_fvalue clenv.evd mv1 with | Some (b,_) -> b.freemetas | None -> Metaset.empty with Not_found -> Metaset.empty in meta_exists menrec mlist in menrec let error_incompatible_inst clenv mv = let na = meta_name clenv.evd mv in match na with Name id -> errorlabstrm "clenv_assign" (str "An incompatible instantiation has already been found for " ++ pr_id id) | _ -> anomaly "clenv_assign: non dependent metavar already assigned" (* TODO: replace by clenv_unify (mkMeta mv) rhs ? *) let clenv_assign mv rhs clenv = let rhs_fls = mk_freelisted rhs in if meta_exists (mentions clenv mv) rhs_fls.freemetas then error "clenv_assign: circularity in unification"; try if meta_defined clenv.evd mv then if not (eq_constr (fst (meta_fvalue clenv.evd mv)).rebus rhs) then error_incompatible_inst clenv mv else clenv else let st = (Conv,TypeNotProcessed) in {clenv with evd = meta_assign mv (rhs_fls.rebus,st) clenv.evd} with Not_found -> error "clenv_assign: undefined meta" (* [clenv_dependent hyps_only clenv] * returns a list of the metavars which appear in the template of clenv, * and which are dependent, This is computed by taking the metavars of the * template in right-to-left order, and collecting the metavars which appear * in their types, and adding in all the metavars appearing in the * type of clenv. * If [hyps_only] then metavariables occurring in the concl are _excluded_ * If [iter] is also set then all metavariables *recursively* occurring * in the concl are _excluded_ Details of the strategies used for computing the set of unresolved dependent metavariables We typically have a clause of the form lem(?T:Type,?T,?U:Type,?V:Type,?x:?T,?y:?U,?z:?V,?H:hyp(?x,?z)) :concl(?y,?z) Then, we compute: A = the set of all unresolved metas C = the set of metas occurring in concl (here ?y, ?z) C* = the recursive closure of C wrt types (here ?y, ?z, ?U, ?V) D = the set of metas occurring in a type of meta (here ?x, ?T, ?z, ?U, ?V) NL = the set of duplicated metas even if non dependent (here ?T) (we make the assumption that duplicated metas have internal dependencies) Then, for the "apply"-style tactic (hyps_only), missing metas are A inter ((D minus C) union NL) for the optimized "apply"-style tactic (taking in care, f_equal style lemma, from 2/8/10, Coq > 8.3), missing metas are A inter (( D minus C* ) union NL) for the "elim"-style tactic, missing metas are A inter (D union C union NL) In any case, we respect the order given in A. *) let clenv_metas_in_type_of_meta evd mv = (mk_freelisted (meta_instance evd (meta_ftype evd mv))).freemetas let dependent_in_type_of_metas clenv mvs = List.fold_right (fun mv -> Metaset.union (clenv_metas_in_type_of_meta clenv.evd mv)) mvs Metaset.empty let dependent_closure clenv mvs = let rec aux mvs acc = Metaset.fold (fun mv deps -> let metas_of_meta_type = clenv_metas_in_type_of_meta clenv.evd mv in aux metas_of_meta_type (Metaset.union deps metas_of_meta_type)) mvs acc in aux mvs mvs let clenv_dependent_gen hyps_only ?(iter=true) clenv = let all_undefined = undefined_metas clenv.evd in let deps_in_concl = (mk_freelisted (clenv_type clenv)).freemetas in let deps_in_hyps = dependent_in_type_of_metas clenv all_undefined in let deps_in_concl = if hyps_only && iter then dependent_closure clenv deps_in_concl else deps_in_concl in List.filter (fun mv -> if hyps_only then Metaset.mem mv deps_in_hyps && not (Metaset.mem mv deps_in_concl) else Metaset.mem mv deps_in_hyps || Metaset.mem mv deps_in_concl) all_undefined let clenv_missing ce = clenv_dependent_gen true ce let clenv_dependent ce = clenv_dependent_gen false ce (******************************************************************) let clenv_unify ?(flags=default_unify_flags) cv_pb t1 t2 clenv = { clenv with evd = w_unify ~flags clenv.env clenv.evd cv_pb t1 t2 } let clenv_unify_meta_types ?(flags=default_unify_flags) clenv = { clenv with evd = w_unify_meta_types ~flags:flags clenv.env clenv.evd } let clenv_unique_resolver ?(flags=default_unify_flags) clenv gl = let concl = Goal.V82.concl clenv.evd (sig_it gl) in if isMeta (fst (whd_stack clenv.evd clenv.templtyp.rebus)) then clenv_unify CUMUL ~flags (clenv_type clenv) concl (clenv_unify_meta_types ~flags clenv) else clenv_unify CUMUL ~flags (meta_reducible_instance clenv.evd clenv.templtyp) concl clenv (* [clenv_pose_metas_as_evars clenv dep_mvs] * For each dependent evar in the clause-env which does not have a value, * pose a value for it by constructing a fresh evar. We do this in * left-to-right order, so that every evar's type is always closed w.r.t. * metas. * Node added 14/4/08 [HH]: before this date, evars were collected in clenv_dependent by collect_metas in the fold_constr order which is (almost) the left-to-right order of dependencies in term. However, due to K-redexes, collect_metas was sometimes missing some metas. The call to collect_metas has been replaced by a call to undefined_metas, but then the order was the one of definition of the metas (numbers in increasing order) which is _not_ the dependency order when a clenv_fchain occurs (because clenv_fchain plugs a term with a list of consecutive metas in place of a - a priori - arbitrary metavariable belonging to another sequence of consecutive metas: e.g., clenv_fchain may plug (H ?1 ?2) at the position ?6 of (nat_ind ?3 ?4 ?5 ?6), leading to a dependency order 3<4<5<1<2). To ensure the dependency order, we check that the type of each meta to pose is already meta-free, otherwise we postpone the transformation, hoping that no cycle may happen. Another approach could have been to use decimal numbers for metas so that in the example above, (H ?1 ?2) would have been renumbered (H ?6.1 ?6.2) then making the numeric order match the dependency order. *) let clenv_pose_metas_as_evars clenv dep_mvs = let rec fold clenv = function | [] -> clenv | mv::mvs -> let ty = clenv_meta_type clenv mv in (* Postpone the evar-ization if dependent on another meta *) (* This assumes no cycle in the dependencies - is it correct ? *) if occur_meta ty then fold clenv (mvs@[mv]) else let (evd,evar) = new_evar clenv.evd (cl_env clenv) ~src:(dummy_loc,GoalEvar) ty in let clenv = clenv_assign mv evar {clenv with evd=evd} in fold clenv mvs in fold clenv dep_mvs let evar_clenv_unique_resolver = clenv_unique_resolver (******************************************************************) let connect_clenv gls clenv = let evd = evars_reset_evd ~with_conv_pbs:true gls.sigma clenv.evd in { clenv with evd = evd ; env = Goal.V82.env evd (sig_it gls) } (* [clenv_fchain mv clenv clenv'] * * Resolves the value of "mv" (which must be undefined) in clenv to be * the template of clenv' be the value "c", applied to "n" fresh * metavars, whose types are chosen by destructing "clf", which should * be a clausale forme generated from the type of "c". The process of * resolution can cause unification of already-existing metavars, and * of the fresh ones which get created. This operation is a composite * of operations which pose new metavars, perform unification on * terms, and make bindings. Otherwise said, from [clenv] = [env;sigma;metas |- c:T] [clenv'] = [env';sigma';metas' |- d:U] [mv] = [mi] of type [Ti] in [metas] then, if the unification of [Ti] and [U] produces map [rho], the chaining is [env';sigma';rho'(metas),rho(metas') |- c:rho'(T)] for [rho'] being [rho;mi:=d]. In particular, it assumes that [env'] and [sigma'] extend [env] and [sigma]. *) let fchain_flags = { default_unify_flags with allow_K_in_toplevel_higher_order_unification = true } let clenv_fchain ?(flags=fchain_flags) mv clenv nextclenv = (* Add the metavars of [nextclenv] to [clenv], with their name-environment *) let clenv' = { templval = clenv.templval; templtyp = clenv.templtyp; evd = meta_merge nextclenv.evd clenv.evd; env = nextclenv.env } in (* unify the type of the template of [nextclenv] with the type of [mv] *) let clenv'' = clenv_unify ~flags:flags CUMUL (clenv_term clenv' nextclenv.templtyp) (clenv_meta_type clenv' mv) clenv' in (* assign the metavar *) let clenv''' = clenv_assign mv (clenv_term clenv' nextclenv.templval) clenv'' in clenv''' (***************************************************************) (* Bindings *) type arg_bindings = constr explicit_bindings (* [clenv_independent clenv] * returns a list of metavariables which appear in the term cval, * and which are not dependent. That is, they do not appear in * the types of other metavars which are in cval, nor in the type * of cval, ctyp. *) let clenv_independent clenv = let mvs = collect_metas (clenv_value clenv) in let ctyp_mvs = (mk_freelisted (clenv_type clenv)).freemetas in let deps = Metaset.union (dependent_in_type_of_metas clenv mvs) ctyp_mvs in List.filter (fun mv -> not (Metaset.mem mv deps)) mvs let check_bindings bl = match list_duplicates (List.map pi2 bl) with | NamedHyp s :: _ -> errorlabstrm "" (str "The variable " ++ pr_id s ++ str " occurs more than once in binding list."); | AnonHyp n :: _ -> errorlabstrm "" (str "The position " ++ int n ++ str " occurs more than once in binding list.") | [] -> () let meta_of_binder clause loc mvs = function | NamedHyp s -> meta_with_name clause.evd s | AnonHyp n -> try List.nth mvs (n-1) with (Failure _|Invalid_argument _) -> errorlabstrm "" (str "No such binder.") let error_already_defined b = match b with | NamedHyp id -> errorlabstrm "" (str "Binder name \"" ++ pr_id id ++ str"\" already defined with incompatible value.") | AnonHyp n -> anomalylabstrm "" (str "Position " ++ int n ++ str" already defined.") let clenv_unify_binding_type clenv c t u = if isMeta (fst (whd_stack clenv.evd u)) then (* Not enough information to know if some subtyping is needed *) CoerceToType, clenv, c else (* Enough information so as to try a coercion now *) try let evd,c = w_coerce_to_type (cl_env clenv) clenv.evd c t u in TypeProcessed, { clenv with evd = evd }, c with | PretypeError (_,_,NotClean _) as e -> raise e | e when precatchable_exception e -> TypeNotProcessed, clenv, c let clenv_assign_binding clenv k c = let k_typ = clenv_hnf_constr clenv (clenv_meta_type clenv k) in let c_typ = nf_betaiota clenv.evd (clenv_get_type_of clenv c) in let status,clenv',c = clenv_unify_binding_type clenv c c_typ k_typ in { clenv' with evd = meta_assign k (c,(Conv,status)) clenv'.evd } let clenv_match_args bl clenv = if bl = [] then clenv else let mvs = clenv_independent clenv in check_bindings bl; List.fold_left (fun clenv (loc,b,c) -> let k = meta_of_binder clenv loc mvs b in if meta_defined clenv.evd k then if eq_constr (fst (meta_fvalue clenv.evd k)).rebus c then clenv else error_already_defined b else clenv_assign_binding clenv k c) clenv bl exception NoSuchBinding let clenv_constrain_last_binding c clenv = let all_mvs = collect_metas clenv.templval.rebus in let k = try list_last all_mvs with Failure _ -> raise NoSuchBinding in clenv_assign_binding clenv k c let error_not_right_number_missing_arguments n = errorlabstrm "" (strbrk "Not the right number of missing arguments (expected " ++ int n ++ str ").") let clenv_constrain_dep_args hyps_only bl clenv = if bl = [] then clenv else let occlist = clenv_dependent_gen hyps_only clenv in if List.length occlist = List.length bl then List.fold_left2 clenv_assign_binding clenv occlist bl else if hyps_only then (* Tolerance for compatibility <= 8.3 *) let occlist' = clenv_dependent_gen hyps_only ~iter:false clenv in if List.length occlist' = List.length bl then List.fold_left2 clenv_assign_binding clenv occlist' bl else error_not_right_number_missing_arguments (List.length occlist) else error_not_right_number_missing_arguments (List.length occlist) (****************************************************************) (* Clausal environment for an application *) let make_clenv_binding_gen hyps_only n env sigma (c,t) = function | ImplicitBindings largs -> let clause = mk_clenv_from_env env sigma n (c,t) in clenv_constrain_dep_args hyps_only largs clause | ExplicitBindings lbind -> let clause = mk_clenv_from_env env sigma n (c,rename_bound_vars_as_displayed [] [] t) in clenv_match_args lbind clause | NoBindings -> mk_clenv_from_env env sigma n (c,t) let make_clenv_binding_env_apply env sigma n = make_clenv_binding_gen true n env sigma let make_clenv_binding_apply gls n = make_clenv_binding_gen true n (pf_env gls) gls.sigma let make_clenv_binding gls = make_clenv_binding_gen false None (pf_env gls) gls.sigma (****************************************************************) (* Pretty-print *) let pr_clenv clenv = h 0 (str"TEMPL: " ++ print_constr clenv.templval.rebus ++ str" : " ++ print_constr clenv.templtyp.rebus ++ fnl () ++ pr_evar_map (Some 2) clenv.evd) coq-8.4pl4/proofs/logic.mli0000644000175000017500000000345112326224777014746 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* tactic (** [without_check] respectively means:\\ [Intro]: no check that the name does not exist\\ [Intro_after]: no check that the name does not exist and that variables in its type does not escape their scope\\ [Intro_replacing]: no check that the name does not exist and that variables in its type does not escape their scope\\ [Convert_hyp]: no check that the name exist and that its type is convertible\\ *) (** The primitive refiner. *) val prim_refiner : prim_rule -> evar_map -> goal -> goal list * evar_map type proof_variable val proof_variable_index : identifier -> proof_variable list -> int (** {6 Refiner errors. } *) type refiner_error = (*i Errors raised by the refiner i*) | BadType of constr * constr * constr | UnresolvedBindings of name list | CannotApply of constr * constr | NotWellTyped of constr | NonLinearProof of constr | MetaInType of constr (*i Errors raised by the tactics i*) | IntroNeedsProduct | DoesNotOccurIn of constr * identifier exception RefinerError of refiner_error val catchable_exception : exn -> bool coq-8.4pl4/proofs/tactic_debug.ml0000644000175000017500000001655112326224777016122 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* assert false) let set_tactic_printer f = prtac := f let prmatchpatt = ref (fun _ _ -> assert false) let set_match_pattern_printer f = prmatchpatt := f let prmatchrl = ref (fun _ -> assert false) let set_match_rule_printer f = prmatchrl := f (* This module intends to be a beginning of debugger for tactic expressions. Currently, it is quite simple and we can hope to have, in the future, a more complete panel of commands dedicated to a proof assistant framework *) (* Debug information *) type debug_info = | DebugOn of int | DebugOff (* An exception handler *) let explain_logic_error = ref (fun e -> mt()) let explain_logic_error_no_anomaly = ref (fun e -> mt()) (* Prints the goal *) let db_pr_goal g = let env = Refiner.pf_env g in let penv = print_named_context env in let pc = print_constr_env env (Goal.V82.concl (Refiner.project g) (Refiner.sig_it g)) in str" " ++ hv 0 (penv ++ fnl () ++ str "============================" ++ fnl () ++ str" " ++ pc) ++ fnl () let db_pr_goal g = msgnl (str "Goal:" ++ fnl () ++ db_pr_goal g) (* Prints the commands *) let help () = msgnl (str "Commands: = Continue" ++ fnl() ++ str " h/? = Help" ++ fnl() ++ str " r = Run times" ++ fnl() ++ str " r = Run up to next idtac " ++ fnl() ++ str " s = Skip" ++ fnl() ++ str " x = Exit") (* Prints the goal and the command to be executed *) let goal_com g tac = begin db_pr_goal g; msg (str "Going to execute:" ++ fnl () ++ !prtac tac ++ fnl ()) end let skipped = ref 0 let skip = ref 0 let breakpoint = ref None let rec drop_spaces inst i = if String.length inst > i && inst.[i] = ' ' then drop_spaces inst (i+1) else i let possibly_unquote s = if String.length s >= 2 & s.[0] = '"' & s.[String.length s - 1] = '"' then String.sub s 1 (String.length s - 2) else s (* (Re-)initialize debugger *) let db_initialize () = skip:=0;skipped:=0;breakpoint:=None (* Gives the number of steps or next breakpoint of a run command *) let run_com inst = if (String.get inst 0)='r' then let i = drop_spaces inst 1 in if String.length inst > i then let s = String.sub inst i (String.length inst - i) in if inst.[0] >= '0' && inst.[0] <= '9' then let num = int_of_string s in if num<0 then raise (Invalid_argument "run_com"); skip:=num;skipped:=0 else breakpoint:=Some (possibly_unquote s) else raise (Invalid_argument "run_com") else raise (Invalid_argument "run_com") (* Prints the run counter *) let run ini = if not ini then begin for i=1 to 2 do print_char (Char.chr 8);print_char (Char.chr 13) done; msg (str "Executed expressions: " ++ int !skipped ++ fnl() ++ fnl()) end; incr skipped (* Prints the prompt *) let rec prompt level = begin msg (fnl () ++ str "TcDebug (" ++ int level ++ str ") > "); flush stdout; let exit () = skip:=0;skipped:=0;raise Sys.Break in let inst = try read_line () with End_of_file -> exit () in match inst with | "" -> DebugOn (level+1) | "s" -> DebugOff | "x" -> print_char (Char.chr 8); exit () | "h"| "?" -> begin help (); prompt level end | _ -> (try run_com inst;run true;DebugOn (level+1) with Failure _ | Invalid_argument _ -> prompt level) end (* Prints the state and waits for an instruction *) let debug_prompt lev g tac f = (* What to print and to do next *) let newlevel = if !skip = 0 then if !breakpoint = None then (goal_com g tac; prompt lev) else (run false; DebugOn (lev+1)) else (decr skip; run false; if !skip=0 then skipped:=0; DebugOn (lev+1)) in (* What to execute *) try f newlevel with reraise -> skip:=0; skipped:=0; if Logic.catchable_exception reraise then ppnl (str "Level " ++ int lev ++ str ": " ++ !explain_logic_error reraise); raise reraise (* Prints a constr *) let db_constr debug env c = if debug <> DebugOff & !skip = 0 & !breakpoint = None then msgnl (str "Evaluated term: " ++ print_constr_env env c) (* Prints the pattern rule *) let db_pattern_rule debug num r = if debug <> DebugOff & !skip = 0 & !breakpoint = None then begin msgnl (str "Pattern rule " ++ int num ++ str ":"); msgnl (str "|" ++ spc () ++ !prmatchrl r) end (* Prints the hypothesis pattern identifier if it exists *) let hyp_bound = function | Anonymous -> " (unbound)" | Name id -> " (bound to "^(Names.string_of_id id)^")" (* Prints a matched hypothesis *) let db_matched_hyp debug env (id,_,c) ido = if debug <> DebugOff & !skip = 0 & !breakpoint = None then msgnl (str "Hypothesis " ++ str ((Names.string_of_id id)^(hyp_bound ido)^ " has been matched: ") ++ print_constr_env env c) (* Prints the matched conclusion *) let db_matched_concl debug env c = if debug <> DebugOff & !skip = 0 & !breakpoint = None then msgnl (str "Conclusion has been matched: " ++ print_constr_env env c) (* Prints a success message when the goal has been matched *) let db_mc_pattern_success debug = if debug <> DebugOff & !skip = 0 & !breakpoint = None then msgnl (str "The goal has been successfully matched!" ++ fnl() ++ str "Let us execute the right-hand side part..." ++ fnl()) (* Prints a failure message for an hypothesis pattern *) let db_hyp_pattern_failure debug env (na,hyp) = if debug <> DebugOff & !skip = 0 & !breakpoint = None then msgnl (str ("The pattern hypothesis"^(hyp_bound na)^ " cannot match: ") ++ !prmatchpatt env hyp) (* Prints a matching failure message for a rule *) let db_matching_failure debug = if debug <> DebugOff & !skip = 0 & !breakpoint = None then msgnl (str "This rule has failed due to matching errors!" ++ fnl() ++ str "Let us try the next one...") (* Prints an evaluation failure message for a rule *) let db_eval_failure debug s = if debug <> DebugOff & !skip = 0 & !breakpoint = None then let s = str "message \"" ++ s ++ str "\"" in msgnl (str "This rule has failed due to \"Fail\" tactic (" ++ s ++ str ", level 0)!" ++ fnl() ++ str "Let us try the next one...") (* Prints a logic failure message for a rule *) let db_logic_failure debug err = if debug <> DebugOff & !skip = 0 & !breakpoint = None then begin msgnl (!explain_logic_error err); msgnl (str "This rule has failed due to a logic error!" ++ fnl() ++ str "Let us try the next one...") end let is_breakpoint brkname s = match brkname, s with | Some s, MsgString s'::_ -> s = s' | _ -> false let db_breakpoint debug s = match debug with | DebugOn lev when s <> [] & is_breakpoint !breakpoint s -> breakpoint:=None | _ -> () coq-8.4pl4/proofs/pfedit.mli0000644000175000017500000001403712326224777015126 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool (** [check_no_pending_proofs ()] fails if there is still some proof in progress *) val check_no_pending_proofs : unit -> unit (** {6 ... } *) (** [delete_proof name] deletes proof of name [name] or fails if no proof has this name *) val delete_proof : identifier located -> unit (** [delete_current_proof ()] deletes current focused proof or fails if no proof is focused *) val delete_current_proof : unit -> unit (** [delete_all_proofs ()] deletes all open proofs if any *) val delete_all_proofs : unit -> unit (** {6 ... } *) (** [undo n] undoes the effect of the last [n] tactics applied to the current proof; it fails if no proof is focused or if the ``undo'' stack is exhausted *) val undo : int -> unit (** [undo_todepth n] resets the proof to its nth step (does [undo (d-n)] where d is the depth of the undo stack). *) val undo_todepth : int -> unit (** Returns the depth of the current focused proof stack, this is used to put informations in coq prompt (in emacs mode). *) val current_proof_depth: unit -> int (** {6 ... } *) (** [start_proof s str env t hook tac] starts a proof of name [s] and conclusion [t]; [hook] is optionally a function to be applied at proof end (e.g. to declare the built constructions as a coercion or a setoid morphism); init_tac is possibly a tactic to systematically apply at initialization time (e.g. to start the proof of mutually dependent theorems) *) type lemma_possible_guards = Proof_global.lemma_possible_guards val start_proof : identifier -> goal_kind -> named_context_val -> constr -> ?init_tac:tactic -> ?compute_guard:lemma_possible_guards -> declaration_hook -> unit (** [restart_proof ()] restarts the current focused proof from the beginning or fails if no proof is focused *) val restart_proof : unit -> unit (** {6 ... } *) (** [cook_proof opacity] turns the current proof (assumed completed) into a constant with its name, kind and possible hook (see [start_proof]); it fails if there is no current proof of if it is not completed; it also tells if the guardness condition has to be inferred. *) val cook_proof : (Proof.proof -> unit) -> identifier * (Entries.definition_entry * lemma_possible_guards * goal_kind * declaration_hook) (** To export completed proofs to xml *) val set_xml_cook_proof : (goal_kind * Proof.proof -> unit) -> unit (** {6 ... } *) (** [get_Proof.proof ()] returns the current focused pending proof or raises [UserError "no focused proof"] *) val get_pftreestate : unit -> Proof.proof (** [get_goal_context n] returns the context of the [n]th subgoal of the current focused proof or raises a [UserError] if there is no focused proof or if there is no more subgoals *) val get_goal_context : int -> Evd.evar_map * env (** [get_current_goal_context ()] works as [get_goal_context 1] *) val get_current_goal_context : unit -> Evd.evar_map * env (** [current_proof_statement] *) val current_proof_statement : unit -> identifier * goal_kind * types * declaration_hook (** {6 ... } *) (** [get_current_proof_name ()] return the name of the current focused proof or failed if no proof is focused *) val get_current_proof_name : unit -> identifier (** [get_all_proof_names ()] returns the list of all pending proof names. The first name is the current proof, the other names may come in any order. *) val get_all_proof_names : unit -> identifier list (** {6 ... } *) (** [set_end_tac tac] applies tactic [tac] to all subgoal generate by [solve_nth] *) val set_end_tac : tactic -> unit (** {6 ... } *) (** [set_used_variables l] declares that section variables [l] will be used in the proof *) val set_used_variables : identifier list -> unit val get_used_variables : unit -> Sign.section_context option (** {6 ... } *) (** [solve_nth n tac] applies tactic [tac] to the [n]th subgoal of the current focused proof or raises a UserError if no proof is focused or if there is no [n]th subgoal *) val solve_nth : ?with_end_tac:bool -> int -> tactic -> unit (** [by tac] applies tactic [tac] to the 1st subgoal of the current focused proof or raises a UserError if there is no focused proof or if there is no more subgoals *) val by : tactic -> unit (** [instantiate_nth_evar_com n c] instantiate the [n]th undefined existential variable of the current focused proof by [c] or raises a UserError if no proof is focused or if there is no such [n]th existential variable *) val instantiate_nth_evar_com : int -> Topconstr.constr_expr -> unit (** [build_by_tactic typ tac] returns a term of type [typ] by calling [tac] *) val build_constant_by_tactic : identifier -> named_context_val -> types -> tactic -> Entries.definition_entry val build_by_tactic : env -> types -> tactic -> constr (** Declare the default tactic to fill implicit arguments *) val declare_implicit_tactic : tactic -> unit (* Raise Exit if cannot solve *) val solve_by_implicit_tactic : env -> Evd.evar_map -> existential -> constr coq-8.4pl4/proofs/evar_refiner.ml0000644000175000017500000000433312326224777016147 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* try head_evar t2 = evk with NoHeadEvar -> false let define_and_solve_constraints evk c evd = try let evd = define evk c evd in let (evd,pbs) = extract_changed_conv_pbs evd (depends_on_evar evk) in fst (List.fold_left (fun (evd,b as p) (pbty,env,t1,t2) -> if b then Evarconv.evar_conv_x full_transparent_state env evd pbty t1 t2 else p) (evd,true) pbs) with e when Pretype_errors.precatchable_exception e -> error "Instance does not satisfy constraints." let w_refine (evk,evi) (ltac_var,rawc) sigma = if Evd.is_defined sigma evk then error "Instantiate called on already-defined evar"; let env = Evd.evar_env evi in let sigma',typed_c = try Pretyping.Default.understand_ltac ~resolve_classes:true true sigma env ltac_var (Pretyping.OfType (Some evi.evar_concl)) rawc with e when Errors.noncritical e -> let loc = Glob_term.loc_of_glob_constr rawc in user_err_loc (loc,"",Pp.str ("Instance is not well-typed in the environment of " ^ string_of_existential evk)) in define_and_solve_constraints evk typed_c (evars_reset_evd sigma' sigma) (* vernac command Existential *) (* Main component of vernac command Existential *) let instantiate_pf_com evk com sigma = let evi = Evd.find sigma evk in let env = Evd.evar_env evi in let rawc = Constrintern.intern_constr sigma env com in let sigma' = w_refine (evk,evi) (([],[]),rawc) sigma in sigma' coq-8.4pl4/proofs/proofview.ml0000644000175000017500000004645112326224777015527 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* { initial = [] ; solution = Evd.empty ; comb = [] } | (env,typ)::l -> let { initial = ret ; solution = sol ; comb = comb } = aux l in let ( new_defs , econstr ) = Evarutil.new_evar sol env typ in let (e,_) = Term.destEvar econstr in let gl = Goal.build e in { initial = (econstr,typ)::ret; solution = new_defs ; comb = gl::comb } in fun l -> let v = aux l in (* Marks all the goal unresolvable for typeclasses. *) { v with solution = Typeclasses.mark_unresolvables v.solution } (* Returns whether this proofview is finished or not. That is, if it has empty subgoals in the comb. There could still be unsolved subgoaled, but they would then be out of the view, focused out. *) let finished = function | {comb = []} -> true | _ -> false (* Returns the current value of the proofview partial proofs. *) let return { initial=init; solution=defs } = List.map (fun (c,t) -> (Evarutil.nf_evar defs c , t)) init (* spiwack: this function should probably go in the Util section, but I'd rather have Util (or a separate module for lists) raise proper exceptions before *) (* [IndexOutOfRange] occurs in case of malformed indices with respect to list lengths. *) exception IndexOutOfRange (* no handler: should not be allowed to reach toplevel *) (* [list_goto i l] returns a pair of lists [c,t] where [c] has length [i] and is the reversed of the [i] first elements of [l], and [t] is the rest of the list. The idea is to navigate through the list, [c] is then seen as the context of the current position. Raises [IndexOutOfRange] if [i > length l]*) let list_goto = let rec aux acc index = function | l when index = 0-> (acc,l) | [] -> raise IndexOutOfRange | a::q -> aux (a::acc) (index-1) q in fun i l -> if i < 0 then raise IndexOutOfRange else aux [] i l (* Type of the object which allow to unfocus a view.*) (* First component is a reverse list of what comes before and second component is what goes after (in the expected order) *) type focus_context = Goal.goal list * Goal.goal list let focus_context f = f (* This (internal) function extracts a sublist between two indices, and returns this sublist together with its context: if it returns [(a,(b,c))] then [a] is the sublist and (rev b)@a@c is the original list. The focused list has lenght [j-i-1] and contains the goals from number [i] to number [j] (both included) the first goal of the list being numbered [1]. [focus_sublist i j l] raises [IndexOutOfRange] if [i > length l], or [j > length l] or [ j < i ]. *) let focus_sublist i j l = let (left,sub_right) = list_goto (i-1) l in let (sub, right) = try Util.list_chop (j-i+1) sub_right with Failure "list_chop" -> Util.errorlabstrm "nth_unproven" (Pp.str"No such unproven subgoal") in (sub, (left,right)) (* Inverse operation to the previous one. *) let unfocus_sublist (left,right) s = List.rev_append left (s@right) (* [focus i j] focuses a proofview on the goals from index [i] to index [j] (inclusive). (i.e. goals number [i] to [j] become the only goals of the returned proofview). The first goal has index 1. It returns the focus proof, and a context for the focus trace. *) let focus i j sp = let (new_comb, context) = focus_sublist i j sp.comb in ( { sp with comb = new_comb } , context ) (* Unfocuses a proofview with respect to a context. *) let undefined defs l = Option.List.flatten (List.map (Goal.advance defs) l) let unfocus c sp = { sp with comb = undefined sp.solution (unfocus_sublist c sp.comb) } (* The tactic monad: - Tactics are objects which apply a transformation to all the subgoals of the current view at the same time. By opposed to the old vision of applying it to a single goal. It mostly allows to consider tactic like [reorder] to reorder the goals in the current view (which might be useful for the tactic designer) (* spiwack: the ordering of goals, though, is perhaps a bit brittle. It would be much more interesting to find a more robust way to adress goals, I have no idea at this time though*) or global automation tactic for dependent subgoals (instantiating an evar has influences on the other goals of the proof in progress, not being able to take that into account causes the current eauto tactic to fail on some instances where it could succeed). - Tactics are a monad ['a tactic], in a sense a tactic can be seens as a function (without argument) which returns a value of type 'a and modifies the environement (in our case: the view). Tactics of course have arguments, but these are given at the meta-level as OCaml functions. Most tactics, in the sense we are used to, return [ () ], that is no really interesting values. But some might pass information around; the [(>>--)] and [(>>==)] bind-like construction are the main ingredients of this information passing. (* spiwack: I don't know how much all this relates to F. Kirchner and C. MuÃąoz. I wasn't able to understand how they used the monad structure in there developpement. *) The tactics seen in Coq's Ltac are (for now at least) only [unit tactic], the return values are kept for the OCaml toolkit. The operation or the monad are [Proofview.tclUNIT] (which is the "return" of the tactic monad) [Proofview.tclBIND] (which is the "bind", also noted [(>=)]) and [Proofview.tclTHEN] (which is a specialized bind on unit-returning tactics). *) (* type of tactics *) (* spiwack: double-continuation backtracking monads are reasonable folklore for "search" implementations (including Tac interactive prover's tactics). Yet it's quite hard to wrap your head around these. I recommand reading a few times the "Backtracking, Interleaving, and Terminating Monad Transformers" paper by O. Kiselyov, C. Chen, D. Fridman. The peculiar shape of the monadic type is reminiscent of that of the continuation monad transformer. A good way to get a feel of what's happening is to look at what happens when executing [apply (tclUNIT ())]. The disjunction function is unlike that of the LogicT paper, because we want and need to backtrack over state as well as values. Therefore we cannot be polymorphic over the inner monad. *) type proof_step = { goals : Goal.goal list ; defs : Evd.evar_map } type +'a result = { proof_step : proof_step ; content : 'a } (* nb=non-backtracking *) type +'a nb_tactic = proof_step -> 'a result (* double-continutation backtracking *) (* "sk" stands for "success continuation", "fk" for "failure continuation" *) type 'r fk = exn -> 'r type (-'a,'r) sk = 'a -> 'r fk -> 'r type +'a tactic0 = { go : 'r. ('a, 'r nb_tactic) sk -> 'r nb_tactic fk -> 'r nb_tactic } (* We obtain a tactic by parametrizing with an environment *) (* spiwack: alternatively the environment could be part of the "nb_tactic" state monad. As long as we do not intend to change the environment during a tactic, it's probably better here. *) type +'a tactic = Environ.env -> 'a tactic0 (* unit of [nb_tactic] *) let nb_tac_unit a step = { proof_step = step ; content = a } (* Applies a tactic to the current proofview. *) let apply env t sp = let start = { goals = sp.comb ; defs = sp.solution } in let res = (t env).go (fun a _ step -> nb_tac_unit a step) (fun e _ -> raise e) start in let next = res.proof_step in {sp with solution = next.defs ; comb = next.goals } (*** tacticals ***) (* Unit of the tactic monad *) let tclUNIT a _ = { go = fun sk fk step -> sk a fk step } (* Bind operation of the tactic monad *) let tclBIND t k env = { go = fun sk fk step -> (t env).go (fun a fk -> (k a env).go sk fk) fk step } (* Interpretes the ";" (semicolon) of Ltac. As a monadic operation, it's a specialized "bind" on unit-returning tactic (meaning "there is no value to bind") *) let tclTHEN t1 t2 env = { go = fun sk fk step -> (t1 env).go (fun () fk -> (t2 env).go sk fk) fk step } (* [tclIGNORE t] has the same operational content as [t], but drops the value at the end. *) let tclIGNORE tac env = { go = fun sk fk step -> (tac env).go (fun _ fk -> sk () fk) fk step } (* [tclOR t1 t2 = t1] if t1 succeeds and [tclOR t1 t2 = t2] if t1 fails. No interleaving for the moment. *) (* spiwack: compared to the LogicT paper, we backtrack at the same state where [t1] has been called, not the state where [t1] failed. *) let tclOR t1 t2 env = { go = fun sk fk step -> (t1 env).go sk (fun _ _ -> (t2 env).go sk fk step) step } (* [tclZERO e] always fails with error message [e]*) let tclZERO e env = { go = fun _ fk step -> fk e step } (* Focusing operation on proof_steps. *) let focus_proof_step i j ps = let (new_subgoals, context) = focus_sublist i j ps.goals in ( { ps with goals = new_subgoals } , context ) (* Unfocusing operation of proof_steps. *) let unfocus_proof_step c ps = { ps with goals = undefined ps.defs (unfocus_sublist c ps.goals) } (* Focuses a tactic at a range of subgoals, found by their indices. *) (* arnaud: bug if 0 goals ! *) let tclFOCUS i j t env = { go = fun sk fk step -> let (focused,context) = focus_proof_step i j step in (t env).go (fun a fk step -> sk a fk (unfocus_proof_step context step)) fk focused } (* Dispatch tacticals are used to apply a different tactic to each goal under consideration. They come in two flavours: [tclDISPATCH] takes a list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHS] takes a list of ['a sensitive tactic] and returns and returns and ['a sensitive tactic] where the ['a sensitive] interpreted in a goal [g] corresponds to that of the tactic which created [g]. It is to be noted that the return value of [tclDISPATCHS ts] makes only sense in the goals immediatly built by it, and would cause an anomaly is used otherwise. *) exception SizeMismatch let _ = Errors.register_handler begin function | SizeMismatch -> Util.error "Incorrect number of goals." | _ -> raise Errors.Unhandled end (* spiwack: we use an parametrised function to generate the dispatch tacticals. [tclDISPATCHGEN] takes a [null] argument to generate the return value if there are no goal under focus, and a [join] argument to explain how the return value at two given lists of subgoals are combined when both lists are being concatenated. [join] and [null] need be some sort of comutative monoid. *) let rec tclDISPATCHGEN null join tacs env = { go = fun sk fk step -> match tacs,step.goals with | [] , [] -> (tclUNIT null env).go sk fk step | t::tacs , first::goals -> (tclDISPATCHGEN null join tacs env).go begin fun x fk step -> match Goal.advance step.defs first with | None -> sk x fk step | Some first -> (t env).go begin fun y fk step' -> sk (join x y) fk { step' with goals = step'.goals@step.goals } end fk { step with goals = [first] } end fk { step with goals = goals } | _ -> raise SizeMismatch } (* takes a tactic which can raise exception and makes it pure by *failing* on with these exceptions. Does not catch anomalies. *) let purify t = let t' env = { go = fun sk fk step -> try (t env).go (fun x -> sk (Util.Inl x)) fk step with Util.Anomaly _ as e -> raise e | e when Errors.noncritical e -> sk (Util.Inr e) fk step } in tclBIND t' begin function | Util.Inl x -> tclUNIT x | Util.Inr e -> tclZERO e end let tclDISPATCHGEN null join tacs = purify (tclDISPATCHGEN null join tacs) let unitK () () = () let tclDISPATCH = tclDISPATCHGEN () unitK let extend_to_list = let rec copy n x l = if n < 0 then raise SizeMismatch else if n = 0 then l else copy (n-1) x (x::l) in fun startxs rx endxs l -> let ns = List.length startxs in let ne = List.length endxs in let n = List.length l in startxs@(copy (n-ne-ns) rx endxs) let tclEXTEND tacs1 rtac tacs2 env = { go = fun sk fk step -> let tacs = extend_to_list tacs1 rtac tacs2 step.goals in (tclDISPATCH tacs env).go sk fk step } (* [tclGOALBIND] and [tclGOALBINDU] are sorts of bind which take a [Goal.sensitive] as a first argument, the tactic then acts on each goal separately. Allows backtracking between goals. *) let list_of_sensitive s k env step = Goal.list_map begin fun defs g -> let (a,defs) = Goal.eval s env defs g in (k a) , defs end step.goals step.defs (* In form of a tactic *) let list_of_sensitive s k env = { go = fun sk fk step -> let (tacs,defs) = list_of_sensitive s k env step in sk tacs fk { step with defs = defs } } (* This is a helper function for the dispatching tactics (like [tclGOALBIND] and [tclDISPATCHS]). It takes an ['a sensitive] value, and returns a tactic whose return value is, again, ['a sensitive] but only has value in the (unmodified) goals under focus. *) let here_s b env = { go = fun sk fk step -> sk (Goal.bind (Goal.here_list step.goals b) (fun b -> b)) fk step } let rec tclGOALBIND s k = (* spiwack: the first line ensures that the value returned by the tactic [k] will not "escape its scope". *) let k a = tclBIND (k a) here_s in purify begin tclBIND (list_of_sensitive s k) begin fun tacs -> tclDISPATCHGEN Goal.null Goal.plus tacs end end (* spiwack: this should probably be moved closer to the [tclDISPATCH] tactical. *) let tclDISPATCHS tacs = let tacs = List.map begin fun tac -> tclBIND tac here_s end tacs in purify begin tclDISPATCHGEN Goal.null Goal.plus tacs end let rec tclGOALBINDU s k = purify begin tclBIND (list_of_sensitive s k) begin fun tacs -> tclDISPATCHGEN () unitK tacs end end (* spiwack: up to a few details, same errors are in the Logic module. this should be maintained synchronized, probably. *) open Pretype_errors let rec catchable_exception = function | Loc.Exc_located(_,e) -> catchable_exception e | Util.UserError _ | Type_errors.TypeError _ | PretypeError (_,_,TypingError _) | Indrec.RecursionSchemeError _ | Nametab.GlobalizationError _ | PretypeError (_,_,VarNotFound _) (* unification errors *) | PretypeError(_,_,(CannotUnify _|CannotUnifyLocal _|CannotGeneralize _ |NoOccurrenceFound _|CannotUnifyBindingType _|NotClean _ |CannotFindWellTypedAbstraction _ |UnsolvableImplicit _)) -> true | Typeclasses_errors.TypeClassError (_, Typeclasses_errors.UnsatisfiableConstraints _) -> true | _ -> false (* No backtracking can happen here, hence, as opposed to the dispatch tacticals, everything is done in one step. *) let sensitive_on_step s env step = let wrap g ((defs, partial_list) as partial_res) = match Goal.advance defs g with | None ->partial_res | Some g -> let {Goal.subgoals = sg } , d' = Goal.eval s env defs g in (d',sg::partial_list) in let ( new_defs , combed_subgoals ) = List.fold_right wrap step.goals (step.defs,[]) in { defs = new_defs; goals = List.flatten combed_subgoals } let tclSENSITIVE s = purify begin fun env -> { go = fun sk fk step -> sk () fk (sensitive_on_step s env step) } end (*** Commands ***) let in_proofview p k = k p.solution module Notations = struct let (>-) = Goal.bind let (>>-) = tclGOALBINDU let (>>--) = tclGOALBIND let (>=) = tclBIND let (>>=) t k = t >= fun s -> s >>- k let (>>==) t k = t >= fun s -> s >>-- k let (<*>) = tclTHEN let (<+>) = tclOR end (*** Compatibility layer with <= 8.2 tactics ***) module V82 = struct type tac = Goal.goal Evd.sigma -> Goal.goal list Evd.sigma let tactic tac _ = { go = fun sk fk ps -> (* spiwack: we ignore the dependencies between goals here, expectingly preserving the semantics of <= 8.2 tactics *) let tac evd gl = let glsigma = tac { Evd.it = gl ; Evd.sigma = evd } in let sigma = glsigma.Evd.sigma in let g = glsigma.Evd.it in ( g , sigma ) in (* Old style tactics expect the goals normalized with respect to evars. *) let (initgoals,initevd) = Goal.list_map Goal.V82.nf_evar ps.goals ps.defs in let (goalss,evd) = Goal.list_map tac initgoals initevd in let sgs = List.flatten goalss in sk () fk { defs = evd ; goals = sgs } } let has_unresolved_evar pv = Evd.has_undefined pv.solution (* Main function in the implementation of Grab Existential Variables.*) let grab pv = let goals = List.map begin fun (e,_) -> Goal.build e end (Evd.undefined_list pv.solution) in { pv with comb = goals } (* Returns the open goals of the proofview together with the evar_map to interprete them. *) let goals { comb = comb ; solution = solution } = { Evd.it = comb ; sigma = solution} let top_goals { initial=initial ; solution=solution } = let goals = List.map (fun (t,_) -> Goal.V82.build (fst (Term.destEvar t))) initial in { Evd.it = goals ; sigma=solution } let top_evars { initial=initial } = let evars_of_initial (c,_) = Util.Intset.elements (Evarutil.evars_of_term c) in List.flatten (List.map evars_of_initial initial) let instantiate_evar n com pv = let (evk,_) = let evl = Evarutil.non_instantiated pv.solution in if (n <= 0) then Util.error "incorrect existential variable index" else if List.length evl < n then Util.error "not so many uninstantiated existential variables" else List.nth evl (n-1) in { pv with solution = Evar_refiner.instantiate_pf_com evk com pv.solution } let purify = purify end coq-8.4pl4/proofs/tactic_debug.mli0000644000175000017500000000564612326224777016276 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Pp.std_ppcmds) -> unit val set_match_pattern_printer : (env -> constr_pattern match_pattern -> Pp.std_ppcmds) -> unit val set_match_rule_printer : ((Genarg.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> Pp.std_ppcmds) -> unit (** Debug information *) type debug_info = | DebugOn of int | DebugOff (** Prints the state and waits *) val debug_prompt : int -> goal sigma -> glob_tactic_expr -> (debug_info -> 'a) -> 'a (** Initializes debugger *) val db_initialize : unit -> unit (** Prints a constr *) val db_constr : debug_info -> env -> constr -> unit (** Prints the pattern rule *) val db_pattern_rule : debug_info -> int -> (Genarg.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit (** Prints a matched hypothesis *) val db_matched_hyp : debug_info -> env -> identifier * constr option * constr -> name -> unit (** Prints the matched conclusion *) val db_matched_concl : debug_info -> env -> constr -> unit (** Prints a success message when the goal has been matched *) val db_mc_pattern_success : debug_info -> unit (** Prints a failure message for an hypothesis pattern *) val db_hyp_pattern_failure : debug_info -> env -> name * constr_pattern match_pattern -> unit (** Prints a matching failure message for a rule *) val db_matching_failure : debug_info -> unit (** Prints an evaluation failure message for a rule *) val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit (** An exception handler *) val explain_logic_error: (exn -> Pp.std_ppcmds) ref (** For use in the Ltac debugger: some exception that are usually consider anomalies are acceptable because they are caught later in the process that is being debugged. One should not require from users that they report these anomalies. *) val explain_logic_error_no_anomaly : (exn -> Pp.std_ppcmds) ref (** Prints a logic failure message for a rule *) val db_logic_failure : debug_info -> exn -> unit (** Prints a logic failure message for a rule *) val db_breakpoint : debug_info -> identifier Util.located message_token list -> unit coq-8.4pl4/proofs/pfedit.ml0000644000175000017500000001372712326224777014762 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* = d then raise Proof.EmptyUndoStack; for i = 1 to n do Proof.undo p done let current_proof_depth () = try let p = Proof_global.give_me_the_proof () in Proof.V82.depth p with Proof_global.NoCurrentProof -> -1 (* [undo_todepth n] resets the proof to its nth step (does [undo (d-n)] where d is the depth of the focus stack). *) let undo_todepth n = try undo ((current_proof_depth ()) - n ) with Proof_global.NoCurrentProof when n=0 -> () let set_undo _ = () let get_undo _ = None let start_proof id str hyps c ?init_tac ?compute_guard hook = let goals = [ (Global.env_of_context hyps , c) ] in Proof_global.start_proof id str goals ?compute_guard hook; let tac = match init_tac with | Some tac -> Proofview.V82.tactic tac | None -> Proofview.tclUNIT () in try Proof_global.run_tactic tac with reraise -> Proof_global.discard_current (); raise reraise let restart_proof () = undo_todepth 1 let cook_proof hook = let prf = Proof_global.give_me_the_proof () in hook prf; match Proof_global.close_proof () with | (i,([e],cg,str,h)) -> (i,(e,cg,str,h)) | _ -> Util.anomaly "Pfedit.cook_proof: more than one proof term." let xml_cook_proof = ref (fun _ -> ()) let set_xml_cook_proof f = xml_cook_proof := f let get_pftreestate () = Proof_global.give_me_the_proof () let set_end_tac tac = let tac = Proofview.V82.tactic tac in Proof_global.set_endline_tactic tac let set_used_variables l = Proof_global.set_used_variables l let get_used_variables () = Proof_global.get_used_variables () exception NoSuchGoal let _ = Errors.register_handler begin function | NoSuchGoal -> Util.error "No such goal." | _ -> raise Errors.Unhandled end let get_nth_V82_goal i = let p = Proof_global.give_me_the_proof () in let { it=goals ; sigma = sigma } = Proof.V82.subgoals p in try { it=(List.nth goals (i-1)) ; sigma=sigma } with Failure _ -> raise NoSuchGoal let get_goal_context_gen i = try let { it=goal ; sigma=sigma } = get_nth_V82_goal i in (sigma, Refiner.pf_env { it=goal ; sigma=sigma }) with Proof_global.NoCurrentProof -> Util.error "No focused proof." let get_goal_context i = try get_goal_context_gen i with NoSuchGoal -> Util.error "No such goal." let get_current_goal_context () = try get_goal_context_gen 1 with NoSuchGoal -> (* spiwack: returning empty evar_map, since if there is no goal, under focus, there is no accessible evar either *) (Evd.empty, Global.env ()) let current_proof_statement () = match Proof_global.V82.get_current_initial_conclusions () with | (id,([concl],strength,hook)) -> id,strength,concl,hook | _ -> Util.anomaly "Pfedit.current_proof_statement: more than one statement" let solve_nth ?(with_end_tac=false) gi tac = try let tac = Proofview.V82.tactic tac in let tac = if with_end_tac then Proof_global.with_end_tac tac else tac in Proof_global.run_tactic (Proofview.tclFOCUS gi gi tac) with | Proof_global.NoCurrentProof -> Util.error "No focused proof" | Proofview.IndexOutOfRange | Failure "list_chop" -> let msg = str "No such goal: " ++ int gi ++ str "." in Util.errorlabstrm "" msg let by = solve_nth 1 let instantiate_nth_evar_com n com = let pf = Proof_global.give_me_the_proof () in Proof.V82.instantiate_evar n com pf (**********************************************************************) (* Shortcut to build a term using tactics *) open Decl_kinds let next = let n = ref 0 in fun () -> incr n; !n let build_constant_by_tactic id sign typ tac = start_proof id (Global,Proof Theorem) sign typ (fun _ _ -> ()); try by tac; let _,(const,_,_,_) = cook_proof (fun _ -> ()) in delete_current_proof (); const with reraise -> delete_current_proof (); raise reraise let build_by_tactic env typ tac = let id = id_of_string ("temporary_proof"^string_of_int (next())) in let sign = val_of_named_context (named_context env) in (build_constant_by_tactic id sign typ tac).const_entry_body (**********************************************************************) (* Support for resolution of evars in tactic interpretation, including resolution by application of tactics *) let implicit_tactic = ref None let declare_implicit_tactic tac = implicit_tactic := Some tac let solve_by_implicit_tactic env sigma (evk,args) = let evi = Evd.find_undefined sigma evk in match (!implicit_tactic, snd (evar_source evk sigma)) with | Some tac, (ImplicitArg _ | QuestionMark _) when Sign.named_context_equal (Environ.named_context_of_val evi.evar_hyps) (Environ.named_context env) -> (try build_by_tactic env evi.evar_concl (tclCOMPLETE tac) with e when Logic.catchable_exception e -> raise Exit) | _ -> raise Exit coq-8.4pl4/proofs/evar_refiner.mli0000644000175000017500000000161412326224777016317 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* glob_constr_ltac_closure -> evar_map -> evar_map val instantiate_pf_com : Evd.evar -> Topconstr.constr_expr -> Evd.evar_map -> Evd.evar_map (** the instantiate tactic was moved to [tactics/evar_tactics.ml] *) coq-8.4pl4/proofs/clenvtac.ml0000644000175000017500000001011312326224777015270 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* crec_hd u | Cast (c,_,_) when isMeta c -> u | _ -> map_constr crec u and crec_hd u = match kind_of_term (strip_outer_cast u) with | Meta mv -> (try let b = Typing.meta_type clenv.evd mv in assert (not (occur_meta b)); if occur_meta b then u else mkCast (mkMeta mv, DEFAULTcast, b) with Not_found -> u) | App(f,args) -> mkApp (crec_hd f, Array.map crec args) | Case(ci,p,c,br) -> mkCase (ci, crec_hd p, crec_hd c, Array.map crec br) | _ -> u in crec let clenv_value_cast_meta clenv = clenv_cast_meta clenv (clenv_value clenv) let clenv_pose_dependent_evars with_evars clenv = let dep_mvs = clenv_dependent clenv in if dep_mvs <> [] & not with_evars then raise (RefinerError (UnresolvedBindings (List.map (meta_name clenv.evd) dep_mvs))); clenv_pose_metas_as_evars clenv dep_mvs let clenv_refine with_evars ?(with_classes=true) clenv gls = let clenv = clenv_pose_dependent_evars with_evars clenv in let evd' = if with_classes then Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:(not with_evars) clenv.env clenv.evd else clenv.evd in let clenv = { clenv with evd = evd' } in tclTHEN (tclEVARS evd') (refine (clenv_cast_meta clenv (clenv_value clenv))) gls open Unification let dft = default_unify_flags let res_pf clenv ?(with_evars=false) ?(flags=dft) gls = clenv_refine with_evars (clenv_unique_resolver ~flags clenv gls) gls let elim_res_pf_THEN_i clenv tac gls = let clenv' = (clenv_unique_resolver ~flags:elim_flags clenv gls) in tclTHENLASTn (clenv_refine false clenv') (tac clenv') gls let e_res_pf clenv = res_pf clenv ~with_evars:true ~flags:dft (* [unifyTerms] et [unify] ne semble pas gÃĐrer les Meta, en particulier ne semblent pas vÃĐrifier que des instances diffÃĐrentes d'une mÊme Meta sont compatibles. D'ailleurs le "fst" jette les metas provenant de w_Unify. (UtilisÃĐ seulement dans prolog.ml) *) let fail_quick_unif_flags = { modulo_conv_on_closed_terms = Some full_transparent_state; use_metas_eagerly_in_conv_on_closed_terms = false; modulo_delta = empty_transparent_state; modulo_delta_types = full_transparent_state; modulo_delta_in_merge = None; check_applied_meta_types = false; resolve_evars = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; (* ? *) frozen_evars = ExistentialSet.empty; restrict_conv_on_strict_subterms = false; (* ? *) modulo_betaiota = false; modulo_eta = true; allow_K_in_toplevel_higher_order_unification = false } (* let unifyTerms m n = walking (fun wc -> fst (w_Unify CONV m n [] wc)) *) let unifyTerms ?(flags=fail_quick_unif_flags) m n gls = let env = pf_env gls in let evd = create_goal_evar_defs (project gls) in let evd' = w_unify env evd CONV ~flags m n in tclIDTAC {it = gls.it; sigma = evd'} let unify ?(flags=fail_quick_unif_flags) m gls = let n = pf_concl gls in unifyTerms ~flags m n gls coq-8.4pl4/proofs/refiner.ml0000644000175000017500000003375112326224777015140 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let prim_fun = prim_refiner pr in (fun goal_sigma -> let (sgl,sigma') = prim_fun goal_sigma.sigma goal_sigma.it in {it=sgl; sigma = sigma'}) | Nested (_,_) | Decl_proof _ -> failwith "Refiner: should not occur" (* Daimon is a canonical unfinished proof *) | Daimon -> fun gls -> {it=[];sigma=gls.sigma} let norm_evar_tac gl = refiner (Prim Change_evars) gl (*********************) (* Tacticals *) (*********************) let unpackage glsig = (ref (glsig.sigma)),glsig.it let repackage r v = {it=v;sigma = !r} let apply_sig_tac r tac g = check_for_interrupt (); (* Breakpoint *) let glsigma = tac (repackage r g) in r := glsigma.sigma; glsigma.it (* [goal_goal_list : goal sigma -> goal list sigma] *) let goal_goal_list gls = {it=[gls.it];sigma=gls.sigma} (* forces propagation of evar constraints *) let tclNORMEVAR = norm_evar_tac (* identity tactic without any message *) let tclIDTAC gls = goal_goal_list gls (* the message printing identity tactic *) let tclIDTAC_MESSAGE s gls = msg (hov 0 s); tclIDTAC gls (* General failure tactic *) let tclFAIL_s s gls = errorlabstrm "Refiner.tclFAIL_s" (str s) (* A special exception for levels for the Fail tactic *) exception FailError of int * std_ppcmds Lazy.t (* The Fail tactic *) let tclFAIL lvl s g = raise (FailError (lvl,lazy s)) let tclFAIL_lazy lvl s g = raise (FailError (lvl,s)) let start_tac gls = let (sigr,g) = unpackage gls in (sigr,[g]) let finish_tac (sigr,gl) = repackage sigr gl (* Apply [tacfi.(i)] on the first n subgoals, [tacli.(i)] on the last m subgoals, and [tac] on the others *) let thens3parts_tac tacfi tac tacli (sigr,gs) = let nf = Array.length tacfi in let nl = Array.length tacli in let ng = List.length gs in if ng apply_sig_tac sigr (if i=ng-nl then tacli.(nl-ng+i) else tac)) 0 gs) in (sigr,List.flatten gll) (* Apply [taci.(i)] on the first n subgoals and [tac] on the others *) let thensf_tac taci tac = thens3parts_tac taci tac [||] (* Apply [taci.(i)] on the last n subgoals and [tac] on the others *) let thensl_tac tac taci = thens3parts_tac [||] tac taci (* Apply [tac i] on the ith subgoal (no subgoals number check) *) let thensi_tac tac (sigr,gs) = let gll = list_map_i (fun i -> apply_sig_tac sigr (tac i)) 1 gs in (sigr, List.flatten gll) let then_tac tac = thensf_tac [||] tac let non_existent_goal n = errorlabstrm ("No such goal: "^(string_of_int n)) (str"Trying to apply a tactic to a non existent goal") (* Apply tac on the i-th goal (if i>0). If i<0, then start counting from the last goal (i=-1). *) let theni_tac i tac ((_,gl) as subgoals) = let nsg = List.length gl in let k = if i < 0 then nsg + i + 1 else i in if nsg < 1 then errorlabstrm "theni_tac" (str"No more subgoals.") else if k >= 1 & k <= nsg then thensf_tac (Array.init k (fun i -> if i+1 = k then tac else tclIDTAC)) tclIDTAC subgoals else non_existent_goal k (* [tclTHENS3PARTS tac1 [|t1 ; ... ; tn|] tac2 [|t'1 ; ... ; t'm|] gls] applies the tactic [tac1] to [gls] then, applies [t1], ..., [tn] to the first [n] resulting subgoals, [t'1], ..., [t'm] to the last [m] subgoals and [tac2] to the rest of the subgoals in the middle. Raises an error if the number of resulting subgoals is strictly less than [n+m] *) let tclTHENS3PARTS tac1 tacfi tac tacli gls = finish_tac (thens3parts_tac tacfi tac tacli (then_tac tac1 (start_tac gls))) (* [tclTHENSFIRSTn tac1 [|t1 ; ... ; tn|] tac2 gls] applies the tactic [tac1] to [gls] and applies [t1], ..., [tn] to the first [n] resulting subgoals, and [tac2] to the others subgoals. Raises an error if the number of resulting subgoals is strictly less than [n] *) let tclTHENSFIRSTn tac1 taci tac = tclTHENS3PARTS tac1 taci tac [||] (* [tclTHENSLASTn tac1 tac2 [|t1 ;...; tn|] gls] applies the tactic [tac1] to [gls] and applies [t1], ..., [tn] to the last [n] resulting subgoals, and [tac2] to the other subgoals. Raises an error if the number of resulting subgoals is strictly less than [n] *) let tclTHENSLASTn tac1 tac taci = tclTHENS3PARTS tac1 [||] tac taci (* [tclTHEN_i tac taci gls] applies the tactic [tac] to [gls] and applies [(taci i)] to the i_th resulting subgoal (starting from 1), whatever the number of subgoals is *) let tclTHEN_i tac taci gls = finish_tac (thensi_tac taci (then_tac tac (start_tac gls))) let tclTHENLASTn tac1 taci = tclTHENSLASTn tac1 tclIDTAC taci let tclTHENFIRSTn tac1 taci = tclTHENSFIRSTn tac1 taci tclIDTAC (* [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies [tac2] to every resulting subgoals *) let tclTHEN tac1 tac2 = tclTHENS3PARTS tac1 [||] tac2 [||] (* [tclTHENSV tac1 [t1 ; ... ; tn] gls] applies the tactic [tac1] to [gls] and applies [t1],..., [tn] to the [n] resulting subgoals. Raises an error if the number of resulting subgoals is not [n] *) let tclTHENSV tac1 tac2v = tclTHENS3PARTS tac1 tac2v (tclFAIL_s "Wrong number of tactics.") [||] let tclTHENS tac1 tac2l = tclTHENSV tac1 (Array.of_list tac2l) (* [tclTHENLAST tac1 tac2 gls] applies the tactic [tac1] to [gls] and [tac2] to the last resulting subgoal *) let tclTHENLAST tac1 tac2 = tclTHENSLASTn tac1 tclIDTAC [|tac2|] (* [tclTHENFIRST tac1 tac2 gls] applies the tactic [tac1] to [gls] and [tac2] to the first resulting subgoal *) let tclTHENFIRST tac1 tac2 = tclTHENSFIRSTn tac1 [|tac2|] tclIDTAC (* [tclTHENLIST [t1;..;tn]] applies [t1] then [t2] ... then [tn]. More convenient than [tclTHEN] when [n] is large. *) let rec tclTHENLIST = function [] -> tclIDTAC | t1::tacl -> tclTHEN t1 (tclTHENLIST tacl) (* [tclMAP f [x1..xn]] builds [(f x1);(f x2);...(f xn)] *) let tclMAP tacfun l = List.fold_right (fun x -> (tclTHEN (tacfun x))) l tclIDTAC (* PROGRESS tac ptree applies tac to the goal ptree and fails if tac leaves the goal unchanged *) let tclWEAK_PROGRESS tac ptree = let rslt = tac ptree in if Goal.V82.weak_progress rslt ptree then rslt else errorlabstrm "Refiner.WEAK_PROGRESS" (str"Failed to progress.") (* PROGRESS tac ptree applies tac to the goal ptree and fails if tac leaves the goal unchanged *) let tclPROGRESS tac ptree = let rslt = tac ptree in if Goal.V82.progress rslt ptree then rslt else errorlabstrm "Refiner.PROGRESS" (str"Failed to progress.") (* Same as tclWEAK_PROGRESS but fails also if tactics generates several goals, one of them being identical to the original goal *) let tclNOTSAMEGOAL (tac : tactic) goal = let same_goal gls1 evd2 gl2 = Goal.V82.same_goal gls1.sigma gls1.it evd2 gl2 in let rslt = tac goal in let {it=gls;sigma=sigma} = rslt in if List.exists (same_goal goal sigma) gls then errorlabstrm "Refiner.tclNOTSAMEGOAL" (str"Tactic generated a subgoal identical to the original goal.") else rslt let catch_failerror e = if catchable_exception e then check_for_interrupt () else match e with | FailError (0,_) | Loc.Exc_located(_, FailError (0,_)) | Loc.Exc_located(_, LtacLocated (_,FailError (0,_))) -> check_for_interrupt () | FailError (lvl,s) -> raise (FailError (lvl - 1, s)) | Loc.Exc_located(s,FailError (lvl,s')) -> raise (Loc.Exc_located(s,FailError (lvl - 1, s'))) | Loc.Exc_located(s,LtacLocated (s'',FailError (lvl,s'))) -> raise (Loc.Exc_located(s,LtacLocated (s'',FailError (lvl - 1,s')))) | e -> raise e (* ORELSE0 t1 t2 tries to apply t1 and if it fails, applies t2 *) let tclORELSE0 t1 t2 g = try t1 g with (* Breakpoint *) | e when Errors.noncritical e -> catch_failerror e; t2 g (* ORELSE t1 t2 tries to apply t1 and if it fails or does not progress, then applies t2 *) let tclORELSE t1 t2 = tclORELSE0 (tclPROGRESS t1) t2 (* applies t1;t2then if t1 succeeds or t2else if t1 fails t2* are called in terminal position (unless t1 produces more than 1 subgoal!) *) let tclORELSE_THEN t1 t2then t2else gls = match try Some(tclPROGRESS t1 gls) with e when Errors.noncritical e -> catch_failerror e; None with | None -> t2else gls | Some sgl -> let (sigr,gl) = unpackage sgl in finish_tac (then_tac t2then (sigr,gl)) (* TRY f tries to apply f, and if it fails, leave the goal unchanged *) let tclTRY f = (tclORELSE0 f tclIDTAC) let tclTHENTRY f g = (tclTHEN f (tclTRY g)) (* Try the first tactic that does not fail in a list of tactics *) let rec tclFIRST = function | [] -> tclFAIL_s "No applicable tactic." | t::rest -> tclORELSE0 t (tclFIRST rest) let ite_gen tcal tac_if continue tac_else gl= let success=ref false in let tac_if0 gl= let result=tac_if gl in success:=true;result in let tac_else0 e gl= if !success then raise e else tac_else gl in try tcal tac_if0 continue gl with (* Breakpoint *) | e when Errors.noncritical e -> catch_failerror e; tac_else0 e gl (* Try the first tactic and, if it succeeds, continue with the second one, and if it fails, use the third one *) let tclIFTHENELSE=ite_gen tclTHEN (* Idem with tclTHENS and tclTHENSV *) let tclIFTHENSELSE=ite_gen tclTHENS let tclIFTHENSVELSE=ite_gen tclTHENSV let tclIFTHENTRYELSEMUST tac1 tac2 gl = tclIFTHENELSE tac1 (tclTRY tac2) tac2 gl (* Fails if a tactic did not solve the goal *) let tclCOMPLETE tac = tclTHEN tac (tclFAIL_s "Proof is not complete.") (* Try the first thats solves the current goal *) let tclSOLVE tacl = tclFIRST (List.map tclCOMPLETE tacl) (* Iteration tacticals *) let tclDO n t = let rec dorec k = if k < 0 then errorlabstrm "Refiner.tclDO" (str"Wrong argument : Do needs a positive integer."); if k = 0 then tclIDTAC else if k = 1 then t else (tclTHEN t (dorec (k-1))) in dorec n (* Fails if a tactic hasn't finished after a certain amount of time *) exception TacTimeout let tclTIMEOUT n t g = let timeout_handler _ = raise TacTimeout in let psh = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in ignore (Unix.alarm n); let restore_timeout () = ignore (Unix.alarm 0); Sys.set_signal Sys.sigalrm psh in try let res = t g in restore_timeout (); res with | TacTimeout | Loc.Exc_located(_,TacTimeout) -> restore_timeout (); errorlabstrm "Refiner.tclTIMEOUT" (str"Timeout!") | reraise -> restore_timeout (); raise reraise (* Beware: call by need of CAML, g is needed *) let rec tclREPEAT t g = tclORELSE_THEN t (tclREPEAT t) tclIDTAC g let tclAT_LEAST_ONCE t = (tclTHEN t (tclREPEAT t)) (* Repeat on the first subgoal (no failure if no more subgoal) *) let rec tclREPEAT_MAIN t g = (tclORELSE (tclTHEN_i t (fun i -> if i = 1 then (tclREPEAT_MAIN t) else tclIDTAC)) tclIDTAC) g (*s Tactics handling a list of goals. *) type tactic_list = (goal list sigma) -> (goal list sigma) (* Functions working on goal list for correct backtracking in Prolog *) let tclFIRSTLIST = tclFIRST let tclIDTAC_list gls = gls (* first_goal : goal list sigma -> goal sigma *) let first_goal gls = let gl = gls.it and sig_0 = gls.sigma in if gl = [] then error "first_goal"; { it = List.hd gl; sigma = sig_0 } (* goal_goal_list : goal sigma -> goal list sigma *) let goal_goal_list gls = let gl = gls.it and sig_0 = gls.sigma in { it = [gl]; sigma = sig_0 } (* tactic -> tactic_list : Apply a tactic to the first goal in the list *) let apply_tac_list tac glls = let (sigr,lg) = unpackage glls in match lg with | (g1::rest) -> let gl = apply_sig_tac sigr tac g1 in repackage sigr (gl@rest) | _ -> error "apply_tac_list" let then_tactic_list tacl1 tacl2 glls = let glls1 = tacl1 glls in let glls2 = tacl2 glls1 in glls2 (* Transform a tactic_list into a tactic *) let tactic_list_tactic tac gls = let glres = tac (goal_goal_list gls) in glres (* Change evars *) let tclEVARS sigma gls = tclIDTAC {gls with sigma=sigma} (* Pretty-printers. *) let pp_info = ref (fun _ _ _ -> assert false) let set_info_printer f = pp_info := f (* Check that holes in arguments have been resolved *) let check_evars env sigma extsigma gl = let origsigma = gl.sigma in let rest = Evd.fold_undefined (fun evk evi acc -> if Evd.is_undefined extsigma evk & not (Evd.mem origsigma evk) then evi::acc else acc) sigma [] in if rest <> [] then let evi = List.hd rest in let (loc,k) = evi.evar_source in let evi = Evarutil.nf_evar_info sigma evi in Pretype_errors.error_unsolvable_implicit loc env sigma evi k None let tclWITHHOLES accept_unresolved_holes tac sigma c gl = if sigma == project gl then tac c gl else let res = tclTHEN (tclEVARS sigma) (tac c) gl in if not accept_unresolved_holes then check_evars (pf_env gl) (res).sigma sigma gl; res coq-8.4pl4/proofs/tacmach.ml0000644000175000017500000001543012326224777015100 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit ; reset : unit -> unit } let proof_modes = Hashtbl.create 6 let find_proof_mode n = try Hashtbl.find proof_modes n with Not_found -> Util.error (Format.sprintf "No proof mode named \"%s\"." n) let register_proof_mode ({ name = n } as m) = Hashtbl.add proof_modes n m (* initial mode: standard mode *) let standard = { name = "No" ; set = (fun ()->()) ; reset = (fun () -> ()) } let _ = register_proof_mode standard (* Default proof mode, to be set at the beginning of proofs. *) let default_proof_mode = ref standard let _ = Goptions.declare_string_option {Goptions. optsync = true ; optdepr = false; optname = "default proof mode" ; optkey = ["Default";"Proof";"Mode"] ; optread = begin fun () -> let { name = name } = !default_proof_mode in name end; optwrite = begin fun n -> default_proof_mode := find_proof_mode n end } (*** Proof Global Environment ***) (* local shorthand *) type nproof = identifier*Proof.proof (* Extra info on proofs. *) type lemma_possible_guards = int list list type proof_info = { strength : Decl_kinds.goal_kind ; compute_guard : lemma_possible_guards; hook :Tacexpr.declaration_hook ; mode : proof_mode } (* Invariant: the domain of proof_info is current_proof.*) (* The head of [!current_proof] is the actual current proof, the other ones are to be resumed when the current proof is closed or aborted. *) let current_proof = ref ([]:nproof list) let proof_info = ref (Idmap.empty : proof_info Idmap.t) (* Current proof_mode, for bookkeeping *) let current_proof_mode = ref !default_proof_mode (* combinators for proof modes *) let update_proof_mode () = match !current_proof with | (id,_)::_ -> let { mode = m } = Idmap.find id !proof_info in !current_proof_mode.reset (); current_proof_mode := m; !current_proof_mode.set () | _ -> !current_proof_mode.reset (); current_proof_mode := standard (* combinators for the current_proof lists *) let push a l = l := a::!l; update_proof_mode () exception NoSuchProof let _ = Errors.register_handler begin function | NoSuchProof -> Util.error "No such proof." | _ -> raise Errors.Unhandled end let rec extract id l = let rec aux = function | ((id',_) as np)::l when id_ord id id' = 0 -> (np,l) | np::l -> let (np', l) = aux l in (np' , np::l) | [] -> raise NoSuchProof in let (np,l') = aux !l in l := l'; update_proof_mode (); np exception NoCurrentProof let _ = Errors.register_handler begin function | NoCurrentProof -> Util.error "No focused proof (No proof-editing in progress)." | _ -> raise Errors.Unhandled end let extract_top l = match !l with | np::l' -> l := l' ; update_proof_mode (); np | [] -> raise NoCurrentProof let find_top l = match !l with | np::_ -> np | [] -> raise NoCurrentProof let rotate_top l1 l2 = let np = extract_top l1 in push np l2 let rotate_find id l1 l2 = let np = extract id l1 in push np l2 (* combinators for the proof_info map *) let add id info m = m := Idmap.add id info !m let remove id m = m := Idmap.remove id !m (*** Proof Global manipulation ***) let get_all_proof_names () = List.map fst !current_proof let give_me_the_proof () = snd (find_top current_proof) let get_current_proof_name () = fst (find_top current_proof) (* spiwack: it might be considered to move error messages away. Or else to remove special exceptions from Proof_global. Arguments for the former: there is no reason Proof_global is only accessed directly through vernacular commands. Error message should be pushed to external layers, and so we should be able to have a finer control on error message on complex actions. *) let msg_proofs () = match get_all_proof_names () with | [] -> (spc () ++ str"(No proof-editing in progress).") | l -> (str"." ++ fnl () ++ str"Proofs currently edited:" ++ spc () ++ (Util.prlist_with_sep Util.pr_spc Nameops.pr_id l)++ str ".") let there_is_a_proof () = !current_proof <> [] let there_are_pending_proofs () = there_is_a_proof () let check_no_pending_proof () = if not (there_are_pending_proofs ()) then () else begin Util.error (Pp.string_of_ppcmds (str"Proof editing in progress" ++ msg_proofs () ++ fnl() ++ str"Use \"Abort All\" first or complete proof(s).")) end let discard_gen id = ignore (extract id current_proof); remove id proof_info let discard (loc,id) = try discard_gen id with NoSuchProof -> Util.user_err_loc (loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs ()) let discard_current () = let (id,_) = extract_top current_proof in remove id proof_info let discard_all () = current_proof := []; proof_info := Idmap.empty (* [set_proof_mode] sets the proof mode to be used after it's called. It is typically called by the Proof Mode command. *) (* Core component. No undo handling. Applies to proof [id], and proof mode [m]. *) let set_proof_mode m id = let info = Idmap.find id !proof_info in let info = { info with mode = m } in proof_info := Idmap.add id info !proof_info; update_proof_mode () (* Complete function. Handles undo. Applies to current proof, and proof mode name [mn]. *) let set_proof_mode mn = let m = find_proof_mode mn in let id = get_current_proof_name () in let pr = give_me_the_proof () in Proof.add_undo begin let curr = !current_proof_mode in fun () -> set_proof_mode curr id ; update_proof_mode () end pr ; set_proof_mode m id exception AlreadyExists let _ = Errors.register_handler begin function | AlreadyExists -> Util.error "Already editing something of that name." | _ -> raise Errors.Unhandled end (* [start_proof s str env t hook tac] starts a proof of name [s] and conclusion [t]; [hook] is optionally a function to be applied at proof end (e.g. to declare the built constructions as a coercion or a setoid morphism); init_tac is possibly a tactic to systematically apply at initialization time (e.g. to start the proof of mutually dependent theorems). It raises exception [ProofInProgress] if there is a proof being currently edited. *) let start_proof id str goals ?(compute_guard=[]) hook = begin List.iter begin fun (id_ex,_) -> if Names.id_ord id id_ex = 0 then raise AlreadyExists end !current_proof end; let p = Proof.start goals in add id { strength=str ; compute_guard=compute_guard ; hook=hook ; mode = ! default_proof_mode } proof_info ; push (id,p) current_proof (* arnaud: à enlever *) let run_tactic tac = let p = give_me_the_proof () in let env = Global.env () in Proof.run_tactic env tac p (* Sets the tactic to be used when a tactic line is closed with [...] *) let set_endline_tactic tac = let p = give_me_the_proof () in Proof.set_endline_tactic tac p let set_used_variables l = let p = give_me_the_proof () in let env = Global.env () in let ids = List.fold_right Idset.add l Idset.empty in let ctx = Environ.keep_hyps env ids in Proof.set_used_variables ctx p let get_used_variables () = Proof.get_used_variables (give_me_the_proof ()) let with_end_tac tac = let p = give_me_the_proof () in Proof.with_end_tac p tac let close_proof () = (* spiwack: for now close_proof doesn't actually discard the proof, it is done by [Command.save]. *) try let id = get_current_proof_name () in let p = give_me_the_proof () in let proofs_and_types = Proof.return p in let section_vars = Proof.get_used_variables p in let entries = List.map (fun (c,t) -> { Entries.const_entry_body = c; const_entry_secctx = section_vars; const_entry_type = Some t; const_entry_opaque = true }) proofs_and_types in let { compute_guard=cg ; strength=str ; hook=hook } = Idmap.find id !proof_info in (id, (entries,cg,str,hook)) with | Proof.UnfinishedProof -> Util.error "Attempt to save an incomplete proof" | Proof.HasUnresolvedEvar -> Util.error "Attempt to save a proof with existential variables still non-instantiated" (**********************************************************) (* *) (* Utility functions *) (* *) (**********************************************************) let maximal_unfocus k p = begin try while Proof.no_focused_goal p do Proof.unfocus k p done with Proof.FullyUnfocused | Proof.CannotUnfocusThisWay -> () end (**********************************************************) (* *) (* Bullets *) (* *) (**********************************************************) module Bullet = struct open Store.Field type t = Vernacexpr.bullet type behavior = { name : string; put : Proof.proof -> t -> unit } let behaviors = Hashtbl.create 4 let register_behavior b = Hashtbl.add behaviors b.name b (*** initial modes ***) let none = { name = "None"; put = fun _ _ -> () } let _ = register_behavior none module Strict = struct (* spiwack: we need only one focus kind as we keep a stack of (distinct!) bullets *) let bullet_kind = (Proof.new_focus_kind () : t list Proof.focus_kind) let bullet_cond = Proof.done_cond ~loose_end:true bullet_kind (* spiwack: as it is bullets are reset (locally) by *any* non-bullet focusing command experience will tell if this is the right discipline of if we want to be finer and reset them only for a choice of bullets. *) let get_bullets pr = if Proof.is_last_focus bullet_kind pr then Proof.get_at_focus bullet_kind pr else [] let has_bullet bul pr = let rec has_bullet = function | b'::_ when bul=b' -> true | _::l -> has_bullet l | [] -> false in has_bullet (get_bullets pr) (* precondition: the stack is not empty *) let pop pr = match get_bullets pr with | b::_ -> Proof.unfocus bullet_kind pr; (*returns*) b | _ -> assert false let push b pr = Proof.focus bullet_cond (b::get_bullets pr) 1 pr let put p bul = if has_bullet bul p then Proof.transaction p begin fun () -> while bul <> pop p do () done; push bul p end else push bul p let strict = { name = "Strict Subproofs"; put = put } let _ = register_behavior strict end (* Current bullet behavior, controled by the option *) let current_behavior = ref Strict.strict let _ = Goptions.declare_string_option {Goptions. optsync = true; optdepr = false; optname = "bullet behavior"; optkey = ["Bullet";"Behavior"]; optread = begin fun () -> (!current_behavior).name end; optwrite = begin fun n -> current_behavior := Hashtbl.find behaviors n end } let put p b = (!current_behavior).put p b end module V82 = struct let get_current_initial_conclusions () = let p = give_me_the_proof () in let id = get_current_proof_name () in let { strength=str ; hook=hook } = Idmap.find id !proof_info in (id,(Proof.V82.get_initial_conclusions p, str, hook)) end coq-8.4pl4/proofs/proof.mli0000644000175000017500000002036512326224777015001 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Goal.goal list * (Goal.goal list * Goal.goal list) list * Evd.evar_map (*** General proof functions ***) val start : (Environ.env * Term.types) list -> proof (* Returns [true] if the considered proof is completed, that is if no goal remain to be considered (this does not require that all evars have been solved). *) val is_done : proof -> bool (* Returns the list of partial proofs to initial goals. *) val partial_proof : proof -> Term.constr list (* Returns the proofs (with their type) of the initial goals. Raises [UnfinishedProof] is some goals remain to be considered. Raises [HasUnresolvedEvar] if some evars have been left undefined. *) exception UnfinishedProof exception HasUnresolvedEvar val return : proof -> (Term.constr * Term.types) list (* Interpretes the Undo command. Raises [EmptyUndoStack] if the undo stack is empty. *) exception EmptyUndoStack val undo : proof -> unit (* Adds an undo effect to the undo stack. Use it with care, errors here might result in inconsistent states. An undo effect is meant to undo an effect on a proof (a canonical example of which is {!Proofglobal.set_proof_mode} which changes the current parser for tactics). Make sure it will work even if the effects have been only partially applied at the time of failure. *) val add_undo : (unit -> unit) -> proof -> unit (*** Focusing actions ***) (* ['a focus_kind] is the type used by focusing and unfocusing commands to synchronise. Focusing and unfocusing commands use a particular ['a focus_kind], and if they don't match, the unfocusing command will fail. When focusing with an ['a focus_kind], an information of type ['a] is stored at the focusing point. An example use is the "induction" tactic of the declarative mode where sub-tactics must be aware of the current induction argument. *) type 'a focus_kind val new_focus_kind : unit -> 'a focus_kind (* To be authorized to unfocus one must meet the condition prescribed by the action which focused. Conditions always carry a focus kind, and inherit their type parameter from it.*) type 'a focus_condition (* [no_cond] only checks that the unfocusing command uses the right [focus_kind]. If [loose_end] (default [false]) is [true], then if the [focus_kind] doesn't match, then unfocusing can occur, provided it unfocuses an earlier focus. For instance bullets can be unfocused in the following situation [{- solve_goal. }] because they use a loose-end condition. *) val no_cond : ?loose_end:bool -> 'a focus_kind -> 'a focus_condition (* [done_cond] checks that the unfocusing command uses the right [focus_kind] and that the focused proofview is complete. If [loose_end] (default [false]) is [true], then if the [focus_kind] doesn't match, then unfocusing can occur, provided it unfocuses an earlier focus. For instance bullets can be unfocused in the following situation [{ - solve_goal. }] because they use a loose-end condition. *) val done_cond : ?loose_end:bool -> 'a focus_kind -> 'a focus_condition (* focus command (focuses on the [i]th subgoal) *) (* spiwack: there could also, easily be a focus-on-a-range tactic, is there a need for it? *) val focus : 'a focus_condition -> 'a -> int -> proof -> unit exception FullyUnfocused exception CannotUnfocusThisWay (* Unfocusing command. Raises [FullyUnfocused] if the proof is not focused. Raises [CannotUnfocusThisWay] if the proof the unfocusing condition is not met. *) val unfocus : 'a focus_kind -> proof -> unit (* [unfocused p] returns [true] when [p] is fully unfocused. *) val unfocused : proof -> bool (* [get_at_focus k] gets the information stored at the closest focus point of kind [k]. Raises [NoSuchFocus] if there is no focus point of kind [k]. *) exception NoSuchFocus val get_at_focus : 'a focus_kind -> proof -> 'a (* [is_last_focus k] check if the most recent focus is of kind [k] *) val is_last_focus : 'a focus_kind -> proof -> bool (* returns [true] if there is no goal under focus. *) val no_focused_goal : proof -> bool (*** Function manipulation proof extra informations ***) val get_proof_info : proof -> Store.t (* Sets the section variables assumed by the proof *) val set_used_variables : Sign.section_context -> proof -> unit val get_used_variables : proof -> Sign.section_context option (*** Endline tactic ***) (* Sets the tactic to be used when a tactic line is closed with [...] *) val set_endline_tactic : unit Proofview.tactic -> proof -> unit val with_end_tac : proof -> unit Proofview.tactic -> unit Proofview.tactic (*** Tactics ***) val run_tactic : Environ.env -> unit Proofview.tactic -> proof -> unit (*** Transactions ***) (* A transaction chains several commands into a single one. For instance, a focusing command and a tactic. Transactions are such that if any of the atomic action fails, the whole transaction fails. During a transaction, the visible undo stack is constituted only of the actions performed done during the transaction. [transaction p f] can be called on an [f] using, itself, [transaction p].*) val transaction : proof -> (unit -> unit) -> unit (*** Commands ***) val in_proof : proof -> (Evd.evar_map -> 'a) -> 'a (*** Compatibility layer with <=v8.2 ***) module V82 : sig val subgoals : proof -> Goal.goal list Evd.sigma (* All the subgoals of the proof, including those which are not focused. *) val background_subgoals : proof -> Goal.goal list Evd.sigma val get_initial_conclusions : proof -> Term.types list val depth : proof -> int val top_goal : proof -> Goal.goal Evd.sigma (* returns the existential variable used to start the proof *) val top_evars : proof -> Evd.evar list (* Turns the unresolved evars into goals. Raises [UnfinishedProof] if there are still unsolved goals. *) val grab_evars : proof -> unit (* Implements the Existential command *) val instantiate_evar : int -> Topconstr.constr_expr -> proof -> unit end coq-8.4pl4/proofs/goal.mli0000644000175000017500000002253712326224777014601 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* goal (* Gives a unique identifier to each goal. The identifier is guaranteed to contain no space. *) val uid : goal -> string (* Returns the goal (even if it has been partially solved) corresponding to a unique identifier obtained by {!uid}. *) val get_by_uid : string -> goal (* Debugging help *) val pr_goal : goal -> Pp.std_ppcmds (* [advance sigma g] returns [Some g'] if [g'] is undefined and is the current avatar of [g] (for instance [g] was changed by [clear] into [g']). It returns [None] if [g] has been (partially) solved. *) open Store.Field val advance : Evd.evar_map -> goal -> goal option (*** Goal tactics ***) (* Goal tactics are [subgoal sensitive]-s *) type subgoals = private { subgoals: goal list } (* Goal sensitive values *) type +'a sensitive (* evaluates a goal sensitive value in a given goal (knowing the current evar_map). *) val eval : 'a sensitive -> Environ.env -> Evd.evar_map -> goal -> 'a * Evd.evar_map (* monadic bind on sensitive expressions *) val bind : 'a sensitive -> ('a -> 'b sensitive) -> 'b sensitive (* monadic return on sensitive expressions *) val return : 'a -> 'a sensitive (* interpretation of "open" constr *) (* spiwack: it is a wrapper around [Constrintern.interp_open_constr]. In an ideal world, this could/should be the other way round. As of now, though, it seems at least quite useful to build tactics. *) val interp_constr : Topconstr.constr_expr -> Term.constr sensitive (* Type of constr with holes used by refine. *) type refinable module Refinable : sig type t = refinable type handle val make : (handle -> Term.constr sensitive) -> refinable sensitive val make_with : (handle -> (Term.constr*'a) sensitive) -> (refinable*'a) sensitive val mkEvar : handle -> Environ.env -> Term.types -> Term.constr sensitive (* [with_type c typ] constrains term [c] to have type [typ]. *) val with_type : Term.constr -> Term.types -> Term.constr sensitive val resolve_typeclasses : ?filter:(Evd.hole_kind -> bool) -> ?split:bool -> ?fail:bool -> unit -> unit sensitive (* [constr_of_raw h check_type resolve_classes] is a pretyping function. The [check_type] argument asks whether the term should have the same type as the conclusion. [resolve_classes] is a flag on pretyping functions which, if set to true, calls the typeclass resolver. The principal argument is a [glob_constr] which is then pretyped in the context of a term, the remaining evars are registered to the handle. It is the main component of the toplevel refine tactic.*) val constr_of_raw : handle -> bool -> bool -> Glob_term.glob_constr -> Term.constr sensitive (* [constr_of_open_constr h check_type] transforms an open constr into a goal-sensitive constr, adding the undefined variables to the set of subgoals. If [check_type] is true, the term is coerced to the conclusion of the goal. It allows to do refinement with already-built terms with holes. *) val constr_of_open_constr : handle -> bool -> Evd.open_constr -> Term.constr sensitive end (* [refine t] takes a refinable term and use it as a partial proof for current goal. *) val refine : refinable -> subgoals sensitive (*** Cleaning goals ***) (* Implements the [clear] tactic *) val clear : Names.identifier list -> subgoals sensitive (* Implements the [clearbody] tactic *) val clear_body : Names.identifier list -> subgoals sensitive (*** Conversion in goals ***) (* Changes an hypothesis of the goal with a convertible type and body. Checks convertibility if the boolean argument is true. *) val convert_hyp : bool -> Term.named_declaration -> subgoals sensitive (* Changes the conclusion of the goal with a convertible type and body. Checks convertibility if the boolean argument is true. *) val convert_concl : bool -> Term.constr -> subgoals sensitive (*** Bureaucracy in hypotheses ***) (* Renames a hypothesis. *) val rename_hyp : Names.identifier -> Names.identifier -> subgoals sensitive (*** Sensitive primitives ***) (* [concl] is the conclusion of the current goal *) val concl : Term.constr sensitive (* [hyps] is the [named_context_val] representing the hypotheses of the current goal *) val hyps : Environ.named_context_val sensitive (* [env] is the current [Environ.env] containing both the environment in which the proof is ran, and the goal hypotheses *) val env : Environ.env sensitive (* [defs] is the [Evd.evar_map] at the current evaluation point *) val defs : Evd.evar_map sensitive (* These four functions serve as foundation for the goal sensitive part of the tactic monad (see Proofview). [here] is a special sort of [return]: [here g a] is the value [a], but does not have any value (it raises an exception) if evaluated in any other goal than [g]. [here_list] is the same, except with a list of goals rather than a single one. [plus a b] is the same as [a] if [a] is defined in the current goal, otherwise it is [b]. Effectively it's defined in the goals where [a] and [b] are defined. [null] is defined in no goal. (it is a neutral element for [plus]). *) (* spiwack: these primitives are a bit hackish, but I couldn't find another way to pass information between goals, like for an intro tactic which gives to each goal the name of the variable it introduce. In pratice, in my experience, the primitives given in Proofview (in terms of [here] and [plus]) are sufficient to define any tactics, hence these might be another example of communication primitives between Goal and Proofview. Still, I can't see a way to prevent using the Proofview primitive to read a goal sensitive value out of its valid context. *) val null : 'a sensitive val plus : 'a sensitive -> 'a sensitive -> 'a sensitive val here : goal -> 'a -> 'a sensitive val here_list : goal list -> 'a -> 'a sensitive (*** Additional functions ***) (* emulates List.map for functions of type [Evd.evar_map -> 'a -> 'b * Evd.evar_map] on lists of type 'a, by propagating new evar_map to next definition *) val list_map : (Evd.evar_map -> 'a -> 'b * Evd.evar_map) -> 'a list -> Evd.evar_map -> 'b list *Evd.evar_map (* Layer to implement v8.2 tactic engine ontop of the new architecture. Types are different from what they used to be due to a change of the internal types. *) module V82 : sig (* Old style env primitive *) val env : Evd.evar_map -> goal -> Environ.env (* For printing *) val unfiltered_env : Evd.evar_map -> goal -> Environ.env (* Old style hyps primitive *) val hyps : Evd.evar_map -> goal -> Environ.named_context_val (* Access to ".evar_concl" *) val concl : Evd.evar_map -> goal -> Term.constr (* Access to ".evar_extra" *) val extra : Evd.evar_map -> goal -> Store.t (* Old style filtered_context primitive *) val filtered_context : Evd.evar_map -> goal -> Sign.named_context (* Old style mk_goal primitive, returns a new goal with corresponding hypotheses and conclusion, together with a term which is precisely the evar corresponding to the goal, and an updated evar_map. *) val mk_goal : Evd.evar_map -> Environ.named_context_val -> Term.constr -> Store.t -> goal * Term.constr * Evd.evar_map (* Equality function on goals *) val equal : Evd.evar_map -> goal -> goal -> bool (* Creates a dummy [goal sigma] for use in auto *) val dummy_goal : goal Evd.sigma (* Makes a goal out of an evar *) (* spiwack: used by [Proofview.init], not entirely clean probably, but it is the only way I could think of to preserve compatibility with previous Coq stuff. *) val build : Evd.evar -> goal (* Instantiates a goal with an open term *) val partial_solution : Evd.evar_map -> goal -> Term.constr -> Evd.evar_map (* Principal part of the weak-progress tactical *) val weak_progress : goal list Evd.sigma -> goal Evd.sigma -> bool (* Principal part of the progress tactical *) val progress : goal list Evd.sigma -> goal Evd.sigma -> bool (* Principal part of tclNOTSAMEGOAL *) val same_goal : Evd.evar_map -> goal -> Evd.evar_map -> goal -> bool (* Used for congruence closure *) val new_goal_with : Evd.evar_map -> goal -> Sign.named_context -> goal Evd.sigma (* Used by the compatibility layer and typeclasses *) val nf_evar : Evd.evar_map -> goal -> goal * Evd.evar_map (* Goal represented as a type, doesn't take into account section variables *) val abstract_type : Evd.evar_map -> goal -> Term.types end coq-8.4pl4/proofs/clenvtac.mli0000644000175000017500000000216112326224777015445 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> tactic val clenv_refine : evars_flag -> ?with_classes:bool -> clausenv -> tactic val res_pf : clausenv -> ?with_evars:evars_flag -> ?flags:unify_flags -> tactic val elim_res_pf_THEN_i : clausenv -> (clausenv -> tactic array) -> tactic val clenv_pose_dependent_evars : evars_flag -> clausenv -> clausenv val clenv_value_cast_meta : clausenv -> constr (** Compatibility, use res_pf ?with_evars:true instead *) val e_res_pf : clausenv -> tactic coq-8.4pl4/proofs/tacexpr.ml0000644000175000017500000003125712326224777015153 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* red | FBeta :: lf -> add_flag { red with rBeta = true } lf | FIota :: lf -> add_flag { red with rIota = true } lf | FZeta :: lf -> add_flag { red with rZeta = true } lf | FConst l :: lf -> if red.rDelta then error "Cannot set both constants to unfold and constants not to unfold"; add_flag { red with rConst = list_union red.rConst l } lf | FDeltaBut l :: lf -> if red.rConst <> [] & not red.rDelta then error "Cannot set both constants to unfold and constants not to unfold"; add_flag { red with rConst = list_union red.rConst l; rDelta = true } lf in add_flag {rBeta = false; rIota = false; rZeta = false; rDelta = false; rConst = []} type 'a raw_hyp_location = 'a with_occurrences * Termops.hyp_location_flag type 'id move_location = | MoveAfter of 'id | MoveBefore of 'id | MoveToEnd of bool let no_move = MoveToEnd true open Pp let pr_move_location pr_id = function | MoveAfter id -> brk(1,1) ++ str "after " ++ pr_id id | MoveBefore id -> brk(1,1) ++ str "before " ++ pr_id id | MoveToEnd toleft -> str (if toleft then " at bottom" else " at top") type 'a induction_arg = | ElimOnConstr of 'a | ElimOnIdent of identifier located | ElimOnAnonHyp of int type inversion_kind = | SimpleInversion | FullInversion | FullInversionClear type ('c,'id) inversion_strength = | NonDepInversion of inversion_kind * 'id list * intro_pattern_expr located option | DepInversion of inversion_kind * 'c option * intro_pattern_expr located option | InversionUsing of 'c * 'id list type ('a,'b) location = HypLocation of 'a | ConclLocation of 'b type 'id message_token = | MsgString of string | MsgInt of int | MsgIdent of 'id (* onhyps: [None] means *on every hypothesis* [Some l] means on hypothesis belonging to l *) type 'id gclause = { onhyps : 'id raw_hyp_location list option; concl_occs : occurrences_expr } let nowhere = {onhyps=Some[]; concl_occs=no_occurrences_expr} type 'constr induction_clause = 'constr with_bindings induction_arg * (intro_pattern_expr located option (* eqn:... *) * intro_pattern_expr located option) (* as ... *) type ('constr,'id) induction_clause_list = 'constr induction_clause list * 'constr with_bindings option (* using ... *) * 'id gclause option (* in ... *) type multi = | Precisely of int | UpTo of int | RepeatStar | RepeatPlus (* Type of patterns *) type 'a match_pattern = | Term of 'a | Subterm of bool * identifier option * 'a (* Type of hypotheses for a Match Context rule *) type 'a match_context_hyps = | Hyp of name located * 'a match_pattern | Def of name located * 'a match_pattern * 'a match_pattern (* Type of a Match rule for Match Context and Match *) type ('a,'t) match_rule = | Pat of 'a match_context_hyps list * 'a match_pattern * 't | All of 't type ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_atomic_tactic_expr = (* Basic tactics *) | TacIntroPattern of intro_pattern_expr located list | TacIntrosUntil of quantified_hypothesis | TacIntroMove of identifier option * 'id move_location | TacAssumption | TacExact of 'constr | TacExactNoCheck of 'constr | TacVmCastNoCheck of 'constr | TacApply of advanced_flag * evars_flag * 'constr with_bindings list * ('id * intro_pattern_expr located option) option | TacElim of evars_flag * 'constr with_bindings * 'constr with_bindings option | TacElimType of 'constr | TacCase of evars_flag * 'constr with_bindings | TacCaseType of 'constr | TacFix of identifier option * int | TacMutualFix of hidden_flag * identifier * int * (identifier * int * 'constr) list | TacCofix of identifier option | TacMutualCofix of hidden_flag * identifier * (identifier * 'constr) list | TacCut of 'constr | TacAssert of 'tac option * intro_pattern_expr located option * 'constr | TacGeneralize of ('constr with_occurrences * name) list | TacGeneralizeDep of 'constr | TacLetTac of name * 'constr * 'id gclause * letin_flag * intro_pattern_expr located option (* Derived basic tactics *) | TacSimpleInductionDestruct of rec_flag * quantified_hypothesis | TacInductionDestruct of rec_flag * evars_flag * ('constr,'id) induction_clause_list | TacDoubleInduction of quantified_hypothesis * quantified_hypothesis | TacDecomposeAnd of 'constr | TacDecomposeOr of 'constr | TacDecompose of 'ind list * 'constr | TacSpecialize of int option * 'constr with_bindings | TacLApply of 'constr (* Automation tactics *) | TacTrivial of debug * 'constr list * string list option | TacAuto of debug * int or_var option * 'constr list * string list option (* Context management *) | TacClear of bool * 'id list | TacClearBody of 'id list | TacMove of bool * 'id * 'id move_location | TacRename of ('id *'id) list | TacRevert of 'id list (* Constructors *) | TacLeft of evars_flag * 'constr bindings | TacRight of evars_flag * 'constr bindings | TacSplit of evars_flag * split_flag * 'constr bindings list | TacAnyConstructor of evars_flag * 'tac option | TacConstructor of evars_flag * int or_var * 'constr bindings (* Conversion *) | TacReduce of ('constr,'cst,'pat) red_expr_gen * 'id gclause | TacChange of 'pat option * 'constr * 'id gclause (* Equivalence relations *) | TacReflexivity | TacSymmetry of 'id gclause | TacTransitivity of 'constr option (* Equality and inversion *) | TacRewrite of evars_flag * (bool * multi * 'constr with_bindings) list * 'id gclause * 'tac option | TacInversion of ('constr,'id) inversion_strength * quantified_hypothesis (* For ML extensions *) | TacExtend of loc * string * 'lev generic_argument list (* For syntax extensions *) | TacAlias of loc * string * (identifier * 'lev generic_argument) list * (dir_path * glob_tactic_expr) and ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr = | TacAtom of loc * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_atomic_tactic_expr | TacThen of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr array * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr array | TacThens of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr list | TacFirst of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr list | TacComplete of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr | TacSolve of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr list | TacTry of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr | TacOrelse of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr | TacDo of int or_var * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr | TacTimeout of int or_var * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr | TacRepeat of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr | TacProgress of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr | TacAbstract of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr * identifier option | TacId of 'id message_token list | TacFail of int or_var * 'id message_token list | TacInfo of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr | TacLetIn of rec_flag * (identifier located * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_arg) list * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr | TacMatch of lazy_flag * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr * ('pat,('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr) match_rule list | TacMatchGoal of lazy_flag * direction_flag * ('pat,('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr) match_rule list | TacFun of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_fun_ast | TacArg of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_arg located and ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_fun_ast = identifier option list * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr (* These are the possible arguments of a tactic definition *) and ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_arg = | TacDynamic of loc * Dyn.t | TacVoid | MetaIdArg of loc * bool * string | ConstrMayEval of ('constr,'cst,'pat) may_eval | IntroPattern of intro_pattern_expr located | Reference of 'ref | Integer of int | TacCall of loc * 'ref * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_arg list | TacExternal of loc * string * string * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_arg list | TacFreshId of string or_var list | Tacexp of 'tac (* Globalized tactics *) and glob_tactic_expr = (glob_constr_and_expr, glob_constr_and_expr * constr_pattern, evaluable_global_reference and_short_name or_var, inductive or_var, ltac_constant located or_var, identifier located, glob_tactic_expr, glevel) gen_tactic_expr type raw_tactic_expr = (constr_expr, constr_pattern_expr, reference or_by_notation, reference or_by_notation, reference, identifier located or_metaid, raw_tactic_expr, rlevel) gen_tactic_expr type raw_atomic_tactic_expr = (constr_expr, (* constr *) constr_pattern_expr, (* pattern *) reference or_by_notation, (* evaluable reference *) reference or_by_notation, (* inductive *) reference, (* ltac reference *) identifier located or_metaid, (* identifier *) raw_tactic_expr, rlevel) gen_atomic_tactic_expr type raw_tactic_arg = (constr_expr, constr_pattern_expr, reference or_by_notation, reference or_by_notation, reference, identifier located or_metaid, raw_tactic_expr, rlevel) gen_tactic_arg type raw_generic_argument = rlevel generic_argument type raw_red_expr = (constr_expr, reference or_by_notation, constr_expr) red_expr_gen type glob_atomic_tactic_expr = (glob_constr_and_expr, glob_constr_and_expr * constr_pattern, evaluable_global_reference and_short_name or_var, inductive or_var, ltac_constant located or_var, identifier located, glob_tactic_expr, glevel) gen_atomic_tactic_expr type glob_tactic_arg = (glob_constr_and_expr, glob_constr_and_expr * constr_pattern, evaluable_global_reference and_short_name or_var, inductive or_var, ltac_constant located or_var, identifier located, glob_tactic_expr, glevel) gen_tactic_arg type glob_generic_argument = glevel generic_argument type glob_red_expr = (glob_constr_and_expr, evaluable_global_reference or_var, constr_pattern) red_expr_gen type typed_generic_argument = tlevel generic_argument type 'a raw_abstract_argument_type = ('a,rlevel) abstract_argument_type type 'a glob_abstract_argument_type = ('a,glevel) abstract_argument_type type 'a typed_abstract_argument_type = ('a,tlevel) abstract_argument_type type declaration_hook = locality -> global_reference -> unit coq-8.4pl4/proofs/goal.ml0000644000175000017500000005203412326224777014423 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* c | _ -> Util.anomaly "Some goal is marked as 'cleared' but is uninstantiated" in let (e,_) = Term.destEvar v in let g' = { g with content = e } in advance sigma g' else match evi.Evd.evar_body with | Evd.Evar_defined _ -> None | _ -> Some g (*** Goal tactics ***) (* Goal tactics are [subgoal sensitive]-s *) type subgoals = { subgoals: goal list } (* type of the base elements of the goal API.*) (* it has an extra evar_info with respect to what would be expected, it is supposed to be the evar_info of the goal in the evar_map. The idea is that it is computed by the [run] function as an optimisation, since it will generaly not change during the evaluation. *) type 'a sensitive = Environ.env -> Evd.evar_map ref -> goal -> Evd.evar_info -> 'a (* evaluates a goal sensitive value in a given goal (knowing the current evar_map). *) (* the evar_info corresponding to the goal is computed at once as an optimisation (it shouldn't change during the evaluation). *) let eval t env defs gl = let info = content defs gl in let env = Environ.reset_with_named_context (Evd.evar_hyps info) env in let rdefs = ref defs in let r = t env rdefs gl info in ( r , !rdefs ) (* monadic bind on sensitive expressions *) let bind e f env rdefs goal info = f (e env rdefs goal info) env rdefs goal info (* monadic return on sensitive expressions *) let return v _ _ _ _ = v (* interpretation of "open" constr *) (* spiwack: it is a wrapper around [Constrintern.interp_open_constr]. In an ideal world, this could/should be the other way round. As of now, though, it seems at least quite useful to build tactics. *) let interp_constr cexpr env rdefs _ _ = let (defs,c) = Constrintern.interp_open_constr !rdefs env cexpr in rdefs := defs ; c (* Type of constr with holes used by refine. *) (* The list of evars doesn't necessarily contain all the evars in the constr, only those the constr has introduced. *) (* The variables in [myevars] are supposed to be stored in decreasing order. Breaking this invariant might cause many things to go wrong. *) type refinable = { me: constr; my_evars: Evd.evar list } module Refinable = struct type t = refinable type handle = Evd.evar list ref let make t env rdefs gl info = let r = ref [] in let me = t r env rdefs gl info in { me = me; my_evars = !r } let make_with t env rdefs gl info = let r = ref [] in let (me,side) = t r env rdefs gl info in { me = me ; my_evars = !r } , side let mkEvar handle env typ _ rdefs _ _ = let ev = Evarutil.e_new_evar rdefs env typ in let (e,_) = Term.destEvar ev in handle := e::!handle; ev (* [with_type c typ] constrains term [c] to have type [typ]. *) let with_type t typ env rdefs _ _ = (* spiwack: this function assumes that no evars can be created during this sort of coercion. If it is not the case it could produce bugs. We would need to add a handle and add the new evars to it. *) let my_type = Retyping.get_type_of env !rdefs t in let j = Environ.make_judge t my_type in let tycon = Evarutil.mk_tycon_type typ in let (new_defs,j') = Coercion.Default.inh_conv_coerce_to true (Util.dummy_loc) env !rdefs j tycon in rdefs := new_defs; j'.Environ.uj_val (* spiwack: it is not very fine grain since it solves all typeclasses holes, not only those containing the current goal, or a given term. But it seems to fit our needs so far. *) let resolve_typeclasses ?filter ?split ?(fail=false) () env rdefs _ _ = rdefs:=Typeclasses.resolve_typeclasses ?filter ?split ~fail env !rdefs; () (* a pessimistic (i.e : there won't be many positive answers) filter over evar_maps, acting only on undefined evars *) let evar_map_filter_undefined f evm = Evd.fold_undefined (fun ev evi r -> if f ev evi then Evd.add r ev evi else r) evm Evd.empty (* Union, sorted in decreasing order, of two lists of evars in decreasing order. *) let rec fusion l1 l2 = match l1 , l2 with | [] , _ -> l2 | _ , [] -> l1 | a::l1 , b::_ when a>b -> a::(fusion l1 l2) | a::l1 , b::l2 when a=b -> a::(fusion l1 l2) | _ , b::l2 -> b::(fusion l1 l2) let update_handle handle init_defs post_defs = (* [delta_evars] holds the evars that have been introduced by this refinement (but not immediatly solved) *) (* spiwack: this is the hackish part, don't know how to do any better though. *) let delta_evars = evar_map_filter_undefined (fun ev _ -> not (Evd.mem init_defs ev)) post_defs in (* [delta_evars] in the shape of a list of [evar]-s*) let delta_list = List.map fst (Evd.to_list delta_evars) in (* The variables in [myevars] are supposed to be stored in decreasing order. Breaking this invariant might cause many things to go wrong. *) handle := fusion delta_list !handle; delta_evars (* [constr_of_raw] is a pretyping function. The [check_type] argument asks whether the term should have the same type as the conclusion. [resolve_classes] is a flag on pretyping functions which, if set to true, calls the typeclass resolver. The principal argument is a [glob_constr] which is then pretyped in the context of a term, the remaining evars are registered to the handle. It is the main component of the toplevel refine tactic.*) (* spiwack: it is not entirely satisfactory to have this function here. Plus it is a bit hackish. However it does not seem possible to move it out until pretyping is defined as some proof procedure. *) let constr_of_raw handle check_type resolve_classes rawc env rdefs gl info = (* We need to keep trace of what [rdefs] was originally*) let init_defs = !rdefs in (* if [check_type] is true, then creates a type constraint for the proof-to-be *) let tycon = Pretyping.OfType (Option.init check_type (Evd.evar_concl info)) in (* call to [understand_tcc_evars] returns a constr with undefined evars these evars will be our new goals *) let open_constr = Pretyping.Default.understand_tcc_evars ~resolve_classes rdefs env tycon rawc in ignore(update_handle handle init_defs !rdefs); open_constr let constr_of_open_constr handle check_type (evars, c) env rdefs gl info = let delta = update_handle handle !rdefs evars in rdefs := Evd.fold (fun ev evi evd -> Evd.add evd ev evi) delta !rdefs; if check_type then with_type c (Evd.evar_concl (content !rdefs gl)) env rdefs gl info else c end (* [refine t] takes a refinable term and use it as a partial proof for current goal. *) let refine step env rdefs gl info = (* subgoals to return *) (* The evars in [my_evars] are stored in reverse order. It is expectingly better however to display the goal in increasing order. *) rdefs := Evarconv.consider_remaining_unif_problems env !rdefs ; let subgoals = List.map (descendent gl) (List.rev step.my_evars) in (* creates the new [evar_map] by defining the evar of the current goal as being [refine_step]. *) let new_defs = Evd.define gl.content (step.me) !rdefs in rdefs := new_defs; (* Filtering the [subgoals] for uninstanciated (=unsolved) goals. *) let subgoals = Option.List.flatten (List.map (advance !rdefs) subgoals) in { subgoals = subgoals } (*** Cleaning goals ***) let clear ids env rdefs gl info = let hyps = Evd.evar_hyps info in let concl = Evd.evar_concl info in let (hyps,concl) = Evarutil.clear_hyps_in_evi rdefs hyps concl ids in let cleared_env = Environ.reset_with_named_context hyps env in let cleared_concl = Evarutil.e_new_evar rdefs cleared_env concl in let (cleared_evar,_) = Term.destEvar cleared_concl in let cleared_goal = descendent gl cleared_evar in rdefs := Evd.define gl.content cleared_concl !rdefs; { subgoals = [cleared_goal] } let wrap_apply_to_hyp_and_dependent_on sign id f g = try Environ.apply_to_hyp_and_dependent_on sign id f g with Environ.Hyp_not_found -> Util.error "No such assumption" let check_typability env sigma c = let _ = Typing.type_of env sigma c in () let recheck_typability (what,id) env sigma t = try check_typability env sigma t with e when Errors.noncritical e -> let s = match what with | None -> "the conclusion" | Some id -> "hypothesis "^(Names.string_of_id id) in Util.error ("The correctness of "^s^" relies on the body of "^(Names.string_of_id id)) let remove_hyp_body env sigma id = let sign = wrap_apply_to_hyp_and_dependent_on (Environ.named_context_val env) id (fun (_,c,t) _ -> match c with | None -> Util.error ((Names.string_of_id id)^" is not a local definition") | Some c ->(id,None,t)) (fun (id',c,t as d) sign -> ( begin let env = Environ.reset_with_named_context sign env in match c with | None -> recheck_typability (Some id',id) env sigma t | Some b -> let b' = mkCast (b,DEFAULTcast, t) in recheck_typability (Some id',id) env sigma b' end;d)) in Environ.reset_with_named_context sign env let clear_body idents env rdefs gl info = let info = content !rdefs gl in let full_env = Environ.reset_with_named_context (Evd.evar_hyps info) env in let aux env id = let env' = remove_hyp_body env !rdefs id in recheck_typability (None,id) env' !rdefs (Evd.evar_concl info); env' in let new_env = List.fold_left aux full_env idents in let concl = Evd.evar_concl info in let (defs',new_constr) = Evarutil.new_evar !rdefs new_env concl in let (new_evar,_) = destEvar new_constr in let new_goal = descendent gl new_evar in rdefs := Evd.define gl.content new_constr defs'; { subgoals = [new_goal] } (*** Sensitive primitives ***) (* [concl] is the conclusion of the current goal *) let concl _ _ _ info = Evd.evar_concl info (* [hyps] is the [named_context_val] representing the hypotheses of the current goal *) let hyps _ _ _ info = Evd.evar_hyps info (* [env] is the current [Environ.env] containing both the environment in which the proof is ran, and the goal hypotheses *) let env env _ _ _ = env (* [defs] is the [Evd.evar_map] at the current evaluation point *) let defs _ rdefs _ _ = !rdefs (* Cf mli for more detailed comment. [null], [plus], [here] and [here_list] use internal exception [UndefinedHere] to communicate whether or not the value is defined in the particular context. *) exception UndefinedHere (* no handler: this should never be allowed to reach toplevel *) let null _ _ _ _ = raise UndefinedHere let plus s1 s2 env rdefs goal info = try s1 env rdefs goal info with UndefinedHere -> s2 env rdefs goal info (* Equality of two goals *) let equal { content = e1 } { content = e2 } = e1 = e2 let here goal value _ _ goal' _ = if equal goal goal' then value else raise UndefinedHere (* arnaud: voir à la passer dans Util ? *) let rec list_mem_with eq x = function | y::_ when eq x y -> true | _::l -> list_mem_with eq x l | [] -> false let here_list goals value _ _ goal' _ = if list_mem_with equal goal' goals then value else raise UndefinedHere (*** Conversion in goals ***) let convert_hyp check (id,b,bt as d) env rdefs gl info = let sigma = !rdefs in (* This function substitutes the new type and body definitions in the appropriate variable when used with {!Environ.apply_hyps}. *) let replace_function = (fun _ (_,c,ct) _ -> if check && not (Reductionops.is_conv env sigma bt ct) then Util.error ("Incorrect change of the type of "^(Names.string_of_id id)); if check && not (Option.Misc.compare (Reductionops.is_conv env sigma) b c) then Util.error ("Incorrect change of the body of "^(Names.string_of_id id)); d) in (* Modified named context. *) let new_hyps = Environ.apply_to_hyp (hyps env rdefs gl info) id replace_function in let new_env = Environ.reset_with_named_context new_hyps env in let new_constr = Evarutil.e_new_evar rdefs new_env (concl env rdefs gl info) in let (new_evar,_) = Term.destEvar new_constr in let new_goal = descendent gl new_evar in rdefs := Evd.define gl.content new_constr !rdefs; { subgoals = [new_goal] } let convert_concl check cl' env rdefs gl info = let sigma = !rdefs in let cl = concl env rdefs gl info in check_typability env sigma cl'; if (not check) || Reductionops.is_conv_leq env sigma cl' cl then let new_constr = Evarutil.e_new_evar rdefs env cl' in let (new_evar,_) = Term.destEvar new_constr in let new_goal = descendent gl new_evar in rdefs := Evd.define gl.content new_constr !rdefs; { subgoals = [new_goal] } else Util.error "convert-concl rule passed non-converting term" (*** Bureaucracy in hypotheses ***) (* Renames a hypothesis. *) let rename_hyp_sign id1 id2 sign = Environ.apply_to_hyp_and_dependent_on sign id1 (fun (_,b,t) _ -> (id2,b,t)) (fun d _ -> map_named_declaration (replace_vars [id1,mkVar id2]) d) let rename_hyp id1 id2 env rdefs gl info = let hyps = hyps env rdefs gl info in if id1 <> id2 && List.mem id2 (Termops.ids_of_named_context (Environ.named_context_of_val hyps)) then Util.error ((Names.string_of_id id2)^" is already used."); let new_hyps = rename_hyp_sign id1 id2 hyps in let new_env = Environ.reset_with_named_context new_hyps env in let new_concl = Term.replace_vars [id1,mkVar id2] (concl env rdefs gl info) in let new_subproof = Evarutil.e_new_evar rdefs new_env new_concl in let new_subproof = Term.replace_vars [id2,mkVar id1] new_subproof in let (new_evar,_) = Term.destEvar new_subproof in let new_goal = descendent gl new_evar in rdefs := Evd.define gl.content new_subproof !rdefs; { subgoals = [new_goal] } (*** Additional functions ***) (* emulates List.map for functions of type [Evd.evar_map -> 'a -> 'b * Evd.evar_map] on lists of type 'a, by propagating new evar_map to next definition. *) (*This sort of construction actually works with any monad (here the State monade in Haskell). There is a generic construction in Haskell called mapM. *) let rec list_map f l s = match l with | [] -> ([],s) | a::l -> let (a,s) = f s a in let (l,s) = list_map f l s in (a::l,s) (* Layer to implement v8.2 tactic engine ontop of the new architecture. Types are different from what they used to be due to a change of the internal types. *) module V82 = struct (* Old style env primitive *) let env evars gl = let evi = content evars gl in Evd.evar_env evi (* For printing *) let unfiltered_env evars gl = let evi = content evars gl in Evd.evar_unfiltered_env evi (* Old style hyps primitive *) let hyps evars gl = let evi = content evars gl in Evd.evar_filtered_hyps evi (* Access to ".evar_concl" *) let concl evars gl = let evi = content evars gl in evi.Evd.evar_concl (* Access to ".evar_extra" *) let extra evars gl = let evi = content evars gl in evi.Evd.evar_extra (* Old style filtered_context primitive *) let filtered_context evars gl = let evi = content evars gl in Evd.evar_filtered_context evi (* Old style mk_goal primitive *) let mk_goal evars hyps concl extra = let evk = Evarutil.new_untyped_evar () in let evi = { Evd.evar_hyps = hyps; Evd.evar_concl = concl; Evd.evar_filter = List.map (fun _ -> true) (Environ.named_context_of_val hyps); Evd.evar_body = Evd.Evar_empty; Evd.evar_source = (Util.dummy_loc,Evd.GoalEvar); Evd.evar_candidates = None; Evd.evar_extra = extra } in let evi = Typeclasses.mark_unresolvable evi in let evars = Evd.add evars evk evi in let ids = List.map Util.pi1 (Environ.named_context_of_val hyps) in let inst = Array.of_list (List.map mkVar ids) in let ev = Term.mkEvar (evk,inst) in (build evk, ev, evars) (* Equality function on goals *) let equal evars gl1 gl2 = let evi1 = content evars gl1 in let evi2 = content evars gl2 in Evd.eq_evar_info evi1 evi2 (* Creates a dummy [goal sigma] for use in auto *) let dummy_goal = (* This goal seems to be marshalled somewhere. Therefore it cannot be marked unresolvable for typeclasses, as non-empty Store.t-s happen to have functional content. *) let evi = Evd.make_evar Environ.empty_named_context_val Term.mkProp in let evk = Evarutil.new_untyped_evar () in let sigma = Evd.add Evd.empty evk evi in { Evd.it = build evk ; Evd.sigma = sigma } (* Makes a goal out of an evar *) let build = build (* Instantiates a goal with an open term *) let partial_solution sigma { content=evk } c = Evd.define evk c sigma (* Parts of the progress tactical *) let same_goal evars1 gl1 evars2 gl2 = let evi1 = content evars1 gl1 in let evi2 = content evars2 gl2 in Term.eq_constr evi1.Evd.evar_concl evi2.Evd.evar_concl && Environ.eq_named_context_val evi1.Evd.evar_hyps evi2.Evd.evar_hyps let weak_progress glss gls = match glss.Evd.it with | [ g ] -> not (same_goal glss.Evd.sigma g gls.Evd.sigma gls.Evd.it) | _ -> true let progress glss gls = weak_progress glss gls (* spiwack: progress normally goes like this: (Evd.progress_evar_map gls.Evd.sigma glss.Evd.sigma) || (weak_progress glss gls) This is immensly slow in the current implementation. Maybe we could reimplement progress_evar_map with restricted folds like "fold_undefined", with a good implementation of them. *) (* Used for congruence closure and change *) let new_goal_with sigma gl extra_hyps = let evi = content sigma gl in let hyps = evi.Evd.evar_hyps in let new_hyps = List.fold_right Environ.push_named_context_val extra_hyps hyps in let extra_filter = List.map (fun _ -> true) extra_hyps in let new_filter = extra_filter @ evi.Evd.evar_filter in let new_evi = { evi with Evd.evar_hyps = new_hyps; Evd.evar_filter = new_filter } in let new_evi = Typeclasses.mark_unresolvable new_evi in let evk = Evarutil.new_untyped_evar () in let new_sigma = Evd.add Evd.empty evk new_evi in { Evd.it = build evk ; sigma = new_sigma } (* Used by the compatibility layer and typeclasses *) let nf_evar sigma gl = let evi = content sigma gl in let evi = Evarutil.nf_evar_info sigma evi in let sigma = Evd.add sigma gl.content evi in (gl,sigma) (* Goal represented as a type, doesn't take into account section variables *) let abstract_type sigma gl = let (gl,sigma) = nf_evar sigma gl in let env = env sigma gl in let genv = Global.env () in let is_proof_var decl = try ignore (Environ.lookup_named (Util.pi1 decl) genv); false with Not_found -> true in Environ.fold_named_context_reverse (fun t decl -> if is_proof_var decl then mkNamedProd_or_LetIn decl t else t ) ~init:(concl sigma gl) env end coq-8.4pl4/proofs/proofview.mli0000644000175000017500000002453212326224777015674 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Goal.goal list * Evd.evar_map (* Initialises a proofview, the argument is a list of environement, conclusion types, creating that many initial goals. *) val init : (Environ.env * Term.types) list -> proofview (* Returns whether this proofview is finished or not.That is, if it has empty subgoals in the comb. There could still be unsolved subgoaled, but they would then be out of the view, focused out. *) val finished : proofview -> bool (* Returns the current value of the proofview partial proofs. *) val return : proofview -> (constr*types) list (*** Focusing operations ***) (* [IndexOutOfRange] occurs in case of malformed indices with respect to list lengths. *) exception IndexOutOfRange (* Type of the object which allow to unfocus a view.*) type focus_context (* Returns a stylised view of a focus_context for use by, for instance, ide-s. *) (* spiwack: the type of [focus_context] will change as we push more refined functions to ide-s. This would be better than spawning a new nearly identical function everytime. Hence the generic name. *) (* In this version: returns the number of goals that are held *) val focus_context : focus_context -> Goal.goal list * Goal.goal list (* [focus i j] focuses a proofview on the goals from index [i] to index [j] (inclusive). (i.e. goals number [i] to [j] become the only goals of the returned proofview). It returns the focus proof, and a context for the focus trace. *) val focus : int -> int -> proofview -> proofview * focus_context (* Unfocuses a proofview with respect to a context. *) val unfocus : focus_context -> proofview -> proofview (* The tactic monad: - Tactics are objects which apply a transformation to all the subgoals of the current view at the same time. By opposed to the old vision of applying it to a single goal. It mostly allows to consider tactic like [reorder] to reorder the goals in the current view (which might be useful for the tactic designer) (* spiwack: the ordering of goals, though, is actually rather brittle. It would be much more interesting to find a more robust way to adress goals, I have no idea at this time though*) or global automation tactic for dependent subgoals (instantiating an evar has influences on the other goals of the proof in progress, not being able to take that into account causes the current eauto tactic to fail on some instances where it could succeed). - Tactics are a monad ['a tactic], in a sense a tactic can be seens as a function (without argument) which returns a value of type 'a and modifies the environement (in our case: the view). Tactics of course have arguments, but these are given at the meta-level as OCaml functions. Most tactics in the sense we are used to return [ () ], that is no really interesting values. But some might, to pass information around; for instance [Proofview.freeze] allows to store a certain goal sensitive value "at the present time" (which means, considering the structure of the dynamics of proofs, [Proofview.freeze s] will have, for every current goal [gl], and for any of its descendent [g'] in the future the same value in [g'] that in [gl]). (* spiwack: I don't know how much all this relates to F. Kirchner and C. MuÃąoz. I wasn't able to understand how they used the monad structure in there developpement. *) The tactics seen in Coq's Ltac are (for now at least) only [unit tactic], the return values are kept for the OCaml toolkit. The operation or the monad are [Proofview.tclIDTAC] (which is the "return" of the tactic monad) [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN] (which is a specialized bind on unit-returning tactics). *) type +'a tactic (* Applies a tactic to the current proofview. *) val apply : Environ.env -> 'a tactic -> proofview -> proofview (*** tacticals ***) (* Unit of the tactic monad *) val tclUNIT : 'a -> 'a tactic (* Bind operation of the tactic monad *) val tclBIND : 'a tactic -> ('a -> 'b tactic) -> 'b tactic (* Interprets the ";" (semicolon) of Ltac. As a monadic operation, it's a specialized "bind" on unit-returning tactic (meaning "there is no value to bind") *) val tclTHEN : unit tactic -> 'a tactic -> 'a tactic (* [tclIGNORE t] has the same operational content as [t], but drops the value at the end. *) val tclIGNORE : 'a tactic -> unit tactic (* [tclOR t1 t2 = t1] if t1 succeeds and [tclOR t1 t2 = t2] if t2 fails. No interleaving at this point. *) val tclOR : 'a tactic -> 'a tactic -> 'a tactic (* [tclZERO] always fails *) val tclZERO : exn -> 'a tactic (* Focuses a tactic at a range of subgoals, found by their indices. *) val tclFOCUS : int -> int -> 'a tactic -> 'a tactic (* Dispatch tacticals are used to apply a different tactic to each goal under consideration. They come in two flavours: [tclDISPATCH] takes a list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHS] takes a list of ['a sensitive tactic] and returns and returns and ['a sensitive tactic] where the ['a sensitive] interpreted in a goal [g] corresponds to that of the tactic which created [g]. It is to be noted that the return value of [tclDISPATCHS ts] makes only sense in the goals immediatly built by it, and would cause an anomaly is used otherwise. *) val tclDISPATCH : unit tactic list -> unit tactic val tclDISPATCHS : 'a Goal.sensitive tactic list -> 'a Goal.sensitive tactic (* [tclEXTEND b r e] is a variant to [tclDISPATCH], where the [r] tactic is "repeated" enough time such that every goal has a tactic assigned to it ([b] is the list of tactics applied to the first goals, [e] to the last goals, and [r] is applied to every goal in between. *) val tclEXTEND : unit tactic list -> unit tactic -> unit tactic list -> unit tactic (* A sort of bind which takes a [Goal.sensitive] as a first argument, the tactic then acts on each goal separately. Allows backtracking between goals. *) val tclGOALBIND : 'a Goal.sensitive -> ('a -> 'b Goal.sensitive tactic) -> 'b Goal.sensitive tactic val tclGOALBINDU : 'a Goal.sensitive -> ('a -> unit tactic) -> unit tactic (* [tclSENSITIVE] views goal-type tactics as a special kind of tactics.*) val tclSENSITIVE : Goal.subgoals Goal.sensitive -> unit tactic (*** Commands ***) val in_proofview : proofview -> (Evd.evar_map -> 'a) -> 'a (* Notations for building tactics. *) module Notations : sig (* Goal.bind *) val (>-) : 'a Goal.sensitive -> ('a -> 'b Goal.sensitive) -> 'b Goal.sensitive (* tclGOALBINDU *) val (>>-) : 'a Goal.sensitive -> ('a -> unit tactic) -> unit tactic (* tclGOALBIND *) val (>>--) : 'a Goal.sensitive -> ('a -> 'b Goal.sensitive tactic) -> 'b Goal.sensitive tactic (* tclBIND *) val (>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic (* [(>>=)] (and its goal sensitive variant [(>>==)]) "binds" in one step the tactic monad and the goal-sensitive monad. It is strongly advised to use it everytieme an ['a Goal.sensitive tactic] needs a bind, since it usually avoids to delay the interpretation of the goal sensitive value to a location where it does not make sense anymore. *) val (>>=) : 'a Goal.sensitive tactic -> ('a -> unit tactic) -> unit tactic val (>>==) : 'a Goal.sensitive tactic -> ('a -> 'b Goal.sensitive tactic) -> 'b Goal.sensitive tactic (* tclTHEN *) val (<*>) : unit tactic -> 'a tactic -> 'a tactic (* tclOR *) val (<+>) : 'a tactic -> 'a tactic -> 'a tactic end (*** Compatibility layer with <= 8.2 tactics ***) module V82 : sig type tac = Goal.goal Evd.sigma -> Goal.goal list Evd.sigma val tactic : tac -> unit tactic val has_unresolved_evar : proofview -> bool (* Main function in the implementation of Grab Existential Variables. Resets the proofview's goals so that it contains all unresolved evars (in chronological order of insertion). *) val grab : proofview -> proofview (* Returns the open goals of the proofview together with the evar_map to interprete them. *) val goals : proofview -> Goal.goal list Evd.sigma val top_goals : proofview -> Goal.goal list Evd.sigma (* returns the existential variable used to start the proof *) val top_evars : proofview -> Evd.evar list (* Implements the Existential command *) val instantiate_evar : int -> Topconstr.constr_expr -> proofview -> proofview (* spiwack: [purify] might be useful while writing tactics manipulating exception explicitely or from the [V82] submodule (neither being advised, though *) val purify : 'a tactic -> 'a tactic end coq-8.4pl4/interp/0000755000175000017500000000000012365131026013117 5ustar stephstephcoq-8.4pl4/interp/interp.mllib0000644000175000017500000000025712326224777015462 0ustar stephstephTok Lexer Topconstr Ppextend Notation Dumpglob Genarg Syntax_def Smartlocate Reserve Impargs Implicit_quantifiers Constrintern Modintern Constrextern Coqlib Discharge Declare coq-8.4pl4/interp/constrextern.ml0000644000175000017500000011177712326224777016242 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* false let encode_record r = let indsp = global_inductive r in if not (is_record indsp) then user_err_loc (loc_of_reference r,"encode_record", str "This type is not a structure type."); indsp module PrintingRecordRecord = PrintingInductiveMake (struct let encode = encode_record let field = "Record" let title = "Types leading to pretty-printing using record notation: " let member_message s b = str "Terms of " ++ s ++ str (if b then " are printed using record notation" else " are not printed using record notation") end) module PrintingRecordConstructor = PrintingInductiveMake (struct let encode = encode_record let field = "Constructor" let title = "Types leading to pretty-printing using constructor form: " let member_message s b = str "Terms of " ++ s ++ str (if b then " are printed using constructor form" else " are not printed using constructor form") end) module PrintingRecord = Goptions.MakeRefTable(PrintingRecordRecord) module PrintingConstructor = Goptions.MakeRefTable(PrintingRecordConstructor) (**********************************************************************) (* Various externalisation functions *) let insert_delimiters e = function | None -> e | Some sc -> CDelimiters (dummy_loc,sc,e) let insert_pat_delimiters loc p = function | None -> p | Some sc -> CPatDelimiters (loc,sc,p) let insert_pat_alias loc p = function | Anonymous -> p | Name id -> CPatAlias (loc,p,id) (**********************************************************************) (* conversion of references *) let extern_evar loc n l = if !print_evar_arguments then CEvar (loc,n,l) else CEvar (loc,n,None) (** We allow customization of the global_reference printer. For instance, in the debugger the tables of global references may be inaccurate *) let default_extern_reference loc vars r = Qualid (loc,shortest_qualid_of_global vars r) let my_extern_reference = ref default_extern_reference let set_extern_reference f = my_extern_reference := f let get_extern_reference () = !my_extern_reference let extern_reference loc vars l = !my_extern_reference loc vars l let in_debugger = ref false (************************************************************************) (* Equality up to location (useful for translator v8) *) let rec check_same_pattern p1 p2 = match p1, p2 with | CPatAlias(_,a1,i1), CPatAlias(_,a2,i2) when i1=i2 -> check_same_pattern a1 a2 | CPatCstr(_,c1,a1), CPatCstr(_,c2,a2) when c1=c2 -> List.iter2 check_same_pattern a1 a2 | CPatCstrExpl(_,c1,a1), CPatCstrExpl(_,c2,a2) when c1=c2 -> List.iter2 check_same_pattern a1 a2 | CPatAtom(_,r1), CPatAtom(_,r2) when r1=r2 -> () | CPatPrim(_,i1), CPatPrim(_,i2) when i1=i2 -> () | CPatDelimiters(_,s1,e1), CPatDelimiters(_,s2,e2) when s1=s2 -> check_same_pattern e1 e2 | _ -> failwith "not same pattern" let check_same_ref r1 r2 = match r1,r2 with | Qualid(_,q1), Qualid(_,q2) when q1=q2 -> () | Ident(_,i1), Ident(_,i2) when i1=i2 -> () | _ -> failwith "not same ref" let rec check_same_type ty1 ty2 = match ty1, ty2 with | CRef r1, CRef r2 -> check_same_ref r1 r2 | CFix(_,(_,id1),fl1), CFix(_,(_,id2),fl2) when id1=id2 -> List.iter2 (fun (id1,i1,bl1,a1,b1) (id2,i2,bl2,a2,b2) -> if id1<>id2 || i1<>i2 then failwith "not same fix"; check_same_fix_binder bl1 bl2; check_same_type a1 a2; check_same_type b1 b2) fl1 fl2 | CCoFix(_,(_,id1),fl1), CCoFix(_,(_,id2),fl2) when id1=id2 -> List.iter2 (fun (id1,bl1,a1,b1) (id2,bl2,a2,b2) -> if id1<>id2 then failwith "not same fix"; check_same_fix_binder bl1 bl2; check_same_type a1 a2; check_same_type b1 b2) fl1 fl2 | CArrow(_,a1,b1), CArrow(_,a2,b2) -> check_same_type a1 a2; check_same_type b1 b2 | CProdN(_,bl1,a1), CProdN(_,bl2,a2) -> List.iter2 check_same_binder bl1 bl2; check_same_type a1 a2 | CLambdaN(_,bl1,a1), CLambdaN(_,bl2,a2) -> List.iter2 check_same_binder bl1 bl2; check_same_type a1 a2 | CLetIn(_,(_,na1),a1,b1), CLetIn(_,(_,na2),a2,b2) when na1=na2 -> check_same_type a1 a2; check_same_type b1 b2 | CAppExpl(_,(proj1,r1),al1), CAppExpl(_,(proj2,r2),al2) when proj1=proj2 -> check_same_ref r1 r2; List.iter2 check_same_type al1 al2 | CApp(_,(_,e1),al1), CApp(_,(_,e2),al2) -> check_same_type e1 e2; List.iter2 (fun (a1,e1) (a2,e2) -> if e1<>e2 then failwith "not same expl"; check_same_type a1 a2) al1 al2 | CCases(_,_,_,a1,brl1), CCases(_,_,_,a2,brl2) -> List.iter2 (fun (tm1,_) (tm2,_) -> check_same_type tm1 tm2) a1 a2; List.iter2 (fun (_,pl1,r1) (_,pl2,r2) -> List.iter2 (located_iter2 (List.iter2 check_same_pattern)) pl1 pl2; check_same_type r1 r2) brl1 brl2 | CHole _, CHole _ -> () | CPatVar(_,i1), CPatVar(_,i2) when i1=i2 -> () | CSort(_,s1), CSort(_,s2) when s1=s2 -> () | CCast(_,a1,CastConv (_,b1)), CCast(_,a2, CastConv(_,b2)) -> check_same_type a1 a2; check_same_type b1 b2 | CCast(_,a1,CastCoerce), CCast(_,a2, CastCoerce) -> check_same_type a1 a2 | CNotation(_,n1,(e1,el1,bl1)), CNotation(_,n2,(e2,el2,bl2)) when n1=n2 -> List.iter2 check_same_type e1 e2; List.iter2 (List.iter2 check_same_type) el1 el2; List.iter2 check_same_fix_binder bl1 bl2 | CPrim(_,i1), CPrim(_,i2) when i1=i2 -> () | CDelimiters(_,s1,e1), CDelimiters(_,s2,e2) when s1=s2 -> check_same_type e1 e2 | _ when ty1=ty2 -> () | _ -> failwith "not same type" and check_same_binder (nal1,_,e1) (nal2,_,e2) = List.iter2 (fun (_,na1) (_,na2) -> if na1<>na2 then failwith "not same name") nal1 nal2; check_same_type e1 e2 and check_same_fix_binder bl1 bl2 = List.iter2 (fun b1 b2 -> match b1,b2 with LocalRawAssum(nal1,k,ty1), LocalRawAssum(nal2,k',ty2) -> check_same_binder (nal1,k,ty1) (nal2,k',ty2) | LocalRawDef(na1,def1), LocalRawDef(na2,def2) -> check_same_binder ([na1],default_binder_kind,def1) ([na2],default_binder_kind,def2) | _ -> failwith "not same binder") bl1 bl2 let is_same_type c d = try let () = check_same_type c d in true with Failure _ | Invalid_argument _ -> false (**********************************************************************) (* mapping patterns to cases_pattern_expr *) let has_curly_brackets ntn = String.length ntn >= 6 & (String.sub ntn 0 6 = "{ _ } " or String.sub ntn (String.length ntn - 6) 6 = " { _ }" or string_string_contains ~where:ntn ~what:" { _ } ") let rec wildcards ntn n = if n = String.length ntn then [] else let l = spaces ntn (n+1) in if ntn.[n] = '_' then n::l else l and spaces ntn n = if n = String.length ntn then [] else if ntn.[n] = ' ' then wildcards ntn (n+1) else spaces ntn (n+1) let expand_curly_brackets loc mknot ntn l = let ntn' = ref ntn in let rec expand_ntn i = function | [] -> [] | a::l -> let a' = let p = List.nth (wildcards !ntn' 0) i - 2 in if p>=0 & p+5 <= String.length !ntn' & String.sub !ntn' p 5 = "{ _ }" then begin ntn' := String.sub !ntn' 0 p ^ "_" ^ String.sub !ntn' (p+5) (String.length !ntn' -p-5); mknot (loc,"{ _ }",[a]) end else a in a' :: expand_ntn (i+1) l in let l = expand_ntn 0 l in (* side effect *) mknot (loc,!ntn',l) let destPrim = function CPrim(_,t) -> Some t | _ -> None let destPatPrim = function CPatPrim(_,t) -> Some t | _ -> None let make_notation_gen loc ntn mknot mkprim destprim l = if has_curly_brackets ntn then expand_curly_brackets loc mknot ntn l else match ntn,List.map destprim l with (* Special case to avoid writing "- 3" for e.g. (Z.opp 3) *) | "- _", [Some (Numeral p)] when Bigint.is_strictly_pos p -> mknot (loc,ntn,([mknot (loc,"( _ )",l)])) | _ -> match decompose_notation_key ntn, l with | [Terminal "-"; Terminal x], [] -> (try mkprim (loc, Numeral (Bigint.neg (Bigint.of_string x))) with e when Errors.noncritical e -> mknot (loc,ntn,[])) | [Terminal x], [] -> (try mkprim (loc, Numeral (Bigint.of_string x)) with e when Errors.noncritical e -> mknot (loc,ntn,[])) | _ -> mknot (loc,ntn,l) let make_notation loc ntn (terms,termlists,binders as subst) = if termlists <> [] or binders <> [] then CNotation (loc,ntn,subst) else make_notation_gen loc ntn (fun (loc,ntn,l) -> CNotation (loc,ntn,(l,[],[]))) (fun (loc,p) -> CPrim (loc,p)) destPrim terms let make_pat_notation loc ntn (terms,termlists as subst) = if termlists <> [] then CPatNotation (loc,ntn,subst) else make_notation_gen loc ntn (fun (loc,ntn,l) -> CPatNotation (loc,ntn,(l,[]))) (fun (loc,p) -> CPatPrim (loc,p)) destPatPrim terms let mkPat loc qid l = (* Normally irrelevant test with v8 syntax, but let's do it anyway *) if l = [] then CPatAtom (loc,Some qid) else CPatCstr (loc,qid,l) (* Better to use extern_glob_constr composed with injection/retraction ?? *) let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = try if !Flags.raw_print or !print_no_symbol then raise No_match; let (na,sc,p) = uninterp_prim_token_cases_pattern pat in match availability_of_prim_token p sc scopes with | None -> raise No_match | Some key -> let loc = cases_pattern_loc pat in insert_pat_alias loc (insert_pat_delimiters loc (CPatPrim(loc,p)) key) na with No_match -> try if !Flags.raw_print or !print_no_symbol then raise No_match; extern_symbol_pattern scopes vars pat (uninterp_cases_pattern_notations pat) with No_match -> match pat with | PatVar (loc,Name id) -> CPatAtom (loc,Some (Ident (loc,id))) | PatVar (loc,Anonymous) -> CPatAtom (loc, None) | PatCstr(loc,cstrsp,args,na) -> let args = List.map (extern_cases_pattern_in_scope scopes vars) args in let p = try if !in_debugger || !Flags.raw_print then raise Exit; let projs = Recordops.lookup_projections (fst cstrsp) in let rec ip projs args acc = match projs with | [] -> acc | None :: q -> ip q args acc | Some c :: q -> match args with | [] -> raise No_match | CPatAtom(_, None) :: tail -> ip q tail acc (* we don't want to have 'x = _' in our patterns *) | head :: tail -> ip q tail ((extern_reference loc Idset.empty (ConstRef c), head) :: acc) in CPatRecord(loc, List.rev (ip projs args [])) with Not_found | No_match | Exit -> CPatCstr (loc, extern_reference loc vars (ConstructRef cstrsp), args) in insert_pat_alias loc p na and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> try match t,n with | PatCstr (loc,(ind,_),l,na), n when (n = Some 0 or n = None or n = Some(fst(Global.lookup_inductive ind)).Declarations.mind_nparams) && (match keyrule with SynDefRule _ -> true | _ -> false) -> (* Abbreviation for the constructor name only *) (match keyrule with | NotationRule _ -> assert false | SynDefRule kn -> let qid = Qualid (loc, shortest_qualid_of_syndef vars kn) in let l = List.map (extern_cases_pattern_in_scope allscopes vars) l in insert_pat_alias loc (mkPat loc qid l) na) | PatCstr (_,f,l,_), Some n when List.length l > n -> raise No_match | PatCstr (loc,_,_,na),_ -> (* Try matching ... *) let subst,substlist = match_aconstr_cases_pattern t pat in (* Try availability of interpretation ... *) let p = match keyrule with | NotationRule (sc,ntn) -> (match availability_of_notation (sc,ntn) allscopes with (* Uninterpretation is not allowed in current context *) | None -> raise No_match (* Uninterpretation is allowed in current context *) | Some (scopt,key) -> let scopes' = Option.List.cons scopt scopes in let l = List.map (fun (c,(scopt,scl)) -> extern_cases_pattern_in_scope (scopt,scl@scopes') vars c) subst in let ll = List.map (fun (c,(scopt,scl)) -> let subscope = (scopt,scl@scopes') in List.map (extern_cases_pattern_in_scope subscope vars) c) substlist in insert_pat_delimiters loc (make_pat_notation loc ntn (l,ll)) key) | SynDefRule kn -> let qid = Qualid (loc, shortest_qualid_of_syndef vars kn) in let l = List.map (fun (c,(scopt,scl)) -> extern_cases_pattern_in_scope (scopt,scl@scopes) vars c) subst in assert (substlist = []); mkPat loc qid l in insert_pat_alias loc p na | PatVar (loc,Anonymous),_ -> CPatAtom (loc, None) | PatVar (loc,Name id),_ -> CPatAtom (loc, Some (Ident (loc,id))) with No_match -> extern_symbol_pattern allscopes vars t rules let extern_cases_pattern vars p = extern_cases_pattern_in_scope (None,[]) vars p (**********************************************************************) (* Externalising applications *) let occur_name na aty = match na with | Name id -> occur_var_constr_expr id aty | Anonymous -> false let is_projection nargs = function | Some r when not !Flags.raw_print & !print_projections -> (try let n = Recordops.find_projection_nparams r + 1 in if n <= nargs then Some n else None with Not_found -> None) | _ -> None let is_hole = function CHole _ -> true | _ -> false let is_significant_implicit a = not (is_hole a) let is_needed_for_correct_partial_application tail imp = tail = [] & not (maximal_insertion_of imp) (* Implicit args indexes are in ascending order *) (* inctx is useful only if there is a last argument to be deduced from ctxt *) let explicitize loc inctx impl (cf,f) args = let impl = if !Constrintern.parsing_explicit then [] else impl in let n = List.length args in let rec exprec q = function | a::args, imp::impl when is_status_implicit imp -> let tail = exprec (q+1) (args,impl) in let visible = !Flags.raw_print or (!print_implicits & !print_implicits_explicit_args) or (is_needed_for_correct_partial_application tail imp) or (!print_implicits_defensive & is_significant_implicit a & not (is_inferable_implicit inctx n imp)) in if visible then (a,Some (dummy_loc, ExplByName (name_of_implicit imp))) :: tail else tail | a::args, _::impl -> (a,None) :: exprec (q+1) (args,impl) | args, [] -> List.map (fun a -> (a,None)) args (*In case of polymorphism*) | [], _ -> [] in match is_projection (List.length args) cf with | Some i as ip -> if impl <> [] & is_status_implicit (List.nth impl (i-1)) then let f' = match f with CRef f -> f | _ -> assert false in CAppExpl (loc,(ip,f'),args) else let (args1,args2) = list_chop i args in let (impl1,impl2) = if impl=[] then [],[] else list_chop i impl in let args1 = exprec 1 (args1,impl1) in let args2 = exprec (i+1) (args2,impl2) in CApp (loc,(Some (List.length args1),f),args1@args2) | None -> let args = exprec 1 (args,impl) in if args = [] then f else CApp (loc, (None, f), args) let extern_global loc impl f = if not !Constrintern.parsing_explicit && impl <> [] && List.for_all is_status_implicit impl then CAppExpl (loc, (None, f), []) else CRef f let extern_app loc inctx impl (cf,f) args = if args = [] (* maybe caused by a hidden coercion *) then extern_global loc impl f else if not !Constrintern.parsing_explicit && ((!Flags.raw_print or (!print_implicits & not !print_implicits_explicit_args)) & List.exists is_status_implicit impl) then CAppExpl (loc, (is_projection (List.length args) cf, f), args) else explicitize loc inctx impl (cf,CRef f) args let rec extern_args extern scopes env args subscopes = match args with | [] -> [] | a::args -> let argscopes, subscopes = match subscopes with | [] -> (None,scopes), [] | scopt::subscopes -> (scopt,scopes), subscopes in extern argscopes env a :: extern_args extern scopes env args subscopes let rec remove_coercions inctx = function | GApp (loc,GRef (_,r),args) as c when not (!Flags.raw_print or !print_coercions) -> let nargs = List.length args in (try match Classops.hide_coercion r with | Some n when n < nargs && (inctx or n+1 < nargs) -> (* We skip a coercion *) let l = list_skipn n args in let (a,l) = match l with a::l -> (a,l) | [] -> assert false in (* Recursively remove the head coercions *) let a' = remove_coercions true a in (* Don't flatten App's in case of funclass so that (atomic) notations on [a] work; should be compatible since printer does not care whether App's are collapsed or not and notations with an implicit coercion using funclass either would have already been confused with ordinary application or would have need a surrounding context and the coercion to funclass would have been made explicit to match *) if l = [] then a' else GApp (loc,a',l) | _ -> c with Not_found -> c) | c -> c let rec flatten_application = function | GApp (loc,GApp(_,a,l'),l) -> flatten_application (GApp (loc,a,l'@l)) | a -> a (**********************************************************************) (* mapping glob_constr to numerals (in presence of coercions, choose the *) (* one with no delimiter if possible) *) let extern_possible_prim_token scopes r = try let (sc,n) = uninterp_prim_token r in match availability_of_prim_token n sc scopes with | None -> None | Some key -> Some (insert_delimiters (CPrim (loc_of_glob_constr r,n)) key) with No_match -> None let extern_optimal_prim_token scopes r r' = let c = extern_possible_prim_token scopes r in let c' = if r==r' then None else extern_possible_prim_token scopes r' in match c,c' with | Some n, (Some (CDelimiters _) | None) | _, Some n -> n | _ -> raise No_match (**********************************************************************) (* mapping glob_constr to constr_expr *) let extern_glob_sort = function | GProp _ as s -> s | GType (Some _) as s when !print_universes -> s | GType _ -> GType None let rec extern inctx scopes vars r = let r' = remove_coercions inctx r in try if !Flags.raw_print or !print_no_symbol then raise No_match; extern_optimal_prim_token scopes r r' with No_match -> try let r'' = flatten_application r' in if !Flags.raw_print or !print_no_symbol then raise No_match; extern_symbol scopes vars r'' (uninterp_notations r'') with No_match -> match r' with | GRef (loc,ref) -> extern_global loc (select_stronger_impargs (implicits_of_global ref)) (extern_reference loc vars ref) | GVar (loc,id) -> CRef (Ident (loc,id)) | GEvar (loc,n,None) when !print_meta_as_hole -> CHole (loc, None) | GEvar (loc,n,l) -> extern_evar loc n (Option.map (List.map (extern false scopes vars)) l) | GPatVar (loc,n) -> if !print_meta_as_hole then CHole (loc, None) else CPatVar (loc,n) | GApp (loc,f,args) -> (match f with | GRef (rloc,ref) -> let subscopes = find_arguments_scope ref in let args = extern_args (extern true) (snd scopes) vars args subscopes in begin try if !Flags.raw_print then raise Exit; let cstrsp = match ref with ConstructRef c -> c | _ -> raise Not_found in let struc = Recordops.lookup_structure (fst cstrsp) in if PrintingRecord.active (fst cstrsp) then () else if PrintingConstructor.active (fst cstrsp) then raise Exit else if not !Flags.record_print then raise Exit; let projs = struc.Recordops.s_PROJ in let locals = struc.Recordops.s_PROJKIND in let rec cut args n = if n = 0 then args else match args with | [] -> raise No_match | _ :: t -> cut t (n - 1) in let args = cut args struc.Recordops.s_EXPECTEDPARAM in let rec ip projs locs args acc = match projs with | [] -> acc | None :: q -> raise No_match | Some c :: q -> match locs with | [] -> anomaly "projections corruption [Constrextern.extern]" | (_, false) :: locs' -> (* we don't want to print locals *) ip q locs' args acc | (_, true) :: locs' -> match args with | [] -> raise No_match (* we give up since the constructor is not complete *) | head :: tail -> ip q locs' tail ((extern_reference loc Idset.empty (ConstRef c), head) :: acc) in CRecord (loc, None, List.rev (ip projs locals args [])) with | Not_found | No_match | Exit -> extern_app loc inctx (select_stronger_impargs (implicits_of_global ref)) (Some ref,extern_reference rloc vars ref) args end | _ -> explicitize loc inctx [] (None,sub_extern false scopes vars f) (List.map (sub_extern true scopes vars) args)) | GProd (loc,Anonymous,_,t,c) -> (* Anonymous product are never factorized *) CArrow (loc,extern_typ scopes vars t, extern_typ scopes vars c) | GLetIn (loc,na,t,c) -> CLetIn (loc,(loc,na),sub_extern false scopes vars t, extern inctx scopes (add_vname vars na) c) | GProd (loc,na,bk,t,c) -> let t = extern_typ scopes vars (anonymize_if_reserved na t) in let (idl,c) = factorize_prod scopes (add_vname vars na) na bk t c in CProdN (loc,[(dummy_loc,na)::idl,Default bk,t],c) | GLambda (loc,na,bk,t,c) -> let t = extern_typ scopes vars (anonymize_if_reserved na t) in let (idl,c) = factorize_lambda inctx scopes (add_vname vars na) na bk t c in CLambdaN (loc,[(dummy_loc,na)::idl,Default bk,t],c) | GCases (loc,sty,rtntypopt,tml,eqns) -> let vars' = List.fold_right (name_fold Idset.add) (cases_predicate_names tml) vars in let rtntypopt' = Option.map (extern_typ scopes vars') rtntypopt in let tml = List.map (fun (tm,(na,x)) -> let na' = match na,tm with Anonymous, GVar (_,id) when rtntypopt<>None & occur_glob_constr id (Option.get rtntypopt) -> Some (dummy_loc,Anonymous) | Anonymous, _ -> None | Name id, GVar (_,id') when id=id' -> None | Name _, _ -> Some (dummy_loc,na) in (sub_extern false scopes vars tm, (na',Option.map (fun (loc,ind,n,nal) -> let params = list_tabulate (fun _ -> GHole (dummy_loc,Evd.InternalHole)) n in let args = List.map (function | Anonymous -> GHole (dummy_loc,Evd.InternalHole) | Name id -> GVar (dummy_loc,id)) nal in let t = GApp (dummy_loc,GRef (dummy_loc,IndRef ind),params@args) in (extern_typ scopes vars t)) x))) tml in let eqns = List.map (extern_eqn inctx scopes vars) eqns in CCases (loc,sty,rtntypopt',tml,eqns) | GLetTuple (loc,nal,(na,typopt),tm,b) -> CLetTuple (loc,List.map (fun na -> (dummy_loc,na)) nal, (Option.map (fun _ -> (dummy_loc,na)) typopt, Option.map (extern_typ scopes (add_vname vars na)) typopt), sub_extern false scopes vars tm, extern inctx scopes (List.fold_left add_vname vars nal) b) | GIf (loc,c,(na,typopt),b1,b2) -> CIf (loc,sub_extern false scopes vars c, (Option.map (fun _ -> (dummy_loc,na)) typopt, Option.map (extern_typ scopes (add_vname vars na)) typopt), sub_extern inctx scopes vars b1, sub_extern inctx scopes vars b2) | GRec (loc,fk,idv,blv,tyv,bv) -> let vars' = Array.fold_right Idset.add idv vars in (match fk with | GFix (nv,n) -> let listdecl = Array.mapi (fun i fi -> let (bl,ty,def) = blv.(i), tyv.(i), bv.(i) in let (assums,ids,bl) = extern_local_binder scopes vars bl in let vars0 = List.fold_right (name_fold Idset.add) ids vars in let vars1 = List.fold_right (name_fold Idset.add) ids vars' in let n = match fst nv.(i) with | None -> None | Some x -> Some (dummy_loc, out_name (List.nth assums x)) in let ro = extern_recursion_order scopes vars (snd nv.(i)) in ((dummy_loc, fi), (n, ro), bl, extern_typ scopes vars0 ty, extern false scopes vars1 def)) idv in CFix (loc,(loc,idv.(n)),Array.to_list listdecl) | GCoFix n -> let listdecl = Array.mapi (fun i fi -> let (_,ids,bl) = extern_local_binder scopes vars blv.(i) in let vars0 = List.fold_right (name_fold Idset.add) ids vars in let vars1 = List.fold_right (name_fold Idset.add) ids vars' in ((dummy_loc, fi),bl,extern_typ scopes vars0 tyv.(i), sub_extern false scopes vars1 bv.(i))) idv in CCoFix (loc,(loc,idv.(n)),Array.to_list listdecl)) | GSort (loc,s) -> CSort (loc,extern_glob_sort s) | GHole (loc,e) -> CHole (loc, Some e) | GCast (loc,c, CastConv (k,t)) -> CCast (loc,sub_extern true scopes vars c, CastConv (k,extern_typ scopes vars t)) | GCast (loc,c, CastCoerce) -> CCast (loc,sub_extern true scopes vars c, CastCoerce) and extern_typ (_,scopes) = extern true (Some Notation.type_scope,scopes) and sub_extern inctx (_,scopes) = extern inctx (None,scopes) and factorize_prod scopes vars na bk aty c = let c = extern_typ scopes vars c in match na, c with | Name id, CProdN (loc,[nal,Default bk',ty],c) when bk = bk' && is_same_type aty ty & not (occur_var_constr_expr id ty) (* avoid na in ty escapes scope *) -> nal,c | _ -> [],c and factorize_lambda inctx scopes vars na bk aty c = let c = sub_extern inctx scopes vars c in match c with | CLambdaN (loc,[nal,Default bk',ty],c) when bk = bk' && is_same_type aty ty & not (occur_name na ty) (* avoid na in ty escapes scope *) -> nal,c | _ -> [],c and extern_local_binder scopes vars = function [] -> ([],[],[]) | (na,bk,Some bd,ty)::l -> let (assums,ids,l) = extern_local_binder scopes (name_fold Idset.add na vars) l in (assums,na::ids, LocalRawDef((dummy_loc,na), extern false scopes vars bd) :: l) | (na,bk,None,ty)::l -> let ty = extern_typ scopes vars (anonymize_if_reserved na ty) in (match extern_local_binder scopes (name_fold Idset.add na vars) l with (assums,ids,LocalRawAssum(nal,k,ty')::l) when is_same_type ty ty' & match na with Name id -> not (occur_var_constr_expr id ty') | _ -> true -> (na::assums,na::ids, LocalRawAssum((dummy_loc,na)::nal,k,ty')::l) | (assums,ids,l) -> (na::assums,na::ids, LocalRawAssum([(dummy_loc,na)],Default bk,ty) :: l)) and extern_eqn inctx scopes vars (loc,ids,pl,c) = (loc,[loc,List.map (extern_cases_pattern_in_scope scopes vars) pl], extern inctx scopes vars c) and extern_symbol (tmp_scope,scopes as allscopes) vars t = function | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> let loc = Glob_term.loc_of_glob_constr t in try (* Adjusts to the number of arguments expected by the notation *) let (t,args,argsscopes,argsimpls) = match t,n with | GApp (_,f,args), Some n when List.length args >= n -> let args1, args2 = list_chop n args in let subscopes, impls = match f with | GRef (_,ref) -> let subscopes = try list_skipn n (find_arguments_scope ref) with e when Errors.noncritical e -> [] in let impls = let impls = select_impargs_size (List.length args) (implicits_of_global ref) in try list_skipn n impls with e when Errors.noncritical e -> [] in subscopes,impls | _ -> [], [] in (if n = 0 then f else GApp (dummy_loc,f,args1)), args2, subscopes, impls | GApp (_,(GRef (_,ref) as f),args), None -> let subscopes = find_arguments_scope ref in let impls = select_impargs_size (List.length args) (implicits_of_global ref) in f, args, subscopes, impls | GRef _, Some 0 -> GApp (dummy_loc,t,[]), [], [], [] | _, None -> t, [], [], [] | _ -> raise No_match in (* Try matching ... *) let terms,termlists,binders = match_aconstr !print_universes t pat in (* Try availability of interpretation ... *) let e = match keyrule with | NotationRule (sc,ntn) -> (match availability_of_notation (sc,ntn) allscopes with (* Uninterpretation is not allowed in current context *) | None -> raise No_match (* Uninterpretation is allowed in current context *) | Some (scopt,key) -> let scopes' = Option.List.cons scopt scopes in let l = List.map (fun (c,(scopt,scl)) -> extern (* assuming no overloading: *) true (scopt,scl@scopes') vars c) terms in let ll = List.map (fun (c,(scopt,scl)) -> List.map (extern true (scopt,scl@scopes') vars) c) termlists in let bll = List.map (fun (bl,(scopt,scl)) -> pi3 (extern_local_binder (scopt,scl@scopes') vars bl)) binders in insert_delimiters (make_notation loc ntn (l,ll,bll)) key) | SynDefRule kn -> let l = List.map (fun (c,(scopt,scl)) -> extern true (scopt,scl@scopes) vars c, None) terms in let a = CRef (Qualid (loc, shortest_qualid_of_syndef vars kn)) in if l = [] then a else CApp (loc,(None,a),l) in if args = [] then e else let args = extern_args (extern true) scopes vars args argsscopes in explicitize loc false argsimpls (None,e) args with No_match -> extern_symbol allscopes vars t rules and extern_recursion_order scopes vars = function GStructRec -> CStructRec | GWfRec c -> CWfRec (extern true scopes vars c) | GMeasureRec (m,r) -> CMeasureRec (extern true scopes vars m, Option.map (extern true scopes vars) r) let extern_glob_constr vars c = extern false (None,[]) vars c let extern_glob_type vars c = extern_typ (None,[]) vars c (******************************************************************) (* Main translation function from constr -> constr_expr *) let loc = dummy_loc (* for constr and pattern, locations are lost *) let extern_constr_gen goal_concl_style scopt env t = (* "goal_concl_style" means do alpha-conversion using the "goal" convention *) (* i.e.: avoid using the names of goal/section/rel variables and the short *) (* names of global definitions of current module when computing names for *) (* bound variables. *) (* Not "goal_concl_style" means do alpha-conversion avoiding only *) (* those goal/section/rel variables that occurs in the subterm under *) (* consideration; see namegen.ml for further details *) let avoid = if goal_concl_style then ids_of_context env else [] in let rel_env_names = names_of_rel_context env in let r = Detyping.detype goal_concl_style avoid rel_env_names t in let vars = vars_of_env env in extern false (scopt,[]) vars r let extern_constr_in_scope goal_concl_style scope env t = extern_constr_gen goal_concl_style (Some scope) env t let extern_constr goal_concl_style env t = extern_constr_gen goal_concl_style None env t let extern_type goal_concl_style env t = let avoid = if goal_concl_style then ids_of_context env else [] in let rel_env_names = names_of_rel_context env in let r = Detyping.detype goal_concl_style avoid rel_env_names t in extern_glob_type (vars_of_env env) r let extern_sort s = extern_glob_sort (detype_sort s) (******************************************************************) (* Main translation function from pattern -> constr_expr *) let any_any_branch = (* | _ => _ *) (loc,[],[PatVar (loc,Anonymous)],GHole (loc,Evd.InternalHole)) let rec glob_of_pat env = function | PRef ref -> GRef (loc,ref) | PVar id -> GVar (loc,id) | PEvar (n,l) -> GEvar (loc,n,Some (array_map_to_list (glob_of_pat env) l)) | PRel n -> let id = try match lookup_name_of_rel n env with | Name id -> id | Anonymous -> anomaly "glob_constr_of_pattern: index to an anonymous variable" with Not_found -> id_of_string ("_UNBOUND_REL_"^(string_of_int n)) in GVar (loc,id) | PMeta None -> GHole (loc,Evd.InternalHole) | PMeta (Some n) -> GPatVar (loc,(false,n)) | PApp (f,args) -> GApp (loc,glob_of_pat env f,array_map_to_list (glob_of_pat env) args) | PSoApp (n,args) -> GApp (loc,GPatVar (loc,(true,n)), List.map (glob_of_pat env) args) | PProd (na,t,c) -> GProd (loc,na,Explicit,glob_of_pat env t,glob_of_pat (na::env) c) | PLetIn (na,t,c) -> GLetIn (loc,na,glob_of_pat env t, glob_of_pat (na::env) c) | PLambda (na,t,c) -> GLambda (loc,na,Explicit,glob_of_pat env t, glob_of_pat (na::env) c) | PIf (c,b1,b2) -> GIf (loc, glob_of_pat env c, (Anonymous,None), glob_of_pat env b1, glob_of_pat env b2) | PCase ({cip_style=LetStyle; cip_ind_args=None},PMeta None,tm,[(0,n,b)]) -> let nal,b = it_destRLambda_or_LetIn_names n (glob_of_pat env b) in GLetTuple (loc,nal,(Anonymous,None),glob_of_pat env tm,b) | PCase (info,p,tm,bl) -> let mat = match bl, info.cip_ind with | [], _ -> [] | _, Some ind -> let bl' = List.map (fun (i,n,c) -> (i,n,glob_of_pat env c)) bl in simple_cases_matrix_of_branches ind bl' | _, None -> anomaly "PCase with some branches but unknown inductive" in let mat = if info.cip_extensible then mat @ [any_any_branch] else mat in let indnames,rtn = match p, info.cip_ind, info.cip_ind_args with | PMeta None, _, _ -> (Anonymous,None),None | _, Some ind, Some (nparams,nargs) -> return_type_of_predicate ind nparams nargs (glob_of_pat env p) | _ -> anomaly "PCase with non-trivial predicate but unknown inductive" in GCases (loc,RegularStyle,rtn,[glob_of_pat env tm,indnames],mat) | PFix f -> Detyping.detype false [] env (mkFix f) | PCoFix c -> Detyping.detype false [] env (mkCoFix c) | PSort s -> GSort (loc,s) let extern_constr_pattern env pat = extern true (None,[]) Idset.empty (glob_of_pat env pat) let extern_rel_context where env sign = let a = detype_rel_context where [] (names_of_rel_context env) sign in let vars = vars_of_env env in pi3 (extern_local_binder (None,[]) vars a) coq-8.4pl4/interp/coqlib.ml0000644000175000017500000003227412326224777014747 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* anomaly (locstr^": cannot find "^(string_of_path sp)) let coq_reference locstr dir s = find_reference locstr ("Coq"::dir) s let coq_constant locstr dir s = constr_of_global (coq_reference locstr dir s) let gen_reference = coq_reference let gen_constant = coq_constant let has_suffix_in_dirs dirs ref = let dir = dirpath (path_of_global ref) in List.exists (fun d -> is_dirpath_prefix_of d dir) dirs let global_of_extended q = try Some (global_of_extended_global q) with Not_found -> None let gen_constant_in_modules locstr dirs s = let dirs = List.map make_dir dirs in let qualid = qualid_of_string s in let all = Nametab.locate_extended_all qualid in let all = list_uniquize (list_map_filter global_of_extended all) in let these = List.filter (has_suffix_in_dirs dirs) all in match these with | [x] -> constr_of_global x | [] -> anomalylabstrm "" (str (locstr^": cannot find "^s^ " in module"^(if List.length dirs > 1 then "s " else " ")) ++ prlist_with_sep pr_comma pr_dirpath dirs) | l -> anomalylabstrm "" (str (locstr^": found more than once object of name "^s^ " in module"^(if List.length dirs > 1 then "s " else " ")) ++ prlist_with_sep pr_comma pr_dirpath dirs) (* For tactics/commands requiring vernacular libraries *) let check_required_library d = let d' = List.map id_of_string d in let dir = make_dirpath (List.rev d') in let mp = (fst(Lib.current_prefix())) in let current_dir = match mp with | MPfile dp -> (dir=dp) | _ -> false in if not (Library.library_is_loaded dir) then if not current_dir then (* Loading silently ... let m, prefix = list_sep_last d' in read_library (dummy_loc,make_qualid (make_dirpath (List.rev prefix)) m) *) (* or failing ...*) error ("Library "^(string_of_dirpath dir)^" has to be required first.") (************************************************************************) (* Specific Coq objects *) let init_reference dir s = gen_reference "Coqlib" ("Init"::dir) s let init_constant dir s = gen_constant "Coqlib" ("Init"::dir) s let logic_constant dir s = gen_constant "Coqlib" ("Logic"::dir) s let arith_dir = ["Coq";"Arith"] let arith_modules = [arith_dir] let numbers_dir = [ "Coq";"Numbers"] let parith_dir = ["Coq";"PArith"] let narith_dir = ["Coq";"NArith"] let zarith_dir = ["Coq";"ZArith"] let zarith_base_modules = [numbers_dir;parith_dir;narith_dir;zarith_dir] let init_dir = ["Coq";"Init"] let init_modules = [ init_dir@["Datatypes"]; init_dir@["Logic"]; init_dir@["Specif"]; init_dir@["Logic_Type"]; init_dir@["Peano"]; init_dir@["Wf"] ] let logic_module_name = ["Coq";"Init";"Logic"] let logic_module = make_dir logic_module_name let logic_type_module_name = ["Coq";"Init";"Logic_Type"] let logic_type_module = make_dir logic_type_module_name let datatypes_module_name = ["Coq";"Init";"Datatypes"] let datatypes_module = make_dir datatypes_module_name let arith_module_name = ["Coq";"Arith";"Arith"] let arith_module = make_dir arith_module_name let jmeq_module_name = ["Coq";"Logic";"JMeq"] let jmeq_module = make_dir jmeq_module_name (* TODO: temporary hack *) let make_kn dir id = Libnames.encode_mind dir id let make_con dir id = Libnames.encode_con dir id (** Identity *) let id = make_con datatypes_module (id_of_string "id") let type_of_id = make_con datatypes_module (id_of_string "ID") let _ = Termops.set_impossible_default_clause (mkConst id,mkConst type_of_id) (** Natural numbers *) let nat_kn = make_kn datatypes_module (id_of_string "nat") let nat_path = Libnames.make_path datatypes_module (id_of_string "nat") let glob_nat = IndRef (nat_kn,0) let path_of_O = ((nat_kn,0),1) let path_of_S = ((nat_kn,0),2) let glob_O = ConstructRef path_of_O let glob_S = ConstructRef path_of_S (** Booleans *) let bool_kn = make_kn datatypes_module (id_of_string "bool") let glob_bool = IndRef (bool_kn,0) let path_of_true = ((bool_kn,0),1) let path_of_false = ((bool_kn,0),2) let glob_true = ConstructRef path_of_true let glob_false = ConstructRef path_of_false (** Equality *) let eq_kn = make_kn logic_module (id_of_string "eq") let glob_eq = IndRef (eq_kn,0) let identity_kn = make_kn datatypes_module (id_of_string "identity") let glob_identity = IndRef (identity_kn,0) let jmeq_kn = make_kn jmeq_module (id_of_string "JMeq") let glob_jmeq = IndRef (jmeq_kn,0) type coq_sigma_data = { proj1 : constr; proj2 : constr; elim : constr; intro : constr; typ : constr } type coq_bool_data = { andb : constr; andb_prop : constr; andb_true_intro : constr} let build_bool_type () = { andb = init_constant ["Datatypes"] "andb"; andb_prop = init_constant ["Datatypes"] "andb_prop"; andb_true_intro = init_constant ["Datatypes"] "andb_true_intro" } let build_sigma_set () = anomaly "Use build_sigma_type" let build_sigma_type () = { proj1 = init_constant ["Specif"] "projT1"; proj2 = init_constant ["Specif"] "projT2"; elim = init_constant ["Specif"] "sigT_rect"; intro = init_constant ["Specif"] "existT"; typ = init_constant ["Specif"] "sigT" } let build_sigma () = { proj1 = init_constant ["Specif"] "proj1_sig"; proj2 = init_constant ["Specif"] "proj2_sig"; elim = init_constant ["Specif"] "sig_rect"; intro = init_constant ["Specif"] "exist"; typ = init_constant ["Specif"] "sig" } let build_prod () = { proj1 = init_constant ["Datatypes"] "fst"; proj2 = init_constant ["Datatypes"] "snd"; elim = init_constant ["Datatypes"] "prod_rec"; intro = init_constant ["Datatypes"] "pair"; typ = init_constant ["Datatypes"] "prod" } (* Equalities *) type coq_eq_data = { eq : constr; ind : constr; refl : constr; sym : constr; trans: constr; congr: constr } (* Data needed for discriminate and injection *) type coq_inversion_data = { inv_eq : constr; (* : forall params, t -> Prop *) inv_ind : constr; (* : forall params P y, eq params y -> P y *) inv_congr: constr (* : forall params B (f:t->B) y, eq params y -> f c=f y *) } let lazy_init_constant dir id = lazy (init_constant dir id) let lazy_logic_constant dir id = lazy (logic_constant dir id) (* Leibniz equality on Type *) let coq_eq_eq = lazy_init_constant ["Logic"] "eq" let coq_eq_refl = lazy_init_constant ["Logic"] "eq_refl" let coq_eq_ind = lazy_init_constant ["Logic"] "eq_ind" let coq_eq_congr = lazy_init_constant ["Logic"] "f_equal" let coq_eq_sym = lazy_init_constant ["Logic"] "eq_sym" let coq_eq_trans = lazy_init_constant ["Logic"] "eq_trans" let coq_f_equal2 = lazy_init_constant ["Logic"] "f_equal2" let coq_eq_congr_canonical = lazy_init_constant ["Logic"] "f_equal_canonical_form" let build_coq_eq_data () = let _ = check_required_library logic_module_name in { eq = Lazy.force coq_eq_eq; ind = Lazy.force coq_eq_ind; refl = Lazy.force coq_eq_refl; sym = Lazy.force coq_eq_sym; trans = Lazy.force coq_eq_trans; congr = Lazy.force coq_eq_congr } let build_coq_eq () = Lazy.force coq_eq_eq let build_coq_eq_refl () = Lazy.force coq_eq_refl let build_coq_eq_sym () = Lazy.force coq_eq_sym let build_coq_f_equal2 () = Lazy.force coq_f_equal2 let build_coq_inversion_eq_data () = let _ = check_required_library logic_module_name in { inv_eq = Lazy.force coq_eq_eq; inv_ind = Lazy.force coq_eq_ind; inv_congr = Lazy.force coq_eq_congr_canonical } (* Heterogenous equality on Type *) let coq_jmeq_eq = lazy_logic_constant ["JMeq"] "JMeq" let coq_jmeq_refl = lazy_logic_constant ["JMeq"] "JMeq_refl" let coq_jmeq_ind = lazy_logic_constant ["JMeq"] "JMeq_ind" let coq_jmeq_sym = lazy_logic_constant ["JMeq"] "JMeq_sym" let coq_jmeq_congr = lazy_logic_constant ["JMeq"] "JMeq_congr" let coq_jmeq_trans = lazy_logic_constant ["JMeq"] "JMeq_trans" let coq_jmeq_congr_canonical = lazy_logic_constant ["JMeq"] "JMeq_congr_canonical_form" let build_coq_jmeq_data () = let _ = check_required_library jmeq_module_name in { eq = Lazy.force coq_jmeq_eq; ind = Lazy.force coq_jmeq_ind; refl = Lazy.force coq_jmeq_refl; sym = Lazy.force coq_jmeq_sym; trans = Lazy.force coq_jmeq_trans; congr = Lazy.force coq_jmeq_congr } let join_jmeq_types eq = mkLambda(Name (id_of_string "A"),Termops.new_Type(), mkLambda(Name (id_of_string "x"),mkRel 1, mkApp (eq,[|mkRel 2;mkRel 1;mkRel 2|]))) let build_coq_inversion_jmeq_data () = let _ = check_required_library logic_module_name in { inv_eq = join_jmeq_types (Lazy.force coq_jmeq_eq); inv_ind = Lazy.force coq_jmeq_ind; inv_congr = Lazy.force coq_jmeq_congr_canonical } (* Specif *) let coq_sumbool = lazy_init_constant ["Specif"] "sumbool" let build_coq_sumbool () = Lazy.force coq_sumbool (* Equality on Type as a Type *) let coq_identity_eq = lazy_init_constant ["Datatypes"] "identity" let coq_identity_refl = lazy_init_constant ["Datatypes"] "identity_refl" let coq_identity_ind = lazy_init_constant ["Datatypes"] "identity_ind" let coq_identity_congr = lazy_init_constant ["Logic_Type"] "identity_congr" let coq_identity_sym = lazy_init_constant ["Logic_Type"] "identity_sym" let coq_identity_trans = lazy_init_constant ["Logic_Type"] "identity_trans" let coq_identity_congr_canonical = lazy_init_constant ["Logic_Type"] "identity_congr_canonical_form" let build_coq_identity_data () = let _ = check_required_library datatypes_module_name in { eq = Lazy.force coq_identity_eq; ind = Lazy.force coq_identity_ind; refl = Lazy.force coq_identity_refl; sym = Lazy.force coq_identity_sym; trans = Lazy.force coq_identity_trans; congr = Lazy.force coq_identity_congr } let build_coq_inversion_identity_data () = let _ = check_required_library datatypes_module_name in let _ = check_required_library logic_type_module_name in { inv_eq = Lazy.force coq_identity_eq; inv_ind = Lazy.force coq_identity_ind; inv_congr = Lazy.force coq_identity_congr_canonical } (* Equality to true *) let coq_eq_true_eq = lazy_init_constant ["Datatypes"] "eq_true" let coq_eq_true_ind = lazy_init_constant ["Datatypes"] "eq_true_ind" let coq_eq_true_congr = lazy_init_constant ["Logic"] "eq_true_congr" let build_coq_inversion_eq_true_data () = let _ = check_required_library datatypes_module_name in let _ = check_required_library logic_module_name in { inv_eq = Lazy.force coq_eq_true_eq; inv_ind = Lazy.force coq_eq_true_ind; inv_congr = Lazy.force coq_eq_true_congr } (* The False proposition *) let coq_False = lazy_init_constant ["Logic"] "False" (* The True proposition and its unique proof *) let coq_True = lazy_init_constant ["Logic"] "True" let coq_I = lazy_init_constant ["Logic"] "I" (* Connectives *) let coq_not = lazy_init_constant ["Logic"] "not" let coq_and = lazy_init_constant ["Logic"] "and" let coq_conj = lazy_init_constant ["Logic"] "conj" let coq_or = lazy_init_constant ["Logic"] "or" let coq_ex = lazy_init_constant ["Logic"] "ex" let coq_iff = lazy_init_constant ["Logic"] "iff" let coq_iff_left_proj = lazy_init_constant ["Logic"] "proj1" let coq_iff_right_proj = lazy_init_constant ["Logic"] "proj2" (* Runtime part *) let build_coq_True () = Lazy.force coq_True let build_coq_I () = Lazy.force coq_I let build_coq_False () = Lazy.force coq_False let build_coq_not () = Lazy.force coq_not let build_coq_and () = Lazy.force coq_and let build_coq_conj () = Lazy.force coq_conj let build_coq_or () = Lazy.force coq_or let build_coq_ex () = Lazy.force coq_ex let build_coq_iff () = Lazy.force coq_iff let build_coq_iff_left_proj () = Lazy.force coq_iff_left_proj let build_coq_iff_right_proj () = Lazy.force coq_iff_right_proj (* The following is less readable but does not depend on parsing *) let coq_eq_ref = lazy (init_reference ["Logic"] "eq") let coq_identity_ref = lazy (init_reference ["Datatypes"] "identity") let coq_jmeq_ref = lazy (gen_reference "Coqlib" ["Logic";"JMeq"] "JMeq") let coq_eq_true_ref = lazy (gen_reference "Coqlib" ["Init";"Datatypes"] "eq_true") let coq_existS_ref = lazy (anomaly "use coq_existT_ref") let coq_existT_ref = lazy (init_reference ["Specif"] "existT") let coq_exist_ref = lazy (init_reference ["Specif"] "exist") let coq_not_ref = lazy (init_reference ["Logic"] "not") let coq_False_ref = lazy (init_reference ["Logic"] "False") let coq_sumbool_ref = lazy (init_reference ["Specif"] "sumbool") let coq_sig_ref = lazy (init_reference ["Specif"] "sig") let coq_or_ref = lazy (init_reference ["Logic"] "or") let coq_iff_ref = lazy (init_reference ["Logic"] "iff") coq-8.4pl4/interp/dumpglob.mli0000644000175000017500000000355512326224777015460 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val close_glob_file : unit -> unit val start_dump_glob : string -> unit val end_dump_glob : unit -> unit val dump : unit -> bool val noglob : unit -> unit val dump_to_stdout : unit -> unit val dump_into_file : string -> unit val dump_to_dotglob : unit -> unit val pause : unit -> unit val continue : unit -> unit type coqdoc_state = Lexer.location_table val coqdoc_freeze : unit -> coqdoc_state val coqdoc_unfreeze : coqdoc_state -> unit val add_glob : Util.loc -> Libnames.global_reference -> unit val add_glob_kn : Util.loc -> Names.kernel_name -> unit val dump_definition : Util.loc * Names.identifier -> bool -> string -> unit val dump_moddef : Util.loc -> Names.module_path -> string -> unit val dump_modref : Util.loc -> Names.module_path -> string -> unit val dump_reference : Util.loc -> string -> string -> string -> unit val dump_libref : Util.loc -> Names.dir_path -> string -> unit val dump_notation_location : (int * int) list -> Topconstr.notation -> (Notation.notation_location * Topconstr.scope_name option) -> unit val dump_binding : Util.loc -> Names.Idset.elt -> unit val dump_notation : Util.loc * (Topconstr.notation * Notation.notation_location) -> Topconstr.scope_name option -> bool -> unit val dump_constraint : Topconstr.typeclass_constraint -> bool -> string -> unit val dump_string : string -> unit coq-8.4pl4/interp/reserve.ml0000644000175000017500000000640312326224777015144 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* RefKey(canonical_gr ref), Some (List.length args) | AList (_,_,AApp (ARef ref,args),_,_) | ABinderList (_,_,AApp (ARef ref,args),_) -> RefKey (canonical_gr ref), Some (List.length args) | ARef ref -> RefKey(canonical_gr ref), None | _ -> Oth, None let cache_reserved_type (_,(id,t)) = let key = fst (aconstr_key t) in reserve_table := Idmap.add id t !reserve_table; reserve_revtable := Gmapl.add key (t,id) !reserve_revtable let in_reserved : identifier * aconstr -> obj = declare_object {(default_object "RESERVED-TYPE") with cache_function = cache_reserved_type } let freeze_reserved () = (!reserve_table,!reserve_revtable) let unfreeze_reserved (r,rr) = reserve_table := r; reserve_revtable := rr let init_reserved () = reserve_table := Idmap.empty; reserve_revtable := Gmapl.empty let _ = Summary.declare_summary "reserved-type" { Summary.freeze_function = freeze_reserved; Summary.unfreeze_function = unfreeze_reserved; Summary.init_function = init_reserved } let declare_reserved_type_binding (loc,id) t = if id <> root_of_id id then user_err_loc(loc,"declare_reserved_type", (pr_id id ++ str " is not reservable: it must have no trailing digits, quote, or _")); begin try let _ = Idmap.find id !reserve_table in user_err_loc(loc,"declare_reserved_type", (pr_id id++str" is already bound to a type")) with Not_found -> () end; add_anonymous_leaf (in_reserved (id,t)) let declare_reserved_type idl t = List.iter (fun id -> declare_reserved_type_binding id t) (List.rev idl) let find_reserved_type id = Idmap.find (root_of_id id) !reserve_table let constr_key c = try RefKey (canonical_gr (global_of_constr (fst (Term.decompose_app c)))) with Not_found -> Oth let revert_reserved_type t = try let l = Gmapl.find (constr_key t) !reserve_revtable in let t = Detyping.detype false [] [] t in list_try_find (fun (pat,id) -> try let _ = match_aconstr false t ([],pat) in Name id with No_match -> failwith "") l with Not_found | Failure _ -> Anonymous let _ = Namegen.set_reserved_typed_name revert_reserved_type open Glob_term let anonymize_if_reserved na t = match na with | Name id as na -> (try if not !Flags.raw_print & (try aconstr_of_glob_constr [] [] t = find_reserved_type id with UserError _ -> false) then GHole (dummy_loc,Evd.BinderType na) else t with Not_found -> t) | Anonymous -> t coq-8.4pl4/interp/modintern.mli0000644000175000017500000000264012326224777015640 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* module_ast -> module_struct_entry val interp_modexpr : env -> module_ast -> module_struct_entry (** The following function tries to interprete an ast as a module, and in case of failure, interpretes this ast as a module type. The boolean is true for a module, false for a module type *) val interp_modexpr_or_modtype : env -> module_ast -> module_struct_entry * bool val lookup_module : qualid located -> module_path coq-8.4pl4/interp/ppextend.ml0000644000175000017500000000262412326224777015321 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* h n | PpHOVB n -> hov n | PpHVB n -> hv n | PpVB n -> v n | PpTB -> t let ppcmd_of_cut = function | PpTab -> tab () | PpFnl -> fnl () | PpBrk(n1,n2) -> brk(n1,n2) | PpTbrk(n1,n2) -> tbrk(n1,n2) type unparsing = | UnpMetaVar of int * parenRelation | UnpListMetaVar of int * parenRelation * unparsing list | UnpBinderListMetaVar of int * bool * unparsing list | UnpTerminal of string | UnpBox of ppbox * unparsing list | UnpCut of ppcut coq-8.4pl4/interp/ppextend.mli0000644000175000017500000000234212326224777015467 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* std_ppcmds -> std_ppcmds val ppcmd_of_cut : ppcut -> std_ppcmds type unparsing = | UnpMetaVar of int * parenRelation | UnpListMetaVar of int * parenRelation * unparsing list | UnpBinderListMetaVar of int * bool * unparsing list | UnpTerminal of string | UnpBox of ppbox * unparsing list | UnpCut of ppcut coq-8.4pl4/interp/implicit_quantifiers.ml0000644000175000017500000002554712326224777017727 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* !generalizable_table); Summary.unfreeze_function = (fun r -> generalizable_table := r); Summary.init_function = (fun () -> generalizable_table := Idpred.empty) } let declare_generalizable_ident table (loc,id) = if id <> root_of_id id then user_err_loc(loc,"declare_generalizable_ident", (pr_id id ++ str " is not declarable as generalizable identifier: it must have no trailing digits, quote, or _")); if Idpred.mem id table then user_err_loc(loc,"declare_generalizable_ident", (pr_id id++str" is already declared as a generalizable identifier")) else Idpred.add id table let add_generalizable gen table = match gen with | None -> Idpred.empty | Some [] -> Idpred.full | Some l -> List.fold_left (fun table lid -> declare_generalizable_ident table lid) table l let cache_generalizable_type (_,(local,cmd)) = generalizable_table := add_generalizable cmd !generalizable_table let load_generalizable_type _ (_,(local,cmd)) = generalizable_table := add_generalizable cmd !generalizable_table let in_generalizable : bool * identifier located list option -> obj = declare_object {(default_object "GENERALIZED-IDENT") with load_function = load_generalizable_type; cache_function = cache_generalizable_type; classify_function = (fun (local, _ as obj) -> if local then Dispose else Keep obj) } let declare_generalizable local gen = Lib.add_anonymous_leaf (in_generalizable (local, gen)) let find_generalizable_ident id = Idpred.mem (root_of_id id) !generalizable_table let ids_of_list l = List.fold_right Idset.add l Idset.empty let locate_reference qid = match Nametab.locate_extended qid with | TrueGlobal ref -> true | SynDef kn -> true let is_global id = try locate_reference (qualid_of_ident id) with Not_found -> false let is_freevar ids env x = try if Idset.mem x ids then false else try ignore(Environ.lookup_named x env) ; false with e when Errors.noncritical e -> not (is_global x) with e when Errors.noncritical e -> true (* Auxiliary functions for the inference of implicitly quantified variables. *) let ungeneralizable loc id = user_err_loc (loc, "Generalization", str "Unbound and ungeneralizable variable " ++ pr_id id) let free_vars_of_constr_expr c ?(bound=Idset.empty) l = let found loc id bdvars l = if List.mem id l then l else if is_freevar bdvars (Global.env ()) id then if find_generalizable_ident id then id :: l else ungeneralizable loc id else l in let rec aux bdvars l c = match c with | CRef (Ident (loc,id)) -> found loc id bdvars l | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id)) :: _, [], [])) when not (Idset.mem id bdvars) -> fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux (Idset.add id bdvars) l c | c -> fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux bdvars l c in aux bound l c let ids_of_names l = List.fold_left (fun acc x -> match snd x with Name na -> na :: acc | Anonymous -> acc) [] l let free_vars_of_binders ?(bound=Idset.empty) l (binders : local_binder list) = let rec aux bdvars l c = match c with ((LocalRawAssum (n, _, c)) :: tl) -> let bound = ids_of_names n in let l' = free_vars_of_constr_expr c ~bound:bdvars l in aux (Idset.union (ids_of_list bound) bdvars) l' tl | ((LocalRawDef (n, c)) :: tl) -> let bound = match snd n with Anonymous -> [] | Name n -> [n] in let l' = free_vars_of_constr_expr c ~bound:bdvars l in aux (Idset.union (ids_of_list bound) bdvars) l' tl | [] -> bdvars, l in aux bound l binders let add_name_to_ids set na = match na with | Anonymous -> set | Name id -> Idset.add id set let generalizable_vars_of_glob_constr ?(bound=Idset.empty) ?(allowed=Idset.empty) = let rec vars bound vs = function | GVar (loc,id) -> if is_freevar bound (Global.env ()) id then if List.mem_assoc id vs then vs else (id, loc) :: vs else vs | GApp (loc,f,args) -> List.fold_left (vars bound) vs (f::args) | GLambda (loc,na,_,ty,c) | GProd (loc,na,_,ty,c) | GLetIn (loc,na,ty,c) -> let vs' = vars bound vs ty in let bound' = add_name_to_ids bound na in vars bound' vs' c | GCases (loc,sty,rtntypopt,tml,pl) -> let vs1 = vars_option bound vs rtntypopt in let vs2 = List.fold_left (fun vs (tm,_) -> vars bound vs tm) vs1 tml in List.fold_left (vars_pattern bound) vs2 pl | GLetTuple (loc,nal,rtntyp,b,c) -> let vs1 = vars_return_type bound vs rtntyp in let vs2 = vars bound vs1 b in let bound' = List.fold_left add_name_to_ids bound nal in vars bound' vs2 c | GIf (loc,c,rtntyp,b1,b2) -> let vs1 = vars_return_type bound vs rtntyp in let vs2 = vars bound vs1 c in let vs3 = vars bound vs2 b1 in vars bound vs3 b2 | GRec (loc,fk,idl,bl,tyl,bv) -> let bound' = Array.fold_right Idset.add idl bound in let vars_fix i vs fid = let vs1,bound1 = List.fold_left (fun (vs,bound) (na,k,bbd,bty) -> let vs' = vars_option bound vs bbd in let vs'' = vars bound vs' bty in let bound' = add_name_to_ids bound na in (vs'',bound') ) (vs,bound') bl.(i) in let vs2 = vars bound1 vs1 tyl.(i) in vars bound1 vs2 bv.(i) in array_fold_left_i vars_fix vs idl | GCast (loc,c,k) -> let v = vars bound vs c in (match k with CastConv (_,t) -> vars bound v t | _ -> v) | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> vs and vars_pattern bound vs (loc,idl,p,c) = let bound' = List.fold_right Idset.add idl bound in vars bound' vs c and vars_option bound vs = function None -> vs | Some p -> vars bound vs p and vars_return_type bound vs (na,tyopt) = let bound' = add_name_to_ids bound na in vars_option bound' vs tyopt in fun rt -> let vars = List.rev (vars bound [] rt) in List.iter (fun (id, loc) -> if not (Idset.mem id allowed || find_generalizable_ident id) then ungeneralizable loc id) vars; vars let rec make_fresh ids env x = if is_freevar ids env x then x else make_fresh ids env (Nameops.lift_subscript x) let next_name_away_from na avoid = match na with | Anonymous -> make_fresh avoid (Global.env ()) (id_of_string "anon") | Name id -> make_fresh avoid (Global.env ()) id let combine_params avoid fn applied needed = let named, applied = List.partition (function (t, Some (loc, ExplByName id)) -> if not (List.exists (fun (_, (id', _, _)) -> Name id = id') needed) then user_err_loc (loc,"",str "Wrong argument name: " ++ Nameops.pr_id id); true | _ -> false) applied in let named = List.map (fun x -> match x with (t, Some (loc, ExplByName id)) -> id, t | _ -> assert false) named in let needed = List.filter (fun (_, (_, b, _)) -> b = None) needed in let rec aux ids avoid app need = match app, need with [], [] -> List.rev ids, avoid | app, (_, (Name id, _, _)) :: need when List.mem_assoc id named -> aux (List.assoc id named :: ids) avoid app need | (x, None) :: app, (None, (Name id, _, _)) :: need -> aux (x :: ids) avoid app need | _, (Some cl, (_, _, _) as d) :: need -> let t', avoid' = fn avoid d in aux (t' :: ids) avoid' app need | x :: app, (None, _) :: need -> aux (fst x :: ids) avoid app need | [], (None, _ as decl) :: need -> let t', avoid' = fn avoid decl in aux (t' :: ids) avoid' app need | (x,_) :: _, [] -> user_err_loc (constr_loc x,"",str "Typeclass does not expect more arguments") in aux [] avoid applied needed let combine_params_freevar = fun avoid (_, (na, _, _)) -> let id' = next_name_away_from na avoid in (CRef (Ident (dummy_loc, id')), Idset.add id' avoid) let destClassApp cl = match cl with | CApp (loc, (None, CRef ref), l) -> loc, ref, List.map fst l | CAppExpl (loc, (None, ref), l) -> loc, ref, l | CRef ref -> loc_of_reference ref, ref, [] | _ -> raise Not_found let destClassAppExpl cl = match cl with | CApp (loc, (None, CRef ref), l) -> loc, ref, l | CRef ref -> loc_of_reference ref, ref, [] | _ -> raise Not_found let implicit_application env ?(allow_partial=true) f ty = let is_class = try let (loc, r, _ as clapp) = destClassAppExpl ty in let (loc, qid) = qualid_of_reference r in let gr = Nametab.locate qid in if Typeclasses.is_class gr then Some (clapp, gr) else None with Not_found -> None in match is_class with | None -> ty, env | Some ((loc, id, par), gr) -> let avoid = Idset.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in let c, avoid = let c = class_info gr in let (ci, rd) = c.cl_context in if not allow_partial then begin let applen = List.fold_left (fun acc (x, y) -> if y = None then succ acc else acc) 0 par in let needlen = List.fold_left (fun acc x -> if x = None then succ acc else acc) 0 ci in if needlen <> applen then Typeclasses_errors.mismatched_ctx_inst (Global.env ()) Parameters (List.map fst par) rd end; let pars = List.rev (List.combine ci rd) in let args, avoid = combine_params avoid f par pars in CAppExpl (loc, (None, id), args), avoid in c, avoid let implicits_of_glob_constr ?(with_products=true) l = let add_impl i na bk l = if bk = Implicit then let name = match na with | Name id -> Some id | Anonymous -> None in (ExplByPos (i, name), (true, true, true)) :: l else l in let rec aux i c = let abs na bk b = add_impl i na bk (aux (succ i) b) in match c with | GProd (loc, na, bk, t, b) -> if with_products then abs na bk b else (if bk = Implicit then msg_warning (str "Ignoring implicit status of product binder " ++ pr_name na ++ str " and following binders"); []) | GLambda (loc, na, bk, t, b) -> abs na bk b | GLetIn (loc, na, t, b) -> aux i b | GRec (_, fix_kind, nas, args, tys, bds) -> let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in list_fold_left_i (fun i l (na,bk,_,_) -> add_impl i na bk l) i (aux (List.length args.(nb) + i) bds.(nb)) args.(nb) | _ -> [] in aux 1 l coq-8.4pl4/interp/notation.mli0000644000175000017500000001462412326224777015501 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val current_scopes : unit -> scopes (** Check where a scope is opened or not in a scope list, or in * the current opened scopes *) val scope_is_open_in_scopes : scope_name -> scopes -> bool val scope_is_open : scope_name -> bool (** Open scope *) val open_close_scope : (** locality *) bool * (* open *) bool * scope_name -> unit (** Extend a list of scopes *) val empty_scope_stack : scopes val push_scope : scope_name -> scopes -> scopes val find_scope : scope_name -> scope (** Declare delimiters for printing *) val declare_delimiters : scope_name -> delimiters -> unit val find_delimiters_scope : loc -> delimiters -> scope_name (** {6 Declare and uses back and forth an interpretation of primitive token } *) (** A numeral interpreter is the pair of an interpreter for **integer** numbers in terms and an optional interpreter in pattern, if negative numbers are not supported, the interpreter must fail with an appropriate error message *) type notation_location = (dir_path * dir_path) * string type required_module = full_path * string list type cases_pattern_status = bool (** true = use prim token in patterns *) type 'a prim_token_interpreter = loc -> 'a -> glob_constr type 'a prim_token_uninterpreter = glob_constr list * (glob_constr -> 'a option) * cases_pattern_status val declare_numeral_interpreter : scope_name -> required_module -> bigint prim_token_interpreter -> bigint prim_token_uninterpreter -> unit val declare_string_interpreter : scope_name -> required_module -> string prim_token_interpreter -> string prim_token_uninterpreter -> unit (** Return the [term]/[cases_pattern] bound to a primitive token in a given scope context*) val interp_prim_token : loc -> prim_token -> local_scopes -> glob_constr * (notation_location * scope_name option) val interp_prim_token_cases_pattern : loc -> prim_token -> name -> local_scopes -> cases_pattern * (notation_location * scope_name option) (** Return the primitive token associated to a [term]/[cases_pattern]; raise [No_match] if no such token *) val uninterp_prim_token : glob_constr -> scope_name * prim_token val uninterp_prim_token_cases_pattern : cases_pattern -> name * scope_name * prim_token val availability_of_prim_token : prim_token -> scope_name -> local_scopes -> delimiters option option (** {6 Declare and interpret back and forth a notation } *) (** Binds a notation in a given scope to an interpretation *) type interp_rule = | NotationRule of scope_name option * notation | SynDefRule of kernel_name val declare_notation_interpretation : notation -> scope_name option -> interpretation -> notation_location -> unit val declare_uninterpretation : interp_rule -> interpretation -> unit (** Return the interpretation bound to a notation *) val interp_notation : loc -> notation -> local_scopes -> interpretation * (notation_location * scope_name option) (** Return the possible notations for a given term *) val uninterp_notations : glob_constr -> (interp_rule * interpretation * int option) list val uninterp_cases_pattern_notations : cases_pattern -> (interp_rule * interpretation * int option) list (** Test if a notation is available in the scopes context [scopes]; if available, the result is not None; the first argument is itself not None if a delimiters is needed *) val availability_of_notation : scope_name option * notation -> local_scopes -> (scope_name option * delimiters option) option (** {6 Declare and test the level of a (possibly uninterpreted) notation } *) val declare_notation_level : notation -> level -> unit val level_of_notation : notation -> level (** raise [Not_found] if no level *) (** {6 Miscellaneous} *) val interp_notation_as_global_reference : loc -> (global_reference -> bool) -> notation -> delimiters option -> global_reference (** Checks for already existing notations *) val exists_notation_in_scope : scope_name option -> notation -> interpretation -> bool (** Declares and looks for scopes associated to arguments of a global ref *) val declare_arguments_scope : bool (** true=local *) -> global_reference -> scope_name option list -> unit val find_arguments_scope : global_reference -> scope_name option list val declare_class_scope : scope_name -> Classops.cl_typ -> unit val declare_ref_arguments_scope : global_reference -> unit val compute_arguments_scope : Term.types -> scope_name option list (** Building notation key *) type symbol = | Terminal of string | NonTerminal of identifier | SProdList of identifier * symbol list | Break of int val make_notation_key : symbol list -> notation val decompose_notation_key : notation -> symbol list (** Prints scopes (expects a pure aconstr printer) *) val pr_scope : (glob_constr -> std_ppcmds) -> scope_name -> std_ppcmds val pr_scopes : (glob_constr -> std_ppcmds) -> std_ppcmds val locate_notation : (glob_constr -> std_ppcmds) -> notation -> scope_name option -> std_ppcmds val pr_visibility: (glob_constr -> std_ppcmds) -> scope_name option -> std_ppcmds (** {6 Printing rules for notations} *) (** Declare and look for the printing rule for symbolic notations *) type unparsing_rule = unparsing list * precedence val declare_notation_printing_rule : notation -> unparsing_rule -> unit val find_notation_printing_rule : notation -> unparsing_rule (** Rem: printing rules for primitive token are canonical *) val with_notation_protection : ('a -> 'b) -> 'a -> 'b coq-8.4pl4/interp/smartlocate.ml0000644000175000017500000000414112326224777016004 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ref | SynDef kn -> match search_syntactic_definition kn with | [],ARef ref -> ref | _ -> raise Not_found let locate_global_with_alias (loc,qid) = let ref = Nametab.locate_extended qid in try global_of_extended_global ref with Not_found -> user_err_loc (loc,"",pr_qualid qid ++ str " is bound to a notation that does not denote a reference.") let global_inductive_with_alias r = let (loc,qid as lqid) = qualid_of_reference r in try match locate_global_with_alias lqid with | IndRef ind -> ind | ref -> user_err_loc (loc_of_reference r,"global_inductive", pr_reference r ++ spc () ++ str "is not an inductive type.") with Not_found -> Nametab.error_global_not_found_loc loc qid let global_with_alias r = let (loc,qid as lqid) = qualid_of_reference r in try locate_global_with_alias lqid with Not_found -> Nametab.error_global_not_found_loc loc qid let smart_global = function | AN r -> global_with_alias r | ByNotation (loc,ntn,sc) -> Notation.interp_notation_as_global_reference loc (fun _ -> true) ntn sc let smart_global_inductive = function | AN r -> global_inductive_with_alias r | ByNotation (loc,ntn,sc) -> destIndRef (Notation.interp_notation_as_global_reference loc isIndRef ntn sc) coq-8.4pl4/interp/coqlib.mli0000644000175000017500000001343412326224777015115 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string list -> string -> global_reference (** [coq_reference caller_message [dir;subdir;...] s] returns a global reference to the name Coq.dir.subdir.(...).s *) val coq_reference : message -> string list -> string -> global_reference (** idem but return a term *) val coq_constant : message -> string list -> string -> constr (** Synonyms of [coq_constant] and [coq_reference] *) val gen_constant : message -> string list -> string -> constr val gen_reference : message -> string list -> string -> global_reference (** Search in several modules (not prefixed by "Coq") *) val gen_constant_in_modules : string->string list list-> string -> constr val arith_modules : string list list val zarith_base_modules : string list list val init_modules : string list list (** For tactics/commands requiring vernacular libraries *) val check_required_library : string list -> unit (** {6 Global references } *) (** Modules *) val logic_module : dir_path val logic_type_module : dir_path val datatypes_module_name : string list val logic_module_name : string list (** Natural numbers *) val nat_path : full_path val glob_nat : global_reference val path_of_O : constructor val path_of_S : constructor val glob_O : global_reference val glob_S : global_reference (** Booleans *) val glob_bool : global_reference val path_of_true : constructor val path_of_false : constructor val glob_true : global_reference val glob_false : global_reference (** Equality *) val glob_eq : global_reference val glob_identity : global_reference val glob_jmeq : global_reference (** {6 ... } *) (** Constructions and patterns related to Coq initial state are unknown at compile time. Therefore, we can only provide methods to build them at runtime. This is the purpose of the [constr delayed] and [constr_pattern delayed] types. Objects of this time needs to be forced with [delayed_force] to get the actual constr or pattern at runtime. *) type coq_bool_data = { andb : constr; andb_prop : constr; andb_true_intro : constr} val build_bool_type : coq_bool_data delayed (** {6 For Equality tactics } *) type coq_sigma_data = { proj1 : constr; proj2 : constr; elim : constr; intro : constr; typ : constr } val build_sigma_set : coq_sigma_data delayed val build_sigma_type : coq_sigma_data delayed val build_sigma : coq_sigma_data delayed (** Non-dependent pairs in Set from Datatypes *) val build_prod : coq_sigma_data delayed type coq_eq_data = { eq : constr; ind : constr; refl : constr; sym : constr; trans: constr; congr: constr } val build_coq_eq_data : coq_eq_data delayed val build_coq_identity_data : coq_eq_data delayed val build_coq_jmeq_data : coq_eq_data delayed val build_coq_eq : constr delayed (** = [(build_coq_eq_data()).eq] *) val build_coq_eq_refl : constr delayed (** = [(build_coq_eq_data()).refl] *) val build_coq_eq_sym : constr delayed (** = [(build_coq_eq_data()).sym] *) val build_coq_f_equal2 : constr delayed (** Data needed for discriminate and injection *) type coq_inversion_data = { inv_eq : constr; (** : forall params, args -> Prop *) inv_ind : constr; (** : forall params P (H : P params) args, eq params args -> P args *) inv_congr: constr (** : forall params B (f:t->B) args, eq params args -> f params = f args *) } val build_coq_inversion_eq_data : coq_inversion_data delayed val build_coq_inversion_identity_data : coq_inversion_data delayed val build_coq_inversion_jmeq_data : coq_inversion_data delayed val build_coq_inversion_eq_true_data : coq_inversion_data delayed (** Specif *) val build_coq_sumbool : constr delayed (** {6 ... } *) (** Connectives The False proposition *) val build_coq_False : constr delayed (** The True proposition and its unique proof *) val build_coq_True : constr delayed val build_coq_I : constr delayed (** Negation *) val build_coq_not : constr delayed (** Conjunction *) val build_coq_and : constr delayed val build_coq_conj : constr delayed val build_coq_iff : constr delayed val build_coq_iff_left_proj : constr delayed val build_coq_iff_right_proj : constr delayed (** Disjunction *) val build_coq_or : constr delayed (** Existential quantifier *) val build_coq_ex : constr delayed val coq_eq_ref : global_reference lazy_t val coq_identity_ref : global_reference lazy_t val coq_jmeq_ref : global_reference lazy_t val coq_eq_true_ref : global_reference lazy_t val coq_existS_ref : global_reference lazy_t val coq_existT_ref : global_reference lazy_t val coq_exist_ref : global_reference lazy_t val coq_not_ref : global_reference lazy_t val coq_False_ref : global_reference lazy_t val coq_sumbool_ref : global_reference lazy_t val coq_sig_ref : global_reference lazy_t val coq_or_ref : global_reference lazy_t val coq_iff_ref : global_reference lazy_t coq-8.4pl4/interp/topconstr.ml0000644000175000017500000014506112326224777015530 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* error "This expression should be a simple identifier." | Name id -> id let to_id g e id = let e,na = g e (Name id) in e,name_to_ident na let rec cases_pattern_fold_map loc g e = function | PatVar (_,na) -> let e',na' = g e na in e', PatVar (loc,na') | PatCstr (_,cstr,patl,na) -> let e',na' = g e na in let e',patl' = list_fold_map (cases_pattern_fold_map loc g) e patl in e', PatCstr (loc,cstr,patl',na') let rec subst_glob_vars l = function | GVar (_,id) as r -> (try List.assoc id l with Not_found -> r) | GProd (loc,Name id,bk,t,c) -> let id = try match List.assoc id l with GVar(_,id') -> id' | _ -> id with Not_found -> id in GProd (loc,Name id,bk,subst_glob_vars l t,subst_glob_vars l c) | GLambda (loc,Name id,bk,t,c) -> let id = try match List.assoc id l with GVar(_,id') -> id' | _ -> id with Not_found -> id in GLambda (loc,Name id,bk,subst_glob_vars l t,subst_glob_vars l c) | r -> map_glob_constr (subst_glob_vars l) r (* assume: id is not binding *) let ldots_var = id_of_string ".." let glob_constr_of_aconstr_with_binders loc g f e = function | AVar id -> GVar (loc,id) | AApp (a,args) -> GApp (loc,f e a, List.map (f e) args) | AList (x,y,iter,tail,swap) -> let t = f e tail in let it = f e iter in let innerl = (ldots_var,t)::(if swap then [] else [x,GVar(loc,y)]) in let inner = GApp (loc,GVar (loc,ldots_var),[subst_glob_vars innerl it]) in let outerl = (ldots_var,inner)::(if swap then [x,GVar(loc,y)] else []) in subst_glob_vars outerl it | ABinderList (x,y,iter,tail) -> let t = f e tail in let it = f e iter in let innerl = [(ldots_var,t);(x,GVar(loc,y))] in let inner = GApp (loc,GVar (loc,ldots_var),[subst_glob_vars innerl it]) in let outerl = [(ldots_var,inner)] in subst_glob_vars outerl it | ALambda (na,ty,c) -> let e',na = g e na in GLambda (loc,na,Explicit,f e ty,f e' c) | AProd (na,ty,c) -> let e',na = g e na in GProd (loc,na,Explicit,f e ty,f e' c) | ALetIn (na,b,c) -> let e',na = g e na in GLetIn (loc,na,f e b,f e' c) | ACases (sty,rtntypopt,tml,eqnl) -> let e',tml' = List.fold_right (fun (tm,(na,t)) (e',tml') -> let e',t' = match t with | None -> e',None | Some (ind,npar,nal) -> let e',nal' = List.fold_right (fun na (e',nal) -> let e',na' = g e' na in e',na'::nal) nal (e',[]) in e',Some (loc,ind,npar,nal') in let e',na' = g e' na in (e',(f e tm,(na',t'))::tml')) tml (e,[]) in let fold (idl,e) na = let (e,na) = g e na in ((name_cons na idl,e),na) in let eqnl' = List.map (fun (patl,rhs) -> let ((idl,e),patl) = list_fold_map (cases_pattern_fold_map loc fold) ([],e) patl in (loc,idl,patl,f e rhs)) eqnl in GCases (loc,sty,Option.map (f e') rtntypopt,tml',eqnl') | ALetTuple (nal,(na,po),b,c) -> let e',nal = list_fold_map g e nal in let e'',na = g e na in GLetTuple (loc,nal,(na,Option.map (f e'') po),f e b,f e' c) | AIf (c,(na,po),b1,b2) -> let e',na = g e na in GIf (loc,f e c,(na,Option.map (f e') po),f e b1,f e b2) | ARec (fk,idl,dll,tl,bl) -> let e,dll = array_fold_map (list_fold_map (fun e (na,oc,b) -> let e,na = g e na in (e,(na,Explicit,Option.map (f e) oc,f e b)))) e dll in let e',idl = array_fold_map (to_id g) e idl in GRec (loc,fk,idl,dll,Array.map (f e) tl,Array.map (f e') bl) | ACast (c,k) -> GCast (loc,f e c, match k with | CastConv (k,t) -> CastConv (k,f e t) | CastCoerce -> CastCoerce) | ASort x -> GSort (loc,x) | AHole x -> GHole (loc,x) | APatVar n -> GPatVar (loc,(false,n)) | ARef x -> GRef (loc,x) let rec glob_constr_of_aconstr loc x = let rec aux () x = glob_constr_of_aconstr_with_binders loc (fun () id -> ((),id)) aux () x in aux () x (****************************************************************************) (* Translating a glob_constr into a notation, interpreting recursive patterns *) let add_id r id = r := (id :: pi1 !r, pi2 !r, pi3 !r) let add_name r = function Anonymous -> () | Name id -> add_id r id let split_at_recursive_part c = let sub = ref None in let rec aux = function | GApp (loc0,GVar(loc,v),c::l) when v = ldots_var -> if !sub <> None then (* Not narrowed enough to find only one recursive part *) raise Not_found else (sub := Some c; if l = [] then GVar (loc,ldots_var) else GApp (loc0,GVar (loc,ldots_var),l)) | c -> map_glob_constr aux c in let outer_iterator = aux c in match !sub with | None -> (* No recursive pattern found *) raise Not_found | Some c -> match outer_iterator with | GVar (_,v) when v = ldots_var -> (* Not enough context *) raise Not_found | _ -> outer_iterator, c let on_true_do b f c = if b then (f c; b) else b let compare_glob_constr f add t1 t2 = match t1,t2 with | GRef (_,r1), GRef (_,r2) -> eq_gr r1 r2 | GVar (_,v1), GVar (_,v2) -> on_true_do (v1 = v2) add (Name v1) | GApp (_,f1,l1), GApp (_,f2,l2) -> f f1 f2 & list_for_all2eq f l1 l2 | GLambda (_,na1,bk1,ty1,c1), GLambda (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 -> on_true_do (f ty1 ty2 & f c1 c2) add na1 | GProd (_,na1,bk1,ty1,c1), GProd (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 -> on_true_do (f ty1 ty2 & f c1 c2) add na1 | GHole _, GHole _ -> true | GSort (_,s1), GSort (_,s2) -> s1 = s2 | GLetIn (_,na1,b1,c1), GLetIn (_,na2,b2,c2) when na1 = na2 -> on_true_do (f b1 b2 & f c1 c2) add na1 | (GCases _ | GRec _ | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _),_ | _,(GCases _ | GRec _ | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _) -> error "Unsupported construction in recursive notations." | (GRef _ | GVar _ | GApp _ | GLambda _ | GProd _ | GHole _ | GSort _ | GLetIn _), _ -> false let rec eq_glob_constr t1 t2 = compare_glob_constr eq_glob_constr (fun _ -> ()) t1 t2 let subtract_loc loc1 loc2 = make_loc (fst (unloc loc1),fst (unloc loc2)-1) let check_is_hole id = function GHole _ -> () | t -> user_err_loc (loc_of_glob_constr t,"", strbrk "In recursive notation with binders, " ++ pr_id id ++ strbrk " is expected to come without type.") let compare_recursive_parts found f (iterator,subc) = let diff = ref None in let terminator = ref None in let rec aux c1 c2 = match c1,c2 with | GVar(_,v), term when v = ldots_var -> (* We found the pattern *) assert (!terminator = None); terminator := Some term; true | GApp (_,GVar(_,v),l1), GApp (_,term,l2) when v = ldots_var -> (* We found the pattern, but there are extra arguments *) (* (this allows e.g. alternative (recursive) notation of application) *) assert (!terminator = None); terminator := Some term; list_for_all2eq aux l1 l2 | GVar (_,x), GVar (_,y) when x<>y -> (* We found the position where it differs *) let lassoc = (!terminator <> None) in let x,y = if lassoc then y,x else x,y in !diff = None && (diff := Some (x,y,Some lassoc); true) | GLambda (_,Name x,_,t_x,c), GLambda (_,Name y,_,t_y,term) | GProd (_,Name x,_,t_x,c), GProd (_,Name y,_,t_y,term) -> (* We found a binding position where it differs *) check_is_hole x t_x; check_is_hole y t_y; !diff = None && (diff := Some (x,y,None); aux c term) | _ -> compare_glob_constr aux (add_name found) c1 c2 in if aux iterator subc then match !diff with | None -> let loc1 = loc_of_glob_constr iterator in let loc2 = loc_of_glob_constr (Option.get !terminator) in (* Here, we would need a loc made of several parts ... *) user_err_loc (subtract_loc loc1 loc2,"", str "Both ends of the recursive pattern are the same.") | Some (x,y,Some lassoc) -> let newfound = (pi1 !found, (x,y) :: pi2 !found, pi3 !found) in let iterator = f (if lassoc then subst_glob_vars [y,GVar(dummy_loc,x)] iterator else iterator) in (* found have been collected by compare_constr *) found := newfound; AList (x,y,iterator,f (Option.get !terminator),lassoc) | Some (x,y,None) -> let newfound = (pi1 !found, pi2 !found, (x,y) :: pi3 !found) in let iterator = f iterator in (* found have been collected by compare_constr *) found := newfound; ABinderList (x,y,iterator,f (Option.get !terminator)) else raise Not_found let aconstr_and_vars_of_glob_constr a = let found = ref ([],[],[]) in let rec aux c = let keepfound = !found in (* n^2 complexity but small and done only once per notation *) try compare_recursive_parts found aux' (split_at_recursive_part c) with Not_found -> found := keepfound; match c with | GApp (_,GVar (loc,f),[c]) when f = ldots_var -> (* Fall on the second part of the recursive pattern w/o having found the first part *) user_err_loc (loc,"", str "Cannot find where the recursive pattern starts.") | c -> aux' c and aux' = function | GVar (_,id) -> add_id found id; AVar id | GApp (_,g,args) -> AApp (aux g, List.map aux args) | GLambda (_,na,bk,ty,c) -> add_name found na; ALambda (na,aux ty,aux c) | GProd (_,na,bk,ty,c) -> add_name found na; AProd (na,aux ty,aux c) | GLetIn (_,na,b,c) -> add_name found na; ALetIn (na,aux b,aux c) | GCases (_,sty,rtntypopt,tml,eqnl) -> let f (_,idl,pat,rhs) = List.iter (add_id found) idl; (pat,aux rhs) in ACases (sty,Option.map aux rtntypopt, List.map (fun (tm,(na,x)) -> add_name found na; Option.iter (fun (_,_,_,nl) -> List.iter (add_name found) nl) x; (aux tm,(na,Option.map (fun (_,ind,n,nal) -> (ind,n,nal)) x))) tml, List.map f eqnl) | GLetTuple (loc,nal,(na,po),b,c) -> add_name found na; List.iter (add_name found) nal; ALetTuple (nal,(na,Option.map aux po),aux b,aux c) | GIf (loc,c,(na,po),b1,b2) -> add_name found na; AIf (aux c,(na,Option.map aux po),aux b1,aux b2) | GRec (_,fk,idl,dll,tl,bl) -> Array.iter (add_id found) idl; let dll = Array.map (List.map (fun (na,bk,oc,b) -> if bk <> Explicit then error "Binders marked as implicit not allowed in notations."; add_name found na; (na,Option.map aux oc,aux b))) dll in ARec (fk,idl,dll,Array.map aux tl,Array.map aux bl) | GCast (_,c,k) -> ACast (aux c, match k with CastConv (k,t) -> CastConv (k,aux t) | CastCoerce -> CastCoerce) | GSort (_,s) -> ASort s | GHole (_,w) -> AHole w | GRef (_,r) -> ARef r | GPatVar (_,(_,n)) -> APatVar n | GEvar _ -> error "Existential variables not allowed in notations." in let t = aux a in (* Side effect *) t, !found let rec list_rev_mem_assoc x = function | [] -> false | (_,x')::l -> x = x' || list_rev_mem_assoc x l let check_variables vars recvars (found,foundrec,foundrecbinding) = let useless_vars = List.map snd recvars in let vars = List.filter (fun (y,_) -> not (List.mem y useless_vars)) vars in let check_recvar x = if List.mem x found then errorlabstrm "" (pr_id x ++ strbrk " should only be used in the recursive part of a pattern.") in List.iter (fun (x,y) -> check_recvar x; check_recvar y) (foundrec@foundrecbinding); let check_bound x = if not (List.mem x found) then if List.mem_assoc x foundrec or List.mem_assoc x foundrecbinding or list_rev_mem_assoc x foundrec or list_rev_mem_assoc x foundrecbinding then error ((string_of_id x)^" should not be bound in a recursive pattern of the right-hand side.") else error ((string_of_id x)^" is unbound in the right-hand side.") in let check_pair s x y where = if not (List.mem (x,y) where) then errorlabstrm "" (strbrk "in the right-hand side, " ++ pr_id x ++ str " and " ++ pr_id y ++ strbrk " should appear in " ++ str s ++ str " position as part of a recursive pattern.") in let check_type (x,typ) = match typ with | NtnInternTypeConstr -> begin try check_pair "term" x (List.assoc x recvars) foundrec with Not_found -> check_bound x end | NtnInternTypeBinder -> begin try check_pair "binding" x (List.assoc x recvars) foundrecbinding with Not_found -> check_bound x end | NtnInternTypeIdent -> check_bound x in List.iter check_type vars let aconstr_of_glob_constr vars recvars a = let a,found = aconstr_and_vars_of_glob_constr a in check_variables vars recvars found; a (* Substitution of kernel names, avoiding a list of bound identifiers *) let aconstr_of_constr avoiding t = aconstr_of_glob_constr [] [] (Detyping.detype false avoiding [] t) let rec subst_pat subst pat = match pat with | PatVar _ -> pat | PatCstr (loc,((kn,i),j),cpl,n) -> let kn' = subst_ind subst kn and cpl' = list_smartmap (subst_pat subst) cpl in if kn' == kn && cpl' == cpl then pat else PatCstr (loc,((kn',i),j),cpl',n) let rec subst_aconstr subst bound raw = match raw with | ARef ref -> let ref',t = subst_global subst ref in if ref' == ref then raw else aconstr_of_constr bound t | AVar _ -> raw | AApp (r,rl) -> let r' = subst_aconstr subst bound r and rl' = list_smartmap (subst_aconstr subst bound) rl in if r' == r && rl' == rl then raw else AApp(r',rl') | AList (id1,id2,r1,r2,b) -> let r1' = subst_aconstr subst bound r1 and r2' = subst_aconstr subst bound r2 in if r1' == r1 && r2' == r2 then raw else AList (id1,id2,r1',r2',b) | ALambda (n,r1,r2) -> let r1' = subst_aconstr subst bound r1 and r2' = subst_aconstr subst bound r2 in if r1' == r1 && r2' == r2 then raw else ALambda (n,r1',r2') | AProd (n,r1,r2) -> let r1' = subst_aconstr subst bound r1 and r2' = subst_aconstr subst bound r2 in if r1' == r1 && r2' == r2 then raw else AProd (n,r1',r2') | ABinderList (id1,id2,r1,r2) -> let r1' = subst_aconstr subst bound r1 and r2' = subst_aconstr subst bound r2 in if r1' == r1 && r2' == r2 then raw else ABinderList (id1,id2,r1',r2') | ALetIn (n,r1,r2) -> let r1' = subst_aconstr subst bound r1 and r2' = subst_aconstr subst bound r2 in if r1' == r1 && r2' == r2 then raw else ALetIn (n,r1',r2') | ACases (sty,rtntypopt,rl,branches) -> let rtntypopt' = Option.smartmap (subst_aconstr subst bound) rtntypopt and rl' = list_smartmap (fun (a,(n,signopt) as x) -> let a' = subst_aconstr subst bound a in let signopt' = Option.map (fun ((indkn,i),n,nal as z) -> let indkn' = subst_ind subst indkn in if indkn == indkn' then z else ((indkn',i),n,nal)) signopt in if a' == a && signopt' == signopt then x else (a',(n,signopt'))) rl and branches' = list_smartmap (fun (cpl,r as branch) -> let cpl' = list_smartmap (subst_pat subst) cpl and r' = subst_aconstr subst bound r in if cpl' == cpl && r' == r then branch else (cpl',r')) branches in if rtntypopt' == rtntypopt && rtntypopt == rtntypopt' & rl' == rl && branches' == branches then raw else ACases (sty,rtntypopt',rl',branches') | ALetTuple (nal,(na,po),b,c) -> let po' = Option.smartmap (subst_aconstr subst bound) po and b' = subst_aconstr subst bound b and c' = subst_aconstr subst bound c in if po' == po && b' == b && c' == c then raw else ALetTuple (nal,(na,po'),b',c') | AIf (c,(na,po),b1,b2) -> let po' = Option.smartmap (subst_aconstr subst bound) po and b1' = subst_aconstr subst bound b1 and b2' = subst_aconstr subst bound b2 and c' = subst_aconstr subst bound c in if po' == po && b1' == b1 && b2' == b2 && c' == c then raw else AIf (c',(na,po'),b1',b2') | ARec (fk,idl,dll,tl,bl) -> let dll' = array_smartmap (list_smartmap (fun (na,oc,b as x) -> let oc' = Option.smartmap (subst_aconstr subst bound) oc in let b' = subst_aconstr subst bound b in if oc' == oc && b' == b then x else (na,oc',b'))) dll in let tl' = array_smartmap (subst_aconstr subst bound) tl in let bl' = array_smartmap (subst_aconstr subst bound) bl in if dll' == dll && tl' == tl && bl' == bl then raw else ARec (fk,idl,dll',tl',bl') | APatVar _ | ASort _ -> raw | AHole (Evd.ImplicitArg (ref,i,b)) -> let ref',t = subst_global subst ref in if ref' == ref then raw else AHole (Evd.InternalHole) | AHole (Evd.BinderType _ | Evd.QuestionMark _ | Evd.CasesType | Evd.InternalHole | Evd.TomatchTypeParameter _ | Evd.GoalEvar | Evd.ImpossibleCase | Evd.MatchingVar _) -> raw | ACast (r1,k) -> match k with CastConv (k, r2) -> let r1' = subst_aconstr subst bound r1 and r2' = subst_aconstr subst bound r2 in if r1' == r1 && r2' == r2 then raw else ACast (r1',CastConv (k,r2')) | CastCoerce -> let r1' = subst_aconstr subst bound r1 in if r1' == r1 then raw else ACast (r1',CastCoerce) let subst_interpretation subst (metas,pat) = let bound = List.map fst metas in (metas,subst_aconstr subst bound pat) (* Pattern-matching glob_constr and aconstr *) let abstract_return_type_context pi mklam tml rtno = Option.map (fun rtn -> let nal = List.flatten (List.map (fun (_,(na,t)) -> match t with Some x -> (pi x)@[na] | None -> [na]) tml) in List.fold_right mklam nal rtn) rtno let abstract_return_type_context_glob_constr = abstract_return_type_context (fun (_,_,_,nal) -> nal) (fun na c -> GLambda(dummy_loc,na,Explicit,GHole(dummy_loc,Evd.InternalHole),c)) let abstract_return_type_context_aconstr = abstract_return_type_context pi3 (fun na c -> ALambda(na,AHole Evd.InternalHole,c)) exception No_match let rec alpha_var id1 id2 = function | (i1,i2)::_ when i1=id1 -> i2 = id2 | (i1,i2)::_ when i2=id2 -> i1 = id1 | _::idl -> alpha_var id1 id2 idl | [] -> id1 = id2 let alpha_eq_val (x,y) = x = y let bind_env alp (sigma,sigmalist,sigmabinders as fullsigma) var v = try let vvar = List.assoc var sigma in if alpha_eq_val (v,vvar) then fullsigma else raise No_match with Not_found -> (* Check that no capture of binding variables occur *) if List.exists (fun (id,_) ->occur_glob_constr id v) alp then raise No_match; (* TODO: handle the case of multiple occs in different scopes *) ((var,v)::sigma,sigmalist,sigmabinders) let bind_binder (sigma,sigmalist,sigmabinders) x bl = (sigma,sigmalist,(x,List.rev bl)::sigmabinders) let match_fix_kind fk1 fk2 = match (fk1,fk2) with | GCoFix n1, GCoFix n2 -> n1 = n2 | GFix (nl1,n1), GFix (nl2,n2) -> n1 = n2 && array_for_all2 (fun (n1,_) (n2,_) -> n2 = None || n1 = n2) nl1 nl2 | _ -> false let match_opt f sigma t1 t2 = match (t1,t2) with | None, None -> sigma | Some t1, Some t2 -> f sigma t1 t2 | _ -> raise No_match let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with | (_,Name id2) when List.mem id2 (fst metas) -> let rhs = match na1 with | Name id1 -> GVar (dummy_loc,id1) | Anonymous -> GHole (dummy_loc,Evd.InternalHole) in alp, bind_env alp sigma id2 rhs | (Name id1,Name id2) -> (id1,id2)::alp,sigma | (Anonymous,Anonymous) -> alp,sigma | _ -> raise No_match let rec match_cases_pattern_binders metas acc pat1 pat2 = match (pat1,pat2) with | PatVar (_,na1), PatVar (_,na2) -> match_names metas acc na1 na2 | PatCstr (_,c1,patl1,na1), PatCstr (_,c2,patl2,na2) when c1 = c2 & List.length patl1 = List.length patl2 -> List.fold_left2 (match_cases_pattern_binders metas) (match_names metas acc na1 na2) patl1 patl2 | _ -> raise No_match let glue_letin_with_decls = true let rec match_iterated_binders islambda decls = function | GLambda (_,na,bk,t,b) when islambda -> match_iterated_binders islambda ((na,bk,None,t)::decls) b | GProd (_,(Name _ as na),bk,t,b) when not islambda -> match_iterated_binders islambda ((na,bk,None,t)::decls) b | GLetIn (loc,na,c,b) when glue_letin_with_decls -> match_iterated_binders islambda ((na,Explicit (*?*), Some c,GHole(loc,Evd.BinderType na))::decls) b | b -> (decls,b) let remove_sigma x (sigmavar,sigmalist,sigmabinders) = (List.remove_assoc x sigmavar,sigmalist,sigmabinders) let rec match_abinderlist_with_app match_fun metas sigma rest x iter termin = let rec aux sigma acc rest = try let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in let rest = List.assoc ldots_var (pi1 sigma) in let b = match List.assoc x (pi3 sigma) with [b] -> b | _ ->assert false in let sigma = remove_sigma x (remove_sigma ldots_var sigma) in aux sigma (b::acc) rest with No_match when acc <> [] -> acc, match_fun metas sigma rest termin in let bl,sigma = aux sigma [] rest in bind_binder sigma x bl let match_alist match_fun metas sigma rest x iter termin lassoc = let rec aux sigma acc rest = try let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in let rest = List.assoc ldots_var (pi1 sigma) in let t = List.assoc x (pi1 sigma) in let sigma = remove_sigma x (remove_sigma ldots_var sigma) in aux sigma (t::acc) rest with No_match when acc <> [] -> acc, match_fun metas sigma rest termin in let l,sigma = aux sigma [] rest in (pi1 sigma, (x,if lassoc then l else List.rev l)::pi2 sigma, pi3 sigma) let does_not_come_from_already_eta_expanded_var = (* This is hack to avoid looping on a rule with rhs of the form *) (* "?f (fun ?x => ?g)" since otherwise, matching "F H" expands in *) (* "F (fun x => H x)" and "H x" is recursively matched against the same *) (* rule, giving "H (fun x' => x x')" and so on. *) (* Ideally, we would need the type of the expression to know which of *) (* the arguments applied to it can be eta-expanded without looping. *) (* The following test is then an approximation of what can be done *) (* optimally (whether other looping situations can occur remains to be *) (* checked). *) function GVar _ -> false | _ -> true let rec match_ inner u alp (tmetas,blmetas as metas) sigma a1 a2 = match (a1,a2) with (* Matching notation variable *) | r1, AVar id2 when List.mem id2 tmetas -> bind_env alp sigma id2 r1 (* Matching recursive notations for terms *) | r1, AList (x,_,iter,termin,lassoc) -> match_alist (match_hd u alp) metas sigma r1 x iter termin lassoc (* Matching recursive notations for binders: ad hoc cases supporting let-in *) | GLambda (_,na1,bk,t1,b1), ABinderList (x,_,ALambda (Name id2,_,b2),termin)-> let (decls,b) = match_iterated_binders true [(na1,bk,None,t1)] b1 in (* TODO: address the possibility that termin is a Lambda itself *) match_in u alp metas (bind_binder sigma x decls) b termin | GProd (_,na1,bk,t1,b1), ABinderList (x,_,AProd (Name id2,_,b2),termin) when na1 <> Anonymous -> let (decls,b) = match_iterated_binders false [(na1,bk,None,t1)] b1 in (* TODO: address the possibility that termin is a Prod itself *) match_in u alp metas (bind_binder sigma x decls) b termin (* Matching recursive notations for binders: general case *) | r, ABinderList (x,_,iter,termin) -> match_abinderlist_with_app (match_hd u alp) metas sigma r x iter termin (* Matching individual binders as part of a recursive pattern *) | GLambda (_,na,bk,t,b1), ALambda (Name id,_,b2) when List.mem id blmetas -> match_in u alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2 | GProd (_,na,bk,t,b1), AProd (Name id,_,b2) when List.mem id blmetas & na <> Anonymous -> match_in u alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2 (* Matching compositionally *) | GVar (_,id1), AVar id2 when alpha_var id1 id2 alp -> sigma | GRef (_,r1), ARef r2 when (eq_gr r1 r2) -> sigma | GPatVar (_,(_,n1)), APatVar n2 when n1=n2 -> sigma | GApp (loc,f1,l1), AApp (f2,l2) -> let n1 = List.length l1 and n2 = List.length l2 in let f1,l1,f2,l2 = if n1 < n2 then let l21,l22 = list_chop (n2-n1) l2 in f1,l1, AApp (f2,l21), l22 else if n1 > n2 then let l11,l12 = list_chop (n1-n2) l1 in GApp (loc,f1,l11),l12, f2,l2 else f1,l1, f2, l2 in let may_use_eta = does_not_come_from_already_eta_expanded_var f1 in List.fold_left2 (match_ may_use_eta u alp metas) (match_in u alp metas sigma f1 f2) l1 l2 | GLambda (_,na1,_,t1,b1), ALambda (na2,t2,b2) -> match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 | GProd (_,na1,_,t1,b1), AProd (na2,t2,b2) -> match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 | GLetIn (_,na1,t1,b1), ALetIn (na2,t2,b2) -> match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 | GCases (_,sty1,rtno1,tml1,eqnl1), ACases (sty2,rtno2,tml2,eqnl2) when sty1 = sty2 & List.length tml1 = List.length tml2 & List.length eqnl1 = List.length eqnl2 -> let rtno1' = abstract_return_type_context_glob_constr tml1 rtno1 in let rtno2' = abstract_return_type_context_aconstr tml2 rtno2 in let sigma = try Option.fold_left2 (match_in u alp metas) sigma rtno1' rtno2' with Option.Heterogeneous -> raise No_match in let sigma = List.fold_left2 (fun s (tm1,_) (tm2,_) -> match_in u alp metas s tm1 tm2) sigma tml1 tml2 in List.fold_left2 (match_equations u alp metas) sigma eqnl1 eqnl2 | GLetTuple (_,nal1,(na1,to1),b1,c1), ALetTuple (nal2,(na2,to2),b2,c2) when List.length nal1 = List.length nal2 -> let sigma = match_opt (match_binders u alp metas na1 na2) sigma to1 to2 in let sigma = match_in u alp metas sigma b1 b2 in let (alp,sigma) = List.fold_left2 (match_names metas) (alp,sigma) nal1 nal2 in match_in u alp metas sigma c1 c2 | GIf (_,a1,(na1,to1),b1,c1), AIf (a2,(na2,to2),b2,c2) -> let sigma = match_opt (match_binders u alp metas na1 na2) sigma to1 to2 in List.fold_left2 (match_in u alp metas) sigma [a1;b1;c1] [a2;b2;c2] | GRec (_,fk1,idl1,dll1,tl1,bl1), ARec (fk2,idl2,dll2,tl2,bl2) when match_fix_kind fk1 fk2 & Array.length idl1 = Array.length idl2 & array_for_all2 (fun l1 l2 -> List.length l1 = List.length l2) dll1 dll2 -> let alp,sigma = array_fold_left2 (List.fold_left2 (fun (alp,sigma) (na1,_,oc1,b1) (na2,oc2,b2) -> let sigma = match_in u alp metas (match_opt (match_in u alp metas) sigma oc1 oc2) b1 b2 in match_names metas (alp,sigma) na1 na2)) (alp,sigma) dll1 dll2 in let sigma = array_fold_left2 (match_in u alp metas) sigma tl1 tl2 in let alp,sigma = array_fold_right2 (fun id1 id2 alsig -> match_names metas alsig (Name id1) (Name id2)) idl1 idl2 (alp,sigma) in array_fold_left2 (match_in u alp metas) sigma bl1 bl2 | GCast(_,c1, CastConv(_,t1)), ACast(c2, CastConv (_,t2)) -> match_in u alp metas (match_in u alp metas sigma c1 c2) t1 t2 | GCast(_,c1, CastCoerce), ACast(c2, CastCoerce) -> match_in u alp metas sigma c1 c2 | GSort (_,GType _), ASort (GType None) when not u -> sigma | GSort (_,s1), ASort s2 when s1 = s2 -> sigma | GPatVar _, AHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match | a, AHole _ -> sigma (* On the fly eta-expansion so as to use notations of the form "exists x, P x" for "ex P"; expects type not given because don't know otherwise how to ensure it corresponds to a well-typed eta-expansion; ensure at least one constructor is consumed to avoid looping *) | b1, ALambda (Name id,AHole _,b2) when inner -> let id' = Namegen.next_ident_away id (free_glob_vars b1) in match_in u alp metas (bind_binder sigma id [(Name id',Explicit,None,GHole(dummy_loc,Evd.BinderType (Name id')))]) (mkGApp dummy_loc b1 (GVar (dummy_loc,id'))) b2 | (GRec _ | GEvar _), _ | _,_ -> raise No_match and match_in u = match_ true u and match_hd u = match_ false u and match_binders u alp metas na1 na2 sigma b1 b2 = let (alp,sigma) = match_names metas (alp,sigma) na1 na2 in match_in u alp metas sigma b1 b2 and match_equations u alp metas sigma (_,_,patl1,rhs1) (patl2,rhs2) = (* patl1 and patl2 have the same length because they respectively correspond to some tml1 and tml2 that have the same length *) let (alp,sigma) = List.fold_left2 (match_cases_pattern_binders metas) (alp,sigma) patl1 patl2 in match_in u alp metas sigma rhs1 rhs2 let match_aconstr u c (metas,pat) = let vars = list_split_by (fun (_,(_,x)) -> x <> NtnTypeBinderList) metas in let vars = (List.map fst (fst vars), List.map fst (snd vars)) in let terms,termlists,binders = match_ false u [] vars ([],[],[]) c pat in (* Reorder canonically the substitution *) let find x = try List.assoc x terms with Not_found -> (* Happens for binders bound to Anonymous *) (* Find a better way to propagate Anonymous... *) GVar (dummy_loc,x) in List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders') -> match typ with | NtnTypeConstr -> ((find x, scl)::terms',termlists',binders') | NtnTypeConstrList -> (terms',(List.assoc x termlists,scl)::termlists',binders') | NtnTypeBinderList -> (terms',termlists',(List.assoc x binders,scl)::binders')) metas ([],[],[]) (* Matching cases pattern *) let bind_env_cases_pattern (sigma,sigmalist,x as fullsigma) var v = try let vvar = List.assoc var sigma in if v=vvar then fullsigma else raise No_match with Not_found -> (* TODO: handle the case of multiple occs in different scopes *) (var,v)::sigma,sigmalist,x let rec match_cases_pattern metas sigma a1 a2 = match (a1,a2) with | r1, AVar id2 when List.mem id2 metas -> bind_env_cases_pattern sigma id2 r1 | PatVar (_,Anonymous), AHole _ -> sigma | PatCstr (loc,(ind,_ as r1),[],_), ARef (ConstructRef r2) when r1 = r2 -> sigma | PatCstr (loc,(ind,_ as r1),args1,_), AApp (ARef (ConstructRef r2),l2) when r1 = r2 -> let nparams = Inductive.inductive_params (Global.lookup_inductive ind) in if List.length l2 <> nparams + List.length args1 then (* TODO: revert partially applied notations of the form "Notation P := (@pair)." *) raise No_match else let (p2,args2) = list_chop nparams l2 in (* All parameters must be _ *) List.iter (function AHole _ -> () | _ -> raise No_match) p2; List.fold_left2 (match_cases_pattern metas) sigma args1 args2 | r1, AList (x,_,iter,termin,lassoc) -> match_alist (fun (metas,_) -> match_cases_pattern metas) (metas,[]) (pi1 sigma,pi2 sigma,()) r1 x iter termin lassoc | _ -> raise No_match let match_aconstr_cases_pattern c (metas,pat) = let vars = List.map fst metas in let terms,termlists,() = match_cases_pattern vars ([],[],()) c pat in (* Reorder canonically the substitution *) List.fold_right (fun (x,(scl,typ)) (terms',termlists') -> match typ with | NtnTypeConstr -> ((List.assoc x terms, scl)::terms',termlists') | NtnTypeConstrList -> (terms',(List.assoc x termlists,scl)::termlists') | NtnTypeBinderList -> assert false) metas ([],[]) (**********************************************************************) (*s Concrete syntax for terms *) type notation = string type explicitation = ExplByPos of int * identifier option | ExplByName of identifier type binder_kind = Default of binding_kind | Generalized of binding_kind * binding_kind * bool type abstraction_kind = AbsLambda | AbsPi type proj_flag = int option (* [Some n] = proj of the n-th visible argument *) type prim_token = Numeral of Bigint.bigint | String of string type cases_pattern_expr = | CPatAlias of loc * cases_pattern_expr * identifier | CPatCstr of loc * reference * cases_pattern_expr list | CPatCstrExpl of loc * reference * cases_pattern_expr list | CPatAtom of loc * reference option | CPatOr of loc * cases_pattern_expr list | CPatNotation of loc * notation * cases_pattern_notation_substitution | CPatPrim of loc * prim_token | CPatRecord of Util.loc * (reference * cases_pattern_expr) list | CPatDelimiters of loc * string * cases_pattern_expr and cases_pattern_notation_substitution = cases_pattern_expr list * (** for constr subterms *) cases_pattern_expr list list (** for recursive notations *) type constr_expr = | CRef of reference | CFix of loc * identifier located * fix_expr list | CCoFix of loc * identifier located * cofix_expr list | CArrow of loc * constr_expr * constr_expr | CProdN of loc * (name located list * binder_kind * constr_expr) list * constr_expr | CLambdaN of loc * (name located list * binder_kind * constr_expr) list * constr_expr | CLetIn of loc * name located * constr_expr * constr_expr | CAppExpl of loc * (proj_flag * reference) * constr_expr list | CApp of loc * (proj_flag * constr_expr) * (constr_expr * explicitation located option) list | CRecord of loc * constr_expr option * (reference * constr_expr) list | CCases of loc * case_style * constr_expr option * (constr_expr * (name located option * constr_expr option)) list * (loc * cases_pattern_expr list located list * constr_expr) list | CLetTuple of loc * name located list * (name located option * constr_expr option) * constr_expr * constr_expr | CIf of loc * constr_expr * (name located option * constr_expr option) * constr_expr * constr_expr | CHole of loc * Evd.hole_kind option | CPatVar of loc * (bool * patvar) | CEvar of loc * existential_key * constr_expr list option | CSort of loc * glob_sort | CCast of loc * constr_expr * constr_expr cast_type | CNotation of loc * notation * constr_notation_substitution | CGeneralization of loc * binding_kind * abstraction_kind option * constr_expr | CPrim of loc * prim_token | CDelimiters of loc * string * constr_expr and fix_expr = identifier located * (identifier located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr and cofix_expr = identifier located * local_binder list * constr_expr * constr_expr and recursion_order_expr = | CStructRec | CWfRec of constr_expr | CMeasureRec of constr_expr * constr_expr option (* measure, relation *) and local_binder = | LocalRawDef of name located * constr_expr | LocalRawAssum of name located list * binder_kind * constr_expr and constr_notation_substitution = constr_expr list * (* for constr subterms *) constr_expr list list * (* for recursive notations *) local_binder list list (* for binders subexpressions *) type typeclass_constraint = name located * binding_kind * constr_expr and typeclass_context = typeclass_constraint list type constr_pattern_expr = constr_expr (***********************) (* For binders parsing *) let default_binder_kind = Default Explicit let names_of_local_assums bl = List.flatten (List.map (function LocalRawAssum(l,_,_)->l|_->[]) bl) let names_of_local_binders bl = List.flatten (List.map (function LocalRawAssum(l,_,_)->l|LocalRawDef(l,_)->[l]) bl) (**********************************************************************) (* Miscellaneous *) let error_invalid_pattern_notation loc = user_err_loc (loc,"",str "Invalid notation for pattern.") (**********************************************************************) (* Functions on constr_expr *) let constr_loc = function | CRef (Ident (loc,_)) -> loc | CRef (Qualid (loc,_)) -> loc | CFix (loc,_,_) -> loc | CCoFix (loc,_,_) -> loc | CArrow (loc,_,_) -> loc | CProdN (loc,_,_) -> loc | CLambdaN (loc,_,_) -> loc | CLetIn (loc,_,_,_) -> loc | CAppExpl (loc,_,_) -> loc | CApp (loc,_,_) -> loc | CRecord (loc,_,_) -> loc | CCases (loc,_,_,_,_) -> loc | CLetTuple (loc,_,_,_,_) -> loc | CIf (loc,_,_,_,_) -> loc | CHole (loc, _) -> loc | CPatVar (loc,_) -> loc | CEvar (loc,_,_) -> loc | CSort (loc,_) -> loc | CCast (loc,_,_) -> loc | CNotation (loc,_,_) -> loc | CGeneralization (loc,_,_,_) -> loc | CPrim (loc,_) -> loc | CDelimiters (loc,_,_) -> loc let cases_pattern_expr_loc = function | CPatAlias (loc,_,_) -> loc | CPatCstr (loc,_,_) -> loc | CPatCstrExpl (loc,_,_) -> loc | CPatAtom (loc,_) -> loc | CPatOr (loc,_) -> loc | CPatNotation (loc,_,_) -> loc | CPatRecord (loc, _) -> loc | CPatPrim (loc,_) -> loc | CPatDelimiters (loc,_,_) -> loc let local_binder_loc = function | LocalRawAssum ((loc,_)::_,_,t) | LocalRawDef ((loc,_),t) -> join_loc loc (constr_loc t) | LocalRawAssum ([],_,_) -> assert false let local_binders_loc bll = if bll = [] then dummy_loc else join_loc (local_binder_loc (List.hd bll)) (local_binder_loc (list_last bll)) let ids_of_cases_indtype = let add_var ids = function CRef (Ident (_,id)) -> id::ids | _ -> ids in let rec vars_of = function (* We deal only with the regular cases *) | CApp (_,_,l) -> List.fold_left add_var [] (List.map fst l) | CNotation (_,_,(l,[],[])) (* assume the ntn is applicative and does not instantiate the head !! *) | CAppExpl (_,_,l) -> List.fold_left add_var [] l | CDelimiters(_,_,c) -> vars_of c | _ -> [] in vars_of let ids_of_cases_tomatch tms = List.fold_right (fun (_,(ona,indnal)) l -> Option.fold_right (fun t -> (@) (ids_of_cases_indtype t)) indnal (Option.fold_right (down_located name_cons) ona l)) tms [] let is_constructor id = try ignore (Nametab.locate_extended (qualid_of_ident id)); true with Not_found -> true let rec cases_pattern_fold_names f a = function | CPatRecord (_, l) -> List.fold_left (fun acc (r, cp) -> cases_pattern_fold_names f acc cp) a l | CPatAlias (_,pat,id) -> f id a | CPatCstr (_,_,patl) | CPatCstrExpl (_,_,patl) | CPatOr (_,patl) -> List.fold_left (cases_pattern_fold_names f) a patl | CPatNotation (_,_,(patl,patll)) -> List.fold_left (cases_pattern_fold_names f) a (patl@List.flatten patll) | CPatDelimiters (_,_,pat) -> cases_pattern_fold_names f a pat | CPatAtom (_,Some (Ident (_,id))) when not (is_constructor id) -> f id a | CPatPrim _ | CPatAtom _ -> a let ids_of_pattern_list = List.fold_left (located_fold_left (List.fold_left (cases_pattern_fold_names Idset.add))) Idset.empty let rec fold_constr_expr_binders g f n acc b = function | (nal,bk,t)::l -> let nal = snd (List.split nal) in let n' = List.fold_right (name_fold g) nal n in f n (fold_constr_expr_binders g f n' acc b l) t | [] -> f n acc b let rec fold_local_binders g f n acc b = function | LocalRawAssum (nal,bk,t)::l -> let nal = snd (List.split nal) in let n' = List.fold_right (name_fold g) nal n in f n (fold_local_binders g f n' acc b l) t | LocalRawDef ((_,na),t)::l -> f n (fold_local_binders g f (name_fold g na n) acc b l) t | [] -> f n acc b let fold_constr_expr_with_binders g f n acc = function | CArrow (loc,a,b) -> f n (f n acc a) b | CAppExpl (loc,(_,_),l) -> List.fold_left (f n) acc l | CApp (loc,(_,t),l) -> List.fold_left (f n) (f n acc t) (List.map fst l) | CProdN (_,l,b) | CLambdaN (_,l,b) -> fold_constr_expr_binders g f n acc b l | CLetIn (_,na,a,b) -> fold_constr_expr_binders g f n acc b [[na],default_binder_kind,a] | CCast (loc,a,CastConv(_,b)) -> f n (f n acc a) b | CCast (loc,a,CastCoerce) -> f n acc a | CNotation (_,_,(l,ll,bll)) -> (* The following is an approximation: we don't know exactly if an ident is binding nor to which subterms bindings apply *) let acc = List.fold_left (f n) acc (l@List.flatten ll) in List.fold_left (fun acc bl -> fold_local_binders g f n acc (CHole (dummy_loc,None)) bl) acc bll | CGeneralization (_,_,_,c) -> f n acc c | CDelimiters (loc,_,a) -> f n acc a | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CRef _ -> acc | CRecord (loc,_,l) -> List.fold_left (fun acc (id, c) -> f n acc c) acc l | CCases (loc,sty,rtnpo,al,bl) -> let ids = ids_of_cases_tomatch al in let acc = Option.fold_left (f (List.fold_right g ids n)) acc rtnpo in let acc = List.fold_left (f n) acc (List.map fst al) in List.fold_right (fun (loc,patl,rhs) acc -> let ids = ids_of_pattern_list patl in f (Idset.fold g ids n) acc rhs) bl acc | CLetTuple (loc,nal,(ona,po),b,c) -> let n' = List.fold_right (down_located (name_fold g)) nal n in f (Option.fold_right (down_located (name_fold g)) ona n') (f n acc b) c | CIf (_,c,(ona,po),b1,b2) -> let acc = f n (f n (f n acc b1) b2) c in Option.fold_left (f (Option.fold_right (down_located (name_fold g)) ona n)) acc po | CFix (loc,_,l) -> let n' = List.fold_right (fun ((_,id),_,_,_,_) -> g id) l n in List.fold_right (fun (_,(_,o),lb,t,c) acc -> fold_local_binders g f n' (fold_local_binders g f n acc t lb) c lb) l acc | CCoFix (loc,_,_) -> Pp.msg_warn "Capture check in multiple binders not done"; acc let free_vars_of_constr_expr c = let rec aux bdvars l = function | CRef (Ident (_,id)) -> if List.mem id bdvars then l else Idset.add id l | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c in aux [] Idset.empty c let occur_var_constr_expr id c = Idset.mem id (free_vars_of_constr_expr c) let mkIdentC id = CRef (Ident (dummy_loc, id)) let mkRefC r = CRef r let mkCastC (a,k) = CCast (dummy_loc,a,k) let mkLambdaC (idl,bk,a,b) = CLambdaN (dummy_loc,[idl,bk,a],b) let mkLetInC (id,a,b) = CLetIn (dummy_loc,id,a,b) let mkProdC (idl,bk,a,b) = CProdN (dummy_loc,[idl,bk,a],b) let mkAppC (f,l) = let l = List.map (fun x -> (x,None)) l in match f with | CApp (_,g,l') -> CApp (dummy_loc, g, l' @ l) | _ -> CApp (dummy_loc, (None, f), l) let rec mkCProdN loc bll c = match bll with | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll -> CProdN (loc,[idl,bk,t],mkCProdN (join_loc loc1 loc) bll c) | LocalRawDef ((loc1,_) as id,b) :: bll -> CLetIn (loc,id,b,mkCProdN (join_loc loc1 loc) bll c) | [] -> c | LocalRawAssum ([],_,_) :: bll -> mkCProdN loc bll c let rec mkCLambdaN loc bll c = match bll with | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll -> CLambdaN (loc,[idl,bk,t],mkCLambdaN (join_loc loc1 loc) bll c) | LocalRawDef ((loc1,_) as id,b) :: bll -> CLetIn (loc,id,b,mkCLambdaN (join_loc loc1 loc) bll c) | [] -> c | LocalRawAssum ([],_,_) :: bll -> mkCLambdaN loc bll c let rec abstract_constr_expr c = function | [] -> c | LocalRawDef (x,b)::bl -> mkLetInC(x,b,abstract_constr_expr c bl) | LocalRawAssum (idl,bk,t)::bl -> List.fold_right (fun x b -> mkLambdaC([x],bk,t,b)) idl (abstract_constr_expr c bl) let rec prod_constr_expr c = function | [] -> c | LocalRawDef (x,b)::bl -> mkLetInC(x,b,prod_constr_expr c bl) | LocalRawAssum (idl,bk,t)::bl -> List.fold_right (fun x b -> mkProdC([x],bk,t,b)) idl (prod_constr_expr c bl) let coerce_reference_to_id = function | Ident (_,id) -> id | Qualid (loc,_) -> user_err_loc (loc, "coerce_reference_to_id", str "This expression should be a simple identifier.") let coerce_to_id = function | CRef (Ident (loc,id)) -> (loc,id) | a -> user_err_loc (constr_loc a,"coerce_to_id", str "This expression should be a simple identifier.") let coerce_to_name = function | CRef (Ident (loc,id)) -> (loc,Name id) | CHole (loc,_) -> (loc,Anonymous) | a -> user_err_loc (constr_loc a,"coerce_to_name", str "This expression should be a name.") (* Interpret the index of a recursion order annotation *) let split_at_annot bl na = let names = List.map snd (names_of_local_assums bl) in match na with | None -> if names = [] then error "A fixpoint needs at least one parameter." else [], bl | Some (loc, id) -> let rec aux acc = function | LocalRawAssum (bls, k, t) as x :: rest -> let l, r = list_split_when (fun (loc, na) -> na = Name id) bls in if r = [] then aux (x :: acc) rest else (List.rev (if l = [] then acc else LocalRawAssum (l, k, t) :: acc), LocalRawAssum (r, k, t) :: rest) | LocalRawDef _ as x :: rest -> aux (x :: acc) rest | [] -> user_err_loc(loc,"", str "No parameter named " ++ Nameops.pr_id id ++ str".") in aux [] bl (* Used in correctness and interface *) let map_binder g e nal = List.fold_right (down_located (name_fold g)) nal e let map_binders f g e bl = (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) let h (e,bl) (nal,bk,t) = (map_binder g e nal,(nal,bk,f e t)::bl) in let (e,rbl) = List.fold_left h (e,[]) bl in (e, List.rev rbl) let map_local_binders f g e bl = (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) let h (e,bl) = function LocalRawAssum(nal,k,ty) -> (map_binder g e nal, LocalRawAssum(nal,k,f e ty)::bl) | LocalRawDef((loc,na),ty) -> (name_fold g na e, LocalRawDef((loc,na),f e ty)::bl) in let (e,rbl) = List.fold_left h (e,[]) bl in (e, List.rev rbl) let map_constr_expr_with_binders g f e = function | CArrow (loc,a,b) -> CArrow (loc,f e a,f e b) | CAppExpl (loc,r,l) -> CAppExpl (loc,r,List.map (f e) l) | CApp (loc,(p,a),l) -> CApp (loc,(p,f e a),List.map (fun (a,i) -> (f e a,i)) l) | CProdN (loc,bl,b) -> let (e,bl) = map_binders f g e bl in CProdN (loc,bl,f e b) | CLambdaN (loc,bl,b) -> let (e,bl) = map_binders f g e bl in CLambdaN (loc,bl,f e b) | CLetIn (loc,na,a,b) -> CLetIn (loc,na,f e a,f (name_fold g (snd na) e) b) | CCast (loc,a,CastConv (k,b)) -> CCast (loc,f e a,CastConv(k, f e b)) | CCast (loc,a,CastCoerce) -> CCast (loc,f e a,CastCoerce) | CNotation (loc,n,(l,ll,bll)) -> (* This is an approximation because we don't know what binds what *) CNotation (loc,n,(List.map (f e) l,List.map (List.map (f e)) ll, List.map (fun bl -> snd (map_local_binders f g e bl)) bll)) | CGeneralization (loc,b,a,c) -> CGeneralization (loc,b,a,f e c) | CDelimiters (loc,s,a) -> CDelimiters (loc,s,f e a) | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CRef _ as x -> x | CRecord (loc,p,l) -> CRecord (loc,p,List.map (fun (id, c) -> (id, f e c)) l) | CCases (loc,sty,rtnpo,a,bl) -> (* TODO: apply g on the binding variables in pat... *) let bl = List.map (fun (loc,pat,rhs) -> (loc,pat,f e rhs)) bl in let ids = ids_of_cases_tomatch a in let po = Option.map (f (List.fold_right g ids e)) rtnpo in CCases (loc, sty, po, List.map (fun (tm,x) -> (f e tm,x)) a,bl) | CLetTuple (loc,nal,(ona,po),b,c) -> let e' = List.fold_right (down_located (name_fold g)) nal e in let e'' = Option.fold_right (down_located (name_fold g)) ona e in CLetTuple (loc,nal,(ona,Option.map (f e'') po),f e b,f e' c) | CIf (loc,c,(ona,po),b1,b2) -> let e' = Option.fold_right (down_located (name_fold g)) ona e in CIf (loc,f e c,(ona,Option.map (f e') po),f e b1,f e b2) | CFix (loc,id,dl) -> CFix (loc,id,List.map (fun (id,n,bl,t,d) -> let (e',bl') = map_local_binders f g e bl in let t' = f e' t in (* Note: fix names should be inserted before the arguments... *) let e'' = List.fold_left (fun e ((_,id),_,_,_,_) -> g id e) e' dl in let d' = f e'' d in (id,n,bl',t',d')) dl) | CCoFix (loc,id,dl) -> CCoFix (loc,id,List.map (fun (id,bl,t,d) -> let (e',bl') = map_local_binders f g e bl in let t' = f e' t in let e'' = List.fold_left (fun e ((_,id),_,_,_) -> g id e) e' dl in let d' = f e'' d in (id,bl',t',d')) dl) (* Used in constrintern *) let rec replace_vars_constr_expr l = function | CRef (Ident (loc,id)) as x -> (try CRef (Ident (loc,List.assoc id l)) with Not_found -> x) | c -> map_constr_expr_with_binders List.remove_assoc replace_vars_constr_expr l c (**********************************************************************) (* Concrete syntax for modules and modules types *) type with_declaration_ast = | CWith_Module of identifier list located * qualid located | CWith_Definition of identifier list located * constr_expr type module_ast = | CMident of qualid located | CMapply of loc * module_ast * module_ast | CMwith of loc * module_ast * with_declaration_ast (* Returns the ranges of locs of the notation that are not occupied by args *) (* and which are then occupied by proper symbols of the notation (or spaces) *) let locs_of_notation loc locs ntn = let (bl,el) = Util.unloc loc in let locs = List.map Util.unloc locs in let rec aux pos = function | [] -> if pos = el then [] else [(pos,el-1)] | (ba,ea)::l ->if pos = ba then aux ea l else (pos,ba-1)::aux ea l in aux bl (Sort.list (fun l1 l2 -> fst l1 < fst l2) locs) let ntn_loc loc (args,argslist,binderslist) = locs_of_notation loc (List.map constr_loc (args@List.flatten argslist)@ List.map local_binders_loc binderslist) let patntn_loc loc (args,argslist) = locs_of_notation loc (List.map cases_pattern_expr_loc (args@List.flatten argslist)) coq-8.4pl4/interp/notation.ml0000644000175000017500000006657712326224777015346 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* level * dir_path *) let notation_level_map = ref Gmap.empty (* Scopes table: scope_name -> symbol_interpretation *) let scope_map = ref Gmap.empty (* Delimiter table : delimiter -> scope_name *) let delimiters_map = ref Gmap.empty let empty_scope = { notations = Gmap.empty; delimiters = None } let default_scope = "" (* empty name, not available from outside *) let type_scope = "type_scope" (* special scope used for interpreting types *) let init_scope_map () = scope_map := Gmap.add default_scope empty_scope !scope_map; scope_map := Gmap.add type_scope empty_scope !scope_map (**********************************************************************) (* Operations on scopes *) let declare_scope scope = try let _ = Gmap.find scope !scope_map in () with Not_found -> (* Flags.if_warn message ("Creating scope "^scope);*) scope_map := Gmap.add scope empty_scope !scope_map let error_unknown_scope sc = error ("Scope "^sc^" is not declared.") let find_scope scope = try Gmap.find scope !scope_map with Not_found -> error_unknown_scope scope let check_scope sc = let _ = find_scope sc in () (* [sc] might be here a [scope_name] or a [delimiter] (now allowed after Open Scope) *) let normalize_scope sc = try let _ = Gmap.find sc !scope_map in sc with Not_found -> try let sc = Gmap.find sc !delimiters_map in let _ = Gmap.find sc !scope_map in sc with Not_found -> error_unknown_scope sc (**********************************************************************) (* The global stack of scopes *) type scope_elem = Scope of scope_name | SingleNotation of string type scopes = scope_elem list let scope_stack = ref [] let current_scopes () = !scope_stack let scope_is_open_in_scopes sc l = List.mem (Scope sc) l let scope_is_open sc = scope_is_open_in_scopes sc (!scope_stack) (* TODO: push nat_scope, z_scope, ... in scopes summary *) (* Exportation of scopes *) let open_scope i (_,(local,op,sc)) = if i=1 then let sc = match sc with | Scope sc -> Scope (normalize_scope sc) | _ -> sc in scope_stack := if op then sc :: !scope_stack else list_except sc !scope_stack let cache_scope o = open_scope 1 o let subst_scope (subst,sc) = sc open Libobject let discharge_scope (_,(local,_,_ as o)) = if local then None else Some o let classify_scope (local,_,_ as o) = if local then Dispose else Substitute o let inScope : bool * bool * scope_elem -> obj = declare_object {(default_object "SCOPE") with cache_function = cache_scope; open_function = open_scope; subst_function = subst_scope; discharge_function = discharge_scope; classify_function = classify_scope } let open_close_scope (local,opening,sc) = Lib.add_anonymous_leaf (inScope (local,opening,Scope sc)) let empty_scope_stack = [] let push_scope sc scopes = Scope sc :: scopes let push_scopes = List.fold_right push_scope type local_scopes = tmp_scope_name option * scope_name list let make_current_scopes (tmp_scope,scopes) = Option.fold_right push_scope tmp_scope (push_scopes scopes !scope_stack) (**********************************************************************) (* Delimiters *) let declare_delimiters scope key = let sc = find_scope scope in let newsc = { sc with delimiters = Some key } in begin match sc.delimiters with | None -> scope_map := Gmap.add scope newsc !scope_map | Some oldkey when oldkey = key -> () | Some oldkey -> Flags.if_warn msg_warning (str ("Overwriting previous delimiting key "^oldkey^" in scope "^scope)); scope_map := Gmap.add scope newsc !scope_map end; try let oldscope = Gmap.find key !delimiters_map in if oldscope = scope then () else begin Flags.if_warn msg_warning (str ("Hiding binding of key "^key^" to "^oldscope)); delimiters_map := Gmap.add key scope !delimiters_map end with Not_found -> delimiters_map := Gmap.add key scope !delimiters_map let find_delimiters_scope loc key = try Gmap.find key !delimiters_map with Not_found -> user_err_loc (loc, "find_delimiters", str ("Unknown scope delimiting key "^key^".")) (* Uninterpretation tables *) type interp_rule = | NotationRule of scope_name option * notation | SynDefRule of kernel_name (* We define keys for glob_constr and aconstr to split the syntax entries according to the key of the pattern (adapted from Chet Murthy by HH) *) type key = | RefKey of global_reference | Oth (* Scopes table : interpretation -> scope_name *) let notations_key_table = ref Gmapl.empty let prim_token_key_table = Hashtbl.create 7 let glob_prim_constr_key = function | GApp (_,GRef (_,ref),_) | GRef (_,ref) -> RefKey (canonical_gr ref) | _ -> Oth let glob_constr_keys = function | GApp (_,GRef (_,ref),_) -> [RefKey (canonical_gr ref); Oth] | GRef (_,ref) -> [RefKey (canonical_gr ref)] | _ -> [Oth] let cases_pattern_key = function | PatCstr (_,ref,_,_) -> RefKey (canonical_gr (ConstructRef ref)) | _ -> Oth let aconstr_key = function (* Rem: AApp(ARef ref,[]) stands for @ref *) | AApp (ARef ref,args) -> RefKey(canonical_gr ref), Some (List.length args) | AList (_,_,AApp (ARef ref,args),_,_) | ABinderList (_,_,AApp (ARef ref,args),_) -> RefKey (canonical_gr ref), Some (List.length args) | ARef ref -> RefKey(canonical_gr ref), None | AApp (_,args) -> Oth, Some (List.length args) | _ -> Oth, None (**********************************************************************) (* Interpreting numbers (not in summary because functional objects) *) type required_module = full_path * string list type 'a prim_token_interpreter = loc -> 'a -> glob_constr type cases_pattern_status = bool (* true = use prim token in patterns *) type 'a prim_token_uninterpreter = glob_constr list * (glob_constr -> 'a option) * cases_pattern_status type internal_prim_token_interpreter = loc -> prim_token -> required_module * (unit -> glob_constr) let prim_token_interpreter_tab = (Hashtbl.create 7 : (scope_name, internal_prim_token_interpreter) Hashtbl.t) let add_prim_token_interpreter sc interp = try let cont = Hashtbl.find prim_token_interpreter_tab sc in Hashtbl.replace prim_token_interpreter_tab sc (interp cont) with Not_found -> let cont = (fun _loc _p -> raise Not_found) in Hashtbl.add prim_token_interpreter_tab sc (interp cont) let declare_prim_token_interpreter sc interp (patl,uninterp,b) = declare_scope sc; add_prim_token_interpreter sc interp; List.iter (fun pat -> Hashtbl.add prim_token_key_table (glob_prim_constr_key pat) (sc,uninterp,b)) patl let mkNumeral n = Numeral n let mkString s = String s let delay dir int loc x = (dir, (fun () -> int loc x)) let declare_numeral_interpreter sc dir interp (patl,uninterp,inpat) = declare_prim_token_interpreter sc (fun cont loc -> function Numeral n-> delay dir interp loc n | p -> cont loc p) (patl, (fun r -> Option.map mkNumeral (uninterp r)), inpat) let declare_string_interpreter sc dir interp (patl,uninterp,inpat) = declare_prim_token_interpreter sc (fun cont loc -> function String s -> delay dir interp loc s | p -> cont loc p) (patl, (fun r -> Option.map mkString (uninterp r)), inpat) let check_required_module loc sc (sp,d) = try let _ = Nametab.global_of_path sp in () with Not_found -> user_err_loc (loc,"prim_token_interpreter", str ("Cannot interpret in "^sc^" without requiring first module " ^(list_last d)^".")) (* Look if some notation or numeral printer in [scope] can be used in the scope stack [scopes], and if yes, using delimiters or not *) let find_with_delimiters = function | None -> None | Some scope -> match (Gmap.find scope !scope_map).delimiters with | Some key -> Some (Some scope, Some key) | None -> None let rec find_without_delimiters find (ntn_scope,ntn) = function | Scope scope :: scopes -> (* Is the expected ntn/numpr attached to the most recently open scope? *) if Some scope = ntn_scope then Some (None,None) else (* If the most recently open scope has a notation/numeral printer but not the expected one then we need delimiters *) if find scope then find_with_delimiters ntn_scope else find_without_delimiters find (ntn_scope,ntn) scopes | SingleNotation ntn' :: scopes -> if ntn_scope = None & ntn = Some ntn' then Some (None,None) else find_without_delimiters find (ntn_scope,ntn) scopes | [] -> (* Can we switch to [scope]? Yes if it has defined delimiters *) find_with_delimiters ntn_scope (* Uninterpreted notation levels *) let declare_notation_level ntn level = if Gmap.mem ntn !notation_level_map then anomaly ("Notation "^ntn^" is already assigned a level"); notation_level_map := Gmap.add ntn level !notation_level_map let level_of_notation ntn = Gmap.find ntn !notation_level_map (* The mapping between notations and their interpretation *) let declare_notation_interpretation ntn scopt pat df = let scope = match scopt with Some s -> s | None -> default_scope in let sc = find_scope scope in if Gmap.mem ntn sc.notations then Flags.if_warn msg_warning (str ("Notation "^ntn^" was already used"^ (if scopt = None then "" else " in scope "^scope))); let sc = { sc with notations = Gmap.add ntn (pat,df) sc.notations } in scope_map := Gmap.add scope sc !scope_map; if scopt = None then scope_stack := SingleNotation ntn :: !scope_stack let declare_uninterpretation rule (metas,c as pat) = let (key,n) = aconstr_key c in notations_key_table := Gmapl.add key (rule,pat,n) !notations_key_table let rec find_interpretation ntn find = function | [] -> raise Not_found | Scope scope :: scopes -> (try let (pat,df) = find scope in pat,(df,Some scope) with Not_found -> find_interpretation ntn find scopes) | SingleNotation ntn'::scopes when ntn' = ntn -> (try let (pat,df) = find default_scope in pat,(df,None) with Not_found -> (* e.g. because single notation only for constr, not cases_pattern *) find_interpretation ntn find scopes) | SingleNotation _::scopes -> find_interpretation ntn find scopes let find_notation ntn sc = Gmap.find ntn (find_scope sc).notations let notation_of_prim_token = function | Numeral n when is_pos_or_zero n -> to_string n | Numeral n -> "- "^(to_string (neg n)) | String _ -> raise Not_found let find_prim_token g loc p sc = (* Try for a user-defined numerical notation *) try let (_,c),df = find_notation (notation_of_prim_token p) sc in g (glob_constr_of_aconstr loc c),df with Not_found -> (* Try for a primitive numerical notation *) let (spdir,interp) = Hashtbl.find prim_token_interpreter_tab sc loc p in check_required_module loc sc spdir; g (interp ()), ((dirpath (fst spdir),empty_dirpath),"") let interp_prim_token_gen g loc p local_scopes = let scopes = make_current_scopes local_scopes in let p_as_ntn = try notation_of_prim_token p with Not_found -> "" in try find_interpretation p_as_ntn (find_prim_token g loc p) scopes with Not_found -> user_err_loc (loc,"interp_prim_token", (match p with | Numeral n -> str "No interpretation for numeral " ++ str (to_string n) | String s -> str "No interpretation for string " ++ qs s) ++ str ".") let interp_prim_token = interp_prim_token_gen (fun x -> x) let interp_prim_token_cases_pattern loc p name = interp_prim_token_gen (cases_pattern_of_glob_constr name) loc p let rec interp_notation loc ntn local_scopes = let scopes = make_current_scopes local_scopes in try find_interpretation ntn (find_notation ntn) scopes with Not_found -> user_err_loc (loc,"",str ("Unknown interpretation for notation \""^ntn^"\".")) let isGApp = function GApp _ -> true | _ -> false let uninterp_notations c = list_map_append (fun key -> Gmapl.find key !notations_key_table) (glob_constr_keys c) let uninterp_cases_pattern_notations c = Gmapl.find (cases_pattern_key c) !notations_key_table let availability_of_notation (ntn_scope,ntn) scopes = let f scope = Gmap.mem ntn (Gmap.find scope !scope_map).notations in find_without_delimiters f (ntn_scope,Some ntn) (make_current_scopes scopes) let uninterp_prim_token c = try let (sc,numpr,_) = Hashtbl.find prim_token_key_table (glob_prim_constr_key c) in match numpr c with | None -> raise No_match | Some n -> (sc,n) with Not_found -> raise No_match let uninterp_prim_token_cases_pattern c = try let k = cases_pattern_key c in let (sc,numpr,b) = Hashtbl.find prim_token_key_table k in if not b then raise No_match; let na,c = glob_constr_of_closed_cases_pattern c in match numpr c with | None -> raise No_match | Some n -> (na,sc,n) with Not_found -> raise No_match let availability_of_prim_token n printer_scope local_scopes = let f scope = try ignore (Hashtbl.find prim_token_interpreter_tab scope dummy_loc n); true with Not_found -> false in let scopes = make_current_scopes local_scopes in Option.map snd (find_without_delimiters f (Some printer_scope,None) scopes) (* Miscellaneous *) let exists_notation_in_scope scopt ntn r = let scope = match scopt with Some s -> s | None -> default_scope in try let sc = Gmap.find scope !scope_map in let (r',_) = Gmap.find ntn sc.notations in r' = r with Not_found -> false let isAVar_or_AHole = function AVar _ | AHole _ -> true | _ -> false (**********************************************************************) (* Mapping classes to scopes *) open Classops let class_scope_map = ref (Gmap.empty : (cl_typ,scope_name) Gmap.t) let _ = class_scope_map := Gmap.add CL_SORT "type_scope" Gmap.empty let declare_class_scope sc cl = class_scope_map := Gmap.add cl sc !class_scope_map let find_class_scope cl = Gmap.find cl !class_scope_map let find_class_scope_opt = function | None -> None | Some cl -> try Some (find_class_scope cl) with Not_found -> None let find_class t = fst (find_class_type Evd.empty t) (**********************************************************************) (* Special scopes associated to arguments of a global reference *) let rec compute_arguments_classes t = match kind_of_term (Reductionops.whd_betaiotazeta Evd.empty t) with | Prod (_,t,u) -> let cl = try Some (find_class t) with Not_found -> None in cl :: compute_arguments_classes u | _ -> [] let compute_arguments_scope_full t = let cls = compute_arguments_classes t in let scs = List.map find_class_scope_opt cls in scs, cls let compute_arguments_scope t = fst (compute_arguments_scope_full t) (** When merging scope list, we give priority to the first one (computed by substitution), using the second one (user given or earlier automatic) as fallback *) let rec merge_scope sc1 sc2 = match sc1, sc2 with | [], _ -> sc2 | _, [] -> sc1 | Some sc :: sc1, _ :: sc2 -> Some sc :: merge_scope sc1 sc2 | None :: sc1, sco :: sc2 -> sco :: merge_scope sc1 sc2 let arguments_scope = ref Refmap.empty type arguments_scope_discharge_request = | ArgsScopeAuto | ArgsScopeManual | ArgsScopeNoDischarge let load_arguments_scope _ (_,(_,r,scl,cls)) = List.iter (Option.iter check_scope) scl; arguments_scope := Refmap.add r (scl,cls) !arguments_scope let cache_arguments_scope o = load_arguments_scope 1 o let subst_arguments_scope (subst,(req,r,scl,cls)) = let r' = fst (subst_global subst r) in let subst_cl cl = try Option.smartmap (subst_cl_typ subst) cl with Not_found -> None in let cls' = list_smartmap subst_cl cls in let scl' = merge_scope (List.map find_class_scope_opt cls') scl in let scl'' = List.map (Option.map Declaremods.subst_scope) scl' in (ArgsScopeNoDischarge,r',scl'',cls') let discharge_arguments_scope (_,(req,r,l,_)) = if req = ArgsScopeNoDischarge or (isVarRef r & Lib.is_in_section r) then None else Some (req,Lib.discharge_global r,l,[]) let classify_arguments_scope (req,_,_,_ as obj) = if req = ArgsScopeNoDischarge then Dispose else Substitute obj let rebuild_arguments_scope (req,r,l,_) = match req with | ArgsScopeNoDischarge -> assert false | ArgsScopeAuto -> let scs,cls = compute_arguments_scope_full (Global.type_of_global r) in (req,r,scs,cls) | ArgsScopeManual -> (* Add to the manually given scopes the one found automatically for the extra parameters of the section *) let l',cls = compute_arguments_scope_full (Global.type_of_global r) in let l1,_ = list_chop (List.length l' - List.length l) l' in (req,r,l1@l,cls) type arguments_scope_obj = arguments_scope_discharge_request * global_reference * scope_name option list * Classops.cl_typ option list let inArgumentsScope : arguments_scope_obj -> obj = declare_object {(default_object "ARGUMENTS-SCOPE") with cache_function = cache_arguments_scope; load_function = load_arguments_scope; subst_function = subst_arguments_scope; classify_function = classify_arguments_scope; discharge_function = discharge_arguments_scope; rebuild_function = rebuild_arguments_scope } let is_local local ref = local || isVarRef ref && Lib.is_in_section ref let declare_arguments_scope_gen req r (scl,cls) = Lib.add_anonymous_leaf (inArgumentsScope (req,r,scl,cls)) let declare_arguments_scope local ref scl = let req = if is_local local ref then ArgsScopeNoDischarge else ArgsScopeManual in declare_arguments_scope_gen req ref (scl,[]) let find_arguments_scope r = try fst (Refmap.find r !arguments_scope) with Not_found -> [] let declare_ref_arguments_scope ref = let t = Global.type_of_global ref in declare_arguments_scope_gen ArgsScopeAuto ref (compute_arguments_scope_full t) (********************************) (* Encoding notations as string *) type symbol = | Terminal of string | NonTerminal of identifier | SProdList of identifier * symbol list | Break of int let rec string_of_symbol = function | NonTerminal _ -> ["_"] | Terminal "_" -> ["'_'"] | Terminal s -> [s] | SProdList (_,l) -> let l = List.flatten (List.map string_of_symbol l) in "_"::l@".."::l@["_"] | Break _ -> [] let make_notation_key symbols = String.concat " " (List.flatten (List.map string_of_symbol symbols)) let decompose_notation_key s = let len = String.length s in let rec decomp_ntn dirs n = if n>=len then List.rev dirs else let pos = try String.index_from s n ' ' with Not_found -> len in let tok = match String.sub s n (pos-n) with | "_" -> NonTerminal (id_of_string "_") | s -> Terminal (drop_simple_quotes s) in decomp_ntn (tok::dirs) (pos+1) in decomp_ntn [] 0 (************) (* Printing *) let pr_delimiters_info = function | None -> str "No delimiting key" | Some key -> str "Delimiting key is " ++ str key let classes_of_scope sc = Gmap.fold (fun cl sc' l -> if sc = sc' then cl::l else l) !class_scope_map [] let pr_scope_classes sc = let l = classes_of_scope sc in if l = [] then mt() else hov 0 (str ("Bound to class"^(if List.tl l=[] then "" else "es")) ++ spc() ++ prlist_with_sep spc pr_class l) ++ fnl() let pr_notation_info prglob ntn c = str "\"" ++ str ntn ++ str "\" := " ++ prglob (glob_constr_of_aconstr dummy_loc c) let pr_named_scope prglob scope sc = (if scope = default_scope then match Gmap.fold (fun _ _ x -> x+1) sc.notations 0 with | 0 -> str "No lonely notation" | n -> str "Lonely notation" ++ (if n=1 then mt() else str"s") else str "Scope " ++ str scope ++ fnl () ++ pr_delimiters_info sc.delimiters) ++ fnl () ++ pr_scope_classes scope ++ Gmap.fold (fun ntn ((_,r),(_,df)) strm -> pr_notation_info prglob df r ++ fnl () ++ strm) sc.notations (mt ()) let pr_scope prglob scope = pr_named_scope prglob scope (find_scope scope) let pr_scopes prglob = Gmap.fold (fun scope sc strm -> pr_named_scope prglob scope sc ++ fnl () ++ strm) !scope_map (mt ()) let rec find_default ntn = function | Scope scope::_ when Gmap.mem ntn (find_scope scope).notations -> Some scope | SingleNotation ntn'::_ when ntn = ntn' -> Some default_scope | _::scopes -> find_default ntn scopes | [] -> None let factorize_entries = function | [] -> [] | (ntn,c)::l -> let (ntn,l_of_ntn,rest) = List.fold_left (fun (a',l,rest) (a,c) -> if a = a' then (a',c::l,rest) else (a,[c],(a',l)::rest)) (ntn,[c],[]) l in (ntn,l_of_ntn)::rest let browse_notation strict ntn map = let find = if String.contains ntn ' ' then (=) ntn else fun ntn' -> let toks = decompose_notation_key ntn' in let trms = List.filter (function Terminal _ -> true | _ -> false) toks in if strict then [Terminal ntn] = trms else List.mem (Terminal ntn) trms in let l = Gmap.fold (fun scope_name sc -> Gmap.fold (fun ntn ((_,r),df) l -> if find ntn then (ntn,(scope_name,r,df))::l else l) sc.notations) map [] in List.sort (fun x y -> Pervasives.compare (fst x) (fst y)) l let global_reference_of_notation test (ntn,(sc,c,_)) = match c with | ARef ref when test ref -> Some (ntn,sc,ref) | AApp (ARef ref, l) when List.for_all isAVar_or_AHole l & test ref -> Some (ntn,sc,ref) | _ -> None let error_ambiguous_notation loc _ntn = user_err_loc (loc,"",str "Ambiguous notation.") let error_notation_not_reference loc ntn = user_err_loc (loc,"", str "Unable to interpret " ++ quote (str ntn) ++ str " as a reference.") let interp_notation_as_global_reference loc test ntn sc = let scopes = match sc with | Some sc -> Gmap.add sc (find_scope (find_delimiters_scope dummy_loc sc)) Gmap.empty | None -> !scope_map in let ntns = browse_notation true ntn scopes in let refs = List.map (global_reference_of_notation test) ntns in match Option.List.flatten refs with | [_,_,ref] -> ref | [] -> error_notation_not_reference loc ntn | refs -> let f (ntn,sc,ref) = find_default ntn !scope_stack = Some sc in match List.filter f refs with | [_,_,ref] -> ref | [] -> error_notation_not_reference loc ntn | _ -> error_ambiguous_notation loc ntn let locate_notation prglob ntn scope = let ntns = factorize_entries (browse_notation false ntn !scope_map) in let scopes = Option.fold_right push_scope scope !scope_stack in if ntns = [] then str "Unknown notation" else t (str "Notation " ++ tab () ++ str "Scope " ++ tab () ++ fnl () ++ prlist (fun (ntn,l) -> let scope = find_default ntn scopes in prlist (fun (sc,r,(_,df)) -> hov 0 ( pr_notation_info prglob df r ++ tbrk (1,2) ++ (if sc = default_scope then mt () else (str ": " ++ str sc)) ++ tbrk (1,2) ++ (if Some sc = scope then str "(default interpretation)" else mt ()) ++ fnl ())) l) ntns) let collect_notation_in_scope scope sc known = assert (scope <> default_scope); Gmap.fold (fun ntn ((_,r),(_,df)) (l,known as acc) -> if List.mem ntn known then acc else ((df,r)::l,ntn::known)) sc.notations ([],known) let collect_notations stack = fst (List.fold_left (fun (all,knownntn as acc) -> function | Scope scope -> if List.mem_assoc scope all then acc else let (l,knownntn) = collect_notation_in_scope scope (find_scope scope) knownntn in ((scope,l)::all,knownntn) | SingleNotation ntn -> if List.mem ntn knownntn then (all,knownntn) else let ((_,r),(_,df)) = Gmap.find ntn (find_scope default_scope).notations in let all' = match all with | (s,lonelyntn)::rest when s = default_scope -> (s,(df,r)::lonelyntn)::rest | _ -> (default_scope,[df,r])::all in (all',ntn::knownntn)) ([],[]) stack) let pr_visible_in_scope prglob (scope,ntns) = let strm = List.fold_right (fun (df,r) strm -> pr_notation_info prglob df r ++ fnl () ++ strm) ntns (mt ()) in (if scope = default_scope then str "Lonely notation" ++ (if List.length ntns <> 1 then str "s" else mt()) else str "Visible in scope " ++ str scope) ++ fnl () ++ strm let pr_scope_stack prglob stack = List.fold_left (fun strm scntns -> strm ++ pr_visible_in_scope prglob scntns ++ fnl ()) (mt ()) (collect_notations stack) let pr_visibility prglob = function | Some scope -> pr_scope_stack prglob (push_scope scope !scope_stack) | None -> pr_scope_stack prglob !scope_stack (**********************************************************************) (* Mapping notations to concrete syntax *) type unparsing_rule = unparsing list * precedence (* Concrete syntax for symbolic-extension table *) let printing_rules = ref (Gmap.empty : (string,unparsing_rule) Gmap.t) let declare_notation_printing_rule ntn unpl = printing_rules := Gmap.add ntn unpl !printing_rules let find_notation_printing_rule ntn = try Gmap.find ntn !printing_rules with Not_found -> anomaly ("No printing rule found for "^ntn) (**********************************************************************) (* Synchronisation with reset *) let freeze () = (!scope_map, !notation_level_map, !scope_stack, !arguments_scope, !delimiters_map, !notations_key_table, !printing_rules, !class_scope_map) let unfreeze (scm,nlm,scs,asc,dlm,fkm,pprules,clsc) = scope_map := scm; notation_level_map := nlm; scope_stack := scs; delimiters_map := dlm; arguments_scope := asc; notations_key_table := fkm; printing_rules := pprules; class_scope_map := clsc let init () = init_scope_map (); (* scope_stack := Gmap.empty arguments_scope := Refmap.empty *) notation_level_map := Gmap.empty; delimiters_map := Gmap.empty; notations_key_table := Gmapl.empty; printing_rules := Gmap.empty; class_scope_map := Gmap.add CL_SORT "type_scope" Gmap.empty let _ = declare_summary "symbols" { freeze_function = freeze; unfreeze_function = unfreeze; init_function = init } let with_notation_protection f x = let fs = freeze () in try let a = f x in unfreeze fs; a with reraise -> unfreeze fs; raise reraise coq-8.4pl4/interp/constrextern.mli0000644000175000017500000000556112326224777016404 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr_expr -> bool (** Translation of pattern, cases pattern, glob_constr and term into syntax trees for printing *) val extern_cases_pattern : Idset.t -> cases_pattern -> cases_pattern_expr val extern_glob_constr : Idset.t -> glob_constr -> constr_expr val extern_glob_type : Idset.t -> glob_constr -> constr_expr val extern_constr_pattern : names_context -> constr_pattern -> constr_expr (** If [b=true] in [extern_constr b env c] then the variables in the first level of quantification clashing with the variables in [env] are renamed *) val extern_constr : bool -> env -> constr -> constr_expr val extern_constr_in_scope : bool -> scope_name -> env -> constr -> constr_expr val extern_reference : loc -> Idset.t -> global_reference -> reference val extern_type : bool -> env -> types -> constr_expr val extern_sort : sorts -> glob_sort val extern_rel_context : constr option -> env -> rel_context -> local_binder list (** Printing options *) val print_implicits : bool ref val print_implicits_defensive : bool ref val print_arguments : bool ref val print_evar_arguments : bool ref val print_coercions : bool ref val print_universes : bool ref val print_no_symbol : bool ref val print_projections : bool ref (** Customization of the global_reference printer *) val set_extern_reference : (loc -> Idset.t -> global_reference -> reference) -> unit val get_extern_reference : unit -> (loc -> Idset.t -> global_reference -> reference) val in_debugger : bool ref (** This governs printing of implicit arguments. If [with_implicits] is on and not [with_arguments] then implicit args are printed prefixed by "!"; if [with_implicits] and [with_arguments] are both on the function and not the arguments is prefixed by "!" *) val with_implicits : ('a -> 'b) -> 'a -> 'b val with_arguments : ('a -> 'b) -> 'a -> 'b (** This forces printing of coercions *) val with_coercions : ('a -> 'b) -> 'a -> 'b (** This forces printing universe names of Type\{.\} *) val with_universes : ('a -> 'b) -> 'a -> 'b (** This suppresses printing of numeral and symbols *) val without_symbols : ('a -> 'b) -> 'a -> 'b (** This prints metas as anonymous holes *) val with_meta_as_hole : ('a -> 'b) -> 'a -> 'b coq-8.4pl4/interp/syntax_def.mli0000644000175000017500000000207312326224777016005 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* identifier -> Flags.compat_version option -> syndef_interpretation -> unit val search_syntactic_definition : kernel_name -> syndef_interpretation (** Options concerning verbose display of compatibility notations or their deactivation *) val set_verbose_compat_notations : bool -> unit val set_compat_notations : bool -> unit coq-8.4pl4/interp/smartlocate.mli0000644000175000017500000000275712326224777016170 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* global_reference (** Extract a global_reference from a reference that can be an "alias" *) val global_of_extended_global : extended_global_reference -> global_reference (** Locate a reference taking into account possible "alias" notations *) val global_with_alias : reference -> global_reference (** The same for inductive types *) val global_inductive_with_alias : reference -> inductive (** Locate a reference taking into account notations and "aliases" *) val smart_global : reference or_by_notation -> global_reference (** The same for inductive types *) val smart_global_inductive : reference or_by_notation -> inductive coq-8.4pl4/interp/constrintern.ml0000644000175000017500000020302012326224777016213 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* false let global_reference_of_reference ref = locate_reference (snd (qualid_of_reference ref)) let global_reference id = constr_of_global (locate_reference (qualid_of_ident id)) let construct_reference ctx id = try Term.mkVar (let _ = Sign.lookup_named id ctx in id) with Not_found -> global_reference id let global_reference_in_absolute_module dir id = constr_of_global (Nametab.global_of_path (Libnames.make_path dir id)) (**********************************************************************) (* Internalization errors *) type internalization_error = | VariableCapture of identifier | WrongExplicitImplicit | IllegalMetavariable | NotAConstructor of reference | UnboundFixName of bool * identifier | NonLinearPattern of identifier | BadPatternsNumber of int * int | BadExplicitationNumber of explicitation * int option exception InternalizationError of loc * internalization_error let explain_variable_capture id = str "The variable " ++ pr_id id ++ str " occurs in its type" let explain_wrong_explicit_implicit = str "Found an explicitly given implicit argument but was expecting" ++ fnl () ++ str "a regular one" let explain_illegal_metavariable = str "Metavariables allowed only in patterns" let explain_not_a_constructor ref = str "Unknown constructor: " ++ pr_reference ref let explain_unbound_fix_name is_cofix id = str "The name" ++ spc () ++ pr_id id ++ spc () ++ str "is not bound in the corresponding" ++ spc () ++ str (if is_cofix then "co" else "") ++ str "fixpoint definition" let explain_non_linear_pattern id = str "The variable " ++ pr_id id ++ str " is bound several times in pattern" let explain_bad_patterns_number n1 n2 = str "Expecting " ++ int n1 ++ str (plural n1 " pattern") ++ str " but found " ++ int n2 let explain_bad_explicitation_number n po = match n with | ExplByPos (n,_id) -> let s = match po with | None -> str "a regular argument" | Some p -> int p in str "Bad explicitation number: found " ++ int n ++ str" but was expecting " ++ s | ExplByName id -> let s = match po with | None -> str "a regular argument" | Some p -> (*pr_id (name_of_position p) in*) failwith "" in str "Bad explicitation name: found " ++ pr_id id ++ str" but was expecting " ++ s let explain_internalization_error e = let pp = match e with | VariableCapture id -> explain_variable_capture id | WrongExplicitImplicit -> explain_wrong_explicit_implicit | IllegalMetavariable -> explain_illegal_metavariable | NotAConstructor ref -> explain_not_a_constructor ref | UnboundFixName (iscofix,id) -> explain_unbound_fix_name iscofix id | NonLinearPattern id -> explain_non_linear_pattern id | BadPatternsNumber (n1,n2) -> explain_bad_patterns_number n1 n2 | BadExplicitationNumber (n,po) -> explain_bad_explicitation_number n po in pp ++ str "." let error_bad_inductive_type loc = user_err_loc (loc,"",str "This should be an inductive type applied to names or \"_\".") let error_inductive_parameter_not_implicit loc = user_err_loc (loc,"", str ("The parameters of inductive types do not bind in\n"^ "the 'return' clauses; they must be replaced by '_' in the 'in' clauses.")) (**********************************************************************) (* Pre-computing the implicit arguments and arguments scopes needed *) (* for interpretation *) let parsing_explicit = ref false let empty_internalization_env = Idmap.empty let compute_explicitable_implicit imps = function | Inductive params -> (* In inductive types, the parameters are fixed implicit arguments *) let sub_impl,_ = list_chop (List.length params) imps in let sub_impl' = List.filter is_status_implicit sub_impl in List.map name_of_implicit sub_impl' | Recursive | Method | Variable -> (* Unable to know in advance what the implicit arguments will be *) [] let compute_internalization_data env ty typ impl = let impl = compute_implicits_with_manual env typ (is_implicit_args()) impl in let expls_impl = compute_explicitable_implicit impl ty in (ty, expls_impl, impl, compute_arguments_scope typ) let compute_internalization_env env ty = list_fold_left3 (fun map id typ impl -> Idmap.add id (compute_internalization_data env ty typ impl) map) empty_internalization_env (**********************************************************************) (* Contracting "{ _ }" in notations *) let rec wildcards ntn n = if n = String.length ntn then [] else let l = spaces ntn (n+1) in if ntn.[n] = '_' then n::l else l and spaces ntn n = if n = String.length ntn then [] else if ntn.[n] = ' ' then wildcards ntn (n+1) else spaces ntn (n+1) let expand_notation_string ntn n = let pos = List.nth (wildcards ntn 0) n in let hd = if pos = 0 then "" else String.sub ntn 0 pos in let tl = if pos = String.length ntn then "" else String.sub ntn (pos+1) (String.length ntn - pos -1) in hd ^ "{ _ }" ^ tl (* This contracts the special case of "{ _ }" for sumbool, sumor notations *) (* Remark: expansion of squash at definition is done in metasyntax.ml *) let contract_notation ntn (l,ll,bll) = let ntn' = ref ntn in let rec contract_squash n = function | [] -> [] | CNotation (_,"{ _ }",([a],[],[])) :: l -> ntn' := expand_notation_string !ntn' n; contract_squash n (a::l) | a :: l -> a::contract_squash (n+1) l in let l = contract_squash 0 l in (* side effect; don't inline *) !ntn',(l,ll,bll) let contract_pat_notation ntn (l,ll) = let ntn' = ref ntn in let rec contract_squash n = function | [] -> [] | CPatNotation (_,"{ _ }",([a],[])) :: l -> ntn' := expand_notation_string !ntn' n; contract_squash n (a::l) | a :: l -> a::contract_squash (n+1) l in let l = contract_squash 0 l in (* side effect; don't inline *) !ntn',(l,ll) type intern_env = { ids: Names.Idset.t; unb: bool; tmp_scope: Topconstr.tmp_scope_name option; scopes: Topconstr.scope_name list; impls: internalization_env } (**********************************************************************) (* Remembering the parsing scope of variables in notations *) let make_current_scope = function | (Some tmp_scope,(sc::_ as scopes)) when sc = tmp_scope -> scopes | (Some tmp_scope,scopes) -> tmp_scope::scopes | None,scopes -> scopes let pr_scope_stack = function | [] -> str "the empty scope stack" | [a] -> str "scope " ++ str a | l -> str "scope stack " ++ str "[" ++ prlist_with_sep pr_comma str l ++ str "]" let error_inconsistent_scope loc id scopes1 scopes2 = user_err_loc (loc,"set_var_scope", pr_id id ++ str " is here used in " ++ pr_scope_stack scopes2 ++ strbrk " while it was elsewhere used in " ++ pr_scope_stack scopes1) let error_expect_constr_notation_type loc id = user_err_loc (loc,"", pr_id id ++ str " is bound in the notation to a term variable.") let error_expect_binder_notation_type loc id = user_err_loc (loc,"", pr_id id ++ str " is expected to occur in binding position in the right-hand side.") let set_var_scope loc id istermvar env ntnvars = try let idscopes,typ = List.assoc id ntnvars in if istermvar then (* scopes have no effect on the interpretation of identifiers *) if !idscopes = None then idscopes := Some (env.tmp_scope,env.scopes) else if make_current_scope (Option.get !idscopes) <> make_current_scope (env.tmp_scope,env.scopes) then error_inconsistent_scope loc id (make_current_scope (Option.get !idscopes)) (make_current_scope (env.tmp_scope,env.scopes)); match typ with | NtnInternTypeBinder -> if istermvar then error_expect_binder_notation_type loc id | NtnInternTypeConstr -> (* We need sometimes to parse idents at a constr level for factorization and we cannot enforce this constraint: if not istermvar then error_expect_constr_notation_type loc id *) () | NtnInternTypeIdent -> () with Not_found -> (* Not in a notation *) () let set_type_scope env = {env with tmp_scope = Some Notation.type_scope} let reset_tmp_scope env = {env with tmp_scope = None} let rec it_mkGProd env body = match env with (na, bk, _, t) :: tl -> it_mkGProd tl (GProd (dummy_loc, na, bk, t, body)) | [] -> body let rec it_mkGLambda env body = match env with (na, bk, _, t) :: tl -> it_mkGLambda tl (GLambda (dummy_loc, na, bk, t, body)) | [] -> body (**********************************************************************) (* Utilities for binders *) let build_impls = function |Implicit -> (function |Name id -> Some (id, Impargs.Manual, (true,true)) |Anonymous -> anomaly "Anonymous implicit argument") |Explicit -> fun _ -> None let impls_type_list ?(args = []) = let rec aux acc = function |GProd (_,na,bk,_,c) -> aux ((build_impls bk na)::acc) c |_ -> (Variable,[],List.append args (List.rev acc),[]) in aux [] let impls_term_list ?(args = []) = let rec aux acc = function |GLambda (_,na,bk,_,c) -> aux ((build_impls bk na)::acc) c |GRec (_, fix_kind, nas, args, tys, bds) -> let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in let acc' = List.fold_left (fun a (na, bk, _, _) -> (build_impls bk na)::a) acc args.(nb) in aux acc' bds.(nb) |_ -> (Variable,[],List.append args (List.rev acc),[]) in aux [] let check_capture loc ty = function | Name id when occur_var_constr_expr id ty -> raise (InternalizationError (loc,VariableCapture id)) | _ -> () let locate_if_isevar loc na = function | GHole _ -> (try match na with | Name id -> glob_constr_of_aconstr loc (Reserve.find_reserved_type id) | Anonymous -> raise Not_found with Not_found -> GHole (loc, Evd.BinderType na)) | x -> x let reset_hidden_inductive_implicit_test env = { env with impls = Idmap.fold (fun id x -> let x = match x with | (Inductive _,b,c,d) -> (Inductive [],b,c,d) | x -> x in Idmap.add id x) env.impls Idmap.empty } let check_hidden_implicit_parameters id impls = if Idmap.exists (fun _ -> function | (Inductive indparams,_,_,_) -> List.mem id indparams | _ -> false) impls then errorlabstrm "" (strbrk "A parameter of an inductive type " ++ pr_id id ++ strbrk " is not allowed to be used as a bound variable in the type of its constructor.") let push_name_env ?(global_level=false) lvar implargs env = function | loc,Anonymous -> if global_level then user_err_loc (loc,"", str "Anonymous variables not allowed"); env | loc,Name id -> check_hidden_implicit_parameters id env.impls ; set_var_scope loc id false env (let (_,ntnvars) = lvar in ntnvars); if global_level then Dumpglob.dump_definition (loc,id) true "var" else Dumpglob.dump_binding loc id; {env with ids = Idset.add id env.ids; impls = Idmap.add id implargs env.impls} let intern_generalized_binder ?(global_level=false) intern_type lvar env bl (loc, na) b b' t ty = let ids = (match na with Anonymous -> fun x -> x | Name na -> Idset.add na) env.ids in let ty, ids' = if t then ty, ids else Implicit_quantifiers.implicit_application ids Implicit_quantifiers.combine_params_freevar ty in let ty' = intern_type {env with ids = ids; unb = true} ty in let fvs = Implicit_quantifiers.generalizable_vars_of_glob_constr ~bound:ids ~allowed:ids' ty' in let env' = List.fold_left (fun env (x, l) -> push_name_env ~global_level lvar (Variable,[],[],[])(*?*) env (l, Name x)) env fvs in let bl = List.map (fun (id, loc) -> (Name id, b, None, GHole (loc, Evd.BinderType (Name id)))) fvs in let na = match na with | Anonymous -> if global_level then na else let name = let id = match ty with | CApp (_, (_, CRef (Ident (loc,id))), _) -> id | _ -> id_of_string "H" in Implicit_quantifiers.make_fresh ids' (Global.env ()) id in Name name | _ -> na in (push_name_env ~global_level lvar (impls_type_list ty')(*?*) env' (loc,na)), (na,b',None,ty') :: List.rev bl let intern_local_binder_aux ?(global_level=false) intern intern_type lvar (env,bl) = function | LocalRawAssum(nal,bk,ty) -> (match bk with | Default k -> let ty = intern_type env ty in let impls = impls_type_list ty in List.fold_left (fun (env,bl) (loc,na as locna) -> (push_name_env lvar impls env locna, (na,k,None,locate_if_isevar loc na ty)::bl)) (env,bl) nal | Generalized (b,b',t) -> let env, b = intern_generalized_binder ~global_level intern_type lvar env bl (List.hd nal) b b' t ty in env, b @ bl) | LocalRawDef((loc,na as locna),def) -> let indef = intern env def in (push_name_env lvar (impls_term_list indef) env locna, (na,Explicit,Some(indef),GHole(loc,Evd.BinderType na))::bl) let intern_generalization intern env lvar loc bk ak c = let c = intern {env with unb = true} c in let fvs = Implicit_quantifiers.generalizable_vars_of_glob_constr ~bound:env.ids c in let env', c' = let abs = let pi = match ak with | Some AbsPi -> true | None when env.tmp_scope = Some Notation.type_scope || List.mem Notation.type_scope env.scopes -> true | _ -> false in if pi then (fun (id, loc') acc -> GProd (join_loc loc' loc, Name id, bk, GHole (loc', Evd.BinderType (Name id)), acc)) else (fun (id, loc') acc -> GLambda (join_loc loc' loc, Name id, bk, GHole (loc', Evd.BinderType (Name id)), acc)) in List.fold_right (fun (id, loc as lid) (env, acc) -> let env' = push_name_env lvar (Variable,[],[],[]) env (loc, Name id) in (env', abs lid acc)) fvs (env,c) in c' let iterate_binder intern lvar (env,bl) = function | LocalRawAssum(nal,bk,ty) -> let intern_type env = intern (set_type_scope env) in (match bk with | Default k -> let ty = intern_type env ty in let impls = impls_type_list ty in List.fold_left (fun (env,bl) (loc,na as locna) -> (push_name_env lvar impls env locna, (na,k,None,locate_if_isevar loc na ty)::bl)) (env,bl) nal | Generalized (b,b',t) -> let env, b = intern_generalized_binder intern_type lvar env bl (List.hd nal) b b' t ty in env, b @ bl) | LocalRawDef((loc,na as locna),def) -> let indef = intern env def in (push_name_env lvar (impls_term_list indef) env locna, (na,Explicit,Some(indef),GHole(loc,Evd.BinderType na))::bl) (**********************************************************************) (* Syntax extensions *) let option_mem_assoc id = function | Some (id',c) -> id = id' | None -> false let find_fresh_name renaming (terms,termlists,binders) id = let fvs1 = List.map (fun (_,(c,_)) -> free_vars_of_constr_expr c) terms in let fvs2 = List.flatten (List.map (fun (_,(l,_)) -> List.map free_vars_of_constr_expr l) termlists) in let fvs3 = List.map snd renaming in (* TODO binders *) let fvs = List.flatten (List.map Idset.elements (fvs1@fvs2)) @ fvs3 in next_ident_away id fvs let traverse_binder (terms,_,_ as subst) (renaming,env)= function | Anonymous -> (renaming,env),Anonymous | Name id -> try (* Binders bound in the notation are considered first-order objects *) let _,na = coerce_to_name (fst (List.assoc id terms)) in (renaming,{env with ids = name_fold Idset.add na env.ids}), na with Not_found -> (* Binders not bound in the notation do not capture variables *) (* outside the notation (i.e. in the substitution) *) let id' = find_fresh_name renaming subst id in let renaming' = if id=id' then renaming else (id,id')::renaming in (renaming',env), Name id' let make_letins loc = List.fold_right (fun (na,b,t) c -> GLetIn (loc,na,b,c)) let rec subordinate_letins letins = function (* binders come in reverse order; the non-let are returned in reverse order together *) (* with the subordinated let-in in writing order *) | (na,_,Some b,t)::l -> subordinate_letins ((na,b,t)::letins) l | (na,bk,None,t)::l -> let letins',rest = subordinate_letins [] l in letins',((na,bk,t),letins)::rest | [] -> letins,[] let rec subst_iterator y t = function | GVar (_,id) as x -> if id = y then t else x | x -> map_glob_constr (subst_iterator y t) x let subst_aconstr_in_glob_constr loc intern lvar subst infos c = let (terms,termlists,binders) = subst in let rec aux (terms,binderopt as subst') (renaming,env) c = let subinfos = renaming,{env with tmp_scope = None} in match c with | AVar id -> begin (* subst remembers the delimiters stack in the interpretation *) (* of the notations *) try let (a,(scopt,subscopes)) = List.assoc id terms in intern {env with tmp_scope = scopt; scopes = subscopes @ env.scopes} a with Not_found -> try GVar (loc,List.assoc id renaming) with Not_found -> (* Happens for local notation joint with inductive/fixpoint defs *) GVar (loc,id) end | AList (x,_,iter,terminator,lassoc) -> (try (* All elements of the list are in scopes (scopt,subscopes) *) let (l,(scopt,subscopes)) = List.assoc x termlists in let termin = aux subst' subinfos terminator in List.fold_right (fun a t -> subst_iterator ldots_var t (aux ((x,(a,(scopt,subscopes)))::terms,binderopt) subinfos iter)) (if lassoc then List.rev l else l) termin with Not_found -> anomaly "Inconsistent substitution of recursive notation") | AHole (Evd.BinderType (Name id as na)) -> let na = try snd (coerce_to_name (fst (List.assoc id terms))) with Not_found -> na in GHole (loc,Evd.BinderType na) | ABinderList (x,_,iter,terminator) -> (try (* All elements of the list are in scopes (scopt,subscopes) *) let (bl,(scopt,subscopes)) = List.assoc x binders in let env,bl = List.fold_left (iterate_binder intern lvar) (env,[]) bl in let letins,bl = subordinate_letins [] bl in let termin = aux subst' (renaming,env) terminator in let res = List.fold_left (fun t binder -> subst_iterator ldots_var t (aux (terms,Some(x,binder)) subinfos iter)) termin bl in make_letins loc letins res with Not_found -> anomaly "Inconsistent substitution of recursive notation") | AProd (Name id, AHole _, c') when option_mem_assoc id binderopt -> let (na,bk,t),letins = snd (Option.get binderopt) in GProd (loc,na,bk,t,make_letins loc letins (aux subst' infos c')) | ALambda (Name id,AHole _,c') when option_mem_assoc id binderopt -> let (na,bk,t),letins = snd (Option.get binderopt) in GLambda (loc,na,bk,t,make_letins loc letins (aux subst' infos c')) | t -> glob_constr_of_aconstr_with_binders loc (traverse_binder subst) (aux subst') subinfos t in aux (terms,None) infos c let split_by_type ids = List.fold_right (fun (x,(scl,typ)) (l1,l2,l3) -> match typ with | NtnTypeConstr -> ((x,scl)::l1,l2,l3) | NtnTypeConstrList -> (l1,(x,scl)::l2,l3) | NtnTypeBinderList -> (l1,l2,(x,scl)::l3)) ids ([],[],[]) let make_subst ids l = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids l let intern_notation intern env lvar loc ntn fullargs = let ntn,(args,argslist,bll as fullargs) = contract_notation ntn fullargs in let ((ids,c),df) = interp_notation loc ntn (env.tmp_scope,env.scopes) in Dumpglob.dump_notation_location (ntn_loc loc fullargs ntn) ntn df; let ids,idsl,idsbl = split_by_type ids in let terms = make_subst ids args in let termlists = make_subst idsl argslist in let binders = make_subst idsbl bll in subst_aconstr_in_glob_constr loc intern lvar (terms,termlists,binders) ([],env) c (**********************************************************************) (* Discriminating between bound variables and global references *) let string_of_ty = function | Inductive _ -> "ind" | Recursive -> "def" | Method -> "meth" | Variable -> "var" let intern_var genv (ltacvars,ntnvars) namedctx loc id = let (ltacvars,unbndltacvars) = ltacvars in (* Is [id] an inductive type potentially with implicit *) try let ty,expl_impls,impls,argsc = Idmap.find id genv.impls in let expl_impls = List.map (fun id -> CRef (Ident (loc,id)), Some (loc,ExplByName id)) expl_impls in let tys = string_of_ty ty in Dumpglob.dump_reference loc "<>" (string_of_id id) tys; GVar (loc,id), make_implicits_list impls, argsc, expl_impls with Not_found -> (* Is [id] bound in current term or is an ltac var bound to constr *) if Idset.mem id genv.ids or List.mem id ltacvars then GVar (loc,id), [], [], [] (* Is [id] a notation variable *) else if List.mem_assoc id ntnvars then (set_var_scope loc id true genv ntnvars; GVar (loc,id), [], [], []) (* Is [id] the special variable for recursive notations *) else if ntnvars <> [] && id = ldots_var then GVar (loc,id), [], [], [] else (* Is [id] bound to a free name in ltac (this is an ltac error message) *) try match List.assoc id unbndltacvars with | None -> user_err_loc (loc,"intern_var", str "variable " ++ pr_id id ++ str " should be bound to a term.") | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0 with Not_found -> (* Is [id] a goal or section variable *) let _ = Sign.lookup_named id namedctx in try (* [id] a section variable *) (* Redundant: could be done in intern_qualid *) let ref = VarRef id in let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in Dumpglob.dump_reference loc "<>" (string_of_qualid (Decls.variable_secpath id)) "var"; GRef (loc, ref), impls, scopes, [] with e when Errors.noncritical e -> (* [id] a goal variable *) GVar (loc,id), [], [], [] let find_appl_head_data = function | GRef (_,ref) as x -> x,implicits_of_global ref,find_arguments_scope ref,[] | GApp (_,GRef (_,ref),l) as x when l <> [] & Flags.version_strictly_greater Flags.V8_2 -> let n = List.length l in x,List.map (drop_first_implicits n) (implicits_of_global ref), list_skipn_at_least n (find_arguments_scope ref),[] | x -> x,[],[],[] let error_not_enough_arguments loc = user_err_loc (loc,"",str "Abbreviation is not applied enough.") let check_no_explicitation l = let l = List.filter (fun (a,b) -> b <> None) l in if l <> [] then let loc = fst (Option.get (snd (List.hd l))) in user_err_loc (loc,"",str"Unexpected explicitation of the argument of an abbreviation.") let dump_extended_global loc = function | TrueGlobal ref -> Dumpglob.add_glob loc ref | SynDef sp -> Dumpglob.add_glob_kn loc sp let intern_extended_global_of_qualid (loc,qid) = try let r = Nametab.locate_extended qid in dump_extended_global loc r; r with Not_found -> error_global_not_found_loc loc qid let intern_reference ref = Smartlocate.global_of_extended_global (intern_extended_global_of_qualid (qualid_of_reference ref)) (* Is it a global reference or a syntactic definition? *) let intern_qualid loc qid intern env lvar args = match intern_extended_global_of_qualid (loc,qid) with | TrueGlobal ref -> GRef (loc, ref), args | SynDef sp -> let (ids,c) = Syntax_def.search_syntactic_definition sp in let nids = List.length ids in if List.length args < nids then error_not_enough_arguments loc; let args1,args2 = list_chop nids args in check_no_explicitation args1; let subst = make_subst ids (List.map fst args1) in subst_aconstr_in_glob_constr loc intern lvar (subst,[],[]) ([],env) c, args2 (* Rule out section vars since these should have been found by intern_var *) let intern_non_secvar_qualid loc qid intern env lvar args = match intern_qualid loc qid intern env lvar args with | GRef (loc, VarRef id),_ -> error_global_not_found_loc loc qid | r -> r let intern_applied_reference intern env namedctx lvar args = function | Qualid (loc, qid) -> let r,args2 = intern_qualid loc qid intern env lvar args in find_appl_head_data r, args2 | Ident (loc, id) -> try intern_var env lvar namedctx loc id, args with Not_found -> let qid = qualid_of_ident id in try let r,args2 = intern_non_secvar_qualid loc qid intern env lvar args in find_appl_head_data r, args2 with e when Errors.noncritical e -> (* Extra allowance for non globalizing functions *) if !interning_grammar || env.unb then (GVar (loc,id), [], [], []),args else raise e let interp_reference vars r = let (r,_,_,_),_ = intern_applied_reference (fun _ -> error_not_enough_arguments dummy_loc) {ids = Idset.empty; unb = false ; tmp_scope = None; scopes = []; impls = empty_internalization_env} [] (vars,[]) [] r in r let apply_scope_env env = function | [] -> {env with tmp_scope = None}, [] | sc::scl -> {env with tmp_scope = sc}, scl let rec simple_adjust_scopes n scopes = if n=0 then [] else match scopes with | [] -> None :: simple_adjust_scopes (n-1) [] | sc::scopes -> sc :: simple_adjust_scopes (n-1) scopes let find_remaining_constructor_scopes pl1 pl2 (ind,j as cstr) = let (mib,mip) = Inductive.lookup_mind_specif (Global.env()) ind in let npar = mib.Declarations.mind_nparams in snd (list_chop (npar + List.length pl1) (simple_adjust_scopes (npar + List.length pl1 + List.length pl2) (find_arguments_scope (ConstructRef cstr)))) (**********************************************************************) (* Cases *) let product_of_cases_patterns ids idspl = List.fold_right (fun (ids,pl) (ids',ptaill) -> (ids@ids', (* Cartesian prod of the or-pats for the nth arg and the tail args *) List.flatten ( List.map (fun (subst,p) -> List.map (fun (subst',ptail) -> (subst@subst',p::ptail)) ptaill) pl))) idspl (ids,[[],[]]) let simple_product_of_cases_patterns pl = List.fold_right (fun pl ptaill -> List.flatten (List.map (fun (subst,p) -> List.map (fun (subst',ptail) -> (subst@subst',p::ptail)) ptaill) pl)) pl [[],[]] (* Check linearity of pattern-matching *) let rec has_duplicate = function | [] -> None | x::l -> if List.mem x l then (Some x) else has_duplicate l let loc_of_lhs lhs = join_loc (fst (List.hd lhs)) (fst (list_last lhs)) let check_linearity lhs ids = match has_duplicate ids with | Some id -> raise (InternalizationError (loc_of_lhs lhs,NonLinearPattern id)) | None -> () (* Match the number of pattern against the number of matched args *) let check_number_of_pattern loc n l = let p = List.length l in if n<>p then raise (InternalizationError (loc,BadPatternsNumber (n,p))) let check_or_pat_variables loc ids idsl = if List.exists (fun ids' -> not (list_eq_set ids ids')) idsl then user_err_loc (loc, "", str "The components of this disjunctive pattern must bind the same variables.") let check_constructor_length env loc cstr pl pl0 = let n = List.length pl + List.length pl0 in let nargs = Inductiveops.constructor_nrealargs env cstr in let nhyps = Inductiveops.constructor_nrealhyps env cstr in if n <> nargs && n <> nhyps (* i.e. with let's *) then error_wrong_numarg_constructor_loc loc env cstr nargs (* Manage multiple aliases *) (* [merge_aliases] returns the sets of all aliases encountered at this point and a substitution mapping extra aliases to the first one *) let merge_aliases (ids,asubst as _aliases) id = ids@[id], if ids=[] then asubst else (id, List.hd ids)::asubst let alias_of = function | ([],_) -> Anonymous | (id::_,_) -> Name id let message_redundant_alias (id1,id2) = if_warn msg_warning (str "Alias variable " ++ pr_id id1 ++ str " is merged with " ++ pr_id id2) (* Expanding notations *) let chop_aconstr_constructor loc (ind,k) args = if List.length args = 0 then (* Tolerance for a @id notation *) args else begin let mib,_ = Global.lookup_inductive ind in let nparams = mib.Declarations.mind_nparams in if nparams > List.length args then error_invalid_pattern_notation loc; let params,args = list_chop nparams args in List.iter (function AHole _ -> () | _ -> error_invalid_pattern_notation loc) params; args end let rec subst_pat_iterator y t (subst,p) = match p with | PatVar (_,id) as x -> if id = Name y then t else [subst,x] | PatCstr (loc,id,l,alias) -> let l' = List.map (fun a -> (subst_pat_iterator y t ([],a))) l in let pl = simple_product_of_cases_patterns l' in List.map (fun (subst',pl) -> subst'@subst,PatCstr (loc,id,pl,alias)) pl let subst_cases_pattern loc alias intern fullsubst env a = let rec aux alias (subst,substlist as fullsubst) = function | AVar id -> begin (* subst remembers the delimiters stack in the interpretation *) (* of the notations *) try let (a,(scopt,subscopes)) = List.assoc id subst in intern {env with scopes=subscopes@env.scopes; tmp_scope = scopt} ([],[]) a with Not_found -> if id = ldots_var then [], [[], PatVar (loc,Name id)] else anomaly ("Unbound pattern notation variable: "^(string_of_id id)) (* (* Happens for local notation joint with inductive/fixpoint defs *) if aliases <> ([],[]) then anomaly "Pattern notation without constructors"; [[id],[]], PatVar (loc,Name id) *) end | ARef (ConstructRef c) -> ([],[[], PatCstr (loc,c, [], alias)]) | AApp (ARef (ConstructRef cstr),args) -> let args = chop_aconstr_constructor loc cstr args in let idslpll = List.map (aux Anonymous fullsubst) args in let ids',pll = product_of_cases_patterns [] idslpll in let pl' = List.map (fun (asubst,pl) -> asubst,PatCstr (loc,cstr,pl,alias)) pll in ids', pl' | AList (x,_,iter,terminator,lassoc) -> (try (* All elements of the list are in scopes (scopt,subscopes) *) let (l,(scopt,subscopes)) = List.assoc x substlist in let termin = aux Anonymous fullsubst terminator in let idsl,v = List.fold_right (fun a (tids,t) -> let uids,u = aux Anonymous ((x,(a,(scopt,subscopes)))::subst,substlist) iter in let pll = List.map (subst_pat_iterator ldots_var t) u in tids@uids, List.flatten pll) (if lassoc then List.rev l else l) termin in idsl, List.map (fun ((asubst, pl) as x) -> match pl with PatCstr (loc, c, pl, Anonymous) -> (asubst, PatCstr (loc, c, pl, alias)) | _ -> x) v with Not_found -> anomaly "Inconsistent substitution of recursive notation") | AHole _ -> ([],[[], PatVar (loc,Anonymous)]) | t -> error_invalid_pattern_notation loc in aux alias fullsubst a (* Differentiating between constructors and matching variables *) type pattern_qualid_kind = | ConstrPat of constructor * (identifier list * ((identifier * identifier) list * cases_pattern) list) list | VarPat of identifier let find_constructor ref f aliases pats env = let (loc,qid) = qualid_of_reference ref in let gref = try locate_extended qid with Not_found -> raise (InternalizationError (loc,NotAConstructor ref)) in match gref with | SynDef sp -> let (vars,a) = Syntax_def.search_syntactic_definition sp in (match a with | ARef (ConstructRef cstr) -> assert (vars=[]); cstr, [], pats | AApp (ARef (ConstructRef cstr),args) -> let args = chop_aconstr_constructor loc cstr args in let nvars = List.length vars in if List.length pats < nvars then error_not_enough_arguments loc; let pats1,pats2 = list_chop nvars pats in let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) vars pats1 in let idspl1 = List.map (subst_cases_pattern loc Anonymous f (subst,[]) env) args in cstr, idspl1, pats2 | _ -> raise Not_found) | TrueGlobal r -> let rec unf = function | ConstRef cst -> let v = Environ.constant_value (Global.env()) cst in unf (global_of_constr v) | ConstructRef cstr -> Dumpglob.add_glob loc r; cstr, [], pats | _ -> raise Not_found in unf r let find_pattern_variable = function | Ident (loc,id) -> id | Qualid (loc,_) as x -> raise (InternalizationError(loc,NotAConstructor x)) let maybe_constructor ref f aliases env = try let c,idspl1,pl2 = find_constructor ref f aliases [] env in assert (pl2 = []); ConstrPat (c,idspl1) with (* patt var does not exists globally *) | InternalizationError _ -> VarPat (find_pattern_variable ref) (* patt var also exists globally but does not satisfy preconditions *) | (Environ.NotEvaluableConst _ | Not_found) -> if_warn msg_warning (str "pattern " ++ pr_reference ref ++ str " is understood as a pattern variable"); VarPat (find_pattern_variable ref) let mustbe_constructor loc ref f aliases patl env = try find_constructor ref f aliases patl env with (Environ.NotEvaluableConst _ | Not_found) -> raise (InternalizationError (loc,NotAConstructor ref)) let sort_fields mode loc l completer = (*mode=false if pattern and true if constructor*) match l with | [] -> None | (refer, value)::rem -> let (nparams, (* the number of parameters *) base_constructor, (* the reference constructor of the record *) (max, (* number of params *) (first_index, (* index of the first field of the record *) list_proj))) (* list of projections *) = let record = try Recordops.find_projection (global_reference_of_reference refer) with Not_found -> user_err_loc (loc_of_reference refer, "intern", pr_reference refer ++ str": Not a projection") in (* elimination of the first field from the projections *) let rec build_patt l m i acc = match l with | [] -> (i, acc) | (Some name) :: b-> (match m with | [] -> anomaly "Number of projections mismatch" | (_, regular)::tm -> let boolean = not regular in (match global_reference_of_reference refer with | ConstRef name' when eq_constant name name' -> if boolean && mode then user_err_loc (loc, "", str"No local fields allowed in a record construction.") else build_patt b tm (i + 1) (i, snd acc) (* we found it *) | _ -> build_patt b tm (if boolean&&mode then i else i + 1) (if boolean && mode then acc else fst acc, (i, ConstRef name) :: snd acc))) | None :: b-> (* we don't want anonymous fields *) if mode then user_err_loc (loc, "", str "This record contains anonymous fields.") else build_patt b m (i+1) acc (* anonymous arguments don't appear in m *) in let ind = record.Recordops.s_CONST in try (* insertion of Constextern.reference_global *) (record.Recordops.s_EXPECTEDPARAM, Qualid (loc, shortest_qualid_of_global Idset.empty (ConstructRef ind)), build_patt record.Recordops.s_PROJ record.Recordops.s_PROJKIND 1 (0,[])) with Not_found -> anomaly "Environment corruption for records." in (* now we want to have all fields of the pattern indexed by their place in the constructor *) let rec sf patts accpatt = match patts with | [] -> accpatt | p::q-> let refer, patt = p in let glob_refer = try global_reference_of_reference refer with |Not_found -> user_err_loc (loc_of_reference refer, "intern", str "The field \"" ++ pr_reference refer ++ str "\" does not exist.") in let rec add_patt l acc = match l with | [] -> user_err_loc (loc, "", str "This record contains fields of different records.") | (i, a) :: b-> if eq_gr glob_refer a then (i,List.rev_append acc l) else add_patt b ((i,a)::acc) in let (index, projs) = add_patt (snd accpatt) [] in sf q ((index, patt)::fst accpatt, projs) in let (unsorted_indexed_pattern, remainings) = sf rem ([first_index, value], list_proj) in (* we sort them *) let sorted_indexed_pattern = List.sort (fun (i, _) (j, _) -> compare i j) unsorted_indexed_pattern in (* a function to complete with wildcards *) let rec complete_list n l = if n <= 1 then l else complete_list (n-1) (completer n l) in (* a function to remove indice *) let rec clean_list l i acc = match l with | [] -> complete_list (max - i) acc | (k, p)::q-> clean_list q k (p::(complete_list (k - i) acc)) in Some (nparams, base_constructor, List.rev (clean_list sorted_indexed_pattern 0 [])) let rec intern_cases_pattern genv env (ids,asubst as aliases) pat = let intern_pat = intern_cases_pattern genv in match pat with | CPatAlias (loc, p, id) -> let aliases' = merge_aliases aliases id in intern_pat env aliases' p | CPatRecord (loc, l) -> let sorted_fields = sort_fields false loc l (fun _ l -> (CPatAtom (loc, None))::l) in let self_patt = match sorted_fields with | None -> CPatAtom (loc, None) | Some (_, head, pl) -> CPatCstr(loc, head, pl) in intern_pat env aliases self_patt | CPatCstr (loc, head, pl) | CPatCstrExpl (loc, head, pl) -> let c,idslpl1,pl2 = mustbe_constructor loc head intern_pat aliases pl env in check_constructor_length genv loc c idslpl1 pl2; let argscs2 = find_remaining_constructor_scopes idslpl1 pl2 c in let idslpl2 = List.map2 (fun x -> intern_pat {env with tmp_scope = x} ([],[])) argscs2 pl2 in let (ids',pll) = product_of_cases_patterns ids (idslpl1@idslpl2) in let pl' = List.map (fun (asubst,pl) -> (asubst, PatCstr (loc,c,pl,alias_of aliases))) pll in ids',pl' | CPatNotation (loc,"- _",([CPatPrim(_,Numeral p)],[])) when Bigint.is_strictly_pos p -> intern_pat env aliases (CPatPrim(loc,Numeral(Bigint.neg p))) | CPatNotation (_,"( _ )",([a],[])) -> intern_pat env aliases a | CPatNotation (loc, ntn, fullargs) -> let ntn,(args,argsl as fullargs) = contract_pat_notation ntn fullargs in let ((ids',c),df) = Notation.interp_notation loc ntn (env.tmp_scope,env.scopes) in let (ids',idsl',_) = split_by_type ids' in Dumpglob.dump_notation_location (patntn_loc loc fullargs ntn) ntn df; let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids' args in let substlist = List.map2 (fun (id,scl) a -> (id,(a,scl))) idsl' argsl in let ids'',pl = subst_cases_pattern loc (alias_of aliases) intern_pat (subst,substlist) env c in ids@ids'', pl | CPatPrim (loc, p) -> let a = alias_of aliases in let (c,_) = Notation.interp_prim_token_cases_pattern loc p a (env.tmp_scope,env.scopes) in (ids,[asubst,c]) | CPatDelimiters (loc, key, e) -> intern_pat {env with scopes=find_delimiters_scope loc key::env.scopes; tmp_scope = None} aliases e | CPatAtom (loc, Some head) -> (match maybe_constructor head intern_pat aliases env with | ConstrPat (c,idspl) -> check_constructor_length genv loc c idspl []; let (ids',pll) = product_of_cases_patterns ids idspl in (ids,List.map (fun (asubst,pl) -> (asubst, PatCstr (loc,c,pl,alias_of aliases))) pll) | VarPat id -> let ids,asubst = merge_aliases aliases id in (ids,[asubst, PatVar (loc,alias_of (ids,asubst))])) | CPatAtom (loc, None) -> (ids,[asubst, PatVar (loc,alias_of aliases)]) | CPatOr (loc, pl) -> assert (pl <> []); let pl' = List.map (intern_pat env aliases) pl in let (idsl,pl') = List.split pl' in let ids = List.hd idsl in check_or_pat_variables loc ids (List.tl idsl); (ids,List.flatten pl') (**********************************************************************) (* Utilities for application *) let merge_impargs l args = List.fold_right (fun a l -> match a with | (_,Some (_,(ExplByName id as x))) when List.exists (function (_,Some (_,y)) -> x=y | _ -> false) args -> l | _ -> a::l) l args let check_projection isproj nargs r = match (r,isproj) with | GRef (loc, ref), Some _ -> (try let n = Recordops.find_projection_nparams ref + 1 in if nargs <> n then user_err_loc (loc,"",str "Projection does not have the right number of explicit parameters."); with Not_found -> user_err_loc (loc,"",pr_global_env Idset.empty ref ++ str " is not a registered projection.")) | _, Some _ -> user_err_loc (loc_of_glob_constr r, "", str "Not a projection.") | _, None -> () let get_implicit_name n imps = Some (Impargs.name_of_implicit (List.nth imps (n-1))) let set_hole_implicit i b = function | GRef (loc,r) | GApp (_,GRef (loc,r),_) -> (loc,Evd.ImplicitArg (r,i,b)) | GVar (loc,id) -> (loc,Evd.ImplicitArg (VarRef id,i,b)) | _ -> anomaly "Only refs have implicits" let exists_implicit_name id = List.exists (fun imp -> is_status_implicit imp & id = name_of_implicit imp) let extract_explicit_arg imps args = let rec aux = function | [] -> [],[] | (a,e)::l -> let (eargs,rargs) = aux l in match e with | None -> (eargs,a::rargs) | Some (loc,pos) -> let id = match pos with | ExplByName id -> if not (exists_implicit_name id imps) then user_err_loc (loc,"",str "Wrong argument name: " ++ pr_id id ++ str "."); if List.mem_assoc id eargs then user_err_loc (loc,"",str "Argument name " ++ pr_id id ++ str " occurs more than once."); id | ExplByPos (p,_id) -> let id = try let imp = List.nth imps (p-1) in if not (is_status_implicit imp) then failwith "imp"; name_of_implicit imp with Failure _ (* "nth" | "imp" *) -> user_err_loc (loc,"",str"Wrong argument position: " ++ int p ++ str ".") in if List.mem_assoc id eargs then user_err_loc (loc,"",str"Argument at position " ++ int p ++ str " is mentioned more than once."); id in ((id,(loc,a))::eargs,rargs) in aux args (**********************************************************************) (* Main loop *) let internalize sigma globalenv env allow_patvar lvar c = let rec intern env = function | CRef ref as x -> let (c,imp,subscopes,l),_ = intern_applied_reference intern env (Environ.named_context globalenv) lvar [] ref in (match intern_impargs c env imp subscopes l with | [] -> c | l -> GApp (constr_loc x, c, l)) | CFix (loc, (locid,iddef), dl) -> let lf = List.map (fun ((_, id),_,_,_,_) -> id) dl in let dl = Array.of_list dl in let n = try list_index0 iddef lf with Not_found -> raise (InternalizationError (locid,UnboundFixName (false,iddef))) in let idl_temp = Array.map (fun (id,(n,order),bl,ty,_) -> let intern_ro_arg f = let before, after = split_at_annot bl n in let (env',rbefore) = List.fold_left intern_local_binder (env,[]) before in let ro = f (intern env') in let n' = Option.map (fun _ -> List.length rbefore) n in n', ro, List.fold_left intern_local_binder (env',rbefore) after in let n, ro, (env',rbl) = match order with | CStructRec -> intern_ro_arg (fun _ -> GStructRec) | CWfRec c -> intern_ro_arg (fun f -> GWfRec (f c)) | CMeasureRec (m,r) -> intern_ro_arg (fun f -> GMeasureRec (f m, Option.map f r)) in ((n, ro), List.rev rbl, intern_type env' ty, env')) dl in let idl = array_map2 (fun (_,_,_,_,bd) (a,b,c,env') -> let env'' = list_fold_left_i (fun i en name -> let (_,bli,tyi,_) = idl_temp.(i) in let fix_args = (List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli) in push_name_env lvar (impls_type_list ~args:fix_args tyi) en (dummy_loc, Name name)) 0 env' lf in (a,b,c,intern {env'' with tmp_scope = None} bd)) dl idl_temp in GRec (loc,GFix (Array.map (fun (ro,_,_,_) -> ro) idl,n), Array.of_list lf, Array.map (fun (_,bl,_,_) -> bl) idl, Array.map (fun (_,_,ty,_) -> ty) idl, Array.map (fun (_,_,_,bd) -> bd) idl) | CCoFix (loc, (locid,iddef), dl) -> let lf = List.map (fun ((_, id),_,_,_) -> id) dl in let dl = Array.of_list dl in let n = try list_index0 iddef lf with Not_found -> raise (InternalizationError (locid,UnboundFixName (true,iddef))) in let idl_tmp = Array.map (fun (id,bl,ty,_) -> let (env',rbl) = List.fold_left intern_local_binder (env,[]) bl in (List.rev rbl, intern_type env' ty,env')) dl in let idl = array_map2 (fun (_,_,_,bd) (b,c,env') -> let env'' = list_fold_left_i (fun i en name -> let (bli,tyi,_) = idl_tmp.(i) in let cofix_args = List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli in push_name_env lvar (impls_type_list ~args:cofix_args tyi) en (dummy_loc, Name name)) 0 env' lf in (b,c,intern {env'' with tmp_scope = None} bd)) dl idl_tmp in GRec (loc,GCoFix n, Array.of_list lf, Array.map (fun (bl,_,_) -> bl) idl, Array.map (fun (_,ty,_) -> ty) idl, Array.map (fun (_,_,bd) -> bd) idl) | CArrow (loc,c1,c2) -> GProd (loc, Anonymous, Explicit, intern_type env c1, intern_type env c2) | CProdN (loc,[],c2) -> intern_type env c2 | CProdN (loc,(nal,bk,ty)::bll,c2) -> iterate_prod loc env bk ty (CProdN (loc, bll, c2)) nal | CLambdaN (loc,[],c2) -> intern env c2 | CLambdaN (loc,(nal,bk,ty)::bll,c2) -> iterate_lam loc (reset_tmp_scope env) bk ty (CLambdaN (loc, bll, c2)) nal | CLetIn (loc,na,c1,c2) -> let inc1 = intern (reset_tmp_scope env) c1 in GLetIn (loc, snd na, inc1, intern (push_name_env lvar (impls_term_list inc1) env na) c2) | CNotation (loc,"- _",([CPrim (_,Numeral p)],[],[])) when Bigint.is_strictly_pos p -> intern env (CPrim (loc,Numeral (Bigint.neg p))) | CNotation (_,"( _ )",([a],[],[])) -> intern env a | CNotation (loc,ntn,args) -> intern_notation intern env lvar loc ntn args | CGeneralization (loc,b,a,c) -> intern_generalization intern env lvar loc b a c | CPrim (loc, p) -> fst (Notation.interp_prim_token loc p (env.tmp_scope,env.scopes)) | CDelimiters (loc, key, e) -> intern {env with tmp_scope = None; scopes = find_delimiters_scope loc key :: env.scopes} e | CAppExpl (loc, (isproj,ref), args) -> let (f,_,args_scopes,_),args = let args = List.map (fun a -> (a,None)) args in intern_applied_reference intern env (Environ.named_context globalenv) lvar args ref in check_projection isproj (List.length args) f; (* Rem: GApp(_,f,[]) stands for @f *) GApp (loc, f, intern_args env args_scopes (List.map fst args)) | CApp (loc, (isproj,f), args) -> let isproj,f,args = match f with (* Compact notations like "t.(f args') args" *) | CApp (_,(Some _,f), args') when isproj=None -> isproj,f,args'@args (* Don't compact "(f args') args" to resolve implicits separately *) | _ -> isproj,f,args in let (c,impargs,args_scopes,l),args = match f with | CRef ref -> intern_applied_reference intern env (Environ.named_context globalenv) lvar args ref | CNotation (loc,ntn,([],[],[])) -> let c = intern_notation intern env lvar loc ntn ([],[],[]) in find_appl_head_data c, args | x -> (intern env f,[],[],[]), args in let args = intern_impargs c env impargs args_scopes (merge_impargs l args) in check_projection isproj (List.length args) c; (match c with (* Now compact "(f args') args" *) | GApp (loc', f', args') -> GApp (join_loc loc' loc, f',args'@args) | _ -> GApp (loc, c, args)) | CRecord (loc, _, fs) -> let cargs = sort_fields true loc fs (fun k l -> CHole (loc, Some (Evd.QuestionMark (Evd.Define true))) :: l) in begin match cargs with | None -> user_err_loc (loc, "intern", str"No constructor inference.") | Some (n, constrname, args) -> let pars = list_make n (CHole (loc, None)) in let app = CAppExpl (loc, (None, constrname), List.rev_append pars args) in intern env app end | CCases (loc, sty, rtnpo, tms, eqns) -> let tms,env' = List.fold_right (fun citm (inds,env) -> let (tm,ind),nal = intern_case_item env citm in (tm,ind)::inds,List.fold_left (push_name_env lvar (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal) tms ([],env) in let rtnpo = Option.map (intern_type env') rtnpo in let eqns' = List.map (intern_eqn (List.length tms) env) eqns in GCases (loc, sty, rtnpo, tms, List.flatten eqns') | CLetTuple (loc, nal, (na,po), b, c) -> let env' = reset_tmp_scope env in let ((b',(na',_)),ids) = intern_case_item env' (b,(na,None)) in let p' = Option.map (fun p -> let env'' = List.fold_left (push_name_env lvar (Variable,[],[],[])) env ids in intern_type env'' p) po in GLetTuple (loc, List.map snd nal, (na', p'), b', intern (List.fold_left (push_name_env lvar (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal) c) | CIf (loc, c, (na,po), b1, b2) -> let env' = reset_tmp_scope env in let ((c',(na',_)),ids) = intern_case_item env' (c,(na,None)) in let p' = Option.map (fun p -> let env'' = List.fold_left (push_name_env lvar (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) ids in intern_type env'' p) po in GIf (loc, c', (na', p'), intern env b1, intern env b2) | CHole (loc, k) -> GHole (loc, match k with Some k -> k | None -> Evd.QuestionMark (Evd.Define true)) | CPatVar (loc, n) when allow_patvar -> GPatVar (loc, n) | CPatVar (loc, _) -> raise (InternalizationError (loc,IllegalMetavariable)) | CEvar (loc, n, l) -> GEvar (loc, n, Option.map (List.map (intern env)) l) | CSort (loc, s) -> GSort(loc,s) | CCast (loc, c1, CastConv (k, c2)) -> GCast (loc,intern env c1, CastConv (k, intern_type env c2)) | CCast (loc, c1, CastCoerce) -> GCast (loc,intern env c1, CastCoerce) and intern_type env = intern (set_type_scope env) and intern_local_binder env bind = intern_local_binder_aux intern intern_type lvar env bind (* Expands a multiple pattern into a disjunction of multiple patterns *) and intern_multiple_pattern env n (loc,pl) = let idsl_pll = List.map (intern_cases_pattern globalenv {env with tmp_scope = None} ([],[])) pl in check_number_of_pattern loc n pl; product_of_cases_patterns [] idsl_pll (* Expands a disjunction of multiple pattern *) and intern_disjunctive_multiple_pattern env loc n mpl = assert (mpl <> []); let mpl' = List.map (intern_multiple_pattern env n) mpl in let (idsl,mpl') = List.split mpl' in let ids = List.hd idsl in check_or_pat_variables loc ids (List.tl idsl); (ids,List.flatten mpl') (* Expands a pattern-matching clause [lhs => rhs] *) and intern_eqn n env (loc,lhs,rhs) = let eqn_ids,pll = intern_disjunctive_multiple_pattern env loc n lhs in (* Linearity implies the order in ids is irrelevant *) check_linearity lhs eqn_ids; let env_ids = List.fold_right Idset.add eqn_ids env.ids in List.map (fun (asubst,pl) -> let rhs = replace_vars_constr_expr asubst rhs in List.iter message_redundant_alias asubst; let rhs' = intern {env with ids = env_ids} rhs in (loc,eqn_ids,pl,rhs')) pll and intern_case_item env (tm,(na,t)) = let tm' = intern env tm in let ids,typ = match t with | Some t -> let tids = ids_of_cases_indtype t in let tids = List.fold_right Idset.add tids Idset.empty in let t = intern_type {env with ids = tids; tmp_scope = None} t in let loc,ind,l = match t with | GRef (loc,IndRef ind) -> (loc,ind,[]) | GApp (loc,GRef (_,IndRef ind),l) -> (loc,ind,l) | _ -> error_bad_inductive_type (loc_of_glob_constr t) in let nparams, nrealargs = inductive_nargs globalenv ind in let nindargs = nparams + nrealargs in if List.length l <> nindargs then error_wrong_numarg_inductive_loc loc globalenv ind nindargs; let nal = List.map (function | GHole (loc,_) -> loc,Anonymous | GVar (loc,id) -> loc,Name id | c -> user_err_loc (loc_of_glob_constr c,"",str "Not a name.")) l in let parnal,realnal = list_chop nparams nal in if List.exists (fun (_,na) -> na <> Anonymous) parnal then error_inductive_parameter_not_implicit loc; realnal, Some (loc,ind,nparams,List.map snd realnal) | None -> [], None in let na = match tm', na with | GVar (loc,id), None when not (List.mem_assoc id (snd lvar)) -> loc,Name id | GRef (loc, VarRef id), None -> loc,Name id | _, None -> dummy_loc,Anonymous | _, Some (loc,na) -> loc,na in (tm',(snd na,typ)), na::ids and iterate_prod loc2 env bk ty body nal = let default env bk = function | (loc1,na)::nal' as nal -> if nal' <> [] then check_capture loc1 ty na; let ty = intern_type env ty in let impls = impls_type_list ty in let env = List.fold_left (push_name_env lvar impls) env nal in List.fold_right (fun (loc,na) c -> GProd (join_loc loc loc2, na, bk, locate_if_isevar loc na ty, c)) nal (intern_type env body) | [] -> assert false in match bk with | Default b -> default env b nal | Generalized (b,b',t) -> let env, ibind = intern_generalized_binder intern_type lvar env [] (List.hd nal) b b' t ty in let body = intern_type env body in it_mkGProd ibind body and iterate_lam loc2 env bk ty body nal = let default env bk = function | (loc1,na)::nal' as nal -> if nal' <> [] then check_capture loc1 ty na; let ty = intern_type env ty in let impls = impls_type_list ty in let env = List.fold_left (push_name_env lvar impls) env nal in List.fold_right (fun (loc,na) c -> GLambda (join_loc loc loc2, na, bk, locate_if_isevar loc na ty, c)) nal (intern env body) | [] -> assert false in match bk with | Default b -> default env b nal | Generalized (b, b', t) -> let env, ibind = intern_generalized_binder intern_type lvar env [] (List.hd nal) b b' t ty in let body = intern env body in it_mkGLambda ibind body and intern_impargs c env l subscopes args = let l = select_impargs_size (List.length args) l in let eargs, rargs = extract_explicit_arg l args in if !parsing_explicit then if eargs <> [] then error "Arguments given by name or position not supported in explicit mode." else intern_args env subscopes rargs else let rec aux n impl subscopes eargs rargs = let (enva,subscopes') = apply_scope_env env subscopes in match (impl,rargs) with | (imp::impl', rargs) when is_status_implicit imp -> begin try let id = name_of_implicit imp in let (_,a) = List.assoc id eargs in let eargs' = List.remove_assoc id eargs in intern enva a :: aux (n+1) impl' subscopes' eargs' rargs with Not_found -> if rargs=[] & eargs=[] & not (maximal_insertion_of imp) then (* Less regular arguments than expected: complete *) (* with implicit arguments if maximal insertion is set *) [] else GHole (set_hole_implicit (n,get_implicit_name n l) (force_inference_of imp) c) :: aux (n+1) impl' subscopes' eargs rargs end | (imp::impl', a::rargs') -> intern enva a :: aux (n+1) impl' subscopes' eargs rargs' | (imp::impl', []) -> if eargs <> [] then (let (id,(loc,_)) = List.hd eargs in user_err_loc (loc,"",str "Not enough non implicit \ arguments to accept the argument bound to " ++ pr_id id ++ str".")); [] | ([], rargs) -> assert (eargs = []); intern_args env subscopes rargs in aux 1 l subscopes eargs rargs and intern_args env subscopes = function | [] -> [] | a::args -> let (enva,subscopes) = apply_scope_env env subscopes in (intern enva a) :: (intern_args env subscopes args) in try intern env c with InternalizationError (loc,e) -> user_err_loc (loc,"internalize", explain_internalization_error e) (**************************************************************************) (* Functions to translate constr_expr into glob_constr *) (**************************************************************************) let extract_ids env = List.fold_right Idset.add (Termops.ids_of_rel_context (Environ.rel_context env)) Idset.empty let intern_gen isarity sigma env ?(impls=empty_internalization_env) ?(allow_patvar=false) ?(ltacvars=([],[])) c = let tmp_scope = if isarity then Some Notation.type_scope else None in internalize sigma env {ids = extract_ids env; unb = false; tmp_scope = tmp_scope; scopes = []; impls = impls} allow_patvar (ltacvars, []) c let intern_constr sigma env c = intern_gen false sigma env c let intern_type sigma env c = intern_gen true sigma env c let intern_pattern globalenv patt = try intern_cases_pattern globalenv {ids = extract_ids globalenv; unb = false; tmp_scope = None; scopes = []; impls = empty_internalization_env} ([],[]) patt with InternalizationError (loc,e) -> user_err_loc (loc,"internalize",explain_internalization_error e) (*********************************************************************) (* Functions to parse and interpret constructions *) let interp_gen kind sigma env ?(impls=empty_internalization_env) ?(allow_patvar=false) ?(ltacvars=([],[])) c = let c = intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars sigma env c in Default.understand_gen kind sigma env c let interp_constr sigma env c = interp_gen (OfType None) sigma env c let interp_type sigma env ?(impls=empty_internalization_env) c = interp_gen IsType sigma env ~impls c let interp_casted_constr sigma env ?(impls=empty_internalization_env) c typ = interp_gen (OfType (Some typ)) sigma env ~impls c let interp_open_constr sigma env c = Default.understand_tcc sigma env (intern_constr sigma env c) let interp_open_constr_patvar sigma env c = let raw = intern_gen false sigma env c ~allow_patvar:true in let sigma = ref sigma in let evars = ref (Gmap.empty : (identifier,glob_constr) Gmap.t) in let rec patvar_to_evar r = match r with | GPatVar (loc,(_,id)) -> ( try Gmap.find id !evars with Not_found -> let ev = Evarutil.e_new_evar sigma env (Termops.new_Type()) in let ev = Evarutil.e_new_evar sigma env ev in let rev = GEvar (loc,(fst (Term.destEvar ev)),None) (*TODO*) in evars := Gmap.add id rev !evars; rev ) | _ -> map_glob_constr patvar_to_evar r in let raw = patvar_to_evar raw in Default.understand_tcc !sigma env raw let interp_constr_judgment sigma env c = Default.understand_judgment sigma env (intern_constr sigma env c) let interp_constr_evars_gen_impls ?evdref ?(fail_evar=true) env ?(impls=empty_internalization_env) kind c = let evdref = match evdref with | None -> ref Evd.empty | Some evdref -> evdref in let istype = kind = IsType in let c = intern_gen istype ~impls !evdref env c in let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:istype c in Default.understand_tcc_evars ~fail_evar evdref env kind c, imps let interp_casted_constr_evars_impls ?evdref ?(fail_evar=true) env ?(impls=empty_internalization_env) c typ = interp_constr_evars_gen_impls ?evdref ~fail_evar env ~impls (OfType (Some typ)) c let interp_type_evars_impls ?evdref ?(fail_evar=true) env ?(impls=empty_internalization_env) c = interp_constr_evars_gen_impls ?evdref ~fail_evar env IsType ~impls c let interp_constr_evars_impls ?evdref ?(fail_evar=true) env ?(impls=empty_internalization_env) c = interp_constr_evars_gen_impls ?evdref ~fail_evar env (OfType None) ~impls c let interp_constr_evars_gen evdref env ?(impls=empty_internalization_env) kind c = let c = intern_gen (kind=IsType) ~impls !evdref env c in Default.understand_tcc_evars evdref env kind c let interp_casted_constr_evars evdref env ?(impls=empty_internalization_env) c typ = interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c let interp_type_evars evdref env ?(impls=empty_internalization_env) c = interp_constr_evars_gen evdref env IsType ~impls c type ltac_sign = identifier list * unbound_ltac_var_map let intern_constr_pattern sigma env ?(as_type=false) ?(ltacvars=([],[])) c = let c = intern_gen as_type ~allow_patvar:true ~ltacvars sigma env c in pattern_of_glob_constr c let interp_aconstr ?(impls=empty_internalization_env) vars recvars a = let env = Global.env () in (* [vl] is intended to remember the scope of the free variables of [a] *) let vl = List.map (fun (id,typ) -> (id,(ref None,typ))) vars in let c = internalize Evd.empty (Global.env()) {ids = extract_ids env; unb = false; tmp_scope = None; scopes = []; impls = impls} false (([],[]),vl) a in (* Translate and check that [c] has all its free variables bound in [vars] *) let a = aconstr_of_glob_constr vars recvars c in (* Splits variables into those that are binding, bound, or both *) (* binding and bound *) let out_scope = function None -> None,[] | Some (a,l) -> a,l in let vars = List.map (fun (id,(sc,typ)) -> (id,(out_scope !sc,typ))) vl in (* Returns [a] and the ordered list of variables with their scopes *) vars, a (* Interpret binders and contexts *) let interp_binder sigma env na t = let t = intern_gen true sigma env t in let t' = locate_if_isevar (loc_of_glob_constr t) na t in Default.understand_type sigma env t' let interp_binder_evars evdref env na t = let t = intern_gen true !evdref env t in let t' = locate_if_isevar (loc_of_glob_constr t) na t in Default.understand_tcc_evars evdref env IsType t' open Environ open Term let my_intern_constr sigma env lvar acc c = internalize sigma env acc false lvar c let my_intern_type sigma env lvar acc c = my_intern_constr sigma env lvar (set_type_scope acc) c let intern_context global_level sigma env impl_env params = let lvar = (([],[]), []) in let lenv, bl = List.fold_left (intern_local_binder_aux ~global_level (my_intern_constr sigma env lvar) (my_intern_type sigma env lvar) lvar) ({ids = extract_ids env; unb = false; tmp_scope = None; scopes = []; impls = impl_env}, []) params in (lenv.impls, bl) let interp_rawcontext_gen understand_type understand_judgment env bl = let (env, par, _, impls) = List.fold_left (fun (env,params,n,impls) (na, k, b, t) -> match b with None -> let t' = locate_if_isevar (loc_of_glob_constr t) na t in let t = understand_type env t' in let d = (na,None,t) in let impls = if k = Implicit then let na = match na with Name n -> Some n | Anonymous -> None in (ExplByPos (n, na), (true, true, true)) :: impls else impls in (push_rel d env, d::params, succ n, impls) | Some b -> let c = understand_judgment env b in let d = (na, Some c.uj_val, Termops.refresh_universes c.uj_type) in (push_rel d env, d::params, succ n, impls)) (env,[],1,[]) (List.rev bl) in (env, par), impls let interp_context_gen understand_type understand_judgment ?(global_level=false) ?(impl_env=empty_internalization_env) sigma env params = let int_env,bl = intern_context global_level sigma env impl_env params in int_env, interp_rawcontext_gen understand_type understand_judgment env bl let interp_context ?(global_level=false) ?(impl_env=empty_internalization_env) sigma env params = interp_context_gen (Default.understand_type sigma) (Default.understand_judgment sigma) ~global_level ~impl_env sigma env params let interp_context_evars ?(global_level=false) ?(impl_env=empty_internalization_env) evdref env params = interp_context_gen (fun env t -> Default.understand_tcc_evars evdref env IsType t) (Default.understand_judgment_tcc evdref) ~global_level ~impl_env !evdref env params coq-8.4pl4/interp/doc.tex0000644000175000017500000000072612326224777014430 0ustar stephsteph \newpage \section*{The interpretation of Coq front abstract syntax of terms} \ocwsection \label{interp} This chapter describes the translation from \Coq\ context-dependent front abstract syntax of terms (\verb=front=) to and from the context-free, untyped, globalized form of constructions (\verb=glob_constr=). The modules translating back and forth the front abstract syntax are organized as follows. \bigskip \begin{center}\epsfig{file=interp.dep.ps}\end{center} coq-8.4pl4/interp/genarg.mli0000644000175000017500000003244312326224777015110 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* loc) -> 'a or_by_notation -> loc (** In globalize tactics, we need to keep the initial [constr_expr] to recompute in the environment by the effective calls to Intro, Inversion, etc The [constr_expr] field is [None] in TacDef though *) type glob_constr_and_expr = glob_constr * constr_expr option type open_constr_expr = unit * constr_expr type open_glob_constr = unit * glob_constr_and_expr type glob_constr_pattern_and_expr = glob_constr_and_expr * constr_pattern type 'a with_ebindings = 'a * open_constr bindings type intro_pattern_expr = | IntroOrAndPattern of or_and_intro_pattern_expr | IntroWildcard | IntroRewrite of bool | IntroIdentifier of identifier | IntroFresh of identifier | IntroForthcoming of bool | IntroAnonymous and or_and_intro_pattern_expr = (loc * intro_pattern_expr) list list val pr_intro_pattern : intro_pattern_expr located -> Pp.std_ppcmds val pr_or_and_intro_pattern : or_and_intro_pattern_expr -> Pp.std_ppcmds (** The route of a generic argument, from parsing to evaluation. In the following diagram, "object" can be tactic_expr, constr, tactic_arg, etc. {% \begin{%}verbatim{% }%} parsing in_raw out_raw char stream ---> raw_object ---> raw_object generic_argument -------+ encapsulation decaps| | V raw_object | globalization | V glob_object | encaps | in_glob | V glob_object generic_argument | out in out_glob | object <--- object generic_argument <--- object <--- glob_object <---+ | decaps encaps interp decaps | V effective use {% \end{%}verbatim{% }%} To distinguish between the uninterpreted (raw), globalized and interpreted worlds, we annotate the type [generic_argument] by a phantom argument which is either [constr_expr], [glob_constr] or [constr]. Transformation for each type : {% \begin{%}verbatim{% }%} tag raw open type cooked closed type BoolArgType bool bool IntArgType int int IntOrVarArgType int or_var int StringArgType string (parsed w/ "") string PreIdentArgType string (parsed w/o "") (vernac only) IdentArgType true identifier identifier IdentArgType false identifier (pattern_ident) identifier IntroPatternArgType intro_pattern_expr intro_pattern_expr VarArgType identifier located identifier RefArgType reference global_reference QuantHypArgType quantified_hypothesis quantified_hypothesis ConstrArgType constr_expr constr ConstrMayEvalArgType constr_expr may_eval constr OpenConstrArgType open_constr_expr open_constr ConstrWithBindingsArgType constr_expr with_bindings constr with_bindings BindingsArgType constr_expr bindings constr bindings List0ArgType of argument_type List1ArgType of argument_type OptArgType of argument_type ExtraArgType of string '_a '_b {% \end{%}verbatim{% }%} *) (** All of [rlevel], [glevel] and [tlevel] must be non convertible to ensure the injectivity of the type inference from type ['co generic_argument] to [('a,'co) abstract_argument_type]; this guarantees that, for 'co fixed, the type of out_gen is monomorphic over 'a, hence type-safe *) type rlevel type glevel type tlevel type ('a,'co) abstract_argument_type val rawwit_bool : (bool,rlevel) abstract_argument_type val globwit_bool : (bool,glevel) abstract_argument_type val wit_bool : (bool,tlevel) abstract_argument_type val rawwit_int : (int,rlevel) abstract_argument_type val globwit_int : (int,glevel) abstract_argument_type val wit_int : (int,tlevel) abstract_argument_type val rawwit_int_or_var : (int or_var,rlevel) abstract_argument_type val globwit_int_or_var : (int or_var,glevel) abstract_argument_type val wit_int_or_var : (int or_var,tlevel) abstract_argument_type val rawwit_string : (string,rlevel) abstract_argument_type val globwit_string : (string,glevel) abstract_argument_type val wit_string : (string,tlevel) abstract_argument_type val rawwit_pre_ident : (string,rlevel) abstract_argument_type val globwit_pre_ident : (string,glevel) abstract_argument_type val wit_pre_ident : (string,tlevel) abstract_argument_type val rawwit_intro_pattern : (intro_pattern_expr located,rlevel) abstract_argument_type val globwit_intro_pattern : (intro_pattern_expr located,glevel) abstract_argument_type val wit_intro_pattern : (intro_pattern_expr located,tlevel) abstract_argument_type val rawwit_ident : (identifier,rlevel) abstract_argument_type val globwit_ident : (identifier,glevel) abstract_argument_type val wit_ident : (identifier,tlevel) abstract_argument_type val rawwit_pattern_ident : (identifier,rlevel) abstract_argument_type val globwit_pattern_ident : (identifier,glevel) abstract_argument_type val wit_pattern_ident : (identifier,tlevel) abstract_argument_type val rawwit_ident_gen : bool -> (identifier,rlevel) abstract_argument_type val globwit_ident_gen : bool -> (identifier,glevel) abstract_argument_type val wit_ident_gen : bool -> (identifier,tlevel) abstract_argument_type val rawwit_var : (identifier located,rlevel) abstract_argument_type val globwit_var : (identifier located,glevel) abstract_argument_type val wit_var : (identifier,tlevel) abstract_argument_type val rawwit_ref : (reference,rlevel) abstract_argument_type val globwit_ref : (global_reference located or_var,glevel) abstract_argument_type val wit_ref : (global_reference,tlevel) abstract_argument_type val rawwit_quant_hyp : (quantified_hypothesis,rlevel) abstract_argument_type val globwit_quant_hyp : (quantified_hypothesis,glevel) abstract_argument_type val wit_quant_hyp : (quantified_hypothesis,tlevel) abstract_argument_type val rawwit_sort : (glob_sort,rlevel) abstract_argument_type val globwit_sort : (glob_sort,glevel) abstract_argument_type val wit_sort : (sorts,tlevel) abstract_argument_type val rawwit_constr : (constr_expr,rlevel) abstract_argument_type val globwit_constr : (glob_constr_and_expr,glevel) abstract_argument_type val wit_constr : (constr,tlevel) abstract_argument_type val rawwit_constr_may_eval : ((constr_expr,reference or_by_notation,constr_expr) may_eval,rlevel) abstract_argument_type val globwit_constr_may_eval : ((glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) may_eval,glevel) abstract_argument_type val wit_constr_may_eval : (constr,tlevel) abstract_argument_type val rawwit_open_constr_gen : bool * bool -> (open_constr_expr,rlevel) abstract_argument_type val globwit_open_constr_gen : bool * bool -> (open_glob_constr,glevel) abstract_argument_type val wit_open_constr_gen : bool * bool -> (open_constr,tlevel) abstract_argument_type val rawwit_open_constr : (open_constr_expr,rlevel) abstract_argument_type val globwit_open_constr : (open_glob_constr,glevel) abstract_argument_type val wit_open_constr : (open_constr,tlevel) abstract_argument_type val rawwit_casted_open_constr : (open_constr_expr,rlevel) abstract_argument_type val globwit_casted_open_constr : (open_glob_constr,glevel) abstract_argument_type val wit_casted_open_constr : (open_constr,tlevel) abstract_argument_type val rawwit_open_constr_wTC : (open_constr_expr,rlevel) abstract_argument_type val globwit_open_constr_wTC : (open_glob_constr,glevel) abstract_argument_type val wit_open_constr_wTC : (open_constr,tlevel) abstract_argument_type val rawwit_constr_with_bindings : (constr_expr with_bindings,rlevel) abstract_argument_type val globwit_constr_with_bindings : (glob_constr_and_expr with_bindings,glevel) abstract_argument_type val wit_constr_with_bindings : (constr with_bindings sigma,tlevel) abstract_argument_type val rawwit_bindings : (constr_expr bindings,rlevel) abstract_argument_type val globwit_bindings : (glob_constr_and_expr bindings,glevel) abstract_argument_type val wit_bindings : (constr bindings sigma,tlevel) abstract_argument_type val rawwit_red_expr : ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen,rlevel) abstract_argument_type val globwit_red_expr : ((glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen,glevel) abstract_argument_type val wit_red_expr : ((constr,evaluable_global_reference,constr_pattern) red_expr_gen,tlevel) abstract_argument_type val wit_list0 : ('a,'co) abstract_argument_type -> ('a list,'co) abstract_argument_type val wit_list1 : ('a,'co) abstract_argument_type -> ('a list,'co) abstract_argument_type val wit_opt : ('a,'co) abstract_argument_type -> ('a option,'co) abstract_argument_type val wit_pair : ('a,'co) abstract_argument_type -> ('b,'co) abstract_argument_type -> ('a * 'b,'co) abstract_argument_type (** ['a generic_argument] = (Sigma t:type. t[[constr/'a]]) *) type 'a generic_argument val fold_list0 : ('a generic_argument -> 'c -> 'c) -> 'a generic_argument -> 'c -> 'c val fold_list1 : ('a generic_argument -> 'c -> 'c) -> 'a generic_argument -> 'c -> 'c val fold_opt : ('a generic_argument -> 'c) -> 'c -> 'a generic_argument -> 'c val fold_pair : ('a generic_argument -> 'a generic_argument -> 'c) -> 'a generic_argument -> 'c (** [app_list0] fails if applied to an argument not of tag [List0 t] for some [t]; it's the responsability of the caller to ensure it *) val app_list0 : ('a generic_argument -> 'b generic_argument) -> 'a generic_argument -> 'b generic_argument val app_list1 : ('a generic_argument -> 'b generic_argument) -> 'a generic_argument -> 'b generic_argument val app_opt : ('a generic_argument -> 'b generic_argument) -> 'a generic_argument -> 'b generic_argument val app_pair : ('a generic_argument -> 'b generic_argument) -> ('a generic_argument -> 'b generic_argument) -> 'a generic_argument -> 'b generic_argument (** create a new generic type of argument: force to associate unique ML types at each of the three levels *) val create_arg : 'rawa option -> string -> ('a,tlevel) abstract_argument_type * ('globa,glevel) abstract_argument_type * ('rawa,rlevel) abstract_argument_type val exists_argtype : string -> bool type argument_type = (** Basic types *) | BoolArgType | IntArgType | IntOrVarArgType | StringArgType | PreIdentArgType | IntroPatternArgType | IdentArgType of bool | VarArgType | RefArgType (** Specific types *) | SortArgType | ConstrArgType | ConstrMayEvalArgType | QuantHypArgType | OpenConstrArgType of bool * bool | ConstrWithBindingsArgType | BindingsArgType | RedExprArgType | List0ArgType of argument_type | List1ArgType of argument_type | OptArgType of argument_type | PairArgType of argument_type * argument_type | ExtraArgType of string val genarg_tag : 'a generic_argument -> argument_type val unquote : ('a,'co) abstract_argument_type -> argument_type val in_gen : ('a,'co) abstract_argument_type -> 'a -> 'co generic_argument val out_gen : ('a,'co) abstract_argument_type -> 'co generic_argument -> 'a (** [in_generic] is used in combination with camlp4 [Gramext.action] magic [in_generic: !l:type, !a:argument_type -> |a|_l -> 'l generic_argument] where |a|_l is the interpretation of a at level l [in_generic] is not typable; we replace the second argument by an absurd type (with no introduction rule) *) type an_arg_of_this_type val in_generic : argument_type -> an_arg_of_this_type -> 'co generic_argument val default_empty_value : ('a,rlevel) abstract_argument_type -> 'a option coq-8.4pl4/interp/reserve.mli0000644000175000017500000000136712326224777015321 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* aconstr -> unit val find_reserved_type : identifier -> aconstr val anonymize_if_reserved : name -> glob_constr -> glob_constr coq-8.4pl4/interp/topconstr.mli0000644000175000017500000002530112326224777015673 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (identifier * identifier) list -> glob_constr -> aconstr (** Name of the special identifier used to encode recursive notations *) val ldots_var : identifier (** Equality of glob_constr (warning: only partially implemented) *) val eq_glob_constr : glob_constr -> glob_constr -> bool (** Re-interpret a notation as a glob_constr, taking care of binders *) val glob_constr_of_aconstr_with_binders : loc -> ('a -> name -> 'a * name) -> ('a -> aconstr -> glob_constr) -> 'a -> aconstr -> glob_constr val glob_constr_of_aconstr : loc -> aconstr -> glob_constr (** [match_aconstr] matches a glob_constr against a notation interpretation; raise [No_match] if the matching fails *) exception No_match val match_aconstr : bool -> glob_constr -> interpretation -> (glob_constr * subscopes) list * (glob_constr list * subscopes) list * (glob_decl list * subscopes) list val match_aconstr_cases_pattern : cases_pattern -> interpretation -> (cases_pattern * subscopes) list * (cases_pattern list * subscopes) list (** Substitution of kernel names in interpretation data *) val subst_interpretation : substitution -> interpretation -> interpretation (** {6 Concrete syntax for terms } *) type notation = string type explicitation = ExplByPos of int * identifier option | ExplByName of identifier type binder_kind = | Default of binding_kind | Generalized of binding_kind * binding_kind * bool (** Inner binding, outer bindings, typeclass-specific flag for implicit generalization of superclasses *) type abstraction_kind = AbsLambda | AbsPi type proj_flag = int option (** [Some n] = proj of the n-th visible argument *) type prim_token = Numeral of Bigint.bigint | String of string type cases_pattern_expr = | CPatAlias of loc * cases_pattern_expr * identifier | CPatCstr of loc * reference * cases_pattern_expr list | CPatCstrExpl of loc * reference * cases_pattern_expr list | CPatAtom of loc * reference option | CPatOr of loc * cases_pattern_expr list | CPatNotation of loc * notation * cases_pattern_notation_substitution | CPatPrim of loc * prim_token | CPatRecord of Util.loc * (reference * cases_pattern_expr) list | CPatDelimiters of loc * string * cases_pattern_expr and cases_pattern_notation_substitution = cases_pattern_expr list * (** for constr subterms *) cases_pattern_expr list list (** for recursive notations *) type constr_expr = | CRef of reference | CFix of loc * identifier located * fix_expr list | CCoFix of loc * identifier located * cofix_expr list | CArrow of loc * constr_expr * constr_expr | CProdN of loc * (name located list * binder_kind * constr_expr) list * constr_expr | CLambdaN of loc * (name located list * binder_kind * constr_expr) list * constr_expr | CLetIn of loc * name located * constr_expr * constr_expr | CAppExpl of loc * (proj_flag * reference) * constr_expr list | CApp of loc * (proj_flag * constr_expr) * (constr_expr * explicitation located option) list | CRecord of loc * constr_expr option * (reference * constr_expr) list | CCases of loc * case_style * constr_expr option * (constr_expr * (name located option * constr_expr option)) list * (loc * cases_pattern_expr list located list * constr_expr) list | CLetTuple of loc * name located list * (name located option * constr_expr option) * constr_expr * constr_expr | CIf of loc * constr_expr * (name located option * constr_expr option) * constr_expr * constr_expr | CHole of loc * Evd.hole_kind option | CPatVar of loc * (bool * patvar) | CEvar of loc * existential_key * constr_expr list option | CSort of loc * glob_sort | CCast of loc * constr_expr * constr_expr cast_type | CNotation of loc * notation * constr_notation_substitution | CGeneralization of loc * binding_kind * abstraction_kind option * constr_expr | CPrim of loc * prim_token | CDelimiters of loc * string * constr_expr and fix_expr = identifier located * (identifier located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr and cofix_expr = identifier located * local_binder list * constr_expr * constr_expr and recursion_order_expr = | CStructRec | CWfRec of constr_expr | CMeasureRec of constr_expr * constr_expr option (** measure, relation *) (** Anonymous defs allowed ?? *) and local_binder = | LocalRawDef of name located * constr_expr | LocalRawAssum of name located list * binder_kind * constr_expr and constr_notation_substitution = constr_expr list * (** for constr subterms *) constr_expr list list * (** for recursive notations *) local_binder list list (** for binders subexpressions *) type typeclass_constraint = name located * binding_kind * constr_expr and typeclass_context = typeclass_constraint list type constr_pattern_expr = constr_expr (** Utilities on constr_expr *) val constr_loc : constr_expr -> loc val cases_pattern_expr_loc : cases_pattern_expr -> loc val local_binders_loc : local_binder list -> loc val replace_vars_constr_expr : (identifier * identifier) list -> constr_expr -> constr_expr val free_vars_of_constr_expr : constr_expr -> Idset.t val occur_var_constr_expr : identifier -> constr_expr -> bool val default_binder_kind : binder_kind (** Specific function for interning "in indtype" syntax of "match" *) val ids_of_cases_indtype : constr_expr -> identifier list val mkIdentC : identifier -> constr_expr val mkRefC : reference -> constr_expr val mkAppC : constr_expr * constr_expr list -> constr_expr val mkCastC : constr_expr * constr_expr cast_type -> constr_expr val mkLambdaC : name located list * binder_kind * constr_expr * constr_expr -> constr_expr val mkLetInC : name located * constr_expr * constr_expr -> constr_expr val mkProdC : name located list * binder_kind * constr_expr * constr_expr -> constr_expr val coerce_reference_to_id : reference -> identifier val coerce_to_id : constr_expr -> identifier located val coerce_to_name : constr_expr -> name located val split_at_annot : local_binder list -> identifier located option -> local_binder list * local_binder list val abstract_constr_expr : constr_expr -> local_binder list -> constr_expr val prod_constr_expr : constr_expr -> local_binder list -> constr_expr (** Same as [abstract_constr_expr] and [prod_constr_expr], with location *) val mkCLambdaN : loc -> local_binder list -> constr_expr -> constr_expr val mkCProdN : loc -> local_binder list -> constr_expr -> constr_expr (** For binders parsing *) (** With let binders *) val names_of_local_binders : local_binder list -> name located list (** Does not take let binders into account *) val names_of_local_assums : local_binder list -> name located list (** Used in typeclasses *) val fold_constr_expr_with_binders : (identifier -> 'a -> 'a) -> ('a -> 'b -> constr_expr -> 'b) -> 'a -> 'b -> constr_expr -> 'b (** Used in correctness and interface; absence of var capture not guaranteed in pattern-matching clauses and in binders of the form [x,y:T(x)] *) val map_constr_expr_with_binders : (identifier -> 'a -> 'a) -> ('a -> constr_expr -> constr_expr) -> 'a -> constr_expr -> constr_expr (** Concrete syntax for modules and module types *) type with_declaration_ast = | CWith_Module of identifier list located * qualid located | CWith_Definition of identifier list located * constr_expr type module_ast = | CMident of qualid located | CMapply of loc * module_ast * module_ast | CMwith of loc * module_ast * with_declaration_ast val ntn_loc : Util.loc -> constr_notation_substitution -> string -> (int * int) list val patntn_loc : Util.loc -> cases_pattern_notation_substitution -> string -> (int * int) list (** For cases pattern parsing errors *) val error_invalid_pattern_notation : Util.loc -> 'a coq-8.4pl4/interp/modintern.ml0000644000175000017500000001354712326224777015477 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a val error_not_a_functor : module_struct_entry -> 'a val error_not_equal : module_path -> module_path -> 'a val error_result_must_be_signature : unit -> 'a oval error_not_a_modtype_loc : loc -> string -> 'a val error_not_a_module_loc : loc -> string -> 'a val error_not_a_module_or_modtype_loc : loc -> string -> 'a val error_with_in_module : unit -> 'a val error_application_to_module_type : unit -> 'a *) let error_result_must_be_signature () = error "The result module type must be a signature." let error_not_a_modtype_loc loc s = Compat.Loc.raise loc (Modops.ModuleTypingError (Modops.NotAModuleType s)) let error_not_a_module_loc loc s = Compat.Loc.raise loc (Modops.ModuleTypingError (Modops.NotAModule s)) let error_not_a_module_nor_modtype_loc loc s = Compat.Loc.raise loc (ModuleInternalizationError (NotAModuleNorModtype s)) let error_incorrect_with_in_module loc = Compat.Loc.raise loc (ModuleInternalizationError IncorrectWithInModule) let error_application_to_module_type loc = Compat.Loc.raise loc (ModuleInternalizationError IncorrectModuleApplication) let rec make_mp mp = function [] -> mp | h::tl -> make_mp (MPdot(mp, label_of_id h)) tl (* (* Since module components are not put in the nametab we try to locate the module prefix *) exception BadRef let lookup_qualid (modtype:bool) qid = let rec make_mp mp = function [] -> mp | h::tl -> make_mp (MPdot(mp, label_of_id h)) tl in let rec find_module_prefix dir n = if n<0 then raise Not_found; let dir',dir'' = list_chop n dir in let id',dir''' = match dir'' with | hd::tl -> hd,tl | _ -> anomaly "This list should not be empty!" in let qid' = make_qualid dir' id' in try match Nametab.locate qid' with | ModRef mp -> mp,dir''' | _ -> raise BadRef with Not_found -> find_module_prefix dir (pred n) in try Nametab.locate qid with Not_found -> let (dir,id) = repr_qualid qid in let pref_mp,dir' = find_module_prefix dir (List.length dir - 1) in let mp = List.fold_left (fun mp id -> MPdot (mp, label_of_id id)) pref_mp dir' in if modtype then ModTypeRef (make_ln mp (label_of_id id)) else ModRef (MPdot (mp,label_of_id id)) *) (* Search for the head of [qid] in [binders]. If found, returns the module_path/kernel_name created from the dirpath and the basename. Searches Nametab otherwise. *) let lookup_module (loc,qid) = try let mp = Nametab.locate_module qid in Dumpglob.dump_modref loc mp "modtype"; mp with | Not_found -> error_not_a_module_loc loc (string_of_qualid qid) let lookup_modtype (loc,qid) = try let mp = Nametab.locate_modtype qid in Dumpglob.dump_modref loc mp "mod"; mp with | Not_found -> error_not_a_modtype_loc loc (string_of_qualid qid) let lookup_module_or_modtype (loc,qid) = try let mp = Nametab.locate_module qid in Dumpglob.dump_modref loc mp "modtype"; (mp,true) with Not_found -> try let mp = Nametab.locate_modtype qid in Dumpglob.dump_modref loc mp "mod"; (mp,false) with Not_found -> error_not_a_module_nor_modtype_loc loc (string_of_qualid qid) let transl_with_decl env = function | CWith_Module ((_,fqid),qid) -> With_Module (fqid,lookup_module qid) | CWith_Definition ((_,fqid),c) -> With_Definition (fqid,interp_constr Evd.empty env c) let loc_of_module = function | CMident (loc,_) | CMapply (loc,_,_) | CMwith (loc,_,_) -> loc let check_module_argument_is_path me' = function | CMident _ -> () | (CMapply (loc,_,_) | CMwith (loc,_,_)) -> Compat.Loc.raise loc (Modops.ModuleTypingError (Modops.ApplicationToNotPath me')) let rec interp_modexpr env = function | CMident qid -> MSEident (lookup_module qid) | CMapply (_,me1,me2) -> let me1' = interp_modexpr env me1 in let me2' = interp_modexpr env me2 in check_module_argument_is_path me2' me2; MSEapply(me1',me2') | CMwith (loc,_,_) -> error_incorrect_with_in_module loc let rec interp_modtype env = function | CMident qid -> MSEident (lookup_modtype qid) | CMapply (_,mty1,me) -> let mty' = interp_modtype env mty1 in let me' = interp_modexpr env me in check_module_argument_is_path me' me; MSEapply(mty',me') | CMwith (_,mty,decl) -> let mty = interp_modtype env mty in let decl = transl_with_decl env decl in MSEwith(mty,decl) let rec interp_modexpr_or_modtype env = function | CMident qid -> let (mp,ismod) = lookup_module_or_modtype qid in (MSEident mp, ismod) | CMapply (_,me1,me2) -> let me1',ismod1 = interp_modexpr_or_modtype env me1 in let me2',ismod2 = interp_modexpr_or_modtype env me2 in check_module_argument_is_path me2' me2; if not ismod2 then error_application_to_module_type (loc_of_module me2); (MSEapply (me1',me2'), ismod1) | CMwith (loc,me,decl) -> let me,ismod = interp_modexpr_or_modtype env me in let decl = transl_with_decl env decl in if ismod then error_incorrect_with_in_module loc; (MSEwith(me,decl), ismod) coq-8.4pl4/interp/dumpglob.ml0000644000175000017500000002013412326224777015277 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* open_glob_file (Filename.chop_extension vfile ^ ".glob"); output_string !glob_file "DIGEST "; output_string !glob_file (Digest.to_hex (Digest.file vfile)); output_char !glob_file '\n' | File f -> open_glob_file f; output_string !glob_file "DIGEST NO\n" | NoGlob | StdOut -> () let end_dump_glob () = match !glob_output with | MultFiles | File _ -> close_glob_file () | NoGlob | StdOut -> () let previous_state = ref MultFiles let pause () = previous_state := !glob_output; glob_output := NoGlob let continue () = glob_output := !previous_state type coqdoc_state = Lexer.location_table let coqdoc_freeze = Lexer.location_table let coqdoc_unfreeze = Lexer.restore_location_table open Decl_kinds let type_of_logical_kind = function | IsDefinition def -> (match def with | Definition -> "def" | Coercion -> "coe" | SubClass -> "subclass" | CanonicalStructure -> "canonstruc" | Example -> "ex" | Fixpoint -> "def" | CoFixpoint -> "def" | Scheme -> "scheme" | StructureComponent -> "proj" | IdentityCoercion -> "coe" | Instance -> "inst" | Method -> "meth") | IsAssumption a -> (match a with | Definitional -> "defax" | Logical -> "prfax" | Conjectural -> "prfax") | IsProof th -> (match th with | Theorem | Lemma | Fact | Remark | Property | Proposition | Corollary -> "thm") let type_of_global_ref gr = if Typeclasses.is_class gr then "class" else match gr with | Libnames.ConstRef cst -> type_of_logical_kind (Decls.constant_kind cst) | Libnames.VarRef v -> "var" ^ type_of_logical_kind (Decls.variable_kind v) | Libnames.IndRef ind -> let (mib,oib) = Inductive.lookup_mind_specif (Global.env ()) ind in if mib.Declarations.mind_record then if mib.Declarations.mind_finite then "rec" else "corec" else if mib.Declarations.mind_finite then "ind" else "coind" | Libnames.ConstructRef _ -> "constr" let remove_sections dir = if Libnames.is_dirpath_prefix_of dir (Lib.cwd ()) then (* Not yet (fully) discharged *) Libnames.pop_dirpath_n (Lib.sections_depth ()) (Lib.cwd ()) else (* Theorem/Lemma outside its outer section of definition *) dir let interval loc = let loc1,loc2 = Util.unloc loc in loc1, loc2-1 let dump_ref loc filepath modpath ident ty = let bl,el = interval loc in dump_string (Printf.sprintf "R%d:%d %s %s %s %s\n" bl el filepath modpath ident ty) let add_glob_gen loc sp lib_dp ty = if dump () then let mod_dp,id = Libnames.repr_path sp in let mod_dp = remove_sections mod_dp in let mod_dp_trunc = Libnames.drop_dirpath_prefix lib_dp mod_dp in let filepath = Names.string_of_dirpath lib_dp in let modpath = Names.string_of_dirpath mod_dp_trunc in let ident = Names.string_of_id id in dump_ref loc filepath modpath ident ty let add_glob loc ref = if dump () && loc <> Util.dummy_loc then let sp = Nametab.path_of_global ref in let lib_dp = Lib.library_part ref in let ty = type_of_global_ref ref in add_glob_gen loc sp lib_dp ty let mp_of_kn kn = let mp,sec,l = Names.repr_kn kn in Names.MPdot (mp,l) let add_glob_kn loc kn = if dump () && loc <> Util.dummy_loc then let sp = Nametab.path_of_syndef kn in let lib_dp = Lib.dp_of_mp (mp_of_kn kn) in add_glob_gen loc sp lib_dp "syndef" let dump_binding loc id = () let dump_definition (loc, id) sec s = let bl,el = interval loc in dump_string (Printf.sprintf "%s %d:%d %s %s\n" s bl el (Names.string_of_dirpath (Lib.current_dirpath sec)) (Names.string_of_id id)) let dump_reference loc modpath ident ty = let bl,el = interval loc in dump_string (Printf.sprintf "R%d:%d %s %s %s %s\n" bl el (Names.string_of_dirpath (Lib.library_dp ())) modpath ident ty) let dump_constraint ((loc, n), _, _) sec ty = match n with | Names.Name id -> dump_definition (loc, id) sec ty | Names.Anonymous -> () let dump_modref loc mp ty = if dump () then let (dp, l) = Lib.split_modpath mp in let l = if l = [] then l else Util.list_drop_last l in let fp = Names.string_of_dirpath dp in let mp = Names.string_of_dirpath (Names.make_dirpath l) in let bl,el = interval loc in dump_string (Printf.sprintf "R%d:%d %s %s %s %s\n" bl el fp mp "<>" ty) let dump_moddef loc mp ty = if dump () then let bl,el = interval loc in let (dp, l) = Lib.split_modpath mp in let mp = Names.string_of_dirpath (Names.make_dirpath l) in dump_string (Printf.sprintf "%s %d:%d %s %s\n" ty bl el "<>" mp) let dump_libref loc dp ty = let bl,el = interval loc in dump_string (Printf.sprintf "R%d:%d %s <> <> %s\n" bl el (Names.string_of_dirpath dp) ty) let cook_notation df sc = (* We encode notations so that they are space-free and still human-readable *) (* - all spaces are replaced by _ *) (* - all _ denoting a non-terminal symbol are replaced by x *) (* - all terminal tokens are surrounded by single quotes, including '_' *) (* which already denotes terminal _ *) (* - all single quotes in terminal tokens are doubled *) (* - characters < 32 are represented by '^A, '^B, '^C, etc *) (* The output is decoded in function Index.prepare_entry of coqdoc *) let ntn = String.make (String.length df * 3) '_' in let j = ref 0 in let l = String.length df - 1 in let i = ref 0 in while !i <= l do assert (df.[!i] <> ' '); if df.[!i] = '_' && (!i = l || df.[!i+1] = ' ') then (* Next token is a non-terminal *) (ntn.[!j] <- 'x'; incr j; incr i) else begin (* Next token is a terminal *) ntn.[!j] <- '\''; incr j; while !i <= l && df.[!i] <> ' ' do if df.[!i] < ' ' then let c = char_of_int (int_of_char 'A' + int_of_char df.[!i] - 1) in (String.blit ("'^" ^ String.make 1 c) 0 ntn !j 3; j := !j+3; incr i) else begin if df.[!i] = '\'' then (ntn.[!j] <- '\''; incr j); ntn.[!j] <- df.[!i]; incr j; incr i end done; ntn.[!j] <- '\''; incr j end; if !i <= l then (ntn.[!j] <- '_'; incr j; incr i) done; let df = String.sub ntn 0 !j in match sc with Some sc -> ":" ^ sc ^ ":" ^ df | _ -> "::" ^ df let dump_notation (loc,(df,_)) sc sec = (* We dump the location of the opening '"' *) dump_string (Printf.sprintf "not %d %s %s\n" (fst (Util.unloc loc)) (Names.string_of_dirpath (Lib.current_dirpath sec)) (cook_notation df sc)) let dump_notation_location posl df (((path,secpath),_),sc) = if dump () then let path = Names.string_of_dirpath path in let secpath = Names.string_of_dirpath secpath in let df = cook_notation df sc in List.iter (fun (bl,el) -> dump_string(Printf.sprintf "R%d:%d %s %s %s not\n" bl el path secpath df)) posl coq-8.4pl4/interp/constrintern.mli0000644000175000017500000001612512326224777016374 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* var_internalization_type -> types -> Impargs.manual_explicitation list -> var_internalization_data val compute_internalization_env : env -> var_internalization_type -> identifier list -> types list -> Impargs.manual_explicitation list list -> internalization_env type ltac_sign = identifier list * unbound_ltac_var_map type glob_binder = (name * binding_kind * glob_constr option * glob_constr) (** {6 Internalization performs interpretation of global names and notations } *) val intern_constr : evar_map -> env -> constr_expr -> glob_constr val intern_type : evar_map -> env -> constr_expr -> glob_constr val intern_gen : bool -> evar_map -> env -> ?impls:internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign -> constr_expr -> glob_constr val intern_pattern : env -> cases_pattern_expr -> Names.identifier list * ((Names.identifier * Names.identifier) list * Glob_term.cases_pattern) list val intern_context : bool -> evar_map -> env -> internalization_env -> local_binder list -> internalization_env * glob_binder list (** {6 Composing internalization with pretyping } *) (** Main interpretation function *) val interp_gen : typing_constraint -> evar_map -> env -> ?impls:internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign -> constr_expr -> constr (** Particular instances *) val interp_constr : evar_map -> env -> constr_expr -> constr val interp_type : evar_map -> env -> ?impls:internalization_env -> constr_expr -> types val interp_open_constr : evar_map -> env -> constr_expr -> evar_map * constr val interp_open_constr_patvar : evar_map -> env -> constr_expr -> evar_map * constr val interp_casted_constr : evar_map -> env -> ?impls:internalization_env -> constr_expr -> types -> constr (** Accepting evars and giving back the manual implicits in addition. *) val interp_casted_constr_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool -> env -> ?impls:internalization_env -> constr_expr -> types -> constr * Impargs.manual_implicits val interp_type_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool -> env -> ?impls:internalization_env -> constr_expr -> types * Impargs.manual_implicits val interp_constr_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool -> env -> ?impls:internalization_env -> constr_expr -> constr * Impargs.manual_implicits val interp_casted_constr_evars : evar_map ref -> env -> ?impls:internalization_env -> constr_expr -> types -> constr val interp_type_evars : evar_map ref -> env -> ?impls:internalization_env -> constr_expr -> types (** {6 Build a judgment } *) val interp_constr_judgment : evar_map -> env -> constr_expr -> unsafe_judgment (** Interprets constr patterns *) val intern_constr_pattern : evar_map -> env -> ?as_type:bool -> ?ltacvars:ltac_sign -> constr_pattern_expr -> patvar list * constr_pattern (** Raise Not_found if syndef not bound to a name and error if unexisting ref *) val intern_reference : reference -> global_reference (** Expands abbreviations (syndef); raise an error if not existing *) val interp_reference : ltac_sign -> reference -> glob_constr (** Interpret binders *) val interp_binder : evar_map -> env -> name -> constr_expr -> types val interp_binder_evars : evar_map ref -> env -> name -> constr_expr -> types (** Interpret contexts: returns extended env and context *) val interp_context_gen : (env -> glob_constr -> types) -> (env -> glob_constr -> unsafe_judgment) -> ?global_level:bool -> ?impl_env:internalization_env -> evar_map -> env -> local_binder list -> internalization_env * ((env * rel_context) * Impargs.manual_implicits) val interp_context : ?global_level:bool -> ?impl_env:internalization_env -> evar_map -> env -> local_binder list -> internalization_env * ((env * rel_context) * Impargs.manual_implicits) val interp_context_evars : ?global_level:bool -> ?impl_env:internalization_env -> evar_map ref -> env -> local_binder list -> internalization_env * ((env * rel_context) * Impargs.manual_implicits) (** Locating references of constructions, possibly via a syntactic definition (these functions do not modify the glob file) *) val is_global : identifier -> bool val construct_reference : named_context -> identifier -> constr val global_reference : identifier -> constr val global_reference_in_absolute_module : dir_path -> identifier -> constr (** Interprets a term as the left-hand side of a notation; the boolean list is a set and this set is [true] for a variable occurring in term position, [false] for a variable occurring in binding position; [true;false] if in both kinds of position *) val interp_aconstr : ?impls:internalization_env -> (identifier * notation_var_internalization_type) list -> (identifier * identifier) list -> constr_expr -> (identifier * (subscopes * notation_var_internalization_type)) list * aconstr (** Globalization options *) val parsing_explicit : bool ref (** Globalization leak for Grammar *) val for_grammar : ('a -> 'b) -> 'a -> 'b coq-8.4pl4/interp/implicit_quantifiers.mli0000644000175000017500000000417112326224777020066 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (identifier located) list option -> unit val ids_of_list : identifier list -> Idset.t val destClassApp : constr_expr -> loc * reference * constr_expr list val destClassAppExpl : constr_expr -> loc * reference * (constr_expr * explicitation located option) list (** Fragile, should be used only for construction a set of identifiers to avoid *) val free_vars_of_constr_expr : constr_expr -> ?bound:Idset.t -> identifier list -> identifier list val free_vars_of_binders : ?bound:Idset.t -> Names.identifier list -> local_binder list -> Idset.t * Names.identifier list (** Returns the generalizable free ids in left-to-right order with the location of their first occurence *) val generalizable_vars_of_glob_constr : ?bound:Idset.t -> ?allowed:Idset.t -> glob_constr -> (Names.identifier * loc) list val make_fresh : Names.Idset.t -> Environ.env -> identifier -> identifier val implicits_of_glob_constr : ?with_products:bool -> Glob_term.glob_constr -> Impargs.manual_implicits val combine_params_freevar : Names.Idset.t -> (global_reference * bool) option * (Names.name * Term.constr option * Term.types) -> Topconstr.constr_expr * Names.Idset.t val implicit_application : Idset.t -> ?allow_partial:bool -> (Names.Idset.t -> (global_reference * bool) option * (Names.name * Term.constr option * Term.types) -> Topconstr.constr_expr * Names.Idset.t) -> constr_expr -> constr_expr * Idset.t coq-8.4pl4/interp/genarg.ml0000644000175000017500000002036012326224777014732 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* f c | ByNotation (loc,s,_) -> loc type glob_constr_and_expr = glob_constr * constr_expr option type open_constr_expr = unit * constr_expr type open_glob_constr = unit * glob_constr_and_expr type glob_constr_pattern_and_expr = glob_constr_and_expr * Pattern.constr_pattern type 'a with_ebindings = 'a * open_constr bindings (* Dynamics but tagged by a type expression *) type 'a generic_argument = argument_type * Obj.t type rlevel type glevel type tlevel type intro_pattern_expr = | IntroOrAndPattern of or_and_intro_pattern_expr | IntroWildcard | IntroRewrite of bool | IntroIdentifier of identifier | IntroFresh of identifier | IntroForthcoming of bool | IntroAnonymous and or_and_intro_pattern_expr = (loc * intro_pattern_expr) list list let rec pr_intro_pattern (_,pat) = match pat with | IntroOrAndPattern pll -> pr_or_and_intro_pattern pll | IntroWildcard -> str "_" | IntroRewrite true -> str "->" | IntroRewrite false -> str "<-" | IntroIdentifier id -> pr_id id | IntroFresh id -> str "?" ++ pr_id id | IntroForthcoming true -> str "*" | IntroForthcoming false -> str "**" | IntroAnonymous -> str "?" and pr_or_and_intro_pattern = function | [pl] -> str "(" ++ hv 0 (prlist_with_sep pr_comma pr_intro_pattern pl) ++ str ")" | pll -> str "[" ++ hv 0 (prlist_with_sep pr_bar (prlist_with_sep spc pr_intro_pattern) pll) ++ str "]" let rawwit_bool = BoolArgType let globwit_bool = BoolArgType let wit_bool = BoolArgType let rawwit_int = IntArgType let globwit_int = IntArgType let wit_int = IntArgType let rawwit_int_or_var = IntOrVarArgType let globwit_int_or_var = IntOrVarArgType let wit_int_or_var = IntOrVarArgType let rawwit_string = StringArgType let globwit_string = StringArgType let wit_string = StringArgType let rawwit_pre_ident = PreIdentArgType let globwit_pre_ident = PreIdentArgType let wit_pre_ident = PreIdentArgType let rawwit_intro_pattern = IntroPatternArgType let globwit_intro_pattern = IntroPatternArgType let wit_intro_pattern = IntroPatternArgType let rawwit_ident_gen b = IdentArgType b let globwit_ident_gen b = IdentArgType b let wit_ident_gen b = IdentArgType b let rawwit_ident = rawwit_ident_gen true let globwit_ident = globwit_ident_gen true let wit_ident = wit_ident_gen true let rawwit_pattern_ident = rawwit_ident_gen false let globwit_pattern_ident = globwit_ident_gen false let wit_pattern_ident = wit_ident_gen false let rawwit_var = VarArgType let globwit_var = VarArgType let wit_var = VarArgType let rawwit_ref = RefArgType let globwit_ref = RefArgType let wit_ref = RefArgType let rawwit_quant_hyp = QuantHypArgType let globwit_quant_hyp = QuantHypArgType let wit_quant_hyp = QuantHypArgType let rawwit_sort = SortArgType let globwit_sort = SortArgType let wit_sort = SortArgType let rawwit_constr = ConstrArgType let globwit_constr = ConstrArgType let wit_constr = ConstrArgType let rawwit_constr_may_eval = ConstrMayEvalArgType let globwit_constr_may_eval = ConstrMayEvalArgType let wit_constr_may_eval = ConstrMayEvalArgType let rawwit_open_constr_gen (b1,b2) = OpenConstrArgType (b1,b2) let globwit_open_constr_gen (b1,b2) = OpenConstrArgType (b1,b2) let wit_open_constr_gen (b1,b2) = OpenConstrArgType (b1,b2) let rawwit_open_constr = rawwit_open_constr_gen (false,false) let globwit_open_constr = globwit_open_constr_gen (false,false) let wit_open_constr = wit_open_constr_gen (false,false) let rawwit_casted_open_constr = rawwit_open_constr_gen (true,false) let globwit_casted_open_constr = globwit_open_constr_gen (true,false) let wit_casted_open_constr = wit_open_constr_gen (true,false) let rawwit_open_constr_wTC = rawwit_open_constr_gen (false,true) let globwit_open_constr_wTC = globwit_open_constr_gen (false,true) let wit_open_constr_wTC = wit_open_constr_gen (false,true) let rawwit_constr_with_bindings = ConstrWithBindingsArgType let globwit_constr_with_bindings = ConstrWithBindingsArgType let wit_constr_with_bindings = ConstrWithBindingsArgType let rawwit_bindings = BindingsArgType let globwit_bindings = BindingsArgType let wit_bindings = BindingsArgType let rawwit_red_expr = RedExprArgType let globwit_red_expr = RedExprArgType let wit_red_expr = RedExprArgType let wit_list0 t = List0ArgType t let wit_list1 t = List1ArgType t let wit_opt t = OptArgType t let wit_pair t1 t2 = PairArgType (t1,t2) let in_gen t o = (t,Obj.repr o) let out_gen t (t',o) = if t = t' then Obj.magic o else failwith "out_gen" let genarg_tag (s,_) = s let fold_list0 f = function | (List0ArgType t, l) -> List.fold_right (fun x -> f (in_gen t x)) (Obj.magic l) | _ -> failwith "Genarg: not a list0" let fold_list1 f = function | (List1ArgType t, l) -> List.fold_right (fun x -> f (in_gen t x)) (Obj.magic l) | _ -> failwith "Genarg: not a list1" let fold_opt f a = function | (OptArgType t, l) -> (match Obj.magic l with | None -> a | Some x -> f (in_gen t x)) | _ -> failwith "Genarg: not a opt" let fold_pair f = function | (PairArgType (t1,t2), l) -> let (x1,x2) = Obj.magic l in f (in_gen t1 x1) (in_gen t2 x2) | _ -> failwith "Genarg: not a pair" let app_list0 f = function | (List0ArgType t as u, l) -> let o = Obj.magic l in (u, Obj.repr (List.map (fun x -> out_gen t (f (in_gen t x))) o)) | _ -> failwith "Genarg: not a list0" let app_list1 f = function | (List1ArgType t as u, l) -> let o = Obj.magic l in (u, Obj.repr (List.map (fun x -> out_gen t (f (in_gen t x))) o)) | _ -> failwith "Genarg: not a list1" let app_opt f = function | (OptArgType t as u, l) -> let o = Obj.magic l in (u, Obj.repr (Option.map (fun x -> out_gen t (f (in_gen t x))) o)) | _ -> failwith "Genarg: not an opt" let app_pair f1 f2 = function | (PairArgType (t1,t2) as u, l) -> let (o1,o2) = Obj.magic l in let o1 = out_gen t1 (f1 (in_gen t1 o1)) in let o2 = out_gen t2 (f2 (in_gen t2 o2)) in (u, Obj.repr (o1,o2)) | _ -> failwith "Genarg: not a pair" let unquote x = x type an_arg_of_this_type = Obj.t let in_generic t x = (t, Obj.repr x) let dyntab = ref ([] : (string * glevel generic_argument option) list) type ('a,'b) abstract_argument_type = argument_type let create_arg v s = if List.mem_assoc s !dyntab then anomaly ("Genarg.create: already declared generic argument " ^ s); let t = ExtraArgType s in dyntab := (s,Option.map (in_gen t) v) :: !dyntab; (t,t,t) let exists_argtype s = List.mem_assoc s !dyntab let default_empty_argtype_value s = List.assoc s !dyntab let default_empty_value t = let rec aux = function | List0ArgType _ -> Some (in_gen t []) | OptArgType _ -> Some (in_gen t None) | PairArgType(t1,t2) -> (match aux t1, aux t2 with | Some (_,v1), Some (_,v2) -> Some (in_gen t (v1,v2)) | _ -> None) | ExtraArgType s -> default_empty_argtype_value s | _ -> None in match aux t with | Some v -> Some (out_gen t v) | None -> None coq-8.4pl4/interp/syntax_def.ml0000644000175000017500000001107112326224777015632 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* !syntax_table); Summary.unfreeze_function = (fun ft -> syntax_table := ft); Summary.init_function = (fun () -> syntax_table := KNmap.empty) } let add_syntax_constant kn c onlyparse = syntax_table := KNmap.add kn (c,onlyparse) !syntax_table let load_syntax_constant i ((sp,kn),(_,pat,onlyparse)) = if Nametab.exists_cci sp then errorlabstrm "cache_syntax_constant" (pr_id (basename sp) ++ str " already exists"); add_syntax_constant kn pat onlyparse; Nametab.push_syndef (Nametab.Until i) sp kn let is_alias_of_already_visible_name sp = function | _,ARef ref -> let (dir,id) = repr_qualid (shortest_qualid_of_global Idset.empty ref) in dir = empty_dirpath && id = basename sp | _ -> false let open_syntax_constant i ((sp,kn),(_,pat,onlyparse)) = if not (is_alias_of_already_visible_name sp pat) then begin Nametab.push_syndef (Nametab.Exactly i) sp kn; if onlyparse = None then (* Redeclare it to be used as (short) name in case an other (distfix) notation was declared inbetween *) Notation.declare_uninterpretation (Notation.SynDefRule kn) pat end let cache_syntax_constant d = load_syntax_constant 1 d; open_syntax_constant 1 d let subst_syntax_constant (subst,(local,pat,onlyparse)) = (local,subst_interpretation subst pat,onlyparse) let classify_syntax_constant (local,_,_ as o) = if local then Dispose else Substitute o let in_syntax_constant : bool * interpretation * Flags.compat_version option -> obj = declare_object {(default_object "SYNTAXCONSTANT") with cache_function = cache_syntax_constant; load_function = load_syntax_constant; open_function = open_syntax_constant; subst_function = subst_syntax_constant; classify_function = classify_syntax_constant } type syndef_interpretation = (identifier * subscopes) list * aconstr (* Coercions to the general format of notation that also supports variables bound to list of expressions *) let in_pat (ids,ac) = (List.map (fun (id,sc) -> (id,(sc,NtnTypeConstr))) ids,ac) let out_pat (ids,ac) = (List.map (fun (id,(sc,typ)) -> (id,sc)) ids,ac) let declare_syntactic_definition local id onlyparse pat = let _ = add_leaf id (in_syntax_constant (local,in_pat pat,onlyparse)) in () let pr_global r = pr_global_env Idset.empty r let pr_syndef kn = pr_qualid (shortest_qualid_of_syndef Idset.empty kn) let allow_compat_notations = ref true let verbose_compat_notations = ref false let is_verbose_compat () = !verbose_compat_notations || not !allow_compat_notations let verbose_compat kn def = function | Some v when is_verbose_compat () && Flags.version_strictly_greater v -> let act = if !verbose_compat_notations then msg_warning else errorlabstrm "" in let pp_def = match def with | [], ARef r -> str " is " ++ pr_global_env Idset.empty r | _ -> str " is a compatibility notation" in let since = str (" since Coq > " ^ Flags.pr_version v ^ ".") in act (pr_syndef kn ++ pp_def ++ since) | _ -> () let search_syntactic_definition kn = let pat,v = KNmap.find kn !syntax_table in let def = out_pat pat in verbose_compat kn def v; def open Goptions let set_verbose_compat_notations = declare_bool_option { optsync = true; optdepr = false; optname = "verbose compatibility notations"; optkey = ["Verbose";"Compat";"Notations"]; optread = (fun () -> !verbose_compat_notations); optwrite = ((:=) verbose_compat_notations) } let set_compat_notations = declare_bool_option { optsync = true; optdepr = false; optname = "accept compatibility notations"; optkey = ["Compat"; "Notations"]; optread = (fun () -> !allow_compat_notations); optwrite = ((:=) allow_compat_notations) } coq-8.4pl4/tools/0000755000175000017500000000000012365131022012752 5ustar stephstephcoq-8.4pl4/tools/fake_ide.ml0000644000175000017500000000640212326224777015056 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* exit 1 | _ -> () let commands = [ "INTERPRAWSILENT", (fun s -> eval_call (Ide_intf.interp (0,true,false,s))); "INTERPRAW", (fun s -> eval_call (Ide_intf.interp (0,true,true,s))); "INTERPSILENT", (fun s -> eval_call (Ide_intf.interp (0,false,false,s))); "INTERP", (fun s -> eval_call (Ide_intf.interp (0,false,true,s))); "REWIND", (fun s -> eval_call (Ide_intf.rewind (int_of_string s))); "GOALS", (fun _ -> eval_call (Ide_intf.goals ())); "HINTS", (fun _ -> eval_call (Ide_intf.hints ())); "GETOPTIONS", (fun _ -> eval_call (Ide_intf.get_options ())); "STATUS", (fun _ -> eval_call (Ide_intf.status ())); "INLOADPATH", (fun s -> eval_call (Ide_intf.inloadpath s)); "MKCASES", (fun s -> eval_call (Ide_intf.mkcases s)); "#", (fun _ -> raise Comment); ] let read_eval_print line = let lline = String.length line in let rec find_cmd = function | [] -> prerr_endline ("Error: Unknown API Command :"^line); exit 1 | (cmd,fn) :: cmds -> let lcmd = String.length cmd in if lline >= lcmd && String.sub line 0 lcmd = cmd then let arg = try String.sub line (lcmd+1) (lline-lcmd-1) with _ -> "" in fn arg else find_cmd cmds in find_cmd commands let usage () = Printf.printf "A fake coqide process talking to a coqtop -ideslave.\n\ Usage: %s []\n\ Input syntax is one API call per line, the keyword coming first,\n\ with the rest of the line as string argument (e.g. INTERP Check plus.)\n\ Supported API keywords are:\n" (Filename.basename Sys.argv.(0)); List.iter (fun (s,_) -> Printf.printf "\t%s\n" s) commands; exit 1 let main = Sys.set_signal Sys.sigpipe (Sys.Signal_handle (fun _ -> prerr_endline "Broken Pipe (coqtop died ?)"; exit 1)); let coqtop_name = match Array.length Sys.argv with | 1 -> "coqtop" | 2 when Sys.argv.(1) <> "-help" -> Sys.argv.(1) | _ -> usage () in coqtop := Unix.open_process (coqtop_name^" -ideslave"); while true do let l = try read_line () with End_of_file -> exit 0 in try read_eval_print l with | Comment -> () | e -> prerr_endline ("Uncaught exception" ^ Printexc.to_string e); exit 1 done coq-8.4pl4/tools/escape_string.ml0000644000175000017500000000005312326224777016151 0ustar stephstephprint_string (String.escaped Sys.argv.(1)) coq-8.4pl4/tools/README.emacs0000755000175000017500000000147512326224777014754 0ustar stephsteph DESCRIPTION: An emacs mode to help editing Coq vernacular files. AUTHOR: Jean-Christophe Filliatre (jcfillia@lri.fr), from the Caml mode of Xavier Leroy. CONTENTS: coq.el A major mode for editing Coq files in Gnu Emacs USAGE: Add the following lines to your .emacs file: (setq auto-mode-alist (cons '("\\.v$" . coq-mode) auto-mode-alist)) (autoload 'coq-mode "coq" "Major mode for editing Coq vernacular." t) The Coq major mode is triggered by visiting a file with extension .v, or manually by M-x coq-mode. It gives you the correct syntax table for the Coq language, and also a rudimentary indentation facility: - pressing TAB at the beginning of a line indents the line like the line above - extra TABs increase the indentation level (by 2 spaces by default) - M-TAB decreases the indentation level. coq-8.4pl4/tools/coqwc.mll0000644000175000017500000002175112326224777014623 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* printf " %s" f | _ -> ()); if !percentage then begin let s = sl + pl + dl in let p = if s > 0 then 100 * dl / s else 0 in printf " (%d%%)" p end; print_newline () let print_file fo = print_line !slines !plines !dlines fo let print_totals () = print_line !tslines !tplines !tdlines (Some "total") (*i*)}(*i*) (*s Shortcuts for regular expressions. The [rcs] regular expression is used to skip the CVS infos possibly contained in some comments, in order not to consider it as documentation. *) let space = [' ' '\t' '\r'] let character = "'" ([^ '\\' '\''] | '\\' (['\\' '\'' 'n' 't' 'b' 'r'] | ['0'-'9'] ['0'-'9'] ['0'-'9'])) "'" let rcs_keyword = "Author" | "Date" | "Header" | "Id" | "Name" | "Locker" | "Log" | "RCSfile" | "Revision" | "Source" | "State" let rcs = "\036" rcs_keyword [^ '$']* "\036" let stars = "(*" '*'* "*)" let dot = '.' (' ' | '\t' | '\n' | '\r' | eof) let proof_start = "Theorem" | "Lemma" | "Fact" | "Remark" | "Goal" | "Correctness" | "Obligation" | "Next" let proof_end = ("Save" | "Qed" | "Defined" | "Abort" | "Admitted") [^'.']* '.' (*s [spec] scans the specification. *) rule spec = parse | "(*" { comment lexbuf; spec lexbuf } | '"' { let n = string lexbuf in slines := !slines + n; seen_spec := true; spec lexbuf } | '\n' { newline (); spec lexbuf } | space+ | stars { spec lexbuf } | proof_start space { seen_spec := true; spec_to_dot lexbuf; proof lexbuf } | proof_start '\n' { seen_spec := true; newline (); spec_to_dot lexbuf; proof lexbuf } | "Program"? "Definition" space { seen_spec := true; definition lexbuf } | "Program"? "Fixpoint" space { seen_spec := true; definition lexbuf } | character | _ { seen_spec := true; spec lexbuf } | eof { () } (*s [spec_to_dot] scans a spec until a dot is reached and returns. *) and spec_to_dot = parse | "(*" { comment lexbuf; spec_to_dot lexbuf } | '"' { let n = string lexbuf in slines := !slines + n; seen_spec := true; spec_to_dot lexbuf } | '\n' { newline (); spec_to_dot lexbuf } | dot { () } | space+ | stars { spec_to_dot lexbuf } | character | _ { seen_spec := true; spec_to_dot lexbuf } | eof { () } (*s [definition] scans a definition; passes to [proof] is the body is absent, and to [spec] otherwise *) and definition = parse | "(*" { comment lexbuf; definition lexbuf } | '"' { let n = string lexbuf in slines := !slines + n; seen_spec := true; definition lexbuf } | '\n' { newline (); definition lexbuf } | ":=" { seen_spec := true; spec lexbuf } | dot { proof lexbuf } | space+ | stars { definition lexbuf } | character | _ { seen_spec := true; definition lexbuf } | eof { () } (*s Scans a proof, then returns to [spec]. *) and proof = parse | "(*" { comment lexbuf; proof lexbuf } | '"' { let n = string lexbuf in plines := !plines + n; seen_proof := true; proof lexbuf } | space+ | stars { proof lexbuf } | '\n' { newline (); proof lexbuf } | "Proof" space* '.' { seen_proof := true; proof lexbuf } | "Proof" space { proof_term lexbuf } | proof_end { seen_proof := true; spec lexbuf } | character | _ { seen_proof := true; proof lexbuf } | eof { () } and proof_term = parse | "(*" { comment lexbuf; proof_term lexbuf } | '"' { let n = string lexbuf in plines := !plines + n; seen_proof := true; proof_term lexbuf } | space+ | stars { proof_term lexbuf } | '\n' { newline (); proof_term lexbuf } | dot { spec lexbuf } | character | _ { seen_proof := true; proof_term lexbuf } | eof { () } (*s Scans a comment. *) and comment = parse | "(*" { comment lexbuf; comment lexbuf } | "*)" { () } | '"' { let n = string lexbuf in dlines := !dlines + n; seen_comment := true; comment lexbuf } | '\n' { newline (); comment lexbuf } | space+ | stars { comment lexbuf } | character | _ { seen_comment := true; comment lexbuf } | eof { () } (*s The entry [string] reads a string until its end and returns the number of newlines it contains. *) and string = parse | '"' { 0 } | '\\' ('\\' | 'n' | '"') { string lexbuf } | '\n' { succ (string lexbuf) } | _ { string lexbuf } | eof { 0 } (*s The following entry [read_header] is used to skip the possible header at the beggining of files (unless option \texttt{-e} is specified). It stops whenever it encounters an empty line or any character outside a comment. In this last case, it correctly resets the lexer position on that character (decreasing [lex_curr_pos] by 1). *) and read_header = parse | "(*" { skip_comment lexbuf; skip_until_nl lexbuf; read_header lexbuf } | "\n" { () } | space+ { read_header lexbuf } | _ { lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - 1 } | eof { () } and skip_comment = parse | "*)" { () } | "(*" { skip_comment lexbuf; skip_comment lexbuf } | _ { skip_comment lexbuf } | eof { () } and skip_until_nl = parse | '\n' { () } | _ { skip_until_nl lexbuf } | eof { () } (*i*){(*i*) (*s Processing files and channels. *) let process_channel ch = let lb = Lexing.from_channel ch in reset_counters (); if !skip_header then read_header lb; spec lb let process_file f = try let ch = open_in f in process_channel ch; close_in ch; print_file (Some f); update_totals () with | Sys_error "Is a directory" -> flush stdout; eprintf "coqwc: %s: Is a directory\n" f; flush stderr | Sys_error s -> flush stdout; eprintf "coqwc: %s\n" s; flush stderr (*s Parsing of the command line. *) let usage () = prerr_endline "usage: coqwc [options] [files]"; prerr_endline "Options are:"; prerr_endline " -p print percentage of comments"; prerr_endline " -s print only the spec size"; prerr_endline " -r print only the proof size"; prerr_endline " -e (everything) do not skip headers"; exit 1 let rec parse = function | [] -> [] | ("-h" | "-?" | "-help" | "--help") :: _ -> usage () | ("-s" | "--spec-only") :: args -> proof_only := false; spec_only := true; parse args | ("-r" | "--proof-only") :: args -> spec_only := false; proof_only := true; parse args | ("-p" | "--percentage") :: args -> percentage := true; parse args | ("-e" | "--header") :: args -> skip_header := false; parse args | f :: args -> f :: (parse args) (*s Main program. *) let main () = let files = parse (List.tl (Array.to_list Sys.argv)) in if not (!spec_only || !proof_only) then printf " spec proof comments\n"; match files with | [] -> process_channel stdin; print_file None | [f] -> process_file f | _ -> List.iter process_file files; print_totals () let _ = Printexc.catch main () (*i*)}(*i*) coq-8.4pl4/tools/win32hack.mllib0000644000175000017500000000002212326224777015577 0ustar stephstephWin32hack_filenamecoq-8.4pl4/tools/coqdep_common.mli0000644000175000017500000000423612326224777016326 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string -> string val get_extension : string -> string list -> string * string val basename_noext : string -> string val mlAccu : (string * string * dir) list ref val mliAccu : (string * dir) list ref val mllibAccu : (string * dir) list ref val vAccu : (string * string) list ref val addQueue : 'a list ref -> 'a -> unit val add_ml_known : string -> dir -> unit val iter_ml_known : (string -> dir -> unit) -> unit val search_ml_known : string -> dir option val add_mli_known : string -> dir -> unit val iter_mli_known : (string -> dir -> unit) -> unit val search_mli_known : string -> dir option val add_mllib_known : string -> dir -> unit val search_mllib_known : string -> dir option val vKnown : (string list, string) Hashtbl.t val coqlibKnown : (string list, unit) Hashtbl.t val file_name : string -> string option -> string val escape : string -> string val canonize : string -> string val mL_dependencies : unit -> unit val coq_dependencies : unit -> unit val suffixes : 'a list -> 'a list list val add_known : string -> string list -> string -> unit val add_directory : bool -> (string -> string list -> string -> unit) -> string -> string list -> unit val add_dir : (string -> string list -> string -> unit) -> string -> string list -> unit val add_rec_dir : (string -> string list -> string -> unit) -> string -> string list -> unit val treat_file : dir -> string -> unit coq-8.4pl4/tools/coqdep_lexer.mll0000644000175000017500000002302612326224777016156 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* " | "." | ".." | ".(" | ".[" | ":" | "::" | ":=" | ";" | ";;" | "<-" | "=" | "[" | "[|" | "[<" | "]" | "_" | "{" | "|" | "||" | "|]" | ">]" | "}" | "!=" | "-" | "-." { caml_action lexbuf } | ['!' '?' '~'] ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] * { caml_action lexbuf } | ['=' '<' '>' '@' '^' '|' '&' '$'] ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] * { caml_action lexbuf } | ['+' '-'] ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] * { caml_action lexbuf } | "**" ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] * { caml_action lexbuf } | ['*' '/' '%'] ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] * { caml_action lexbuf } | eof { raise Fin_fichier } | _ { caml_action lexbuf } and comment = parse | "(*" (* "*)" *) { comment_depth := succ !comment_depth; comment lexbuf } | "*)" { comment_depth := pred !comment_depth; if !comment_depth > 0 then comment lexbuf } | "'" [^ '\\' '\''] "'" { comment lexbuf } | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" { comment lexbuf } | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { comment lexbuf } | eof { raise Fin_fichier } | _ { comment lexbuf } and string = parse | '"' (* '"' *) { () } | '\\' ("\010" | "\013" | "\010\013") [' ' '\009'] * { string lexbuf } | '\\' ['\\' '"' 'n' 't' 'b' 'r'] (*'"'*) { string lexbuf } | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { string lexbuf } | eof { raise Fin_fichier } | _ { string lexbuf } and load_file = parse | '"' [^ '"']* '"' (*'"'*) { let s = lexeme lexbuf in parse_dot lexbuf; Load (unquote_vfile_string s) } | coq_ident { let s = lexeme lexbuf in skip_to_dot lexbuf; Load s } | eof { syntax_error lexbuf } | _ { syntax_error lexbuf } and require_file = parse | "(*" { comment_depth := 1; comment lexbuf; require_file lexbuf } | space+ { require_file lexbuf } | coq_ident { module_current_name := [Lexing.lexeme lexbuf]; module_names := [coq_qual_id_tail lexbuf]; let qid = coq_qual_id_list lexbuf in parse_dot lexbuf; Require qid } | '"' [^'"']* '"' (*'"'*) { let s = Lexing.lexeme lexbuf in parse_dot lexbuf; RequireString (unquote_vfile_string s) } | eof { syntax_error lexbuf } | _ { syntax_error lexbuf } and skip_to_dot = parse | dot { () } | eof { syntax_error lexbuf } | _ { skip_to_dot lexbuf } and parse_dot = parse | dot { () } | eof { syntax_error lexbuf } | _ { syntax_error lexbuf } and coq_qual_id = parse | "(*" { comment_depth := 1; comment lexbuf; coq_qual_id lexbuf } | space+ { coq_qual_id lexbuf } | coq_ident { module_current_name := [Lexing.lexeme lexbuf]; coq_qual_id_tail lexbuf } | eof { syntax_error lexbuf } | _ { backtrack lexbuf; let qid = List.rev !module_current_name in module_current_name := []; qid } and coq_qual_id_tail = parse | "(*" { comment_depth := 1; comment lexbuf; coq_qual_id_tail lexbuf } | space+ { coq_qual_id_tail lexbuf } | coq_field { module_current_name := field_name (Lexing.lexeme lexbuf) :: !module_current_name; coq_qual_id_tail lexbuf } | eof { syntax_error lexbuf } | _ { backtrack lexbuf; let qid = List.rev !module_current_name in module_current_name := []; qid } and coq_qual_id_list = parse | "(*" { comment_depth := 1; comment lexbuf; coq_qual_id_list lexbuf } | space+ { coq_qual_id_list lexbuf } | coq_ident { module_current_name := [Lexing.lexeme lexbuf]; module_names := coq_qual_id_tail lexbuf :: !module_names; coq_qual_id_list lexbuf } | eof { syntax_error lexbuf } | _ { backtrack lexbuf; List.rev !module_names } and modules = parse | space+ { modules lexbuf } | "(*" { comment_depth := 1; comment lexbuf; modules lexbuf } | '"' [^'"']* '"' { let lex = (Lexing.lexeme lexbuf) in let str = String.sub lex 1 (String.length lex - 2) in mllist := str :: !mllist; modules lexbuf} | eof { syntax_error lexbuf } | _ { (Declare (List.rev !mllist)) } and qual_id = parse | '.' [^ '.' '(' '['] { Use_module (String.uncapitalize !ml_module_name) } | eof { raise Fin_fichier } | _ { caml_action lexbuf } and mllib_list = parse | caml_up_ident { let s = String.uncapitalize (Lexing.lexeme lexbuf) in s :: mllib_list lexbuf } | "*predef*" { mllib_list lexbuf } | space+ { mllib_list lexbuf } | eof { [] } | _ { syntax_error lexbuf } and ocamldep_parse = parse | [^ ':' ]* ':' { mllib_list lexbuf } coq-8.4pl4/tools/coqdep.ml0000644000175000017500000001611512326224777014604 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (Filename.dirname (file_name f d')) then begin eprintf "*** Warning : the file %s is defined twice!\n" (f ^ suf); flush stderr end with Not_found -> () end; Hashtbl.add tab f d in iter check let add_coqlib_known phys_dir log_dir f = match get_extension f [".vo"] with | (basename,".vo") -> let name = log_dir@[basename] in let paths = suffixes name in List.iter (fun f -> Hashtbl.add coqlibKnown f ()) paths | _ -> () let sort () = let seen = Hashtbl.create 97 in let rec loop file = let file = canonize file in if not (Hashtbl.mem seen file) then begin Hashtbl.add seen file (); let cin = open_in (file ^ ".v") in let lb = Lexing.from_channel cin in try while true do match coq_action lb with | Require sl -> List.iter (fun s -> try loop (Hashtbl.find vKnown s) with Not_found -> ()) sl | RequireString s -> loop s | _ -> () done with Fin_fichier -> close_in cin; printf "%s%s " file !suffixe end in List.iter (fun (name,_) -> loop name) !vAccu let (dep_tab : (string,string list) Hashtbl.t) = Hashtbl.create 151 let mL_dep_list b f = try Hashtbl.find dep_tab f with Not_found -> let deja_vu = ref ([] : string list) in try let chan = open_in f in let buf = Lexing.from_channel chan in try while true do let (Use_module str) = caml_action buf in if str = b then begin eprintf "*** Warning : in file %s the" f; eprintf " notation %s. is useless !\n" b; flush stderr end else if not (List.mem str !deja_vu) then addQueue deja_vu str done; [] with Fin_fichier -> begin close_in chan; let rl = List.rev !deja_vu in Hashtbl.add dep_tab f rl; rl end with Sys_error _ -> [] let affiche_Declare f dcl = printf "\n*** In file %s: \n" f; printf "Declare ML Module"; List.iter (fun str -> printf " \"%s\"" str) dcl; printf ".\n"; flush stdout let warning_Declare f dcl = eprintf "*** Warning : in file %s, the ML modules" f; eprintf " declaration should be\n"; eprintf "*** Declare ML Module"; List.iter (fun str -> eprintf " \"%s\"" str) dcl; eprintf ".\n"; flush stderr let traite_Declare f = let decl_list = ref ([] : string list) in let rec treat = function | s :: ll -> let s' = basename_noext s in (match search_ml_known s with | Some mldir when not (List.mem s' !decl_list) -> let fullname = file_name (String.uncapitalize s') mldir in let depl = mL_dep_list s (fullname ^ ".ml") in treat depl; decl_list := s :: !decl_list | _ -> ()); treat ll | [] -> () in try let chan = open_in f in let buf = Lexing.from_channel chan in begin try while true do let tok = coq_action buf in (match tok with | Declare sl -> decl_list := []; treat sl; decl_list := List.rev !decl_list; if !option_D then affiche_Declare f !decl_list else if !decl_list <> sl then warning_Declare f !decl_list | _ -> ()) done with Fin_fichier -> () end; close_in chan with Sys_error _ -> () let declare_dependencies () = List.iter (fun (name,_) -> traite_Declare (name^".v"); flush stdout) (List.rev !vAccu) let usage () = eprintf " usage: coqdep [-w] [-c] [-D] [-I dir] [-R dir coqdir] +\n"; eprintf " extra options:\n"; eprintf " -coqlib dir : set the coq standard library directory\n"; eprintf " -exclude-dir f : skip subdirectories named f during -R search\n"; exit 1 let rec parse = function | "-c" :: ll -> option_c := true; parse ll | "-D" :: ll -> option_D := true; parse ll | "-w" :: ll -> option_w := true; parse ll | "-boot" :: ll -> Flags.boot := true; parse ll | "-sort" :: ll -> option_sort := true; parse ll | ("-noglob" | "-no-glob") :: ll -> option_noglob := true; parse ll | "-I" :: r :: "-as" :: ln :: ll -> add_dir add_known r [ln]; parse ll | "-I" :: r :: "-as" :: [] -> usage () | "-I" :: r :: ll -> add_dir add_known r []; parse ll | "-I" :: [] -> usage () | "-R" :: r :: "-as" :: ln :: ll -> add_rec_dir add_known r [ln]; parse ll | "-R" :: r :: "-as" :: [] -> usage () | "-R" :: r :: ln :: ll -> add_rec_dir add_known r [ln]; parse ll | "-R" :: ([] | [_]) -> usage () | "-exclude-dir" :: r :: ll -> norec_dirnames := r::!norec_dirnames; parse ll | "-exclude-dir" :: [] -> usage () | "-coqlib" :: r :: ll -> Flags.coqlib_spec := true; Flags.coqlib := r; parse ll | "-coqlib" :: [] -> usage () | "-suffix" :: s :: ll -> suffixe := s ; parse ll | "-suffix" :: [] -> usage () | "-slash" :: ll -> option_slash := true; parse ll | ("-h"|"--help"|"-help") :: _ -> usage () | f :: ll -> treat_file None f; parse ll | [] -> () let coqdep () = if Array.length Sys.argv < 2 then usage (); parse (List.tl (Array.to_list Sys.argv)); if not Coq_config.has_natdynlink then option_natdynlk := false; (* NOTE: These directories are searched from last to first *) if !Flags.boot then begin add_rec_dir add_known "theories" ["Coq"]; add_rec_dir add_known "plugins" ["Coq"] end else begin let coqlib = Envars.coqlib () in add_rec_dir add_coqlib_known (coqlib//"theories") ["Coq"]; add_rec_dir add_coqlib_known (coqlib//"plugins") ["Coq"]; let user = coqlib//"user-contrib" in if Sys.file_exists user then add_rec_dir add_coqlib_known user []; List.iter (fun s -> add_rec_dir add_coqlib_known s []) Envars.xdg_dirs; List.iter (fun s -> add_rec_dir add_coqlib_known s []) Envars.coqpath; end; List.iter (fun (f,d) -> add_mli_known f d) !mliAccu; List.iter (fun (f,d) -> add_mllib_known f d) !mllibAccu; List.iter (fun (f,_,d) -> add_ml_known f d) !mlAccu; warning_mult ".mli" iter_mli_known; warning_mult ".ml" iter_ml_known; if !option_sort then begin sort (); exit 0 end; if !option_c && not !option_D then mL_dependencies (); if not !option_D then coq_dependencies (); if !option_w || !option_D then declare_dependencies () let _ = Printexc.catch coqdep () coq-8.4pl4/tools/coqdoc/0000755000175000017500000000000012365131022014222 5ustar stephstephcoq-8.4pl4/tools/coqdoc/tokens.ml0000644000175000017500000001310312326224777016076 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* None with | Some tt' -> CharMap.add c (insert tt' (i + 1)) (CharMap.remove c tt.branch) | None -> let tt' = {node = None; branch = CharMap.empty} in CharMap.add c (insert tt' (i + 1)) tt.branch in { node = tt.node; branch = br } in insert ttree 0 (* Removes a string from a dictionary: returns an equal dictionary if the word not present. *) let ttree_remove ttree str = let rec remove tt i = if i == String.length str then {node = None; branch = tt.branch} else let c = str.[i] in let br = match try Some (CharMap.find c tt.branch) with Not_found -> None with | Some tt' -> CharMap.add c (remove tt' (i + 1)) (CharMap.remove c tt.branch) | None -> tt.branch in { node = tt.node; branch = br } in remove ttree 0 let ttree_descend ttree c = CharMap.find c ttree.branch let ttree_find ttree str = let rec proc_rec tt i = if i == String.length str then tt else proc_rec (CharMap.find str.[i] tt.branch) (i+1) in proc_rec ttree 0 (*s Parameters of the translation automaton *) type out_function = bool -> bool -> Index.index_entry option -> string -> unit let token_tree = ref (ref empty_ttree) let outfun = ref (fun _ _ _ _ -> failwith "outfun not initialized") (*s Translation automaton *) let buff = Buffer.create 4 let flush_buffer was_symbolchar tag tok = let hastr = String.length tok <> 0 in if hastr then !outfun false was_symbolchar tag tok; if Buffer.length buff <> 0 then !outfun true (if hastr then not was_symbolchar else was_symbolchar) tag (Buffer.contents buff); Buffer.clear buff type sublexer_state = | Neutral | Buffering of bool * Index.index_entry option * string * ttree let translation_state = ref Neutral let buffer_char is_symbolchar ctag c = let rec aux = function | Neutral -> restart_buffering () | Buffering (was_symbolchar,tag,translated,tt) -> if tag <> ctag then (* A strong tag comes from Coq; if different Coq tags *) (* hence, we don't try to see the chars as part of a single token *) let translated = match tt.node with | Some tok -> Buffer.clear buff; tok | None -> translated in flush_buffer was_symbolchar tag translated; restart_buffering () else begin (* If we change the category of characters (symbol vs ident) *) (* we accept this as a possible token cut point and remember the *) (* translated token up to that point *) let translated = if is_symbolchar <> was_symbolchar then match tt.node with | Some tok -> Buffer.clear buff; tok | None -> translated else translated in (* We try to make a significant token from the current *) (* buffer and the new character *) try let tt = ttree_descend tt c in Buffer.add_char buff c; Buffering (is_symbolchar,ctag,translated,tt) with Not_found -> (* No existing translation for the given set of chars *) if is_symbolchar <> was_symbolchar then (* If we changed the category of character read, we accept it *) (* as a possible cut point and restart looking for a translation *) (flush_buffer was_symbolchar tag translated; restart_buffering ()) else (* If we did not change the category of character read, we do *) (* not want to cut arbitrarily in the middle of the sequence of *) (* symbol characters or identifier characters *) (Buffer.add_char buff c; Buffering (is_symbolchar,tag,translated,empty_ttree)) end and restart_buffering () = let tt = try ttree_descend !(!token_tree) c with Not_found -> empty_ttree in Buffer.add_char buff c; Buffering (is_symbolchar,ctag,"",tt) in translation_state := aux !translation_state let output_tagged_ident_string s = for i = 0 to String.length s - 1 do buffer_char false None s.[i] done let output_tagged_symbol_char tag c = buffer_char true tag c let flush_sublexer () = match !translation_state with | Neutral -> () | Buffering (was_symbolchar,tag,translated,tt) -> let translated = match tt.node with | Some tok -> Buffer.clear buff; tok | None -> translated in flush_buffer was_symbolchar tag translated; translation_state := Neutral (* Translation not using the automaton *) let translate s = try (ttree_find !(!token_tree) s).node with Not_found -> None coq-8.4pl4/tools/coqdoc/main.ml0000644000175000017500000005032212326224777015523 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* on 9 & 10 Mar 2004: * - handling of absolute filenames (function coq_module) * - coq_module: chop ./// (arbitrary amount of slashes), not only "./" * - function chop_prefix not useful anymore. Deleted. * - correct typo in usage message: "-R" -> "--R" * - shorten the definition of make_path * This notice is made to comply with section 2.a of the GPLv2. * It may be removed or abbreviated as far as I am concerned. *) open Cdglobals open Printf (*s \textbf{Usage.} Printed on error output. *) let usage () = prerr_endline ""; prerr_endline "Usage: coqdoc "; prerr_endline " --html produce a HTML document (default)"; prerr_endline " --latex produce a LaTeX document"; prerr_endline " --texmacs produce a TeXmacs document"; prerr_endline " --raw produce a text document"; prerr_endline " --dvi output the DVI"; prerr_endline " --ps output the PostScript"; prerr_endline " --pdf output the Pdf"; prerr_endline " --stdout write output to stdout"; prerr_endline " -o write output in file "; prerr_endline " -d output files into directory "; prerr_endline " -g (gallina) skip proofs"; prerr_endline " -s (short) no titles for files"; prerr_endline " -l light mode (only defs and statements)"; prerr_endline " -t give a title to the document"; prerr_endline " --body-only suppress LaTeX/HTML header and trailer"; prerr_endline " --with-header prepend as html reader"; prerr_endline " --with-footer append as html footer"; prerr_endline " --no-index do not output the index"; prerr_endline " --multi-index index split in multiple files"; prerr_endline " --index set index name (default is index)"; prerr_endline " --toc output a table of contents"; prerr_endline " --vernac consider as a .v file"; prerr_endline " --tex consider as a .tex file"; prerr_endline " -p insert in LaTeX preamble"; prerr_endline " --files-from read file names to process in "; prerr_endline " --glob-from read globalization information from "; prerr_endline " --no-glob don't use any globalization information (no links will be inserted at identifiers)"; prerr_endline " --quiet quiet mode (default)"; prerr_endline " --verbose verbose mode"; prerr_endline " --no-externals no links to Coq standard library"; prerr_endline " --external set URL for external library d"; prerr_endline " --coqlib set URL for Coq standard library"; prerr_endline (" (default is " ^ Coq_config.wwwstdlib ^ ")"); prerr_endline " --boot run in boot mode"; prerr_endline " --coqlib_path set the path where Coq files are installed"; prerr_endline " -R map physical dir to Coq dir"; prerr_endline " --latin1 set ISO-8859-1 input language"; prerr_endline " --utf8 set UTF-8 input language"; prerr_endline " --charset set HTML charset"; prerr_endline " --inputenc set LaTeX input encoding"; prerr_endline " --interpolate try to typeset identifiers in comments using definitions in the same module"; prerr_endline " --parse-comments parse regular comments"; prerr_endline " --plain-comments consider comments as non-literate text"; prerr_endline " --toc-depth don't include TOC entries for sections below level "; prerr_endline " --no-lib-name don't display \"Library\" before library names in the toc"; prerr_endline " --lib-name call top level toc entries instead of \"Library\""; prerr_endline " --lib-subtitles first line comments of the form (** * ModuleName : text *) will be interpreted as subtitles"; prerr_endline " --inline-notmono use a proportional width font for inline code (possibly with a different color)"; prerr_endline ""; exit 1 let obsolete s = eprintf "Warning: option %s is now obsolete; please update your scripts\n" s (*s \textbf{Banner.} Always printed. Notice that it is printed on error output, so that when the output of [coqdoc] is redirected this header is not (unless both standard and error outputs are redirected, of course). *) let banner () = eprintf "This is coqdoc version %s, compiled on %s\n" Coq_config.version Coq_config.compile_date; flush stderr let target_full_name f = match !Cdglobals.target_language with | HTML -> f ^ ".html" | Raw -> f ^ ".txt" | _ -> f ^ ".tex" (*s \textbf{Separation of files.} Files given on the command line are separated according to their type, which is determined by their suffix. Coq files have suffixe \verb!.v! or \verb!.g! and \LaTeX\ files have suffix \verb!.tex!. *) let check_if_file_exists f = if not (Sys.file_exists f) then begin eprintf "coqdoc: %s: no such file\n" f; exit 1 end (* [paths] maps a physical path to a name *) let paths = ref [] let add_path dir name = let p = normalize_path dir in paths := (p,name) :: !paths (* turn A/B/C into A.B.C *) let rec name_of_path p name dirname suffix = if p = dirname then String.concat "." (if name = "" then suffix else (name::suffix)) else let subdir = Filename.dirname dirname in if subdir = dirname then raise Not_found else name_of_path p name subdir (Filename.basename dirname::suffix) let coq_module filename = let bfname = Filename.chop_extension filename in let dirname, fname = normalize_filename bfname in let rec change_prefix = function (* Follow coqc: if in scope of -R, substitute logical name *) (* otherwise, keep only base name *) | [] -> fname | (p, name) :: rem -> try name_of_path p name dirname [fname] with Not_found -> change_prefix rem in change_prefix !paths let what_file f = check_if_file_exists f; if Filename.check_suffix f ".v" || Filename.check_suffix f ".g" then Vernac_file (f, coq_module f) else if Filename.check_suffix f ".tex" then Latex_file f else (eprintf "\ncoqdoc: don't know what to do with %s\n" f; exit 1) (*s \textbf{Reading file names from a file.} * File names may be given * in a file instead of being given on the command * line. [(files_from_file f)] returns the list of file names contained * in the file named [f]. These file names must be separated by spaces, * tabulations or newlines. *) let files_from_file f = let files_from_channel ch = let buf = Buffer.create 80 in let l = ref [] in try while true do match input_char ch with | ' ' | '\t' | '\n' -> if Buffer.length buf > 0 then l := (Buffer.contents buf) :: !l; Buffer.clear buf | c -> Buffer.add_char buf c done; [] with End_of_file -> List.rev !l in try check_if_file_exists f; let ch = open_in f in let l = files_from_channel ch in close_in ch;l with Sys_error s -> begin eprintf "coqdoc: cannot read from file %s (%s)\n" f s; exit 1 end (*s \textbf{Parsing of the command line.} *) let dvi = ref false let ps = ref false let pdf = ref false let parse () = let files = ref [] in let add_file f = files := f :: !files in let rec parse_rec = function | [] -> () | ("-nopreamble" | "--nopreamble" | "--no-preamble" | "-bodyonly" | "--bodyonly" | "--body-only") :: rem -> header_trailer := false; parse_rec rem | ("-with-header" | "--with-header") :: f ::rem -> header_trailer := true; header_file_spec := true; header_file := f; parse_rec rem | ("-with-header" | "--with-header") :: [] -> usage () | ("-with-footer" | "--with-footer") :: f ::rem -> header_trailer := true; footer_file_spec := true; footer_file := f; parse_rec rem | ("-with-footer" | "--with-footer") :: [] -> usage () | ("-p" | "--preamble") :: s :: rem -> Output.push_in_preamble s; parse_rec rem | ("-p" | "--preamble") :: [] -> usage () | ("-noindex" | "--noindex" | "--no-index") :: rem -> index := false; parse_rec rem | ("-multi-index" | "--multi-index") :: rem -> multi_index := true; parse_rec rem | ("-index" | "--index") :: s :: rem -> Cdglobals.index_name := s; parse_rec rem | ("-index" | "--index") :: [] -> usage () | ("-toc" | "--toc" | "--table-of-contents") :: rem -> toc := true; parse_rec rem | ("-stdout" | "--stdout") :: rem -> out_to := StdOut; parse_rec rem | ("-o" | "--output") :: f :: rem -> out_to := File (Filename.basename f); output_dir := Filename.dirname f; parse_rec rem | ("-o" | "--output") :: [] -> usage () | ("-d" | "--directory") :: dir :: rem -> output_dir := dir; parse_rec rem | ("-d" | "--directory") :: [] -> usage () | ("-s" | "--short") :: rem -> short := true; parse_rec rem | ("-l" | "-light" | "--light") :: rem -> gallina := true; light := true; parse_rec rem | ("-g" | "-gallina" | "--gallina") :: rem -> gallina := true; parse_rec rem | ("-t" | "-title" | "--title") :: s :: rem -> title := s; parse_rec rem | ("-t" | "-title" | "--title") :: [] -> usage () | ("-latex" | "--latex") :: rem -> Cdglobals.target_language := LaTeX; parse_rec rem | ("-pdf" | "--pdf") :: rem -> Cdglobals.target_language := LaTeX; pdf := true; parse_rec rem | ("-dvi" | "--dvi") :: rem -> Cdglobals.target_language := LaTeX; dvi := true; parse_rec rem | ("-ps" | "--ps") :: rem -> Cdglobals.target_language := LaTeX; ps := true; parse_rec rem | ("-html" | "--html") :: rem -> Cdglobals.target_language := HTML; parse_rec rem | ("-texmacs" | "--texmacs") :: rem -> Cdglobals.target_language := TeXmacs; parse_rec rem | ("-raw" | "--raw") :: rem -> Cdglobals.target_language := Raw; parse_rec rem | ("-charset" | "--charset") :: s :: rem -> Cdglobals.charset := s; parse_rec rem | ("-charset" | "--charset") :: [] -> usage () | ("-inputenc" | "--inputenc") :: s :: rem -> Cdglobals.inputenc := s; parse_rec rem | ("-inputenc" | "--inputenc") :: [] -> usage () | ("-raw-comments" | "--raw-comments") :: rem -> Cdglobals.raw_comments := true; parse_rec rem | ("-parse-comments" | "--parse-comments") :: rem -> Cdglobals.parse_comments := true; parse_rec rem | ("-plain-comments" | "--plain-comments") :: rem -> Cdglobals.plain_comments := true; parse_rec rem | ("-interpolate" | "--interpolate") :: rem -> Cdglobals.interpolate := true; parse_rec rem | ("-toc-depth" | "--toc-depth") :: [] -> usage () | ("-toc-depth" | "--toc-depth") :: ds :: rem -> let d = try int_of_string ds with Failure _ -> (eprintf "--toc-depth must be followed by an integer\n"; exit 1) in Cdglobals.toc_depth := Some d; parse_rec rem | ("-no-lib-name" | "--no-lib-name") :: rem -> Cdglobals.lib_name := ""; parse_rec rem | ("-lib-name" | "--lib-name") :: ds :: rem -> Cdglobals.lib_name := ds; parse_rec rem | ("-lib-subtitles" | "--lib-subtitles") :: rem -> Cdglobals.lib_subtitles := true; parse_rec rem | ("-inline-notmono" | "--inline-notmono") :: rem -> Cdglobals.inline_notmono := true; parse_rec rem | ("-latin1" | "--latin1") :: rem -> Cdglobals.set_latin1 (); parse_rec rem | ("-utf8" | "--utf8") :: rem -> Cdglobals.set_utf8 (); parse_rec rem | ("-q" | "-quiet" | "--quiet") :: rem -> quiet := true; parse_rec rem | ("-v" | "-verbose" | "--verbose") :: rem -> quiet := false; parse_rec rem | ("-h" | "-help" | "-?" | "--help") :: rem -> banner (); usage () | ("-V" | "-version" | "--version") :: _ -> banner (); exit 0 | ("-vernac-file" | "--vernac-file") :: f :: rem -> check_if_file_exists f; add_file (Vernac_file (f, coq_module f)); parse_rec rem | ("-vernac-file" | "--vernac-file") :: [] -> usage () | ("-tex-file" | "--tex-file") :: f :: rem -> add_file (Latex_file f); parse_rec rem | ("-tex-file" | "--tex-file") :: [] -> usage () | ("-files" | "--files" | "--files-from") :: f :: rem -> List.iter (fun f -> add_file (what_file f)) (files_from_file f); parse_rec rem | ("-files" | "--files") :: [] -> usage () | "-R" :: path :: log :: rem -> add_path path log; parse_rec rem | "-R" :: ([] | [_]) -> usage () | ("-glob-from" | "--glob-from") :: f :: rem -> glob_source := GlobFile f; parse_rec rem | ("-glob-from" | "--glob-from") :: [] -> usage () | ("-no-glob" | "--no-glob") :: rem -> glob_source := NoGlob; parse_rec rem | ("--no-externals" | "-no-externals" | "-noexternals") :: rem -> Cdglobals.externals := false; parse_rec rem | ("--external" | "-external") :: u :: logicalpath :: rem -> Index.add_external_library logicalpath u; parse_rec rem | ("--coqlib" | "-coqlib") :: u :: rem -> Cdglobals.coqlib := u; parse_rec rem | ("--coqlib" | "-coqlib") :: [] -> usage () | ("--boot" | "-boot") :: rem -> Cdglobals.coqlib_path := normalize_path ( Filename.concat (Filename.dirname Sys.executable_name) Filename.parent_dir_name ); parse_rec rem | ("--coqlib_path" | "-coqlib_path") :: d :: rem -> Cdglobals.coqlib_path := d; parse_rec rem | ("--coqlib_path" | "-coqlib_path") :: [] -> usage () | f :: rem -> add_file (what_file f); parse_rec rem in parse_rec (List.tl (Array.to_list Sys.argv)); List.rev !files (*s The following function produces the output. The default output is the \LaTeX\ document: in that case, we just call [Web.produce_document]. If option \verb!-dvi!, \verb!-ps! or \verb!-html! is invoked, then we make calls to \verb!latex! or \verb!dvips! or \verb!pdflatex! accordingly. *) let locally dir f x = let cwd = Sys.getcwd () in try Sys.chdir dir; let y = f x in Sys.chdir cwd; y with e -> Sys.chdir cwd; raise e let clean_temp_files basefile = let remove f = try Sys.remove f with _ -> () in remove (basefile ^ ".tex"); remove (basefile ^ ".log"); remove (basefile ^ ".aux"); remove (basefile ^ ".toc"); remove (basefile ^ ".dvi"); remove (basefile ^ ".ps"); remove (basefile ^ ".pdf"); remove (basefile ^ ".haux"); remove (basefile ^ ".html") let clean_and_exit file res = clean_temp_files file; exit res let cat file = let c = open_in file in try while true do print_char (input_char c) done with End_of_file -> close_in c let copy src dst = let cin = open_in src in try let cout = open_out dst in try while true do Pervasives.output_char cout (input_char cin) done with End_of_file -> close_out cout; close_in cin with Sys_error e -> eprintf "%s\n" e; exit 1 (*s Functions for generating output files *) let gen_one_file l = let file = function | Vernac_file (f,m) -> let sub = if !lib_subtitles then Cpretty.detect_subtitle f m else None in Output.set_module m sub; Cpretty.coq_file f m | Latex_file _ -> () in if (!header_trailer) then Output.header (); if !toc then Output.make_toc (); List.iter file l; if !index then Output.make_index(); if (!header_trailer) then Output.trailer () let gen_mult_files l = let file = function | Vernac_file (f,m) -> let sub = if !lib_subtitles then Cpretty.detect_subtitle f m else None in let hf = target_full_name m in Output.set_module m sub; open_out_file hf; if (!header_trailer) then Output.header (); Cpretty.coq_file f m; if (!header_trailer) then Output.trailer (); close_out_file() | Latex_file _ -> () in List.iter file l; if (!index && !target_language=HTML) then begin if (!multi_index) then Output.make_multi_index (); open_out_file (!index_name^".html"); page_title := (if !title <> "" then !title else "Index"); if (!header_trailer) then Output.header (); Output.make_index (); if (!header_trailer) then Output.trailer (); close_out_file() end; if (!toc && !target_language=HTML) then begin open_out_file "toc.html"; page_title := (if !title <> "" then !title else "Table of contents"); if (!header_trailer) then Output.header (); if !title <> "" then printf "

%s

\n" !title; Output.make_toc (); if (!header_trailer) then Output.trailer (); close_out_file() end (* Rq: pour latex et texmacs, une toc ou un index séparé n'a pas de sens... *) let read_glob_file vfile f = try Index.read_glob vfile f with Sys_error s -> eprintf "Warning: %s (links will not be available)\n" s let read_glob_file_of = function | Vernac_file (f,_) -> read_glob_file (Some f) (Filename.chop_extension f ^ ".glob") | Latex_file _ -> () let index_module = function | Vernac_file (f,m) -> Index.add_module m | Latex_file _ -> () let copy_style_file file = let src = List.fold_left Filename.concat !Cdglobals.coqlib_path ["tools";"coqdoc";file] in let dst = coqdoc_out file in if Sys.file_exists src then copy src dst else eprintf "Warning: file %s does not exist\n" src let produce_document l = if !target_language=HTML then copy_style_file "coqdoc.css"; if !target_language=LaTeX then copy_style_file "coqdoc.sty"; (match !Cdglobals.glob_source with | NoGlob -> () | DotGlob -> List.iter read_glob_file_of l | GlobFile f -> read_glob_file None f); List.iter index_module l; match !out_to with | StdOut -> Cdglobals.out_channel := stdout; gen_one_file l | File f -> open_out_file f; gen_one_file l; close_out_file() | MultFiles -> gen_mult_files l let produce_output fl = if not (!dvi || !ps || !pdf) then produce_document fl else begin let texfile = Filename.temp_file "coqdoc" ".tex" in let basefile = Filename.chop_suffix texfile ".tex" in let final_out_to = !out_to in out_to := File texfile; output_dir := (Filename.dirname texfile); produce_document fl; let latexexe = if !pdf then "pdflatex" else "latex" in let latexcmd = let file = Filename.basename texfile in let file = if !quiet then sprintf "'\\nonstopmode\\input{%s}'" file else file in sprintf "%s %s && %s %s 1>&2 %s" latexexe file latexexe file (if !quiet then "> /dev/null" else "") in let res = locally (Filename.dirname texfile) Sys.command latexcmd in if res <> 0 then begin eprintf "Couldn't run LaTeX successfully\n"; clean_and_exit basefile res end; let dvifile = basefile ^ ".dvi" in if !dvi then begin match final_out_to with | MultFiles | StdOut -> cat dvifile | File f -> copy dvifile f end; let pdffile = basefile ^ ".pdf" in if !pdf then begin match final_out_to with | MultFiles | StdOut -> cat pdffile | File f -> copy pdffile f end; if !ps then begin let psfile = basefile ^ ".ps" in let command = sprintf "dvips %s -o %s %s" dvifile psfile (if !quiet then "> /dev/null 2>&1" else "") in let res = Sys.command command in if res <> 0 then begin eprintf "Couldn't run dvips successfully\n"; clean_and_exit basefile res end; match final_out_to with | MultFiles | StdOut -> cat psfile | File f -> copy psfile f end; clean_temp_files basefile end (*s \textbf{Main program.} Print the banner, parse the command line, read the files and then call [produce_document] from module [Web]. *) let main () = let files = parse () in Index.init_coqlib_library (); if not !quiet then banner (); if files <> [] then produce_output files let _ = Printexc.catch main () coq-8.4pl4/tools/coqdoc/cdglobals.ml0000644000175000017500000000712312326224777016532 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* "" && Filename.is_relative f then if not (Sys.file_exists !output_dir) then (Printf.eprintf "No such directory: %s\n" !output_dir; exit 1) else Filename.concat !output_dir f else f let open_out_file f = out_channel := try open_out (coqdoc_out f) with Sys_error s -> Printf.eprintf "%s\n" s; exit 1 let close_out_file () = close_out !out_channel type glob_source_t = | NoGlob | DotGlob | GlobFile of string let glob_source = ref DotGlob (*s Manipulations of paths and path aliases *) let normalize_path p = (* We use the Unix subsystem to normalize a physical path (relative or absolute) and get rid of symbolic links, relative links (like ./ or ../ in the middle of the path; it's tricky but it works... *) (* Rq: Sys.getcwd () returns paths without '/' at the end *) let orig = Sys.getcwd () in Sys.chdir p; let res = Sys.getcwd () in Sys.chdir orig; res let normalize_filename f = let basename = Filename.basename f in let dirname = Filename.dirname f in normalize_path dirname, basename (** A weaker analog of the function in Envars *) let guess_coqlib () = let file = "states/initial.coq" in match Coq_config.coqlib with | Some coqlib when Sys.file_exists (Filename.concat coqlib file) -> coqlib | Some _ | None -> let coqbin = normalize_path (Filename.dirname Sys.executable_name) in let prefix = Filename.dirname coqbin in let rpath = if Coq_config.local then [] else (if Coq_config.arch = "win32" then ["lib"] else ["lib";"coq"]) in let coqlib = List.fold_left Filename.concat prefix rpath in if Sys.file_exists (Filename.concat coqlib file) then coqlib else prefix let header_trailer = ref true let header_file = ref "" let header_file_spec = ref false let footer_file = ref "" let footer_file_spec = ref false let quiet = ref true let light = ref false let gallina = ref false let short = ref false let index = ref true let multi_index = ref false let index_name = ref "index" let toc = ref false let page_title = ref "" let title = ref "" let externals = ref true let coqlib = ref Coq_config.wwwstdlib let coqlib_path = ref (guess_coqlib ()) let raw_comments = ref false let parse_comments = ref false let plain_comments = ref false let toc_depth = (ref None : int option ref) let lib_name = ref "Library" let lib_subtitles = ref false let interpolate = ref false let inline_notmono = ref false let charset = ref "iso-8859-1" let inputenc = ref "" let latin1 = ref false let utf8 = ref false let set_latin1 () = charset := "iso-8859-1"; inputenc := "latin1"; latin1 := true let set_utf8 () = charset := "utf-8"; inputenc := "utf8x"; utf8 := true (* Parsing options *) type coq_module = string type file = | Vernac_file of string * coq_module | Latex_file of string coq-8.4pl4/tools/coqdoc/cpretty.mli0000644000175000017500000000122612326224777016441 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Cdglobals.coq_module -> unit val detect_subtitle : string -> Cdglobals.coq_module -> string option coq-8.4pl4/tools/coqdoc/tokens.mli0000644000175000017500000000616012326224777016254 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string -> string -> ttree (* Remove a translation from a dictionary: returns an equal dictionary if the word not present *) val ttree_remove : ttree -> string -> ttree (* Translate a string *) val translate : string -> string option (* Sublexer automaton *) (* The sublexer buffers the chars it receives; if after some time, it recognizes that a sequence of chars has a translation in the current dictionary, it replaces the buffer by the translation *) (* Received chars can come with a "tag" (usually made from informations from the globalization file). A sequence of chars can be considered a word only, if all chars have the same "tag". Rules for cutting words are the following: - in a sequence like "**" where * is in the dictionary but not **, "**" is not translated; otherwise said, to be translated, a sequence must not be surrounded by other symbol-like chars - in a sequence like "<>_h*", where <>_h is in the dictionary, the translation is done because the switch from a letter to a symbol char is an acceptable cutting point - in a sequence like "<>_ha", where <>_h is in the dictionary, the translation is not done because it is considered that h and a are not separable (however, if h and a have different tags, and h has the same tags as <, > and _, the translation happens) - in a sequence like "<>_ha", where <> but not <>_h is in the dictionary, the translation is done for <> and _ha is considered independently because the switch from a symbol char to a letter is considered to be an acceptable cutting point - the longest-word rule applies: if both <> and <>_h are in the dictionary, "<>_h" is one word and gets translated *) (* Warning: do not output anything on output channel inbetween a call to [output_tagged_*] and [flush_sublexer]!! *) type out_function = bool (* needs escape *) -> bool (* it is a symbol, not a pure ident *) -> Index.index_entry option (* the index type of the token if any *) -> string -> unit (* This must be initialized before calling the sublexer *) val token_tree : ttree ref ref val outfun : out_function ref (* Process an ident part that might be a symbol part *) val output_tagged_ident_string : string -> unit (* Process a non-ident char (possibly equipped with a tag) *) val output_tagged_symbol_char : Index.index_entry option -> char -> unit (* Flush the buffered content of the lexer using [outfun] *) val flush_sublexer : unit -> unit coq-8.4pl4/tools/coqdoc/style.css0000644000175000017500000000201312326224777016111 0ustar stephstepha:visited {color : #416DFF; text-decoration : none; } a:link {color : #416DFF; text-decoration : none; font-weight : bold} a:hover {color : Red; text-decoration : underline; } a:active {color : Red; text-decoration : underline; } .keyword { font-weight : bold ; color : Red } .keywordsign { color : #C04600 } .superscript { font-size : 4 } .subscript { font-size : 4 } .comment { color : Green } .constructor { color : Blue } .string { color : Maroon } .warning { color : Red ; font-weight : bold } .info { margin-left : 3em; margin-right : 3em } .title1 { font-size : 20pt ; background-color : #416DFF } .title2 { font-size : 20pt ; background-color : #418DFF } .title3 { font-size : 20pt ; background-color : #41ADFF } .title4 { font-size : 20pt ; background-color : #41CDFF } .title5 { font-size : 20pt ; background-color : #41EDFF } .title6 { font-size : 20pt ; background-color : #41FFFF } body { background-color : White } tr { background-color : White } # .doc { background-color :#aaeeff } .doc { background-color :#66ff66 } coq-8.4pl4/tools/coqdoc/alpha.mli0000644000175000017500000000133512326224777016035 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* char -> int val compare_string : string -> string -> int (* Alphabetic normalization. *) val norm_char : char -> char val norm_string : string -> string coq-8.4pl4/tools/coqdoc/index.mli0000644000175000017500000000363712326224777016066 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string type index_entry = | Def of string * entry_type | Ref of coq_module * string * entry_type (* Find what symbol coqtop said is located at loc in the source file *) val find : coq_module -> loc -> index_entry (* Find what data is referred to by some string in some coq module *) val find_string : coq_module -> string -> index_entry val add_module : coq_module -> unit type module_kind = Local | External of coq_module | Unknown val find_module : coq_module -> module_kind val init_coqlib_library : unit -> unit val add_external_library : string -> coq_module -> unit (*s Read globalizations from a file (produced by coqc -dump-glob) *) val read_glob : Digest.t option -> string -> unit (*s Indexes *) type 'a index = { idx_name : string; idx_entries : (char * (string * 'a) list) list; idx_size : int } val current_library : string ref val display_letter : char -> string val prepare_entry : string -> entry_type -> string val all_entries : unit -> (coq_module * entry_type) index * (entry_type * coq_module index) list val map : (string -> 'a -> 'b) -> 'a index -> 'b index coq-8.4pl4/tools/coqdoc/cpretty.mll0000644000175000017500000012016112326224777016444 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [] | (l :: ls) -> l :: (take (n-1) ls) (* count the number of spaces at the beginning of a string *) let count_spaces s = let n = String.length s in let rec count c i = if i == n then c,i else match s.[i] with | '\t' -> count (c + (8 - (c mod 8))) (i + 1) | ' ' -> count (c + 1) (i + 1) | _ -> c,i in count 0 0 let remove_newline s = let n = String.length s in let rec count i = if i == n || s.[i] <> '\n' then i else count (i + 1) in let i = count 0 in i, String.sub s i (n - i) let count_dashes s = let c = ref 0 in for i = 0 to String.length s - 1 do if s.[i] = '-' then incr c done; !c let cut_head_tail_spaces s = let n = String.length s in let rec look_up i = if i == n || s.[i] <> ' ' then i else look_up (i+1) in let rec look_dn i = if i == -1 || s.[i] <> ' ' then i else look_dn (i-1) in let l = look_up 0 in let r = look_dn (n-1) in if l <= r then String.sub s l (r-l+1) else s let sec_title s = let rec count lev i = if s.[i] = '*' then count (succ lev) (succ i) else let t = String.sub s i (String.length s - i) in lev, cut_head_tail_spaces t in count 0 (String.index s '*') let strip_eol s = let eol = s.[String.length s - 1] = '\n' in (eol, if eol then String.sub s 1 (String.length s - 1) else s) let formatted = ref false let brackets = ref 0 let comment_level = ref 0 let in_proof = ref None let in_emph = ref false let in_env start stop = let r = ref false in let start_env () = r := true; start () in let stop_env () = if !r then stop (); r := false in (fun x -> !r), start_env, stop_env let in_emph, start_emph, stop_emph = in_env Output.start_emph Output.stop_emph let in_quote, start_quote, stop_quote = in_env Output.start_quote Output.stop_quote let url_buffer = Buffer.create 40 let url_name_buffer = Buffer.create 40 let backtrack lexbuf = lexbuf.lex_curr_pos <- lexbuf.lex_start_pos; lexbuf.lex_curr_p <- lexbuf.lex_start_p let backtrack_past_newline lexbuf = let buf = lexeme lexbuf in let splits = Str.bounded_split_delim (Str.regexp "['\n']") buf 2 in match splits with | [] -> () | (_ :: []) -> () | (s1 :: rest :: _) -> let length_skip = 1 + String.length s1 in lexbuf.lex_curr_pos <- lexbuf.lex_start_pos + length_skip let is_space = function ' ' | '\t' | '\n' | '\r' -> true | _ -> false (* saving/restoring the PP state *) type state = { st_gallina : bool; st_light : bool } let state_stack = Stack.create () let save_state () = Stack.push { st_gallina = !Cdglobals.gallina; st_light = !Cdglobals.light } state_stack let restore_state () = let s = Stack.pop state_stack in Cdglobals.gallina := s.st_gallina; Cdglobals.light := s.st_light let without_ref r f x = save_state (); r := false; f x; restore_state () let without_gallina = without_ref Cdglobals.gallina let without_light = without_ref Cdglobals.light let show_all f = without_gallina (without_light f) let begin_show () = save_state (); Cdglobals.gallina := false; Cdglobals.light := false let end_show () = restore_state () (* Reset the globals *) let reset () = formatted := false; brackets := 0; comment_level := 0 (* erasing of Section/End *) let section_re = Str.regexp "[ \t]*Section" let end_re = Str.regexp "[ \t]*End" let is_section s = Str.string_match section_re s 0 let is_end s = Str.string_match end_re s 0 let sections_to_close = ref 0 let section_or_end s = if is_section s then begin incr sections_to_close; true end else if is_end s then begin if !sections_to_close > 0 then begin decr sections_to_close; true end else false end else true (* for item lists *) type list_compare = | Before | StartLevel of int | InLevel of int * bool (* Before : we're before any levels StartLevel : at the same column as the dash in a level InLevel : after the dash of this level, but before any deeper dashes. bool is true if this is the last level *) let find_level levels cur_indent = match levels with | [] -> Before | (l::ls) -> if cur_indent < l then Before else (* cur_indent will never be less than the head of the list *) let rec findind ls n = match ls with | [] -> InLevel (n,true) | (l :: []) -> if cur_indent = l then StartLevel n else InLevel (n,true) | (l1 :: l2 :: ls) -> if cur_indent = l1 then StartLevel n else if cur_indent < l2 then InLevel (n,false) else findind (l2 :: ls) (n+1) in findind (l::ls) 1 type is_start_list = | Rule | List of int | Neither let check_start_list str = let n_dashes = count_dashes str in let (n_spaces,_) = count_spaces str in if n_dashes >= 4 && not !Cdglobals.plain_comments then Rule else if n_dashes = 1 && not !Cdglobals.plain_comments then List n_spaces else Neither (* examine a string for subtitleness *) let subtitle m s = match Str.split_delim (Str.regexp ":") s with | [] -> false | (name::_) -> if (cut_head_tail_spaces name) = m then true else false (* tokens pretty-print *) let token_buffer = Buffer.create 1024 let token_re = Str.regexp "[ \t]*(\\*\\*[ \t]+printing[ \t]+\\([^ \t]+\\)" let printing_token_re = Str.regexp "[ \t]*\\(\\(%\\([^%]*\\)%\\)\\|\\(\\$[^$]*\\$\\)\\)?[ \t]*\\(#\\(\\(&#\\|[^#]\\)*\\)#\\)?" let add_printing_token toks pps = try if Str.string_match token_re toks 0 then let tok = Str.matched_group 1 toks in if Str.string_match printing_token_re pps 0 then let pp = (try Some (Str.matched_group 3 pps) with _ -> try Some (Str.matched_group 4 pps) with _ -> None), (try Some (Str.matched_group 6 pps) with _ -> None) in Output.add_printing_token tok pp with _ -> () let remove_token_re = Str.regexp "[ \t]*(\\*\\*[ \t]+remove[ \t]+printing[ \t]+\\([^ \t]+\\)[ \t]*\\*)" let remove_printing_token toks = try if Str.string_match remove_token_re toks 0 then let tok = Str.matched_group 1 toks in Output.remove_printing_token tok with _ -> () let extract_ident_re = Str.regexp "([ \t]*\\([^ \t]+\\)[ \t]*:=" let extract_ident s = assert (String.length s >= 3); if Str.string_match extract_ident_re s 0 then Str.matched_group 1 s else String.sub s 1 (String.length s - 3) let output_indented_keyword s lexbuf = let nbsp,isp = count_spaces s in Output.indentation nbsp; let s = String.sub s isp (String.length s - isp) in Output.keyword s (lexeme_start lexbuf + isp) } (*s Regular expressions *) let space = [' ' '\t'] let space_nl = [' ' '\t' '\n' '\r'] let nl = "\r\n" | '\n' let firstchar = ['A'-'Z' 'a'-'z' '_'] | (* superscript 1 *) '\194' '\185' | (* utf-8 latin 1 supplement *) '\195' ['\128'-'\150'] | '\195' ['\152'-'\182'] | '\195' ['\184'-'\191'] | (* utf-8 letterlike symbols *) (* '\206' ([ '\145' - '\183'] | '\187') | *) (* '\xCF' [ '\x00' - '\xCE' ] | *) (* utf-8 letterlike symbols *) '\206' (['\145'-'\161'] | ['\163'-'\187']) | '\226' ('\130' [ '\128'-'\137' ] (* subscripts *) | '\129' [ '\176'-'\187' ] (* superscripts *) | '\132' ['\128'-'\191'] | '\133' ['\128'-'\143']) let identchar = firstchar | ['\'' '0'-'9' '@' ] let id = firstchar identchar* let pfx_id = (id '.')* let identifier = id | pfx_id id (* This misses unicode stuff, and it adds "[" and "]". It's only an approximation of idents - used for detecting whether an underscore is part of an identifier or meant to indicate emphasis *) let nonidentchar = [^ 'A'-'Z' 'a'-'z' '_' '[' ']' '\'' '0'-'9' '@' ] let printing_token = [^ ' ' '\t']* let thm_token = "Theorem" | "Lemma" | "Fact" | "Remark" | "Corollary" | "Proposition" | "Property" | "Goal" let prf_token = "Next" space+ "Obligation" | "Proof" (space* "." | space+ "with" | space+ "using") let immediate_prf_token = (* Approximation of a proof term, if not in the prf_token case *) (* To be checked after prf_token *) "Proof" space* [^ '.' 'w' 'u'] let def_token = "Definition" | "Let" | "Class" | "SubClass" | "Example" | "Fixpoint" | "Function" | "Boxed" | "CoFixpoint" | "Record" | "Structure" | "Scheme" | "Inductive" | "CoInductive" | "Equations" | "Instance" | "Declare" space+ "Instance" | "Global" space+ "Instance" let decl_token = "Hypothesis" | "Hypotheses" | "Parameter" | "Axiom" 's'? | "Conjecture" let gallina_ext = "Module" | "Include" space+ "Type" | "Include" | "Declare" space+ "Module" | "Transparent" | "Opaque" | "Canonical" | "Coercion" | "Identity" | "Implicit" | "Tactic" space+ "Notation" | "Section" | "Context" | "Variable" 's'? | ("Hypothesis" | "Hypotheses") | "End" let notation_kw = "Notation" | "Infix" | "Reserved" space+ "Notation" let commands = "Pwd" | "Cd" | "Drop" | "ProtectedLoop" | "Quit" | "Restart" | "Load" | "Add" | "Remove" space+ "Loadpath" | "Print" | "Inspect" | "About" | "SearchAbout" | "SearchRewrite" | "Search" | "Locate" | "Eval" | "Reset" | "Check" | "Type" | "Section" | "Chapter" | "Variable" 's'? | ("Hypothesis" | "Hypotheses") | "End" let end_kw = immediate_prf_token | "Qed" | "Defined" | "Save" | "Admitted" | "Abort" let extraction = "Extraction" | "Recursive" space+ "Extraction" | "Extract" let gallina_kw = thm_token | def_token | decl_token | gallina_ext | commands | extraction let prog_kw = "Program" space+ gallina_kw | "Obligation" | "Obligations" | "Solve" let hint_kw = "Extern" | "Rewrite" | "Resolve" | "Immediate" | "Transparent" | "Opaque" | "Unfold" | "Constructors" let set_kw = "Printing" space+ ("Coercions" | "Universes" | "All") | "Implicit" space+ "Arguments" let gallina_kw_to_hide = "Implicit" space+ "Arguments" | "Ltac" | "Require" | "Import" | "Export" | "Load" | "Hint" space+ hint_kw | "Open" | "Close" | "Delimit" | "Transparent" | "Opaque" | ("Declare" space+ ("Morphism" | "Step") ) | ("Set" | "Unset") space+ set_kw | "Declare" space+ ("Left" | "Right") space+ "Step" | "Debug" space+ ("On" | "Off") let section = "*" | "**" | "***" | "****" let item_space = " " let begin_hide = "(*" space* "begin" space+ "hide" space* "*)" space* nl let end_hide = "(*" space* "end" space+ "hide" space* "*)" space* nl let begin_show = "(*" space* "begin" space+ "show" space* "*)" space* nl let end_show = "(*" space* "end" space+ "show" space* "*)" space* nl (* let begin_verb = "(*" space* "begin" space+ "verb" space* "*)" let end_verb = "(*" space* "end" space+ "verb" space* "*)" *) (*s Scanning Coq, at beginning of line *) rule coq_bol = parse | space* nl+ { if not (!in_proof <> None && (!Cdglobals.gallina || !Cdglobals.light)) then Output.empty_line_of_code (); coq_bol lexbuf } | space* "(**" space_nl { Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); if eol then coq_bol lexbuf else coq lexbuf } | space* "Comments" space_nl { Output.end_coq (); Output.start_doc (); comments lexbuf; Output.end_doc (); Output.start_coq (); coq lexbuf } | space* begin_hide { skip_hide lexbuf; coq_bol lexbuf } | space* begin_show { begin_show (); coq_bol lexbuf } | space* end_show { end_show (); coq_bol lexbuf } | space* ("Local"|"Global") { in_proof := None; let s = lexeme lexbuf in output_indented_keyword s lexbuf; coq_bol lexbuf } | space* gallina_kw_to_hide { let s = lexeme lexbuf in if !Cdglobals.light && section_or_end s then let eol = skip_to_dot lexbuf in if eol then (coq_bol lexbuf) else coq lexbuf else begin output_indented_keyword s lexbuf; let eol = body lexbuf in if eol then coq_bol lexbuf else coq lexbuf end } | space* thm_token { let s = lexeme lexbuf in output_indented_keyword s lexbuf; let eol = body lexbuf in in_proof := Some eol; if eol then coq_bol lexbuf else coq lexbuf } | space* prf_token { in_proof := Some true; let eol = if not !Cdglobals.gallina then begin backtrack lexbuf; body_bol lexbuf end else let s = lexeme lexbuf in if s.[String.length s - 1] = '.' then false else skip_to_dot lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | space* end_kw { let eol = if not (!in_proof <> None && !Cdglobals.gallina) then begin backtrack lexbuf; body_bol lexbuf end else skip_to_dot lexbuf in in_proof := None; if eol then coq_bol lexbuf else coq lexbuf } | space* gallina_kw { in_proof := None; let s = lexeme lexbuf in output_indented_keyword s lexbuf; let eol= body lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | space* prog_kw { in_proof := None; let s = lexeme lexbuf in output_indented_keyword s lexbuf; let eol= body lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | space* notation_kw { let s = lexeme lexbuf in output_indented_keyword s lexbuf; let eol= start_notation_string lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | space* "(**" space+ "printing" space+ printing_token space+ { let tok = lexeme lexbuf in let s = printing_token_body lexbuf in add_printing_token tok s; coq_bol lexbuf } | space* "(**" space+ "printing" space+ { eprintf "warning: bad 'printing' command at character %d\n" (lexeme_start lexbuf); flush stderr; comment_level := 1; ignore (comment lexbuf); coq_bol lexbuf } | space* "(**" space+ "remove" space+ "printing" space+ printing_token space* "*)" { remove_printing_token (lexeme lexbuf); coq_bol lexbuf } | space* "(**" space+ "remove" space+ "printing" space+ { eprintf "warning: bad 'remove printing' command at character %d\n" (lexeme_start lexbuf); flush stderr; comment_level := 1; ignore (comment lexbuf); coq_bol lexbuf } | space* "(*" { comment_level := 1; if !Cdglobals.parse_comments then begin let s = lexeme lexbuf in let nbsp,isp = count_spaces s in Output.indentation nbsp; Output.start_comment (); end; let eol = comment lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | eof { () } | _ { let eol = if not !Cdglobals.gallina then begin backtrack lexbuf; body_bol lexbuf end else skip_to_dot lexbuf in if eol then coq_bol lexbuf else coq lexbuf } (*s Scanning Coq elsewhere *) and coq = parse | nl { if not (!in_proof <> None && !Cdglobals.gallina) then Output.line_break(); coq_bol lexbuf } | "(**" space_nl { Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); if eol then coq_bol lexbuf else coq lexbuf } | "(*" { comment_level := 1; if !Cdglobals.parse_comments then begin let s = lexeme lexbuf in let nbsp,isp = count_spaces s in Output.indentation nbsp; Output.start_comment (); end; let eol = comment lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | nl+ space* "]]" { if not !formatted then begin (* Isn't this an anomaly *) let s = lexeme lexbuf in let nlsp,s = remove_newline s in let nbsp,isp = count_spaces s in Output.indentation nbsp; let loc = lexeme_start lexbuf + isp + nlsp in Output.sublexer ']' loc; Output.sublexer ']' (loc+1); coq lexbuf end } | eof { () } | gallina_kw_to_hide { let s = lexeme lexbuf in if !Cdglobals.light && section_or_end s then begin let eol = skip_to_dot lexbuf in if eol then coq_bol lexbuf else coq lexbuf end else begin Output.ident s (lexeme_start lexbuf); let eol=body lexbuf in if eol then coq_bol lexbuf else coq lexbuf end } | prf_token { let eol = if not !Cdglobals.gallina then begin backtrack lexbuf; body lexbuf end else let s = lexeme lexbuf in let eol = if s.[String.length s - 1] = '.' then false else skip_to_dot lexbuf in eol in if eol then coq_bol lexbuf else coq lexbuf } | end_kw { let eol = if not !Cdglobals.gallina then begin backtrack lexbuf; body lexbuf end else let eol = skip_to_dot lexbuf in if !in_proof <> Some true && eol then Output.line_break (); eol in in_proof := None; if eol then coq_bol lexbuf else coq lexbuf } | gallina_kw { let s = lexeme lexbuf in Output.ident s (lexeme_start lexbuf); let eol = body lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | notation_kw { let s = lexeme lexbuf in Output.ident s (lexeme_start lexbuf); let eol= start_notation_string lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | prog_kw { let s = lexeme lexbuf in Output.ident s (lexeme_start lexbuf); let eol = body lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | space+ { Output.char ' '; coq lexbuf } | eof { () } | _ { let eol = if not !Cdglobals.gallina then begin backtrack lexbuf; body lexbuf end else skip_to_dot lexbuf in if eol then coq_bol lexbuf else coq lexbuf} (*s Scanning documentation, at beginning of line *) and doc_bol = parse | space* section space+ ([^'\n' '*'] | '*'+ [^'\n' ')' '*'])* ('*'+ '\n')? { let eol, lex = strip_eol (lexeme lexbuf) in let lev, s = sec_title lex in if (!Cdglobals.lib_subtitles) && (subtitle (Output.get_module false) s) then () else Output.section lev (fun () -> ignore (doc None (from_string s))); if eol then doc_bol lexbuf else doc None lexbuf } | space_nl* '-'+ { let buf' = lexeme lexbuf in let bufs = Str.split_delim (Str.regexp "['\n']") buf' in let lines = (List.length bufs) - 1 in let line = match bufs with | [] -> eprintf "Internal error bad_split1 - please report\n"; exit 1 | _ -> List.nth bufs lines in match check_start_list line with | Neither -> backtrack_past_newline lexbuf; doc None lexbuf | List n -> Output.paragraph (); Output.item 1; doc (Some [n]) lexbuf | Rule -> Output.rule (); doc None lexbuf } | space* nl+ { Output.paragraph (); doc_bol lexbuf } | "<<" space* { Output.start_verbatim false; verbatim false lexbuf; doc_bol lexbuf } | eof { true } | '_' { if !Cdglobals.plain_comments then Output.char '_' else start_emph (); doc None lexbuf } | _ { backtrack lexbuf; doc None lexbuf } (*s Scanning lists - using whitespace *) and doc_list_bol indents = parse | space* '-' { let (n_spaces,_) = count_spaces (lexeme lexbuf) in match find_level indents n_spaces with | Before -> backtrack lexbuf; doc_bol lexbuf | StartLevel n -> Output.item n; doc (Some (take n indents)) lexbuf | InLevel (n,true) -> let items = List.length indents in Output.item (items+1); doc (Some (List.append indents [n_spaces])) lexbuf | InLevel (_,false) -> backtrack lexbuf; doc_bol lexbuf } | "<<" space* { Output.start_verbatim false; verbatim false lexbuf; doc_list_bol indents lexbuf } | "[[" nl { formatted := true; Output.start_inline_coq_block (); ignore(body_bol lexbuf); Output.end_inline_coq_block (); formatted := false; doc_list_bol indents lexbuf } | "[[[" nl { inf_rules (Some indents) lexbuf } | space* nl space* '-' { (* Like in the doc_bol production, these two productions exist only to deal properly with whitespace *) Output.paragraph (); backtrack_past_newline lexbuf; doc_list_bol indents lexbuf } | space* nl space* _ { let buf' = lexeme lexbuf in let buf = let bufs = Str.split_delim (Str.regexp "['\n']") buf' in match bufs with | (_ :: s :: []) -> s | (_ :: _ :: s :: _) -> s | _ -> eprintf "Internal error bad_split2 - please report\n"; exit 1 in let (n_spaces,_) = count_spaces buf in match find_level indents n_spaces with | InLevel _ -> Output.paragraph (); backtrack_past_newline lexbuf; doc_list_bol indents lexbuf | StartLevel n -> if n = 1 then begin Output.stop_item (); backtrack_past_newline lexbuf; doc_bol lexbuf end else begin Output.paragraph (); backtrack_past_newline lexbuf; doc_list_bol indents lexbuf end | Before -> (* Here we were at the beginning of a line, and it was blank. The next line started before any list items. So: insert a paragraph for the empty line, rewind to whatever's just after the newline, then toss over to doc_bol for whatever comes next. *) Output.stop_item (); Output.paragraph (); backtrack_past_newline lexbuf; doc_bol lexbuf } | space* _ { let (n_spaces,_) = count_spaces (lexeme lexbuf) in match find_level indents n_spaces with | Before -> Output.stop_item (); backtrack lexbuf; doc_bol lexbuf | StartLevel n -> (if n = 1 then Output.stop_item () else Output.reach_item_level (n-1)); backtrack lexbuf; doc (Some (take (n-1) indents)) lexbuf | InLevel (n,_) -> Output.reach_item_level n; backtrack lexbuf; doc (Some (take n indents)) lexbuf } (*s Scanning documentation elsewhere *) and doc indents = parse | nl { Output.char '\n'; match indents with | Some ls -> doc_list_bol ls lexbuf | None -> doc_bol lexbuf } | "[[" nl { if !Cdglobals.plain_comments then (Output.char '['; Output.char '['; doc indents lexbuf) else (formatted := true; Output.start_inline_coq_block (); let eol = body_bol lexbuf in Output.end_inline_coq_block (); formatted := false; if eol then match indents with | Some ls -> doc_list_bol ls lexbuf | None -> doc_bol lexbuf else doc indents lexbuf)} | "[[[" nl { inf_rules indents lexbuf } | "[]" { Output.proofbox (); doc indents lexbuf } | "{{" { url lexbuf; doc indents lexbuf } | "[" { if !Cdglobals.plain_comments then Output.char '[' else (brackets := 1; Output.start_inline_coq (); escaped_coq lexbuf; Output.end_inline_coq ()); doc indents lexbuf } | "(*" { backtrack lexbuf ; let bol_parse = match indents with | Some is -> doc_list_bol is | None -> doc_bol in let eol = comment lexbuf in if eol then bol_parse lexbuf else doc indents lexbuf } | '*'* "*)" space_nl* "(**" {(match indents with | Some _ -> Output.stop_item () | None -> ()); (* this says - if there is a blank line between the two comments, insert one in the output too *) let lines = List.length (Str.split_delim (Str.regexp "['\n']") (lexeme lexbuf)) in if lines > 2 then Output.paragraph (); doc_bol lexbuf } | '*'* "*)" space* nl { true } | '*'* "*)" { false } | "$" { if !Cdglobals.plain_comments then Output.char '$' else (Output.start_latex_math (); escaped_math_latex lexbuf); doc indents lexbuf } | "$$" { if !Cdglobals.plain_comments then Output.char '$'; Output.char '$'; doc indents lexbuf } | "%" { if !Cdglobals.plain_comments then Output.char '%' else escaped_latex lexbuf; doc indents lexbuf } | "%%" { if !Cdglobals.plain_comments then Output.char '%'; Output.char '%'; doc indents lexbuf } | "#" { if !Cdglobals.plain_comments then Output.char '#' else escaped_html lexbuf; doc indents lexbuf } | "##" { if !Cdglobals.plain_comments then Output.char '#'; Output.char '#'; doc indents lexbuf } | nonidentchar '_' nonidentchar { List.iter (fun x -> Output.char (lexeme_char lexbuf x)) [0;1;2]; doc indents lexbuf} | nonidentchar '_' { Output.char (lexeme_char lexbuf 0); if !Cdglobals.plain_comments then Output.char '_' else start_emph () ; doc indents lexbuf } | '_' nonidentchar { if !Cdglobals.plain_comments then Output.char '_' else stop_emph () ; Output.char (lexeme_char lexbuf 1); doc indents lexbuf } | "<<" space* { Output.start_verbatim true; verbatim true lexbuf; doc_bol lexbuf } | '"' { if !Cdglobals.plain_comments then Output.char '"' else if in_quote () then stop_quote () else start_quote (); doc indents lexbuf } | eof { false } | _ { Output.char (lexeme_char lexbuf 0); doc indents lexbuf } (*s Various escapings *) and escaped_math_latex = parse | "$" { Output.stop_latex_math () } | eof { Output.stop_latex_math () } | _ { Output.latex_char (lexeme_char lexbuf 0); escaped_math_latex lexbuf } and escaped_latex = parse | "%" { () } | eof { () } | _ { Output.latex_char (lexeme_char lexbuf 0); escaped_latex lexbuf } and escaped_html = parse | "#" { () } | "&#" { Output.html_char '&'; Output.html_char '#'; escaped_html lexbuf } | "##" { Output.html_char '#'; escaped_html lexbuf } | eof { () } | _ { Output.html_char (lexeme_char lexbuf 0); escaped_html lexbuf } and verbatim inline = parse | nl ">>" space* nl { Output.verbatim_char inline '\n'; Output.stop_verbatim inline } | nl ">>" { Output.verbatim_char inline '\n'; Output.stop_verbatim inline } | ">>" { Output.stop_verbatim inline } | eof { Output.stop_verbatim inline } | _ { Output.verbatim_char inline (lexeme_char lexbuf 0); verbatim inline lexbuf } and url = parse | "}}" { Output.url (Buffer.contents url_buffer) None; Buffer.clear url_buffer } | "}" { url_name lexbuf } | _ { Buffer.add_char url_buffer (lexeme_char lexbuf 0); url lexbuf } and url_name = parse | "}" { Output.url (Buffer.contents url_buffer) (Some (Buffer.contents url_name_buffer)); Buffer.clear url_buffer; Buffer.clear url_name_buffer } | _ { Buffer.add_char url_name_buffer (lexeme_char lexbuf 0); url_name lexbuf } (*s Coq, inside quotations *) and escaped_coq = parse | "]" { decr brackets; if !brackets > 0 then (Output.sublexer ']' (lexeme_start lexbuf); escaped_coq lexbuf) else Tokens.flush_sublexer () } | "[" { incr brackets; Output.sublexer '[' (lexeme_start lexbuf); escaped_coq lexbuf } | "(*" { Tokens.flush_sublexer (); comment_level := 1; ignore (comment lexbuf); escaped_coq lexbuf } | "*)" { (* likely to be a syntax error: we escape *) backtrack lexbuf } | eof { Tokens.flush_sublexer () } | (identifier '.')* identifier { Tokens.flush_sublexer(); Output.ident (lexeme lexbuf) (lexeme_start lexbuf); escaped_coq lexbuf } | space_nl* { let str = lexeme lexbuf in Tokens.flush_sublexer(); (if !Cdglobals.inline_notmono then () else Output.end_inline_coq ()); String.iter Output.char str; (if !Cdglobals.inline_notmono then () else Output.start_inline_coq ()); escaped_coq lexbuf } | _ { Output.sublexer (lexeme_char lexbuf 0) (lexeme_start lexbuf); escaped_coq lexbuf } (*s Coq "Comments" command. *) and comments = parse | space_nl+ { Output.char ' '; comments lexbuf } | '"' [^ '"']* '"' { let s = lexeme lexbuf in let s = String.sub s 1 (String.length s - 2) in ignore (doc None (from_string s)); comments lexbuf } | ([^ '.' '"'] | '.' [^ ' ' '\t' '\n'])+ { escaped_coq (from_string (lexeme lexbuf)); comments lexbuf } | "." (space_nl | eof) { () } | eof { () } | _ { Output.char (lexeme_char lexbuf 0); comments lexbuf } (*s Skip comments *) and comment = parse | "(*" { incr comment_level; if !Cdglobals.parse_comments then Output.start_comment (); comment lexbuf } | "*)" space* nl { if !Cdglobals.parse_comments then (Output.end_comment (); Output.line_break ()); decr comment_level; if !comment_level > 0 then comment lexbuf else true } | "*)" { if !Cdglobals.parse_comments then (Output.end_comment ()); decr comment_level; if !comment_level > 0 then comment lexbuf else false } | "[" { if !Cdglobals.parse_comments then if !Cdglobals.plain_comments then Output.char '[' else (brackets := 1; Output.start_inline_coq (); escaped_coq lexbuf; Output.end_inline_coq ()); comment lexbuf } | "[[" nl { if !Cdglobals.parse_comments then if !Cdglobals.plain_comments then (Output.char '['; Output.char '[') else (formatted := true; Output.start_inline_coq_block (); let _ = body_bol lexbuf in Output.end_inline_coq_block (); formatted := false); comment lexbuf} | "$" { if !Cdglobals.parse_comments then if !Cdglobals.plain_comments then Output.char '$' else (Output.start_latex_math (); escaped_math_latex lexbuf); comment lexbuf } | "$$" { if !Cdglobals.parse_comments then (if !Cdglobals.plain_comments then Output.char '$'; Output.char '$'); doc None lexbuf } | "%" { if !Cdglobals.parse_comments then if !Cdglobals.plain_comments then Output.char '%' else escaped_latex lexbuf; comment lexbuf } | "%%" { if !Cdglobals.parse_comments then (if !Cdglobals.plain_comments then Output.char '%'; Output.char '%'); comment lexbuf } | "#" { if !Cdglobals.parse_comments then if !Cdglobals.plain_comments then Output.char '$' else escaped_html lexbuf; comment lexbuf } | "##" { if !Cdglobals.parse_comments then (if !Cdglobals.plain_comments then Output.char '#'; Output.char '#'); comment lexbuf } | eof { false } | space+ { if !Cdglobals.parse_comments then Output.indentation (fst (count_spaces (lexeme lexbuf))); comment lexbuf } | nl { if !Cdglobals.parse_comments then Output.line_break (); comment lexbuf } | _ { if !Cdglobals.parse_comments then Output.char (lexeme_char lexbuf 0); comment lexbuf } and skip_to_dot = parse | '.' space* nl { true } | eof | '.' space+ { false } | "(*" { comment_level := 1; ignore (comment lexbuf); skip_to_dot lexbuf } | _ { skip_to_dot lexbuf } and body_bol = parse | space+ { Output.indentation (fst (count_spaces (lexeme lexbuf))); body lexbuf } | _ { backtrack lexbuf; Output.indentation 0; body lexbuf } and body = parse | nl {Tokens.flush_sublexer(); Output.line_break(); new_line lexbuf; body_bol lexbuf} | nl+ space* "]]" space* nl { Tokens.flush_sublexer(); if not !formatted then begin let s = lexeme lexbuf in let nlsp,s = remove_newline s in let _,isp = count_spaces s in let loc = lexeme_start lexbuf + nlsp + isp in Output.sublexer ']' loc; Output.sublexer ']' (loc+1); Tokens.flush_sublexer(); body lexbuf end else begin Output.paragraph (); true end } | "]]" space* nl { Tokens.flush_sublexer(); if not !formatted then begin let loc = lexeme_start lexbuf in Output.sublexer ']' loc; Output.sublexer ']' (loc+1); Tokens.flush_sublexer(); Output.line_break(); body lexbuf end else begin Output.paragraph (); true end } | eof { Tokens.flush_sublexer(); false } | '.' space* nl | '.' space* eof { Tokens.flush_sublexer(); Output.char '.'; Output.line_break(); if not !formatted then true else body_bol lexbuf } | '.' space* nl "]]" space* nl { Tokens.flush_sublexer(); Output.char '.'; if not !formatted then begin eprintf "Error: stray ]] at %d\n" (lexeme_start lexbuf); flush stderr; exit 1 end else begin Output.paragraph (); true end } | '.' space+ { Tokens.flush_sublexer(); Output.char '.'; Output.char ' '; if not !formatted then false else body lexbuf } | "(**" space_nl { Tokens.flush_sublexer(); Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); if eol then body_bol lexbuf else body lexbuf } | "(*" { Tokens.flush_sublexer(); comment_level := 1; if !Cdglobals.parse_comments then Output.start_comment (); let eol = comment lexbuf in if eol then begin if not !Cdglobals.parse_comments then Output.line_break(); body_bol lexbuf end else body lexbuf } | "where" { Tokens.flush_sublexer(); Output.ident (lexeme lexbuf) (lexeme_start lexbuf); start_notation_string lexbuf } | identifier { Tokens.flush_sublexer(); Output.ident (lexeme lexbuf) (lexeme_start lexbuf); body lexbuf } | ".." { Tokens.flush_sublexer(); Output.char '.'; Output.char '.'; body lexbuf } | '"' { Tokens.flush_sublexer(); Output.char '"'; string lexbuf; body lexbuf } | space { Tokens.flush_sublexer(); Output.char (lexeme_char lexbuf 0); body lexbuf } | _ { let c = lexeme_char lexbuf 0 in Output.sublexer c (lexeme_start lexbuf); body lexbuf } and start_notation_string = parse | space { Tokens.flush_sublexer(); Output.char (lexeme_char lexbuf 0); start_notation_string lexbuf } | '"' (* a true notation *) { Output.sublexer '"' (lexeme_start lexbuf); notation_string lexbuf; body lexbuf } | _ (* an abbreviation *) { backtrack lexbuf; body lexbuf } and notation_string = parse | "\"\"" { Output.char '"'; Output.char '"'; (* Unlikely! *) notation_string lexbuf } | '"' { Tokens.flush_sublexer(); Output.char '"' } | _ { let c = lexeme_char lexbuf 0 in Output.sublexer c (lexeme_start lexbuf); notation_string lexbuf } and string = parse | "\"\"" { Output.char '"'; Output.char '"'; string lexbuf } | '"' { Output.char '"' } | _ { let c = lexeme_char lexbuf 0 in Output.char c; string lexbuf } and skip_hide = parse | eof | end_hide { () } | _ { skip_hide lexbuf } (*s Reading token pretty-print *) and printing_token_body = parse | "*)" nl? | eof { let s = Buffer.contents token_buffer in Buffer.clear token_buffer; s } | _ { Buffer.add_string token_buffer (lexeme lexbuf); printing_token_body lexbuf } (*s These handle inference rules, parsing the body segments of things enclosed in [[[ ]]] brackets *) and inf_rules indents = parse | space* nl (* blank line, before or between definitions *) { inf_rules indents lexbuf } | "]]]" nl (* end of the inference rules block *) { match indents with | Some ls -> doc_list_bol ls lexbuf | None -> doc_bol lexbuf } | _ { backtrack lexbuf; (* anything else must be the first line in a rule *) inf_rules_assumptions indents [] lexbuf} (* The inference rule parsing just collects the inference rule and then calls the output function once, instead of doing things incrementally like the rest of the lexer. If only there were a real parsing phase... *) and inf_rules_assumptions indents assumptions = parse | space* "---" '-'* [^ '\n']* nl (* hit the horizontal line *) { let line = lexeme lexbuf in let (spaces,_) = count_spaces line in let dashes_and_name = cut_head_tail_spaces (String.sub line 0 (String.length line - 1)) in let ldn = String.length dashes_and_name in let (dashes,name) = try (let i = String.index dashes_and_name ' ' in let d = String.sub dashes_and_name 0 i in let n = cut_head_tail_spaces (String.sub dashes_and_name (i+1) (ldn-i-1)) in (d, Some n)) with _ -> (dashes_and_name, None) in inf_rules_conclusion indents (List.rev assumptions) (spaces, dashes, name) [] lexbuf } | [^ '\n']* nl (* if it's not the horizontal line, it's an assumption *) { let line = lexeme lexbuf in let (spaces,_) = count_spaces line in let assumption = cut_head_tail_spaces (String.sub line 0 (String.length line - 1)) in inf_rules_assumptions indents ((spaces,assumption)::assumptions) lexbuf } (*s The conclusion is required to come immediately after the horizontal bar. It is allowed to contain multiple lines of text, like the assumptions. The conclusion ends when we spot a blank line or a ']]]'. *) and inf_rules_conclusion indents assumptions middle conclusions = parse | space* nl | space* "]]]" nl (* end of conclusions. *) { backtrack lexbuf; Output.inf_rule assumptions middle (List.rev conclusions); inf_rules indents lexbuf } | space* [^ '\n']+ nl (* this is a line in the conclusion *) { let line = lexeme lexbuf in let (spaces,_) = count_spaces line in let conc = cut_head_tail_spaces (String.sub line 0 (String.length line - 1)) in inf_rules_conclusion indents assumptions middle ((spaces,conc) :: conclusions) lexbuf } (*s A small scanner to support the chapter subtitle feature *) and st_start m = parse | "(*" "*"+ space+ "*" space+ { st_modname m lexbuf } | _ { None } and st_modname m = parse | identifier space* ":" space* { if subtitle m (lexeme lexbuf) then st_subtitle lexbuf else None } | _ { None } and st_subtitle = parse | [^ '\n']* '\n' { let st = lexeme lexbuf in let i = try Str.search_forward (Str.regexp "\\**)") st 0 with Not_found -> (eprintf "unterminated comment at beginning of file\n"; exit 1) in Some (cut_head_tail_spaces (String.sub st 0 i)) } | _ { None } (*s Applying the scanners to files *) { let coq_file f m = reset (); let c = open_in f in let lb = from_channel c in (Index.current_library := m; Output.initialize (); Output.start_module (); Output.start_coq (); coq_bol lb; Output.end_coq (); close_in c) let detect_subtitle f m = let c = open_in f in let lb = from_channel c in let sub = st_start m lb in close_in c; sub } coq-8.4pl4/tools/coqdoc/output.mli0000644000175000017500000000604612326224777016314 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val add_printing_token : string -> string option * string option -> unit val remove_printing_token : string -> unit val set_module : coq_module -> string option -> unit val get_module : bool -> string val header : unit -> unit val trailer : unit -> unit val push_in_preamble : string -> unit val start_module : unit -> unit val start_doc : unit -> unit val end_doc : unit -> unit val start_emph : unit -> unit val stop_emph : unit -> unit val start_comment : unit -> unit val end_comment : unit -> unit val start_coq : unit -> unit val end_coq : unit -> unit val start_code : unit -> unit val end_code : unit -> unit val start_inline_coq : unit -> unit val end_inline_coq : unit -> unit val start_inline_coq_block : unit -> unit val end_inline_coq_block : unit -> unit val indentation : int -> unit val line_break : unit -> unit val paragraph : unit -> unit val empty_line_of_code : unit -> unit val section : int -> (unit -> unit) -> unit val item : int -> unit val stop_item : unit -> unit val reach_item_level : int -> unit val rule : unit -> unit val nbsp : unit -> unit val char : char -> unit val keyword : string -> loc -> unit val ident : string -> loc -> unit val sublexer : char -> loc -> unit val initialize : unit -> unit val proofbox : unit -> unit val latex_char : char -> unit val latex_string : string -> unit val html_char : char -> unit val html_string : string -> unit val verbatim_char : bool -> char -> unit val hard_verbatim_char : char -> unit val start_latex_math : unit -> unit val stop_latex_math : unit -> unit val start_verbatim : bool -> unit val stop_verbatim : bool -> unit val start_quote : unit -> unit val stop_quote : unit -> unit val url : string -> string option -> unit (* this outputs an inference rule in one go. You pass it the list of assumptions, then the middle line info, then the conclusion (which is allowed to span multiple lines). In each case, the int is the number of spaces before the start of the line's text and the string is the text of the line with the leading trailing space trimmed. For the middle rule, you can also optionally provide a name. We need the space info so that in modes where we aren't doing something smart we can just format the rule verbatim like the user did *) val inf_rule : (int * string) list -> (int * string * (string option)) -> (int * string) list -> unit val make_multi_index : unit -> unit val make_index : unit -> unit val make_toc : unit -> unit coq-8.4pl4/tools/coqdoc/coqdoc.css0000644000175000017500000001214012326224777016223 0ustar stephstephbody { padding: 0px 0px; margin: 0px 0px; background-color: white } #page { display: block; padding: 0px; margin: 0px; padding-bottom: 10px; } #header { display: block; position: relative; padding: 0; margin: 0; vertical-align: middle; border-bottom-style: solid; border-width: thin } #header h1 { padding: 0; margin: 0;} /* Contents */ #main{ display: block; padding: 10px; font-family: sans-serif; font-size: 100%; line-height: 100% } #main h1 { line-height: 95% } /* allow for multi-line headers */ #main a.idref:visited {color : #416DFF; text-decoration : none; } #main a.idref:link {color : #416DFF; text-decoration : none; } #main a.idref:hover {text-decoration : none; } #main a.idref:active {text-decoration : none; } #main a.modref:visited {color : #416DFF; text-decoration : none; } #main a.modref:link {color : #416DFF; text-decoration : none; } #main a.modref:hover {text-decoration : none; } #main a.modref:active {text-decoration : none; } #main .keyword { color : #cf1d1d } #main { color: black } .section { background-color: rgb(60%,60%,100%); padding-top: 13px; padding-bottom: 13px; padding-left: 3px; margin-top: 5px; margin-bottom: 5px; font-size : 175% } h2.section { background-color: rgb(80%,80%,100%); padding-left: 3px; padding-top: 12px; padding-bottom: 10px; font-size : 130% } h3.section { background-color: rgb(90%,90%,100%); padding-left: 3px; padding-top: 7px; padding-bottom: 7px; font-size : 115% } h4.section { /* background-color: rgb(80%,80%,80%); max-width: 20em; padding-left: 5px; padding-top: 5px; padding-bottom: 5px; */ background-color: white; padding-left: 0px; padding-top: 0px; padding-bottom: 0px; font-size : 100%; font-style : bold; text-decoration : underline; } #main .doc { margin: 0px; font-family: sans-serif; font-size: 100%; line-height: 125%; max-width: 40em; color: black; padding: 10px; background-color: #90bdff; border-style: plain} .inlinecode { display: inline; /* font-size: 125%; */ color: #666666; font-family: monospace } .doc .inlinecode { display: inline; font-size: 120%; color: rgb(30%,30%,70%); font-family: monospace } .doc .inlinecode .id { color: rgb(30%,30%,70%); } .inlinecodenm { display: inline; color: #444444; } .doc .code { display: inline; font-size: 120%; color: rgb(30%,30%,70%); font-family: monospace } .comment { display: inline; font-family: monospace; color: rgb(50%,50%,80%); } .code { display: block; /* padding-left: 15px; */ font-size: 110%; font-family: monospace; } table.infrule { border: 0px; margin-left: 50px; margin-top: 10px; margin-bottom: 10px; } td.infrule { font-family: monospace; text-align: center; /* color: rgb(35%,35%,70%); */ padding: 0px; line-height: 100%; } tr.infrulemiddle hr { margin: 1px 0 1px 0; } .infrulenamecol { color: rgb(60%,60%,60%); font-size: 80%; padding-left: 1em; padding-bottom: 0.1em } /* Pied de page */ #footer { font-size: 65%; font-family: sans-serif; } .id { display: inline; } .id[type="constructor"] { color: rgb(60%,0%,0%); } .id[type="var"] { color: rgb(40%,0%,40%); } .id[type="variable"] { color: rgb(40%,0%,40%); } .id[type="definition"] { color: rgb(0%,40%,0%); } .id[type="abbreviation"] { color: rgb(0%,40%,0%); } .id[type="lemma"] { color: rgb(0%,40%,0%); } .id[type="instance"] { color: rgb(0%,40%,0%); } .id[type="projection"] { color: rgb(0%,40%,0%); } .id[type="method"] { color: rgb(0%,40%,0%); } .id[type="inductive"] { color: rgb(0%,0%,80%); } .id[type="record"] { color: rgb(0%,0%,80%); } .id[type="class"] { color: rgb(0%,0%,80%); } .id[type="keyword"] { color : #cf1d1d; /* color: black; */ } .inlinecode .id { color: rgb(0%,0%,0%); } /* TOC */ #toc h2 { padding: 10px; background-color: rgb(60%,60%,100%); } #toc li { padding-bottom: 8px; } /* Index */ #index { margin: 0; padding: 0; width: 100%; } #index #frontispiece { margin: 1em auto; padding: 1em; width: 60%; } .booktitle { font-size : 140% } .authors { font-size : 90%; line-height: 115%; } .moreauthors { font-size : 60% } #index #entrance { text-align: center; } #index #entrance .spacer { margin: 0 30px 0 30px; } #index #footer { position: absolute; bottom: 0; text-align: bottom; } .paragraph { height: 0.75em; } ul.doclist { margin-top: 0em; margin-bottom: 0em; } coq-8.4pl4/tools/coqdoc/index.ml0000644000175000017500000002721012326224777015706 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* "<>" then if id <> "<>" then sp ^ "." ^ id else sp else if id <> "<>" then id else "" let add_def loc1 loc2 ty sp id = let fullid = full_ident sp id in let def = Def (fullid, ty) in for loc = loc1 to loc2 do Hashtbl.add reftable (!current_library, loc) def done; Hashtbl.add deftable !current_library (fullid, ty); Hashtbl.add byidtable id (!current_library, fullid, ty) let add_ref m loc m' sp id ty = let fullid = full_ident sp id in if Hashtbl.mem reftable (m, loc) then () else Hashtbl.add reftable (m, loc) (Ref (m', fullid, ty)); let idx = if id = "<>" then m' else id in if Hashtbl.mem byidtable idx then () else Hashtbl.add byidtable idx (m', fullid, ty) let find m l = Hashtbl.find reftable (m, l) let find_string m s = let (m,s,t) = Hashtbl.find byidtable s in Ref (m,s,t) (*s Manipulating path prefixes *) type stack = string list let rec string_of_stack st = match st with | [] -> "" | x::[] -> x | x::tl -> (string_of_stack tl) ^ "." ^ x let empty_stack = [] let module_stack = ref empty_stack let section_stack = ref empty_stack let init_stack () = module_stack := empty_stack; section_stack := empty_stack let push st p = st := p::!st let pop st = match !st with | [] -> () | _::tl -> st := tl let head st = match st with | [] -> "" | x::_ -> x let begin_module m = push module_stack m let begin_section s = push section_stack s let end_block id = (** determines if it ends a module or a section and pops the stack *) if ((String.compare (head !module_stack) id ) == 0) then pop module_stack else if ((String.compare (head !section_stack) id) == 0) then pop section_stack else () let make_fullid id = (** prepends the current module path to an id *) let path = string_of_stack !module_stack in if String.length path > 0 then path ^ "." ^ id else id (* Coq modules *) let split_sp s = try let i = String.rindex s '.' in String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1) with Not_found -> "", s let modules = Hashtbl.create 97 let local_modules = Hashtbl.create 97 let add_module m = let _,id = split_sp m in Hashtbl.add modules id m; Hashtbl.add local_modules m () type module_kind = Local | External of string | Unknown let external_libraries = ref [] let add_external_library logicalpath url = external_libraries := (logicalpath,url) :: !external_libraries let find_external_library logicalpath = let rec aux = function | [] -> raise Not_found | (l,u)::rest -> if String.length logicalpath > String.length l & String.sub logicalpath 0 (String.length l + 1) = l ^"." then u else aux rest in aux !external_libraries let init_coqlib_library () = add_external_library "Coq" !coqlib let find_module m = if Hashtbl.mem local_modules m then Local else try External (Filename.concat (find_external_library m) m) with Not_found -> Unknown (* Building indexes *) type 'a index = { idx_name : string; idx_entries : (char * (string * 'a) list) list; idx_size : int } let map f i = { i with idx_entries = List.map (fun (c,l) -> (c, List.map (fun (s,x) -> (s,f s x)) l)) i.idx_entries } let compare_entries (s1,_) (s2,_) = Alpha.compare_string s1 s2 let sort_entries el = let t = Hashtbl.create 97 in List.iter (fun c -> Hashtbl.add t c []) ['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'; '_'; '*']; List.iter (fun ((s,_) as e) -> let c = Alpha.norm_char s.[0] in let c,l = try c,Hashtbl.find t c with Not_found -> '*',Hashtbl.find t '*' in Hashtbl.replace t c (e :: l)) el; let res = ref [] in Hashtbl.iter (fun c l -> res := (c, List.sort compare_entries l) :: !res) t; List.sort (fun (c1,_) (c2,_) -> Alpha.compare_char c1 c2) !res let display_letter c = if c = '*' then "other" else String.make 1 c let index_size = List.fold_left (fun s (_,l) -> s + List.length l) 0 let hashtbl_elements h = Hashtbl.fold (fun x y l -> (x,y)::l) h [] let type_name = function | Library -> let ln = !lib_name in if ln <> "" then String.lowercase ln else "library" | Module -> "module" | Definition -> "definition" | Inductive -> "inductive" | Constructor -> "constructor" | Lemma -> "lemma" | Record -> "record" | Projection -> "projection" | Instance -> "instance" | Class -> "class" | Method -> "method" | Variable -> "variable" | Axiom -> "axiom" | TacticDefinition -> "tactic" | Abbreviation -> "abbreviation" | Notation -> "notation" | Section -> "section" let prepare_entry s = function | Notation -> (* We decode the encoding done in Dumpglob.cook_notation of coqtop *) (* Encoded notations have the form section:sc:x_'++'_x where: *) (* - the section, if any, ends with a "." *) (* - the scope can be empty *) (* - tokens are separated with "_" *) (* - non-terminal symbols are conventionally represented by "x" *) (* - terminals are enclosed within simple quotes *) (* - existing simple quotes (that necessarily are parts of *) (* terminals) are doubled *) (* (as a consequence, when a terminal contains "_" or "x", these *) (* necessarily appear enclosed within non-doubled simple quotes) *) (* - non-printable characters < 32 are left encoded so that they *) (* are human-readable in index files *) (* Example: "x ' %x _% y %'x %'_' z" is encoded as *) (* "x_''''_'%x'_'_%'_x_'%''x'_'%''_'''_x" *) let err () = eprintf "Invalid notation in globalization file\n"; exit 1 in let h = try String.index_from s 0 ':' with _ -> err () in let i = try String.index_from s (h+1) ':' with _ -> err () in let sc = String.sub s (h+1) (i-h-1) in let ntn = String.make (String.length s - i) ' ' in let k = ref 0 in let j = ref (i+1) in let quoted = ref false in let l = String.length s - 1 in while !j <= l do if not !quoted then begin (match s.[!j] with | '_' -> ntn.[!k] <- ' '; incr k | 'x' -> ntn.[!k] <- '_'; incr k | '\'' -> quoted := true | _ -> assert false) end else if s.[!j] = '\'' then if (!j = l || s.[!j+1] = '_') then quoted := false else (incr j; ntn.[!k] <- s.[!j]; incr k) else begin ntn.[!k] <- s.[!j]; incr k end; incr j done; let ntn = String.sub ntn 0 !k in if sc = "" then ntn else ntn ^ " (" ^ sc ^ ")" | _ -> s let all_entries () = let gl = ref [] in let add_g s m t = gl := (s,(m,t)) :: !gl in let bt = Hashtbl.create 11 in let add_bt t s m = let l = try Hashtbl.find bt t with Not_found -> [] in Hashtbl.replace bt t ((s,m) :: l) in let classify m (s,t) = (add_g s m t; add_bt t s m) in Hashtbl.iter classify deftable; Hashtbl.iter (fun id m -> add_g id m Library; add_bt Library id m) modules; { idx_name = "global"; idx_entries = sort_entries !gl; idx_size = List.length !gl }, Hashtbl.fold (fun t e l -> (t, { idx_name = type_name t; idx_entries = sort_entries e; idx_size = List.length e }) :: l) bt [] let type_of_string = function | "def" | "coe" | "subclass" | "canonstruc" | "fix" | "cofix" | "ex" | "scheme" -> Definition | "prf" | "thm" -> Lemma | "ind" | "coind" -> Inductive | "constr" -> Constructor | "rec" | "corec" -> Record | "proj" -> Projection | "class" -> Class | "meth" -> Method | "inst" -> Instance | "var" -> Variable | "defax" | "prfax" | "ax" -> Axiom | "syndef" -> Abbreviation | "not" -> Notation | "lib" -> Library | "mod" | "modtype" -> Module | "tac" -> TacticDefinition | "sec" -> Section | s -> raise (Invalid_argument ("type_of_string:" ^ s)) let ill_formed_glob_file f = eprintf "Warning: ill-formed file %s (links will not be available)\n" f let outdated_glob_file f = eprintf "Warning: %s not consistent with corresponding .v file (links will not be available)\n" f let correct_file vfile f c = let s = input_line c in if String.length s < 7 || String.sub s 0 7 <> "DIGEST " then (ill_formed_glob_file f; false) else let s = String.sub s 7 (String.length s - 7) in match vfile, s with | None, "NO" -> true | Some _, "NO" -> ill_formed_glob_file f; false | None, _ -> ill_formed_glob_file f; false | Some vfile, s -> s = Digest.to_hex (Digest.file vfile) || (outdated_glob_file f; false) let read_glob vfile f = let c = open_in f in if correct_file vfile f c then let cur_mod = ref "" in try while true do let s = input_line c in let n = String.length s in if n > 0 then begin match s.[0] with | 'F' -> cur_mod := String.sub s 1 (n - 1); current_library := !cur_mod | 'R' -> (try Scanf.sscanf s "R%d:%d %s %s %s %s" (fun loc1 loc2 lib_dp sp id ty -> for loc=loc1 to loc2 do add_ref !cur_mod loc lib_dp sp id (type_of_string ty); (* Also add an entry for each module mentioned in [lib_dp], * to use in interpolation. *) ignore (List.fold_right (fun thisPiece priorPieces -> let newPieces = match priorPieces with | "" -> thisPiece | _ -> thisPiece ^ "." ^ priorPieces in add_ref !cur_mod loc "" "" newPieces Library; newPieces) (Str.split (Str.regexp_string ".") lib_dp) "") done) with _ -> ()) | _ -> try Scanf.sscanf s "not %d %s %s" (fun loc sp id -> add_def loc loc (type_of_string "not") sp id) with Scanf.Scan_failure _ -> try Scanf.sscanf s "%s %d:%d %s %s" (fun ty loc1 loc2 sp id -> add_def loc1 loc2 (type_of_string ty) sp id) with Scanf.Scan_failure _ -> () end done; assert false with End_of_file -> close_in c coq-8.4pl4/tools/coqdoc/alpha.ml0000644000175000017500000000303012326224777015656 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'A' | '\199' -> 'C' | '\200'..'\203' -> 'E' | '\204'..'\207' -> 'I' | '\209' -> 'N' | '\210'..'\214' -> 'O' | '\217'..'\220' -> 'U' | '\221' -> 'Y' | c -> c let norm_char_utf8 c = Char.uppercase c let norm_char c = if !utf8 then norm_char_utf8 c else if !latin1 then norm_char_latin1 c else Char.uppercase c let norm_string s = let u = String.copy s in for i = 0 to String.length s - 1 do u.[i] <- norm_char s.[i] done; u let compare_char c1 c2 = match norm_char c1, norm_char c2 with | ('A'..'Z' as c1), ('A'..'Z' as c2) -> compare c1 c2 | 'A'..'Z', _ -> -1 | _, 'A'..'Z' -> 1 | '_', _ -> -1 | _, '_' -> 1 | c1, c2 -> compare c1 c2 let compare_string s1 s2 = let n1 = String.length s1 in let n2 = String.length s2 in let rec cmp i = if i == n1 || i == n2 then n1 - n2 else let c = compare_char s1.[i] s2.[i] in if c == 0 then cmp (succ i) else c in cmp 0 coq-8.4pl4/tools/coqdoc/output.ml0000644000175000017500000012000712326224777016135 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Hashtbl.add h key ()) l; function s -> try Hashtbl.find h s; true with Not_found -> false let is_keyword = build_table [ "About"; "AddPath"; "Axiom"; "Abort"; "Chapter"; "Check"; "Coercion"; "Compute"; "CoFixpoint"; "CoInductive"; "Corollary"; "Defined"; "Definition"; "End"; "Eval"; "Example"; "Export"; "Fact"; "Fix"; "Fixpoint"; "Function"; "Generalizable"; "Global"; "Grammar"; "Guarded"; "Goal"; "Hint"; "Debug"; "On"; "Hypothesis"; "Hypotheses"; "Resolve"; "Unfold"; "Immediate"; "Extern"; "Constructors"; "Rewrite"; "Implicit"; "Import"; "Inductive"; "Infix"; "Lemma"; "Let"; "Load"; "Local"; "Ltac"; "Module"; "Module Type"; "Declare Module"; "Include"; "Mutual"; "Parameter"; "Parameters"; "Print"; "Printing"; "All"; "Proof"; "Proof with"; "Qed"; "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme"; "Assumptions"; "Axioms"; "Universes"; "Induction"; "for"; "Sort"; "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem"; "Search"; "SearchAbout"; "SearchRewrite"; "Set"; "Types"; "Undo"; "Unset"; "Variable"; "Variables"; "Context"; "Notation"; "Reserved Notation"; "Tactic Notation"; "Delimit"; "Bind"; "Open"; "Scope"; "Inline"; "Implicit Arguments"; "Add"; "Strict"; "Typeclasses"; "Instance"; "Global Instance"; "Class"; "Instantiation"; "subgoal"; "subgoals"; "vm_compute"; "Opaque"; "Transparent"; "Time"; "Extraction"; "Extract"; (* Program *) "Program Definition"; "Program Example"; "Program Fixpoint"; "Program Lemma"; "Obligation"; "Obligations"; "Solve"; "using"; "Next Obligation"; "Next"; "Program Instance"; "Equations"; "Equations_nocomp"; (*i (* coq terms *) *) "forall"; "match"; "as"; "in"; "return"; "with"; "end"; "let"; "fun"; "if"; "then"; "else"; "Prop"; "Set"; "Type"; ":="; "where"; "struct"; "wf"; "measure"; "fix"; "cofix"; (* Ltac *) "before"; "after"; "constr"; "ltac"; "goal"; "context"; "beta"; "delta"; "iota"; "zeta"; (* Notations *) "level"; "associativity"; "no" ] let is_tactic = build_table [ "intro"; "intros"; "apply"; "rewrite"; "refine"; "case"; "clear"; "injection"; "elimtype"; "progress"; "setoid_rewrite"; "left"; "right"; "constructor"; "econstructor"; "decide equality"; "abstract"; "exists"; "cbv"; "simple destruct"; "info"; "fourier"; "field"; "specialize"; "evar"; "solve"; "instanciate"; "quote"; "eexact"; "autorewrite"; "destruct"; "destruction"; "destruct_call"; "dependent"; "elim"; "extensionality"; "f_equal"; "generalize"; "generalize_eqs"; "generalize_eqs_vars"; "induction"; "rename"; "move"; "omega"; "set"; "assert"; "do"; "repeat"; "cut"; "assumption"; "exact"; "split"; "subst"; "try"; "discriminate"; "simpl"; "unfold"; "red"; "compute"; "at"; "in"; "by"; "reflexivity"; "symmetry"; "transitivity"; "replace"; "setoid_replace"; "inversion"; "inversion_clear"; "pattern"; "intuition"; "congruence"; "fail"; "fresh"; "trivial"; "tauto"; "firstorder"; "ring"; "clapply"; "program_simpl"; "program_simplify"; "eapply"; "auto"; "eauto"; "change"; "fold"; "hnf"; "lazy"; "simple"; "eexists"; "debug"; "idtac"; "first"; "type of"; "pose"; "eval"; "instantiate"; "until" ] (*s Current Coq module *) let current_module : (string * string option) ref = ref ("",None) let get_module withsub = let (m,sub) = !current_module in if withsub then match sub with | None -> m | Some sub -> m ^ ": " ^ sub else m let set_module m sub = current_module := (m,sub); page_title := get_module true (*s Common to both LaTeX and HTML *) let item_level = ref 0 let in_doc = ref false (*s Customized and predefined pretty-print *) let initialize_texmacs () = let ensuremath x = sprintf ">" x in List.fold_right (fun (s,t) tt -> Tokens.ttree_add tt s t) [ "*", ensuremath "times"; "->", ensuremath "rightarrow"; "<-", ensuremath "leftarrow"; "<->", ensuremath "leftrightarrow"; "=>", ensuremath "Rightarrow"; "<=", ensuremath "le"; ">=", ensuremath "ge"; "<>", ensuremath "noteq"; "~", ensuremath "lnot"; "/\\", ensuremath "land"; "\\/", ensuremath "lor"; "|-", ensuremath "vdash" ] Tokens.empty_ttree let token_tree_texmacs = ref (initialize_texmacs ()) let token_tree_latex = ref Tokens.empty_ttree let token_tree_html = ref Tokens.empty_ttree let initialize_tex_html () = let if_utf8 = if !Cdglobals.utf8 then fun x -> Some x else fun _ -> None in let (tree_latex, tree_html) = List.fold_right (fun (s,l,l') (tt,tt') -> (Tokens.ttree_add tt s l, match l' with None -> tt' | Some l' -> Tokens.ttree_add tt' s l')) [ "*" , "\\ensuremath{\\times}", if_utf8 "×"; "|", "\\ensuremath{|}", None; "->", "\\ensuremath{\\rightarrow}", if_utf8 "→"; "->~", "\\ensuremath{\\rightarrow\\lnot}", None; "->~~", "\\ensuremath{\\rightarrow\\lnot\\lnot}", None; "<-", "\\ensuremath{\\leftarrow}", None; "<->", "\\ensuremath{\\leftrightarrow}", if_utf8 "↔"; "=>", "\\ensuremath{\\Rightarrow}", if_utf8 "⇒"; "<=", "\\ensuremath{\\le}", if_utf8 "â‰Ī"; ">=", "\\ensuremath{\\ge}", if_utf8 "â‰Ĩ"; "<>", "\\ensuremath{\\not=}", if_utf8 "≠"; "~", "\\ensuremath{\\lnot}", if_utf8 "ÂŽ"; "/\\", "\\ensuremath{\\land}", if_utf8 "∧"; "\\/", "\\ensuremath{\\lor}", if_utf8 "âˆĻ"; "|-", "\\ensuremath{\\vdash}", None; "forall", "\\ensuremath{\\forall}", if_utf8 "∀"; "exists", "\\ensuremath{\\exists}", if_utf8 "∃"; "Π", "\\ensuremath{\\Pi}", if_utf8 "Π"; "Îŧ", "\\ensuremath{\\lambda}", if_utf8 "Îŧ"; (* "fun", "\\ensuremath{\\lambda}" ? *) ] (Tokens.empty_ttree,Tokens.empty_ttree) in token_tree_latex := tree_latex; token_tree_html := tree_html let add_printing_token s (t1,t2) = (match t1 with None -> () | Some t1 -> token_tree_latex := Tokens.ttree_add !token_tree_latex s t1); (match t2 with None -> () | Some t2 -> token_tree_html := Tokens.ttree_add !token_tree_html s t2) let remove_printing_token s = token_tree_latex := Tokens.ttree_remove !token_tree_latex s; token_tree_html := Tokens.ttree_remove !token_tree_html s (*s Table of contents *) type toc_entry = | Toc_library of string * string option | Toc_section of int * (unit -> unit) * string let (toc_q : toc_entry Queue.t) = Queue.create () let add_toc_entry e = Queue.add e toc_q let new_label = let r = ref 0 in fun () -> incr r; "lab" ^ string_of_int !r (*s LaTeX output *) module Latex = struct let in_title = ref false (*s Latex preamble *) let (preamble : string Queue.t) = Queue.create () let push_in_preamble s = Queue.add s preamble let utf8x_extra_support () = printf "\n"; printf "%%Warning: tipa declares many non-standard macros used by utf8x to\n"; printf "%%interpret utf8 characters but extra packages might have to be added\n"; printf "%%(e.g. \"textgreek\" for Greek letters not already in tipa).\n"; printf "%%Use coqdoc's option -p to add new packages.\n"; printf "\\usepackage{tipa}\n"; printf "\n" let header () = if !header_trailer then begin printf "\\documentclass[12pt]{report}\n"; if !inputenc != "" then printf "\\usepackage[%s]{inputenc}\n" !inputenc; if !inputenc = "utf8x" then utf8x_extra_support (); printf "\\usepackage[T1]{fontenc}\n"; printf "\\usepackage{fullpage}\n"; printf "\\usepackage{coqdoc}\n"; printf "\\usepackage{amsmath,amssymb}\n"; (match !toc_depth with | None -> () | Some n -> printf "\\setcounter{tocdepth}{%i}\n" n); Queue.iter (fun s -> printf "%s\n" s) preamble; printf "\\begin{document}\n" end; output_string "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n"; output_string "%% This file has been automatically generated with the command\n"; output_string "%% "; Array.iter (fun s -> printf "%s " s) Sys.argv; printf "\n"; output_string "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n" let trailer () = if !header_trailer then begin printf "\\end{document}\n" end (*s Latex low-level translation *) let nbsp () = output_char '~' let char c = match c with | '\\' -> printf "\\symbol{92}" | '$' | '#' | '%' | '&' | '{' | '}' | '_' -> output_char '\\'; output_char c | '^' | '~' -> output_char '\\'; output_char c; printf "{}" | _ -> output_char c let label_char c = match c with | '_' -> output_char ' ' | '\\' | '$' | '#' | '%' | '&' | '{' | '}' | '^' | '~' -> printf "x%X" (Char.code c) | _ -> if c >= '\x80' then printf "x%X" (Char.code c) else output_char c let label_ident s = for i = 0 to String.length s - 1 do label_char s.[i] done let latex_char = output_char let latex_string = output_string let html_char _ = () let html_string _ = () (*s Latex char escaping *) let escaped = let buff = Buffer.create 5 in fun s -> Buffer.clear buff; for i = 0 to String.length s - 1 do match s.[i] with | '\\' -> Buffer.add_string buff "\\symbol{92}" | '$' | '#' | '%' | '&' | '{' | '}' | '_' as c -> Buffer.add_char buff '\\'; Buffer.add_char buff c | '^' | '~' as c -> Buffer.add_char buff '\\'; Buffer.add_char buff c; Buffer.add_string buff "{}" | '\'' -> if i < String.length s - 1 && s.[i+1] = '\'' then begin Buffer.add_char buff '\''; Buffer.add_char buff '{'; Buffer.add_char buff '}' end else Buffer.add_char buff '\'' | c -> Buffer.add_char buff c done; Buffer.contents buff (*s Latex reference and symbol translation *) let start_module () = let ln = !lib_name in if not !short then begin printf "\\coqlibrary{"; label_ident (get_module false); printf "}{"; if ln <> "" then printf "%s " ln; printf "}{%s}\n\n" (escaped (get_module true)) end let start_latex_math () = output_char '$' let stop_latex_math () = output_char '$' let start_quote () = output_char '`'; output_char '`' let stop_quote () = output_char '\''; output_char '\'' let start_verbatim inline = if inline then printf "\\texttt{" else printf "\\begin{verbatim}" let stop_verbatim inline = if inline then printf "}" else printf "\\end{verbatim}\n" let url addr name = printf "%s\\footnote{\\url{%s}}" (match name with | None -> "" | Some n -> n) addr let indentation n = if n == 0 then printf "\\coqdocnoindent\n" else let space = 0.5 *. (float n) in printf "\\coqdocindent{%2.2fem}\n" space let ident_ref m fid typ s = let id = if fid <> "" then (m ^ "." ^ fid) else m in match find_module m with | Local -> if typ = Variable then printf "\\coqdoc%s{%s}" (type_name typ) s else (printf "\\coqref{"; label_ident id; printf "}{\\coqdoc%s{%s}}" (type_name typ) s) | External m when !externals -> printf "\\coqexternalref{"; label_ident fid; printf "}{%s}{\\coqdoc%s{%s}}" (escaped m) (type_name typ) s | External _ | Unknown -> printf "\\coqdoc%s{%s}" (type_name typ) s let defref m id ty s = if ty <> Notation then (printf "\\coqdef{"; label_ident (m ^ "." ^ id); printf "}{%s}{\\coqdoc%s{%s}}" s (type_name ty) s) else (* Glob file still not able to say the exact extent of the definition *) (* so we currently renounce to highlight the notation location *) (printf "\\coqdef{"; label_ident (m ^ "." ^ id); printf "}{%s}{%s}" s s) let reference s = function | Def (fullid,typ) -> defref (get_module false) fullid typ s | Ref (m,fullid,typ) -> ident_ref m fullid typ s (*s The sublexer buffers symbol characters and attached uninterpreted ident and try to apply special translation such as, predefined, translation "->" to "\ensuremath{\rightarrow}" or, virtually, a user-level translation from "=_h" to "\ensuremath{=_{h}}" *) let output_sublexer_string doescape issymbchar tag s = let s = if doescape then escaped s else s in match tag with | Some ref -> reference s ref | None -> if issymbchar then output_string s else printf "\\coqdocvar{%s}" s let last_was_in = ref false let sublexer c loc = if c = '*' && !last_was_in then begin Tokens.flush_sublexer (); output_char '*' end else begin let tag = try Some (Index.find (get_module false) loc) with Not_found -> None in Tokens.output_tagged_symbol_char tag c end; last_was_in := false let initialize () = initialize_tex_html (); Tokens.token_tree := token_tree_latex; Tokens.outfun := output_sublexer_string (*s Interpreting ident with fallback on sublexer if unknown ident *) let translate s = match Tokens.translate s with Some s -> s | None -> escaped s let keyword s loc = printf "\\coqdockw{%s}" (translate s) let ident s loc = last_was_in := s = "in"; try let tag = Index.find (get_module false) loc in reference (translate s) tag with Not_found -> if is_tactic s then printf "\\coqdoctac{%s}" (translate s) else if is_keyword s then printf "\\coqdockw{%s}" (translate s) else if !Cdglobals.interpolate && !in_doc (* always a var otherwise *) then try let tag = Index.find_string (get_module false) s in reference (translate s) tag with _ -> Tokens.output_tagged_ident_string s else Tokens.output_tagged_ident_string s let ident s l = if !in_title then ( printf "\\texorpdfstring{\\protect"; ident s l; printf "}{%s}" (translate s)) else ident s l (*s Translating structure *) let proofbox () = printf "\\ensuremath{\\Box}" let rec reach_item_level n = if !item_level < n then begin printf "\n\\begin{itemize}\n\\item "; incr item_level; reach_item_level n end else if !item_level > n then begin printf "\n\\end{itemize}\n"; decr item_level; reach_item_level n end let item n = let old_level = !item_level in reach_item_level n; if n <= old_level then printf "\n\\item " let stop_item () = reach_item_level 0 let start_doc () = in_doc := true let end_doc () = in_doc := false; stop_item () (* This is broken if we are in math mode, but coqdoc currently isn't tracking that *) let start_emph () = printf "\\textit{" let stop_emph () = printf "}" let start_comment () = printf "\\begin{coqdoccomment}\n" let end_comment () = printf "\\end{coqdoccomment}\n" let start_coq () = printf "\\begin{coqdoccode}\n" let end_coq () = printf "\\end{coqdoccode}\n" let start_code () = end_doc (); start_coq () let end_code () = end_coq (); start_doc () let section_kind = function | 1 -> "\\section{" | 2 -> "\\subsection{" | 3 -> "\\subsubsection{" | 4 -> "\\paragraph{" | _ -> assert false let section lev f = stop_item (); output_string (section_kind lev); in_title := true; f (); in_title := false; printf "}\n\n" let rule () = printf "\\par\n\\noindent\\hrulefill\\par\n\\noindent{}" let paragraph () = printf "\n\n" let line_break () = printf "\\coqdoceol\n" let empty_line_of_code () = printf "\\coqdocemptyline\n" let start_inline_coq_block () = line_break (); empty_line_of_code () let end_inline_coq_block () = empty_line_of_code () let start_inline_coq () = () let end_inline_coq () = () let make_multi_index () = () let make_index () = () let make_toc () = printf "\\tableofcontents\n" end (*s HTML output *) module Html = struct let header () = if !header_trailer then if !header_file_spec then let cin = Pervasives.open_in !header_file in try while true do let s = Pervasives.input_line cin in printf "%s\n" s done with End_of_file -> Pervasives.close_in cin else begin printf "\n"; printf "\n\n"; printf "\n" !charset; printf "\n"; printf "%s\n\n\n" !page_title; printf "\n\n
\n\n
\n
\n\n"; printf "
\n\n" end let trailer () = if !header_trailer && !footer_file_spec then let cin = Pervasives.open_in !footer_file in try while true do let s = Pervasives.input_line cin in printf "%s\n" s done with End_of_file -> Pervasives.close_in cin else begin if !index && (get_module false) <> "Index" then printf "
\n\n
\n
Index" !index_name; printf "
This page has been generated by "; printf "coqdoc\n" Coq_config.wwwcoq; printf "
\n\n
\n\n\n" end let start_module () = let ln = !lib_name in if not !short then begin let (m,sub) = !current_module in add_toc_entry (Toc_library (m,sub)); if ln = "" then printf "

%s

\n\n" (get_module true) else printf "

%s %s

\n\n" ln (get_module true) end let indentation n = for i = 1 to n do printf " " done let line_break () = printf "
\n" let empty_line_of_code () = printf "\n
\n" let nbsp () = printf " " let char = function | '<' -> printf "<" | '>' -> printf ">" | '&' -> printf "&" | c -> output_char c let raw_string s = for i = 0 to String.length s - 1 do char s.[i] done let escaped = let buff = Buffer.create 5 in fun s -> Buffer.clear buff; for i = 0 to String.length s - 1 do match s.[i] with | '<' -> Buffer.add_string buff "<" | '>' -> Buffer.add_string buff ">" | '&' -> Buffer.add_string buff "&" | c -> Buffer.add_char buff c done; Buffer.contents buff let latex_char _ = () let latex_string _ = () let html_char = output_char let html_string = output_string let start_latex_math () = () let stop_latex_math () = () let start_quote () = char '"' let stop_quote () = start_quote () let start_verbatim inline = if inline then printf "" else printf "
"

  let stop_verbatim inline = 
    if inline then printf "" 
    else printf "
\n" let url addr name = printf "%s" addr (match name with | Some n -> n | None -> addr) let ident_ref m fid typ s = match find_module m with | Local -> printf "" m fid; printf "%s" typ s | External m when !externals -> printf "" m fid; printf "%s" typ s | External _ | Unknown -> printf "%s" typ s let reference s r = match r with | Def (fullid,ty) -> printf "" fullid; printf "%s" (type_name ty) s | Ref (m,fullid,ty) -> ident_ref m fullid (type_name ty) s let output_sublexer_string doescape issymbchar tag s = let s = if doescape then escaped s else s in match tag with | Some ref -> reference s ref | None -> if issymbchar then output_string s else printf "%s" s let sublexer c loc = let tag = try Some (Index.find (get_module false) loc) with Not_found -> None in Tokens.output_tagged_symbol_char tag c let initialize () = initialize_tex_html(); Tokens.token_tree := token_tree_html; Tokens.outfun := output_sublexer_string let translate s = match Tokens.translate s with Some s -> s | None -> escaped s let keyword s loc = printf "%s" (translate s) let ident s loc = if is_keyword s then begin printf "%s" (translate s) end else begin try reference (translate s) (Index.find (get_module false) loc) with Not_found -> if is_tactic s then printf "%s" (translate s) else if !Cdglobals.interpolate && !in_doc (* always a var otherwise *) then try reference (translate s) (Index.find_string (get_module false) s) with _ -> Tokens.output_tagged_ident_string s else Tokens.output_tagged_ident_string s end let proofbox () = printf "☐" let rec reach_item_level n = if !item_level < n then begin printf "
    \n
  • "; incr item_level; reach_item_level n end else if !item_level > n then begin printf "\n
    • \n
\n"; decr item_level; reach_item_level n end let item n = let old_level = !item_level in reach_item_level n; if n <= old_level then printf "\n\n
  • " let stop_item () = reach_item_level 0 let start_coq () = if not !raw_comments then printf "
    \n" let end_coq () = if not !raw_comments then printf "
    \n" let start_doc () = in_doc := true; if not !raw_comments then printf "\n
    \n" let end_doc () = in_doc := false; stop_item (); if not !raw_comments then printf "\n
    \n" let start_emph () = printf "" let stop_emph () = printf "" let start_comment () = printf "(*" let end_comment () = printf "*)" let start_code () = end_doc (); start_coq () let end_code () = end_coq (); start_doc () let start_inline_coq () = if !inline_notmono then printf "" else printf "" let end_inline_coq () = printf "" let start_inline_coq_block () = line_break (); start_inline_coq () let end_inline_coq_block () = end_inline_coq () let paragraph () = printf "\n
    \n\n" (* inference rules *) let inf_rule assumptions (_,_,midnm) conclusions = (* this first function replaces any occurance of 3 or more spaces in a row with " "s. We do this to the assumptions so that people can put multiple rules on a line with nice formatting *) let replace_spaces str = let rec copy a n = match n with 0 -> [] | n -> (a :: copy a (n - 1)) in let results = Str.full_split (Str.regexp "[' '][' '][' ']+") str in let strs = List.map (fun r -> match r with | Str.Text s -> [s] | Str.Delim s -> copy " " (String.length s)) results in String.concat "" (List.concat strs) in let start_assumption line = (printf "\n"; printf " %s\n" (replace_spaces line)) in let end_assumption () = (printf " \n"; printf "\n") in let rec print_assumptions hyps = match hyps with | [] -> start_assumption "  " | [(_,hyp)] -> start_assumption hyp | ((_,hyp) :: hyps') -> (start_assumption hyp; end_assumption (); print_assumptions hyps') in printf "
    \n"; print_assumptions assumptions; printf " " | Some s -> printf " %s  \n " s); printf "\n"; printf "\n"; printf " \n"; printf "\n"; print_assumptions conclusions; end_assumption (); printf "
    \n"; (match midnm with | None -> printf "  \n
    " let section lev f = let lab = new_label () in let r = sprintf "%s.html#%s" (get_module false) lab in (match !toc_depth with | None -> add_toc_entry (Toc_section (lev, f, r)) | Some n -> if lev <= n then add_toc_entry (Toc_section (lev, f, r)) else ()); stop_item (); printf "" lab lev; f (); printf "\n" lev let rule () = printf "
    \n" (* make a HTML index from a list of triples (name,text,link) *) let index_ref i c = let idxc = sprintf "%s_%c" i.idx_name c in !index_name ^ (if !multi_index then "_" ^ idxc ^ ".html" else ".html#" ^ idxc) let letter_index category idx (c,l) = if l <> [] then begin let cat = if category && idx <> "global" then "(" ^ idx ^ ")" else "" in printf "

    %s %s

    \n" idx c (display_letter c) cat; List.iter (fun (id,(text,link,t)) -> let id' = prepare_entry id t in printf "%s %s
    \n" link id' text) l; printf "

    " end let all_letters i = List.iter (letter_index false i.idx_name) i.idx_entries (* Construction d'une liste des index (1 index global, puis 1 index par catÃĐgorie) *) let format_global_index = Index.map (fun s (m,t) -> if t = Library then let ln = !lib_name in if ln <> "" then "[" ^ String.lowercase ln ^ "]", m ^ ".html", t else "[library]", m ^ ".html", t else sprintf "[%s, in %s]" (type_name t) m m , sprintf "%s.html#%s" m s, t) let format_bytype_index = function | Library, idx -> Index.map (fun id m -> "", m ^ ".html", Library) idx | (t,idx) -> Index.map (fun s m -> let text = sprintf "[in %s]" m m in (text, sprintf "%s.html#%s" m s, t)) idx (* Impression de la table d'index *) let print_index_table_item i = printf "\n%s Index\n" (String.capitalize i.idx_name); List.iter (fun (c,l) -> if l <> [] then printf "%s\n" (index_ref i c) (display_letter c) else printf "%s\n" (display_letter c)) i.idx_entries; let n = i.idx_size in printf "(%d %s)\n" n (if n > 1 then "entries" else "entry"); printf "\n" let print_index_table idxl = printf "\n"; List.iter print_index_table_item idxl; printf "
    \n" let make_one_multi_index prt_tbl i = (* Attn: make_one_multi_index crÃĐe un nouveau fichier... *) let idx = i.idx_name in let one_letter ((c,l) as cl) = open_out_file (sprintf "%s_%s_%c.html" !index_name idx c); if (!header_trailer) then header (); prt_tbl (); printf "
    "; letter_index true idx cl; if List.length l > 30 then begin printf "
    "; prt_tbl () end; if (!header_trailer) then trailer (); close_out_file () in List.iter one_letter i.idx_entries let make_multi_index () = let all_index = let glob,bt = Index.all_entries () in (format_global_index glob) :: (List.map format_bytype_index bt) in let print_table () = print_index_table all_index in List.iter (make_one_multi_index print_table) all_index let make_index () = let all_index = let glob,bt = Index.all_entries () in (format_global_index glob) :: (List.map format_bytype_index bt) in let print_table () = print_index_table all_index in let print_one_index i = if i.idx_size > 0 then begin printf "
    \n

    %s Index

    \n" (String.capitalize i.idx_name); all_letters i end in set_module "Index" None; if !title <> "" then printf "

    %s

    \n" !title; print_table (); if not (!multi_index) then begin List.iter print_one_index all_index; printf "
    "; print_table () end let make_toc () = let ln = !lib_name in let make_toc_entry = function | Toc_library (m,sub) -> stop_item (); let ms = match sub with | None -> m | Some s -> m ^ ": " ^ s in if ln = "" then printf "

    %s

    \n" m ms else printf "

    %s %s

    \n" m ln ms | Toc_section (n, f, r) -> item n; printf "" r; f (); printf "\n" in printf "
    \n"; Queue.iter make_toc_entry toc_q; stop_item (); printf "
    \n" end (*s TeXmacs-aware output *) module TeXmacs = struct (*s Latex preamble *) let (preamble : string Queue.t) = in_doc := false; Queue.create () let push_in_preamble s = Queue.add s preamble let header () = output_string "(*i This file has been automatically generated with the command \n"; output_string " "; Array.iter (fun s -> printf "%s " s) Sys.argv; printf " *)\n" let trailer () = () let nbsp () = output_char ' ' let char_true c = match c with | '\\' -> printf "\\\\" | '<' -> printf "\\<" | '|' -> printf "\\|" | '>' -> printf "\\>" | _ -> output_char c let char c = if !in_doc then char_true c else output_char c let latex_char = char_true let latex_string = String.iter latex_char let html_char _ = () let html_string _ = () let raw_ident s = for i = 0 to String.length s - 1 do char s.[i] done let start_module () = () let start_latex_math () = printf "' let start_verbatim inline = in_doc := true; printf "<\\verbatim>" let stop_verbatim inline = in_doc := false; printf "" let url addr name = printf "%s<\\footnote><\\url>%s" addr (match name with | None -> "" | Some n -> n) let start_quote () = output_char '`'; output_char '`' let stop_quote () = output_char '\''; output_char '\'' let indentation n = () let keyword s = printf "" let ident_true s = if is_keyword s then keyword s else raw_ident s let keyword s loc = keyword s let ident s _ = if !in_doc then ident_true s else raw_ident s let output_sublexer_string doescape issymbchar tag s = if doescape then raw_ident s else output_string s let sublexer c l = if !in_doc then Tokens.output_tagged_symbol_char None c else char c let initialize () = Tokens.token_tree := token_tree_texmacs; Tokens.outfun := output_sublexer_string let proofbox () = printf "QED" let rec reach_item_level n = if !item_level < n then begin printf "\n<\\itemize>\n"; incr item_level; reach_item_level n end else if !item_level > n then begin printf "\n"; decr item_level; reach_item_level n end let item n = let old_level = !item_level in reach_item_level n; if n <= old_level then printf "\n\n" let stop_item () = reach_item_level 0 let start_doc () = in_doc := true; printf "(** texmacs: " let end_doc () = stop_item (); in_doc := false; printf " *)" let start_coq () = () let end_coq () = () let start_emph () = printf "" let start_comment () = () let end_comment () = () let start_code () = in_doc := true; printf "<\\code>\n" let end_code () = in_doc := false; printf "\n" let section_kind = function | 1 -> "section" | 2 -> "subsection" | 3 -> "subsubsection" | 4 -> "paragraph" | _ -> assert false let section lev f = stop_item (); printf "<"; output_string (section_kind lev); printf "|"; f (); printf ">\n\n" let rule () = printf "\n\n" let paragraph () = printf "\n\n" let line_break_true () = printf "" let line_break () = printf "\n" let empty_line_of_code () = printf "\n" let start_inline_coq () = printf "" let start_inline_coq_block () = line_break (); start_inline_coq () let end_inline_coq_block () = end_inline_coq () let make_multi_index () = () let make_index () = () let make_toc () = () end (*s Raw output *) module Raw = struct let header () = () let trailer () = () let nbsp () = output_char ' ' let char = output_char let latex_char = output_char let latex_string = output_string let html_char _ = () let html_string _ = () let raw_ident s = for i = 0 to String.length s - 1 do char s.[i] done let start_module () = () let end_module () = () let start_latex_math () = () let stop_latex_math () = () let start_verbatim inline = () let stop_verbatim inline = () let url addr name = match name with | Some n -> printf "%s (%s)" n addr | None -> printf "%s" addr let start_quote () = printf "\"" let stop_quote () = printf "\"" let indentation n = for i = 1 to n do printf " " done let keyword s loc = raw_ident s let ident s loc = raw_ident s let sublexer c l = char c let initialize () = Tokens.token_tree := ref Tokens.empty_ttree; Tokens.outfun := (fun _ _ _ _ -> failwith "Useless") let proofbox () = printf "[]" let item n = printf "- " let stop_item () = () let reach_item_level _ = () let start_doc () = printf "(** " let end_doc () = printf " *)\n" let start_emph () = printf "_" let stop_emph () = printf "_" let start_comment () = printf "(*" let end_comment () = printf "*)" let start_coq () = () let end_coq () = () let start_code () = end_doc (); start_coq () let end_code () = end_coq (); start_doc () let section_kind = function | 1 -> "* " | 2 -> "** " | 3 -> "*** " | 4 -> "**** " | _ -> assert false let section lev f = output_string (section_kind lev); f () let rule () = () let paragraph () = printf "\n\n" let line_break () = printf "\n" let empty_line_of_code () = printf "\n" let start_inline_coq () = () let end_inline_coq () = () let start_inline_coq_block () = line_break (); start_inline_coq () let end_inline_coq_block () = end_inline_coq () let make_multi_index () = () let make_index () = () let make_toc () = () end (*s Generic output *) let select f1 f2 f3 f4 x = match !target_language with LaTeX -> f1 x | HTML -> f2 x | TeXmacs -> f3 x | Raw -> f4 x let push_in_preamble = Latex.push_in_preamble let header = select Latex.header Html.header TeXmacs.header Raw.header let trailer = select Latex.trailer Html.trailer TeXmacs.trailer Raw.trailer let start_module = select Latex.start_module Html.start_module TeXmacs.start_module Raw.start_module let start_doc = select Latex.start_doc Html.start_doc TeXmacs.start_doc Raw.start_doc let end_doc = select Latex.end_doc Html.end_doc TeXmacs.end_doc Raw.end_doc let start_comment = select Latex.start_comment Html.start_comment TeXmacs.start_comment Raw.start_comment let end_comment = select Latex.end_comment Html.end_comment TeXmacs.end_comment Raw.end_comment let start_coq = select Latex.start_coq Html.start_coq TeXmacs.start_coq Raw.start_coq let end_coq = select Latex.end_coq Html.end_coq TeXmacs.end_coq Raw.end_coq let start_code = select Latex.start_code Html.start_code TeXmacs.start_code Raw.start_code let end_code = select Latex.end_code Html.end_code TeXmacs.end_code Raw.end_code let start_inline_coq = select Latex.start_inline_coq Html.start_inline_coq TeXmacs.start_inline_coq Raw.start_inline_coq let end_inline_coq = select Latex.end_inline_coq Html.end_inline_coq TeXmacs.end_inline_coq Raw.end_inline_coq let start_inline_coq_block = select Latex.start_inline_coq_block Html.start_inline_coq_block TeXmacs.start_inline_coq_block Raw.start_inline_coq_block let end_inline_coq_block = select Latex.end_inline_coq_block Html.end_inline_coq_block TeXmacs.end_inline_coq_block Raw.end_inline_coq_block let indentation = select Latex.indentation Html.indentation TeXmacs.indentation Raw.indentation let paragraph = select Latex.paragraph Html.paragraph TeXmacs.paragraph Raw.paragraph let line_break = select Latex.line_break Html.line_break TeXmacs.line_break Raw.line_break let empty_line_of_code = select Latex.empty_line_of_code Html.empty_line_of_code TeXmacs.empty_line_of_code Raw.empty_line_of_code let section = select Latex.section Html.section TeXmacs.section Raw.section let item = select Latex.item Html.item TeXmacs.item Raw.item let stop_item = select Latex.stop_item Html.stop_item TeXmacs.stop_item Raw.stop_item let reach_item_level = select Latex.reach_item_level Html.reach_item_level TeXmacs.reach_item_level Raw.reach_item_level let rule = select Latex.rule Html.rule TeXmacs.rule Raw.rule let nbsp = select Latex.nbsp Html.nbsp TeXmacs.nbsp Raw.nbsp let char = select Latex.char Html.char TeXmacs.char Raw.char let keyword = select Latex.keyword Html.keyword TeXmacs.keyword Raw.keyword let ident = select Latex.ident Html.ident TeXmacs.ident Raw.ident let sublexer = select Latex.sublexer Html.sublexer TeXmacs.sublexer Raw.sublexer let initialize = select Latex.initialize Html.initialize TeXmacs.initialize Raw.initialize let proofbox = select Latex.proofbox Html.proofbox TeXmacs.proofbox Raw.proofbox let latex_char = select Latex.latex_char Html.latex_char TeXmacs.latex_char Raw.latex_char let latex_string = select Latex.latex_string Html.latex_string TeXmacs.latex_string Raw.latex_string let html_char = select Latex.html_char Html.html_char TeXmacs.html_char Raw.html_char let html_string = select Latex.html_string Html.html_string TeXmacs.html_string Raw.html_string let start_emph = select Latex.start_emph Html.start_emph TeXmacs.start_emph Raw.start_emph let stop_emph = select Latex.stop_emph Html.stop_emph TeXmacs.stop_emph Raw.stop_emph let start_latex_math = select Latex.start_latex_math Html.start_latex_math TeXmacs.start_latex_math Raw.start_latex_math let stop_latex_math = select Latex.stop_latex_math Html.stop_latex_math TeXmacs.stop_latex_math Raw.stop_latex_math let start_verbatim = select Latex.start_verbatim Html.start_verbatim TeXmacs.start_verbatim Raw.start_verbatim let stop_verbatim = select Latex.stop_verbatim Html.stop_verbatim TeXmacs.stop_verbatim Raw.stop_verbatim let verbatim_char inline = select (if inline then Latex.char else output_char) Html.char TeXmacs.char Raw.char let hard_verbatim_char = output_char let url = select Latex.url Html.url TeXmacs.url Raw.url let start_quote = select Latex.start_quote Html.start_quote TeXmacs.start_quote Raw.start_quote let stop_quote = select Latex.stop_quote Html.stop_quote TeXmacs.stop_quote Raw.stop_quote let inf_rule_dumb assumptions (midsp,midln,midnm) conclusions = start_verbatim false; let dumb_line = function (sp,ln) -> (String.iter char ((String.make sp ' ') ^ ln); char '\n') in (List.iter dumb_line assumptions; dumb_line (midsp, midln ^ (match midnm with | Some s -> " " ^ s | None -> "")); List.iter dumb_line conclusions); stop_verbatim false let inf_rule = select inf_rule_dumb Html.inf_rule inf_rule_dumb inf_rule_dumb let make_multi_index = select Latex.make_multi_index Html.make_multi_index TeXmacs.make_multi_index Raw.make_multi_index let make_index = select Latex.make_index Html.make_index TeXmacs.make_index Raw.make_index let make_toc = select Latex.make_toc Html.make_toc TeXmacs.make_toc Raw.make_toc coq-8.4pl4/tools/coqdoc/coqdoc.sty0000644000175000017500000001256512326224777016265 0ustar stephsteph % This is coqdoc.sty, by Jean-Christophe Filliâtre % This LaTeX package is used by coqdoc (http://www.lri.fr/~filliatr/coqdoc) % % You can modify the following macros to customize the appearance % of the document. \NeedsTeXFormat{LaTeX2e} \ProvidesPackage{coqdoc}[2002/02/11] % % Headings % \usepackage{fancyhdr} % \newcommand{\coqdocleftpageheader}{\thepage\ -- \today} % \newcommand{\coqdocrightpageheader}{\today\ -- \thepage} % \pagestyle{fancyplain} % %BEGIN LATEX % \headsep 8mm % \renewcommand{\plainheadrulewidth}{0.4pt} % \renewcommand{\plainfootrulewidth}{0pt} % \lhead[\coqdocleftpageheader]{\leftmark} % \rhead[\leftmark]{\coqdocrightpageheader} % \cfoot{} % %END LATEX % Hevea puts to much space with \medskip and \bigskip %HEVEA\renewcommand{\medskip}{} %HEVEA\renewcommand{\bigskip}{} %HEVEA\newcommand{\lnot}{\coqwkw{not}} %HEVEA\newcommand{\lor}{\coqwkw{or}} %HEVEA\newcommand{\land}{\&} % own name \newcommand{\coqdoc}{\textsf{coqdoc}} % pretty underscores (the package fontenc causes ugly underscores) %BEGIN LATEX \def\_{\kern.08em\vbox{\hrule width.35em height.6pt}\kern.08em} %END LATEX % macro for typesetting keywords \newcommand{\coqdockw}[1]{\texttt{#1}} % macro for typesetting variable identifiers \newcommand{\coqdocvar}[1]{\textit{#1}} % macro for typesetting constant identifiers \newcommand{\coqdoccst}[1]{\textsf{#1}} % macro for typesetting module identifiers \newcommand{\coqdocmod}[1]{\textsc{\textsf{#1}}} % macro for typesetting module constant identifiers (e.g. Parameters in % module types) \newcommand{\coqdocax}[1]{\textsl{\textsf{#1}}} % macro for typesetting inductive type identifiers \newcommand{\coqdocind}[1]{\textbf{\textsf{#1}}} % macro for typesetting constructor identifiers \newcommand{\coqdocconstr}[1]{\textsf{#1}} % macro for typesetting tactic identifiers \newcommand{\coqdoctac}[1]{\texttt{#1}} % These are the real macros used by coqdoc, their typesetting is % based on the above macros by default. \newcommand{\coqdoclibrary}[1]{\coqdoccst{#1}} \newcommand{\coqdocinductive}[1]{\coqdocind{#1}} \newcommand{\coqdocdefinition}[1]{\coqdoccst{#1}} \newcommand{\coqdocvariable}[1]{\coqdocvar{#1}} \newcommand{\coqdocconstructor}[1]{\coqdocconstr{#1}} \newcommand{\coqdoclemma}[1]{\coqdoccst{#1}} \newcommand{\coqdocclass}[1]{\coqdocind{#1}} \newcommand{\coqdocinstance}[1]{\coqdoccst{#1}} \newcommand{\coqdocmethod}[1]{\coqdoccst{#1}} \newcommand{\coqdocabbreviation}[1]{\coqdoccst{#1}} \newcommand{\coqdocrecord}[1]{\coqdocind{#1}} \newcommand{\coqdocprojection}[1]{\coqdoccst{#1}} \newcommand{\coqdocnotation}[1]{\coqdockw{#1}} \newcommand{\coqdocsection}[1]{\coqdoccst{#1}} \newcommand{\coqdocaxiom}[1]{\coqdocax{#1}} \newcommand{\coqdocmodule}[1]{\coqdocmod{#1}} % Environment encompassing code fragments % !!! CAUTION: This environment may have empty contents \newenvironment{coqdoccode}{}{} % Environment for comments \newenvironment{coqdoccomment}{\tt(*}{*)} % newline and indentation %BEGIN LATEX % Base indentation length \newlength{\coqdocbaseindent} \setlength{\coqdocbaseindent}{0em} % Beginning of a line without any Coq indentation \newcommand{\coqdocnoindent}{\noindent\kern\coqdocbaseindent} % Beginning of a line with a given Coq indentation \newcommand{\coqdocindent}[1]{\noindent\kern\coqdocbaseindent\noindent\kern#1} % End-of-the-line \newcommand{\coqdoceol}{\hspace*{\fill}\setlength\parskip{0pt}\par} % Empty lines (in code only) \newcommand{\coqdocemptyline}{\vskip 0.4em plus 0.1em minus 0.1em} \usepackage{ifpdf} \ifpdf \RequirePackage{hyperref} \hypersetup{raiselinks=true,colorlinks=true,linkcolor=black} % To do indexing, use something like: % \usepackage{multind} % \newcommand{\coqdef}[3]{\hypertarget{coq:#1}{\index{coq}{#1@#2|hyperpage}#3}} \newcommand{\coqdef}[3]{\phantomsection\hypertarget{coq:#1}{#3}} \newcommand{\coqref}[2]{\hyperlink{coq:#1}{#2}} \newcommand{\coqexternalref}[3]{\href{#1.html\##2}{#3}} \newcommand{\identref}[2]{\hyperlink{coq:#1}{\textsf {#2}}} \newcommand{\coqlibrary}[3]{\cleardoublepage\phantomsection \hypertarget{coq:#1}{\chapter{#2\texorpdfstring{\coqdoccst}{}{#3}}}} \else \newcommand{\coqdef}[3]{#3} \newcommand{\coqref}[2]{#2} \newcommand{\coqexternalref}[3]{#3} \newcommand{\texorpdfstring}[2]{#1} \newcommand{\identref}[2]{\textsf{#2}} \newcommand{\coqlibrary}[3]{\cleardoublepage\chapter{#2\coqdoccst{#3}}} \fi \usepackage{xr} \newif\if@coqdoccolors \@coqdoccolorsfalse \DeclareOption{color}{\@coqdoccolorstrue} \ProcessOptions \if@coqdoccolors \RequirePackage{xcolor} \definecolor{varpurple}{rgb}{0.4,0,0.4} \definecolor{constrmaroon}{rgb}{0.6,0,0} \definecolor{defgreen}{rgb}{0,0.4,0} \definecolor{indblue}{rgb}{0,0,0.8} \definecolor{kwred}{rgb}{0.8,0.1,0.1} \def\coqdocvarcolor{varpurple} \def\coqdockwcolor{kwred} \def\coqdoccstcolor{defgreen} \def\coqdocindcolor{indblue} \def\coqdocconstrcolor{constrmaroon} \def\coqdocmodcolor{defgreen} \def\coqdocaxcolor{varpurple} \def\coqdoctaccolor{black} \def\coqdockw#1{{\color{\coqdockwcolor}{\texttt{#1}}}} \def\coqdocvar#1{{\color{\coqdocvarcolor}{\textit{#1}}}} \def\coqdoccst#1{{\color{\coqdoccstcolor}{\textrm{#1}}}} \def\coqdocind#1{{\color{\coqdocindcolor}{\textsf{#1}}}} \def\coqdocconstr#1{{\color{\coqdocconstrcolor}{\textsf{#1}}}} \def\coqdocmod#1{{{\color{\coqdocmodcolor}{\textsc{\textsf{#1}}}}}} \def\coqdocax#1{{{\color{\coqdocaxcolor}{\textsl{\textrm{#1}}}}}} \def\coqdoctac#1{{\color{\coqdoctaccolor}{\texttt{#1}}}} \fi \endinput coq-8.4pl4/tools/coq-db.el0000644000175000017500000002074112326224777014466 0ustar stephsteph;;; coq-db.el --- coq keywords database utility functions ;; ;; Author: Pierre Courtieu ;; License: GPL (GNU GENERAL PUBLIC LICENSE) ;; ;;; We store all information on keywords (tactics or command) in big ;; tables (ex: `coq-tactics-db') From there we get: menus including ;; "smart" commands, completions for command coq-insert-... ;; abbrev tables and font-lock keyword ;;; real value defined below ;;; Commentary: ;; ;;; Code: ;(require 'proof-config) ; for proof-face-specs, a macro ;(require 'holes) (defconst coq-syntax-db nil "Documentation-only variable, for coq keyword databases. Each element of a keyword database contains the definition of a \"form\", of the form: (MENUNAME ABBREV INSERT STATECH KWREG INSERT-FUN HIDE) MENUNAME is the name of form (or form variant) as it should appear in menus or completion lists. ABBREV is the abbreviation for completion via \\[expand-abbrev]. INSERT is the complete text of the form, which may contain holes denoted by \"#\" or \"@{xxx}\". If non-nil the optional STATECH specifies that the command is not state preserving for coq. If non-nil the optional KWREG is the regexp to colorize correponding to the keyword. ex: \"simple\\\\s-+destruct\" (\\\\s-+ meaning \"one or more spaces\"). *WARNING*: A regexp longer than another one should be put FIRST. For example: (\"Module Type\" ... ... t \"Module\\s-+Type\") (\"Module\" ... ... t \"Module\") Is ok because the longer regexp is recognized first. If non-nil the optional INSERT-FUN is the function to be called when inserting the form (instead of inserting INSERT, except when using \\[expand-abbrev]). This allows to write functions asking for more information to assist the user. If non-nil the optional HIDE specifies that this form should not appear in the menu but only in interactive completions. Example of what could be in your emacs init file: (defvar coq-user-tactics-db '( (\"mytac\" \"mt\" \"mytac # #\" t \"mytac\") (\"myassert by\" \"massb\" \"myassert ( # : # ) by #\" t \"assert\") )) Explanation of the first line: the tactic menu entry mytac, abbreviated by mt, will insert \"mytac # #\" where #s are holes to fill, and \"mytac\" becomes a new keyword to colorize." ) (defun coq-insert-from-db (db prompt) "Ask for a keyword, with completion on keyword database DB and insert. Insert corresponding string with holes at point. If an insertion function is present for the keyword, call it instead. see `coq-syntax-db' for DB structure." (let* ((tac (completing-read (concat prompt " (tab for completion) : ") db nil nil)) (infos (cddr (assoc tac db))) (s (car infos)) ; completion to insert (f (car-safe (cdr-safe (cdr-safe (cdr infos))))) ; insertion function (pt (point))) (if f (funcall f) ; call f if present (insert (or s tac)) ; insert completion and indent otherwise (holes-replace-string-by-holes-backward-jump pt) (indent-according-to-mode)))) (defun coq-build-regexp-list-from-db (db &optional filter) "Take a keyword database DB and return the list of regexps for font-lock. If non-nil Optional argument FILTER is a function applying to each line of DB. For each line if FILTER returns nil, then the keyword is not added to the regexp. See `coq-syntax-db' for DB structure." (let ((l db) (res ())) (while l (let* ((hd (car l)) (tl (cdr l)) ; hd is the first infos list (e1 (car hd)) (tl1 (cdr hd)) ; e1 = menu entry (e2 (car tl1)) (tl2 (cdr tl1)) ; e2 = abbreviation (e3 (car tl2)) (tl3 (cdr tl2)) ; e3 = completion (e4 (car-safe tl3)) (tl4 (cdr-safe tl3)) ; e4 = state changing (e5 (car-safe tl4)) (tl5 (cdr-safe tl4)) ; e5 = colorization string ) ;; TODO delete doublons (when (and e5 (or (not filter) (funcall filter hd))) (setq res (nconc res (list e5)))) ; careful: nconc destructive! (setq l tl))) res )) ;; Computes the max length of strings in a list (defun max-length-db (db) "Return the length of the longest first element (menu label) of DB. See `coq-syntax-db' for DB structure." (let ((l db) (res 0)) (while l (let ((lgth (length (car (car l))))) (setq res (max lgth res)) (setq l (cdr l)))) res)) (defun coq-build-menu-from-db-internal (db lgth menuwidth) "Take a keyword database DB and return one insertion submenu. Argument LGTH is the max size of the submenu. Argument MENUWIDTH is the width of the largest line in the menu (without abbrev and shortcut specifications). Used by `coq-build-menu-from-db', which you should probably use instead. See `coq-syntax-db' for DB structure." (let ((l db) (res ()) (size lgth) (keybind-abbrev (substitute-command-keys " \\[expand-abbrev]"))) (while (and l (> size 0)) (let* ((hd (car l))(tl (cdr l)) ; hd is a list of length 3 or 4 (e1 (car hd)) (tl1 (cdr hd)) ; e1 = menu entry (e2 (car tl1)) (tl2 (cdr tl1)) ; e2 = abbreviation (e3 (car tl2)) (tl3 (cdr tl2)) ; e3 = completion (e4 (car-safe tl3)) (tl4 (cdr-safe tl3)) ; e4 = state changing (e5 (car-safe tl4)) (tl5 (cdr-safe tl4)) ; e5 = colorization string (e6 (car-safe tl5)) ; e6 = function for smart insertion (e7 (car-safe (cdr-safe tl5))) ; e7 = if non-nil : hide in menu (entry-with (max (- menuwidth (length e1)) 0)) (spaces (make-string entry-with ? )) ;;(restofmenu (coq-build-menu-from-db-internal tl (- size 1) menuwidth)) ) (when (not e7) ;; if not hidden (let ((menu-entry (vector ;; menu entry label (concat e1 (if (not e2) "" (concat spaces "(" e2 keybind-abbrev ")"))) ;;insertion function if present otherwise insert completion (if e6 e6 `(holes-insert-and-expand ,e3)) t))) (setq res (nconc res (list menu-entry)))));; append *in place* (setq l tl) (setq size (- size 1)))) res)) (defun coq-build-title-menu (db size) "Build a title for the first submenu of DB, of size SIZE. Return the string made of the first and the SIZE nth first element of DB, separated by \"...\". Used by `coq-build-menu-from-db'. See `coq-syntax-db' for DB structure." (concat (car-safe (car-safe db)) " ... " (car-safe (car-safe (nthcdr (- size 1) db))))) (defun coq-sort-menu-entries (menu) (sort menu '(lambda (x y) (string< (downcase (elt x 0)) (downcase (elt y 0)))))) (defun coq-build-menu-from-db (db &optional size) "Take a keyword database DB and return a list of insertion menus for them. Submenus contain SIZE entries (default 30). See `coq-syntax-db' for DB structure." ;; sort is destructive for the list, so copy list before sorting (let* ((l (coq-sort-menu-entries (copy-list db))) (res ()) (wdth (+ 2 (max-length-db db))) (sz (or size 30)) (lgth (length l))) (while l (if (<= lgth sz) (setq res ;; careful: nconc destructive! (nconc res (list (cons (coq-build-title-menu l lgth) (coq-build-menu-from-db-internal l lgth wdth))))) (setq res ; careful: nconc destructive! (nconc res (list (cons (coq-build-title-menu l sz) (coq-build-menu-from-db-internal l sz wdth)))))) (setq l (nthcdr sz l)) (setq lgth (length l))) res)) (defun coq-build-abbrev-table-from-db (db) "Take a keyword database DB and return an abbrev table. See `coq-syntax-db' for DB structure." (let ((l db) (res ())) (while l (let* ((hd (car l))(tl (cdr l)) ; hd is a list of length 3 or 4 (e1 (car hd)) (tl1 (cdr hd)) ; e1 = menu entry (e2 (car tl1)) (tl2 (cdr tl1)) ; e2 = abbreviation (e3 (car tl2)) (tl3 (cdr tl2)) ; e3 = completion ) ;; careful: nconc destructive! (when e2 (setq res (nconc res (list `(,e2 ,e3 holes-abbrev-complete))))) (setq l tl))) res)) (defun filter-state-preserving (l) ; checkdoc-params: (l) "Not documented." (not (nth 3 l))) ; fourth argument is nil --> state preserving command (defun filter-state-changing (l) ; checkdoc-params: (l) "Not documented." (nth 3 l)) ; fourth argument is nil --> state preserving command (defconst coq-solve-tactics-face 'coq-solve-tactics-face "Expression that evaluates to a face. Required so that 'proof-solve-tactics-face is a proper facename") ;;A new face for tactics which fail when they don't kill the current goal (defface coq-solve-tactics-face '((t (:background "red"))) "Face for names of closing tactics in proof scripts." :group 'proof-faces) (provide 'coq-db) ;;; coq-db.el ends here ;** Local Variables: *** ;** fill-column: 80 *** ;** End: *** coq-8.4pl4/tools/coq-sl.sty0000755000175000017500000000134412326224777014737 0ustar stephsteph% COQ style option, for use with the coq-latex filter. \typeout{Document Style option `coq-sl' <7 Apr 92>.} \ifcase\@ptsize \font\sltt = cmsltt10 \or \font\sltt = cmsltt10 \@halfmag \or \font\sltt = cmsltt10 \@magscale1 \fi {\catcode`\^^M=\active % \gdef\@coqinputline#1^^M{\tt Coq < #1\par} % \gdef\@coqoutputline#1^^M{\sltt#1\par} } % \def\@coqblankline{\medskip} \chardef\@coqbackslash="5C \def\coq{ \bgroup \flushleft \parindent 0pt \parskip 0pt \let\do\@makeother\dospecials \catcode`\^^M=\active \catcode`\\=0 \catcode`\ \active \frenchspacing \@vobeyspaces \let\?\@coqinputline \let\:\@coqoutputline \let\;\@coqblankline \let\\\@coqbackslash } \def\endcoq{ \endflushleft \egroup\noindent } coq-8.4pl4/tools/coq.el0000644000175000017500000001130412326224777014076 0ustar stephsteph;; coq.el --- Coq mode editing commands for Emacs ;; ;; Jean-Christophe Filliatre, march 1995 ;; Honteusement pompé de caml.el, Xavier Leroy, july 1993. ;; ;; modified by Marco Maggesi for coq-inferior ; compatibility code for proofgeneral files (require 'coq-font-lock) ; ProofGeneral files. remember to remove coq version tests in ; coq-syntax.el (require 'coq-syntax) (defvar coq-mode-map nil "Keymap used in Coq mode.") (if coq-mode-map () (setq coq-mode-map (make-sparse-keymap)) (define-key coq-mode-map "\t" 'coq-indent-command) (define-key coq-mode-map "\M-\t" 'coq-unindent-command) (define-key coq-mode-map "\C-c\C-c" 'compile) ) (defvar coq-mode-syntax-table nil "Syntax table in use in Coq mode buffers.") (if coq-mode-syntax-table () (setq coq-mode-syntax-table (make-syntax-table)) ; ( is first character of comment start (modify-syntax-entry ?\( "()1" coq-mode-syntax-table) ; * is second character of comment start, ; and first character of comment end (modify-syntax-entry ?* ". 23" coq-mode-syntax-table) ; ) is last character of comment end (modify-syntax-entry ?\) ")(4" coq-mode-syntax-table) ; quote is a string-like delimiter (for character literals) (modify-syntax-entry ?' "\"" coq-mode-syntax-table) ; quote is part of words (modify-syntax-entry ?' "w" coq-mode-syntax-table) ) (defvar coq-mode-indentation 2 "*Indentation for each extra tab in Coq mode.") (defun coq-mode-variables () (set-syntax-table coq-mode-syntax-table) (make-local-variable 'paragraph-start) (setq paragraph-start (concat "^$\\|" page-delimiter)) (make-local-variable 'paragraph-separate) (setq paragraph-separate paragraph-start) (make-local-variable 'paragraph-ignore-fill-prefix) (setq paragraph-ignore-fill-prefix t) (make-local-variable 'require-final-newline) (setq require-final-newline t) (make-local-variable 'comment-start) (setq comment-start "(* ") (make-local-variable 'comment-end) (setq comment-end " *)") (make-local-variable 'comment-column) (setq comment-column 40) (make-local-variable 'comment-start-skip) (setq comment-start-skip "(\\*+ *") (make-local-variable 'parse-sexp-ignore-comments) (setq parse-sexp-ignore-comments nil) (make-local-variable 'indent-line-function) (setq indent-line-function 'coq-indent-command) (make-local-variable 'font-lock-keywords) (setq font-lock-defaults '(coq-font-lock-keywords-1))) ;;; The major mode (defun coq-mode () "Major mode for editing Coq code. Tab at the beginning of a line indents this line like the line above. Extra tabs increase the indentation level. \\{coq-mode-map} The variable coq-mode-indentation indicates how many spaces are inserted for each indentation level." (interactive) (kill-all-local-variables) (setq major-mode 'coq-mode) (setq mode-name "coq") (use-local-map coq-mode-map) (coq-mode-variables) (run-hooks 'coq-mode-hook)) ;;; Indentation stuff (defun coq-in-indentation () "Tests whether all characters between beginning of line and point are blanks." (save-excursion (skip-chars-backward " \t") (bolp))) (defun coq-indent-command () "Indent the current line in Coq mode. When the point is at the beginning of an empty line, indent this line like the line above. When the point is at the beginning of an indented line \(i.e. all characters between beginning of line and point are blanks\), increase the indentation by one level. The indentation size is given by the variable coq-mode-indentation. In all other cases, insert a tabulation (using insert-tab)." (interactive) (let* ((begline (save-excursion (beginning-of-line) (point))) (current-offset (- (point) begline)) (previous-indentation (save-excursion (if (eq (forward-line -1) 0) (current-indentation) 0)))) (cond ((and (bolp) (looking-at "[ \t]*$") (> previous-indentation 0)) (indent-to previous-indentation)) ((coq-in-indentation) (indent-to (+ current-offset coq-mode-indentation))) (t (insert-tab))))) (defun coq-unindent-command () "Decrease indentation by one level in Coq mode. Works only if the point is at the beginning of an indented line \(i.e. all characters between beginning of line and point are blanks\). Does nothing otherwise." (interactive) (let* ((begline (save-excursion (beginning-of-line) (point))) (current-offset (- (point) begline))) (if (and (>= current-offset coq-mode-indentation) (coq-in-indentation)) (backward-delete-char-untabify coq-mode-indentation)))) ;;; coq.el ends here (provide 'coq) coq-8.4pl4/tools/coq-inferior.el0000644000175000017500000002652612326224777015725 0ustar stephsteph;;; inferior-coq.el --- Run an inferior Coq process. ;;; ;;; Copyright (C) Marco Maggesi ;;; Time-stamp: "2002-02-28 12:15:04 maggesi" ;; Emacs Lisp Archive Entry ;; Filename: inferior-coq.el ;; Version: 1.0 ;; Keywords: process coq ;; Author: Marco Maggesi ;; Maintainer: Marco Maggesi ;; Description: Run an inferior Coq process. ;; URL: http://www.math.unifi.it/~maggesi/ ;; Compatibility: Emacs20, Emacs21, XEmacs21 ;; This is free software; you can redistribute it and/or modify it under ;; the terms of the GNU General Public License as published by the Free ;; Software Foundation; either version 2, or (at your option) any later ;; version. ;; ;; This is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License ;; for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ;; MA 02111-1307, USA. ;;; Commentary: ;; Coq is a proof assistant (http://coq.inria.fr/). This code run an ;; inferior Coq process and defines functions to send bits of code ;; from other buffers to the inferior process. This is a ;; customisation of comint-mode (see comint.el). For a more complex ;; and full featured Coq interface under Emacs look at Proof General ;; (http://zermelo.dcs.ed.ac.uk/~proofgen/). ;; ;; Written by Marco Maggesi with code heavly ;; borrowed from emacs cmuscheme.el ;; ;; Please send me bug reports, bug fixes, and extensions, so that I can ;; merge them into the master source. ;;; Installation: ;; You need to have coq.el already installed (it comes with the ;; standard Coq distribution) in order to use this code. Put this ;; file somewhere in you load-path and add the following lines in your ;; "~/.emacs": ;; ;; (setq auto-mode-alist (cons '("\\.v$" . coq-mode) auto-mode-alist)) ;; (autoload 'coq-mode "coq" "Major mode for editing Coq vernacular." t) ;; (autoload 'run-coq "inferior-coq" "Run an inferior Coq process." t) ;; (autoload 'run-coq-other-window "inferior-coq" ;; "Run an inferior Coq process in a new window." t) ;; (autoload 'run-coq-other-frame "inferior-coq" ;; "Run an inferior Coq process in a new frame." t) ;;; Usage: ;; Call `M-x "run-coq'. ;; ;; Functions and key bindings (Learn more keys with `C-c C-h' or `C-h m'): ;; C-return ('M-x coq-send-line) send the current line. ;; C-c C-r (`M-x coq-send-region') send the current region. ;; C-c C-a (`M-x coq-send-abort') send the command "Abort". ;; C-c C-t (`M-x coq-send-restart') send the command "Restart". ;; C-c C-s (`M-x coq-send-show') send the command "Show". ;; C-c C-u (`M-x coq-send-undo') send the command "Undo". ;; C-c C-v (`M-x coq-check-region') run command "Check" on region. ;; C-c . (`M-x coq-come-here') Restart and send until current point. ;;; Change Log: ;; From -0.0 to 1.0 brought into existence. (require 'coq) (require 'comint) (setq coq-program-name "coqtop") (defgroup inferior-coq nil "Run a coq process in a buffer." :group 'coq) (defcustom inferior-coq-mode-hook nil "*Hook for customising inferior-coq mode." :type 'hook :group 'coq) (defvar inferior-coq-mode-map (let ((m (make-sparse-keymap))) (define-key m "\C-c\C-r" 'coq-send-region) (define-key m "\C-c\C-a" 'coq-send-abort) (define-key m "\C-c\C-t" 'coq-send-restart) (define-key m "\C-c\C-s" 'coq-send-show) (define-key m "\C-c\C-u" 'coq-send-undo) (define-key m "\C-c\C-v" 'coq-check-region) m)) ;; Install the process communication commands in the coq-mode keymap. (define-key coq-mode-map [(control return)] 'coq-send-line) (define-key coq-mode-map "\C-c\C-r" 'coq-send-region) (define-key coq-mode-map "\C-c\C-a" 'coq-send-abort) (define-key coq-mode-map "\C-c\C-t" 'coq-send-restart) (define-key coq-mode-map "\C-c\C-s" 'coq-send-show) (define-key coq-mode-map "\C-c\C-u" 'coq-send-undo) (define-key coq-mode-map "\C-c\C-v" 'coq-check-region) (define-key coq-mode-map "\C-c." 'coq-come-here) (defvar coq-buffer) (define-derived-mode inferior-coq-mode comint-mode "Inferior Coq" "\ Major mode for interacting with an inferior Coq process. The following commands are available: \\{inferior-coq-mode-map} A Coq process can be fired up with M-x run-coq. Customisation: Entry to this mode runs the hooks on comint-mode-hook and inferior-coq-mode-hook (in that order). You can send text to the inferior Coq process from other buffers containing Coq source. Functions and key bindings (Learn more keys with `C-c C-h'): C-return ('M-x coq-send-line) send the current line. C-c C-r (`M-x coq-send-region') send the current region. C-c C-a (`M-x coq-send-abort') send the command \"Abort\". C-c C-t (`M-x coq-send-restart') send the command \"Restart\". C-c C-s (`M-x coq-send-show') send the command \"Show\". C-c C-u (`M-x coq-send-undo') send the command \"Undo\". C-c C-v (`M-x coq-check-region') run command \"Check\" on region. C-c . (`M-x coq-come-here') Restart and send until current point. " ;; Customise in inferior-coq-mode-hook (setq comint-prompt-regexp "^[^<]* < *") (coq-mode-variables) (setq mode-line-process '(":%s")) (setq comint-input-filter (function coq-input-filter)) (setq comint-get-old-input (function coq-get-old-input))) (defcustom inferior-coq-filter-regexp "\\`\\s *\\S ?\\S ?\\s *\\'" "*Input matching this regexp are not saved on the history list. Defaults to a regexp ignoring all inputs of 0, 1, or 2 letters." :type 'regexp :group 'inferior-coq) (defun coq-input-filter (str) "Don't save anything matching `inferior-coq-filter-regexp'." (not (string-match inferior-coq-filter-regexp str))) (defun coq-get-old-input () "Snarf the sexp ending at point." (save-excursion (let ((end (point))) (backward-sexp) (buffer-substring (point) end)))) (defun coq-args-to-list (string) (let ((where (string-match "[ \t]" string))) (cond ((null where) (list string)) ((not (= where 0)) (cons (substring string 0 where) (coq-args-to-list (substring string (+ 1 where) (length string))))) (t (let ((pos (string-match "[^ \t]" string))) (if (null pos) nil (coq-args-to-list (substring string pos (length string))))))))) ;;;###autoload (defun run-coq (cmd) "Run an inferior Coq process, input and output via buffer *coq*. If there is a process already running in `*coq*', switch to that buffer. With argument, allows you to edit the command line (default is value of `coq-program-name'). Runs the hooks `inferior-coq-mode-hook' \(after the `comint-mode-hook' is run). \(Type \\[describe-mode] in the process buffer for a list of commands.)" (interactive (list (if current-prefix-arg (read-string "Run Coq: " coq-program-name) coq-program-name))) (if (not (comint-check-proc "*coq*")) (let ((cmdlist (coq-args-to-list cmd))) (set-buffer (apply 'make-comint "coq" (car cmdlist) nil (cdr cmdlist))) (inferior-coq-mode))) (setq coq-program-name cmd) (setq coq-buffer "*coq*") (switch-to-buffer "*coq*")) ;;;###autoload (add-hook 'same-window-buffer-names "*coq*") ;;;###autoload (defun run-coq-other-window (cmd) "Run an inferior Coq process, input and output via buffer *coq*. If there is a process already running in `*coq*', switch to that buffer. With argument, allows you to edit the command line (default is value of `coq-program-name'). Runs the hooks `inferior-coq-mode-hook' \(after the `comint-mode-hook' is run). \(Type \\[describe-mode] in the process buffer for a list of commands.)" (interactive (list (if current-prefix-arg (read-string "Run Coq: " coq-program-name) coq-program-name))) (if (not (comint-check-proc "*coq*")) (let ((cmdlist (coq-args-to-list cmd))) (set-buffer (apply 'make-comint "coq" (car cmdlist) nil (cdr cmdlist))) (inferior-coq-mode))) (setq coq-program-name cmd) (setq coq-buffer "*coq*") (pop-to-buffer "*coq*")) ;;;###autoload (add-hook 'same-window-buffer-names "*coq*") (defun run-coq-other-frame (cmd) "Run an inferior Coq process, input and output via buffer *coq*. If there is a process already running in `*coq*', switch to that buffer. With argument, allows you to edit the command line (default is value of `coq-program-name'). Runs the hooks `inferior-coq-mode-hook' \(after the `comint-mode-hook' is run). \(Type \\[describe-mode] in the process buffer for a list of commands.)" (interactive (list (if current-prefix-arg (read-string "Run Coq: " coq-program-name) coq-program-name))) (if (not (comint-check-proc "*coq*")) (let ((cmdlist (coq-args-to-list cmd))) (set-buffer (apply 'make-comint "coq" (car cmdlist) nil (cdr cmdlist))) (inferior-coq-mode))) (setq coq-program-name cmd) (setq coq-buffer "*coq*") (switch-to-buffer-other-frame "*coq*")) (defun switch-to-coq (eob-p) "Switch to the coq process buffer. With argument, position cursor at end of buffer." (interactive "P") (if (get-buffer coq-buffer) (pop-to-buffer coq-buffer) (error "No current process buffer. See variable `coq-buffer'")) (cond (eob-p (push-mark) (goto-char (point-max))))) (defun coq-send-region (start end) "Send the current region to the inferior Coq process." (interactive "r") (comint-send-region (coq-proc) start end) (comint-send-string (coq-proc) "\n")) (defun coq-send-line () "Send the current line to the Coq process." (interactive) (save-excursion (end-of-line) (let ((end (point))) (beginning-of-line) (coq-send-region (point) end))) (next-line 1)) (defun coq-send-abort () "Send the command \"Abort.\" to the inferior Coq process." (interactive) (comint-send-string (coq-proc) "Abort.\n")) (defun coq-send-restart () "Send the command \"Restart.\" to the inferior Coq process." (interactive) (comint-send-string (coq-proc) "Restart.\n")) (defun coq-send-undo () "Reset coq to the initial state and send the region between the beginning of file and the point." (interactive) (comint-send-string (coq-proc) "Undo.\n")) (defun coq-check-region (start end) "Run the commmand \"Check\" on the current region." (interactive "r") (comint-proc-query (coq-proc) (concat "Check " (buffer-substring start end) ".\n"))) (defun coq-send-show () "Send the command \"Show.\" to the inferior Coq process." (interactive) (comint-send-string (coq-proc) "Show.\n")) (defun coq-come-here () "Reset coq to the initial state and send the region between the beginning of file and the point." (interactive) (comint-send-string (coq-proc) "Reset Initial.\n") (coq-send-region 1 (point))) (defvar coq-buffer nil "*The current coq process buffer.") (defun coq-proc () "Return the current coq process. See variable `coq-buffer'." (let ((proc (get-buffer-process (if (eq major-mode 'inferior-coq-mode) (current-buffer) coq-buffer)))) (or proc (error "No current process. See variable `coq-buffer'")))) (defcustom inferior-coq-load-hook nil "This hook is run when inferior-coq is loaded in. This is a good place to put keybindings." :type 'hook :group 'inferior-coq) (run-hooks 'inferior-coq-load-hook) (provide 'inferior-coq) coq-8.4pl4/tools/coq_makefile.ml0000644000175000017500000007336412326224777015761 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* print x | x :: l -> print x; print sep; print_list sep l | [] -> () let list_iter_i f = let rec aux i = function [] -> () | a::l -> f i a; aux (i+1) l in aux 1 let section s = let l = String.length s in let sep = String.make (l+5) '#' and sep2 = String.make (l+5) ' ' in String.set sep (l+4) '\n'; String.set sep2 0 '#'; String.set sep2 (l+3) '#'; String.set sep2 (l+4) '\n'; print sep; print sep2; print "# "; print s; print " #\n"; print sep2; print sep; print "\n" let usage () = output_string stderr "Usage summary: coq_makefile [subdirectory] .... [file.v] ... [file.ml[i4]?] ... [file.mllib] ... [-custom command dependencies file] ... [-I dir] ... [-R physicalpath logicalpath] ... [VARIABLE = value] ... [-arg opt] ... [-opt|-byte] [-no-install] [-f file] [-o file] [-h] [--help] [file.v]: Coq file to be compiled [file.ml[i4]?]: Objective Caml file to be compiled [file.mllib]: ocamlbuild file that describes a Objective Caml library [subdirectory] : subdirectory that should be \"made\" and has a Makefile itself to do so. [-custom command dependencies file]: add target \"file\" with command \"command\" and dependencies \"dependencies\" [-I dir]: look for Objective Caml dependencies in \"dir\" [-R physicalpath logicalpath]: look for Coq dependencies resursively starting from \"physicalpath\". The logical path associated to the physical path is \"logicalpath\". [VARIABLE = value]: Add the variable definition \"VARIABLE=value\" [-byte]: compile with byte-code version of coq [-opt]: compile with native-code version of coq [-arg opt]: send option \"opt\" to coqc [-install opt]: where opt is \"user\" to force install into user directory, \"none\" to build a makefile with no install target or \"global\" to force install in $COQLIB directory [-f file]: take the contents of file as arguments [-o file]: output should go in file file Output file outside the current directory is forbidden. [-h]: print this usage summary [--help]: equivalent to [-h]\n"; exit 1 let is_genrule r = let genrule = Str.regexp("%") in Str.string_match genrule r 0 let string_prefix a b = let rec aux i = try if a.[i] = b.[i] then aux (i+1) else i with |Invalid_argument _ -> i in String.sub a 0 (aux 0) let is_prefix dir1 dir2 = let l1 = String.length dir1 in let l2 = String.length dir2 in dir1 = dir2 or (l1 < l2 & String.sub dir2 0 l1 = dir1 & dir2.[l1] = '/') let physical_dir_of_logical_dir ldir = let le = String.length ldir - 1 in let pdir = if ldir.[le] = '.' then String.sub ldir 0 (le - 1) else String.copy ldir in for i = 0 to le - 1 do if pdir.[i] = '.' then pdir.[i] <- '/'; done; pdir let standard opt = print "byte:\n"; print "\t$(MAKE) all \"OPT:=-byte\"\n\n"; print "opt:\n"; if not opt then print "\t@echo \"WARNING: opt is disabled\"\n"; print "\t$(MAKE) all \"OPT:="; print (if opt then "-opt" else "-byte"); print "\"\n\n" let classify_files_by_root var files (inc_i,inc_r) = if not (List.exists (fun (pdir,_,_) -> pdir = ".") inc_r) then begin let absdir_of_files = List.rev_map (fun x -> Minilib.canonical_path_name (Filename.dirname x)) files in (* files in scope of a -I option (assuming they are no overlapping) *) let has_inc_i = List.exists (fun (_,a) -> List.mem a absdir_of_files) inc_i in if has_inc_i then begin printf "%sINC=" var; List.iter (fun (pdir,absdir) -> if List.mem absdir absdir_of_files then printf "$(filter $(wildcard %s/*),$(%s)) " pdir var ) inc_i; printf "\n"; end; (* Files in the scope of a -R option (assuming they are disjoint) *) list_iter_i (fun i (pdir,ldir,abspdir) -> if List.exists (is_prefix abspdir) absdir_of_files then printf "%s%d=$(patsubst %s/%%,%%,$(filter %s/%%,$(%s)))\n" var i pdir pdir var) inc_r; end let install_include_by_root files_var files (inc_i,inc_r) = try (* All files caught by a -R . option (assuming it is the only one) *) let ldir = match inc_r with |[(".",t,_)] -> t |l -> let out = List.assoc "." (List.map (fun (p,l,_) -> (p,l)) inc_r) in let () = prerr_string "Warning: install rule assumes that -R . _ is the only -R option" in out in let pdir = physical_dir_of_logical_dir ldir in printf "\tfor i in $(%s); do \\\n" files_var; printf "\t install -d `dirname $(DSTROOT)$(COQLIBINSTALL)/%s/$$i`; \\\n" pdir; printf "\t install -m 0644 $$i $(DSTROOT)$(COQLIBINSTALL)/%s/$$i; \\\n" pdir; printf "\tdone\n" with Not_found -> let absdir_of_files = List.rev_map (fun x -> Minilib.canonical_path_name (Filename.dirname x)) files in let has_inc_i_files = List.exists (fun (_,a) -> List.mem a absdir_of_files) inc_i in let install_inc_i d = printf "\tinstall -d $(DSTROOT)$(COQLIBINSTALL)/%s; \\\n" d; printf "\tfor i in $(%sINC); do \\\n" files_var; printf "\t install -m 0644 $$i $(DSTROOT)$(COQLIBINSTALL)/%s/`basename $$i`; \\\n" d; printf "\tdone\n" in if inc_r = [] then if has_inc_i_files then begin (* Files in the scope of a -I option *) install_inc_i "$(INSTALLDEFAULTROOT)"; end else () else (* Files in the scope of a -R option (assuming they are disjoint) *) list_iter_i (fun i (pdir,ldir,abspdir) -> let has_inc_r_files = List.exists (is_prefix abspdir) absdir_of_files in let pdir' = physical_dir_of_logical_dir ldir in if has_inc_r_files then begin printf "\tcd %s; for i in $(%s%d); do \\\n" pdir files_var i; printf "\t install -d `dirname $(DSTROOT)$(COQLIBINSTALL)/%s/$$i`; \\\n" pdir'; printf "\t install -m 0644 $$i $(DSTROOT)$(COQLIBINSTALL)/%s/$$i; \\\n" pdir'; printf "\tdone\n"; end; if has_inc_i_files then install_inc_i pdir' ) inc_r let install_doc some_vfiles some_mlifiles (_,inc_r) = let install_one_kind kind dir = printf "\tinstall -d $(DSTROOT)$(COQDOCINSTALL)/%s/%s\n" dir kind; printf "\tfor i in %s/*; do \\\n" kind; printf "\t install -m 0644 $$i $(DSTROOT)$(COQDOCINSTALL)/%s/$$i;\\\n" dir; print "\tdone\n" in print "install-doc:\n"; let () = match inc_r with |[] -> if some_vfiles then install_one_kind "html" "$(INSTALLDEFAULTROOT)"; if some_mlifiles then install_one_kind "mlihtml" "$(INSTALLDEFAULTROOT)"; |(_,lp,_)::q -> let pr = List.fold_left (fun a (_,b,_) -> string_prefix a b) lp q in if (pr <> "") && ((List.exists (fun(_,b,_) -> b = pr) inc_r) || pr.[String.length pr - 1] = '.') then begin let rt = physical_dir_of_logical_dir pr in if some_vfiles then install_one_kind "html" rt; if some_mlifiles then install_one_kind "mlihtml" rt; end else begin prerr_string "Warning: -R options don't have a correct common prefix, install-doc will put anything in $INSTALLDEFAULTROOT\n"; if some_vfiles then install_one_kind "html" "$(INSTALLDEFAULTROOT)"; if some_mlifiles then install_one_kind "mlihtml" "$(INSTALLDEFAULTROOT)"; end in print "\n" let install (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,sds) inc = function |Project_file.NoInstall -> () |is_install -> let () = if is_install = Project_file.UnspecInstall then print "userinstall:\n\t+$(MAKE) USERINSTALL=true install\n\n" in let not_empty = function |[] -> false |_::_ -> true in let cmofiles = mlpackfiles@mlfiles@ml4files in let cmifiles = mlifiles@cmofiles in let cmxsfiles = cmofiles@mllibfiles in if (not_empty cmxsfiles) then begin print "install-natdynlink:\n"; install_include_by_root "CMXSFILES" cmxsfiles inc; print "\n"; end; print "install:"; if (not_empty cmxsfiles) then print "$(if $(HASNATDYNLINK_OR_EMPTY),install-natdynlink)"; print "\n"; if not_empty vfiles then install_include_by_root "VOFILES" vfiles inc; if (not_empty cmofiles) then install_include_by_root "CMOFILES" cmofiles inc; if (not_empty cmifiles) then install_include_by_root "CMIFILES" cmifiles inc; if (not_empty mllibfiles) then install_include_by_root "CMAFILES" mllibfiles inc; List.iter (fun x -> printf "\t(cd %s; $(MAKE) DSTROOT=$(DSTROOT) INSTALLDEFAULTROOT=$(INSTALLDEFAULTROOT)/%s install)\n" x x) sds; print "\n"; install_doc (not_empty vfiles) (not_empty mlifiles) inc let make_makefile sds = if !make_name <> "" then begin printf "%s: %s\n" !makefile_name !make_name; print "\tmv -f $@ $@.bak\n"; print "\t$(COQBIN)coq_makefile -f $< -o $@\n\n"; List.iter (fun x -> print "\t(cd "; print x; print " ; $(MAKE) Makefile)\n") sds; print "\n"; end let clean sds sps = print "clean:\n"; if !some_mlfile || !some_mlifile || !some_ml4file || !some_mllibfile || !some_mlpackfile then begin print "\trm -f $(ALLCMOFILES) $(CMIFILES) $(CMAFILES)\n"; print "\trm -f $(ALLCMOFILES:.cmo=.cmx) $(CMXAFILES) $(CMXSFILES) $(ALLCMOFILES:.cmo=.o) $(CMXAFILES:.cmxa=.a)\n"; print "\trm -f $(addsuffix .d,$(MLFILES) $(MLIFILES) $(ML4FILES) $(MLLIBFILES) $(MLPACKFILES))\n"; end; if !some_vfile then print "\trm -f $(VOFILES) $(VIFILES) $(GFILES) $(VFILES:.v=.v.d) $(VFILES:=.beautified) $(VFILES:=.old)\n"; print "\trm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob $(VFILES:.v=.glob) $(VFILES:.v=.tex) $(VFILES:.v=.g.tex) all-mli.tex\n"; print "\t- rm -rf html mlihtml\n"; List.iter (fun (file,_,_) -> if not (is_genrule file) then (print "\t- rm -rf "; print file; print "\n")) sps; List.iter (fun x -> print "\t(cd "; print x; print " ; $(MAKE) clean)\n") sds; print "\n"; print "archclean:\n"; print "\trm -f *.cmx *.o\n"; List.iter (fun x -> print "\t(cd "; print x; print " ; $(MAKE) archclean)\n") sds; print "\n"; print "printenv:\n\t@$(COQBIN)coqtop -config\n"; print "\t@echo CAMLC =\t$(CAMLC)\n\t@echo CAMLOPTC =\t$(CAMLOPTC)\n\t@echo PP =\t$(PP)\n\t@echo COQFLAGS =\t$(COQFLAGS)\n"; print "\t@echo COQLIBINSTALL =\t$(COQLIBINSTALL)\n\t@echo COQDOCINSTALL =\t$(COQDOCINSTALL)\n\n" let header_includes () = () let implicit () = section "Implicit rules."; let mli_rules () = print "%.cmi: %.mli\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n"; print "%.mli.d: %.mli\n"; print "\t$(OCAMLDEP) -slash $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in let ml4_rules () = print "%.cmo: %.ml4\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n"; print "%.cmx: %.ml4\n\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n"; print "%.ml4.d: %.ml4\n"; print "\t$(COQDEP) -slash $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in let ml_rules () = print "%.cmo: %.ml\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n"; print "%.cmx: %.ml\n\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $<\n\n"; print "%.ml.d: %.ml\n"; print "\t$(OCAMLDEP) -slash $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in let cmxs_rules () = print "%.cmxs: %.cmxa\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -linkall -shared -o $@ $<\n\n"; print "%.cmxs: %.cmx\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $<\n\n" in let mllib_rules () = print "%.cma: | %.mllib\n\t$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n"; print "%.cmxa: | %.mllib\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n"; print "%.mllib.d: %.mllib\n"; print "\t$(COQDEP) -slash $(COQLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in let mlpack_rules () = print "%.cmo: | %.mlpack\n\t$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n"; print "%.cmx: | %.mlpack\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n"; print "%.mlpack.d: %.mlpack\n"; print "\t$(COQDEP) -slash $(COQLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n"; in let v_rules () = print "%.vo %.glob: %.v\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) $*\n\n"; print "%.vi: %.v\n\t$(COQC) -i $(COQDEBUG) $(COQFLAGS) $*\n\n"; print "%.g: %.v\n\t$(GALLINA) $<\n\n"; print "%.tex: %.v\n\t$(COQDOC) $(COQDOCFLAGS) -latex $< -o $@\n\n"; print "%.html: %.v %.glob\n\t$(COQDOC) $(COQDOCFLAGS) -html $< -o $@\n\n"; print "%.g.tex: %.v\n\t$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@\n\n"; print "%.g.html: %.v %.glob\n\t$(COQDOC)$(COQDOCFLAGS) -html -g $< -o $@\n\n"; print "%.v.d: %.v\n"; print "\t$(COQDEP) -slash $(COQLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n"; print "%.v.beautified:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $*\n\n" in if !some_mlifile then mli_rules (); if !some_ml4file then ml4_rules (); if !some_mlfile then ml_rules (); if !some_mlfile || !some_ml4file then cmxs_rules (); if !some_mllibfile then mllib_rules (); if !some_mlpackfile then mlpack_rules (); if !some_vfile then v_rules () let variables is_install opt (args,defs) = let var_aux (v,def) = print v; print "="; print def; print "\n" in section "Variables definitions."; List.iter var_aux defs; print "\n"; if not opt then print "override OPT:=-byte\n" else print "OPT?=\n"; begin match args with |[] -> () |h::t -> print "OTHERFLAGS="; print h; List.iter (fun s -> print " ";print s) t; print "\n"; end; (* Coq executables and relative variables *) if !some_vfile || !some_mlpackfile || !some_mllibfile then print "COQDEP?=$(COQBIN)coqdep -c\n"; if !some_vfile then begin print "COQFLAGS?=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)\n"; print "COQCHKFLAGS?=-silent -o\n"; print "COQDOCFLAGS?=-interpolate -utf8\n"; print "COQC?=$(COQBIN)coqc\n"; print "GALLINA?=$(COQBIN)gallina\n"; print "COQDOC?=$(COQBIN)coqdoc\n"; print "COQCHK?=$(COQBIN)coqchk\n\n"; end; (* Caml executables and relative variables *) if !some_ml4file || !some_mlfile || !some_mlifile then begin print "COQSRCLIBS?=-I $(COQLIB)kernel -I $(COQLIB)lib \\ -I $(COQLIB)library -I $(COQLIB)parsing \\ -I $(COQLIB)pretyping -I $(COQLIB)interp \\ -I $(COQLIB)proofs -I $(COQLIB)tactics \\ -I $(COQLIB)toplevel"; List.iter (fun c -> print " \\ -I $(COQLIB)plugins/"; print c) Coq_config.plugins_dirs; print "\n"; print "ZFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB)\n\n"; print "CAMLC?=$(OCAMLC) -c -rectypes\n"; print "CAMLOPTC?=$(OCAMLOPT) -c -rectypes\n"; print "CAMLLINK?=$(OCAMLC) -rectypes\n"; print "CAMLOPTLINK?=$(OCAMLOPT) -rectypes\n"; print "GRAMMARS?=grammar.cma\n"; print "CAMLP4EXTEND?=pa_extend.cmo pa_macro.cmo q_MLast.cmo\n"; print "CAMLP4OPTIONS?=-loc loc\n"; print "PP?=-pp \"$(CAMLP4BIN)$(CAMLP4)o -I $(CAMLLIB) -I . $(COQSRCLIBS) $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl\"\n\n"; end; match is_install with | Project_file.NoInstall -> () | Project_file.UnspecInstall -> section "Install Paths."; print "ifdef USERINSTALL\n"; print "XDG_DATA_HOME?=$(HOME)/.local/share\n"; print "COQLIBINSTALL=$(XDG_DATA_HOME)/coq\n"; print "COQDOCINSTALL=$(XDG_DATA_HOME)/doc/coq\n"; print "else\n"; print "COQLIBINSTALL=${COQLIB}user-contrib\n"; print "COQDOCINSTALL=${DOCDIR}user-contrib\n"; print "endif\n\n" | Project_file.TraditionalInstall -> section "Install Paths."; print "COQLIBINSTALL=${COQLIB}user-contrib\n"; print "COQDOCINSTALL=${DOCDIR}user-contrib\n"; print "\n" | Project_file.UserInstall -> section "Install Paths."; print "XDG_DATA_HOME?=$(HOME)/.local/share\n"; print "COQLIBINSTALL=$(XDG_DATA_HOME)/coq\n"; print "COQDOCINSTALL=$(XDG_DATA_HOME)/doc/coq\n"; print "\n" let parameters () = print ".DEFAULT_GOAL := all\n\n# \n"; print "# This Makefile may take arguments passed as environment variables:\n"; print "# COQBIN to specify the directory where Coq binaries resides;\n"; print "# ZDEBUG/COQDEBUG to specify debug flags for ocamlc&ocamlopt/coqc;\n"; print "# DSTROOT to specify a prefix to install path.\n\n"; print "# Here is a hack to make $(eval $(shell works:\n"; print "define donewline\n\n\nendef\n"; print "includecmdwithout@ = $(eval $(subst @,$(donewline),$(shell { $(1) | tr -d '\\r' | tr '\\n' '@'; })))\n"; print "$(call includecmdwithout@,$(COQBIN)coqtop -config)\n\n" let include_dirs (inc_i,inc_r) = let parse_includes l = List.map (fun (x,_) -> "-I " ^ x) l in let parse_rec_includes l = List.map (fun (p,l,_) -> let l' = if l = "" then "\"\"" else l in "-R " ^ p ^ " " ^ l') l in let inc_i' = List.filter (fun (_,i) -> not (List.exists (fun (_,_,i') -> is_prefix i' i) inc_r)) inc_i in let str_i = parse_includes inc_i in let str_i' = parse_includes inc_i' in let str_r = parse_rec_includes inc_r in section "Libraries definitions."; if !some_ml4file || !some_mlfile || !some_mlifile then begin print "OCAMLLIBS?="; print_list "\\\n " str_i; print "\n"; end; if !some_vfile || !some_mllibfile || !some_mlpackfile then begin print "COQLIBS?="; print_list "\\\n " str_i'; print " "; print_list "\\\n " str_r; print "\n"; print "COQDOCLIBS?="; print_list "\\\n " str_r; print "\n\n"; end let custom sps = let pr_path (file,dependencies,com) = print file; print ": "; print dependencies; print "\n"; if com <> "" then (print "\t"; print com); print "\n\n" in if sps <> [] then section "Custom targets."; List.iter pr_path sps let subdirs sds = let pr_subdir s = print s; print ":\n\tcd "; print s; print " ; $(MAKE) all\n\n" in if sds <> [] then section "Subdirectories."; List.iter pr_subdir sds let forpacks l = let () = if l <> [] then section "Ad-hoc implicit rules for mlpack." in List.iter (fun it -> let h = Filename.chop_extension it in printf "$(addsuffix .cmx,$(filter $(basename $(MLFILES)),$(%s_MLPACK_DEPENDENCIES))): %%.cmx: %%.ml\n" h; printf "\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -for-pack %s $<\n\n" (String.capitalize (Filename.basename h)); printf "$(addsuffix .cmx,$(filter $(basename $(ML4FILES)),$(%s_MLPACK_DEPENDENCIES))): %%.cmx: %%.ml4\n" h; printf "\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -for-pack %s $(PP) -impl $<\n\n" (String.capitalize (Filename.basename h)) ) l let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other_targets inc = let decl_var var = function |[] -> () |l -> printf "%s:=" var; print_list "\\\n " l; print "\n"; printf "\n-include $(addsuffix .d,$(%s))\n.SECONDARY: $(addsuffix .d,$(%s))\n\n" var var in section "Files dispatching."; decl_var "VFILES" vfiles; begin match vfiles with |[] -> () |l -> print "VOFILES:=$(VFILES:.v=.vo)\n"; classify_files_by_root "VOFILES" l inc; print "GLOBFILES:=$(VFILES:.v=.glob)\n"; print "VIFILES:=$(VFILES:.v=.vi)\n"; print "GFILES:=$(VFILES:.v=.g)\n"; print "HTMLFILES:=$(VFILES:.v=.html)\n"; print "GHTMLFILES:=$(VFILES:.v=.g.html)\n" end; decl_var "ML4FILES" ml4files; decl_var "MLFILES" mlfiles; decl_var "MLPACKFILES" mlpackfiles; decl_var "MLLIBFILES" mllibfiles; decl_var "MLIFILES" mlifiles; let mlsfiles = match ml4files,mlfiles,mlpackfiles with |[],[],[] -> [] |[],[],_ -> Printf.eprintf "Mlpack cannot work without ml[4]?"; [] |[],ml,[] -> print "ALLCMOFILES:=$(MLFILES:.ml=.cmo)\n"; ml |ml4,[],[] -> print "ALLCMOFILES:=$(ML4FILES:.ml4=.cmo)\n"; ml4 |ml4,ml,[] -> print "ALLCMOFILES:=$(ML4FILES:.ml4=.cmo) $(MLFILES:.ml=.cmo)\n"; List.rev_append ml ml4 |[],ml,mlpack -> print "ALLCMOFILES:=$(MLFILES:.ml=.cmo) $(MLPACKFILES:.mlpack=.cmo)\n"; List.rev_append mlpack ml |ml4,[],mlpack -> print "ALLCMOFILES:=$(ML4FILES:.ml4=.cmo) $(MLPACKFILES:.mlpack=.cmo)\n"; List.rev_append mlpack ml4 |ml4,ml,mlpack -> print "ALLCMOFILES:=$(ML4FILES:.ml4=.cmo) $(MLFILES:.ml=.cmo) $(MLPACKFILES:.mlpack=.cmo)\n"; List.rev_append mlpack (List.rev_append ml ml4) in begin match mlsfiles with |[] -> () |l -> print "CMOFILES=$(filter-out $(addsuffix .cmo,$(foreach lib,$(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES) $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(ALLCMOFILES))\n"; classify_files_by_root "CMOFILES" l inc; print "CMXFILES=$(CMOFILES:.cmo=.cmx)\n"; print "OFILES=$(CMXFILES:.cmx=.o)\n"; end; begin match mllibfiles with |[] -> () |l -> print "CMAFILES:=$(MLLIBFILES:.mllib=.cma)\n"; classify_files_by_root "CMAFILES" l inc; print "CMXAFILES:=$(CMAFILES:.cma=.cmxa)\n"; end; begin match mlifiles,mlsfiles with |[],[] -> () |l,[] -> print "CMIFILES:=$(MLIFILES:.mli=.cmi)\n"; classify_files_by_root "CMIFILES" l inc; |[],l -> print "CMIFILES=$(ALLCMOFILES:.cmo=.cmi)\n"; classify_files_by_root "CMIFILES" l inc; |l1,l2 -> print "CMIFILES=$(sort $(ALLCMOFILES:.cmo=.cmi) $(MLIFILES:.mli=.cmi))\n"; classify_files_by_root "CMIFILES" (l1@l2) inc; end; begin match mllibfiles,mlsfiles with |[],[] -> () |l,[] -> print "CMXSFILES:=$(CMXAFILES:.cmxa=.cmxs)\n"; classify_files_by_root "CMXSFILES" l inc; |[],l -> print "CMXSFILES=$(CMXFILES:.cmx=.cmxs)\n"; classify_files_by_root "CMXSFILES" l inc; |l1,l2 -> print "CMXSFILES=$(CMXFILES:.cmx=.cmxs) $(CMXAFILES:.cmxa=.cmxs)\n"; classify_files_by_root "CMXSFILES" (l1@l2) inc; end; print "ifeq '$(HASNATDYNLINK)' 'true'\n"; print "HASNATDYNLINK_OR_EMPTY := yes\n"; print "else\n"; print "HASNATDYNLINK_OR_EMPTY :=\n"; print "endif\n\n"; section "Definition of the toplevel targets."; print "all: "; if !some_vfile then print "$(VOFILES) "; if !some_mlfile || !some_ml4file || !some_mlpackfile then print "$(CMOFILES) "; if !some_mllibfile then print "$(CMAFILES) "; if !some_mlfile || !some_ml4file || !some_mllibfile || !some_mlpackfile then print "$(if $(HASNATDYNLINK_OR_EMPTY),$(CMXSFILES)) "; print_list "\\\n " other_targets; print "\n\n"; if !some_mlifile then begin print "mlihtml: $(MLIFILES:.mli=.cmi)\n"; print "\t mkdir $@ || rm -rf $@/*\n"; print "\t$(OCAMLDOC) -html -rectypes -d $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n"; print "all-mli.tex: $(MLIFILES:.mli=.cmi)\n"; print "\t$(OCAMLDOC) -latex -rectypes -o $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n"; end; if !some_vfile then begin print "spec: $(VIFILES)\n\n"; print "gallina: $(GFILES)\n\n"; print "html: $(GLOBFILES) $(VFILES)\n"; print "\t- mkdir -p html\n"; print "\t$(COQDOC) -toc $(COQDOCFLAGS) -html $(COQDOCLIBS) -d html $(VFILES)\n\n"; print "gallinahtml: $(GLOBFILES) $(VFILES)\n"; print "\t- mkdir -p html\n"; print "\t$(COQDOC) -toc $(COQDOCFLAGS) -html -g $(COQDOCLIBS) -d html $(VFILES)\n\n"; print "all.ps: $(VFILES)\n"; print "\t$(COQDOC) -toc $(COQDOCFLAGS) -ps $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; print "all-gal.ps: $(VFILES)\n"; print "\t$(COQDOC) -toc $(COQDOCFLAGS) -ps -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; print "all.pdf: $(VFILES)\n"; print "\t$(COQDOC) -toc $(COQDOCFLAGS) -pdf $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; print "all-gal.pdf: $(VFILES)\n"; print "\t$(COQDOC) -toc $(COQDOCFLAGS) -pdf -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; print "validate: $(VOFILES)\n"; print "\t$(COQCHK) $(COQCHKFLAGS) $(COQLIBS) $(notdir $(^:.vo=))\n\n"; print "beautify: $(VFILES:=.beautified)\n"; print "\tfor file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done\n"; print "\t@echo \'Do not do \"make clean\" until you are sure that everything went well!\'\n"; print "\t@echo \'If there were a problem, execute \"for file in $$(find . -name \\*.v.old -print); do mv $${file} $${file%.old}; done\" in your shell/'\n\n" end let all_target (vfiles, (_,_,_,_,mlpackfiles as mlfiles), sps, sds) inc = let special_targets = List.filter (fun (n,_,_) -> not (is_genrule n)) sps in let other_targets = List.map (function x,_,_ -> x) special_targets @ sds in main_targets vfiles mlfiles other_targets inc; print ".PHONY: "; print_list " " ("all" :: "opt" :: "byte" :: "archclean" :: "clean" :: "install" :: "userinstall" :: "depend" :: "html" :: "validate" :: sds); print "\n\n"; custom sps; subdirs sds; forpacks mlpackfiles let banner () = print (Printf.sprintf "############################################################################# ## v # The Coq Proof Assistant ## ## print x; print " ") l let command_line args = print "#\n# This Makefile was generated by the command line :\n"; print "# coq_makefile "; print_list args; print "\n#\n\n" let ensure_root_dir (v,(mli,ml4,ml,mllib,mlpack),_,_) ((i_inc,r_inc) as l) = let here = Sys.getcwd () in let not_tops =List.for_all (fun s -> s <> Filename.basename s) in if List.exists (fun (_,x) -> x = here) i_inc or List.exists (fun (_,_,x) -> is_prefix x here) r_inc or (not_tops v && not_tops mli && not_tops ml4 && not_tops ml && not_tops mllib && not_tops mlpack) then l else ((".",here)::i_inc,r_inc) let warn_install_at_root_directory (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,_) (inc_i,inc_r) = let inc_r_top = List.filter (fun (_,ldir,_) -> ldir = "") inc_r in let inc_top = List.map (fun (p,_,_) -> p) inc_r_top in let files = vfiles @ mlifiles @ ml4files @ mlfiles @ mllibfiles @ mlpackfiles in if inc_r = [] || List.exists (fun f -> List.mem (Filename.dirname f) inc_top) files then Printf.eprintf "Warning: install target will copy files at the first level of the coq contributions installation directory; option -R %sis recommended\n" (if inc_r_top = [] then "" else "with non trivial logical root ") let check_overlapping_include (_,inc_r) = let pwd = Sys.getcwd () in let rec aux = function | [] -> () | (pdir,_,abspdir)::l -> if not (is_prefix pwd abspdir) then Printf.eprintf "Warning: in option -R, %s is not a subdirectory of the current directory\n" pdir; List.iter (fun (pdir',_,abspdir') -> if is_prefix abspdir abspdir' or is_prefix abspdir' abspdir then Printf.eprintf "Warning: in options -R, %s and %s overlap\n" pdir pdir') l; in aux inc_r let do_makefile args = let has_file var = function |[] -> var := false |_::_ -> var := true in let (project_file,makefile,is_install,opt),l = try Project_file.process_cmd_line Filename.current_dir_name (None,None,Project_file.UnspecInstall,true) [] args with Project_file.Parsing_error -> usage () in let (v_f,(mli_f,ml4_f,ml_f,mllib_f,mlpack_f),sps,sds as targets), inc, defs = Project_file.split_arguments l in let () = match project_file with |None -> () |Some f -> make_name := f in let () = match makefile with |None -> () |Some f -> makefile_name := f; output_channel := open_out f in has_file some_vfile v_f; has_file some_mlifile mli_f; has_file some_mlfile ml_f; has_file some_ml4file ml4_f; has_file some_mllibfile mllib_f; has_file some_mlpackfile mlpack_f; let check_dep f = if Filename.check_suffix f ".v" then some_vfile := true else if (Filename.check_suffix f ".mli") then some_mlifile := true else if (Filename.check_suffix f ".ml4") then some_ml4file := true else if (Filename.check_suffix f ".ml") then some_mlfile := true else if (Filename.check_suffix f ".mllib") then some_mllibfile := true else if (Filename.check_suffix f ".mlpack") then some_mlpackfile := true in List.iter (fun (_,dependencies,_) -> List.iter check_dep (Str.split (Str.regexp "[ \t]+") dependencies)) sps; let inc = ensure_root_dir targets inc in if is_install <> Project_file.NoInstall then warn_install_at_root_directory targets inc; check_overlapping_include inc; banner (); header_includes (); warning (); command_line args; parameters (); include_dirs inc; variables is_install opt defs; all_target targets inc; section "Special targets."; standard opt; install targets inc is_install; clean sds sps; make_makefile sds; implicit (); warning (); if not (makefile = None) then close_out !output_channel; exit 0 let main () = let args = if Array.length Sys.argv = 1 then usage (); List.tl (Array.to_list Sys.argv) in do_makefile args let _ = Printexc.catch main () coq-8.4pl4/tools/gallina.ml0000644000175000017500000000350512326224777014737 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* begin flush !chan_out; close_in chan_in; if not !option_stdout then close_out !chan_out end with Sys_error _ -> () let traite_stdin () = try let buf = Lexing.from_channel stdin in try while true do Gallina_lexer.action buf done with Fin_fichier -> flush !chan_out with Sys_error _ -> () let gallina () = let lg_command = Array.length Sys.argv in if lg_command < 2 then begin output_string stderr "Usage: gallina [-] [-stdout] file1 file2 ...\n"; flush stderr; exit 1 end; let treat = function | "-" -> option_moins := true | "-stdout" -> option_stdout := true | "-nocomments" -> comments := false | f -> if Filename.check_suffix f ".v" then vfiles := (Filename.chop_suffix f ".v") :: !vfiles in Array.iter treat Sys.argv; if !option_moins then traite_stdin () else List.iter traite_fichier !vfiles let _ = Printexc.catch gallina () coq-8.4pl4/tools/mingwpath.ml0000644000175000017500000000053312326224777015324 0ustar stephsteph(** Mingwpath *) (** Converts mingw-encoded filenames such as: /c/Program Files/Ocaml/bin to a more windows-friendly form (but still with / instead of \) : c:/Program Files/Ocaml/bin This nice hack was suggested by Benjamin Monate (cf bug #2526) to mimic the cygwin-specific tool cygpath *) print_string Sys.argv.(1) coq-8.4pl4/tools/README.coq-tex0000755000175000017500000000057412326224777015243 0ustar stephstephDESCRIPTION. The coq-tex filter extracts Coq phrases embedded in LaTeX files, evaluates them, and insert the outcome of the evaluation after each phrase. The filter is written in Perl, so you'll need Perl version 4 installed on your machine. USAGE. See the manual page (coq-tex.1). AUTHOR. Jean-Christophe Filliatre (jcfillia@lip.ens-lyon.fr) from caml-tex of Xavier Leroy. coq-8.4pl4/tools/coqdep_common.ml0000644000175000017500000004124512326224777016156 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (f, "") | s :: _ when Filename.check_suffix f s -> (Filename.chop_suffix f s, s) | _ :: l -> get_extension f l (** [basename_noext] removes both the directory part and the extension (if necessary) of a filename *) let basename_noext filename = let fn = Filename.basename filename in try Filename.chop_extension fn with _ -> fn (** ML Files specified on the command line. In the entries: - the first string is the basename of the file, without extension nor directory part - the second string of [mlAccu] is the extension (either .ml or .ml4) - the [dir] part is the directory, with None used as the current directory *) let mlAccu = ref ([] : (string * string * dir) list) and mliAccu = ref ([] : (string * dir) list) and mllibAccu = ref ([] : (string * dir) list) and mlpackAccu = ref ([] : (string * dir) list) (** Coq files specifies on the command line: - first string is the full filename, with only its extension removed - second string is the absolute version of the previous (via getcwd) *) let vAccu = ref ([] : (string * string) list) (** Queue operations *) let addQueue q v = q := v :: !q let safe_hash_add clq q (k,v) = try let v2 = Hashtbl.find q k in if v<>v2 then let rec add_clash = function (k1,l1)::cltl when k=k1 -> (k1,v::l1)::cltl | cl::cltl -> cl::add_clash cltl | [] -> [(k,[v;v2])] in clq := add_clash !clq; (* overwrite previous bindings, as coqc does *) Hashtbl.add q k v with Not_found -> Hashtbl.add q k v (** Files found in the loadpaths. For the ML files, the string is the basename without extension. To allow ML source filename to be potentially capitalized, we perform a double search. *) let mkknown () = let h = (Hashtbl.create 19 : (string, dir) Hashtbl.t) in let add x s = if Hashtbl.mem h x then () else Hashtbl.add h x s and iter f = Hashtbl.iter f h and search x = try Some (Hashtbl.find h (String.uncapitalize x)) with Not_found -> try Some (Hashtbl.find h (String.capitalize x)) with Not_found -> None in add, iter, search let add_ml_known, iter_ml_known, search_ml_known = mkknown () let add_mli_known, iter_mli_known, search_mli_known = mkknown () let add_mllib_known, _, search_mllib_known = mkknown () let add_mlpack_known, _, search_mlpack_known = mkknown () let vKnown = (Hashtbl.create 19 : (string list, string) Hashtbl.t) let coqlibKnown = (Hashtbl.create 19 : (string list, unit) Hashtbl.t) let clash_v = ref ([]: (string list * string list) list) let error_cannot_parse s (i,j) = Printf.eprintf "File \"%s\", characters %i-%i: Syntax error\n" s i j; exit 1 let warning_module_notfound f s = eprintf "*** Warning: in file %s, library " f; eprintf "%s.v is required and has not been found in loadpath!\n" (String.concat "." s); flush stderr let warning_notfound f s = eprintf "*** Warning: in file %s, the file " f; eprintf "%s.v is required and has not been found!\n" s; flush stderr let warning_declare f s = eprintf "*** Warning: in file %s, declared ML module " f; eprintf "%s has not been found!\n" s; flush stderr let warning_clash file dir = match List.assoc dir !clash_v with (f1::f2::fl) -> let f = Filename.basename f1 in let d1 = Filename.dirname f1 in let d2 = Filename.dirname f2 in let dl = List.map Filename.dirname (List.rev fl) in eprintf "*** Warning: in file %s, \n required library %s matches several files in path\n (found %s.v in " file (String.concat "." dir) f; List.iter (fun s -> eprintf "%s, " s) dl; eprintf "%s and %s; used the latter)\n" d2 d1 | _ -> assert false let safe_assoc verbose file k = if verbose && List.mem_assoc k !clash_v then warning_clash file k; Hashtbl.find vKnown k let absolute_dir dir = let current = Sys.getcwd () in Sys.chdir dir; let dir' = Sys.getcwd () in Sys.chdir current; dir' let absolute_file_name basename odir = let dir = match odir with Some dir -> dir | None -> "." in absolute_dir dir // basename let file_name s = function | None -> s | Some "." -> s | Some d -> d // s let depend_ML str = match search_mli_known str, search_ml_known str with | Some mlidir, Some mldir -> let mlifile = file_name str mlidir and mlfile = file_name str mldir in (" "^mlifile^".cmi"," "^mlfile^".cmx") | None, Some mldir -> let mlfile = file_name str mldir in (" "^mlfile^".cmo"," "^mlfile^".cmx") | Some mlidir, None -> let mlifile = file_name str mlidir in (" "^mlifile^".cmi"," "^mlifile^".cmi") | None, None -> "", "" let soustraite_fichier_ML dep md ext = try let chan = open_process_in (dep^" -modules "^md^ext) in let list = ocamldep_parse (Lexing.from_channel chan) in let a_faire = ref "" in let a_faire_opt = ref "" in List.iter (fun str -> let byte,opt = depend_ML str in a_faire := !a_faire ^ byte; a_faire_opt := !a_faire_opt ^ opt) (List.rev list); (!a_faire, !a_faire_opt) with | Sys_error _ -> ("","") | _ -> Printf.eprintf "Coqdep: subprocess %s failed on file %s%s\n" dep md ext; exit 1 let autotraite_fichier_ML md ext = try let chan = open_in (md ^ ext) in let buf = Lexing.from_channel chan in let deja_vu = ref [md] in let a_faire = ref "" in let a_faire_opt = ref "" in begin try while true do let (Use_module str) = caml_action buf in if List.mem str !deja_vu then () else begin addQueue deja_vu str; let byte,opt = depend_ML str in a_faire := !a_faire ^ byte; a_faire_opt := !a_faire_opt ^ opt end done with Fin_fichier -> () end; close_in chan; (!a_faire, !a_faire_opt) with Sys_error _ -> ("","") let traite_fichier_ML md ext = match !option_mldep with | Some dep -> soustraite_fichier_ML dep md ext | None -> autotraite_fichier_ML md ext let traite_fichier_modules md ext = try let chan = open_in (md ^ ext) in let list = mllib_list (Lexing.from_channel chan) in List.fold_left (fun a_faire str -> match search_mlpack_known str with | Some mldir -> let file = file_name str mldir in a_faire^" "^file | None -> match search_ml_known str with | Some mldir -> let file = file_name str mldir in a_faire^" "^file | None -> a_faire) "" list with | Sys_error _ -> "" | Syntax_error (i,j) -> error_cannot_parse (md^ext) (i,j) (* Makefile's escaping rules are awful: $ is escaped by doubling and other special characters are escaped by backslash prefixing while backslashes themselves must be escaped only if part of a sequence followed by a special character (i.e. in case of ambiguity with a use of it as escaping character). Moreover (even if not crucial) it is apparently not possible to directly escape ';' and leading '\t'. *) let escape = let s' = Buffer.create 10 in fun s -> Buffer.clear s'; for i = 0 to String.length s - 1 do let c = s.[i] in if c = ' ' or c = '#' or c = ':' (* separators and comments *) or c = '%' (* pattern *) or c = '?' or c = '[' or c = ']' or c = '*' (* expansion in filenames *) or i=0 && c = '~' && (String.length s = 1 || s.[1] = '/' || 'A' <= s.[1] && s.[1] <= 'Z' || 'a' <= s.[1] && s.[1] <= 'z') (* homedir expansion *) then begin let j = ref (i-1) in while !j >= 0 && s.[!j] = '\\' do Buffer.add_char s' '\\'; decr j (* escape all preceding '\' *) done; Buffer.add_char s' '\\'; end; if c = '$' then Buffer.add_char s' '$'; Buffer.add_char s' c done; Buffer.contents s' let canonize f = let f' = absolute_dir (Filename.dirname f) // Filename.basename f in match List.filter (fun (_,full) -> f' = full) !vAccu with | (f,_) :: _ -> escape f | _ -> escape f let rec traite_fichier_Coq verbose f = try let chan = open_in f in let buf = Lexing.from_channel chan in let deja_vu_v = ref ([]: string list list) and deja_vu_ml = ref ([] : string list) in try while true do let tok = coq_action buf in match tok with | Require strl -> List.iter (fun str -> if not (List.mem str !deja_vu_v) then begin addQueue deja_vu_v str; try let file_str = safe_assoc verbose f str in printf " %s%s" (canonize file_str) !suffixe with Not_found -> if verbose && not (Hashtbl.mem coqlibKnown str) then warning_module_notfound f str end) strl | RequireString s -> let str = Filename.basename s in if not (List.mem [str] !deja_vu_v) then begin addQueue deja_vu_v [str]; try let file_str = Hashtbl.find vKnown [str] in printf " %s%s" (canonize file_str) !suffixe with Not_found -> if not (Hashtbl.mem coqlibKnown [str]) then warning_notfound f s end | Declare sl -> let declare suff dir s = let base = file_name s dir in let opt = if !option_natdynlk then " "^base^".cmxs" else "" in printf " %s%s%s" (escape base) suff opt in let decl str = let s = basename_noext str in if not (List.mem s !deja_vu_ml) then begin addQueue deja_vu_ml s; match search_mllib_known s with | Some mldir -> declare ".cma" mldir s | None -> match search_mlpack_known s with | Some mldir -> declare ".cmo" mldir s | None -> match search_ml_known s with | Some mldir -> declare ".cmo" mldir s | None -> warning_declare f str end in List.iter decl sl | Load str -> let str = Filename.basename str in if not (List.mem [str] !deja_vu_v) then begin addQueue deja_vu_v [str]; try let file_str = Hashtbl.find vKnown [str] in let canon = canonize file_str in printf " %s.v" canon; traite_fichier_Coq true (canon ^ ".v") with Not_found -> () end | AddLoadPath _ | AddRecLoadPath _ -> (* TODO *) () done with Fin_fichier -> close_in chan | Syntax_error (i,j) -> close_in chan; error_cannot_parse f (i,j) with Sys_error _ -> () let mL_dependencies () = List.iter (fun (name,ext,dirname) -> let fullname = file_name name dirname in let (dep,dep_opt) = traite_fichier_ML fullname ext in let intf = match search_mli_known name with | None -> "" | Some mldir -> " "^(file_name name mldir)^".cmi" in let efullname = escape fullname in printf "%s.cmo:%s%s\n" efullname dep intf; printf "%s.cmx:%s%s\n" efullname dep_opt intf; flush stdout) (List.rev !mlAccu); List.iter (fun (name,dirname) -> let fullname = file_name name dirname in let (dep,_) = traite_fichier_ML fullname ".mli" in printf "%s.cmi:%s\n" (escape fullname) dep; flush stdout) (List.rev !mliAccu); List.iter (fun (name,dirname) -> let fullname = file_name name dirname in let dep = traite_fichier_modules fullname ".mllib" in let efullname = escape fullname in printf "%s_MLLIB_DEPENDENCIES:=%s\n" efullname dep; printf "%s.cma:$(addsuffix .cmo,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname; printf "%s.cmxa %s.cmxs:$(addsuffix .cmx,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname efullname; flush stdout) (List.rev !mllibAccu); List.iter (fun (name,dirname) -> let fullname = file_name name dirname in let dep = traite_fichier_modules fullname ".mlpack" in let efullname = escape fullname in printf "%s_MLPACK_DEPENDENCIES:=%s\n" efullname dep; printf "%s.cmo:$(addsuffix .cmo,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname; printf "%s.cmx %s.cmxs:$(addsuffix .cmx,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname efullname; flush stdout) (List.rev !mlpackAccu) let coq_dependencies () = List.iter (fun (name,_) -> let ename = escape name in let glob = if !option_noglob then "" else " "^ename^".glob" in printf "%s%s%s %s.v.beautified: %s.v" ename !suffixe glob ename ename; traite_fichier_Coq true (name ^ ".v"); printf "\n"; flush stdout) (List.rev !vAccu) let rec suffixes = function | [] -> assert false | [name] -> [[name]] | dir::suffix as l -> l::suffixes suffix let add_known phys_dir log_dir f = match get_extension f [".v";".ml";".mli";".ml4";".mllib";".mlpack"] with | (basename,".v") -> let name = log_dir@[basename] in let file = phys_dir//basename in let paths = suffixes name in List.iter (fun n -> safe_hash_add clash_v vKnown (n,file)) paths | (basename,(".ml"|".ml4")) -> add_ml_known basename (Some phys_dir) | (basename,".mli") -> add_mli_known basename (Some phys_dir) | (basename,".mllib") -> add_mllib_known basename (Some phys_dir) | (basename,".mlpack") -> add_mlpack_known basename (Some phys_dir) | _ -> () (* Visits all the directories under [dir], including [dir], or just [dir] if [recur=false] *) let rec add_directory recur add_file phys_dir log_dir = let dirh = opendir phys_dir in try while true do let f = readdir dirh in (* we avoid all files and subdirs starting by '.' (e.g. .svn), plus CVS and _darcs and any subdirs given via -exclude-dirs *) if f.[0] <> '.' then let phys_f = if phys_dir = "." then f else phys_dir//f in match try (stat phys_f).st_kind with _ -> S_BLK with | S_DIR when recur -> if List.mem f !norec_dirnames then () else if List.mem phys_f !norec_dirs then () else add_directory recur add_file phys_f (log_dir@[f]) | S_REG -> add_file phys_dir log_dir f | _ -> () done with End_of_file -> closedir dirh let add_dir add_file phys_dir log_dir = try add_directory false add_file phys_dir log_dir with Unix_error _ -> () let add_rec_dir add_file phys_dir log_dir = handle_unix_error (add_directory true add_file phys_dir) log_dir let rec treat_file old_dirname old_name = let name = Filename.basename old_name and new_dirname = Filename.dirname old_name in let dirname = match (old_dirname,new_dirname) with | (d, ".") -> d | (None,d) -> Some d | (Some d1,d2) -> Some (d1//d2) in let complete_name = file_name name dirname in match try (stat complete_name).st_kind with _ -> S_BLK with | S_DIR -> (if name.[0] <> '.' then let dir=opendir complete_name in let newdirname = match dirname with | None -> name | Some d -> d//name in try while true do treat_file (Some newdirname) (readdir dir) done with End_of_file -> closedir dir) | S_REG -> (match get_extension name [".v";".ml";".mli";".ml4";".mllib";".mlpack"] with | (base,".v") -> let name = file_name base dirname and absname = absolute_file_name base dirname in addQueue vAccu (name, absname) | (base,(".ml"|".ml4" as ext)) -> addQueue mlAccu (base,ext,dirname) | (base,".mli") -> addQueue mliAccu (base,dirname) | (base,".mllib") -> addQueue mllibAccu (base,dirname) | (base,".mlpack") -> addQueue mlpackAccu (base,dirname) | _ -> ()) | _ -> () coq-8.4pl4/tools/compat5b.ml0000644000175000017500000000125612326224777015043 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ;; coq-syntax.el,v 9.9 2008/07/21 15:14:58 pier Exp ;(require 'proof-syntax) ;(require 'proof-utils) ; proof-locate-executable (require 'coq-db) ;;; keyword databases (defcustom coq-user-tactics-db nil "User defined tactic information. See `coq-syntax-db' for syntax. It is not necessary to add your own tactics here (it is not needed by the synchronizing/backtracking system). You may however do so for the following reasons: 1 your tactics will be colorized by font-lock 2 your tactics will be added to the menu and to completion when calling \\[coq-insert-tactic] 3 you may define an abbreviation for your tactic." :type '(repeat sexp) :group 'coq) (defcustom coq-user-commands-db nil "User defined command information. See `coq-syntax-db' for syntax. It is not necessary to add your own commands here (it is not needed by the synchronizing/backtracking system). You may however do so for the following reasons: 1 your commands will be colorized by font-lock 2 your commands will be added to the menu and to completion when calling \\[coq-insert-command] 3 you may define an abbreviation for your command." :type '(repeat sexp) :group 'coq) (defcustom coq-user-tacticals-db nil "User defined tactical information. See `coq-syntax-db' for syntax. It is not necessary to add your own commands here (it is not needed by the synchronizing/backtracking system). You may however do so for the following reasons: 1 your commands will be colorized by font-lock 2 your commands will be added to the menu and to completion when calling \\[coq-insert-command] 3 you may define an abbreviation for your command." :type '(repeat sexp) :group 'coq) (defcustom coq-user-solve-tactics-db nil "User defined closing tactics. See `coq-syntax-db' for syntax. It is not necessary to add your own commands here (it is not needed by the synchronizing/backtracking system). You may however do so for the following reasons: 1 your commands will be colorized by font-lock 2 your commands will be added to the menu and to completion when calling \\[coq-insert-command] 3 you may define an abbreviation for your command." :type '(repeat sexp) :group 'coq) (defcustom coq-user-reserved-db nil "User defined reserved keywords information. See `coq-syntax-db' for syntax. It is not necessary to add your own commands here (it is not needed by the synchronizing/backtracking system). You may however do so for the following reasons: 1 your commands will be colorized by font-lock 2 your commands will be added to the menu and to completion when calling \\[coq-insert-command] 3 you may define an abbreviation for your command." :type '(repeat sexp) :group 'coq) (defvar coq-tactics-db (append coq-user-tactics-db '( ("absurd " "abs" "absurd " t "absurd") ("apply" "ap" "apply " t "apply") ("assert by" "assb" "assert ( # : # ) by #" t "assert") ("assert" "ass" "assert ( # : # )" t) ;; ("assumption" "as" "assumption" t "assumption") ("auto with arith" "awa" "auto with arith" t) ("auto with" "aw" "auto with @{db}" t) ("auto" "a" "auto" t "auto") ("autorewrite with in using" "arwiu" "autorewrite with @{db,db...} in @{hyp} using @{tac}" t) ("autorewrite with in" "arwi" "autorewrite with @{db,db...} in @{hyp}" t) ("autorewrite with using" "arwu" "autorewrite with @{db,db...} using @{tac}" t) ("autorewrite with" "ar" "autorewrite with @{db,db...}" t "autorewrite") ("case" "c" "case " t "case") ("cbv" "cbv" "cbv beta [#] delta iota zeta" t "cbv") ("change in" "chi" "change # in #" t) ("change with in" "chwi" "change # with # in #" t) ("change with" "chw" "change # with" t) ("change" "ch" "change " t "change") ("clear" "cl" "clear" t "clear") ("clearbody" "cl" "clearbody" t "clearbody") ("cofix" "cof" "cofix" t "cofix") ("coinduction" "coind" "coinduction" t "coinduction") ("compare" "cmpa" "compare # #" t "compare") ("compute" "cmpu" "compute" t "compute") ;; ("congruence" "cong" "congruence" t "congruence") ("constructor" "cons" "constructor" t "constructor") ;; ("contradiction" "contr" "contradiction" t "contradiction") ("cut" "cut" "cut" t "cut") ("cutrewrite" "cutr" "cutrewrite -> # = #" t "cutrewrite") ;; ("decide equality" "deg" "decide equality" t "decide\\s-+equality") ("decompose record" "decr" "decompose record #" t "decompose\\s-+record") ("decompose sum" "decs" "decompose sum #" t "decompose\\s-+sum") ("decompose" "dec" "decompose [#] #" t "decompose") ("dependent inversion" "depinv" "dependent inversion" t "dependent\\s-+inversion") ("dependent inversion with" "depinvw" "dependent inversion # with #" t) ("dependent inversion_clear" "depinvc" "dependent inversion_clear" t "dependent\\s-+inversion_clear") ("dependent inversion_clear with" "depinvw" "dependent inversion_clear # with #" t) ("dependent rewrite ->" "depr" "dependent rewrite -> @{id}" t "dependent\\s-+rewrite") ("dependent rewrite <-" "depr<" "dependent rewrite <- @{id}" t) ("destruct as" "desa" "destruct # as #" t) ("destruct using" "desu" "destruct # using #" t) ("destruct" "des" "destruct " t "destruct") ;; ("discriminate" "dis" "discriminate" t "discriminate") ("discrR" "discrR" "discrR" t "discrR") ("double induction" "dind" "double induction # #" t "double\\s-+induction") ("eapply" "eap" "eapply #" t "eapply") ("eauto with arith" "eawa" "eauto with arith" t) ("eauto with" "eaw" "eauto with @{db}" t) ("eauto" "ea" "eauto" t "eauto") ("econstructor" "econs" "econstructor" t "econstructor") ("eexists" "eex" "eexists" t "eexists") ("eleft" "eleft" "eleft" t "eleft") ("elim using" "elu" "elim # using #" t) ("elim" "e" "elim #" t "elim") ("elimtype" "elt" "elimtype" "elimtype") ("eright" "erig" "eright" "eright") ("esplit" "esp" "esplit" t "esplit") ;; ("exact" "exa" "exact" t "exact") ("exists" "ex" "exists #" t "exists") ;; ("fail" "fa" "fail" nil) ;; ("field" "field" "field" t "field") ("firstorder" "fsto" "firstorder" t "firstorder") ("firstorder with" "fsto" "firstorder with #" t) ("firstorder with using" "fsto" "firstorder # with #" t) ("fold" "fold" "fold #" t "fold") ;; ("fourier" "four" "fourier" t "fourier") ("functional induction" "fi" "functional induction @{f} @{args}" t "functional\\s-+induction") ("generalize dependent" "gd" "generalize dependent #" t "generalize\\s-+dependent") ("generalize" "g" "generalize #" t "generalize") ("hnf" "hnf" "hnf" t "hnf") ("idtac" "id" "idtac" nil "idtac") ; also in tacticals with abbrev id ("idtac \"" "id\"" "idtac \"#\"") ; also in tacticals ("induction" "ind" "induction #" t "induction") ("induction using" "indu" "induction # using #" t) ("injection" "inj" "injection #" t "injection") ("instantiate" "inst" "instantiate" t "instantiate") ("intro" "i" "intro" t "intro") ("intro after" "ia" "intro # after #" t) ("intros" "is" "intros #" t "intros") ("intros! (guess names)" nil "intros #" nil nil coq-insert-intros) ("intros until" "isu" "intros until #" t) ("intuition" "intu" "intuition #" t "intuition") ("inversion" "inv" "inversion #" t "inversion") ("inversion in" "invi" "inversion # in #" t) ("inversion using" "invu" "inversion # using #" t) ("inversion using in" "invui" "inversion # using # in #" t) ("inversion_clear" "invcl" "inversion_clear" t "inversion_clear") ("lapply" "lap" "lapply" t "lapply") ("lazy" "lazy" "lazy beta [#] delta iota zeta" t "lazy") ("left" "left" "left" t "left") ("linear" "lin" "linear" t "linear") ("load" "load" "load" t "load") ("move after" "mov" "move # after #" t "move") ("omega" "o" "omega" t "omega") ("pattern" "pat" "pattern" t "pattern") ("pattern(s)" "pats" "pattern # , #" t) ("pattern at" "pata" "pattern # at #" t) ("pose" "po" "pose ( # := # )" t "pose") ("prolog" "prol" "prolog" t "prolog") ("quote" "quote" "quote" t "quote") ("quote []" "quote2" "quote # [#]" t) ("red" "red" "red" t "red") ("refine" "ref" "refine" t "refine") ;; ("reflexivity" "refl" "reflexivity #" t "reflexivity") ("rename into" "ren" "rename # into #" t "rename") ("replace with" "rep" "replace # with #" t "replace") ("replace with in" "repi" "replace # with # in #" t) ("rewrite <- in" "ri<" "rewrite <- # in #" t) ("rewrite <-" "r<" "rewrite <- #" t) ("rewrite in" "ri" "rewrite # in #" t) ("rewrite" "r" "rewrite #" t "rewrite") ("right" "rig" "right" t "right") ;; ("ring" "ring" "ring #" t "ring") ("set in * |-" "seth" "set ( # := #) in * |-" t) ("set in *" "set*" "set ( # := #) in *" t) ("set in |- *" "setg" "set ( # := #) in |- *" t) ("set in" "seti" "set ( # := #) in #" t) ("set" "set" "set ( # := #)" t "set") ("setoid_replace with" "strep2" "setoid_replace # with #" t "setoid_replace") ("setoid replace with" "strep" "setoid replace # with #" t "setoid\\s-+replace") ("setoid_rewrite" "strew" "setoid_rewrite #" t "setoid_rewrite") ("setoid rewrite" "strew" "setoid rewrite #" t "setoid\\s-+rewrite") ("simpl" "s" "simpl" t "simpl") ("simpl" "sa" "simpl # at #" t) ("simple destruct" "sdes" "simple destruct" t "simple\\s-+destruct") ("simple inversion" "sinv" "simple inversion" t "simple\\s-+inversion") ("simple induction" "sind" "simple induction" t "simple\\s-+induction") ("simplify_eq" "simeq" "simplify_eq @{hyp}" t "simplify_eq") ("specialize" "spec" "specialize" t "specialize") ("split" "sp" "split" t "split") ("split_Rabs" "spra" "splitRabs" t "split_Rabs") ("split_Rmult" "sprm" "splitRmult" t "split_Rmult") ("stepl" "stl" "stepl #" t "stepl") ("stepl by" "stlb" "stepl # by #" t) ("stepr" "str" "stepr #" t "stepr") ("stepr by" "strb" "stepr # by #" t) ("subst" "su" "subst #" t "subst") ("symmetry" "sy" "symmetry" t "symmetry") ("symmetry in" "syi" "symmetry in #" t) ;; ("tauto" "ta" "tauto" t "tauto") ("transitivity" "trans" "transitivity #" t "transitivity") ("trivial" "t" "trivial" t "trivial") ("trivial with" "tw" "trivial with @{db}" t) ("unfold" "u" "unfold #" t "unfold") ("unfold(s)" "us" "unfold # , #" t) ("unfold in" "unfi" "unfold # in #" t) ("unfold at" "unfa" "unfold # at #" t) )) "Coq tactics information list. See `coq-syntax-db' for syntax. " ) (defvar coq-solve-tactics-db (append coq-user-solve-tactics-db '( ("assumption" "as" "assumption" t "assumption") ("by" "by" "by #" t "by") ("congruence" "cong" "congruence" t "congruence") ("contradiction" "contr" "contradiction" t "contradiction") ("decide equality" "deg" "decide equality" t "decide\\s-+equality") ("discriminate" "dis" "discriminate" t "discriminate") ("exact" "exa" "exact" t "exact") ("fourier" "four" "fourier" t "fourier") ("fail" "fa" "fail" nil) ("field" "field" "field" t "field") ("omega" "o" "omega" t "omega") ("reflexivity" "refl" "reflexivity #" t "reflexivity") ("ring" "ring" "ring #" t "ring") ("solve" nil "solve [ # | # ]" nil "solve") ("tauto" "ta" "tauto" t "tauto") )) "Coq tactic(al)s that solve a subgoal." ) (defvar coq-tacticals-db (append coq-user-tacticals-db '( ("info" nil "info #" nil "info") ("first" nil "first [ # | # ]" nil "first") ("abstract" nil "abstract @{tac} using @{name}." nil "abstract") ("do" nil "do @{num} @{tac}" nil "do") ("idtac" nil "idtac") ; also in tactics ; ("idtac \"" nil "idtac \"#\"") ; also in tactics ("fail" "fa" "fail" nil "fail") ; ("fail \"" "fa\"" "fail" nil) ; ; ("orelse" nil "orelse #" t "orelse") ("repeat" nil "repeat #" nil "repeat") ("try" nil "try #" nil "try") ("progress" nil "progress #" nil "progress") ("|" nil "[ # | # ]" nil) ("||" nil "# || #" nil) )) "Coq tacticals information list. See `coq-syntax-db' for syntax.") (defvar coq-decl-db '( ("Axiom" "ax" "Axiom # : #" t "Axiom") ("Hint Constructors" "hc" "Hint Constructors # : #." t "Hint\\s-+Constructors") ("Hint Extern" "he" "Hint Extern @{cost} @{pat} => @{tac} : @{db}." t "Hint\\s-+Extern") ("Hint Immediate" "hi" "Hint Immediate # : @{db}." t "Hint\\s-+Immediate") ("Hint Resolve" "hr" "Hint Resolve # : @{db}." t "Hint\\s-+Resolve") ("Hint Rewrite ->" "hrw" "Hint Rewrite -> @{t1,t2...} using @{tac} : @{db}." t "Hint\\s-+Rewrite") ("Hint Rewrite <-" "hrw" "Hint Rewrite <- @{t1,t2...} using @{tac} : @{db}." t ) ("Hint Unfold" "hu" "Hint Unfold # : #." t "Hint\\s-+Unfold") ("Hypothesis" "hyp" "Hypothesis #: #" t "Hypothesis") ("Hypotheses" "hyp" "Hypotheses #: #" t "Hypotheses") ("Parameter" "par" "Parameter #: #" t "Parameter") ("Parameters" "par" "Parameter #: #" t "Parameters") ("Conjecture" "conj" "Conjecture #: #." t "Conjecture") ("Variable" "v" "Variable #: #." t "Variable") ("Variables" "vs" "Variables # , #: #." t "Variables") ("Coercion" "coerc" "Coercion @{id} : @{typ1} >-> @{typ2}." t "Coercion") ) "Coq declaration keywords information list. See `coq-syntax-db' for syntax." ) (defvar coq-defn-db '( ("CoFixpoint" "cfix" "CoFixpoint # (#:#) : # :=\n#." t "CoFixpoint") ("CoInductive" "coindv" "CoInductive # : # :=\n|# : #." t "CoInductive") ("Declare Module : :=" "dm" "Declare Module # : # := #." t "Declare\\s-+Module") ("Declare Module <: :=" "dm2" "Declare Module # <: # := #." t);; careful ("Declare Module Import : :=" "dmi" "Declare Module # : # := #." t) ("Declare Module Import <: :=" "dmi2" "Declare Module # <: # := #." t);; careful ("Declare Module Export : :=" "dme" "Declare Module # : # := #." t) ("Declare Module Export <: :=" "dme2" "Declare Module # <: # := #." t);; careful ("Definition" "def" "Definition #:# := #." t "Definition");; careful ("Definition (2 args)" "def2" "Definition # (# : #) (# : #):# := #." t) ("Definition (3 args)" "def3" "Definition # (# : #) (# : #) (# : #):# := #." t) ("Definition (4 args)" "def4" "Definition # (# : #) (# : #) (# : #) (# : #):# := #." t) ("Program Definition" "pdef" "Program Definition #:# := #." t "Program\\s-+Definition");; careful ? ("Program Definition (2 args)" "pdef2" "Program Definition # (# : #) (# : #):# := #." t) ("Program Definition (3 args)" "pdef3" "Program Definition # (# : #) (# : #) (# : #):# := #." t) ("Program Definition (4 args)" "pdef4" "Program Definition # (# : #) (# : #) (# : #) (# : #):# := #." t) ("Derive Inversion" nil "Derive Inversion @{id} with # Sort #." t "Derive\\s-+Inversion") ("Derive Dependent Inversion" nil "Derive Dependent Inversion @{id} with # Sort #." t "Derive\\s-+Dependent\\s-+Inversion") ("Derive Inversion_clear" nil "Derive Inversion_clear @{id} with # Sort #." t) ("Fixpoint" "fix" "Fixpoint # (#:#) {struct @{arg}} : # :=\n#." t "Fixpoint") ("Program Fixpoint" "pfix" "Program Fixpoint # (#:#) {struct @{arg}} : # :=\n#." t "Program\\s-+Fixpoint") ("Program Fixpoint measure" "pfixm" "Program Fixpoint # (#:#) {measure @{arg} @{f}} : # :=\n#." t) ("Program Fixpoint wf" "pfixwf" "Program Fixpoint # (#:#) {wf @{arg} @{f}} : # :=\n#." t) ("Function" "func" "Function # (#:#) {struct @{arg}} : # :=\n#." t "Function") ("Function measure" "funcm" "Function # (#:#) {measure @{f} @{arg}} : # :=\n#." t) ("Function wf" "func wf" "Function # (#:#) {wf @{R} @{arg}} : # :=\n#." t) ("Functional Scheme with" "fsw" "Functional Scheme @{name} := Induction for @{fun} with @{mutfuns}." t ) ("Functional Scheme" "fs" "Functional Scheme @{name} := Induction for @{fun}." t "Functional\\s-+Scheme") ("Inductive" "indv" "Inductive # : # := # : #." t "Inductive") ("Inductive (2 args)" "indv2" "Inductive # : # :=\n| # : #\n| # : #." t ) ("Inductive (3 args)" "indv3" "Inductive # : # :=\n| # : #\n| # : #\n| # : #." t ) ("Inductive (4 args)" "indv4" "Inductive # : # :=\n| # : #\n| # : #\n| # : #\n| # : #." t ) ("Inductive (5 args)" "indv5" "Inductive # : # :=\n| # : #\n| # : #\n| # : #\n| # : #\n| # : #." t ) ("Let" "Let" "Let # : # := #." t "Let") ("Ltac" "ltac" "Ltac # := #" t "Ltac") ("Module :=" "mo" "Module # : # := #." t ) ; careful ("Module <: :=" "mo2" "Module # <: # := #." t ) ; careful ("Module Import :=" "moi" "Module Import # : # := #." t ) ; careful ("Module Import <: :=" "moi2" "Module Import # <: # := #." t ) ; careful ("Module Export :=" "moe" "Module Export # : # := #." t ) ; careful ("Module Export <: :=" "moe2" "Module Export# <: # := #." t ) ; careful ("Record" "rec" "Record # : # := {\n# : #;\n# : # }" t "Record") ("Scheme" "sc" "Scheme @{name} := #." t "Scheme") ("Scheme Induction" "sci" "Scheme @{name} := Induction for # Sort #." t) ("Scheme Minimality" "scm" "Scheme @{name} := Minimality for # Sort #." t) ("Structure" "str" "Structure # : # := {\n# : #;\n# : # }" t "Structure") ) "Coq definition keywords information list. See `coq-syntax-db' for syntax. " ) ;; modules and section are indented like goal starters (defvar coq-goal-starters-db '( ("Add Morphism" "addmor" "Add Morphism @{f} : @{id}" t "Add\\s-+Morphism") ("Chapter" "chp" "Chapter # : #." t "Chapter") ("Corollary" "cor" "Corollary # : #.\nProof.\n#\nQed." t "Corollary") ("Declare Module :" "dmi" "Declare Module # : #.\n#\nEnd #." t) ("Declare Module <:" "dmi2" "Declare Module # <: #.\n#\nEnd #." t) ("Definition goal" "defg" "Definition #:#.\n#\nSave." t);; careful ("Fact" "fct" "Fact # : #." t "Fact") ("Goal" nil "Goal #." t "Goal") ("Lemma" "l" "Lemma # : #.\nProof.\n#\nQed." t "Lemma") ("Program Lemma" "pl" "Program Lemma # : #.\nProof.\n#\nQed." t "Program\\s-+Lemma") ("Module! (interactive)" nil "Module # : #.\n#\nEnd #." nil nil coq-insert-section-or-module) ("Module Type" "mti" "Module Type #.\n#\nEnd #." t "Module\\s-+Type") ; careful ("Module :" "moi" "Module # : #.\n#\nEnd #." t "Module") ; careful ("Module <:" "moi2" "Module # <: #.\n#\nEnd #." t ) ; careful ("Remark" "rk" "Remark # : #.\n#\nQed." t "Remark") ("Section" "sec" "Section #." t "Section") ("Theorem" "th" "Theorem # : #.\n#\nQed." t "Theorem") ("Program Theorem" "pth" "Program Theorem # : #.\nProof.\n#\nQed." t "Program\\s-+Theorem") ("Obligation" "obl" "Obligation #.\n#\nQed." t "Obligation") ("Next Obligation" "nobl" "Next Obligation.\n#\nQed." t "Next Obligation") ) "Coq goal starters keywords information list. See `coq-syntax-db' for syntax. " ) ;; command that are not declarations, definition or goal starters (defvar coq-other-commands-db '( ;; ("Abort" nil "Abort." t "Abort" nil nil);don't appear in menu ("About" nil "About #." nil "About") ("Add" nil "Add #." nil "Add" nil t) ("Add Abstract Ring" nil "Add Abstract Ring #." t "Add\\s-+Abstract\\s-+Ring") ("Add Abstract Semi Ring" nil "Add Abstract Semi Ring #." t "Add\\s-+Abstract\\s-+Semi\\s-+Ring") ("Add Field" nil "Add Field #." t "Add\\s-+Field") ("Add LoadPath" nil "Add LoadPath #." nil "Add\\s-+LoadPath") ("Add ML Path" nil "Add ML Path #." nil "Add\\s-+ML\\s-+Path") ("Add Morphism" nil "Add Morphism #." t "Add\\s-+Morphism") ("Add Printing" nil "Add Printing #." t "Add\\s-+Printing") ("Add Printing Constructor" nil "Add Printing Constructor #." t "Add\\s-+Printing\\s-+Constructor") ("Add Printing If" nil "Add Printing If #." t "Add\\s-+Printing\\s-+If") ("Add Printing Let" nil "Add Printing Let #." t "Add\\s-+Printing\\s-+Let") ("Add Printing Record" nil "Add Printing Record #." t "Add\\s-+Printing\\s-+Record") ("Add Rec LoadPath" nil "Add Rec LoadPath #." nil "Add\\s-+Rec\\s-+LoadPath") ("Add Rec ML Path" nil "Add Rec ML Path #." nil "Add\\s-+Rec\\s-+ML\\s-+Path") ("Add Ring" nil "Add Ring #." t "Add\\s-+Ring") ("Add Semi Ring" nil "Add Semi Ring #." t "Add\\s-+Semi\\s-+Ring") ("Add Setoid" nil "Add Setoid #." t "Add\\s-+Setoid") ("Admit Obligations" "oblsadmit" "Admit Obligations." nil "Admit\\s-+Obligations") ("Arguments Scope" "argsc" "Arguments Scope @{id} [ @{_} ]" t "Arguments\\s-+Scope") ("Bind Scope" "bndsc" "Bind Scope @{scope} with @{type}" t "Bind\\s-+Scope") ("Canonical Structure" nil "Canonical Structure #." t "Canonical\\s-+Structure") ("Cd" nil "Cd #." nil "Cd") ("Check" nil "Check" nil "Check") ("Close Local Scope" "cllsc" "Close Local Scope #" t "Close\\s-+Local\\s-+Scope") ("Close Scope" "clsc" "Close Scope #" t "Close\\s-+Scope") ("Comments" nil "Comments #." nil "Comments") ("Delimit Scope" "delsc" "Delimit Scope @{scope} with @{id}." t "Delimit\\s-+Scope" ) ("Eval" nil "Eval #." nil "Eval") ("Export" nil "Export #." t "Export") ("Extract Constant" "extrc" "Extract Constant @{id} => \"@{id}\"." nil "Extract\\s-+Constant") ("Extract Inlined Constant" "extric" "Extract Inlined Constant @{id} => \"@{id}\"." nil "Extract\\s-+Inlined\\s-+Constant") ("Extract Inductive" "extri" "Extract Inductive @{id} => \"@{id}\" [\"@{id}\" \"@{id...}\"]." nil "Extract") ("Extraction" "extr" "Extraction @{id}." nil "Extraction") ("Extraction (in a file)" "extrf" "Extraction \"@{file}\" @{id}." nil) ("Extraction Inline" nil "Extraction Inline #." t "Extraction\\s-+Inline") ("Extraction NoInline" nil "Extraction NoInline #." t "Extraction\\s-+NoInline") ("Extraction Language" "extrlang" "Extraction Language #." t "Extraction\\s-+Language") ("Extraction Library" "extrl" "Extraction Library @{id}." nil "Extraction\\s-+Library") ("Focus" nil "Focus #." nil "Focus") ("Identity Coercion" nil "Identity Coercion #." t "Identity\\s-+Coercion") ("Implicit Arguments Off" nil "Implicit Arguments Off." t "Implicit\\s-+Arguments\\s-+Off") ("Implicit Arguments On" nil "Implicit Arguments On." t "Implicit\\s-+Arguments\\s-+On") ("Implicit Arguments" nil "Implicit Arguments # [#]." t "Implicit\\s-+Arguments") ("Import" nil "Import #." t "Import") ("Infix" "inf" "Infix \"#\" := # (at level #) : @{scope}." t "Infix") ("Inspect" nil "Inspect #." nil "Inspect") ("Locate" nil "Locate" nil "Locate") ("Locate File" nil "Locate File \"#\"." nil "Locate\\s-+File") ("Locate Library" nil "Locate Library #." nil "Locate\\s-+Library") ("Notation (assoc)" "notas" "Notation \"#\" := # (at level #, # associativity)." t) ("Notation (at assoc)" "notassc" "Notation \"#\" := # (at level #, # associativity) : @{scope}." t) ("Notation (at at scope)" "notasc" "Notation \"#\" := # (at level #, # at level #) : @{scope}." t) ("Notation (at at)" "nota" "Notation \"#\" := # (at level #, # at level #)." t) ("Notation (only parsing)" "notsp" "Notation # := # (only parsing)." t) ("Notation Local (only parsing)" "notslp" "Notation Local # := # (only parsing)." t) ("Notation Local" "notsl" "Notation Local # := #." t "Notation\\s-+Local") ("Notation (simple)" "nots" "Notation # := #." t "Notation") ("Opaque" nil "Opaque #." nil "Opaque") ("Obligations Tactic" nil "Obligations Tactic := #." t "Obligations\\s-+Tactic") ("Open Local Scope" "oplsc" "Open Local Scope #" t "Open\\s-+Local\\s-+Scope") ("Open Scope" "opsc" "Open Scope #" t "Open\\s-+Scope") ("Print Coercions" nil "Print Coercions." nil "Print\\s-+Coercions") ("Print Hint" nil "Print Hint." nil "Print\\s-+Hint" coq-PrintHint) ("Print" "p" "Print #." nil "Print") ("Qed" nil "Qed." nil "Qed") ("Pwd" nil "Pwd." nil "Pwd") ("Recursive Extraction" "recextr" "Recursive Extraction @{id}." nil "Recursive\\s-+Extraction") ("Recursive Extraction Library" "recextrl" "Recursive Extraction Library @{id}." nil "Recursive\\s-+Extraction\\s-+Library") ("Recursive Extraction Module" "recextrm" "Recursive Extraction Module @{id}." nil "Recursive\\s-+Extraction\\s-+Module") ("Remove LoadPath" nil "Remove LoadPath" nil "Remove\\s-+LoadPath") ("Remove LoadPath" nil "Remove LoadPath" nil "Remove\\s-+LoadPath") ("Remove Printing If" nil "Remove Printing If #." t "Remove\\s-+Printing\\s-+If") ("Remove Printing Let" nil "Remove Printing Let #." t "Remove\\s-+Printing\\s-+Let") ("Require Export" nil "Require Export #." t "Require\\s-+Export") ("Require Import" nil "Require Import #." t "Require\\s-+Import") ("Require" nil "Require #." t "Require") ("Reserved Notation" nil "Reserved Notation" nil "Reserved\\s-+Notation") ("Reset Extraction Inline" nil "Reset Extraction Inline." t "Reset\\s-+Extraction\\s-+Inline") ("Save" nil "Save." t "Save") ("Search" nil "Search #" nil "Search") ("SearchAbout" nil "SearchAbout #" nil "SearchAbout") ("SearchPattern" nil "SearchPattern #" nil "SearchPattern") ("SearchRewrite" nil "SearchRewrite #" nil "SearchRewrite") ("Set Extraction AutoInline" nil "Set Extraction AutoInline" t "Set\\s-+Extraction\\s-+AutoInline") ("Set Extraction Optimize" nil "Set Extraction Optimize" t "Set\\s-+Extraction\\s-+Optimize") ("Set Implicit Arguments" nil "Set Implicit Arguments" t "Set\\s-+Implicit\\s-+Arguments") ("Set Strict Implicit" nil "Set Strict Implicit" t "Set\\s-+Strict\\s-+Implicit") ("Set Printing Synth" nil "Set Printing Synth" t "Set\\s-+Printing\\s-+Synth") ("Set Printing Wildcard" nil "Set Printing Wildcard" t "Set\\s-+Printing\\s-+Wildcard") ("Set Printing All" "sprall" "Set Printing All" t "Set\\s-+Printing\\s-+All") ("Set Printing Records" nil "Set Printing Records" t "Set\\s-+Printing\\s-+Records") ("Set Hyps Limit" nil "Set Hyps Limit #." nil "Set\\s-+Hyps\\s-+Limit") ("Set Printing Coercions" nil "Set Printing Coercions." t "Set\\s-+Printing\\s-+Coercions") ("Set Printing Notations" "sprn" "Set Printing Notations" t "Set\\s-+Printing\\s-+Notations") ("Set Undo" nil "Set Undo #." nil "Set\\s-+Undo") ("Show" nil "Show #." nil "Show") ("Solve Obligations" "oblssolve" "Solve Obligations using #." nil "Solve\\s-+Obligations") ("Test" nil "Test" nil "Test" nil t) ("Test Printing Depth" nil "Test Printing Depth." nil "Test\\s-+Printing\\s-+Depth") ("Test Printing If" nil "Test Printing If #." nil "Test\\s-+Printing\\s-+If") ("Test Printing Let" nil "Test Printing Let #." nil "Test\\s-+Printing\\s-+Let") ("Test Printing Synth" nil "Test Printing Synth." nil "Test\\s-+Printing\\s-+Synth") ("Test Printing Width" nil "Test Printing Width." nil "Test\\s-+Printing\\s-+Width") ("Test Printing Wildcard" nil "Test Printing Wildcard." nil "Test\\s-+Printing\\s-+Wildcard") ("Transparent" nil "Transparent #." nil "Transparent") ("Unfocus" nil "Unfocus." nil "Unfocus") ("Unset Extraction AutoInline" nil "Unset Extraction AutoInline" t "Unset\\s-+Extraction\\s-+AutoInline") ("Unset Extraction Optimize" nil "Unset Extraction Optimize" t "Unset\\s-+Extraction\\s-+Optimize") ("Unset Implicit Arguments" nil "Unset Implicit Arguments" t "Unset\\s-+Implicit\\s-+Arguments") ("Unset Strict Implicit" nil "Unset Strict Implicit" t "Unset\\s-+Strict\\s-+Implicit") ("Unset Printing Synth" nil "Unset Printing Synth" t "Unset\\s-+Printing\\s-+Synth") ("Unset Printing Wildcard" nil "Unset Printing Wildcard" t "Unset\\s-+Printing\\s-+Wildcard") ("Unset Hyps Limit" nil "Unset Hyps Limit" nil "Unset\\s-+Hyps\\s-+Limit") ("Unset Printing All" "unsprall" "Unset Printing All" nil "Unset\\s-+Printing\\s-+All") ("Unset Printing Coercion" nil "Unset Printing Coercion #." t "Unset\\s-+Printing\\s-+Coercion") ("Unset Printing Coercions" nil "Unset Printing Coercions." nil "Unset\\s-+Printing\\s-+Coercions") ("Unset Printing Notations" "unsprn" "Unset Printing Notations" nil "Unset\\s-+Printing\\s-+Notations") ("Unset Undo" nil "Unset Undo." nil "Unset\\s-+Undo") ; ("print" "pr" "print #" "print") ) "Command that are not declarations, definition or goal starters." ) (defvar coq-commands-db (append coq-decl-db coq-defn-db coq-goal-starters-db coq-other-commands-db coq-user-commands-db) "Coq all commands keywords information list. See `coq-syntax-db' for syntax. " ) (defvar coq-terms-db '( ("fun (1 args)" "f" "fun #:# => #" nil "fun") ("fun (2 args)" "f2" "fun (#:#) (#:#) => #") ("fun (3 args)" "f3" "fun (#:#) (#:#) (#:#) => #") ("fun (4 args)" "f4" "fun (#:#) (#:#) (#:#) (#:#) => #") ("forall" "fo" "forall #:#,#" nil "forall") ("forall (2 args)" "fo2" "forall (#:#) (#:#), #") ("forall (3 args)" "fo3" "forall (#:#) (#:#) (#:#), #") ("forall (4 args)" "fo4" "forall (#:#) (#:#) (#:#) (#:#), #") ("if" "if" "if # then # else #" nil "if") ("let in" "li" "let # := # in #" nil "let") ("match! (from type)" nil "" nil "match" coq-insert-match) ("match with" "m" "match # with\n| # => #\nend") ("match with 2" "m2" "match # with\n| # => #\n| # => #\nend") ("match with 3" "m3" "match # with\n| # => #\n| # => #\n| # => #\nend") ("match with 4" "m4" "match # with\n| # => #\n| # => #\n| # => #\n| # => #\nend") ("match with 5" "m5" "match # with\n| # => #\n| # => #\n| # => #\n| # => #\n| # => #\nend") ) "Coq terms keywords information list. See `coq-syntax-db' for syntax. " ) ;;; Goals (and module/sections) starters detection ;; ----- keywords for font-lock. ;; FIXME da: this one function breaks the nice configuration of Proof General: ;; would like to have proof-goal-regexp instead. ;; Unfortunately Coq allows "Definition" and friends to perhaps have a goal, ;; so it appears more difficult than just a proof-goal-regexp setting. ;; Future improvement may simply to be allow a function value for ;; proof-goal-regexp. ;; FIXME Pierre: the right way IMHO here would be to set a span ;; property 'goalcommand when coq prompt says it (if the name of ;; current proof has changed). ;; excerpt of Jacek Chrzaszcz, implementer of the module system: sorry ;; for the french: ;;*) suivant les suggestions de Chritine, pas de mode preuve dans un type de ;; module (donc pas de Definition truc:machin. Lemma, Theorem ... ) ;; ;; *) la commande Module M [ ( : | <: ) MTYP ] [ := MEXPR ] est valable ;; uniquement hors d'un MT ;; - si :=MEXPR est absent, elle demarre un nouveau module interactif ;; - si :=MEXPR est present, elle definit un module ;; (la fonction vernac_define_module dans toplevel/vernacentries) ;; ;; *) la nouvelle commande Declare Module M [ ( : | <: ) MTYP ] [ := MEXPR ] ;; est valable uniquement dans un MT ;; - si :=MEXPR absent, :MTYP absent, elle demarre un nouveau module ;; interactif ;; - si (:=MEXPR absent, :MTYP present) ;; ou (:=MEXPR present, :MTYP absent) ;; elle declare un module. ;; (la fonction vernac_declare_module dans toplevel/vernacentries) (defun coq-count-match (regexp strg) "Count the number of (maximum, non overlapping) matching substring of STRG matching REGEXP. Empty match are counted once." (let ((nbmatch 0) (str strg)) (while (and (proof-string-match regexp str) (not (string-equal str ""))) (incf nbmatch) (if (= (match-end 0) 0) (setq str (substring str 1)) (setq str (substring str (match-end 0))))) nbmatch)) ;; This function is used for amalgamating a proof into a single ;; goal-save region (proof-goal-command-p used in ;; proof-done-advancing-save in generic/proof-script.el) for coq < ;; 8.0. It is the test when looking backward the start of the proof. ;; It is NOT used for coq > v8.1 ;; (coq-find-and-forget in coq.el uses state numbers, proof numbers and ;; lemma names given in the prompt) ;; compatibility with v8.0, will delete it some day (defun coq-goal-command-str-v80-p (str) "See `coq-goal-command-p'." (let* ((match (coq-count-match "\\" str)) (with (coq-count-match "\\" str)) (letwith (+ (coq-count-match "\\" str) (- with match))) (affect (coq-count-match ":=" str))) (and (proof-string-match coq-goal-command-regexp str) (not ; (and (proof-string-match "\\`\\(Local\\|Definition\\|Lemma\\|Module\\)\\>" str) (not (= letwith affect)))) (not (proof-string-match "\\`Declare\\s-+Module\\(\\w\\|\\s-\\|<\\)*:" str)) ) ) ) ;; Module and or section openings are detected syntactically. Module ;; *openings* are difficult to detect because there can be Module ;; ...with X := ... . So we need to count :='s to detect real openings. ;; TODO: have opened section/chapter in the prompt too, and get rid of ;; syntactical tests everywhere (defun coq-module-opening-p (str) "Decide whether STR is a module or section opening or not. Used by `coq-goal-command-p'" (let* ((match (coq-count-match "\\" str)) (with (coq-count-match "\\" str)) (letwith (+ (coq-count-match "\\" str) (- with match))) (affect (coq-count-match ":=" str))) (and (proof-string-match "\\`\\(Module\\)\\>" str) (= letwith affect)) )) (defun coq-section-command-p (str) (proof-string-match "\\`\\(Section\\|Chapter\\)\\>" str)) (defun coq-goal-command-str-v81-p (str) "Decide syntactically whether STR is a goal start or not. Use `coq-goal-command-p-v81' on a span instead if possible." (coq-goal-command-str-v80-p str) ) ;; This is the function that tests if a SPAN is a goal start. All it ;; has to do is look at the 'goalcmd attribute of the span. ;; It also looks if this is not a module start. ;; TODO: have also attributes 'modulecmd and 'sectioncmd. This needs ;; something in the coq prompt telling the name of all opened modules ;; (like for open goals), and use it to set goalcmd --> no more need ;; to look at Modules and section (actually indentation will still ;; need it) (defun coq-goal-command-p-v81 (span) "see `coq-goal-command-p'" (or (span-property span 'goalcmd) ;; module and section starts are detected here (let ((str (or (span-property span 'cmd) ""))) (or (coq-section-command-p str) (coq-module-opening-p str)) ))) ;; In coq > 8.1 This is used only for indentation. (defun coq-goal-command-str-p (str) "Decide whether argument is a goal or not. Use `coq-goal-command-p' on a span instead if posible." (cond (coq-version-is-V8-1 (coq-goal-command-str-v81-p str)) (coq-version-is-V8-0 (coq-goal-command-str-v80-p str)) (t (coq-goal-command-str-v80-p str));; this is temporary )) ;; This is used for backtracking (defun coq-goal-command-p (span) "Decide whether argument is a goal or not." (cond (coq-version-is-V8-1 (coq-goal-command-p-v81 span)) (coq-version-is-V8-0 (coq-goal-command-str-v80-p (span-property span 'cmd))) (t (coq-goal-command-str-v80-p (span-property span 'cmd)));; this is temporary )) (defvar coq-keywords-save-strict '("Defined" "Save" "Qed" "End" "Admitted" "Abort" )) (defvar coq-keywords-save (append coq-keywords-save-strict '("Proof")) ) (defun coq-save-command-p (span str) "Decide whether argument is a Save command or not" (or (proof-string-match coq-save-command-regexp-strict str) (and (proof-string-match "\\`Proof\\>" str) (not (proof-string-match "Proof\\s-*\\(\\.\\|\\\\)" str))) ) ) (defvar coq-keywords-kill-goal '("Abort")) ;; Following regexps are all state changing (defvar coq-keywords-state-changing-misc-commands (coq-build-regexp-list-from-db coq-commands-db 'filter-state-changing)) (defvar coq-keywords-goal (coq-build-regexp-list-from-db coq-goal-starters-db)) (defvar coq-keywords-decl (coq-build-regexp-list-from-db coq-decl-db)) (defvar coq-keywords-defn (coq-build-regexp-list-from-db coq-defn-db)) (defvar coq-keywords-state-changing-commands (append coq-keywords-state-changing-misc-commands coq-keywords-decl ; all state changing coq-keywords-defn ; idem coq-keywords-goal)) ; idem ;; (defvar coq-keywords-state-preserving-commands (coq-build-regexp-list-from-db coq-commands-db 'filter-state-preserving)) ;; concat this is faster that redoing coq-build-regexp-list-from-db on ;; whole commands-db (defvar coq-keywords-commands (append coq-keywords-state-changing-commands coq-keywords-state-preserving-commands) "All commands keyword.") (defvar coq-solve-tactics (coq-build-regexp-list-from-db coq-solve-tactics-db) "Keywords for closing tactic(al)s.") (defvar coq-tacticals (coq-build-regexp-list-from-db coq-tacticals-db) "Keywords for tacticals in a Coq script.") ;; From JF Monin: (defvar coq-reserved (append coq-user-reserved-db '( "False" "True" "after" "as" "cofix" "fix" "forall" "fun" "match" "return" "struct" "else" "end" "if" "in" "into" "let" "then" "using" "with" "beta" "delta" "iota" "zeta" "after" "until" "at" "Sort" "Time")) "Reserved keywords of Coq.") (defvar coq-state-changing-tactics (coq-build-regexp-list-from-db coq-tactics-db 'filter-state-changing)) (defvar coq-state-preserving-tactics (coq-build-regexp-list-from-db coq-tactics-db 'filter-state-preserving)) (defvar coq-tactics (append coq-state-changing-tactics coq-state-preserving-tactics)) (defvar coq-retractable-instruct (append coq-state-changing-tactics coq-keywords-state-changing-commands)) (defvar coq-non-retractable-instruct (append coq-state-preserving-tactics coq-keywords-state-preserving-commands)) (defvar coq-keywords (append coq-keywords-goal coq-keywords-save coq-keywords-decl coq-keywords-defn coq-keywords-commands) "All keywords in a Coq script.") (defvar coq-symbols '("|" "||" ":" ";" "," "(" ")" "[" "]" "{" "}" ":=" "=>" "->" ".") "Punctuation Symbols used by Coq.") ;; ----- regular expressions (defvar coq-error-regexp "^\\(Error:\\|Discarding pattern\\|Syntax error:\\|System Error:\\|User Error:\\|User error:\\|Anomaly[:.]\\|Toplevel input[,]\\)" "A regexp indicating that the Coq process has identified an error.") (defvar coq-id proof-id) (defvar coq-id-shy "\\(?:\\w\\(?:\\w\\|\\s_\\)*\\)") (defvar coq-ids (proof-ids coq-id " ")) (defun coq-first-abstr-regexp (paren end) (concat paren "\\s-*\\(" coq-ids "\\)\\s-*" end)) (defcustom coq-variable-highlight-enable t "Activates partial bound variable highlighting" :type 'boolean :group 'coq) (defvar coq-font-lock-terms (if coq-variable-highlight-enable (list ;; lambda binders (list (coq-first-abstr-regexp "\\" "\\(?:=>\\|:\\)") 1 'font-lock-variable-name-face) ;; forall binder (list (coq-first-abstr-regexp "\\" "\\(?:,\\|:\\)") 1 'font-lock-variable-name-face) ; (list "\\" ; (list 0 font-lock-type-face) ; (list (concat "[^ :]\\s-*\\(" coq-ids "\\)\\s-*") nil nil ; (list 0 font-lock-variable-name-face))) ;; parenthesized binders (list (coq-first-abstr-regexp "(" ":[ a-zA-Z]") 1 'font-lock-variable-name-face) )) "*Font-lock table for Coq terms.") ;; According to Coq, "Definition" is both a declaration and a goal. ;; It is understood here as being a goal. This is important for ;; recognizing global identifiers, see coq-global-p. (defconst coq-save-command-regexp-strict (proof-anchor-regexp (concat "\\(Time\\s-+\\|\\)\\(" (proof-ids-to-regexp coq-keywords-save-strict) "\\)"))) (defconst coq-save-command-regexp (proof-anchor-regexp (concat "\\(Time\\s-+\\|\\)\\(" (proof-ids-to-regexp coq-keywords-save) "\\)"))) (defconst coq-save-with-hole-regexp (concat "\\(Time\\s-+\\|\\)\\(" (proof-ids-to-regexp coq-keywords-save-strict) "\\)\\s-+\\(" coq-id "\\)\\s-*\\.")) (defconst coq-goal-command-regexp (proof-anchor-regexp (proof-ids-to-regexp coq-keywords-goal))) (defconst coq-goal-with-hole-regexp (concat "\\(" (proof-ids-to-regexp coq-keywords-goal) "\\)\\s-+\\(" coq-id "\\)\\s-*:?")) (defconst coq-decl-with-hole-regexp (concat "\\(" (proof-ids-to-regexp coq-keywords-decl) "\\)\\s-+\\(" coq-ids "\\)\\s-*:")) ;; (defconst coq-decl-with-hole-regexp ;; (if coq-variable-highlight-enable coq-decl-with-hole-regexp-1 'nil)) (defconst coq-defn-with-hole-regexp (concat "\\(" (proof-ids-to-regexp coq-keywords-defn) "\\)\\s-+\\(" coq-id "\\)")) ;; must match: ;; "with f x y :" (followed by = or not) ;; "with f x y (z:" (not followed by =) ;; BUT NOT: ;; "with f ... (x:=" ;; "match ... with .. => " (defconst coq-with-with-hole-regexp (concat "\\(with\\)\\s-+\\(" coq-id "\\)\\s-*\\([^=(.]*:\\|[^(]*(\\s-*" coq-id "\\s-*:[^=]\\)")) ;; marche aussi a peu pres ;; (concat "\\(with\\)\\s-+\\(" coq-id "\\)\\s-*\\([^(.]*:\\|.*)[^(.]*:=\\)")) ;;"\\\\|\\\\|\\" (defvar coq-font-lock-keywords-1 (append coq-font-lock-terms (list (cons (proof-ids-to-regexp coq-solve-tactics) 'coq-solve-tactics-face) (cons (proof-ids-to-regexp coq-keywords) 'font-lock-keyword-face) (cons (proof-ids-to-regexp coq-reserved) 'font-lock-type-face) (cons (proof-ids-to-regexp coq-tactics ) 'proof-tactics-name-face) (cons (proof-ids-to-regexp coq-tacticals) 'proof-tacticals-name-face) (cons (proof-ids-to-regexp (list "Set" "Type" "Prop")) 'font-lock-type-face) (cons "============================" 'font-lock-keyword-face) (cons "Subtree proved!" 'font-lock-keyword-face) (cons "subgoal [0-9]+ is:" 'font-lock-keyword-face) (list "^\\([^ \n]+\\) \\(is defined\\)" (list 2 'font-lock-keyword-face t) (list 1 'font-lock-function-name-face t)) (list coq-goal-with-hole-regexp 2 'font-lock-function-name-face)) (if coq-variable-highlight-enable (list (list coq-decl-with-hole-regexp 2 'font-lock-variable-name-face))) (list (list coq-defn-with-hole-regexp 2 'font-lock-function-name-face) (list coq-with-with-hole-regexp 2 'font-lock-function-name-face) (list coq-save-with-hole-regexp 2 'font-lock-function-name-face) ;; Remove spurious variable and function faces on commas. '(proof-zap-commas)))) (defvar coq-font-lock-keywords coq-font-lock-keywords-1) (defun coq-init-syntax-table () "Set appropriate values for syntax table in current buffer." (modify-syntax-entry ?\$ ".") (modify-syntax-entry ?\/ ".") (modify-syntax-entry ?\\ ".") (modify-syntax-entry ?+ ".") (modify-syntax-entry ?- ".") (modify-syntax-entry ?= ".") (modify-syntax-entry ?% ".") (modify-syntax-entry ?< ".") (modify-syntax-entry ?> ".") (modify-syntax-entry ?\& ".") (modify-syntax-entry ?_ "_") (modify-syntax-entry ?\' "_") (modify-syntax-entry ?\| ".") ;; should maybe be "_" but it makes coq-find-and-forget (in coq.el) bug (modify-syntax-entry ?\. ".") (condition-case nil ;; Try to use Emacs-21's nested comments. (modify-syntax-entry ?\* ". 23n") ;; Revert to non-nested comments if that failed. (error (modify-syntax-entry ?\* ". 23"))) (modify-syntax-entry ?\( "()1") (modify-syntax-entry ?\) ")(4")) (defconst coq-generic-expression (mapcar (lambda (kw) (list (capitalize kw) (concat "\\<" kw "\\>" "\\s-+\\(\\w+\\)\\W" ) 1)) (append coq-keywords-decl coq-keywords-defn coq-keywords-goal))) (provide 'coq-syntax) ;;; coq-syntax.el ends here ; Local Variables: *** ; indent-tabs-mode: nil *** ; End: *** coq-8.4pl4/tools/coq_tex.ml0000644000175000017500000002322012326224777014766 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* begin close_in chan_in; close_out chan_out end (* Second pass: insert the answers of Coq from [coq_output] into the * TeX file [texfile]. The result goes in file [result]. *) let begin_coq_example = Str.regexp "\\\\begin{coq_\\(example\\|example\\*\\|example\\#\\)}[ \t]*$" let begin_coq_eval = Str.regexp "\\\\begin{coq_eval}[ \t]*$" let end_coq_example = Str.regexp "\\\\end{coq_\\(example\\|example\\*\\|example\\#\\)}[ \t]*$" let end_coq_eval = Str.regexp "\\\\end{coq_eval}[ \t]*$" let dot_end_line = Str.regexp "\\.[ \t]*\\((\\*.*\\*)\\)?[ \t]*$" let has_match r s = try let _ = Str.search_forward r s 0 in true with Not_found -> false let percent = Str.regexp "%" let bang = Str.regexp "!" let expos = Str.regexp "^" let tex_escaped s = let dollar = "\\$" and backslash = "\\\\" and expon = "\\^" in let delims = Str.regexp ("[_{}&%#" ^ dollar ^ backslash ^ expon ^"~ <>]") in let adapt_delim = function | "_" | "{" | "}" | "&" | "%" | "#" | "$" as c -> "\\"^c | "\\" -> "{\\char'134}" | "^" -> "{\\char'136}" | "~" -> "{\\char'176}" | " " -> "~" | "<" -> "{<}" | ">" -> "{>}" | _ -> assert false in let adapt = function | Str.Text s -> s | Str.Delim s -> adapt_delim s in String.concat "" (List.map adapt (Str.full_split delims s)) let encapsule sl c_out s = if sl then Printf.fprintf c_out "\\texttt{\\textit{%s}}\\\\\n" (tex_escaped s) else Printf.fprintf c_out "\\texttt{%s}\\\\\n" (tex_escaped s) let print_block c_out bl = List.iter (fun s -> if s="" then () else encapsule !slanted c_out s) bl let insert texfile coq_output result = let c_tex = open_in texfile in let c_coq = open_in coq_output in let c_out = open_out result in (* next_block k : this function reads the next block of Coq output * removing the k leading prompts. * it returns the block as a list of string) *) let last_read = ref "" in let next_block k = if !last_read = "" then last_read := input_line c_coq; (* skip k prompts *) for i = 1 to k do last_read := remove_prompt !last_read; done; (* read and return the following lines until a prompt is found *) let rec read_lines () = let s = input_line c_coq in if Str.string_match any_prompt s 0 then begin last_read := s; [] end else s :: (read_lines ()) in let first = !last_read in first :: (read_lines ()) in (* we are just after \end{coq_...} block *) let rec just_after () = let s = input_line c_tex in if Str.string_match begin_coq_example s 0 then begin inside (Str.matched_group 1 s <> "example*") (Str.matched_group 1 s <> "example#") 0 false end else begin if !hrule then output_string c_out "\\hrulefill\\\\\n"; output_string c_out "\\end{flushleft}\n"; if !small then output_string c_out "\\end{small}\n"; if Str.string_match begin_coq_eval s 0 then eval 0 else begin output_string c_out (s ^ "\n"); outside () end end (* we are outside of a \begin{coq_...} ... \end{coq_...} block *) and outside () = let s = input_line c_tex in if Str.string_match begin_coq_example s 0 then begin if !small then output_string c_out "\\begin{small}\n"; output_string c_out "\\begin{flushleft}\n"; if !hrule then output_string c_out "\\hrulefill\\\\\n"; inside (Str.matched_group 1 s <> "example*") (Str.matched_group 1 s <> "example#") 0 true end else if Str.string_match begin_coq_eval s 0 then eval 0 else begin output_string c_out (s ^ "\n"); outside () end (* we are inside a \begin{coq_example?} ... \end{coq_example?} block * show_answers tells what kind of block it is * k is the number of lines read until now *) and inside show_answers show_questions k first_block = let s = input_line c_tex in if Str.string_match end_coq_example s 0 then begin just_after () end else begin if !verbose then Printf.printf "Coq < %s\n" s; if (not first_block) & k=0 then output_string c_out "\\medskip\n"; if show_questions then encapsule false c_out ("Coq < " ^ s); if has_match dot_end_line s then begin let bl = next_block (succ k) in if !verbose then List.iter print_endline bl; if show_answers then print_block c_out bl; inside show_answers show_questions 0 false end else inside show_answers show_questions (succ k) first_block end (* we are inside a \begin{coq_eval} ... \end{coq_eval} block * k is the number of lines read until now *) and eval k = let s = input_line c_tex in if Str.string_match end_coq_eval s 0 then outside () else begin if !verbose then Printf.printf "Coq < %s\n" s; if has_match dot_end_line s then let bl = next_block (succ k) in if !verbose then List.iter print_endline bl; eval 0 else eval (succ k) end in try let _ = next_block 0 in (* to skip the Coq banner *) let _ = next_block 0 in (* to skip the Coq answer to Set Printing Width *) outside () with End_of_file -> begin close_in c_tex; close_in c_coq; close_out c_out end (* Process of one TeX file *) let rm f = try Sys.remove f with _ -> () let one_file texfile = let inputv = Filename.temp_file "coq_tex" ".v" in let coq_output = Filename.temp_file "coq_tex" ".coq_output"in let result = if !output_specified then !output else if Filename.check_suffix texfile ".tex" then (Filename.chop_suffix texfile ".tex") ^ ".v.tex" else texfile ^ ".v.tex" in try (* 1. extract Coq phrases *) extract texfile inputv; (* 2. run Coq on input *) let _ = Sys.command (Printf.sprintf "%s < %s > %s 2>&1" !image inputv coq_output) in (* 3. insert Coq output into original file *) insert texfile coq_output result; (* 4. clean up *) rm inputv; rm coq_output with e -> begin rm inputv; rm coq_output; raise e end (* Parsing of the command line, check of the Coq command and process * of all the files in the command line, one by one *) let files = ref [] let parse_cl () = Arg.parse [ "-o", Arg.String (fun s -> output_specified := true; output := s), "output-file Specifiy the resulting LaTeX file"; "-n", Arg.Int (fun n -> linelen := n), "line-width Set the line width"; "-image", Arg.String (fun s -> image := s), "coq-image Use coq-image as Coq command"; "-w", Arg.Set cut_at_blanks, " Try to cut lines at blanks"; "-v", Arg.Set verbose, " Verbose mode (show Coq answers on stdout)"; "-sl", Arg.Set slanted, " Coq answers in slanted font (only with LaTeX2e)"; "-hrule", Arg.Set hrule, " Coq parts are written between 2 horizontal lines"; "-small", Arg.Set small, " Coq parts are written in small font"; "-boot", Arg.Set boot, " Launch coqtop with the -boot option" ] (fun s -> files := s :: !files) "coq-tex [options] file ..." let find_coqtop () = let prog = Sys.executable_name in try let size = String.length prog in let i = Str.search_backward (Str.regexp_string "coq-tex") prog (size-7) in (String.sub prog 0 i)^"coqtop"^(String.sub prog (i+7) (size-i-7)) with Not_found -> begin Printf.printf "Warning: preprocessing with default image \"coqtop\"\n"; "coqtop" end let main () = parse_cl (); if !image = "" then image := Filename.quote (find_coqtop ()); if !boot then image := !image ^ " -boot"; if Sys.command (!image ^ " -batch -silent") <> 0 then begin Printf.printf "Error: "; let _ = Sys.command (!image ^ " -batch") in exit 1 end else begin Printf.printf "Your version of coqtop seems OK\n"; flush stdout end; List.iter one_file (List.rev !files) let _ = Printexc.catch main () coq-8.4pl4/tools/coq-font-lock.el0000644000175000017500000001144612326224777015777 0ustar stephsteph;; coq-font-lock.el --- Coq syntax highlighting for Emacs - compatibilty code ;; Pierre Courtieu, may 2009 ;; ;; Authors: Pierre Courtieu ;; License: GPL (GNU GENERAL PUBLIC LICENSE) ;; Maintainer: Pierre Courtieu ;; This is copy paste from ProofGeneral by David Aspinall ;; . ProofGeneral is under GPL and Copyright ;; (C) LFCS Edinburgh. ;;; Commentary: ;; This file contains the code necessary to coq-syntax.el and ;; coq-db.el from ProofGeneral. It is also pocked from ProofGeneral. ;;; History: ;; First created from ProofGeneral may 28th 2009 ;;; Code: (setq coq-version-is-V8-1 t) (defun coq-build-regexp-list-from-db (db &optional filter) "Take a keyword database DB and return the list of regexps for font-lock. If non-nil Optional argument FILTER is a function applying to each line of DB. For each line if FILTER returns nil, then the keyword is not added to the regexp. See `coq-syntax-db' for DB structure." (let ((l db) (res ())) (while l (let* ((hd (car l)) (tl (cdr l)) ; hd is the first infos list (e1 (car hd)) (tl1 (cdr hd)) ; e1 = menu entry (e2 (car tl1)) (tl2 (cdr tl1)) ; e2 = abbreviation (e3 (car tl2)) (tl3 (cdr tl2)) ; e3 = completion (e4 (car-safe tl3)) (tl4 (cdr-safe tl3)) ; e4 = state changing (e5 (car-safe tl4)) (tl5 (cdr-safe tl4)) ; e5 = colorization string ) ;; TODO delete doublons (when (and e5 (or (not filter) (funcall filter hd))) (setq res (nconc res (list e5)))) ; careful: nconc destructive! (setq l tl))) res )) (defun filter-state-preserving (l) ; checkdoc-params: (l) "Not documented." (not (nth 3 l))) ; fourth argument is nil --> state preserving command (defun filter-state-changing (l) ; checkdoc-params: (l) "Not documented." (nth 3 l)) ; fourth argument is nil --> state preserving command ;; Generic font-lock (defvar proof-id "\\(\\w\\(\\w\\|\\s_\\)*\\)" "A regular expression for parsing identifiers.") ;; For font-lock, we treat ,-separated identifiers as one identifier ;; and refontify commata using \{proof-zap-commas}. (defun proof-anchor-regexp (e) "Anchor (\\`) and group the regexp E." (concat "\\`\\(" e "\\)")) (defun proof-ids (proof-id &optional sepregexp) "Generate a regular expression for separated lists of identifiers PROOF-ID. Default is comma separated, or SEPREGEXP if set." (concat proof-id "\\(\\s-*" (or sepregexp ",") "\\s-*" proof-id "\\)*")) (defun proof-ids-to-regexp (l) "Maps a non-empty list of tokens `L' to a regexp matching any element." (if (featurep 'xemacs) (mapconcat (lambda (s) (concat "\\_<" s "\\_>")) l "\\|") ;; old version (concat "\\_<\\(?:" (mapconcat 'identity l "\\|") "\\)\\_>"))) ;; TODO: get rid of this list. Does 'default work widely enough ;; by now? (defconst pg-defface-window-systems '(x ;; bog standard mswindows ;; Windows w32 ;; Windows gtk ;; gtk emacs (obsolete?) mac ;; used by Aquamacs carbon ;; used by Carbon XEmacs ns ;; NeXTstep Emacs (Emacs.app) x-toolkit) ;; possible catch all (but probably not) "A list of possible values for variable `window-system'. If you are on a window system and your value of variable `window-system' is not listed here, you may not get the correct syntax colouring behaviour.") (defmacro proof-face-specs (bl bd ow) "Return a spec for `defface' with BL for light bg, BD for dark, OW o/w." `(append (apply 'append (mapcar (lambda (ty) (list (list (list (list 'type ty) '(class color) (list 'background 'light)) (quote ,bl)) (list (list (list 'type ty) '(class color) (list 'background 'dark)) (quote ,bd)))) pg-defface-window-systems)) (list (list t (quote ,ow))))) ;;A new face for tactics (defface coq-solve-tactics-face (proof-face-specs (:foreground "forestgreen" t) ; pour les fonds clairs (:foreground "forestgreen" t) ; pour les fond foncés ()) ; pour le noir et blanc "Face for names of closing tactics in proof scripts." :group 'proof-faces) ;;A new face for tactics which fail when they don't kill the current goal (defface coq-solve-tactics-face (proof-face-specs (:foreground "red" t) ; pour les fonds clairs (:foreground "red" t) ; pour les fond foncés ()) ; pour le noir et blanc "Face for names of closing tactics in proof scripts." :group 'proof-faces) (defconst coq-solve-tactics-face 'coq-solve-tactics-face "Expression that evaluates to a face. Required so that 'proof-solve-tactics-face is a proper facename") (defconst proof-tactics-name-face 'coq-solve-tactics-face) (defconst proof-tacticals-name-face 'coq-solve-tactics-face) (provide 'coq-font-lock) ;;; coq-font-lock.el ends here coq-8.4pl4/tools/coqdep_boot.ml0000644000175000017500000000355012326224777015626 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* option_slash := true; parse ll | "-natdynlink" :: "no" :: ll -> option_natdynlk := false; parse ll | "-c" :: ll -> option_c := true; parse ll | "-boot" :: ll -> parse ll (* We're already in boot mode by default *) | "-mldep" :: ocamldep :: ll -> option_mldep := Some ocamldep; option_c := true; parse ll | "-I" :: r :: ll -> (* To solve conflict (e.g. same filename in kernel and checker) we allow to state an explicit order *) add_dir add_known r []; norec_dirs:=r::!norec_dirs; parse ll | f :: ll -> treat_file None f; parse ll | [] -> () let coqdep_boot () = if Array.length Sys.argv < 2 then exit 1; parse (List.tl (Array.to_list Sys.argv)); if !option_c then add_rec_dir add_known "." [] else begin add_rec_dir add_known "theories" ["Coq"]; add_rec_dir add_known "plugins" ["Coq"]; end; if !option_c then mL_dependencies (); coq_dependencies () let _ = Printexc.catch coqdep_boot () coq-8.4pl4/tools/compat5b.mlp0000644000175000017500000000172112326224777015220 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ] -> [< 't; '(UIDENT "Gram", Loc.ghost); my_token_filter s >] | [< 'tokloc; s >] -> [< 'tokloc; my_token_filter s >] | [< >] -> [< >] let _ = Token.Filter.define_filter (Gram.get_filter()) (fun prev strm -> prev (my_token_filter strm)) coq-8.4pl4/tools/check-translate0000755000175000017500000000171712326224777015777 0ustar stephsteph#!/bin/sh echo -------------- Producing translated files --------------------- rm */*/*.v8 >& /dev/null make COQ_XML=-translate theories || { echo ---- Failed to translate; exit 1; } if [ -e translated ]; then rm -r translated; fi if [ -e successful-translation ]; then rm -r successful-translation; fi if [ -e failed-translation ]; then rm -r failed-translation; fi mv theories translated mkdir theories echo -------------------- Upgrading files -------------------------- cd translated for i in */*.v do mkdir ../theories/`dirname $i` >& /dev/null mv "$i"8 ../theories/$i done cd .. echo --------------- Recompiling translated files ------------------ make theories || { echo ---- Failed to recompile; mv theories failed-translation; mv translated theories; exit 1; } echo ----------------- Recompilation successful -------------------- if [ -e successful-translation ]; then rm -r successful-translation; fi mv theories successful-translation; mv translated theories coq-8.4pl4/tools/beautify-archive0000755000175000017500000000376212326224777016160 0ustar stephsteph#!/bin/sh #This script compiles and beautifies an archive, check the correctness #of beautified files, then replace the original files by the #beautified ones, keeping a copy of original files in $OLDARCHIVE. #The script assumes: #- that the archive provides a Makefile built by coq_makefile, #- that coqc is in the path or that variables COQTOP and COQBIN are set. OLDARCHIVE=old_files NEWARCHIVE=beautify_files BEAUTIFYSUFFIX=.beautified if [ -e $OLDARCHIVE ]; then echo "Warning: $OLDARCHIVE directory found, the files are maybe already beautified"; sleep 5; fi echo ---- Producing beautified files in the beautification directory ------- if [ -e $NEWARCHIVE ]; then rm -r $NEWARCHIVE; fi if [ -e /tmp/$OLDARCHIVE.$$ ]; then rm -r /tmp/$OLDARCHIVE.$$; fi cp -pr . /tmp/$OLDARCHIVE.$$ cp -pr /tmp/$OLDARCHIVE.$$ $NEWARCHIVE cd $NEWARCHIVE rm description || true make clean make COQFLAGS='-beautify -q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)' || \ { echo ---- Failed to beautify; exit 1; } echo -------- Upgrading files in the beautification directory -------------- beaufiles=`find . -name \*.v$BEAUTIFYSUFFIX` for i in $beaufiles; do j=`dirname $i`/`basename $i .v$BEAUTIFYSUFFIX`.v echo Upgrading $j in the beautification directory mv -u -f $i $j done echo ---- Recompiling beautified files in the beautification directory ----- make clean make || { echo ---- Failed to recompile; exit 1; } echo ----- Saving old files in directory $OLDARCHIVE ------------------------- /bin/rm -r ../$OLDARCHIVE mv /tmp/$OLDARCHIVE.$$ ../$OLDARCHIVE echo Saving $OLDARCHIVE files done echo --------- Upgrading files in current directory ------------------------ vfiles=`find . -name \*.v` cd .. for i in $vfiles; do echo Upgrading $i in current directory mv -u -f $NEWARCHIVE/$i $i done echo -------- Beautification completed ------------------------------------- echo Old files are in directory '"'$OLDARCHIVE'"' echo New files are in current directory echo You can now remove the beautification directory '"'$NEWARCHIVE'"' coq-8.4pl4/tools/win32hack_filename.ml0000644000175000017500000000021112326224777016750 0ustar stephsteph(* The mingw32-ocaml cross-compiler currently uses Filename.dir_sep="/". Let's tweak that... *) let _ = Filename.dir_sep.[0] <- '\\' coq-8.4pl4/tools/compat5.mlp0000644000175000017500000000170512326224777015060 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ] -> [< '(KEYWORD "EXTEND", loc); my_token_filter s >] | [< 'tokloc; s >] -> [< 'tokloc; my_token_filter s >] | [< >] -> [< >] let _ = Token.Filter.define_filter (Gram.get_filter()) (fun prev strm -> prev (my_token_filter strm)) coq-8.4pl4/tools/coqdep_lexer.mli0000644000175000017500000000177112326224777016156 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* coq_token val caml_action : Lexing.lexbuf -> mL_token val mllib_list : Lexing.lexbuf -> string list val ocamldep_parse : Lexing.lexbuf -> string list coq-8.4pl4/tools/mkwinapp.ml0000644000175000017500000000571012326224777015156 0ustar stephsteph(* OCaml-Win32 * mkwinapp.ml * Copyright (c) 2002-2004 by Harry Chomsky * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Library General Public License for more details. * * You should have received a copy of the GNU Library General Public * License along with this library; if not, write to the Free * Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (********************************************************************* * This program alters an .exe file to make it use the "windows subsystem" * instead of the "console subsystem". In other words, when Windows runs * the program, it will not create a console for it. *) (* Pierre Letouzey 23/12/2010 : modification to allow selecting the subsystem to use instead of just setting the windows subsystem *) (* This tool can be run directly via : ocaml unix.cma mkwinapp.ml [-set|-unset] *) exception Invalid_file_format let input_word ic = let lo = input_byte ic in let hi = input_byte ic in (hi lsl 8) + lo let find_pe_header ic = seek_in ic 0x3C; let peheader = input_word ic in seek_in ic peheader; if input_char ic <> 'P' then raise Invalid_file_format; if input_char ic <> 'E' then raise Invalid_file_format; peheader let find_optional_header ic = let peheader = find_pe_header ic in let coffheader = peheader + 4 in seek_in ic (coffheader + 16); let optsize = input_word ic in if optsize < 96 then raise Invalid_file_format; let optheader = coffheader + 20 in seek_in ic optheader; let magic = input_word ic in if magic <> 0x010B && magic <> 0x020B then raise Invalid_file_format; optheader let change flag ic oc = let optheader = find_optional_header ic in seek_out oc (optheader + 64); for i = 1 to 4 do output_byte oc 0 done; output_byte oc (if flag then 2 else 3) let usage () = print_endline "Alters a Win32 executable file to use the Windows subsystem or not."; print_endline "Usage: mkwinapp [-set|-unset] "; print_endline "Giving no option is equivalent to -set"; exit 1 let main () = let n = Array.length Sys.argv - 1 in if not (n = 1 || n = 2) then usage (); let flag = if n = 1 then true else if Sys.argv.(1) = "-set" then true else if Sys.argv.(1) = "-unset" then false else usage () in let filename = Sys.argv.(n) in let f = Unix.openfile filename [Unix.O_RDWR] 0 in let ic = Unix.in_channel_of_descr f and oc = Unix.out_channel_of_descr f in change flag ic oc let _ = main () coq-8.4pl4/tools/gallina_lexer.mll0000644000175000017500000001137712326224777016320 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 then comment lexbuf } | "*)" [' ''\t']*'\n' { (if !comments then print (Lexing.lexeme lexbuf)); comment_depth := pred !comment_depth; if !comment_depth > 0 then comment lexbuf } | eof { raise Fin_fichier } | _ { (if !comments then print (Lexing.lexeme lexbuf)); comment lexbuf } and skip_comment = parse | "(*" { comment_depth := succ !comment_depth; skip_comment lexbuf } | "*)" { comment_depth := pred !comment_depth; if !comment_depth > 0 then skip_comment lexbuf } | eof { raise Fin_fichier } | _ { skip_comment lexbuf } and body_def = parse | [^'.']* ":=" { print (Lexing.lexeme lexbuf); () } | _ { print (Lexing.lexeme lexbuf); body lexbuf } and body = parse | enddot { print ".\n"; skip_proof lexbuf } | ":=" { print ".\n"; skip_proof lexbuf } | "(*" { print "(*"; comment_depth := 1; comment lexbuf; body lexbuf } | eof { raise Fin_fichier } | _ { print (Lexing.lexeme lexbuf); body lexbuf } and body_pgm = parse | enddot { print ".\n"; skip_proof lexbuf } | "(*" { print "(*"; comment_depth := 1; comment lexbuf; body_pgm lexbuf } | eof { raise Fin_fichier } | _ { print (Lexing.lexeme lexbuf); body_pgm lexbuf } and skip_until_point = parse | '.' '\n' { () } | enddot { end_of_line lexbuf } | "(*" { comment_depth := 1; skip_comment lexbuf; skip_until_point lexbuf } | eof { raise Fin_fichier } | _ { skip_until_point lexbuf } and end_of_line = parse | [' ' '\t' ]* { end_of_line lexbuf } | '\n' { () } | eof { raise Fin_fichier } | _ { print (Lexing.lexeme lexbuf) } and skip_proof = parse | "Save." { end_of_line lexbuf } | "Save" space { skip_until_point lexbuf } | "Qed." { end_of_line lexbuf } | "Qed" space { skip_until_point lexbuf } | "Defined." { end_of_line lexbuf } | "Defined" space { skip_until_point lexbuf } | "Abort." { end_of_line lexbuf } | "Abort" space { skip_until_point lexbuf } | "Proof" space { skip_until_point lexbuf } | "Proof" [' ' '\t']* '.' { skip_proof lexbuf } | "(*" { comment_depth := 1; skip_comment lexbuf; skip_proof lexbuf } | eof { raise Fin_fichier } | _ { skip_proof lexbuf } coq-8.4pl4/INSTALL.ide0000644000175000017500000001055212326224777013427 0ustar stephsteph CoqIde Installation procedure. CoqIde is a graphical interface to perform interactive proofs. You should be able to do everything you do in coqtop inside CoqIde excepted dropping to the ML toplevel. DISCLAIMER: CoqIde is ongoing work. Although it should never let you loose a proof, you may encounter unexpected bugs. Do not hesitate to send suggestions/bug reports. DISTRIBUTION PACKAGES Your POSIX operating system may already contain precompiled packages for Coq, including CoqIde, or a ready-to-compile... If the version provided there suits you, follow the usual procedure for your operating system. E.g., on Debian GNU/Linux (or Debian GNU/k*BSD or ...), do: aptitude install coqide On Gentoo GNU/Linux, do: USE=ide emerge sci-mathematics/coq Else, read the rest of this document to compile your own CoqIde. REQUIREMENT: - OCaml >= 3.11 with native threads support. - make world must succeed. - The graphical toolkit GTK+ 2.x. See http://www.gtk.org. The official supported version is at least 2.10.x. You may still compile CoqIde with older versions and use all features. Run "pkg-config --modversion gtk+-2.0" to check your version. All recent distributions have precompiled packages. Do not forget to install the developement headers packages. On Debian, installing lablgtk2 (see below) will automatically install GTK+. (But "aptitude install libgtk2.0-dev" will install GTK+ 2.x should you need to force it for one reason or another.) - The OCaml bindings for GTK+ 2.x, lablgtk2. You need at least version 2.12.0. Your distribution may contain precompiled packages. For example, for Debian, run aptitude install liblablgtk2-ocaml-dev for Mandriva, run urpmi ocaml-lablgtk2-devel If it does not, see http://wwwfun.kurims.kyoto-u.ac.jp/soft/olabl/lablgtk.html . One official releases of lablgtk2 is here: http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/dist/lablgtk-2.10.1.tar.gz If you are in a hurry just run : cd /tmp && \ wget \ http://wwwfun.kurims.kyoto-u.ac.jp/soft/olabl/dist/lablgtk-2.10.1.tar.gz && \ tar zxvf lablgtk-2.10.1.tar.gz && \ cd lablgtk-2.10.1 && \ ./configure && \ make world && \ make install You must have write access to the OCaml standard library path. If this fails, read lablgtk-2.10.1/README. INSTALLATION 0) For optimal performance, OCaml must support native threads (aka pthreads). If this not the case, this means that Coq computations will be slow and "make ide" will fail. Use "make bin/coqide.byte" instead. To fix this problem, just recompile OCaml from source and configure OCaml with : "./configure --with-pthreads". In case you install over an existing copy of OCaml, you should better empty the OCaml installation directory. 1) Go into your Coq source directory and, as usual, configure with: ./configure This should detect the ability of making CoqIde; check that is says it has detected this ability and activated the building of CoqIde. Then compile with make world and install with make install In case you are upgrading from an old version you may need to run make clean-ide 3) You may now run bin/coqide NOTES There are three configuration files located in your $(XDG_CONFIG_HOME)/coq dir. You may need to set HOME to some sensible value under Windows. - coqiderc is generated by coqide itself. It may be edited by hand or by using the Preference menu from coqide. It will be generated the first time you save your the preferences in Coqide. - coqide.keys is a standard Gtk2 accelerator dump. You may edit this file to change the default shortcuts for the menus. Read ide/FAQ for more informations. TROUBLESHOOTING - Problem with automatic templates Some users may experiment problems with unwanted automatic templates while using Coqide. This is due to a change in the modifiers keys available through GTK. The straightest way to get rid of the problem is to edit by hand your coqiderc (either /home//.config/coq/coqiderc under Linux, or C:\Documents and Settings\\.config\coq\coqiderc under Windows) and replace any occurence of MOD4 by MOD1. coq-8.4pl4/scripts/0000755000175000017500000000000012365131025013304 5ustar stephstephcoq-8.4pl4/scripts/coqc.ml0000644000175000017500000001432212326224777014603 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ". On essaye au maximum d'utiliser les modules Sys et Filename pour que la portabilité soit maximale, mais il reste encore des appels ā des fonctions du module Unix. Ceux-ci sont préfixés par "Unix." *) (* environment *) let environment = Unix.environment () let best = if Coq_config.arch = "win32" then "" else ("."^Coq_config.best) let binary = ref ("coqtop" ^ best) let image = ref "" (* coqc options *) let verbose = ref false (* Verifies that a string starts by a letter and do not contain others caracters than letters, digits, or `_` *) let check_module_name s = let err c = output_string stderr "Invalid module name: "; output_string stderr s; output_string stderr " character "; if c = '\'' then output_string stderr "\"'\"" else (output_string stderr"'"; output_char stderr c; output_string stderr"'"); output_string stderr " is not allowed in module names\n"; exit 1 in match String.get s 0 with | 'a' .. 'z' | 'A' .. 'Z' -> for i = 1 to (String.length s)-1 do match String.get s i with | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> () | c -> err c done | c -> err c let rec make_compilation_args = function | [] -> [] | file :: fl -> let name_no_suffix = if Filename.check_suffix file ".v" then Filename.chop_suffix file ".v" else file in let modulename = Filename.basename name_no_suffix in check_module_name modulename; (if !verbose then "-compile-verbose" else "-compile") :: name_no_suffix :: (make_compilation_args fl) (* compilation of files [files] with command [command] and args [args] *) let compile command args files = let args' = command :: args @ (make_compilation_args files) in match Sys.os_type with | "Win32" -> let pid = Unix.create_process_env command (Array.of_list args') environment Unix.stdin Unix.stdout Unix.stderr in let status = snd (Unix.waitpid [] pid) in let errcode = match status with Unix.WEXITED c|Unix.WSTOPPED c|Unix.WSIGNALED c -> c in exit errcode | _ -> Unix.execvpe command (Array.of_list args') environment (* parsing of the command line * * special treatment for -bindir and -i. * other options are passed to coqtop *) let usage () = Usage.print_usage_coqc () ; flush stderr ; exit 1 let parse_args () = let rec parse (cfiles,args) = function | [] -> List.rev cfiles, List.rev args | ("-verbose" | "--verbose") :: rem -> verbose := true ; parse (cfiles,args) rem | "-image" :: f :: rem -> image := f; parse (cfiles,args) rem | "-image" :: [] -> usage () | "-byte" :: rem -> binary := "coqtop.byte"; parse (cfiles,args) rem | "-opt" :: rem -> binary := "coqtop.opt"; parse (cfiles,args) rem | "-libdir" :: _ :: rem -> print_string "Warning: option -libdir deprecated and ignored\n"; flush stdout; parse (cfiles,args) rem | ("-db"|"-debugger") :: rem -> print_string "Warning: option -db/-debugger deprecated and ignored\n";flush stdout; parse (cfiles,args) rem | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () | ("-outputstate"|"-inputstate"|"-is"|"-exclude-dir" |"-load-vernac-source"|"-l"|"-load-vernac-object" |"-load-ml-source"|"-require"|"-load-ml-object" |"-init-file"|"-dump-glob"|"-compat"|"-coqlib" as o) :: rem -> begin match rem with | s :: rem' -> parse (cfiles,s::o::args) rem' | [] -> usage () end | ("-I"|"-include" as o) :: rem -> begin match rem with | s :: "-as" :: t :: rem' -> parse (cfiles,t::"-as"::s::o::args) rem' | s :: "-as" :: [] -> usage () | s :: rem' -> parse (cfiles,s::o::args) rem' | [] -> usage () end | "-R" :: s :: "-as" :: t :: rem -> parse (cfiles,t::"-as"::s::"-R"::args) rem | "-R" :: s :: "-as" :: [] -> usage () | "-R" :: s :: t :: rem -> parse (cfiles,t::s::"-R"::args) rem | ("-notactics"|"-debug"|"-nolib"|"-boot" |"-batch"|"-nois"|"-noglob"|"-no-glob" |"-q"|"-full"|"-profile"|"-just-parsing"|"-echo" |"-unsafe"|"-quiet" |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-beautify"|"-strict-implicit" |"-dont-load-proofs"|"-load-proofs"|"-force-load-proofs" |"-impredicative-set"|"-vm" as o) :: rem -> parse (cfiles,o::args) rem | ("-where") :: _ -> (try print_endline (Envars.coqlib ()) with Util.UserError(_,pps) -> Pp.msgerrnl (Pp.hov 0 pps)); exit 0 | ("-config" | "--config") :: _ -> Usage.print_config (); exit 0 | ("-v"|"--version") :: _ -> Usage.version 0 | f :: rem -> if Sys.file_exists f then parse (f::cfiles,args) rem else let fv = f ^ ".v" in if Sys.file_exists fv then parse (fv::cfiles,args) rem else begin prerr_endline ("coqc: "^f^": no such file or directory") ; exit 1 end in parse ([],[]) (List.tl (Array.to_list Sys.argv)) (* main: we parse the command line, define the command to compile files * and then call the compilation on each file *) let main () = let cfiles, args = parse_args () in if cfiles = [] then begin prerr_endline "coqc: too few arguments" ; usage () end; let coqtopname = if !image <> "" then !image else Filename.concat Envars.coqbin (!binary ^ Coq_config.exec_extension) in (* List.iter (compile coqtopname args) cfiles*) Unix.handle_unix_error (compile coqtopname args) cfiles let _ = Printexc.print main () coq-8.4pl4/scripts/coqmktop.ml0000644000175000017500000002546012326224777015520 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Sys.command ("\""^cmd^"\"") else Sys.command (* Objects to link *) (* 1. Core objects *) let ocamlobjs = ["str.cma";"unix.cma";"nums.cma"] let dynobjs = ["dynlink.cma"] let camlp4objs = if Coq_config.camlp4 = "camlp5" then ["gramlib.cma"] else ["camlp4lib.cma"] let libobjs = ocamlobjs @ camlp4objs let spaces = Str.regexp "[ \t\n]+" let split_list l = Str.split spaces l let copts = split_list Tolink.copts let core_objs = split_list Tolink.core_objs let core_libs = split_list Tolink.core_libs (* 3. Toplevel objects *) let camlp4topobjs = if Coq_config.camlp4 = "camlp5" then ["camlp5_top.cma"; "pa_o.cmo"; "pa_extend.cmo"] else [ "Camlp4Top.cmo"; "Camlp4Parsers/Camlp4OCamlRevisedParser.cmo"; "Camlp4Parsers/Camlp4OCamlParser.cmo"; "Camlp4Parsers/Camlp4GrammarParser.cmo" ] let topobjs = camlp4topobjs let gramobjs = [] let notopobjs = gramobjs (* 4. High-level tactics objects *) (* environment *) let opt = ref false let full = ref false let top = ref false let echo = ref false let no_start = ref false let is_ocaml4 = Coq_config.caml_version.[0] <> '3' (* Since the .cma are given with their relative paths (e.g. "lib/clib.cma"), we only need to include directories mentionned in the temp main ml file below (for accessing the corresponding .cmi). *) let src_dirs = [ []; ["lib"]; ["toplevel"]; ["kernel";"byterun"]; ] let includes () = let coqlib = if !Flags.boot then "." else Envars.coqlib () in let mkdir d = "\"" ^ List.fold_left Filename.concat coqlib d ^ "\"" in (List.fold_right (fun d l -> "-I" :: mkdir d :: l) src_dirs []) @ ["-I"; "\"" ^ Envars.camlp4lib () ^ "\""] @ (if is_ocaml4 then ["-I"; "+compiler-libs"] else []) (* Transform bytecode object file names in native object file names *) let native_suffix f = if Filename.check_suffix f ".cmo" then (Filename.chop_suffix f ".cmo") ^ ".cmx" else if Filename.check_suffix f ".cma" then (Filename.chop_suffix f ".cma") ^ ".cmxa" else if Filename.check_suffix f ".a" then f else failwith ("File "^f^" has not extension .cmo, .cma or .a") (* Transforms a file name in the corresponding Caml module name. *) let rem_ext_regexpr = Str.regexp "\\(.*\\)\\.\\(cm..?\\|ml\\)" let module_of_file name = let s = Str.replace_first rem_ext_regexpr "\\1" (Filename.basename name) in String.capitalize s (* Build the list of files to link and the list of modules names *) let files_to_link userfiles = let dyn_objs = if not !opt || Coq_config.has_natdynlink then dynobjs else [] in let toplevel_objs = if !top then topobjs else if !opt then notopobjs else [] in let objs = dyn_objs @ libobjs @ core_objs @ toplevel_objs in let modules = List.map module_of_file (objs @ userfiles) in let libs = dyn_objs @ libobjs @ core_libs @ toplevel_objs in let libstolink = (if !opt then List.map native_suffix libs else libs) @ userfiles in (modules, libstolink) (* Gives the list of all the directories under [dir]. Uses [Unix] (it is hard to do without it). *) let all_subdirs dir = let l = ref [dir] in let add f = l := f :: !l in let rec traverse dir = let dirh = try opendir dir with Unix_error _ -> invalid_arg "all_subdirs" in try while true do let f = readdir dirh in if f <> "." && f <> ".." then let file = Filename.concat dir f in if (stat file).st_kind = S_DIR then begin add file; traverse file end done with End_of_file -> closedir dirh in traverse dir; List.rev !l (* usage *) let usage () = prerr_endline "Usage: coqmktop files\ \nFlags are:\ \n -coqlib dir Specify where the Coq object files are\ \n -camlbin dir Specify where the OCaml binaries are\ \n -camlp4bin dir Specify where the Camlp4/5 binaries are\ \n -o exec-file Specify the name of the resulting toplevel\ \n -boot Run in boot mode\ \n -echo Print calls to external commands\ \n -full Link high level tactics\ \n -opt Compile in native code\ \n -top Build Coq on a OCaml toplevel (incompatible with -opt)\ \n -R dir Add recursively dir to OCaml search path\ \n"; exit 1 (* parsing of the command line *) let parse_args () = let rec parse (op,fl) = function | [] -> List.rev op, List.rev fl | "-coqlib" :: d :: rem -> Flags.coqlib_spec := true; Flags.coqlib := d ; parse (op,fl) rem | "-coqlib" :: _ -> usage () | "-camlbin" :: d :: rem -> Flags.camlbin_spec := true; Flags.camlbin := d ; parse (op,fl) rem | "-camlbin" :: _ -> usage () | "-camlp4bin" :: d :: rem -> Flags.camlp4bin_spec := true; Flags.camlp4bin := d ; parse (op,fl) rem | "-camlp4bin" :: _ -> usage () | "-boot" :: rem -> Flags.boot := true; parse (op,fl) rem | "-opt" :: rem -> opt := true ; parse (op,fl) rem | "-full" :: rem -> full := true ; parse (op,fl) rem | "-top" :: rem -> top := true ; parse (op,fl) rem | "-v8" :: rem -> Printf.eprintf "warning: option -v8 deprecated"; parse (op,fl) rem | "-echo" :: rem -> echo := true ; parse (op,fl) rem | ("-cclib"|"-ccopt"|"-I"|"-o"|"-w" as o) :: rem' -> begin match rem' with | a :: rem -> parse (a::o::op,fl) rem | [] -> usage () end | "-R" :: a :: rem -> parse ((List.rev(List.flatten (List.map (fun d -> ["-I";d]) (all_subdirs a))))@op,fl) rem | "-R" :: [] -> usage () | ("-noassert"|"-compact"|"-g"|"-p"|"-thread"|"-dtypes" as o) :: rem -> parse (o::op,fl) rem | ("-h"|"--help") :: _ -> usage () | ("-no-start") :: rem -> no_start:=true; parse (op, fl) rem | f :: rem -> if Filename.check_suffix f ".ml" or Filename.check_suffix f ".cmx" or Filename.check_suffix f ".cmo" or Filename.check_suffix f ".cmxa" or Filename.check_suffix f ".cma" or Filename.check_suffix f ".c" then parse (op,f::fl) rem else begin prerr_endline ("Don't know what to do with " ^ f); exit 1 end in parse ([Coq_config.osdeplibs],[]) (List.tl (Array.to_list Sys.argv)) let clean file = let rm f = if Sys.file_exists f then Sys.remove f in let basename = Filename.chop_suffix file ".ml" in if not !echo then begin rm file; rm (basename ^ ".o"); rm (basename ^ ".cmi"); rm (basename ^ ".cmo"); rm (basename ^ ".cmx") end (* Creates another temporary file for Dynlink if needed *) let tmp_dynlink()= let tmp = Filename.temp_file "coqdynlink" ".ml" in let _ = Sys.command ("echo \"Dynlink.init();;\" > "^tmp) in tmp (* Initializes the kind of loading in the main program *) let declare_loading_string () = if not !top then "Mltop.remove ();;" else "begin try\ \n (* Enable rectypes in the toplevel if it has the directive #rectypes *)\ \n begin match Hashtbl.find Toploop.directive_table \"rectypes\" with\ \n | Toploop.Directive_none f -> f ()\ \n | _ -> ()\ \n end\ \n with\ \n | Not_found -> ()\ \n end;;\ \n\ \n let ppf = Format.std_formatter;;\ \n Mltop.set_top\ \n {Mltop.load_obj=\ \n (fun f -> if not (Topdirs.load_file ppf f) then Util.error (\"Could not load plugin \"^f));\ \n Mltop.use_file=Topdirs.dir_use ppf;\ \n Mltop.add_dir=Topdirs.dir_directory;\ \n Mltop.ml_loop=(fun () -> Toploop.loop ppf) };;\ \n" (* create a temporary main file to link *) let create_tmp_main_file modules = let main_name,oc = Filename.open_temp_file "coqmain" ".ml" in try (* Add the pre-linked modules *) output_string oc "List.iter Mltop.add_known_module [\""; output_string oc (String.concat "\";\"" modules); output_string oc "\"];;\n"; (* Initializes the kind of loading *) output_string oc (declare_loading_string()); (* Start the toplevel loop *) if not !no_start then output_string oc "Coqtop.start();;\n"; close_out oc; main_name with reraise -> clean main_name; raise reraise (* main part *) let main () = let (options, userfiles) = parse_args () in (* which ocaml command to invoke *) let camlbin = Envars.camlbin () in let prog = if !opt then begin (* native code *) if !top then failwith "no custom toplevel in native code !"; let ocamloptexec = Filename.quote (Filename.concat camlbin "ocamlopt") in ocamloptexec^" -linkall" end else (* bytecode (we shunt ocamlmktop script which fails on win32) *) let ocamlmktoplib = if is_ocaml4 then " ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma" else " toplevellib.cma" in let ocamlcexec = Filename.quote (Filename.concat camlbin "ocamlc") in let ocamlccustom = Printf.sprintf "%s %s -linkall " ocamlcexec Coq_config.coqrunbyteflags in (if !top then ocamlccustom^ocamlmktoplib else ocamlccustom) in (* files to link *) let (modules, tolink) = files_to_link userfiles in (*file for dynlink *) let dynlink= if not (!opt || !top) then [tmp_dynlink()] else [] in (* the list of the loaded modules *) let main_file = create_tmp_main_file modules in try let args = options @ includes () @ copts @ tolink @ dynlink in let args = args @ [ Filename.quote main_file ] in (* add topstart.cmo explicitly because we shunted ocamlmktop wrapper *) let args = if !top then args @ [ "topstart.cmo" ] else args in (* Now, with the .cma, we MUST use the -linkall option *) let command = String.concat " " (prog::"-rectypes"::args) in if !echo then begin print_endline command; print_endline ("(command length is " ^ (string_of_int (String.length command)) ^ " characters)"); flush Pervasives.stdout end; let retcode = safe_sys_command command in clean main_file; (* command gives the exit code in HSB, and signal in LSB !!! *) if retcode > 255 then retcode lsr 8 else retcode with reraise -> clean main_file; raise reraise let retcode = try Printexc.print main () with any -> 1 let _ = exit retcode coq-8.4pl4/checker/0000755000175000017500000000000012365131026013222 5ustar stephstephcoq-8.4pl4/checker/safe_typing.mli0000644000175000017500000000251312326224777016253 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* env (* exporting and importing modules *) type compiled_library val set_engagement : Declarations.engagement -> unit val import : System.physical_path -> compiled_library -> Digest.t -> unit val unsafe_import : System.physical_path -> compiled_library -> Digest.t -> unit (** Store the body of modules' opaque constants inside a table. This module is used during the serialization and deserialization of vo files. *) module LightenLibrary : sig type table type lightened_compiled_library (** [load table lcl] builds a compiled library from a lightened library [lcl] by remplacing every index by its related opaque terms inside [table]. *) val load : table -> lightened_compiled_library -> compiled_library end coq-8.4pl4/checker/modops.ml0000644000175000017500000001350212326224777015073 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (arg_id,arg_t,body_t) | _ -> error_not_a_functor mtb let module_body_of_type mp mtb = { mod_mp = mp; mod_type = mtb.typ_expr; mod_type_alg = mtb.typ_expr_alg; mod_expr = None; mod_constraints = mtb.typ_constraints; mod_delta = mtb.typ_delta; mod_retroknowledge = []} let rec add_signature mp sign resolver env = let add_one env (l,elem) = let kn = make_kn mp empty_dirpath l in let con = constant_of_kn kn in let mind = mind_of_delta resolver (mind_of_kn kn) in match elem with | SFBconst cb -> (* let con = constant_of_delta resolver con in*) Environ.add_constant con cb env | SFBmind mib -> (* let mind = mind_of_delta resolver mind in*) Environ.add_mind mind mib env | SFBmodule mb -> add_module mb env (* adds components as well *) | SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env in List.fold_left add_one env sign and add_module mb env = let mp = mb.mod_mp in let env = Environ.shallow_add_module mp mb env in match mb.mod_type with | SEBstruct (sign) -> add_signature mp sign mb.mod_delta env | SEBfunctor _ -> env | _ -> anomaly "Modops:the evaluation of the structure failed " let strengthen_const mp_from l cb resolver = match cb.const_body with | Def _ -> cb | _ -> let con = make_con mp_from empty_dirpath l in (* let con = constant_of_delta resolver con in*) { cb with const_body = Def (Declarations.from_val (Const con)) } let rec strengthen_mod mp_from mp_to mb = if Declarations.mp_in_delta mb.mod_mp mb.mod_delta then mb else match mb.mod_type with | SEBstruct (sign) -> let resolve_out,sign_out = strengthen_sig mp_from sign mp_to mb.mod_delta in { mb with mod_expr = Some (SEBident mp_to); mod_type = SEBstruct(sign_out); mod_type_alg = mb.mod_type_alg; mod_constraints = mb.mod_constraints; mod_delta = resolve_out(*add_mp_delta_resolver mp_from mp_to (add_delta_resolver mb.mod_delta resolve_out)*); mod_retroknowledge = mb.mod_retroknowledge} | SEBfunctor _ -> mb | _ -> anomaly "Modops:the evaluation of the structure failed " and strengthen_sig mp_from sign mp_to resolver = match sign with | [] -> empty_delta_resolver,[] | (l,SFBconst cb) :: rest -> let item' = l,SFBconst (strengthen_const mp_from l cb resolver) in let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in resolve_out,item'::rest' | (_,SFBmind _ as item):: rest -> let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in resolve_out,item::rest' | (l,SFBmodule mb) :: rest -> let mp_from' = MPdot (mp_from,l) in let mp_to' = MPdot(mp_to,l) in let mb_out = strengthen_mod mp_from' mp_to' mb in let item' = l,SFBmodule (mb_out) in let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in resolve_out (*add_delta_resolver resolve_out mb.mod_delta*), item':: rest' | (l,SFBmodtype mty as item) :: rest -> let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in resolve_out,item::rest' let strengthen mtb mp = match mtb.typ_expr with | SEBstruct (sign) -> let resolve_out,sign_out = strengthen_sig mtb.typ_mp sign mp mtb.typ_delta in {mtb with typ_expr = SEBstruct(sign_out); typ_delta = resolve_out(*add_delta_resolver mtb.typ_delta (add_mp_delta_resolver mtb.typ_mp mp resolve_out)*)} | SEBfunctor _ -> mtb | _ -> anomaly "Modops:the evaluation of the structure failed " let subst_and_strengthen mb mp = strengthen_mod mb.mod_mp mp (subst_module (map_mp mb.mod_mp mp) mb) let module_type_of_module mp mb = match mp with Some mp -> strengthen { typ_mp = mp; typ_expr = mb.mod_type; typ_expr_alg = None; typ_constraints = mb.mod_constraints; typ_delta = mb.mod_delta} mp | None -> {typ_mp = mb.mod_mp; typ_expr = mb.mod_type; typ_expr_alg = None; typ_constraints = mb.mod_constraints; typ_delta = mb.mod_delta} coq-8.4pl4/checker/modops.mli0000644000175000017500000000344312326224777015247 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* module_type_body -> module_body val module_type_of_module : module_path option -> module_body -> module_type_body val destr_functor : env -> struct_expr_body -> mod_bound_id * module_type_body * struct_expr_body val add_signature : module_path -> structure_body -> delta_resolver -> env -> env (* adds a module and its components, but not the constraints *) val add_module : module_body -> env -> env val strengthen : module_type_body -> module_path -> module_type_body val subst_and_strengthen : module_body -> module_path -> module_body val error_incompatible_modtypes : module_type_body -> module_type_body -> 'a val error_not_match : label -> structure_field_body -> 'a val error_with_incorrect : label -> 'a val error_no_such_label : label -> 'a val error_no_such_label_sub : label -> module_path -> 'a val error_signature_expected : struct_expr_body -> 'a val error_not_a_constant : label -> 'a val error_not_a_module : label -> 'a val error_a_generative_module_expected : label -> 'a val error_application_to_not_path : struct_expr_body -> 'a coq-8.4pl4/checker/inductive.mli0000644000175000017500000000566312326224777015746 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> inductive * constr list type mind_specif = mutual_inductive_body * one_inductive_body (*s Fetching information in the environment about an inductive type. Raises [Not_found] if the inductive type is not found. *) val lookup_mind_specif : env -> inductive -> mind_specif val type_of_inductive : env -> mind_specif -> constr (* Return type as quoted by the user *) val type_of_constructor : constructor -> mind_specif -> constr val arities_of_specif : mutual_inductive -> mind_specif -> constr array (* [type_case_branches env (I,args) (p:A) c] computes useful types about the following Cases expression:

    Cases (c :: (I args)) of b1..bn end It computes the type of every branch (pattern variables are introduced by products) and the type for the whole expression. *) val type_case_branches : env -> inductive * constr list -> constr * constr -> constr -> constr array * constr (* Check a [case_info] actually correspond to a Case expression on the given inductive type. *) val check_case_info : env -> inductive -> case_info -> unit (*s Guard conditions for fix and cofix-points. *) val check_fix : env -> fixpoint -> unit val check_cofix : env -> cofixpoint -> unit (*s Support for sort-polymorphic inductive types *) val type_of_inductive_knowing_parameters : env -> one_inductive_body -> constr array -> constr val max_inductive_sort : sorts array -> Univ.universe val instantiate_universes : env -> rel_context -> polymorphic_arity -> constr array -> rel_context * sorts (***************************************************************) (* Debug *) type size = Large | Strict type subterm_spec = Subterm of (size * wf_paths) | Dead_code | Not_subterm type guard_env = { env : env; (* dB of last fixpoint *) rel_min : int; (* inductive of recarg of each fixpoint *) inds : inductive array; (* the recarg information of inductive family *) recvec : wf_paths array; (* dB of variables denoting subterms *) genv : subterm_spec Lazy.t list; } type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t val subterm_specif : guard_env -> stack_element list -> constr -> subterm_spec val branches_specif : guard_env -> subterm_spec Lazy.t -> case_info -> subterm_spec Lazy.t list array coq-8.4pl4/checker/main.ml0000644000175000017500000000003212326224777014510 0ustar stephsteph let _ = Checker.start () coq-8.4pl4/checker/closure.mli0000644000175000017500000001271212326224777015421 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a (*s Delta implies all consts (both global (= by [kernel_name]) and local (= by [Rel] or [Var])), all evars, and letin's. Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of a LetIn expression is Letin reduction *) type transparent_state = Idpred.t * Cpred.t val all_opaque : transparent_state val all_transparent : transparent_state val is_transparent_variable : transparent_state -> variable -> bool val is_transparent_constant : transparent_state -> constant -> bool (* Sets of reduction kinds. *) module type RedFlagsSig = sig type reds type red_kind (* The different kinds of reduction *) val fBETA : red_kind val fDELTA : red_kind val fIOTA : red_kind val fZETA : red_kind val fCONST : constant -> red_kind val fVAR : identifier -> red_kind (* No reduction at all *) val no_red : reds (* Adds a reduction kind to a set *) val red_add : reds -> red_kind -> reds (* Build a reduction set from scratch = iter [red_add] on [no_red] *) val mkflags : red_kind list -> reds (* Tests if a reduction kind is set *) val red_set : reds -> red_kind -> bool end module RedFlags : RedFlagsSig open RedFlags val betadeltaiota : reds val betaiotazeta : reds val betadeltaiotanolet : reds (***********************************************************************) type table_key = | ConstKey of constant | VarKey of identifier | RelKey of int type 'a infos val ref_value_cache: 'a infos -> table_key -> 'a option val create: ('a infos -> constr -> 'a) -> reds -> env -> 'a infos (************************************************************************) (*s Lazy reduction. *) (* [fconstr] is the type of frozen constr *) type fconstr (* [fconstr] can be accessed by using the function [fterm_of] and by matching on type [fterm] *) type fterm = | FRel of int | FAtom of constr (* Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key | FInd of inductive | FConstruct of constructor | FApp of fconstr * fconstr array | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCases of case_info * fconstr * fconstr * fconstr array | FLambda of int * (name * constr) list * constr * fconstr subs | FProd of name * fconstr * fconstr | FLetIn of name * fconstr * fconstr * constr * fconstr subs | FEvar of existential_key * fconstr array | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED (************************************************************************) (*s A [stack] is a context of arguments, arguments are pushed by [append_stack] one array at a time but popped with [decomp_stack] one by one *) type stack_member = | Zapp of fconstr array | Zcase of case_info * fconstr * fconstr array | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr and stack = stack_member list val append_stack : fconstr array -> stack -> stack val eta_expand_stack : stack -> stack (* To lazy reduce a constr, create a [clos_infos] with [create_clos_infos], inject the term to reduce with [inject]; then use a reduction function *) val inject : constr -> fconstr val fterm_of : fconstr -> fterm val term_of_fconstr : fconstr -> constr val destFLambda : (fconstr subs -> constr -> fconstr) -> fconstr -> name * fconstr * fconstr (* Global and local constant cache *) type clos_infos val create_clos_infos : reds -> env -> clos_infos (* Reduction function *) (* [whd_val] is for weak head normalization *) val whd_val : clos_infos -> fconstr -> constr (* [whd_stack] performs weak head normalization in a given stack. It stops whenever a reduction is blocked. *) val whd_stack : clos_infos -> fconstr -> stack -> fconstr * stack (* Conversion auxiliary functions to do step by step normalisation *) (* [unfold_reference] unfolds references in a [fconstr] *) val unfold_reference : clos_infos -> table_key -> fconstr option (* [mind_equiv] checks whether two inductive types are intentionally equal *) val mind_equiv_infos : clos_infos -> inductive -> inductive -> bool val eq_table_key : table_key -> table_key -> bool (************************************************************************) (*i This is for lazy debug *) val lift_fconstr : int -> fconstr -> fconstr val lift_fconstr_vect : int -> fconstr array -> fconstr array val mk_clos : fconstr subs -> constr -> fconstr val mk_clos_vect : fconstr subs -> constr array -> fconstr array val mk_clos_deep : (fconstr subs -> constr -> fconstr) -> fconstr subs -> constr -> fconstr val kni: clos_infos -> fconstr -> stack -> fconstr * stack val knr: clos_infos -> fconstr -> stack -> fconstr * stack val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr val optimise_closure : fconstr subs -> constr -> fconstr subs * constr (* End of cbn debug section i*) coq-8.4pl4/checker/check_stat.ml0000644000175000017500000000357412326224777015712 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* str "Theory: Set is impredicative" | None -> str "Theory: Set is predicative" let cst_filter f csts = Cmap_env.fold (fun c ce acc -> if f c ce then c::acc else acc) csts [] let is_ax _ cb = not (constant_has_body cb) let pr_ax csts = let axs = cst_filter is_ax csts in if axs = [] then str "Axioms: " else hv 2 (str "Axioms:" ++ fnl() ++ prlist_with_sep fnl Indtypes.prcon axs) let print_context env = if !output_context then begin let {env_globals= {env_constants=csts; env_inductives=inds; env_modules=mods; env_modtypes=mtys}; env_stratification= {env_universes=univ; env_engagement=engt}} = env in msgnl(hov 0 (fnl() ++ str"CONTEXT SUMMARY" ++ fnl() ++ str"===============" ++ fnl() ++ fnl() ++ str "* " ++ hov 0 (pr_engt engt ++ fnl()) ++ fnl() ++ str "* " ++ hov 0 (pr_ax csts) ++ fnl())) end let stats () = print_context (Safe_typing.get_env()); print_memory_stat () coq-8.4pl4/checker/term.mli0000644000175000017500000001011212326224777014704 0ustar stephstephopen Names type existential_key = int type metavariable = int type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle type case_printing = { ind_nargs : int; style : case_style; } type case_info = { ci_ind : inductive; ci_npar : int; ci_cstr_ndecls : int array; ci_pp_info : case_printing; } type contents = Pos | Null type sorts = Prop of contents | Type of Univ.universe type sorts_family = InProp | InSet | InType val family_of_sort : sorts -> sorts_family type 'a pexistential = existential_key * 'a array type 'a prec_declaration = name array * 'a array * 'a array type 'a pfixpoint = (int array * int) * 'a prec_declaration type 'a pcofixpoint = int * 'a prec_declaration type cast_kind = VMcast | DEFAULTcast type constr = Rel of int | Var of identifier | Meta of metavariable | Evar of constr pexistential | Sort of sorts | Cast of constr * cast_kind * constr | Prod of name * constr * constr | Lambda of name * constr * constr | LetIn of name * constr * constr * constr | App of constr * constr array | Const of constant | Ind of inductive | Construct of constructor | Case of case_info * constr * constr * constr array | Fix of constr pfixpoint | CoFix of constr pcofixpoint type existential = constr pexistential type rec_declaration = constr prec_declaration type fixpoint = constr pfixpoint type cofixpoint = constr pcofixpoint val strip_outer_cast : constr -> constr val collapse_appl : constr -> constr val decompose_app : constr -> constr * constr list val applist : constr * constr list -> constr val iter_constr_with_binders : ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit exception LocalOccur val closedn : int -> constr -> bool val closed0 : constr -> bool val noccurn : int -> constr -> bool val noccur_between : int -> int -> constr -> bool val noccur_with_meta : int -> int -> constr -> bool val map_constr_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr val exliftn : Esubst.lift -> constr -> constr val liftn : int -> int -> constr -> constr val lift : int -> constr -> constr type info = Closed | Open | Unknown type 'a substituend = { mutable sinfo : info; sit : 'a; } val lift_substituend : int -> constr substituend -> constr val make_substituend : 'a -> 'a substituend val substn_many : constr substituend array -> int -> constr -> constr val substnl : constr list -> int -> constr -> constr val substl : constr list -> constr -> constr val subst1 : constr -> constr -> constr type named_declaration = identifier * constr option * constr type rel_declaration = name * constr option * constr type named_context = named_declaration list val empty_named_context : named_context val fold_named_context : (named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a type section_context = named_context type rel_context = rel_declaration list val empty_rel_context : rel_context val rel_context_length : rel_context -> int val rel_context_nhyps : rel_context -> int val fold_rel_context : (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a val map_context : (constr -> constr) -> named_context -> named_context val map_rel_context : (constr -> constr) -> rel_context -> rel_context val extended_rel_list : int -> rel_context -> constr list val compose_lam : (name * constr) list -> constr -> constr val decompose_lam : constr -> (name * constr) list * constr val decompose_lam_n_assum : int -> constr -> rel_context * constr val mkProd_or_LetIn : name * constr option * constr -> constr -> constr val it_mkProd_or_LetIn : constr -> rel_context -> constr val decompose_prod_assum : constr -> rel_context * constr val decompose_prod_n_assum : int -> constr -> rel_context * constr type arity = rel_context * sorts val mkArity : arity -> constr val destArity : constr -> arity val isArity : constr -> bool val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool val eq_constr : constr -> constr -> bool (* Validation *) val val_sortfam : Validate.func val val_sort : Validate.func val val_constr : Validate.func val val_rctxt : Validate.func val val_nctxt : Validate.func coq-8.4pl4/checker/safe_typing.ml0000644000175000017500000001557312326224777016114 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* () | _, None -> () | _, Some ImpredicativeSet -> error "Needs option -impredicative-set" (* Libraries = Compiled modules *) let report_clash f caller dir = let msg = str "compiled library " ++ str(string_of_dirpath caller) ++ spc() ++ str "makes inconsistent assumptions over library" ++ spc() ++ str(string_of_dirpath dir) ++ fnl() in f msg let check_imports f caller env needed = let check (dp,stamp) = try let actual_stamp = lookup_digest env dp in if stamp <> actual_stamp then report_clash f caller dp with Not_found -> error ("Reference to unknown module " ^ (string_of_dirpath dp)) in List.iter check needed type compiled_library = dir_path * module_body * (dir_path * Digest.t) list * engagement option (* Store the body of modules' opaque constants inside a table. This module is used during the serialization and deserialization of vo files. By adding an indirection to the opaque constant definitions, we gain the ability not to load them. As these constant definitions are usually big terms, we save a deserialization time as well as some memory space. *) module LightenLibrary : sig type table type lightened_compiled_library val load : table -> lightened_compiled_library -> compiled_library end = struct (* The table is implemented as an array of [constr_substituted]. Keys are hence integers. To avoid changing the [compiled_library] type, we brutally encode integers into [lazy_constr]. This isn't pretty, but shouldn't be dangerous since the produced structure [lightened_compiled_library] is abstract and only meant for writing to .vo via Marshal (which doesn't care about types). *) type table = constr_substituted array let key_of_lazy_constr (c:lazy_constr) = (Obj.magic c : int) (* To avoid any future misuse of the lightened library that could interpret encoded keys as real [constr_substituted], we hide these kind of values behind an abstract datatype. *) type lightened_compiled_library = compiled_library (* Map a [compiled_library] to another one by just updating the opaque term [t] to [on_opaque_const_body t]. *) let traverse_library on_opaque_const_body = let rec traverse_module mb = match mb.mod_expr with None -> { mb with mod_expr = None; mod_type = traverse_modexpr mb.mod_type; } | Some impl when impl == mb.mod_type-> let mtb = traverse_modexpr mb.mod_type in { mb with mod_expr = Some mtb; mod_type = mtb; } | Some impl -> { mb with mod_expr = Option.map traverse_modexpr mb.mod_expr; mod_type = traverse_modexpr mb.mod_type; } and traverse_struct struc = let traverse_body (l,body) = (l,match body with | (SFBconst cb) when is_opaque cb -> SFBconst {cb with const_body = on_opaque_const_body cb.const_body} | (SFBconst _ | SFBmind _ ) as x -> x | SFBmodule m -> SFBmodule (traverse_module m) | SFBmodtype m -> SFBmodtype ({m with typ_expr = traverse_modexpr m.typ_expr})) in List.map traverse_body struc and traverse_modexpr = function | SEBfunctor (mbid,mty,mexpr) -> SEBfunctor (mbid, ({mty with typ_expr = traverse_modexpr mty.typ_expr}), traverse_modexpr mexpr) | SEBident mp as x -> x | SEBstruct (struc) -> SEBstruct (traverse_struct struc) | SEBapply (mexpr,marg,u) -> SEBapply (traverse_modexpr mexpr,traverse_modexpr marg,u) | SEBwith (seb,wdcl) -> SEBwith (traverse_modexpr seb,wdcl) in fun (dp,mb,depends,s) -> (dp,traverse_module mb,depends,s) (* Loading is also a traversing that decodes the embedded keys that are inside the [lightened_library]. If the [load_proof] flag is set, we lookup inside the table to graft the [constr_substituted]. Otherwise, we set the [const_body] field to [None]. *) let load table lightened_library = let decode_key = function | Undef _ | Def _ -> assert false | OpaqueDef k -> let k = key_of_lazy_constr k in let body = try table.(k) with _ -> error "Error while retrieving an opaque body" in OpaqueDef (lazy_constr_from_val body) in traverse_library decode_key lightened_library end open Validate let val_deps = val_list (val_tuple ~name:"dep"[|val_dp;no_val|]) let val_vo = val_tuple ~name:"vo" [|val_dp;val_module;val_deps;val_opt val_eng|] (* This function should append a certificate to the .vo file. The digest must be part of the certicate to rule out attackers that could change the .vo file between the time it was read and the time the stamp is written. For the moment, .vo are not signed. *) let stamp_library file digest = () (* When the module is checked, digests do not need to match, but a warning is issued in case of mismatch *) let import file (dp,mb,depends,engmt as vo) digest = Validate.apply !Flags.debug val_vo vo; Flags.if_verbose msgnl (str "*** vo structure validated ***"); let env = !genv in check_imports msg_warning dp env depends; check_engagement env engmt; Mod_checking.check_module (add_constraints mb.mod_constraints env) mb.mod_mp mb; stamp_library file digest; (* We drop proofs once checked *) (* let mb = lighten_module mb in*) full_add_module dp mb digest (* When the module is admitted, digests *must* match *) let unsafe_import file (dp,mb,depends,engmt as vo) digest = if !Flags.debug then ignore vo; (*Validate.apply !Flags.debug val_vo vo;*) let env = !genv in check_imports (errorlabstrm"unsafe_import") dp env depends; check_engagement env engmt; (* We drop proofs once checked *) (* let mb = lighten_module mb in*) full_add_module dp mb digest coq-8.4pl4/checker/environ.mli0000644000175000017500000000463112326224777015426 0ustar stephstephopen Names open Term (* Environments *) type globals = { env_constants : Declarations.constant_body Cmap_env.t; env_inductives : Declarations.mutual_inductive_body Mindmap_env.t; env_inductives_eq : kernel_name KNmap.t; env_modules : Declarations.module_body MPmap.t; env_modtypes : Declarations.module_type_body MPmap.t} type stratification = { env_universes : Univ.universes; env_engagement : Declarations.engagement option; } type env = { env_globals : globals; env_named_context : named_context; env_rel_context : rel_context; env_stratification : stratification; env_imports : Digest.t MPmap.t; } val empty_env : env (* Engagement *) val engagement : env -> Declarations.engagement option val set_engagement : Declarations.engagement -> env -> env (* Digests *) val add_digest : env -> dir_path -> Digest.t -> env val lookup_digest : env -> dir_path -> Digest.t (* de Bruijn variables *) val rel_context : env -> rel_context val lookup_rel : int -> env -> rel_declaration val push_rel : rel_declaration -> env -> env val push_rel_context : rel_context -> env -> env val push_rec_types : name array * constr array * 'a -> env -> env (* Named variables *) val named_context : env -> named_context val push_named : named_declaration -> env -> env val lookup_named : identifier -> env -> named_declaration val named_type : identifier -> env -> constr (* Universes *) val universes : env -> Univ.universes val add_constraints : Univ.constraints -> env -> env (* Constants *) val lookup_constant : constant -> env -> Declarations.constant_body val add_constant : constant -> Declarations.constant_body -> env -> env type const_evaluation_result = NoBody | Opaque exception NotEvaluableConst of const_evaluation_result val constant_value : env -> constant -> constr val evaluable_constant : constant -> env -> bool (* Inductives *) val mind_equiv : env -> inductive -> inductive -> bool val lookup_mind : mutual_inductive -> env -> Declarations.mutual_inductive_body val add_mind : mutual_inductive -> Declarations.mutual_inductive_body -> env -> env (* Modules *) val add_modtype : module_path -> Declarations.module_type_body -> env -> env val shallow_add_module : module_path -> Declarations.module_body -> env -> env val shallow_remove_module : module_path -> env -> env val lookup_module : module_path -> env -> Declarations.module_body val lookup_modtype : module_path -> env -> Declarations.module_type_body coq-8.4pl4/checker/type_errors.ml0000644000175000017500000000711112326224777016146 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* InProp | Prop Pos -> InSet | Type _ -> InType let val_sort = val_sum "sort" 0 [|[|val_enum "cnt" 2|];[|val_univ|]|] let val_sortfam = val_enum "sorts_family" 3 (********************************************************************) (* Constructions as implemented *) (********************************************************************) (* [constr array] is an instance matching definitional [named_context] in the same order (i.e. last argument first) *) type 'constr pexistential = existential_key * 'constr array type 'constr prec_declaration = name array * 'constr array * 'constr array type 'constr pfixpoint = (int array * int) * 'constr prec_declaration type 'constr pcofixpoint = int * 'constr prec_declaration let val_evar f = val_tuple ~name:"pexistential" [|val_int;val_array f|] let val_prec f = val_tuple ~name:"prec_declaration" [|val_array val_name; val_array f; val_array f|] let val_fix f = val_tuple ~name:"pfixpoint" [|val_tuple~name:"fix2"[|val_array val_int;val_int|];val_prec f|] let val_cofix f = val_tuple ~name:"pcofixpoint"[|val_int;val_prec f|] type cast_kind = VMcast | DEFAULTcast let val_cast = val_enum "cast_kind" 2 (*s*******************************************************************) (* The type of constructions *) type constr = | Rel of int | Var of identifier | Meta of metavariable | Evar of constr pexistential | Sort of sorts | Cast of constr * cast_kind * constr | Prod of name * constr * constr | Lambda of name * constr * constr | LetIn of name * constr * constr * constr | App of constr * constr array | Const of constant | Ind of inductive | Construct of constructor | Case of case_info * constr * constr * constr array | Fix of constr pfixpoint | CoFix of constr pcofixpoint let val_constr = val_rec_sum "constr" 0 (fun val_constr -> [| [|val_int|]; (* Rel *) [|val_id|]; (* Var *) [|val_int|]; (* Meta *) [|val_evar val_constr|]; (* Evar *) [|val_sort|]; (* Sort *) [|val_constr;val_cast;val_constr|]; (* Cast *) [|val_name;val_constr;val_constr|]; (* Prod *) [|val_name;val_constr;val_constr|]; (* Lambda *) [|val_name;val_constr;val_constr;val_constr|]; (* LetIn *) [|val_constr;val_array val_constr|]; (* App *) [|val_con|]; (* Const *) [|val_ind|]; (* Ind *) [|val_cstr|]; (* Construct *) [|val_ci;val_constr;val_constr;val_array val_constr|]; (* Case *) [|val_fix val_constr|]; (* Fix *) [|val_cofix val_constr|] (* CoFix *) |]) type existential = constr pexistential type rec_declaration = constr prec_declaration type fixpoint = constr pfixpoint type cofixpoint = constr pcofixpoint let rec strip_outer_cast c = match c with | Cast (c,_,_) -> strip_outer_cast c | _ -> c let rec collapse_appl c = match c with | App (f,cl) -> let rec collapse_rec f cl2 = match (strip_outer_cast f) with | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) | _ -> App (f,cl2) in collapse_rec f cl | _ -> c let decompose_app c = match collapse_appl c with | App (f,cl) -> (f, Array.to_list cl) | _ -> (c,[]) let applist (f,l) = App (f, Array.of_list l) (****************************************************************************) (* Functions for dealing with constr terms *) (****************************************************************************) (*********************) (* Occurring *) (*********************) let iter_constr_with_binders g f n c = match c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () | Cast (c,_,t) -> f n c; f n t | Prod (_,t,c) -> f n t; f (g n) c | Lambda (_,t,c) -> f n t; f (g n) c | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c | App (c,l) -> f n c; Array.iter (f n) l | Evar (_,l) -> Array.iter (f n) l | Case (_,p,c,bl) -> f n p; f n c; Array.iter (f n) bl | Fix (_,(_,tl,bl)) -> Array.iter (f n) tl; Array.iter (f (iterate g (Array.length tl) n)) bl | CoFix (_,(_,tl,bl)) -> Array.iter (f n) tl; Array.iter (f (iterate g (Array.length tl) n)) bl exception LocalOccur (* (closedn n M) raises FreeVar if a variable of height greater than n occurs in M, returns () otherwise *) let closedn n c = let rec closed_rec n c = match c with | Rel m -> if m>n then raise LocalOccur | _ -> iter_constr_with_binders succ closed_rec n c in try closed_rec n c; true with LocalOccur -> false (* [closed0 M] is true iff [M] is a (deBruijn) closed term *) let closed0 = closedn 0 (* (noccurn n M) returns true iff (Rel n) does NOT occur in term M *) let noccurn n term = let rec occur_rec n c = match c with | Rel m -> if m = n then raise LocalOccur | _ -> iter_constr_with_binders succ occur_rec n c in try occur_rec n term; true with LocalOccur -> false (* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M for n <= p < n+m *) let noccur_between n m term = let rec occur_rec n c = match c with | Rel(p) -> if n<=p && p iter_constr_with_binders succ occur_rec n c in try occur_rec n term; true with LocalOccur -> false (* Checking function for terms containing existential variables. The function [noccur_with_meta] considers the fact that each existential variable (as well as each isevar) in the term appears applied to its local context, which may contain the CoFix variables. These occurrences of CoFix variables are not considered *) let noccur_with_meta n m term = let rec occur_rec n c = match c with | Rel p -> if n<=p & p (match f with | (Cast (Meta _,_,_)| Meta _) -> () | _ -> iter_constr_with_binders succ occur_rec n c) | Evar (_, _) -> () | _ -> iter_constr_with_binders succ occur_rec n c in try (occur_rec n term; true) with LocalOccur -> false (*********************) (* Lifting *) (*********************) let map_constr_with_binders g f l c = match c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> c | Cast (c,k,t) -> Cast (f l c, k, f l t) | Prod (na,t,c) -> Prod (na, f l t, f (g l) c) | Lambda (na,t,c) -> Lambda (na, f l t, f (g l) c) | LetIn (na,b,t,c) -> LetIn (na, f l b, f l t, f (g l) c) | App (c,al) -> App (f l c, Array.map (f l) al) | Evar (e,al) -> Evar (e, Array.map (f l) al) | Case (ci,p,c,bl) -> Case (ci, f l p, f l c, Array.map (f l) bl) | Fix (ln,(lna,tl,bl)) -> let l' = iterate g (Array.length tl) l in Fix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) | CoFix(ln,(lna,tl,bl)) -> let l' = iterate g (Array.length tl) l in CoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) (* The generic lifting function *) let rec exliftn el c = match c with | Rel i -> Rel(reloc_rel i el) | _ -> map_constr_with_binders el_lift exliftn el c (* Lifting the binding depth across k bindings *) let liftn k n = match el_liftn (pred n) (el_shft k el_id) with | ELID -> (fun c -> c) | el -> exliftn el let lift k = liftn k 1 (*********************) (* Substituting *) (*********************) (* (subst1 M c) substitutes M for Rel(1) in c we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel M1,...,Mn for respectively Rel(1),...,Rel(n) in c *) (* 1st : general case *) type info = Closed | Open | Unknown type 'a substituend = { mutable sinfo: info; sit: 'a } let rec lift_substituend depth s = match s.sinfo with | Closed -> s.sit | Open -> lift depth s.sit | Unknown -> s.sinfo <- if closed0 s.sit then Closed else Open; lift_substituend depth s let make_substituend c = { sinfo=Unknown; sit=c } let substn_many lamv n c = let lv = Array.length lamv in if lv = 0 then c else let rec substrec depth c = match c with | Rel k -> if k<=depth then c else if k-depth <= lv then lift_substituend depth lamv.(k-depth-1) else Rel (k-lv) | _ -> map_constr_with_binders succ substrec depth c in substrec n c let substnl laml n = substn_many (Array.map make_substituend (Array.of_list laml)) n let substl laml = substnl laml 0 let subst1 lam = substl [lam] (***************************************************************************) (* Type of assumptions and contexts *) (***************************************************************************) let val_ndecl = val_tuple ~name:"named_declaration"[|val_id;val_opt val_constr;val_constr|] let val_rdecl = val_tuple ~name:"rel_declaration"[|val_name;val_opt val_constr;val_constr|] let val_nctxt = val_list val_ndecl let val_rctxt = val_list val_rdecl type named_declaration = identifier * constr option * constr type rel_declaration = name * constr option * constr type named_context = named_declaration list let empty_named_context = [] let fold_named_context f l ~init = List.fold_right f l init type section_context = named_context type rel_context = rel_declaration list let empty_rel_context = [] let rel_context_length = List.length let rel_context_nhyps hyps = let rec nhyps acc = function | [] -> acc | (_,None,_)::hyps -> nhyps (1+acc) hyps | (_,Some _,_)::hyps -> nhyps acc hyps in nhyps 0 hyps let fold_rel_context f l ~init = List.fold_right f l init let map_context f l = let map_decl (n, body_o, typ as decl) = let body_o' = Option.smartmap f body_o in let typ' = f typ in if body_o' == body_o && typ' == typ then decl else (n, body_o', typ') in list_smartmap map_decl l let map_rel_context = map_context let extended_rel_list n hyps = let rec reln l p = function | (_,None,_) :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps | (_,Some _,_) :: hyps -> reln l (p+1) hyps | [] -> l in reln [] 1 hyps (* Iterate lambda abstractions *) (* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *) let compose_lam l b = let rec lamrec = function | ([], b) -> b | ((v,t)::l, b) -> lamrec (l, Lambda (v,t,b)) in lamrec (l,b) (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) let decompose_lam = let rec lamdec_rec l c = match c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c | Cast (c,_,_) -> lamdec_rec l c | _ -> l,c in lamdec_rec [] (* Decompose lambda abstractions and lets, until finding n abstractions *) let decompose_lam_n_assum n = if n < 0 then error "decompose_lam_n_assum: integer parameter must be positive"; let rec lamdec_rec l n c = if n=0 then l,c else match c with | Lambda (x,t,c) -> lamdec_rec ((x,None,t) :: l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec ((x,Some b,t) :: l) n c | Cast (c,_,_) -> lamdec_rec l n c | c -> error "decompose_lam_n_assum: not enough abstractions" in lamdec_rec empty_rel_context n (* Iterate products, with or without lets *) (* Constructs either [(x:t)c] or [[x=b:t]c] *) let mkProd_or_LetIn (na,body,t) c = match body with | None -> Prod (na, t, c) | Some b -> LetIn (na, b, t, c) let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) let decompose_prod_assum = let rec prodec_rec l c = match c with | Prod (x,t,c) -> prodec_rec ((x,None,t) :: l) c | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t) :: l) c | Cast (c,_,_) -> prodec_rec l c | _ -> l,c in prodec_rec empty_rel_context let decompose_prod_n_assum n = if n < 0 then error "decompose_prod_n_assum: integer parameter must be positive"; let rec prodec_rec l n c = if n=0 then l,c else match c with | Prod (x,t,c) -> prodec_rec ((x,None,t) :: l) (n-1) c | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t) :: l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c | c -> error "decompose_prod_n_assum: not enough assumptions" in prodec_rec empty_rel_context n (***************************) (* Other term constructors *) (***************************) type arity = rel_context * sorts let mkArity (sign,s) = it_mkProd_or_LetIn (Sort s) sign let destArity = let rec prodec_rec l c = match c with | Prod (x,t,c) -> prodec_rec ((x,None,t)::l) c | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c | Cast (c,_,_) -> prodec_rec l c | Sort s -> l,s | _ -> anomaly "destArity: not an arity" in prodec_rec [] let rec isArity c = match c with | Prod (_,_,c) -> isArity c | LetIn (_,b,_,c) -> isArity (subst1 b c) | Cast (c,_,_) -> isArity c | Sort _ -> true | _ -> false (*******************************) (* alpha conversion functions *) (*******************************) (* alpha conversion : ignore print names and casts *) let compare_constr f t1 t2 = match t1, t2 with | Rel n1, Rel n2 -> n1 = n2 | Meta m1, Meta m2 -> m1 = m2 | Var id1, Var id2 -> id1 = id2 | Sort s1, Sort s2 -> s1 = s2 | Cast (c1,_,_), _ -> f c1 t2 | _, Cast (c2,_,_) -> f t1 c2 | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 & f c1 c2 | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 & f c1 c2 | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 & f t1 t2 & f c1 c2 | App (c1,l1), App (c2,l2) -> if Array.length l1 = Array.length l2 then f c1 c2 & array_for_all2 f l1 l2 else let (h1,l1) = decompose_app t1 in let (h2,l2) = decompose_app t2 in if List.length l1 = List.length l2 then f h1 h2 & List.for_all2 f l1 l2 else false | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2 | Const c1, Const c2 -> eq_con_chk c1 c2 | Ind c1, Ind c2 -> eq_ind_chk c1 c2 | Construct (c1,i1), Construct (c2,i2) -> i1=i2 && eq_ind_chk c1 c2 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> f p1 p2 & f c1 c2 & array_for_all2 f bl1 bl2 | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2 | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2 | _ -> false let rec eq_constr m n = (m==n) or compare_constr eq_constr m n let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *) coq-8.4pl4/checker/.depend0000644000175000017500000000575312326224777014511 0ustar stephstephchecker.cmo: type_errors.cmi term.cmo safe_typing.cmi indtypes.cmi \ declarations.cmi check_stat.cmi check.cmo checker.cmx: type_errors.cmx term.cmx safe_typing.cmx indtypes.cmx \ declarations.cmx check_stat.cmx check.cmx check.cmo: safe_typing.cmi check.cmx: safe_typing.cmx check_stat.cmo: term.cmo safe_typing.cmi indtypes.cmi environ.cmo \ declarations.cmi check_stat.cmi check_stat.cmx: term.cmx safe_typing.cmx indtypes.cmx environ.cmx \ declarations.cmx check_stat.cmi closure.cmo: term.cmo environ.cmo closure.cmi closure.cmx: term.cmx environ.cmx closure.cmi closure.cmi: term.cmo environ.cmo declarations.cmo: term.cmo declarations.cmi declarations.cmx: term.cmx declarations.cmi declarations.cmi: term.cmo environ.cmo: term.cmo declarations.cmi environ.cmx: term.cmx declarations.cmx indtypes.cmo: typeops.cmi term.cmo reduction.cmi inductive.cmi environ.cmo \ declarations.cmi indtypes.cmi indtypes.cmx: typeops.cmx term.cmx reduction.cmx inductive.cmx environ.cmx \ declarations.cmx indtypes.cmi indtypes.cmi: typeops.cmi term.cmo environ.cmo declarations.cmi inductive.cmo: type_errors.cmi term.cmo reduction.cmi environ.cmo \ declarations.cmi inductive.cmi inductive.cmx: type_errors.cmx term.cmx reduction.cmx environ.cmx \ declarations.cmx inductive.cmi inductive.cmi: term.cmo environ.cmo declarations.cmi main.cmo: checker.cmo main.cmx: checker.cmx mod_checking.cmo: typeops.cmi term.cmo subtyping.cmi reduction.cmi modops.cmi \ inductive.cmi indtypes.cmi environ.cmo declarations.cmi mod_checking.cmx: typeops.cmx term.cmx subtyping.cmx reduction.cmx modops.cmx \ inductive.cmx indtypes.cmx environ.cmx declarations.cmx modops.cmo: term.cmo environ.cmo declarations.cmi modops.cmi modops.cmx: term.cmx environ.cmx declarations.cmx modops.cmi modops.cmi: term.cmo environ.cmo declarations.cmi reduction.cmo: term.cmo environ.cmo closure.cmi reduction.cmi reduction.cmx: term.cmx environ.cmx closure.cmx reduction.cmi reduction.cmi: term.cmo environ.cmo safe_typing.cmo: validate.cmo modops.cmi mod_checking.cmo environ.cmo \ declarations.cmi safe_typing.cmi safe_typing.cmx: validate.cmx modops.cmx mod_checking.cmx environ.cmx \ declarations.cmx safe_typing.cmi safe_typing.cmi: term.cmo environ.cmo declarations.cmi subtyping.cmo: typeops.cmi term.cmo reduction.cmi modops.cmi inductive.cmi \ environ.cmo declarations.cmi subtyping.cmi subtyping.cmx: typeops.cmx term.cmx reduction.cmx modops.cmx inductive.cmx \ environ.cmx declarations.cmx subtyping.cmi subtyping.cmi: term.cmo environ.cmo declarations.cmi type_errors.cmo: term.cmo environ.cmo type_errors.cmi type_errors.cmx: term.cmx environ.cmx type_errors.cmi type_errors.cmi: term.cmo environ.cmo typeops.cmo: type_errors.cmi term.cmo reduction.cmi inductive.cmi environ.cmo \ declarations.cmi typeops.cmi typeops.cmx: type_errors.cmx term.cmx reduction.cmx inductive.cmx environ.cmx \ declarations.cmx typeops.cmi typeops.cmi: term.cmo environ.cmo declarations.cmi coq-8.4pl4/checker/inductive.ml0000644000175000017500000010254212326224777015567 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* = Array.length mib.mind_packets then error "Inductive.lookup_mind_specif: invalid inductive index"; (mib, mib.mind_packets.(tyi)) let find_rectype env c = let (t, l) = decompose_app (whd_betadeltaiota env c) in match t with | Ind ind -> (ind, l) | _ -> raise Not_found let find_inductive env c = let (t, l) = decompose_app (whd_betadeltaiota env c) in match t with | Ind ind when (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l) | _ -> raise Not_found let find_coinductive env c = let (t, l) = decompose_app (whd_betadeltaiota env c) in match t with | Ind ind when not (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l) | _ -> raise Not_found let inductive_params (mib,_) = mib.mind_nparams (************************************************************************) (* Build the substitution that replaces Rels by the appropriate *) (* inductives *) let ind_subst mind mib = let ntypes = mib.mind_ntypes in let make_Ik k = Ind (mind,ntypes-k-1) in list_tabulate make_Ik ntypes (* Instantiate inductives in constructor type *) let constructor_instantiate mind mib c = let s = ind_subst mind mib in substl s c let instantiate_params full t args sign = let fail () = anomaly "instantiate_params: type, ctxt and args mismatch" in let (rem_args, subs, ty) = fold_rel_context (fun (_,copt,_) (largs,subs,ty) -> match (copt, largs, ty) with | (None, a::args, Prod(_,_,t)) -> (args, a::subs, t) | (Some b,_,LetIn(_,_,_,t)) -> (largs, (substl subs b)::subs, t) | (_,[],_) -> if full then fail() else ([], subs, ty) | _ -> fail ()) sign ~init:(args,[],t) in if rem_args <> [] then fail(); substl subs ty let full_inductive_instantiate mib params sign = let dummy = Prop Null in let t = mkArity (sign,dummy) in fst (destArity (instantiate_params true t params mib.mind_params_ctxt)) let full_constructor_instantiate ((mind,_),(mib,_),params) = let inst_ind = constructor_instantiate mind mib in (fun t -> instantiate_params true (inst_ind t) params mib.mind_params_ctxt) (************************************************************************) (************************************************************************) (* Functions to build standard types related to inductive *) (* Computing the actual sort of an applied or partially applied inductive type: I_i: forall uniformparams:utyps, forall otherparams:otyps, Type(a) uniformargs : utyps otherargs : otyps I_1:forall ...,s_1;...I_n:forall ...,s_n |- sort(C_kj(uniformargs)) = s_kj s'_k = max(..s_kj..) merge(..s'_k..) = ..s''_k.. -------------------------------------------------------------------- Gamma |- I_i uniformargs otherargs : phi(s''_i) where - if p=0, phi() = Prop - if p=1, phi(s) = s - if p<>1, phi(s) = sup(Set,s) Remark: Set (predicative) is encoded as Type(0) *) let sort_as_univ = function | Type u -> u | Prop Null -> type0m_univ | Prop Pos -> type0_univ let cons_subst u su subst = try (u, sup su (List.assoc u subst)) :: List.remove_assoc u subst with Not_found -> (u, su) :: subst let actualize_decl_level env lev t = let sign,s = dest_arity env t in mkArity (sign,lev) let polymorphism_on_non_applied_parameters = false (* Bind expected levels of parameters to actual levels *) (* Propagate the new levels in the signature *) let rec make_subst env = function | (_,Some _,_ as t)::sign, exp, args -> let ctx,subst = make_subst env (sign, exp, args) in t::ctx, subst | d::sign, None::exp, args -> let args = match args with _::args -> args | [] -> [] in let ctx,subst = make_subst env (sign, exp, args) in d::ctx, subst | d::sign, Some u::exp, a::args -> (* We recover the level of the argument, but we don't change the *) (* level in the corresponding type in the arity; this level in the *) (* arity is a global level which, at typing time, will be enforce *) (* to be greater than the level of the argument; this is probably *) (* a useless extra constraint *) let s = sort_as_univ (snd (dest_arity env a)) in let ctx,subst = make_subst env (sign, exp, args) in d::ctx, cons_subst u s subst | (na,None,t as d)::sign, Some u::exp, [] -> (* No more argument here: we instantiate the type with a fresh level *) (* which is first propagated to the corresponding premise in the arity *) (* (actualize_decl_level), then to the conclusion of the arity (via *) (* the substitution) *) let ctx,subst = make_subst env (sign, exp, []) in if polymorphism_on_non_applied_parameters then let s = fresh_local_univ () in let t = actualize_decl_level env (Type s) t in (na,None,t)::ctx, cons_subst u s subst else d::ctx, subst | sign, [], _ -> (* Uniform parameters are exhausted *) sign,[] | [], _, _ -> assert false let instantiate_universes env ctx ar argsorts = let args = Array.to_list argsorts in let ctx,subst = make_subst env (ctx,ar.poly_param_levels,args) in let level = subst_large_constraints subst ar.poly_level in ctx, if is_type0m_univ level then Prop Null else if is_type0_univ level then Prop Pos else Type level let type_of_inductive_knowing_parameters env mip paramtyps = match mip.mind_arity with | Monomorphic s -> s.mind_user_arity | Polymorphic ar -> let ctx = List.rev mip.mind_arity_ctxt in let ctx,s = instantiate_universes env ctx ar paramtyps in mkArity (List.rev ctx,s) (* Type of a (non applied) inductive type *) let type_of_inductive env (_,mip) = type_of_inductive_knowing_parameters env mip [||] (* The max of an array of universes *) let cumulate_constructor_univ u = function | Prop Null -> u | Prop Pos -> sup type0_univ u | Type u' -> sup u u' let max_inductive_sort = Array.fold_left cumulate_constructor_univ type0m_univ (************************************************************************) (* Type of a constructor *) let type_of_constructor cstr (mib,mip) = let ind = inductive_of_constructor cstr in let specif = mip.mind_user_lc in let i = index_of_constructor cstr in let nconstr = Array.length mip.mind_consnames in if i > nconstr then error "Not enough constructors in the type"; constructor_instantiate (fst ind) mib specif.(i-1) let arities_of_specif kn (mib,mip) = let specif = mip.mind_nf_lc in Array.map (constructor_instantiate kn mib) specif (************************************************************************) let error_elim_expln kp ki = match kp,ki with | (InType | InSet), InProp -> NonInformativeToInformative | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *) | _ -> WrongArity (* Type of case predicates *) (* Get type of inductive, with parameters instantiated *) let inductive_sort_family mip = match mip.mind_arity with | Monomorphic s -> family_of_sort s.mind_sort | Polymorphic _ -> InType let mind_arity mip = mip.mind_arity_ctxt, inductive_sort_family mip let get_instantiated_arity (mib,mip) params = let sign, s = mind_arity mip in full_inductive_instantiate mib params sign, s let elim_sorts (_,mip) = mip.mind_kelim let extended_rel_list n hyps = let rec reln l p = function | (_,None,_) :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps | (_,Some _,_) :: hyps -> reln l (p+1) hyps | [] -> l in reln [] 1 hyps let build_dependent_inductive ind (_,mip) params = let realargs,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in applist (Ind ind, List.map (lift mip.mind_nrealargs_ctxt) params @ extended_rel_list 0 realargs) (* This exception is local *) exception LocalArity of (sorts_family * sorts_family * arity_error) option let check_allowed_sort ksort specif = if not (List.exists ((=) ksort) (elim_sorts specif)) then let s = inductive_sort_family (snd specif) in raise (LocalArity (Some(ksort,s,error_elim_expln ksort s))) let is_correct_arity env c (p,pj) ind specif params = let arsign,_ = get_instantiated_arity specif params in let rec srec env pt ar = let pt' = whd_betadeltaiota env pt in match pt', ar with | Prod (na1,a1,t), (_,None,a1')::ar' -> (try conv env a1 a1' with NotConvertible -> raise (LocalArity None)); srec (push_rel (na1,None,a1) env) t ar' | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) let env' = push_rel (na1,None,a1) env in let ksort = match (whd_betadeltaiota env' a2) with | Sort s -> family_of_sort s | _ -> raise (LocalArity None) in let dep_ind = build_dependent_inductive ind specif params in (try conv env a1 dep_ind with NotConvertible -> raise (LocalArity None)); check_allowed_sort ksort specif; true | Sort s', [] -> check_allowed_sort (family_of_sort s') specif; false | _, (_,Some _,_ as d)::ar' -> srec (push_rel d env) (lift 1 pt') ar' | _ -> raise (LocalArity None) in try srec env pj (List.rev arsign) with LocalArity kinds -> error_elim_arity env ind (elim_sorts specif) c (p,pj) kinds (************************************************************************) (* Type of case branches *) (* [p] is the predicate, [i] is the constructor number (starting from 0), and [cty] is the type of the constructor (params not instantiated) *) let build_branches_type ind (_,mip as specif) params dep p = let build_one_branch i cty = let typi = full_constructor_instantiate (ind,specif,params) cty in let (args,ccl) = decompose_prod_assum typi in let nargs = rel_context_length args in let (_,allargs) = decompose_app ccl in let (lparams,vargs) = list_chop (inductive_params specif) allargs in let cargs = if dep then let cstr = ith_constructor_of_inductive ind (i+1) in let dep_cstr = applist (Construct cstr,lparams@extended_rel_list 0 args) in vargs @ [dep_cstr] else vargs in let base = beta_appvect (lift nargs p) (Array.of_list cargs) in it_mkProd_or_LetIn base args in Array.mapi build_one_branch mip.mind_nf_lc (* [p] is the predicate, [c] is the match object, [realargs] is the list of real args of the inductive type *) let build_case_type dep p c realargs = let args = if dep then realargs@[c] else realargs in beta_appvect p (Array.of_list args) let type_case_branches env (ind,largs) (p,pj) c = let specif = lookup_mind_specif env ind in let nparams = inductive_params specif in let (params,realargs) = list_chop nparams largs in let dep = is_correct_arity env c (p,pj) ind specif params in let lc = build_branches_type ind specif params dep p in let ty = build_case_type dep p c realargs in (lc, ty) (************************************************************************) (* Checking the case annotation is relevant *) let check_case_info env indsp ci = let (mib,mip) = lookup_mind_specif env indsp in if not (eq_ind indsp ci.ci_ind) or (mib.mind_nparams <> ci.ci_npar) or (mip.mind_consnrealdecls <> ci.ci_cstr_ndecls) then raise (TypeError(env,WrongCaseInfo(indsp,ci))) (************************************************************************) (************************************************************************) (* Guard conditions for fix and cofix-points *) (* Check if t is a subterm of Rel n, and gives its specification, assuming lst already gives index of subterms with corresponding specifications of recursive arguments *) (* A powerful notion of subterm *) (* To each inductive definition corresponds an array describing the structure of recursive arguments for each constructor, we call it the recursive spec of the type (it has type recargs vect). For checking the guard, we start from the decreasing argument (Rel n) with its recursive spec. During checking the guardness condition, we collect patterns variables corresponding to subterms of n, each of them with its recursive spec. They are organised in a list lst of type (int * recargs) list which is sorted with respect to the first argument. *) (*************************************************************) (* Environment annotated with marks on recursive arguments *) (* tells whether it is a strict or loose subterm *) type size = Large | Strict (* merging information *) let size_glb s1 s2 = match s1,s2 with Strict, Strict -> Strict | _ -> Large (* possible specifications for a term: - Not_subterm: when the size of a term is not related to the recursive argument of the fixpoint - Subterm: when the term is a subterm of the recursive argument the wf_paths argument specifies which subterms are recursive - Dead_code: when the term has been built by elimination over an empty type *) type subterm_spec = Subterm of (size * wf_paths) | Dead_code | Not_subterm let spec_of_tree t = lazy (if Rtree.eq_rtree (=) (Lazy.force t) mk_norec then Not_subterm else Subterm(Strict,Lazy.force t)) let subterm_spec_glb = let glb2 s1 s2 = match s1,s2 with _, Dead_code -> s1 | Dead_code, _ -> s2 | Not_subterm, _ -> Not_subterm | _, Not_subterm -> Not_subterm | Subterm (a1,t1), Subterm (a2,t2) -> if Rtree.eq_rtree (=) t1 t2 then Subterm (size_glb a1 a2, t1) (* branches do not return objects with same spec *) else Not_subterm in Array.fold_left glb2 Dead_code type guard_env = { env : env; (* dB of last fixpoint *) rel_min : int; (* inductive of recarg of each fixpoint *) inds : inductive array; (* the recarg information of inductive family *) recvec : wf_paths array; (* dB of variables denoting subterms *) genv : subterm_spec Lazy.t list; } let make_renv env minds recarg (kn,tyi) = let mib = lookup_mind kn env in let mind_recvec = Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in { env = env; rel_min = recarg+2; inds = minds; recvec = mind_recvec; genv = [Lazy.lazy_from_val(Subterm(Large,mind_recvec.(tyi)))] } let push_var renv (x,ty,spec) = { renv with env = push_rel (x,None,ty) renv.env; rel_min = renv.rel_min+1; genv = spec:: renv.genv } let assign_var_spec renv (i,spec) = { renv with genv = list_assign renv.genv (i-1) spec } let push_var_renv renv (x,ty) = push_var renv (x,ty,Lazy.lazy_from_val Not_subterm) (* Fetch recursive information about a variable p *) let subterm_var p renv = try Lazy.force (List.nth renv.genv (p-1)) with Failure _ | Invalid_argument _ -> Not_subterm let push_ctxt_renv renv ctxt = let n = rel_context_length ctxt in { renv with env = push_rel_context ctxt renv.env; rel_min = renv.rel_min+n; genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv } let push_fix_renv renv (_,v,_ as recdef) = let n = Array.length v in { renv with env = push_rec_types recdef renv.env; rel_min = renv.rel_min+n; genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv } (* Definition and manipulation of the stack *) type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t let push_stack_closures renv l stack = List.fold_right (fun h b -> (SClosure (renv,h))::b) l stack let push_stack_args l stack = List.fold_right (fun h b -> (SArg h)::b) l stack (******************************) (* Computing the recursive subterms of a term (propagation of size information through Cases). *) (* c is a branch of an inductive definition corresponding to the spec lrec. mind_recvec is the recursive spec of the inductive definition of the decreasing argument n. case_branches_specif renv lrec lc will pass the lambdas of c corresponding to pattern variables and collect possibly new subterms variables and returns the bodies of the branches with the correct envs and decreasing args. *) let lookup_subterms env ind = let (_,mip) = lookup_mind_specif env ind in mip.mind_recargs let match_inductive ind ra = match ra with | (Mrec i | Imbr i) -> eq_ind ind i | Norec -> false (* In {match c as z in ci y_s return P with |C_i x_s => t end} [branches_specif renv c_spec ci] returns an array of x_s specs knowing c_spec. *) let branches_specif renv c_spec ci = let car = (* We fetch the regular tree associated to the inductive of the match. This is just to get the number of constructors (and constructor arities) that fit the match branches without forcing c_spec. Note that c_spec might be more precise than [v] below, because of nested inductive types. *) let (_,mip) = lookup_mind_specif renv.env ci.ci_ind in let v = dest_subterms mip.mind_recargs in Array.map List.length v in Array.mapi (fun i nca -> (* i+1-th cstructor has arity nca *) let lvra = lazy (match Lazy.force c_spec with Subterm (_,t) when match_inductive ci.ci_ind (dest_recarg t) -> let vra = Array.of_list (dest_subterms t).(i) in assert (nca = Array.length vra); Array.map (fun t -> Lazy.force (spec_of_tree (lazy t))) vra | Dead_code -> Array.create nca Dead_code | _ -> Array.create nca Not_subterm) in list_tabulate (fun j -> lazy (Lazy.force lvra).(j)) nca) car (* [subterm_specif renv t] computes the recursive structure of [t] and compare its size with the size of the initial recursive argument of the fixpoint we are checking. [renv] collects such information about variables. *) let rec subterm_specif renv stack t = (* maybe reduction is not always necessary! *) let f,l = decompose_app (whd_betadeltaiota renv.env t) in match f with | Rel k -> subterm_var k renv | Case (ci,_,c,lbr) -> let stack' = push_stack_closures renv l stack in let cases_spec = branches_specif renv (lazy_subterm_specif renv [] c) ci in let stl = Array.mapi (fun i br' -> let stack_br = push_stack_args (cases_spec.(i)) stack' in subterm_specif renv stack_br br') lbr in subterm_spec_glb stl | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> (* when proving that the fixpoint f(x)=e is less than n, it is enough to prove that e is less than n assuming f is less than n furthermore when f is applied to a term which is strictly less than n, one may assume that x itself is strictly less than n *) let (ctxt,clfix) = dest_prod renv.env typarray.(i) in let oind = let env' = push_rel_context ctxt renv.env in try Some(fst(find_inductive env' clfix)) with Not_found -> None in (match oind with None -> Not_subterm (* happens if fix is polymorphic *) | Some ind -> let nbfix = Array.length typarray in let recargs = lookup_subterms renv.env ind in (* pushing the fixpoints *) let renv' = push_fix_renv renv recdef in let renv' = (* Why Strict here ? To be general, it could also be Large... *) assign_var_spec renv' (nbfix-i, lazy (Subterm(Strict,recargs))) in let decrArg = recindxs.(i) in let theBody = bodies.(i) in let nbOfAbst = decrArg+1 in let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in (* pushing the fix parameters *) let stack' = push_stack_closures renv l stack in let renv'' = push_ctxt_renv renv' sign in let renv'' = if List.length stack' < nbOfAbst then renv'' else let decrArg = List.nth stack' decrArg in let arg_spec = stack_element_specif decrArg in assign_var_spec renv'' (1, arg_spec) in subterm_specif renv'' [] strippedBody) | Lambda (x,a,b) -> assert (l=[]); let spec,stack' = extract_stack renv a stack in subterm_specif (push_var renv (x,a,spec)) stack' b (* Metas and evars are considered OK *) | (Meta _|Evar _) -> Dead_code (* Other terms are not subterms *) | _ -> Not_subterm and lazy_subterm_specif renv stack t = lazy (subterm_specif renv stack t) and stack_element_specif = function |SClosure (h_renv,h) -> lazy_subterm_specif h_renv [] h |SArg x -> x and extract_stack renv a = function | [] -> Lazy.lazy_from_val Not_subterm , [] | h::t -> stack_element_specif h, t (* Check size x is a correct size for recursive calls. *) let check_is_subterm x = match Lazy.force x with Subterm (Strict,_) | Dead_code -> true | _ -> false (************************************************************************) exception FixGuardError of env * guard_error let error_illegal_rec_call renv fx (arg_renv,arg) = let (_,le_vars,lt_vars) = List.fold_left (fun (i,le,lt) sbt -> match Lazy.force sbt with (Subterm(Strict,_) | Dead_code) -> (i+1, le, i::lt) | (Subterm(Large,_)) -> (i+1, i::le, lt) | _ -> (i+1, le ,lt)) (1,[],[]) renv.genv in raise (FixGuardError (renv.env, RecursionOnIllegalTerm(fx,(arg_renv.env, arg), le_vars,lt_vars))) let error_partial_apply renv fx = raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx)) (* Check if [def] is a guarded fixpoint body with decreasing arg. given [recpos], the decreasing arguments of each mutually defined fixpoint. *) let check_one_fix renv recpos def = let nfi = Array.length recpos in (* Checks if [t] only make valid recursive calls *) let rec check_rec_call renv stack t = (* if [t] does not make recursive calls, it is guarded: *) if noccur_with_meta renv.rel_min nfi t then () else let (f,l) = decompose_app (whd_betaiotazeta t) in match f with | Rel p -> (* Test if [p] is a fixpoint (recursive call) *) if renv.rel_min <= p & p < renv.rel_min+nfi then begin List.iter (check_rec_call renv []) l; (* the position of the invoked fixpoint: *) let glob = renv.rel_min+nfi-1-p in (* the decreasing arg of the rec call: *) let np = recpos.(glob) in let stack' = push_stack_closures renv l stack in if List.length stack' <= np then error_partial_apply renv glob else (* Check the decreasing arg is smaller *) let z = List.nth stack' np in if not (check_is_subterm (stack_element_specif z)) then begin match z with |SClosure (z,z') -> error_illegal_rec_call renv glob (z,z') |SArg _ -> error_partial_apply renv glob end end else begin match pi2 (lookup_rel p renv.env) with | None -> List.iter (check_rec_call renv []) l | Some c -> try List.iter (check_rec_call renv []) l with FixGuardError _ -> check_rec_call renv stack (applist(lift p c,l)) end | Case (ci,p,c_0,lrest) -> List.iter (check_rec_call renv []) (c_0::p::l); (* compute the recarg information for the arguments of each branch *) let case_spec = branches_specif renv (lazy_subterm_specif renv [] c_0) ci in let stack' = push_stack_closures renv l stack in Array.iteri (fun k br' -> let stack_br = push_stack_args case_spec.(k) stack' in check_rec_call renv stack_br br') lrest (* Enables to traverse Fixpoint definitions in a more intelligent way, ie, the rule : if - g = fix g (y1:T1)...(yp:Tp) {struct yp} := e & - f is guarded with respect to the set of pattern variables S in a1 ... am & - f is guarded with respect to the set of pattern variables S in T1 ... Tp & - ap is a sub-term of the formal argument of f & - f is guarded with respect to the set of pattern variables S+{yp} in e then f is guarded with respect to S in (g a1 ... am). Eduardo 7/9/98 *) | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> List.iter (check_rec_call renv []) l; Array.iter (check_rec_call renv []) typarray; let decrArg = recindxs.(i) in let renv' = push_fix_renv renv recdef in let stack' = push_stack_closures renv l stack in Array.iteri (fun j body -> if i=j && (List.length stack' > decrArg) then let recArg = List.nth stack' decrArg in let arg_sp = stack_element_specif recArg in check_nested_fix_body renv' (decrArg+1) arg_sp body else check_rec_call renv' [] body) bodies | Const kn -> if evaluable_constant kn renv.env then try List.iter (check_rec_call renv []) l with (FixGuardError _ ) -> let value = (applist(constant_value renv.env kn, l)) in check_rec_call renv stack value else List.iter (check_rec_call renv []) l | Lambda (x,a,b) -> assert (l = []); check_rec_call renv [] a ; let spec, stack' = extract_stack renv a stack in check_rec_call (push_var renv (x,a,spec)) stack' b | Prod (x,a,b) -> assert (l = [] && stack = []); check_rec_call renv [] a; check_rec_call (push_var_renv renv (x,a)) [] b | CoFix (i,(_,typarray,bodies as recdef)) -> List.iter (check_rec_call renv []) l; Array.iter (check_rec_call renv []) typarray; let renv' = push_fix_renv renv recdef in Array.iter (check_rec_call renv' []) bodies | (Ind _ | Construct _) -> List.iter (check_rec_call renv []) l | Var id -> begin match pi2 (lookup_named id renv.env) with | None -> List.iter (check_rec_call renv []) l | Some c -> try List.iter (check_rec_call renv []) l with (FixGuardError _) -> check_rec_call renv stack (applist(c,l)) end | Sort _ -> assert (l = []) (* l is not checked because it is considered as the meta's context *) | (Evar _ | Meta _) -> () | (App _ | LetIn _ | Cast _) -> assert false (* beta zeta reduction *) and check_nested_fix_body renv decr recArgsDecrArg body = if decr = 0 then check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) [] body else match body with | Lambda (x,a,b) -> check_rec_call renv [] a; let renv' = push_var_renv renv (x,a) in check_nested_fix_body renv' (decr-1) recArgsDecrArg b | _ -> anomaly "Not enough abstractions in fix body" in check_rec_call renv [] def let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = let nbfix = Array.length bodies in if nbfix = 0 or Array.length nvect <> nbfix or Array.length types <> nbfix or Array.length names <> nbfix or bodynum < 0 or bodynum >= nbfix then anomaly "Ill-formed fix term"; let fixenv = push_rec_types recdef env in let raise_err env i err = error_ill_formed_rec_body env err names i in (* Check the i-th definition with recarg k *) let find_ind i k def = (* check fi does not appear in the k+1 first abstractions, gives the type of the k+1-eme abstraction (must be an inductive) *) let rec check_occur env n def = match (whd_betadeltaiota env def) with | Lambda (x,a,b) -> if noccur_with_meta n nbfix a then let env' = push_rel (x, None, a) env in if n = k+1 then (* get the inductive type of the fixpoint *) let (mind, _) = try find_inductive env a with Not_found -> raise_err env i (RecursionNotOnInductiveType a) in (mind, (env', b)) else check_occur env' (n+1) b else anomaly "check_one_fix: Bad occurrence of recursive call" | _ -> raise_err env i NotEnoughAbstractionInFixBody in check_occur fixenv 1 def in (* Do it on every fixpoint *) let rv = array_map2_i find_ind nvect bodies in (Array.map fst rv, Array.map snd rv) let check_fix env ((nvect,_),(names,_,bodies as _recdef) as fix) = let (minds, rdef) = inductive_of_mutfix env fix in for i = 0 to Array.length bodies - 1 do let (fenv,body) = rdef.(i) in let renv = make_renv fenv minds nvect.(i) minds.(i) in try check_one_fix renv nvect body with FixGuardError (fixenv,err) -> error_ill_formed_rec_body fixenv err names i done (* let cfkey = Profile.declare_profile "check_fix";; let check_fix env fix = Profile.profile3 cfkey check_fix env fix;; *) (************************************************************************) (* Co-fixpoints. *) exception CoFixGuardError of env * guard_error let anomaly_ill_typed () = anomaly "check_one_cofix: too many arguments applied to constructor" let rec codomain_is_coind env c = let b = whd_betadeltaiota env c in match b with | Prod (x,a,b) -> codomain_is_coind (push_rel (x, None, a) env) b | _ -> (try find_coinductive env b with Not_found -> raise (CoFixGuardError (env, CodomainNotInductiveType b))) let check_one_cofix env nbfix def deftype = let rec check_rec_call env alreadygrd n vlra t = if not (noccur_with_meta n nbfix t) then let c,args = decompose_app (whd_betadeltaiota env t) in match c with | Rel p when n <= p && p < n+nbfix -> (* recursive call: must be guarded and no nested recursive call allowed *) if not alreadygrd then raise (CoFixGuardError (env,UnguardedRecursiveCall t)) else if not(List.for_all (noccur_with_meta n nbfix) args) then raise (CoFixGuardError (env,NestedRecursiveOccurrences)) | Construct (_,i as cstr_kn) -> let lra = vlra.(i-1) in let mI = inductive_of_constructor cstr_kn in let (mib,mip) = lookup_mind_specif env mI in let realargs = list_skipn mib.mind_nparams args in let rec process_args_of_constr = function | (t::lr), (rar::lrar) -> if rar = mk_norec then if noccur_with_meta n nbfix t then process_args_of_constr (lr, lrar) else raise (CoFixGuardError (env,RecCallInNonRecArgOfConstructor t)) else let spec = dest_subterms rar in check_rec_call env true n spec t; process_args_of_constr (lr, lrar) | [],_ -> () | _ -> anomaly_ill_typed () in process_args_of_constr (realargs, lra) | Lambda (x,a,b) -> assert (args = []); if noccur_with_meta n nbfix a then let env' = push_rel (x, None, a) env in check_rec_call env' alreadygrd (n+1) vlra b else raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a)) | CoFix (j,(_,varit,vdefs as recdef)) -> if List.for_all (noccur_with_meta n nbfix) args then if array_for_all (noccur_with_meta n nbfix) varit then let nbfix = Array.length vdefs in let env' = push_rec_types recdef env in (Array.iter (check_rec_call env' alreadygrd (n+nbfix) vlra) vdefs; List.iter (check_rec_call env alreadygrd n vlra) args) else raise (CoFixGuardError (env,RecCallInTypeOfDef c)) else raise (CoFixGuardError (env,UnguardedRecursiveCall c)) | Case (_,p,tm,vrest) -> if (noccur_with_meta n nbfix p) then if (noccur_with_meta n nbfix tm) then if (List.for_all (noccur_with_meta n nbfix) args) then Array.iter (check_rec_call env alreadygrd n vlra) vrest else raise (CoFixGuardError (env,RecCallInCaseFun c)) else raise (CoFixGuardError (env,RecCallInCaseArg c)) else raise (CoFixGuardError (env,RecCallInCasePred c)) | Meta _ -> () | Evar _ -> List.iter (check_rec_call env alreadygrd n vlra) args | _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in let (mind, _) = codomain_is_coind env deftype in let vlra = lookup_subterms env mind in check_rec_call env false 1 (dest_subterms vlra) def (* The function which checks that the whole block of definitions satisfies the guarded condition *) let check_cofix env (bodynum,(names,types,bodies as recdef)) = let nbfix = Array.length bodies in for i = 0 to nbfix-1 do let fixenv = push_rec_types recdef env in try check_one_cofix fixenv nbfix bodies.(i) types.(i) with CoFixGuardError (errenv,err) -> error_ill_formed_rec_body errenv err names i done coq-8.4pl4/checker/environ.ml0000644000175000017500000001413512326224777015255 0ustar stephstephopen Util open Names open Univ open Term open Declarations type globals = { env_constants : constant_body Cmap_env.t; env_inductives : mutual_inductive_body Mindmap_env.t; env_inductives_eq : kernel_name KNmap.t; env_modules : module_body MPmap.t; env_modtypes : module_type_body MPmap.t} type stratification = { env_universes : universes; env_engagement : engagement option } type env = { env_globals : globals; env_named_context : named_context; env_rel_context : rel_context; env_stratification : stratification; env_imports : Digest.t MPmap.t } let empty_env = { env_globals = { env_constants = Cmap_env.empty; env_inductives = Mindmap_env.empty; env_inductives_eq = KNmap.empty; env_modules = MPmap.empty; env_modtypes = MPmap.empty}; env_named_context = []; env_rel_context = []; env_stratification = { env_universes = Univ.initial_universes; env_engagement = None}; env_imports = MPmap.empty } let engagement env = env.env_stratification.env_engagement let universes env = env.env_stratification.env_universes let named_context env = env.env_named_context let rel_context env = env.env_rel_context let set_engagement c env = match env.env_stratification.env_engagement with | Some c' -> if c=c' then env else error "Incompatible engagement" | None -> { env with env_stratification = { env.env_stratification with env_engagement = Some c } } (* Digests *) let add_digest env dp digest = { env with env_imports = MPmap.add (MPfile dp) digest env.env_imports } let lookup_digest env dp = MPmap.find (MPfile dp) env.env_imports (* Rel context *) let lookup_rel n env = let rec lookup_rel n sign = match n, sign with | 1, decl :: _ -> decl | n, _ :: sign -> lookup_rel (n-1) sign | _, [] -> raise Not_found in lookup_rel n env.env_rel_context let push_rel d env = { env with env_rel_context = d :: env.env_rel_context } let push_rel_context ctxt x = fold_rel_context push_rel ctxt ~init:x let push_rec_types (lna,typarray,_) env = let ctxt = array_map2_i (fun i na t -> (na, None, lift i t)) lna typarray in Array.fold_left (fun e assum -> push_rel assum e) env ctxt (* Named context *) let push_named d env = (* if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context); assert (env.env_rel_context = []); *) { env with env_named_context = d :: env.env_named_context } let lookup_named id env = let rec lookup_named id = function | (id',_,_ as decl) :: _ when id=id' -> decl | _ :: sign -> lookup_named id sign | [] -> raise Not_found in lookup_named id env.env_named_context (* A local const is evaluable if it is defined *) let named_type id env = let (_,_,t) = lookup_named id env in t (* Universe constraints *) let add_constraints c env = if c == empty_constraint then env else let s = env.env_stratification in { env with env_stratification = { s with env_universes = merge_constraints c s.env_universes } } (* Global constants *) let lookup_constant kn env = Cmap_env.find kn env.env_globals.env_constants let add_constant kn cs env = if Cmap_env.mem kn env.env_globals.env_constants then Printf.ksprintf anomaly "Constant %s is already defined" (string_of_con kn); let new_constants = Cmap_env.add kn cs env.env_globals.env_constants in let new_globals = { env.env_globals with env_constants = new_constants } in { env with env_globals = new_globals } type const_evaluation_result = NoBody | Opaque exception NotEvaluableConst of const_evaluation_result let constant_value env kn = let cb = lookup_constant kn env in match cb.const_body with | Def l_body -> force_constr l_body | OpaqueDef _ -> raise (NotEvaluableConst Opaque) | Undef _ -> raise (NotEvaluableConst NoBody) (* A global const is evaluable if it is defined and not opaque *) let evaluable_constant cst env = try let _ = constant_value env cst in true with Not_found | NotEvaluableConst _ -> false (* Mutual Inductives *) let scrape_mind env kn= try KNmap.find kn env.env_globals.env_inductives_eq with Not_found -> kn let mind_equiv env (kn1,i1) (kn2,i2) = i1 = i2 && scrape_mind env (user_mind kn1) = scrape_mind env (user_mind kn2) let lookup_mind kn env = Mindmap_env.find kn env.env_globals.env_inductives let add_mind kn mib env = if Mindmap_env.mem kn env.env_globals.env_inductives then Printf.ksprintf anomaly "Inductive %s is already defined" (string_of_mind kn); let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in let kn1,kn2 = user_mind kn,canonical_mind kn in let new_inds_eq = if kn1=kn2 then env.env_globals.env_inductives_eq else KNmap.add kn1 kn2 env.env_globals.env_inductives_eq in let new_globals = { env.env_globals with env_inductives = new_inds; env_inductives_eq = new_inds_eq} in { env with env_globals = new_globals } (* Modules *) let add_modtype ln mtb env = if MPmap.mem ln env.env_globals.env_modtypes then Printf.ksprintf anomaly "Module type %s is already defined" (string_of_mp ln); let new_modtypes = MPmap.add ln mtb env.env_globals.env_modtypes in let new_globals = { env.env_globals with env_modtypes = new_modtypes } in { env with env_globals = new_globals } let shallow_add_module mp mb env = if MPmap.mem mp env.env_globals.env_modules then Printf.ksprintf anomaly "Module %s is already defined" (string_of_mp mp); let new_mods = MPmap.add mp mb env.env_globals.env_modules in let new_globals = { env.env_globals with env_modules = new_mods } in { env with env_globals = new_globals } let shallow_remove_module mp env = if not (MPmap.mem mp env.env_globals.env_modules) then Printf.ksprintf anomaly "Module %s is unknown" (string_of_mp mp); let new_mods = MPmap.remove mp env.env_globals.env_modules in let new_globals = { env.env_globals with env_modules = new_mods } in { env with env_globals = new_globals } let lookup_module mp env = MPmap.find mp env.env_globals.env_modules let lookup_modtype ln env = MPmap.find ln env.env_globals.env_modtypes coq-8.4pl4/checker/mod_checking.ml0000644000175000017500000003106512326224777016210 0ustar stephsteph open Pp open Util open Names open Term open Inductive open Reduction open Typeops open Indtypes open Modops open Subtyping open Declarations open Environ (************************************************************************) (* Checking constants *) let refresh_arity ar = let ctxt, hd = decompose_prod_assum ar in match hd with Sort (Type u) when not (Univ.is_univ_variable u) -> let u' = Univ.fresh_local_univ() in mkArity (ctxt,Type u'), Univ.enforce_geq u' u Univ.empty_constraint | _ -> ar, Univ.empty_constraint let check_constant_declaration env kn cb = Flags.if_verbose msgnl (str " checking cst: " ++ prcon kn); (* let env = add_constraints cb.const_constraints env in*) let env' = check_named_ctxt env cb.const_hyps in (match cb.const_type with NonPolymorphicType ty -> let ty, cu = refresh_arity ty in let envty = add_constraints cu env' in let _ = infer_type envty ty in (match body_of_constant cb with | Some bd -> let j = infer env' (force_constr bd) in conv_leq envty j ty | None -> ()) | PolymorphicArity(ctxt,par) -> let _ = check_ctxt env ctxt in check_polymorphic_arity env ctxt par); add_constant kn cb env (************************************************************************) (* Checking modules *) exception Not_path let path_of_mexpr = function | SEBident mp -> mp | _ -> raise Not_path let is_modular = function | SFBmodule _ | SFBmodtype _ -> true | SFBconst _ | SFBmind _ -> false let rec list_split_assoc ((k,m) as km) rev_before = function | [] -> raise Not_found | (k',b)::after when k=k' && is_modular b = m -> rev_before,b,after | h::tail -> list_split_assoc km (h::rev_before) tail let check_definition_sub env cb1 cb2 = let check_type env t1 t2 = (* If the type of a constant is generated, it may mention non-variable algebraic universes that the general conversion algorithm is not ready to handle. Anyway, generated types of constants are functions of the body of the constant. If the bodies are the same in environments that are subtypes one of the other, the types are subtypes too (i.e. if Gamma <= Gamma', Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T'). Hence they don't have to be checked again *) let t1,t2 = if isArity t2 then let (ctx2,s2) = destArity t2 in match s2 with | Type v when not (Univ.is_univ_variable v) -> (* The type in the interface is inferred and is made of algebraic universes *) begin try let (ctx1,s1) = dest_arity env t1 in match s1 with | Type u when not (Univ.is_univ_variable u) -> (* Both types are inferred, no need to recheck them. We cheat and collapse the types to Prop *) mkArity (ctx1,Prop Null), mkArity (ctx2,Prop Null) | Prop _ -> (* The type in the interface is inferred, it may be the case that the type in the implementation is smaller because the body is more reduced. We safely collapse the upper type to Prop *) mkArity (ctx1,Prop Null), mkArity (ctx2,Prop Null) | Type _ -> (* The type in the interface is inferred and the type in the implementation is not inferred or is inferred but from a more reduced body so that it is just a variable. Since constraints of the form "univ <= max(...)" are not expressible in the system of algebraic universes: we fail (the user has to use an explicit type in the interface *) raise Reduction.NotConvertible with UserError _ (* "not an arity" *) -> raise Reduction.NotConvertible end | _ -> t1,t2 else (t1,t2) in Reduction.conv_leq env t1 t2 in assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ; (*Start by checking types*) let typ1 = Typeops.type_of_constant_type env cb1.const_type in let typ2 = Typeops.type_of_constant_type env cb2.const_type in check_type env typ1 typ2; (* In the spirit of subtyping.check_constant, we accept any implementations of parameters and opaques terms, as long as they have the right type *) (match cb2.const_body with | Undef _ | OpaqueDef _ -> () | Def lc2 -> (match cb1.const_body with | Def lc1 -> let c1 = force_constr lc1 in let c2 = force_constr lc2 in Reduction.conv env c1 c2 (* Coq only places transparent cb in With_definition_body *) | _ -> assert false)) let lookup_modtype mp env = try Environ.lookup_modtype mp env with Not_found -> failwith ("Unknown module type: "^string_of_mp mp) let lookup_module mp env = try Environ.lookup_module mp env with Not_found -> failwith ("Unknown module: "^string_of_mp mp) let rec check_with env mtb with_decl mp= match with_decl with | With_definition_body (idl,c) -> check_with_def env mtb (idl,c) mp; mtb | With_module_body (idl,mp1) -> check_with_mod env mtb (idl,mp1) mp; mtb and check_with_def env mtb (idl,c) mp = let sig_b = match mtb with | SEBstruct(sig_b) -> sig_b | _ -> error_signature_expected mtb in let id,idl = match idl with | [] -> assert false | id::idl -> id,idl in let l = label_of_id id in try let rev_before,spec,after = list_split_assoc (l,(idl<>[])) [] sig_b in let before = List.rev rev_before in let env' = Modops.add_signature mp before empty_delta_resolver env in if idl = [] then let cb = match spec with SFBconst cb -> cb | _ -> error_not_a_constant l in check_definition_sub env' c cb else let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module l in begin match old.mod_expr with | None -> check_with_def env' old.mod_type (idl,c) (MPdot(mp,l)) | Some msb -> error_a_generative_module_expected l end with Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_with_incorrect l and check_with_mod env mtb (idl,mp1) mp = let sig_b = match mtb with | SEBstruct(sig_b) -> sig_b | _ -> error_signature_expected mtb in let id,idl = match idl with | [] -> assert false | id::idl -> id,idl in let l = label_of_id id in try let rev_before,spec,after = list_split_assoc (l,false) [] sig_b in let before = List.rev rev_before in let env' = Modops.add_signature mp before empty_delta_resolver env in if idl = [] then let _ = match spec with SFBmodule msb -> msb | _ -> error_not_a_module l in let (_:module_body) = (Environ.lookup_module mp1 env) in () else let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module l in begin match old.mod_expr with None -> check_with_mod env' old.mod_type (idl,mp1) (MPdot(mp,l)) | Some msb -> error_a_generative_module_expected l end with Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_with_incorrect l and check_module_type env mty = let (_:struct_expr_body) = check_modtype env mty.typ_expr mty.typ_mp mty.typ_delta in () and check_module env mp mb = match mb.mod_expr, mb.mod_type with | None,mtb -> let (_:struct_expr_body) = check_modtype env mtb mb.mod_mp mb.mod_delta in () | Some mexpr, mtb when mtb==mexpr -> let (_:struct_expr_body) = check_modtype env mtb mb.mod_mp mb.mod_delta in () | Some mexpr, _ -> let sign = check_modexpr env mexpr mb.mod_mp mb.mod_delta in let (_:struct_expr_body) = check_modtype env mb.mod_type mb.mod_mp mb.mod_delta in let mtb1 = {typ_mp=mp; typ_expr=sign; typ_expr_alg=None; typ_constraints=Univ.empty_constraint; typ_delta = mb.mod_delta;} and mtb2 = {typ_mp=mp; typ_expr=mb.mod_type; typ_expr_alg=None; typ_constraints=Univ.empty_constraint; typ_delta = mb.mod_delta;} in let env = add_module (module_body_of_type mp mtb1) env in check_subtypes env mtb1 mtb2 and check_structure_field env mp lab res = function | SFBconst cb -> let c = make_con mp empty_dirpath lab in check_constant_declaration env c cb | SFBmind mib -> let kn = make_mind mp empty_dirpath lab in let kn = mind_of_delta res kn in Indtypes.check_inductive env kn mib | SFBmodule msb -> let (_:unit) = check_module env (MPdot(mp,lab)) msb in Modops.add_module msb env | SFBmodtype mty -> check_module_type env mty; add_modtype (MPdot(mp,lab)) mty env and check_modexpr env mse mp_mse res = match mse with | SEBident mp -> let mb = lookup_module mp env in (subst_and_strengthen mb mp_mse).mod_type | SEBfunctor (arg_id, mtb, body) -> check_module_type env mtb ; let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in let sign = check_modexpr env' body mp_mse res in SEBfunctor (arg_id, mtb, sign) | SEBapply (f,m,cst) -> let sign = check_modexpr env f mp_mse res in let farg_id, farg_b, fbody_b = destr_functor env sign in let mp = try (path_of_mexpr m) with Not_path -> error_application_to_not_path m (* place for nondep_supertype *) in let mtb = module_type_of_module (Some mp) (lookup_module mp env) in check_subtypes env mtb farg_b; (subst_struct_expr (map_mbid farg_id mp) fbody_b) | SEBwith(mte, with_decl) -> let sign = check_modexpr env mte mp_mse res in let sign = check_with env sign with_decl mp_mse in sign | SEBstruct(msb) -> let (_:env) = List.fold_left (fun env (lab,mb) -> check_structure_field env mp_mse lab res mb) env msb in SEBstruct(msb) and check_modtype env mse mp_mse res = match mse with | SEBident mp -> let mtb = lookup_modtype mp env in mtb.typ_expr | SEBfunctor (arg_id, mtb, body) -> check_module_type env mtb; let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in let body = check_modtype env' body mp_mse res in SEBfunctor(arg_id,mtb,body) | SEBapply (f,m,cst) -> let sign = check_modtype env f mp_mse res in let farg_id, farg_b, fbody_b = destr_functor env sign in let mp = try (path_of_mexpr m) with Not_path -> error_application_to_not_path m (* place for nondep_supertype *) in let mtb = module_type_of_module (Some mp) (lookup_module mp env) in check_subtypes env mtb farg_b; subst_struct_expr (map_mbid farg_id mp) fbody_b | SEBwith(mte, with_decl) -> let sign = check_modtype env mte mp_mse res in let sign = check_with env sign with_decl mp_mse in sign | SEBstruct(msb) -> let (_:env) = List.fold_left (fun env (lab,mb) -> check_structure_field env mp_mse lab res mb) env msb in SEBstruct(msb) (* let rec add_struct_expr_constraints env = function | SEBident _ -> env | SEBfunctor (_,mtb,meb) -> add_struct_expr_constraints (add_modtype_constraints env mtb) meb | SEBstruct (_,structure_body) -> List.fold_left (fun env (l,item) -> add_struct_elem_constraints env item) env structure_body | SEBapply (meb1,meb2,cst) -> (* let g = Univ.merge_constraints cst Univ.initial_universes in msgnl(str"ADDING FUNCTOR APPLICATION CONSTRAINTS:"++fnl()++ Univ.pr_universes g++str"============="++fnl()); *) Environ.add_constraints cst (add_struct_expr_constraints (add_struct_expr_constraints env meb1) meb2) | SEBwith(meb,With_definition_body(_,cb))-> Environ.add_constraints cb.const_constraints (add_struct_expr_constraints env meb) | SEBwith(meb,With_module_body(_,_,cst))-> Environ.add_constraints cst (add_struct_expr_constraints env meb) and add_struct_elem_constraints env = function | SFBconst cb -> Environ.add_constraints cb.const_constraints env | SFBmind mib -> Environ.add_constraints mib.mind_constraints env | SFBmodule mb -> add_module_constraints env mb | SFBalias (mp,Some cst) -> Environ.add_constraints cst env | SFBalias (mp,None) -> env | SFBmodtype mtb -> add_modtype_constraints env mtb and add_module_constraints env mb = let env = match mb.mod_expr with | None -> env | Some meb -> add_struct_expr_constraints env meb in let env = match mb.mod_type with | None -> env | Some mtb -> add_struct_expr_constraints env mtb in Environ.add_constraints mb.mod_constraints env and add_modtype_constraints env mtb = add_struct_expr_constraints env mtb.typ_expr *) coq-8.4pl4/checker/subtyping.ml0000644000175000017500000003370512326224777015625 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Labmap.add (label_of_id id) (IndConstr((ip,i+1), mib)) map) oib.mind_consnames map in Labmap.add (label_of_id oib.mind_typename) (IndType (ip, mib)) map in array_fold_right_i add_mip_nameobjects mib.mind_packets map (* creates (namedobject/namedmodule) map for the whole signature *) type labmap = { objs : namedobject Labmap.t; mods : namedmodule Labmap.t } let empty_labmap = { objs = Labmap.empty; mods = Labmap.empty } let get_obj mp map l = try Labmap.find l map.objs with Not_found -> error_no_such_label_sub l mp let get_mod mp map l = try Labmap.find l map.mods with Not_found -> error_no_such_label_sub l mp let make_labmap mp list = let add_one (l,e) map = match e with | SFBconst cb -> { map with objs = Labmap.add l (Constant cb) map.objs } | SFBmind mib -> { map with objs = add_mib_nameobjects mp l mib map.objs } | SFBmodule mb -> { map with mods = Labmap.add l (Module mb) map.mods } | SFBmodtype mtb -> { map with mods = Labmap.add l (Modtype mtb) map.mods } in List.fold_right add_one list empty_labmap let check_conv_error error f env a1 a2 = try f env a1 a2 with NotConvertible -> error () (* for now we do not allow reorderings *) let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= let kn = make_mind mp1 empty_dirpath l in let error () = error_not_match l spec2 in let check_conv f = check_conv_error error f in let mib1 = match info1 with | IndType ((_,0), mib) -> mib | _ -> error () in let mib2 = subst_mind subst2 mib2 in let check_inductive_type env t1 t2 = (* Due to sort-polymorphism in inductive types, the conclusions of t1 and t2, if in Type, are generated as the least upper bounds of the types of the constructors. By monotonicity of the infered l.u.b. wrt subtyping (i.e. if X:U |- T(X):s and |- M:U' and U'<=U then infer_type(T(M))<=s), each universe in the conclusion of t1 has an bounding universe in the conclusion of t2, so that we don't need to check the subtyping of the conclusions of t1 and t2. Even if we'd like to recheck it, the inference of constraints is not designed to deal with algebraic constraints of the form max-univ(u1..un) <= max-univ(u'1..u'n), so that it is not easy to recheck it (in short, we would need the actual graph of constraints as input while type checking is currently designed to output a set of constraints instead) *) (* So we cheat and replace the subtyping problem on algebraic constraints of the form max-univ(u1..un) <= max-univ(u'1..u'n) (that we know are necessary true) by trivial constraints that the constraint generator knows how to deal with *) let (ctx1,s1) = dest_arity env t1 in let (ctx2,s2) = dest_arity env t2 in let s1,s2 = match s1, s2 with | Type _, Type _ -> (* shortcut here *) Prop Null, Prop Null | (Prop _, Type _) | (Type _,Prop _) -> error () | _ -> (s1, s2) in check_conv conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) in let check_packet p1 p2 = let check f = if f p1 <> f p2 then error () in check (fun p -> p.mind_consnames); check (fun p -> p.mind_typename); (* nf_lc later *) (* nf_arity later *) (* user_lc ignored *) (* user_arity ignored *) check (fun p -> p.mind_nrealargs); (* kelim ignored *) (* listrec ignored *) (* finite done *) (* nparams done *) (* params_ctxt done because part of the inductive types *) (* Don't check the sort of the type if polymorphic *) check_inductive_type env (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2)) in let check_cons_types i p1 p2 = array_iter2 (check_conv conv env) (arities_of_specif kn (mib1,p1)) (arities_of_specif kn (mib2,p2)) in let check f = if f mib1 <> f mib2 then error () in check (fun mib -> mib.mind_finite); check (fun mib -> mib.mind_ntypes); assert (mib1.mind_hyps=[] && mib2.mind_hyps=[]); assert (Array.length mib1.mind_packets >= 1 && Array.length mib2.mind_packets >= 1); (* Check that the expected numbers of uniform parameters are the same *) (* No need to check the contexts of parameters: it is checked *) (* at the time of checking the inductive arities in check_packet. *) (* Notice that we don't expect the local definitions to match: only *) (* the inductive types and constructors types have to be convertible *) check (fun mib -> mib.mind_nparams); (*begin match mib2.mind_equiv with | None -> () | Some kn2' -> let kn2 = scrape_mind env kn2' in let kn1 = match mib1.mind_equiv with None -> kn | Some kn1' -> scrape_mind env kn1' in if kn1 <> kn2 then error () end;*) (* we check that records and their field names are preserved. *) check (fun mib -> mib.mind_record); if mib1.mind_record then begin let rec names_prod_letin t = match t with | Prod(n,_,t) -> n::(names_prod_letin t) | LetIn(n,_,_,t) -> n::(names_prod_letin t) | Cast(t,_,_) -> names_prod_letin t | _ -> [] in assert (Array.length mib1.mind_packets = 1); assert (Array.length mib2.mind_packets = 1); assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1); assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1); check (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0)); end; (* we first check simple things *) array_iter2 check_packet mib1.mind_packets mib2.mind_packets; (* and constructor types in the end *) let _ = array_map2_i check_cons_types mib1.mind_packets mib2.mind_packets in () let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 = let error () = error_not_match l spec2 in let check_conv f = check_conv_error error f in let check_type env t1 t2 = (* If the type of a constant is generated, it may mention non-variable algebraic universes that the general conversion algorithm is not ready to handle. Anyway, generated types of constants are functions of the body of the constant. If the bodies are the same in environments that are subtypes one of the other, the types are subtypes too (i.e. if Gamma <= Gamma', Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T'). Hence they don't have to be checked again *) let t1,t2 = if isArity t2 then let (ctx2,s2) = destArity t2 in match s2 with | Type v when not (is_univ_variable v) -> (* The type in the interface is inferred and is made of algebraic universes *) begin try let (ctx1,s1) = dest_arity env t1 in match s1 with | Type u when not (is_univ_variable u) -> (* Both types are inferred, no need to recheck them. We cheat and collapse the types to Prop *) mkArity (ctx1,Prop Null), mkArity (ctx2,Prop Null) | Prop _ -> (* The type in the interface is inferred, it may be the case that the type in the implementation is smaller because the body is more reduced. We safely collapse the upper type to Prop *) mkArity (ctx1,Prop Null), mkArity (ctx2,Prop Null) | Type _ -> (* The type in the interface is inferred and the type in the implementation is not inferred or is inferred but from a more reduced body so that it is just a variable. Since constraints of the form "univ <= max(...)" are not expressible in the system of algebraic universes: we fail (the user has to use an explicit type in the interface *) error () with UserError _ (* "not an arity" *) -> error () end | _ -> t1,t2 else (t1,t2) in check_conv conv_leq env t1 t2 in match info1 with | Constant cb1 -> assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ; let cb1 = subst_const_body subst1 cb1 in let cb2 = subst_const_body subst2 cb2 in (*Start by checking types*) let typ1 = Typeops.type_of_constant_type env cb1.const_type in let typ2 = Typeops.type_of_constant_type env cb2.const_type in check_type env typ1 typ2; (* Now we check the bodies: - A transparent constant can only be implemented by a compatible transparent constant. - In the signature, an opaque is handled just as a parameter: anything of the right type can implement it, even if bodies differ. *) (match cb2.const_body with | Undef _ | OpaqueDef _ -> () | Def lc2 -> (match cb1.const_body with | Undef _ | OpaqueDef _ -> error () | Def lc1 -> (* NB: cb1 might have been strengthened and appear as transparent. Anyway [check_conv] will handle that afterwards. *) let c1 = force_constr lc1 in let c2 = force_constr lc2 in check_conv conv env c1 c2)) | IndType ((kn,i),mind1) -> ignore (Util.error ( "The kernel does not recognize yet that a parameter can be " ^ "instantiated by an inductive type. Hint: you can rename the " ^ "inductive type and give a definition to map the old name to the new " ^ "name.")); assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ; if constant_has_body cb2 then error () ; let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in let typ2 = Typeops.type_of_constant_type env cb2.const_type in check_conv conv_leq env arity1 typ2 | IndConstr (((kn,i),j) as cstr,mind1) -> ignore (Util.error ( "The kernel does not recognize yet that a parameter can be " ^ "instantiated by a constructor. Hint: you can rename the " ^ "constructor and give a definition to map the old name to the new " ^ "name.")); assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ; if constant_has_body cb2 then error () ; let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in let ty2 = Typeops.type_of_constant_type env cb2.const_type in check_conv conv env ty1 ty2 let rec check_modules env msb1 msb2 subst1 subst2 = let mty1 = module_type_of_module None msb1 in let mty2 = module_type_of_module None msb2 in check_modtypes env mty1 mty2 subst1 subst2 false; and check_signatures env mp1 sig1 sig2 subst1 subst2 = let map1 = make_labmap mp1 sig1 in let check_one_body (l,spec2) = match spec2 with | SFBconst cb2 -> check_constant env mp1 l (get_obj mp1 map1 l) cb2 spec2 subst1 subst2 | SFBmind mib2 -> check_inductive env mp1 l (get_obj mp1 map1 l) mib2 spec2 subst1 subst2 | SFBmodule msb2 -> begin match get_mod mp1 map1 l with | Module msb -> check_modules env msb msb2 subst1 subst2 | _ -> error_not_match l spec2 end | SFBmodtype mtb2 -> let mtb1 = match get_mod mp1 map1 l with | Modtype mtb -> mtb | _ -> error_not_match l spec2 in let env = add_module (module_body_of_type mtb2.typ_mp mtb2) (add_module (module_body_of_type mtb1.typ_mp mtb1) env) in check_modtypes env mtb1 mtb2 subst1 subst2 true in List.iter check_one_body sig2 and check_modtypes env mtb1 mtb2 subst1 subst2 equiv = if mtb1==mtb2 then () else let mtb1',mtb2'=mtb1.typ_expr,mtb2.typ_expr in let rec check_structure env str1 str2 equiv subst1 subst2 = match str1,str2 with | SEBstruct (list1), SEBstruct (list2) -> check_signatures env mtb1.typ_mp list1 list2 subst1 subst2; if equiv then check_signatures env mtb2.typ_mp list2 list1 subst1 subst2 else () | SEBfunctor (arg_id1,arg_t1,body_t1), SEBfunctor (arg_id2,arg_t2,body_t2) -> check_modtypes env arg_t2 arg_t1 (map_mp arg_t1.typ_mp arg_t2.typ_mp) subst2 equiv ; (* contravariant *) let env = add_module (module_body_of_type (MPbound arg_id2) arg_t2) env in let env = match body_t1 with SEBstruct str -> let env = shallow_remove_module mtb1.typ_mp env in add_module {mod_mp = mtb1.typ_mp; mod_expr = None; mod_type = body_t1; mod_type_alg= None; mod_constraints=mtb1.typ_constraints; mod_retroknowledge = []; mod_delta = mtb1.typ_delta} env | _ -> env in check_structure env body_t1 body_t2 equiv (join (map_mbid arg_id1 (MPbound arg_id2)) subst1) subst2 | _ , _ -> error_incompatible_modtypes mtb1 mtb2 in if mtb1'== mtb2' then () else check_structure env mtb1' mtb2' equiv subst1 subst2 let check_subtypes env sup super = check_modtypes env (strengthen sup sup.typ_mp) super empty_subst (map_mp super.typ_mp sup.typ_mp) false coq-8.4pl4/checker/declarations.mli0000644000175000017500000001521412326224777016415 0ustar stephstephopen Util open Names open Term (* Bytecode *) type values type reloc_table type to_patch_substituted (*Retroknowledge *) type action type retroknowledge (* Engagements *) type engagement = ImpredicativeSet (* Constants *) type polymorphic_arity = { poly_param_levels : Univ.universe option list; poly_level : Univ.universe; } type constant_type = | NonPolymorphicType of constr | PolymorphicArity of rel_context * polymorphic_arity type constr_substituted val force_constr : constr_substituted -> constr val from_val : constr -> constr_substituted (** Beware! In .vo files, lazy_constr are stored as integers used as indexes for a separate table. The actual lazy_constr is restored later, by [Safe_typing.LightenLibrary.load]. This allows us to use here a different definition of lazy_constr than coqtop: since the checker will inspect all proofs parts, even opaque ones, no need to use Lazy.t here *) type lazy_constr val force_lazy_constr : lazy_constr -> constr val lazy_constr_from_val : constr_substituted -> lazy_constr (** Inlining level of parameters at functor applications. This is ignored by the checker. *) type inline = int option (** A constant can have no body (axiom/parameter), or a transparent body, or an opaque one *) type constant_def = | Undef of inline | Def of constr_substituted | OpaqueDef of lazy_constr type constant_body = { const_hyps : section_context; (* New: younger hyp at top *) const_body : constant_def; const_type : constant_type; const_body_code : to_patch_substituted; const_constraints : Univ.constraints } val body_of_constant : constant_body -> constr_substituted option val constant_has_body : constant_body -> bool val is_opaque : constant_body -> bool (* Mutual inductives *) type recarg = | Norec | Mrec of inductive | Imbr of inductive type wf_paths = recarg Rtree.t val mk_norec : wf_paths val mk_paths : recarg -> wf_paths list array -> wf_paths val dest_recarg : wf_paths -> recarg val dest_subterms : wf_paths -> wf_paths list array type monomorphic_inductive_arity = { mind_user_arity : constr; mind_sort : sorts; } type inductive_arity = | Monomorphic of monomorphic_inductive_arity | Polymorphic of polymorphic_arity type one_inductive_body = { (* Primitive datas *) (* Name of the type: [Ii] *) mind_typename : identifier; (* Arity context of [Ii] with parameters: [forall params, Ui] *) mind_arity_ctxt : rel_context; (* Arity sort, original user arity, and allowed elim sorts, if monomorphic *) mind_arity : inductive_arity; (* Names of the constructors: [cij] *) mind_consnames : identifier array; (* Types of the constructors with parameters: [forall params, Tij], where the Ik are replaced by de Bruijn index in the context I1:forall params, U1 .. In:forall params, Un *) mind_user_lc : constr array; (* Derived datas *) (* Number of expected real arguments of the type (no let, no params) *) mind_nrealargs : int; (* Length of realargs context (with let, no params) *) mind_nrealargs_ctxt : int; (* List of allowed elimination sorts *) mind_kelim : sorts_family list; (* Head normalized constructor types so that their conclusion is atomic *) mind_nf_lc : constr array; (* Length of the signature of the constructors (with let, w/o params) *) mind_consnrealdecls : int array; (* Signature of recursive arguments in the constructors *) mind_recargs : wf_paths; (* Datas for bytecode compilation *) (* number of constant constructor *) mind_nb_constant : int; (* number of no constant constructor *) mind_nb_args : int; mind_reloc_tbl : reloc_table; } type mutual_inductive_body = { (* The component of the mutual inductive block *) mind_packets : one_inductive_body array; (* Whether the inductive type has been declared as a record *) mind_record : bool; (* Whether the type is inductive or coinductive *) mind_finite : bool; (* Number of types in the block *) mind_ntypes : int; (* Section hypotheses on which the block depends *) mind_hyps : section_context; (* Number of expected parameters *) mind_nparams : int; (* Number of recursively uniform (i.e. ordinary) parameters *) mind_nparams_rec : int; (* The context of parameters (includes let-in declaration) *) mind_params_ctxt : rel_context; (* Universes constraints enforced by the inductive declaration *) mind_constraints : Univ.constraints; } (* Modules *) type substitution type delta_resolver val empty_delta_resolver : delta_resolver type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body | SFBmodtype of module_type_body and structure_body = (label * structure_field_body) list and struct_expr_body = | SEBident of module_path | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body | SEBapply of struct_expr_body * struct_expr_body * Univ.constraints | SEBstruct of structure_body | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = With_module_body of identifier list * module_path | With_definition_body of identifier list * constant_body and module_body = { mod_mp : module_path; mod_expr : struct_expr_body option; mod_type : struct_expr_body; mod_type_alg : struct_expr_body option; mod_constraints : Univ.constraints; mod_delta : delta_resolver; mod_retroknowledge : action list} and module_type_body = { typ_mp : module_path; typ_expr : struct_expr_body; typ_expr_alg : struct_expr_body option ; typ_constraints : Univ.constraints; typ_delta :delta_resolver} (* Substitutions *) type 'a subst_fun = substitution -> 'a -> 'a val empty_subst : substitution val add_mbid : mod_bound_id -> module_path -> substitution -> substitution val add_mp : module_path -> module_path -> substitution -> substitution val map_mbid : mod_bound_id -> module_path -> substitution val map_mp : module_path -> module_path -> substitution val mp_in_delta : module_path -> delta_resolver -> bool val mind_of_delta : delta_resolver -> mutual_inductive -> mutual_inductive val subst_const_body : constant_body subst_fun val subst_mind : mutual_inductive_body subst_fun val subst_modtype : substitution -> module_type_body -> module_type_body val subst_struct_expr : substitution -> struct_expr_body -> struct_expr_body val subst_structure : substitution -> structure_body -> structure_body val subst_module : substitution -> module_body -> module_body val join : substitution -> substitution -> substitution (* Validation *) val val_eng : Validate.func val val_module : Validate.func val val_modtype : Validate.func coq-8.4pl4/checker/check_stat.mli0000644000175000017500000000114112326224777016047 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit coq-8.4pl4/checker/subtyping.mli0000644000175000017500000000136212326224777015770 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* module_type_body -> module_type_body -> unit coq-8.4pl4/checker/indtypes.mli0000644000175000017500000000254412326224777015606 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Pp.std_ppcmds val prcon : constant -> Pp.std_ppcmds (*s The different kinds of errors that may result of a malformed inductive definition. *) (* Errors related to inductive constructions *) type inductive_error = | NonPos of env * constr * constr | NotEnoughArgs of env * constr * constr | NotConstructor of env * constr * constr | NonPar of env * constr * int * constr * constr | SameNamesTypes of identifier | SameNamesConstructors of identifier | SameNamesOverlap of identifier list | NotAnArity of identifier | BadEntry exception InductiveError of inductive_error (*s The following function does checks on inductive declarations. *) val check_inductive : env -> mutual_inductive -> mutual_inductive_body -> env coq-8.4pl4/checker/type_errors.mli0000644000175000017500000000656612326224777016334 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int -> 'a val error_unbound_var : env -> variable -> 'a val error_not_type : env -> unsafe_judgment -> 'a val error_assumption : env -> unsafe_judgment -> 'a val error_reference_variables : env -> constr -> 'a val error_elim_arity : env -> inductive -> sorts_family list -> constr -> unsafe_judgment -> (sorts_family * sorts_family * arity_error) option -> 'a val error_case_not_inductive : env -> unsafe_judgment -> 'a val error_number_branches : env -> unsafe_judgment -> int -> 'a val error_ill_formed_branch : env -> constr -> int -> constr -> constr -> 'a val error_actual_type : env -> unsafe_judgment -> constr -> 'a val error_cant_apply_not_functional : env -> unsafe_judgment -> unsafe_judgment array -> 'a val error_cant_apply_bad_type : env -> int * constr * constr -> unsafe_judgment -> unsafe_judgment array -> 'a val error_ill_formed_rec_body : env -> guard_error -> name array -> int -> 'a val error_ill_typed_rec_body : env -> int -> name array -> unsafe_judgment array -> constr array -> 'a coq-8.4pl4/checker/reduction.mli0000644000175000017500000000345112326224777015741 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr val whd_betadeltaiota : env -> constr -> constr val whd_betadeltaiota_nolet : env -> constr -> constr (************************************************************************) (*s conversion functions *) exception NotConvertible exception NotConvertibleVect of int type 'a conversion_function = env -> 'a -> 'a -> unit type conv_pb = CONV | CUMUL val conv : constr conversion_function val conv_leq : constr conversion_function val vm_conv : conv_pb -> constr conversion_function (************************************************************************) (* Builds an application node, reducing beta redexes it may produce. *) val beta_appvect : constr -> constr array -> constr (* Pseudo-reduction rule Prod(x,A,B) a --> B[x\a] *) val hnf_prod_applist : env -> constr -> constr list -> constr (************************************************************************) (*s Recognizing products and arities modulo reduction *) val dest_prod : env -> constr -> rel_context * constr val dest_prod_assum : env -> constr -> rel_context * constr val dest_arity : env -> constr -> arity coq-8.4pl4/checker/validate.ml0000644000175000017500000001461212326224777015366 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Obj.no_scan_tag then if t = Obj.string_tag then Format.print_string ("\""^String.escaped(Obj.magic o)^"\"") else Format.print_string "?" else (let n = Obj.size o in Format.print_string ("#"^string_of_int t^"("); Format.open_hvbox 0; for i = 0 to n-1 do pr_obj_rec (Obj.field o i); if i<>n-1 then (Format.print_string ","; Format.print_cut()) done; Format.close_box(); Format.print_string ")") else Format.print_string "?" let pr_obj o = pr_obj_rec o; Format.print_newline() (**************************************************************************) (* Obj low-level validators *) type error_context = string list let mt_ec : error_context = [] let (/) (ctx:error_context) s : error_context = s::ctx let overr (ctx:error_context) f = (fun (_:error_context) -> f ctx) let ext s f (ctx:error_context) = f (ctx/s) exception ValidObjError of string * error_context * Obj.t let fail ctx o s = raise (ValidObjError(s,ctx,o)) type func = error_context -> Obj.t -> unit let apply debug f x = let o = Obj.repr x in try f mt_ec o with ValidObjError(msg,ctx,obj) -> if debug then begin print_endline ("Validation failed: "^msg); print_endline ("Context: "^String.concat"/"(List.rev ctx)); pr_obj obj end; failwith "vo structure validation failed" (* data not validated *) let no_val (c:error_context) (o:Obj.t) = () (* Check that object o is a block with tag t *) let val_tag t ctx o = if Obj.is_block o && Obj.tag o = t then () else fail ctx o ("expected tag "^string_of_int t) let val_block ctx o = if Obj.is_block o then (if Obj.tag o > Obj.no_scan_tag then fail ctx o "block: found no scan tag") else fail ctx o "expected block obj" (* Check that an object is a tuple (or a record). v is an array of validation functions for each field. Its size corresponds to the expected size of the object. *) let val_tuple ?name v ctx o = let ctx = match name with Some n -> ctx/n | _ -> ctx in let n = Array.length v in let val_fld i f = f (ctx/("fld="^string_of_int i)) (Obj.field o i) in val_block ctx o; if Obj.size o = n then Array.iteri val_fld v else fail ctx o ("tuple size: found "^string_of_int (Obj.size o)^ ", expected "^string_of_int n) (* Check that the object is either a constant constructor of tag < cc, or a constructed variant. each element of vv is an array of validation functions to be applied to the constructor arguments. The size of vv corresponds to the number of non-constant constructors, and the size of vv.(i) is the expected arity of the i-th non-constant constructor. *) let val_sum name cc vv ctx o = let ctx = ctx/name in if Obj.is_block o then (val_block (ctx/name) o; let n = Array.length vv in let i = Obj.tag o in let ctx' = if n=1 then ctx else ctx/("tag="^string_of_int i) in if i < n then val_tuple vv.(i) ctx' o else fail ctx' o ("sum: unexpected tag")) else if Obj.is_int o then let (n:int) = Obj.magic o in (if n<0 || n>=cc then fail ctx o ("bad constant constructor "^string_of_int n)) else fail ctx o "not a sum" let val_enum s n = val_sum s n [||] (* Recursive types: avoid looping by eta-expansion *) let rec val_rec_sum name cc f ctx o = val_sum name cc (f (overr (ctx/name) (val_rec_sum name cc f))) ctx o (**************************************************************************) (* Builtin types *) (* Check the o is an array of values satisfying f. *) let val_array ?(pos=false) f ctx o = let upd_ctx = if pos then (fun i -> ctx/string_of_int i) else (fun _ -> ctx) in val_block (ctx/"array") o; for i = 0 to Obj.size o - 1 do (f (upd_ctx i) (Obj.field o i):unit) done (* Integer validator *) let val_int ctx o = if not (Obj.is_int o) then fail ctx o "expected an int" (* String validator *) let val_str ctx o = try val_tag Obj.string_tag ctx o with Failure _ -> fail ctx o "expected a string" (* Booleans *) let val_bool = val_enum "bool" 2 (* Option type *) let val_opt ?(name="option") f = val_sum name 1 [|[|f|]|] (* Lists *) let val_list ?(name="list") f ctx = val_rec_sum name 1 (fun vlist -> [|[|ext "elem" f;vlist|]|]) ctx (* Reference *) let val_ref ?(name="ref") f ctx = val_tuple [|f|] (ctx/name) (**************************************************************************) (* Standard library types *) (* Sets *) let val_set ?(name="Set.t") f = val_rec_sum name 1 (fun vset -> [|[|vset;ext "elem" f; vset;ext "bal" val_int|]|]) (* Maps *) let rec val_map ?(name="Map.t") fk fv = val_rec_sum name 1 (fun vmap -> [|[|vmap; ext "key" fk; ext "value" fv; vmap; ext "bal" val_int|]|]) (**************************************************************************) (* Coq types *) (* names *) let val_id = val_str let val_dp = val_list ~name:"dirpath" val_id let val_name = val_sum "name" 1 [|[|val_id|]|] let val_uid = val_tuple ~name:"uniq_ident" [|val_int;val_str;val_dp|] let val_mp = val_rec_sum "module_path" 0 (fun vmp -> [|[|val_dp|];[|val_uid|];[|vmp;val_id|]|]) let val_kn = val_tuple ~name:"kernel_name" [|val_mp;val_dp;val_id|] let val_con = val_tuple ~name:"constant/mutind" [|val_kn;val_kn|] let val_ind = val_tuple ~name:"inductive"[|val_con;val_int|] let val_cstr = val_tuple ~name:"constructor"[|val_ind;val_int|] (* univ *) let val_level = val_sum "level" 1 [|[|val_dp;val_int|]|] let val_univ = val_sum "univ" 0 [|[|val_level|];[|val_list val_level;val_list val_level|]|] let val_cstrs = val_set ~name:"Univ.constraints" (val_tuple ~name:"univ_constraint" [|val_level;val_enum "order_request" 3;val_level|]) coq-8.4pl4/checker/indtypes.ml0000644000175000017500000005042612326224777015437 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string_of_dirpath sl | MPbound uid -> "bound("^string_of_mbid uid^")" | MPdot (mp,l) -> debug_string_of_mp mp ^ "." ^ string_of_label l let rec string_of_mp = function | MPfile sl -> string_of_dirpath sl | MPbound uid -> string_of_mbid uid | MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l let string_of_mp mp = if !Flags.debug then debug_string_of_mp mp else string_of_mp mp let prkn kn = let (mp,_,l) = repr_kn kn in str(string_of_mp mp ^ "." ^ string_of_label l) let prcon c = let ck = canonical_con c in let uk = user_con c in if ck=uk then prkn uk else (prkn uk ++str"(="++prkn ck++str")") (* Same as noccur_between but may perform reductions. Could be refined more... *) let weaker_noccur_between env x nvars t = if noccur_between x nvars t then Some t else let t' = whd_betadeltaiota env t in if noccur_between x nvars t' then Some t' else None let is_constructor_head t = match fst(decompose_app t) with | Rel _ -> true | _ -> false let conv_ctxt_prefix env (ctx1:rel_context) ctx2 = let rec chk env rctx1 rctx2 = match rctx1, rctx2 with (_,None,ty1 as d1)::rctx1', (_,None,ty2)::rctx2' -> conv env ty1 ty2; chk (push_rel d1 env) rctx1' rctx2' | (_,Some bd1,ty1 as d1)::rctx1', (_,Some bd2,ty2)::rctx2' -> conv env ty1 ty2; conv env bd1 bd2; chk (push_rel d1 env) rctx1' rctx2' | [],_ -> () | _ -> failwith "non convertible contexts" in chk env (List.rev ctx1) (List.rev ctx2) (************************************************************************) (* Various well-formedness check for inductive declarations *) (* Errors related to inductive constructions *) type inductive_error = | NonPos of env * constr * constr | NotEnoughArgs of env * constr * constr | NotConstructor of env * constr * constr | NonPar of env * constr * int * constr * constr | SameNamesTypes of identifier | SameNamesConstructors of identifier | SameNamesOverlap of identifier list | NotAnArity of identifier | BadEntry exception InductiveError of inductive_error (************************************************************************) (************************************************************************) (* Typing the arities and constructor types *) let rec sorts_of_constr_args env t = let t = whd_betadeltaiota_nolet env t in match t with | Prod (name,c1,c2) -> let varj = infer_type env c1 in let env1 = push_rel (name,None,c1) env in varj :: sorts_of_constr_args env1 c2 | LetIn (name,def,ty,c) -> let env1 = push_rel (name,Some def,ty) env in sorts_of_constr_args env1 c | _ when is_constructor_head t -> [] | _ -> anomaly "infos_and_sort: not a positive constructor" (* Prop and Set are small *) let is_small_sort = function | Prop _ -> true | _ -> false let is_logic_sort s = (s = Prop Null) (* [infos] is a sequence of pair [islogic,issmall] for each type in the product of a constructor or arity *) let is_small_constr infos = List.for_all (fun s -> is_small_sort s) infos let is_logic_constr infos = List.for_all (fun s -> is_logic_sort s) infos (* An inductive definition is a "unit" if it has only one constructor and that all arguments expected by this constructor are logical, this is the case for equality, conjunction of logical properties *) let is_unit constrsinfos = match constrsinfos with (* One info = One constructor *) | [|constrinfos|] -> is_logic_constr constrinfos | [||] -> (* type without constructors *) true | _ -> false let small_unit constrsinfos = let issmall = array_for_all is_small_constr constrsinfos and isunit = is_unit constrsinfos in issmall, isunit (* check information related to inductive arity *) let typecheck_arity env params inds = let nparamargs = rel_context_nhyps params in let nparamdecls = rel_context_length params in let check_arity arctxt = function Monomorphic mar -> let ar = mar.mind_user_arity in let _ = infer_type env ar in conv env (it_mkProd_or_LetIn (Sort mar.mind_sort) arctxt) ar; ar | Polymorphic par -> check_polymorphic_arity env params par; it_mkProd_or_LetIn (Sort(Type par.poly_level)) arctxt in let env_arities = Array.fold_left (fun env_ar ind -> let ar_ctxt = ind.mind_arity_ctxt in let _ = check_ctxt env ar_ctxt in conv_ctxt_prefix env params ar_ctxt; (* Arities (with params) are typed-checked here *) let arity = check_arity ar_ctxt ind.mind_arity in (* mind_nrealargs *) let nrealargs = rel_context_nhyps ar_ctxt - nparamargs in if ind.mind_nrealargs <> nrealargs then failwith "bad number of real inductive arguments"; let nrealargs_ctxt = rel_context_length ar_ctxt - nparamdecls in if ind.mind_nrealargs_ctxt <> nrealargs_ctxt then failwith "bad length of real inductive arguments signature"; (* We do not need to generate the universe of full_arity; if later, after the validation of the inductive definition, full_arity is used as argument or subject to cast, an upper universe will be generated *) let id = ind.mind_typename in let env_ar' = push_rel (Name id, None, arity) env_ar in env_ar') env inds in env_arities (* Allowed eliminations *) let check_predicativity env s small level = match s, engagement env with Type u, _ -> let u' = fresh_local_univ () in let cst = merge_constraints (enforce_geq u' u empty_constraint) (universes env) in if not (check_geq cst u' level) then failwith "impredicative Type inductive type" | Prop Pos, Some ImpredicativeSet -> () | Prop Pos, _ -> if not small then failwith "impredicative Set inductive type" | Prop Null,_ -> () let sort_of_ind = function Monomorphic mar -> mar.mind_sort | Polymorphic par -> Type par.poly_level let all_sorts = [InProp;InSet;InType] let small_sorts = [InProp;InSet] let logical_sorts = [InProp] let allowed_sorts issmall isunit s = match family_of_sort s with (* Type: all elimination allowed *) | InType -> all_sorts (* Small Set is predicative: all elimination allowed *) | InSet when issmall -> all_sorts (* Large Set is necessarily impredicative: forbids large elimination *) | InSet -> small_sorts (* Unitary/empty Prop: elimination to all sorts are realizable *) (* unless the type is large. If it is large, forbids large elimination *) (* which otherwise allows to simulate the inconsistent system Type:Type *) | InProp when isunit -> if issmall then all_sorts else small_sorts (* Other propositions: elimination only to Prop *) | InProp -> logical_sorts let compute_elim_sorts env_ar params mib arity lc = let inst = extended_rel_list 0 params in let env_params = push_rel_context params env_ar in let lc = Array.map (fun c -> hnf_prod_applist env_params (lift (rel_context_length params) c) inst) lc in let s = sort_of_ind arity in let infos = Array.map (sorts_of_constr_args env_params) lc in let (small,unit) = small_unit infos in (* We accept recursive unit types... *) let unit = unit && mib.mind_ntypes = 1 in (* compute the max of the sorts of the products of the constructor type *) let level = max_inductive_sort (Array.concat (Array.to_list (Array.map Array.of_list infos))) in check_predicativity env_ar s small level; allowed_sorts small unit s let typecheck_one_inductive env params mib mip = (* mind_typename and mind_consnames not checked *) (* mind_reloc_tbl, mind_nb_constant, mind_nb_args not checked (VM) *) (* mind_arity_ctxt, mind_arity, mind_nrealargs DONE (typecheck_arity) *) (* mind_user_lc *) let _ = Array.map (infer_type env) mip.mind_user_lc in (* mind_nf_lc *) let _ = Array.map (infer_type env) mip.mind_nf_lc in array_iter2 (conv env) mip.mind_nf_lc mip.mind_user_lc; (* mind_consnrealdecls *) let check_cons_args c n = let ctx,_ = decompose_prod_assum c in if n <> rel_context_length ctx - rel_context_length params then failwith "bad number of real constructor arguments" in array_iter2 check_cons_args mip.mind_nf_lc mip.mind_consnrealdecls; (* mind_kelim: checked by positivity criterion ? *) let sorts = compute_elim_sorts env params mib mip.mind_arity mip.mind_nf_lc in if List.exists (fun s -> not (List.mem s sorts)) mip.mind_kelim then failwith "elimination not allowed"; (* mind_recargs: checked by positivity criterion *) () (************************************************************************) (************************************************************************) (* Positivity *) type ill_formed_ind = | LocalNonPos of int | LocalNotEnoughArgs of int | LocalNotConstructor | LocalNonPar of int * int exception IllFormedInd of ill_formed_ind (* [mind_extract_params mie] extracts the params from an inductive types declaration, and checks that they are all present (and all the same) for all the given types. *) let mind_extract_params = decompose_prod_n_assum let explain_ind_err ntyp env0 nbpar c err = let (lpar,c') = mind_extract_params nbpar c in let env = push_rel_context lpar env0 in match err with | LocalNonPos kt -> raise (InductiveError (NonPos (env,c',Rel (kt+nbpar)))) | LocalNotEnoughArgs kt -> raise (InductiveError (NotEnoughArgs (env,c',Rel (kt+nbpar)))) | LocalNotConstructor -> raise (InductiveError (NotConstructor (env,c',Rel (ntyp+nbpar)))) | LocalNonPar (n,l) -> raise (InductiveError (NonPar (env,c',n,Rel (nbpar-n+1), Rel (l+nbpar)))) let failwith_non_pos n ntypes c = for k = n to n + ntypes - 1 do if not (noccurn k c) then raise (IllFormedInd (LocalNonPos (k-n+1))) done let failwith_non_pos_vect n ntypes v = Array.iter (failwith_non_pos n ntypes) v; anomaly "failwith_non_pos_vect: some k in [n;n+ntypes-1] should occur" let failwith_non_pos_list n ntypes l = List.iter (failwith_non_pos n ntypes) l; anomaly "failwith_non_pos_list: some k in [n;n+ntypes-1] should occur" (* Conclusion of constructors: check the inductive type is called with the expected parameters *) let check_correct_par (env,n,ntypes,_) hyps l largs = let nparams = rel_context_nhyps hyps in let largs = Array.of_list largs in if Array.length largs < nparams then raise (IllFormedInd (LocalNotEnoughArgs l)); let (lpar,largs') = array_chop nparams largs in let nhyps = List.length hyps in let rec check k index = function | [] -> () | (_,Some _,_)::hyps -> check k (index+1) hyps | _::hyps -> match whd_betadeltaiota env lpar.(k) with | Rel w when w = index -> check (k-1) (index+1) hyps | _ -> raise (IllFormedInd (LocalNonPar (k+1,l))) in check (nparams-1) (n-nhyps) hyps; if not (array_for_all (noccur_between n ntypes) largs') then failwith_non_pos_vect n ntypes largs' (* Arguments of constructor: check the number of recursive parameters nrecp. the first parameters which are constant in recursive arguments n is the current depth, nmr is the maximum number of possible recursive parameters *) let check_rec_par (env,n,_,_) hyps nrecp largs = let (lpar,_) = list_chop nrecp largs in let rec find index = function | ([],_) -> () | (_,[]) -> failwith "number of recursive parameters cannot be greater than the number of parameters." | (lp,(_,Some _,_)::hyps) -> find (index-1) (lp,hyps) | (p::lp,_::hyps) -> (match whd_betadeltaiota env p with | Rel w when w = index -> find (index-1) (lp,hyps) | _ -> failwith "bad number of recursive parameters") in find (n-1) (lpar,List.rev hyps) let lambda_implicit_lift n a = let lambda_implicit a = Lambda(Anonymous,Evar(0,[||]),a) in iterate lambda_implicit n (lift n a) (* This removes global parameters of the inductive types in lc (for nested inductive types only ) *) let abstract_mind_lc env ntyps npars lc = if npars = 0 then lc else let make_abs = list_tabulate (function i -> lambda_implicit_lift npars (Rel (i+1))) ntyps in Array.map (substl make_abs) lc (* [env] is the typing environment [n] is the dB of the last inductive type [ntypes] is the number of inductive types in the definition (i.e. range of inductives is [n; n+ntypes-1]) [lra] is the list of recursive tree of each variable *) let ienv_push_var (env, n, ntypes, lra) (x,a,ra) = (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra) let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) = let auxntyp = 1 in let specif = lookup_mind_specif env mi in let env' = push_rel (Anonymous,None, hnf_prod_applist env (type_of_inductive env specif) lpar) env in let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in (* New index of the inductive types *) let newidx = n + auxntyp in (env', newidx, ntypes, ra_env') let rec ienv_decompose_prod (env,_,_,_ as ienv) n c = if n=0 then (ienv,c) else let c' = whd_betadeltaiota env c in match c' with Prod(na,a,b) -> let ienv' = ienv_push_var ienv (na,a,mk_norec) in ienv_decompose_prod ienv' (n-1) b | _ -> assert false (* The recursive function that checks positivity and builds the list of recursive arguments *) let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp (_,i as ind) indlc = let lparams = rel_context_length hyps in (* check the inductive types occur positively in [c] *) let rec check_pos (env, n, ntypes, ra_env as ienv) c = let x,largs = decompose_app (whd_betadeltaiota env c) in match x with | Prod (na,b,d) -> assert (largs = []); (match weaker_noccur_between env n ntypes b with None -> failwith_non_pos_list n ntypes [b] | Some b -> check_pos (ienv_push_var ienv (na, b, mk_norec)) d) | Rel k -> (try let (ra,rarg) = List.nth ra_env (k-1) in (match ra with Mrec _ -> check_rec_par ienv hyps nrecp largs | _ -> ()); if not (List.for_all (noccur_between n ntypes) largs) then failwith_non_pos_list n ntypes largs else rarg with Failure _ | Invalid_argument _ -> mk_norec) | Ind ind_kn -> (* If the inductive type being defined appears in a parameter, then we have an imbricated type *) if List.for_all (noccur_between n ntypes) largs then mk_norec else check_positive_imbr ienv (ind_kn, largs) | err -> if noccur_between n ntypes x && List.for_all (noccur_between n ntypes) largs then mk_norec else failwith_non_pos_list n ntypes (x::largs) (* accesses to the environment are not factorised, but is it worth it? *) and check_positive_imbr (env,n,ntypes,ra_env as ienv) (mi, largs) = let (mib,mip) = lookup_mind_specif env mi in let auxnpar = mib.mind_nparams_rec in let nonrecpar = mib.mind_nparams - auxnpar in let (lpar,auxlargs) = try list_chop auxnpar largs with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in (* If the inductive appears in the args (non params) then the definition is not positive. *) if not (List.for_all (noccur_between n ntypes) auxlargs) then raise (IllFormedInd (LocalNonPos n)); (* We do not deal with imbricated mutual inductive types *) let auxntyp = mib.mind_ntypes in if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n)); (* The nested inductive type with parameters removed *) let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in (* Extends the environment with a variable corresponding to the inductive def *) let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in (* Parameters expressed in env' *) let lpar' = List.map (lift auxntyp) lpar in let irecargs = (* fails if the inductive type occurs non positively *) (* with recursive parameters substituted *) Array.map (function c -> let c' = hnf_prod_applist env' c lpar' in (* skip non-recursive parameters *) let (ienv',c') = ienv_decompose_prod ienv' nonrecpar c' in check_constructors ienv' false c') auxlcvect in (Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0) (* check the inductive types occur positively in the products of C, if check_head=true, also check the head corresponds to a constructor of the ith type *) and check_constructors ienv check_head c = let rec check_constr_rec (env,n,ntypes,ra_env as ienv) lrec c = let x,largs = decompose_app (whd_betadeltaiota env c) in match x with | Prod (na,b,d) -> assert (largs = []); let recarg = check_pos ienv b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in check_constr_rec ienv' (recarg::lrec) d | hd -> if check_head then if hd = Rel (n+ntypes-i-1) then check_correct_par ienv hyps (ntypes-i) largs else raise (IllFormedInd LocalNotConstructor) else if not (List.for_all (noccur_between n ntypes) largs) then raise (IllFormedInd (LocalNonPos n)); List.rev lrec in check_constr_rec ienv [] c in let irecargs = Array.map (fun c -> let _,rawc = mind_extract_params lparams c in try check_constructors ienv true rawc with IllFormedInd err -> explain_ind_err (ntypes-i) env lparams c err) indlc in mk_paths (Mrec ind) irecargs let check_subtree (t1:'a) (t2:'a) = if not (Rtree.compare_rtree (fun t1 t2 -> let l1 = fst(Rtree.dest_node t1) in let l2 = fst(Rtree.dest_node t2) in if l1 = Norec || l1 = l2 then 0 else -1) t1 t2) then failwith "bad recursive trees" (* if t1=t2 then () else msg_warning (str"TODO: check recursive positions")*) let check_positivity env_ar mind params nrecp inds = let ntypes = Array.length inds in let rc = Array.mapi (fun j t -> (Mrec(mind,j),t)) (Rtree.mk_rec_calls ntypes) in let lra_ind = List.rev (Array.to_list rc) in let lparams = rel_context_length params in let check_one i mip = let ra_env = list_tabulate (fun _ -> (Norec,mk_norec)) lparams @ lra_ind in let ienv = (env_ar, 1+lparams, ntypes, ra_env) in check_positivity_one ienv params nrecp (mind,i) mip.mind_nf_lc in let irecargs = Array.mapi check_one inds in let wfp = Rtree.mk_rec irecargs in array_iter2 (fun ind wfpi -> check_subtree ind.mind_recargs wfpi) inds wfp (************************************************************************) (************************************************************************) let check_inductive env kn mib = Flags.if_verbose msgnl (str " checking ind: " ++ pr_mind kn); (* check mind_constraints: should be consistent with env *) let env = add_constraints mib.mind_constraints env in (* check mind_record : TODO ? check #constructor = 1 ? *) (* check mind_finite : always OK *) (* check mind_ntypes *) if Array.length mib.mind_packets <> mib.mind_ntypes then error "not the right number of packets"; (* check mind_hyps: should be empty *) if mib.mind_hyps <> empty_named_context then error "section context not empty"; (* check mind_params_ctxt *) let params = mib.mind_params_ctxt in let _ = check_ctxt env params in (* check mind_nparams *) if rel_context_nhyps params <> mib.mind_nparams then error "number the right number of parameters"; (* mind_packets *) (* - check arities *) let env_ar = typecheck_arity env params mib.mind_packets in (* - check constructor types *) Array.iter (typecheck_one_inductive env_ar params mib) mib.mind_packets; (* check mind_nparams_rec: positivity condition *) check_positivity env_ar kn params mib.mind_nparams_rec mib.mind_packets; (* check mind_equiv... *) (* Now we can add the inductive *) add_mind kn mib env coq-8.4pl4/checker/typeops.ml0000644000175000017500000003124512326224777015301 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (try conv_leq env t1 t2 with NotConvertible -> raise (NotConvertibleVect i)); ()) () v1 v2 (* This should be a type (a priori without intension to be an assumption) *) let type_judgment env (c,ty as j) = match whd_betadeltaiota env ty with | Sort s -> (c,s) | _ -> error_not_type env j (* This should be a type intended to be assumed. The error message is *) (* not as useful as for [type_judgment]. *) let assumption_of_judgment env j = try fst(type_judgment env j) with TypeError _ -> error_assumption env j (************************************************) (* Incremental typing rules: builds a typing judgement given the *) (* judgements for the subterms. *) (*s Type of sorts *) (* Prop and Set *) let judge_of_prop = Sort (Type type1_univ) (* Type of Type(i). *) let judge_of_type u = Sort (Type (super u)) (*s Type of a de Bruijn index. *) let judge_of_relative env n = try let (_,_,typ) = lookup_rel n env in lift n typ with Not_found -> error_unbound_rel env n (* Type of variables *) let judge_of_variable env id = try named_type id env with Not_found -> error_unbound_var env id (* Management of context of variables. *) (* Checks if a context of variable can be instantiated by the variables of the current env *) (* TODO: check order? *) let rec check_hyps_inclusion env sign = fold_named_context (fun (id,_,ty1) () -> let ty2 = named_type id env in if not (eq_constr ty2 ty1) then error "types do not match") sign ~init:() let check_args env c hyps = try check_hyps_inclusion env hyps with UserError _ | Not_found -> error_reference_variables env c (* Type of constants *) let type_of_constant_knowing_parameters env t paramtyps = match t with | NonPolymorphicType t -> t | PolymorphicArity (sign,ar) -> let ctx = List.rev sign in let ctx,s = instantiate_universes env ctx ar paramtyps in mkArity (List.rev ctx,s) let type_of_constant_type env t = type_of_constant_knowing_parameters env t [||] let judge_of_constant_knowing_parameters env cst paramstyp = let c = Const cst in let cb = try lookup_constant cst env with Not_found -> failwith ("Cannot find constant: "^string_of_con cst) in let _ = check_args env c cb.const_hyps in type_of_constant_knowing_parameters env cb.const_type paramstyp let judge_of_constant env cst = judge_of_constant_knowing_parameters env cst [||] (* Type of an application. *) let judge_of_apply env (f,funj) argjv = let rec apply_rec n typ = function | [] -> typ | (h,hj)::restjl -> (match whd_betadeltaiota env typ with | Prod (_,c1,c2) -> (try conv_leq env hj c1 with NotConvertible -> error_cant_apply_bad_type env (n,c1, hj) (f,funj) argjv); apply_rec (n+1) (subst1 h c2) restjl | _ -> error_cant_apply_not_functional env (f,funj) argjv) in apply_rec 1 funj (Array.to_list argjv) (* Type of product *) let sort_of_product env domsort rangsort = match (domsort, rangsort) with (* Product rule (s,Prop,Prop) *) | (_, Prop Null) -> rangsort (* Product rule (Prop/Set,Set,Set) *) | (Prop _, Prop Pos) -> rangsort (* Product rule (Type,Set,?) *) | (Type u1, Prop Pos) -> if engagement env = Some ImpredicativeSet then (* Rule is (Type,Set,Set) in the Set-impredicative calculus *) rangsort else (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) Type (sup u1 type0_univ) (* Product rule (Prop,Type_i,Type_i) *) | (Prop Pos, Type u2) -> Type (sup type0_univ u2) (* Product rule (Prop,Type_i,Type_i) *) | (Prop Null, Type _) -> rangsort (* Product rule (Type_i,Type_i,Type_i) *) | (Type u1, Type u2) -> Type (sup u1 u2) (* Type of a type cast *) (* [judge_of_cast env (c,typ1) (typ2,s)] implements the rule env |- c:typ1 env |- typ2:s env |- typ1 <= typ2 --------------------------------------------------------------------- env |- c:typ2 *) let judge_of_cast env (c,cj) k tj = let conversion = match k with | VMcast -> vm_conv CUMUL | DEFAULTcast -> conv_leq in try conversion env cj tj with NotConvertible -> error_actual_type env (c,cj) tj (* Inductive types. *) (* The type is parametric over the uniform parameters whose conclusion is in Type; to enforce the internal constraints between the parameters and the instances of Type occurring in the type of the constructors, we use the level variables _statically_ assigned to the conclusions of the parameters as mediators: e.g. if a parameter has conclusion Type(alpha), static constraints of the form alpha<=v exist between alpha and the Type's occurring in the constructor types; when the parameters is finally instantiated by a term of conclusion Type(u), then the constraints u<=alpha is computed in the App case of execute; from this constraints, the expected dynamic constraints of the form u<=v are enforced *) let judge_of_inductive_knowing_parameters env ind (paramstyp:constr array) = let c = Ind ind in let (mib,mip) = try lookup_mind_specif env ind with Not_found -> failwith ("Cannot find inductive: "^string_of_mind (fst ind)) in check_args env c mib.mind_hyps; type_of_inductive_knowing_parameters env mip paramstyp let judge_of_inductive env ind = judge_of_inductive_knowing_parameters env ind [||] (* Constructors. *) let judge_of_constructor env c = let constr = Construct c in let _ = let ((kn,_),_) = c in let mib = try lookup_mind kn env with Not_found -> failwith ("Cannot find inductive: "^string_of_mind (fst (fst c))) in check_args env constr mib.mind_hyps in let specif = lookup_mind_specif env (inductive_of_constructor c) in type_of_constructor c specif (* Case. *) let check_branch_types env (c,cj) (lfj,explft) = try conv_leq_vecti env lfj explft with NotConvertibleVect i -> error_ill_formed_branch env c i lfj.(i) explft.(i) | Invalid_argument _ -> error_number_branches env (c,cj) (Array.length explft) let judge_of_case env ci pj (c,cj) lfj = let indspec = try find_rectype env cj with Not_found -> error_case_not_inductive env (c,cj) in let _ = check_case_info env (fst indspec) ci in let (bty,rslty) = type_case_branches env indspec pj c in check_branch_types env (c,cj) (lfj,bty); rslty (* Fixpoints. *) (* Checks the type of a general (co)fixpoint, i.e. without checking *) (* the specific guard condition. *) let type_fixpoint env lna lar lbody vdefj = let lt = Array.length vdefj in assert (Array.length lar = lt && Array.length lbody = lt); try conv_leq_vecti env vdefj (Array.map (fun ty -> lift lt ty) lar) with NotConvertibleVect i -> let vdefj = array_map2 (fun b ty -> b,ty) lbody vdefj in error_ill_typed_rec_body env i lna vdefj lar (************************************************************************) (************************************************************************) let refresh_arity env ar = let ctxt, hd = decompose_prod_assum ar in match hd with Sort (Type u) when not (is_univ_variable u) -> let u' = fresh_local_univ() in let env' = add_constraints (enforce_geq u' u empty_constraint) env in env', mkArity (ctxt,Type u') | _ -> env, ar (* The typing machine. *) let rec execute env cstr = match cstr with (* Atomic terms *) | Sort (Prop _) -> judge_of_prop | Sort (Type u) -> judge_of_type u | Rel n -> judge_of_relative env n | Var id -> judge_of_variable env id | Const c -> judge_of_constant env c (* Lambda calculus operators *) | App (App (f,args),args') -> execute env (App(f,Array.append args args')) | App (f,args) -> let jl = execute_array env args in let j = match f with | Ind ind -> (* Sort-polymorphism of inductive types *) judge_of_inductive_knowing_parameters env ind jl | Const cst -> (* Sort-polymorphism of constant *) judge_of_constant_knowing_parameters env cst jl | _ -> (* No sort-polymorphism *) execute env f in let jl = array_map2 (fun c ty -> c,ty) args jl in judge_of_apply env (f,j) jl | Lambda (name,c1,c2) -> let _ = execute_type env c1 in let env1 = push_rel (name,None,c1) env in let j' = execute env1 c2 in Prod(name,c1,j') | Prod (name,c1,c2) -> let varj = execute_type env c1 in let env1 = push_rel (name,None,c1) env in let varj' = execute_type env1 c2 in Sort (sort_of_product env varj varj') | LetIn (name,c1,c2,c3) -> let j1 = execute env c1 in (* /!\ c2 can be an inferred type => refresh (but the pushed type is still c2) *) let _ = let env',c2' = refresh_arity env c2 in let _ = execute_type env' c2' in judge_of_cast env' (c1,j1) DEFAULTcast c2' in let env1 = push_rel (name,Some c1,c2) env in let j' = execute env1 c3 in subst1 c1 j' | Cast (c,k,t) -> let cj = execute env c in let _ = execute_type env t in judge_of_cast env (c,cj) k t; t (* Inductive types *) | Ind ind -> judge_of_inductive env ind | Construct c -> judge_of_constructor env c | Case (ci,p,c,lf) -> let cj = execute env c in let pj = execute env p in let lfj = execute_array env lf in judge_of_case env ci (p,pj) (c,cj) lfj | Fix ((_,i as vni),recdef) -> let fix_ty = execute_recdef env recdef i in let fix = (vni,recdef) in check_fix env fix; fix_ty | CoFix (i,recdef) -> let fix_ty = execute_recdef env recdef i in let cofix = (i,recdef) in check_cofix env cofix; fix_ty (* Partial proofs: unsupported by the kernel *) | Meta _ -> anomaly "the kernel does not support metavariables" | Evar _ -> anomaly "the kernel does not support existential variables" and execute_type env constr = let j = execute env constr in snd (type_judgment env (constr,j)) and execute_recdef env (names,lar,vdef) i = let larj = execute_array env lar in let larj = array_map2 (fun c ty -> c,ty) lar larj in let lara = Array.map (assumption_of_judgment env) larj in let env1 = push_rec_types (names,lara,vdef) env in let vdefj = execute_array env1 vdef in type_fixpoint env1 names lara vdef vdefj; lara.(i) and execute_array env = Array.map (execute env) (* Derived functions *) let infer env constr = execute env constr let infer_type env constr = execute_type env constr (* Typing of several terms. *) let check_ctxt env rels = fold_rel_context (fun d env -> match d with (_,None,ty) -> let _ = infer_type env ty in push_rel d env | (_,Some bd,ty) -> let j1 = infer env bd in let _ = infer env ty in conv_leq env j1 ty; push_rel d env) rels ~init:env let check_named_ctxt env ctxt = fold_named_context (fun (id,_,_ as d) env -> let _ = try let _ = lookup_named id env in failwith ("variable "^string_of_id id^" defined twice") with Not_found -> () in match d with (_,None,ty) -> let _ = infer_type env ty in push_named d env | (_,Some bd,ty) -> let j1 = infer env bd in let _ = infer env ty in conv_leq env j1 ty; push_named d env) ctxt ~init:env (* Polymorphic arities utils *) let check_kind env ar u = if snd (dest_prod env ar) = Sort(Type u) then () else failwith "not the correct sort" let check_polymorphic_arity env params par = let pl = par.poly_param_levels in let rec check_p env pl params = match pl, params with Some u::pl, (na,None,ty)::params -> check_kind env ty u; check_p (push_rel (na,None,ty) env) pl params | None::pl,d::params -> check_p (push_rel d env) pl params | [], _ -> () | _ -> failwith "check_poly: not the right number of params" in check_p env pl (List.rev params) coq-8.4pl4/checker/Makefile0000644000175000017500000000401312326224777014675 0ustar stephstephOCAMLC=ocamlc OCAMLOPT=ocamlopt COQSRC=.. MLDIRS=-I $(COQSRC)/config -I $(COQSRC)/lib -I $(COQSRC)/kernel -I +camlp4 BYTEFLAGS=$(MLDIRS) OPTFLAGS=$(MLDIRS) CHECKERNAME=coqchk BINARIES=../bin/$(CHECKERNAME)$(EXE) ../bin/$(CHECKERNAME).opt$(EXE) MCHECKERLOCAL :=\ declarations.cmo environ.cmo \ closure.cmo reduction.cmo \ type_errors.cmo \ modops.cmo \ inductive.cmo typeops.cmo \ indtypes.cmo subtyping.cmo mod_checking.cmo \ validate.cmo \ safe_typing.cmo check.cmo \ check_stat.cmo checker.cmo MCHECKER:=\ $(COQSRC)/config/coq_config.cmo \ $(COQSRC)/lib/pp_control.cmo $(COQSRC)/lib/pp.cmo $(COQSRC)/lib/compat.cmo \ $(COQSRC)/lib/util.cmo $(COQSRC)/lib/option.cmo $(COQSRC)/lib/hashcons.cmo \ $(COQSRC)/lib/system.cmo $(COQSRC)/lib/flags.cmo \ $(COQSRC)/lib/predicate.cmo $(COQSRC)/lib/rtree.cmo \ $(COQSRC)/kernel/names.cmo $(COQSRC)/kernel/univ.cmo \ $(COQSRC)/kernel/esubst.cmo term.cmo \ $(MCHECKERLOCAL) all: $(BINARIES) byte : ../bin/$(CHECKERNAME)$(EXE) opt : ../bin/$(CHECKERNAME).opt$(EXE) check.cma: $(MCHECKERLOCAL) ocamlc $(BYTEFLAGS) -a -o $@ $(MCHECKER) check.cmxa: $(MCHECKERLOCAL:.cmo=.cmx) ocamlopt $(OPTFLAGS) -a -o $@ $(MCHECKER:.cmo=.cmx) ../bin/$(CHECKERNAME)$(EXE): check.cma ocamlc $(BYTEFLAGS) -o $@ unix.cma gramlib.cma check.cma main.ml ../bin/$(CHECKERNAME).opt$(EXE): check.cmxa ocamlopt $(OPTFLAGS) -o $@ unix.cmxa gramlib.cmxa check.cmxa main.ml stats: @echo STRUCTURE @wc names.ml term.ml declarations.ml environ.ml type_errors.ml @echo @echo REDUCTION @-wc esubst.ml closure.ml reduction.ml @echo @echo TYPAGE @wc univ.ml inductive.ml indtypes.ml typeops.ml safe_typing.ml @echo @echo MODULES @wc modops.ml subtyping.ml @echo @echo INTERFACE @wc check*.ml main.ml @echo @echo TOTAL @wc *.ml | tail -1 .SUFFIXES:.ml .mli .cmi .cmo .cmx .ml.cmo: $(OCAMLC) -c $(BYTEFLAGS) $< .ml.cmx: $(OCAMLOPT) -c $(OPTFLAGS) $< .mli.cmi: $(OCAMLC) -c $(BYTEFLAGS) $< depend:: ocamldep *.ml* > .depend clean:: rm -f *.cm* *.o *.a *~ $(BINARIES) -include .depend coq-8.4pl4/checker/mod_checking.mli0000644000175000017500000000114612326224777016356 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Names.module_path -> Declarations.module_body -> unit coq-8.4pl4/checker/declarations.ml0000644000175000017500000006340412326224777016250 0ustar stephstephopen Util open Names open Term open Validate (* Bytecode *) type values type reloc_table type to_patch_substituted (*Retroknowledge *) type action type retroknowledge type engagement = ImpredicativeSet let val_eng = val_enum "eng" 1 type polymorphic_arity = { poly_param_levels : Univ.universe option list; poly_level : Univ.universe; } let val_pol_arity = val_tuple ~name:"polyorphic_arity"[|val_list(val_opt val_univ);val_univ|] type constant_type = | NonPolymorphicType of constr | PolymorphicArity of rel_context * polymorphic_arity let val_cst_type = val_sum "constant_type" 0 [|[|val_constr|];[|val_rctxt;val_pol_arity|]|] (** Substitutions, code imported from kernel/mod_subst *) type delta_hint = | Inline of int * constr option | Equiv of kernel_name module Deltamap = struct type t = module_path MPmap.t * delta_hint KNmap.t let empty = MPmap.empty, KNmap.empty let add_kn kn hint (mm,km) = (mm,KNmap.add kn hint km) let add_mp mp mp' (mm,km) = (MPmap.add mp mp' mm, km) let remove_mp mp (mm,km) = (MPmap.remove mp mm, km) let find_mp mp map = MPmap.find mp (fst map) let find_kn kn map = KNmap.find kn (snd map) let mem_mp mp map = MPmap.mem mp (fst map) let mem_kn kn map = KNmap.mem kn (snd map) let fold_kn f map i = KNmap.fold f (snd map) i let fold fmp fkn (mm,km) i = MPmap.fold fmp mm (KNmap.fold fkn km i) let join map1 map2 = fold add_mp add_kn map1 map2 end type delta_resolver = Deltamap.t let empty_delta_resolver = Deltamap.empty module MBImap = Map.Make (struct type t = mod_bound_id let compare = Pervasives.compare end) module Umap = struct type 'a t = 'a MPmap.t * 'a MBImap.t let empty = MPmap.empty, MBImap.empty let is_empty (m1,m2) = MPmap.is_empty m1 && MBImap.is_empty m2 let add_mbi mbi x (m1,m2) = (m1,MBImap.add mbi x m2) let add_mp mp x (m1,m2) = (MPmap.add mp x m1, m2) let find_mp mp map = MPmap.find mp (fst map) let find_mbi mbi map = MBImap.find mbi (snd map) let mem_mp mp map = MPmap.mem mp (fst map) let mem_mbi mbi map = MBImap.mem mbi (snd map) let iter_mbi f map = MBImap.iter f (snd map) let fold fmp fmbi (m1,m2) i = MPmap.fold fmp m1 (MBImap.fold fmbi m2 i) let join map1 map2 = fold add_mp add_mbi map1 map2 end type substitution = (module_path * delta_resolver) Umap.t type 'a subst_fun = substitution -> 'a -> 'a let empty_subst = Umap.empty let is_empty_subst = Umap.is_empty let val_delta_hint = val_sum "delta_hint" 0 [|[|val_int; val_opt val_constr|];[|val_kn|]|] let val_res = val_tuple ~name:"delta_resolver" [|val_map ~name:"delta_resolver" val_mp val_mp; val_map ~name:"delta_resolver" val_kn val_delta_hint|] let val_mp_res = val_tuple [|val_mp;val_res|] let val_subst = val_tuple ~name:"substitution" [|val_map ~name:"substitution" val_mp val_mp_res; val_map ~name:"substitution" val_uid val_mp_res|] let add_mbid mbid mp = Umap.add_mbi mbid (mp,empty_delta_resolver) let add_mp mp1 mp2 = Umap.add_mp mp1 (mp2,empty_delta_resolver) let map_mbid mbid mp = add_mbid mbid mp empty_subst let map_mp mp1 mp2 = add_mp mp1 mp2 empty_subst let mp_in_delta mp = Deltamap.mem_mp mp let rec find_prefix resolve mp = let rec sub_mp = function | MPdot(mp,l) as mp_sup -> (try Deltamap.find_mp mp_sup resolve with Not_found -> MPdot(sub_mp mp,l)) | p -> Deltamap.find_mp p resolve in try sub_mp mp with Not_found -> mp (** Nota: the following function is slightly different in mod_subst PL: Is it on purpose ? *) let solve_delta_kn resolve kn = try match Deltamap.find_kn kn resolve with | Equiv kn1 -> kn1 | Inline _ -> raise Not_found with Not_found -> let mp,dir,l = repr_kn kn in let new_mp = find_prefix resolve mp in if mp == new_mp then kn else make_kn new_mp dir l let gen_of_delta resolve x kn fix_can = try let new_kn = solve_delta_kn resolve kn in if kn == new_kn then x else fix_can new_kn with _ -> x let constant_of_delta resolve con = let kn = user_con con in gen_of_delta resolve con kn (constant_of_kn_equiv kn) let constant_of_delta2 resolve con = let kn, kn' = canonical_con con, user_con con in gen_of_delta resolve con kn (constant_of_kn_equiv kn') let mind_of_delta resolve mind = let kn = user_mind mind in gen_of_delta resolve mind kn (mind_of_kn_equiv kn) let mind_of_delta2 resolve mind = let kn, kn' = canonical_mind mind, user_mind mind in gen_of_delta resolve mind kn (mind_of_kn_equiv kn') let find_inline_of_delta kn resolve = match Deltamap.find_kn kn resolve with | Inline (_,o) -> o | _ -> raise Not_found let constant_of_delta_with_inline resolve con = let kn1,kn2 = canonical_con con,user_con con in try find_inline_of_delta kn2 resolve with Not_found -> try find_inline_of_delta kn1 resolve with Not_found -> None let subst_mp0 sub mp = (* 's like subst *) let rec aux mp = match mp with | MPfile sid -> Umap.find_mp mp sub | MPbound bid -> begin try Umap.find_mbi bid sub with Not_found -> Umap.find_mp mp sub end | MPdot (mp1,l) as mp2 -> begin try Umap.find_mp mp2 sub with Not_found -> let mp1',resolve = aux mp1 in MPdot (mp1',l),resolve end in try Some (aux mp) with Not_found -> None let subst_mp sub mp = match subst_mp0 sub mp with None -> mp | Some (mp',_) -> mp' let subst_kn_delta sub kn = let mp,dir,l = repr_kn kn in match subst_mp0 sub mp with Some (mp',resolve) -> solve_delta_kn resolve (make_kn mp' dir l) | None -> kn let subst_kn sub kn = let mp,dir,l = repr_kn kn in match subst_mp0 sub mp with Some (mp',_) -> make_kn mp' dir l | None -> kn exception No_subst type sideconstantsubst = | User | Canonical let gen_subst_mp f sub mp1 mp2 = match subst_mp0 sub mp1, subst_mp0 sub mp2 with | None, None -> raise No_subst | Some (mp',resolve), None -> User, (f mp' mp2), resolve | None, Some (mp',resolve) -> Canonical, (f mp1 mp'), resolve | Some (mp1',_), Some (mp2',resolve2) -> Canonical, (f mp1' mp2'), resolve2 let subst_ind sub mind = let kn1,kn2 = user_mind mind, canonical_mind mind in let mp1,dir,l = repr_kn kn1 in let mp2,_,_ = repr_kn kn2 in let rebuild_mind mp1 mp2 = make_mind_equiv mp1 mp2 dir l in try let side,mind',resolve = gen_subst_mp rebuild_mind sub mp1 mp2 in match side with | User -> mind_of_delta resolve mind' | Canonical -> mind_of_delta2 resolve mind' with No_subst -> mind let subst_con0 sub con = let kn1,kn2 = user_con con,canonical_con con in let mp1,dir,l = repr_kn kn1 in let mp2,_,_ = repr_kn kn2 in let rebuild_con mp1 mp2 = make_con_equiv mp1 mp2 dir l in let dup con = con, Const con in let side,con',resolve = gen_subst_mp rebuild_con sub mp1 mp2 in match constant_of_delta_with_inline resolve con' with | Some t -> con', t | None -> let con'' = match side with | User -> constant_of_delta resolve con' | Canonical -> constant_of_delta2 resolve con' in if con'' == con then raise No_subst else dup con'' let rec map_kn f f' c = let func = map_kn f f' in match c with | Const kn -> (try snd (f' kn) with No_subst -> c) | Ind (kn,i) -> let kn' = f kn in if kn'==kn then c else Ind (kn',i) | Construct ((kn,i),j) -> let kn' = f kn in if kn'==kn then c else Construct ((kn',i),j) | Case (ci,p,ct,l) -> let ci_ind = let (kn,i) = ci.ci_ind in let kn' = f kn in if kn'==kn then ci.ci_ind else kn',i in let p' = func p in let ct' = func ct in let l' = array_smartmap func l in if (ci.ci_ind==ci_ind && p'==p && l'==l && ct'==ct)then c else Case ({ci with ci_ind = ci_ind}, p',ct', l') | Cast (ct,k,t) -> let ct' = func ct in let t'= func t in if (t'==t && ct'==ct) then c else Cast (ct', k, t') | Prod (na,t,ct) -> let ct' = func ct in let t'= func t in if (t'==t && ct'==ct) then c else Prod (na, t', ct') | Lambda (na,t,ct) -> let ct' = func ct in let t'= func t in if (t'==t && ct'==ct) then c else Lambda (na, t', ct') | LetIn (na,b,t,ct) -> let ct' = func ct in let t'= func t in let b'= func b in if (t'==t && ct'==ct && b==b') then c else LetIn (na, b', t', ct') | App (ct,l) -> let ct' = func ct in let l' = array_smartmap func l in if (ct'== ct && l'==l) then c else App (ct',l') | Evar (e,l) -> let l' = array_smartmap func l in if (l'==l) then c else Evar (e,l') | Fix (ln,(lna,tl,bl)) -> let tl' = array_smartmap func tl in let bl' = array_smartmap func bl in if (bl == bl'&& tl == tl') then c else Fix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> let tl' = array_smartmap func tl in let bl' = array_smartmap func bl in if (bl == bl'&& tl == tl') then c else CoFix (ln,(lna,tl',bl')) | _ -> c let subst_mps sub c = if is_empty_subst sub then c else map_kn (subst_ind sub) (subst_con0 sub) c type 'a lazy_subst = | LSval of 'a | LSlazy of substitution list * 'a type 'a substituted = 'a lazy_subst ref let val_substituted val_a = val_ref (val_sum "constr_substituted" 0 [|[|val_a|];[|val_list val_subst;val_a|]|]) let from_val a = ref (LSval a) let rec replace_mp_in_mp mpfrom mpto mp = match mp with | _ when mp = mpfrom -> mpto | MPdot (mp1,l) -> let mp1' = replace_mp_in_mp mpfrom mpto mp1 in if mp1==mp1' then mp else MPdot (mp1',l) | _ -> mp let rec mp_in_mp mp mp1 = match mp1 with | _ when mp1 = mp -> true | MPdot (mp2,l) -> mp_in_mp mp mp2 | _ -> false let subset_prefixed_by mp resolver = let mp_prefix mkey mequ rslv = if mp_in_mp mp mkey then Deltamap.add_mp mkey mequ rslv else rslv in let kn_prefix kn hint rslv = match hint with | Inline _ -> rslv | Equiv _ -> if mp_in_mp mp (modpath kn) then Deltamap.add_kn kn hint rslv else rslv in Deltamap.fold mp_prefix kn_prefix resolver empty_delta_resolver let subst_dom_delta_resolver subst resolver = let mp_apply_subst mkey mequ rslv = Deltamap.add_mp (subst_mp subst mkey) mequ rslv in let kn_apply_subst kkey hint rslv = Deltamap.add_kn (subst_kn subst kkey) hint rslv in Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver let subst_mp_delta sub mp mkey = match subst_mp0 sub mp with None -> empty_delta_resolver,mp | Some (mp',resolve) -> let mp1 = find_prefix resolve mp' in let resolve1 = subset_prefixed_by mp1 resolve in (subst_dom_delta_resolver (map_mp mp1 mkey) resolve1),mp1 let gen_subst_delta_resolver dom subst resolver = let mp_apply_subst mkey mequ rslv = let mkey' = if dom then subst_mp subst mkey else mkey in let rslv',mequ' = subst_mp_delta subst mequ mkey in Deltamap.join rslv' (Deltamap.add_mp mkey' mequ' rslv) in let kn_apply_subst kkey hint rslv = let kkey' = if dom then subst_kn subst kkey else kkey in let hint' = match hint with | Equiv kequ -> Equiv (subst_kn_delta subst kequ) | Inline (lev,Some t) -> Inline (lev,Some (subst_mps subst t)) | Inline (_,None) -> hint in Deltamap.add_kn kkey' hint' rslv in Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver let subst_codom_delta_resolver = gen_subst_delta_resolver false let subst_dom_codom_delta_resolver = gen_subst_delta_resolver true let update_delta_resolver resolver1 resolver2 = let mp_apply_rslv mkey mequ rslv = if Deltamap.mem_mp mkey resolver2 then rslv else Deltamap.add_mp mkey (find_prefix resolver2 mequ) rslv in let kn_apply_rslv kkey hint rslv = if Deltamap.mem_kn kkey resolver2 then rslv else let hint' = match hint with | Equiv kequ -> Equiv (solve_delta_kn resolver2 kequ) | _ -> hint in Deltamap.add_kn kkey hint' rslv in Deltamap.fold mp_apply_rslv kn_apply_rslv resolver1 empty_delta_resolver let add_delta_resolver resolver1 resolver2 = if resolver1 == resolver2 then resolver2 else if resolver2 = empty_delta_resolver then resolver1 else Deltamap.join (update_delta_resolver resolver1 resolver2) resolver2 let substition_prefixed_by k mp subst = let mp_prefixmp kmp (mp_to,reso) sub = if mp_in_mp mp kmp && mp <> kmp then let new_key = replace_mp_in_mp mp k kmp in Umap.add_mp new_key (mp_to,reso) sub else sub in let mbi_prefixmp mbi _ sub = sub in Umap.fold mp_prefixmp mbi_prefixmp subst empty_subst let join subst1 subst2 = let apply_subst mpk add (mp,resolve) res = let mp',resolve' = match subst_mp0 subst2 mp with | None -> mp, None | Some (mp',resolve') -> mp', Some resolve' in let resolve'' = match resolve' with | Some res -> add_delta_resolver (subst_dom_codom_delta_resolver subst2 resolve) res | None -> subst_codom_delta_resolver subst2 resolve in let prefixed_subst = substition_prefixed_by mpk mp' subst2 in Umap.join prefixed_subst (add (mp',resolve'') res) in let mp_apply_subst mp = apply_subst mp (Umap.add_mp mp) in let mbi_apply_subst mbi = apply_subst (MPbound mbi) (Umap.add_mbi mbi) in let subst = Umap.fold mp_apply_subst mbi_apply_subst subst1 empty_subst in Umap.join subst2 subst let force fsubst r = match !r with | LSval a -> a | LSlazy(s,a) -> let subst = List.fold_left join empty_subst (List.rev s) in let a' = fsubst subst a in r := LSval a'; a' let subst_substituted s r = match !r with | LSval a -> ref (LSlazy([s],a)) | LSlazy(s',a) -> ref (LSlazy(s::s',a)) let force_constr = force subst_mps type constr_substituted = constr substituted let val_cstr_subst = val_substituted val_constr let subst_constr_subst = subst_substituted (** Beware! In .vo files, lazy_constr are stored as integers used as indexes for a separate table. The actual lazy_constr is restored later, by [Safe_typing.LightenLibrary.load]. This allows us to use here a different definition of lazy_constr than coqtop: since the checker will inspect all proofs parts, even opaque ones, no need to use Lazy.t here *) type lazy_constr = constr_substituted let subst_lazy_constr = subst_substituted let force_lazy_constr = force_constr let lazy_constr_from_val c = c let val_lazy_constr = val_cstr_subst (** Inlining level of parameters at functor applications. This is ignored by the checker. *) type inline = int option (** A constant can have no body (axiom/parameter), or a transparent body, or an opaque one *) type constant_def = | Undef of inline | Def of constr_substituted | OpaqueDef of lazy_constr let val_cst_def = val_sum "constant_def" 0 [|[|val_opt val_int|]; [|val_cstr_subst|]; [|val_lazy_constr|]|] let subst_constant_def sub = function | Undef inl -> Undef inl | Def c -> Def (subst_constr_subst sub c) | OpaqueDef lc -> OpaqueDef (subst_lazy_constr sub lc) type constant_body = { const_hyps : section_context; (* New: younger hyp at top *) const_body : constant_def; const_type : constant_type; const_body_code : to_patch_substituted; const_constraints : Univ.constraints } let body_of_constant cb = match cb.const_body with | Undef _ -> None | Def c -> Some c | OpaqueDef c -> Some c let constant_has_body cb = match cb.const_body with | Undef _ -> false | Def _ | OpaqueDef _ -> true let is_opaque cb = match cb.const_body with | OpaqueDef _ -> true | Def _ | Undef _ -> false let val_cb = val_tuple ~name:"constant_body" [|val_nctxt; val_cst_def; val_cst_type; no_val; val_cstrs|] let subst_rel_declaration sub (id,copt,t as x) = let copt' = Option.smartmap (subst_mps sub) copt in let t' = subst_mps sub t in if copt == copt' & t == t' then x else (id,copt',t') let subst_rel_context sub = list_smartmap (subst_rel_declaration sub) type recarg = | Norec | Mrec of inductive | Imbr of inductive let val_recarg = val_sum "recarg" 1 (* Norec *) [|[|val_ind|] (* Mrec *);[|val_ind|] (* Imbr *)|] let subst_recarg sub r = match r with | Norec -> r | (Mrec(kn,i)|Imbr (kn,i)) -> let kn' = subst_ind sub kn in if kn==kn' then r else Imbr (kn',i) type wf_paths = recarg Rtree.t let val_wfp = val_rec_sum "wf_paths" 0 (fun val_wfp -> [|[|val_int;val_int|]; (* Rtree.Param *) [|val_recarg;val_array val_wfp|]; (* Rtree.Node *) [|val_int;val_array val_wfp|] (* Rtree.Rec *) |]) let mk_norec = Rtree.mk_node Norec [||] let mk_paths r recargs = Rtree.mk_node r (Array.map (fun l -> Rtree.mk_node Norec (Array.of_list l)) recargs) let dest_recarg p = fst (Rtree.dest_node p) let dest_subterms p = let (_,cstrs) = Rtree.dest_node p in Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p (**********************************************************************) (* Representation of mutual inductive types in the kernel *) (* Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1 ... with In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn *) type monomorphic_inductive_arity = { mind_user_arity : constr; mind_sort : sorts; } let val_mono_ind_arity = val_tuple ~name:"monomorphic_inductive_arity"[|val_constr;val_sort|] type inductive_arity = | Monomorphic of monomorphic_inductive_arity | Polymorphic of polymorphic_arity let val_ind_arity = val_sum "inductive_arity" 0 [|[|val_mono_ind_arity|];[|val_pol_arity|]|] type one_inductive_body = { (* Primitive datas *) (* Name of the type: [Ii] *) mind_typename : identifier; (* Arity context of [Ii] with parameters: [forall params, Ui] *) mind_arity_ctxt : rel_context; (* Arity sort, original user arity, and allowed elim sorts, if monomorphic *) mind_arity : inductive_arity; (* Names of the constructors: [cij] *) mind_consnames : identifier array; (* Types of the constructors with parameters: [forall params, Tij], where the Ik are replaced by de Bruijn index in the context I1:forall params, U1 .. In:forall params, Un *) mind_user_lc : constr array; (* Derived datas *) (* Number of expected real arguments of the type (no let, no params) *) mind_nrealargs : int; (* Length of realargs context (with let, no params) *) mind_nrealargs_ctxt : int; (* List of allowed elimination sorts *) mind_kelim : sorts_family list; (* Head normalized constructor types so that their conclusion is atomic *) mind_nf_lc : constr array; (* Length of the signature of the constructors (with let, w/o params) *) mind_consnrealdecls : int array; (* Signature of recursive arguments in the constructors *) mind_recargs : wf_paths; (* Datas for bytecode compilation *) (* number of constant constructor *) mind_nb_constant : int; (* number of no constant constructor *) mind_nb_args : int; mind_reloc_tbl : reloc_table; } let val_one_ind = val_tuple ~name:"one_inductive_body" [|val_id;val_rctxt;val_ind_arity;val_array val_id;val_array val_constr; val_int;val_int;val_list val_sortfam;val_array val_constr;val_array val_int; val_wfp;val_int;val_int;no_val|] type mutual_inductive_body = { (* The component of the mutual inductive block *) mind_packets : one_inductive_body array; (* Whether the inductive type has been declared as a record *) mind_record : bool; (* Whether the type is inductive or coinductive *) mind_finite : bool; (* Number of types in the block *) mind_ntypes : int; (* Section hypotheses on which the block depends *) mind_hyps : section_context; (* Number of expected parameters *) mind_nparams : int; (* Number of recursively uniform (i.e. ordinary) parameters *) mind_nparams_rec : int; (* The context of parameters (includes let-in declaration) *) mind_params_ctxt : rel_context; (* Universes constraints enforced by the inductive declaration *) mind_constraints : Univ.constraints; } let val_ind_pack = val_tuple ~name:"mutual_inductive_body" [|val_array val_one_ind;val_bool;val_bool;val_int;val_nctxt; val_int; val_int; val_rctxt;val_cstrs|] let subst_arity sub = function | NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s) | PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s) (* TODO: should be changed to non-coping after Term.subst_mps *) let subst_const_body sub cb = { const_hyps = (assert (cb.const_hyps=[]); []); const_body = subst_constant_def sub cb.const_body; const_type = subst_arity sub cb.const_type; const_body_code = (*Cemitcodes.subst_to_patch_subst sub*) cb.const_body_code; const_constraints = cb.const_constraints} let subst_arity sub = function | Monomorphic s -> Monomorphic { mind_user_arity = subst_mps sub s.mind_user_arity; mind_sort = s.mind_sort; } | Polymorphic s as x -> x let subst_mind_packet sub mbp = { mind_consnames = mbp.mind_consnames; mind_consnrealdecls = mbp.mind_consnrealdecls; mind_typename = mbp.mind_typename; mind_nf_lc = array_smartmap (subst_mps sub) mbp.mind_nf_lc; mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt; mind_arity = subst_arity sub mbp.mind_arity; mind_user_lc = array_smartmap (subst_mps sub) mbp.mind_user_lc; mind_nrealargs = mbp.mind_nrealargs; mind_nrealargs_ctxt = mbp.mind_nrealargs_ctxt; mind_kelim = mbp.mind_kelim; mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); mind_nb_constant = mbp.mind_nb_constant; mind_nb_args = mbp.mind_nb_args; mind_reloc_tbl = mbp.mind_reloc_tbl } let subst_mind sub mib = { mind_record = mib.mind_record ; mind_finite = mib.mind_finite ; mind_ntypes = mib.mind_ntypes ; mind_hyps = (assert (mib.mind_hyps=[]); []) ; mind_nparams = mib.mind_nparams; mind_nparams_rec = mib.mind_nparams_rec; mind_params_ctxt = map_rel_context (subst_mps sub) mib.mind_params_ctxt; mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ; mind_constraints = mib.mind_constraints } (* Modules *) (* Whenever you change these types, please do update the validation functions below *) type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body | SFBmodtype of module_type_body and structure_body = (label * structure_field_body) list and struct_expr_body = | SEBident of module_path | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body | SEBapply of struct_expr_body * struct_expr_body * Univ.constraints | SEBstruct of structure_body | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = With_module_body of identifier list * module_path | With_definition_body of identifier list * constant_body and module_body = { mod_mp : module_path; mod_expr : struct_expr_body option; mod_type : struct_expr_body; mod_type_alg : struct_expr_body option; mod_constraints : Univ.constraints; mod_delta : delta_resolver; mod_retroknowledge : action list} and module_type_body = { typ_mp : module_path; typ_expr : struct_expr_body; typ_expr_alg : struct_expr_body option ; typ_constraints : Univ.constraints; typ_delta :delta_resolver} (* the validation functions: *) let rec val_sfb o = val_sum "struct_field_body" 0 [|[|val_cb|]; (* SFBconst *) [|val_ind_pack|]; (* SFBmind *) [|val_module|]; (* SFBmodule *) [|val_modtype|] (* SFBmodtype *) |] o and val_sb o = val_list (val_tuple ~name:"label*sfb"[|val_id;val_sfb|]) o and val_seb o = val_sum "struct_expr_body" 0 [|[|val_mp|]; (* SEBident *) [|val_uid;val_modtype;val_seb|]; (* SEBfunctor *) [|val_seb;val_seb;val_cstrs|]; (* SEBapply *) [|val_sb|]; (* SEBstruct *) [|val_seb;val_with|] (* SEBwith *) |] o and val_with o = val_sum "with_declaration_body" 0 [|[|val_list val_id;val_mp|]; [|val_list val_id;val_cb|]|] o and val_module o = val_tuple ~name:"module_body" [|val_mp;val_opt val_seb;val_seb; val_opt val_seb;val_cstrs;val_res;no_val|] o and val_modtype o = val_tuple ~name:"module_type_body" [|val_mp;val_seb;val_opt val_seb;val_cstrs;val_res|] o let rec subst_with_body sub = function | With_module_body(id,mp) -> With_module_body(id,subst_mp sub mp) | With_definition_body(id,cb) -> With_definition_body( id,subst_const_body sub cb) and subst_modtype sub mtb= let typ_expr' = subst_struct_expr sub mtb.typ_expr in let typ_alg' = Option.smartmap (subst_struct_expr sub) mtb.typ_expr_alg in let mp = subst_mp sub mtb.typ_mp in if typ_expr'==mtb.typ_expr && typ_alg'==mtb.typ_expr_alg && mp==mtb.typ_mp then mtb else {mtb with typ_mp = mp; typ_expr = typ_expr'; typ_expr_alg = typ_alg'} and subst_structure sub sign = let subst_body = function SFBconst cb -> SFBconst (subst_const_body sub cb) | SFBmind mib -> SFBmind (subst_mind sub mib) | SFBmodule mb -> SFBmodule (subst_module sub mb) | SFBmodtype mtb -> SFBmodtype (subst_modtype sub mtb) in List.map (fun (l,b) -> (l,subst_body b)) sign and subst_module sub mb = let mtb' = subst_struct_expr sub mb.mod_type in let typ_alg' = Option.smartmap (subst_struct_expr sub ) mb.mod_type_alg in let me' = Option.smartmap (subst_struct_expr sub) mb.mod_expr in let mp = subst_mp sub mb.mod_mp in if mtb'==mb.mod_type && mb.mod_expr == me' && mp == mb.mod_mp then mb else { mb with mod_mp = mp; mod_expr = me'; mod_type_alg = typ_alg'; mod_type=mtb'} and subst_struct_expr sub = function | SEBident mp -> SEBident (subst_mp sub mp) | SEBfunctor (mbid, mtb, meb') -> SEBfunctor(mbid,subst_modtype sub mtb ,subst_struct_expr sub meb') | SEBstruct (str)-> SEBstruct( subst_structure sub str) | SEBapply (meb1,meb2,cst)-> SEBapply(subst_struct_expr sub meb1, subst_struct_expr sub meb2, cst) | SEBwith (meb,wdb)-> SEBwith(subst_struct_expr sub meb, subst_with_body sub wdb) coq-8.4pl4/checker/check.ml0000644000175000017500000003152412326224777014653 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* failwith "path_of_dirpath" | l::dir -> {dirpath=List.map string_of_id dir;basename=string_of_id l} let pr_dirlist dp = prlist_with_sep (fun _ -> str".") str (List.rev dp) let pr_path sp = match sp.dirpath with [] -> str sp.basename | sl -> pr_dirlist sl ++ str"." ++ str sp.basename type library_objects type compilation_unit_name = dir_path type library_disk = { md_name : compilation_unit_name; md_compiled : Safe_typing.LightenLibrary.lightened_compiled_library; md_objects : library_objects; md_deps : (compilation_unit_name * Digest.t) list; md_imports : compilation_unit_name list } (************************************************************************) (*s Modules on disk contain the following informations (after the magic number, and before the digest). *) (*s Modules loaded in memory contain the following informations. They are kept in the global table [libraries_table]. *) type library_t = { library_name : compilation_unit_name; library_filename : System.physical_path; library_compiled : Safe_typing.compiled_library; library_deps : (compilation_unit_name * Digest.t) list; library_digest : Digest.t } module LibraryOrdered = struct type t = dir_path let compare d1 d2 = Pervasives.compare (List.rev (repr_dirpath d1)) (List.rev (repr_dirpath d2)) end module LibrarySet = Set.Make(LibraryOrdered) module LibraryMap = Map.Make(LibraryOrdered) (* This is a map from names to loaded libraries *) let libraries_table = ref LibraryMap.empty (* various requests to the tables *) let find_library dir = LibraryMap.find dir !libraries_table let try_find_library dir = try find_library dir with Not_found -> error ("Unknown library " ^ (string_of_dirpath dir)) let library_full_filename dir = (find_library dir).library_filename (* If a library is loaded several time, then the first occurrence must be performed first, thus the libraries_loaded_list ... *) let register_loaded_library m = libraries_table := LibraryMap.add m.library_name m !libraries_table let check_one_lib admit (dir,m) = let file = m.library_filename in let md = m.library_compiled in let dig = m.library_digest in (* Look up if the library is to be admitted correct. We could also check if it carries a validation certificate (yet to be implemented). *) if LibrarySet.mem dir admit then (Flags.if_verbose msgnl (str "Admitting library: " ++ pr_dirpath dir); Safe_typing.unsafe_import file md dig) else (Flags.if_verbose msgnl (str "Checking library: " ++ pr_dirpath dir); Safe_typing.import file md dig); Flags.if_verbose msg(fnl()); register_loaded_library m (*************************************************************************) (*s Load path. Mapping from physical to logical paths etc.*) type logical_path = dir_path let load_paths = ref ([],[] : System.physical_path list * logical_path list) let get_load_paths () = fst !load_paths (* Hints to partially detects if two paths refer to the same repertory *) let rec remove_path_dot p = let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *) let n = String.length curdir in if String.length p > n && String.sub p 0 n = curdir then remove_path_dot (String.sub p n (String.length p - n)) else p let strip_path p = let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *) let n = String.length cwd in if String.length p > n && String.sub p 0 n = cwd then remove_path_dot (String.sub p n (String.length p - n)) else remove_path_dot p let canonical_path_name p = let current = Sys.getcwd () in try Sys.chdir p; let p' = Sys.getcwd () in Sys.chdir current; p' with Sys_error _ -> (* We give up to find a canonical name and just simplify it... *) strip_path p let find_logical_path phys_dir = let phys_dir = canonical_path_name phys_dir in match list_filter2 (fun p d -> p = phys_dir) !load_paths with | _,[dir] -> dir | _,[] -> default_root_prefix | _,l -> anomaly ("Two logical paths are associated to "^phys_dir) let remove_load_path dir = load_paths := list_filter2 (fun p d -> p <> dir) !load_paths let add_load_path (phys_path,coq_path) = if !Flags.debug then msgnl (str "path: " ++ pr_dirpath coq_path ++ str " ->" ++ spc() ++ str phys_path); let phys_path = canonical_path_name phys_path in match list_filter2 (fun p d -> p = phys_path) !load_paths with | _,[dir] -> if coq_path <> dir (* If this is not the default -I . to coqtop *) && not (phys_path = canonical_path_name Filename.current_dir_name && coq_path = default_root_prefix) then begin (* Assume the user is concerned by library naming *) if dir <> default_root_prefix then Flags.if_warn msg_warning (str phys_path ++ strbrk " was previously bound to " ++ pr_dirpath dir ++ strbrk "; it is remapped to " ++ pr_dirpath coq_path); remove_load_path phys_path; load_paths := (phys_path::fst !load_paths, coq_path::snd !load_paths) end | _,[] -> load_paths := (phys_path :: fst !load_paths, coq_path :: snd !load_paths) | _ -> anomaly ("Two logical paths are associated to "^phys_path) let load_paths_of_dir_path dir = fst (list_filter2 (fun p d -> d = dir) !load_paths) (************************************************************************) (*s Locate absolute or partially qualified library names in the path *) exception LibUnmappedDir exception LibNotFound let locate_absolute_library dir = (* Search in loadpath *) let pref, base = split_dirpath dir in let loadpath = load_paths_of_dir_path pref in if loadpath = [] then raise LibUnmappedDir; try let name = string_of_id base^".vo" in let _, file = System.where_in_path ~warn:false loadpath name in (dir, file) with Not_found -> (* Last chance, removed from the file system but still in memory *) try (dir, library_full_filename dir) with Not_found -> raise LibNotFound let locate_qualified_library qid = try let loadpath = (* Search library in loadpath *) if qid.dirpath=[] then get_load_paths () else (* we assume qid is an absolute dirpath *) load_paths_of_dir_path (dir_of_path qid) in if loadpath = [] then raise LibUnmappedDir; let name = qid.basename^".vo" in let path, file = System.where_in_path loadpath name in let dir = extend_dirpath (find_logical_path path) (id_of_string qid.basename) in (* Look if loaded *) try (dir, library_full_filename dir) with Not_found -> (dir, file) with Not_found -> raise LibNotFound let explain_locate_library_error qid = function | LibUnmappedDir -> let prefix = qid.dirpath in errorlabstrm "load_absolute_library_from" (str "Cannot load " ++ pr_path qid ++ str ":" ++ spc () ++ str "no physical path bound to" ++ spc () ++ pr_dirlist prefix ++ fnl ()) | LibNotFound -> errorlabstrm "load_absolute_library_from" (str"Cannot find library " ++ pr_path qid ++ str" in loadpath") | e -> raise e let try_locate_absolute_library dir = try locate_absolute_library dir with e -> explain_locate_library_error (path_of_dirpath dir) e let try_locate_qualified_library qid = try locate_qualified_library qid with e -> explain_locate_library_error qid e (************************************************************************) (*s Low-level interning/externing of libraries to files *) (*s Loading from disk to cache (preparation phase) *) let raw_intern_library = snd (System.raw_extern_intern Coq_config.vo_magic_number ".vo") let with_magic_number_check f a = try f a with System.Bad_magic_number fname -> errorlabstrm "with_magic_number_check" (str"file " ++ str fname ++ spc () ++ str"has bad magic number." ++ spc () ++ str"It is corrupted" ++ spc () ++ str"or was compiled with another version of Coq.") (************************************************************************) (* Internalise libraries *) let mk_library md f table digest = { library_name = md.md_name; library_filename = f; library_compiled = Safe_typing.LightenLibrary.load table md.md_compiled; library_deps = md.md_deps; library_digest = digest } let name_clash_message dir mdir f = str ("The file " ^ f ^ " contains library") ++ spc () ++ pr_dirpath mdir ++ spc () ++ str "and not library" ++ spc() ++ pr_dirpath dir (* Dependency graph *) let depgraph = ref LibraryMap.empty let intern_from_file (dir, f) = Flags.if_verbose msg (str"[intern "++str f++str" ..."); let (md,table,digest) = try let ch = with_magic_number_check raw_intern_library f in let (md:library_disk) = System.marshal_in f ch in let digest = System.marshal_in f ch in let table = (System.marshal_in f ch : Safe_typing.LightenLibrary.table) in close_in ch; if dir <> md.md_name then errorlabstrm "load_physical_library" (name_clash_message dir md.md_name f); Flags.if_verbose msgnl(str" done]"); md,table,digest with e -> Flags.if_verbose msgnl(str" failed!]"); raise e in depgraph := LibraryMap.add md.md_name md.md_deps !depgraph; mk_library md f table digest let get_deps (dir, f) = try LibraryMap.find dir !depgraph with Not_found -> let _ = intern_from_file (dir,f) in LibraryMap.find dir !depgraph (* Read a compiled library and all dependencies, in reverse order. Do not include files that are already in the context. *) let rec intern_library seen (dir, f) needed = if LibrarySet.mem dir seen then failwith "Recursive dependencies!"; (* Look if in the current logical environment *) try let _ = find_library dir in needed with Not_found -> (* Look if already listed and consequently its dependencies too *) if List.mem_assoc dir needed then needed else (* [dir] is an absolute name which matches [f] which must be in loadpath *) let m = intern_from_file (dir,f) in let seen' = LibrarySet.add dir seen in let deps = List.map (fun (d,_) -> try_locate_absolute_library d) m.library_deps in (dir,m) :: List.fold_right (intern_library seen') deps needed (* Compute the reflexive transitive dependency closure *) let rec fold_deps seen ff (dir,f) (s,acc) = if LibrarySet.mem dir seen then failwith "Recursive dependencies!"; if LibrarySet.mem dir s then (s,acc) else let deps = get_deps (dir,f) in let deps = List.map (fun (d,_) -> try_locate_absolute_library d) deps in let seen' = LibrarySet.add dir seen in let (s',acc') = List.fold_right (fold_deps seen' ff) deps (s,acc) in (LibrarySet.add dir s', ff dir acc') and fold_deps_list seen ff modl needed = List.fold_right (fold_deps seen ff) modl needed let fold_deps_list ff modl acc = snd (fold_deps_list LibrarySet.empty ff modl (LibrarySet.empty,acc)) let recheck_library ~norec ~admit ~check = let ml = List.map try_locate_qualified_library check in let nrl = List.map try_locate_qualified_library norec in let al = List.map try_locate_qualified_library admit in let needed = List.rev (List.fold_right (intern_library LibrarySet.empty) (ml@nrl) []) in (* first compute the closure of norec, remove closure of check, add closure of admit, and finally remove norec and check *) let nochk = fold_deps_list LibrarySet.add nrl LibrarySet.empty in let nochk = fold_deps_list LibrarySet.remove ml nochk in let nochk = fold_deps_list LibrarySet.add al nochk in (* explicitly required modules cannot be skipped... *) let nochk = List.fold_right LibrarySet.remove (List.map fst (nrl@ml)) nochk in (* *) Flags.if_verbose msgnl (fnl()++hv 2 (str "Ordered list:" ++ fnl() ++ prlist (fun (dir,_) -> pr_dirpath dir ++ fnl()) needed)); List.iter (check_one_lib nochk) needed; Flags.if_verbose msgnl(str"Modules were successfully checked") open Printf let mem s = let m = try_find_library s in h 0 (str (sprintf "%dk" (size_kb m))) coq-8.4pl4/checker/checker.ml0000644000175000017500000003006612326224777015202 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* =len then dirs else let pos = try String.index_from s n '.' with Not_found -> len in let dir = String.sub s n (pos-n) in decoupe_dirs (dir::dirs) (pos+1) in decoupe_dirs [] 0 let dirpath_of_string s = match parse_dir s with [] -> Check.default_root_prefix | dir -> make_dirpath (List.map id_of_string dir) let path_of_string s = match parse_dir s with [] -> invalid_arg "path_of_string" | l::dir -> {dirpath=dir; basename=l} let (/) = Filename.concat let get_version_date () = try let coqlib = Envars.coqlib () in let ch = open_in (Filename.concat coqlib "revision") in let ver = input_line ch in let rev = input_line ch in (ver,rev) with _ -> (Coq_config.version,Coq_config.date) let print_header () = let (ver,rev) = (get_version_date ()) in Printf.printf "Welcome to Chicken %s (%s)\n" ver rev; flush stdout (* Adding files to Coq loadpath *) let add_path ~unix_path:dir ~coq_root:coq_dirpath = if exists_dir dir then begin Check.add_load_path (dir,coq_dirpath) end else msg_warning (str ("Cannot open " ^ dir)) let convert_string d = try id_of_string d with _ -> if_verbose warning ("Directory "^d^" cannot be used as a Coq identifier (skipped)"); flush_all (); failwith "caught" let add_rec_path ~unix_path ~coq_root = if exists_dir unix_path then let dirs = all_subdirs ~unix_path in let prefix = repr_dirpath coq_root in let convert_dirs (lp,cp) = (lp,make_dirpath (List.map convert_string (List.rev cp)@prefix)) in let dirs = map_succeed convert_dirs dirs in List.iter Check.add_load_path dirs; Check.add_load_path (unix_path, coq_root) else msg_warning (str ("Cannot open " ^ unix_path)) (* By the option -include -I or -R of the command line *) let includes = ref [] let push_include (s, alias) = includes := (s,alias,false) :: !includes let push_rec_include (s, alias) = includes := (s,alias,true) :: !includes let set_default_include d = push_include (d, Check.default_root_prefix) let set_include d p = let p = dirpath_of_string p in push_include (d,p) let set_rec_include d p = let p = dirpath_of_string p in push_rec_include(d,p) (* Initializes the LoadPath *) let init_load_path () = let coqlib = Envars.coqlib () in let user_contrib = coqlib/"user-contrib" in let xdg_dirs = Envars.xdg_dirs in let coqpath = Envars.coqpath in let plugins = coqlib/"plugins" in (* NOTE: These directories are searched from last to first *) (* first standard library *) add_rec_path ~unix_path:(coqlib/"theories") ~coq_root:(Names.make_dirpath[coq_root]); (* then plugins *) add_rec_path ~unix_path:plugins ~coq_root:(Names.make_dirpath [coq_root]); (* then user-contrib *) if Sys.file_exists user_contrib then add_rec_path ~unix_path:user_contrib ~coq_root:Check.default_root_prefix; (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME *) List.iter (fun s -> add_rec_path ~unix_path:s ~coq_root:Check.default_root_prefix) xdg_dirs; (* then directories in COQPATH *) List.iter (fun s -> add_rec_path ~unix_path:s ~coq_root:Check.default_root_prefix) coqpath; (* then current directory *) add_path ~unix_path:"." ~coq_root:Check.default_root_prefix; (* additional loadpath, given with -I -include -R options *) List.iter (fun (unix_path, coq_root, reci) -> if reci then add_rec_path ~unix_path ~coq_root else add_path ~unix_path ~coq_root) (List.rev !includes); includes := [] let set_debug () = Flags.debug := true let engagement = ref None let set_engagement c = engagement := Some c let engage () = match !engagement with Some c -> Safe_typing.set_engagement c | None -> () let admit_list = ref ([] : section_path list) let add_admit s = admit_list := path_of_string s :: !admit_list let norec_list = ref ([] : section_path list) let add_norec s = norec_list := path_of_string s :: !norec_list let compile_list = ref ([] : section_path list) let add_compile s = compile_list := path_of_string s :: !compile_list (*s Parsing of the command line. We no longer use [Arg.parse], in order to use share [Usage.print_usage] between coqtop and coqc. *) let compile_files () = Check.recheck_library ~norec:(List.rev !norec_list) ~admit:(List.rev !admit_list) ~check:(List.rev !compile_list) let version () = Printf.printf "The Coq Proof Checker, version %s (%s)\n" Coq_config.version Coq_config.date; Printf.printf "compiled on %s\n" Coq_config.compile_date; exit 0 (* print the usage of coqtop (or coqc) on channel co *) let print_usage_channel co command = output_string co command; output_string co "coqchk options are:\n"; output_string co " -I dir -as coqdir map physical dir to logical coqdir\ \n -I dir map directory dir to the empty logical path\ \n -include dir (idem)\ \n -R dir -as coqdir recursively map physical dir to logical coqdir\ \n -R dir coqdir (idem)\ \n\ \n -admit module load module and dependencies without checking\ \n -norec module check module but admit dependencies without checking\ \n\ \n -where print coqchk's standard library location and exit\ \n -v print coqchk version and exit\ \n -boot boot mode\ \n -o, --output-context print the list of assumptions\ \n -m, --memory print the maximum heap size\ \n -silent disable trace of constants being checked\ \n\ \n -impredicative-set set sort Set impredicative\ \n\ \n -h, --help print this list of options\ \n" (* print the usage on standard error *) let print_usage = print_usage_channel stderr let print_usage_coqtop () = print_usage "Usage: coqchk modules\n\n" let usage () = print_usage_coqtop (); flush stderr; exit 1 open Type_errors let anomaly_string () = str "Anomaly: " let report () = (str "." ++ spc () ++ str "Please report.") let print_loc loc = if loc = dummy_loc then (str"") else let loc = unloc loc in (int (fst loc) ++ str"-" ++ int (snd loc)) let guill s = "\""^s^"\"" let where s = if !Flags.debug then (str"in " ++ str s ++ str":" ++ spc ()) else (mt ()) let rec explain_exn = function | Stream.Failure -> hov 0 (anomaly_string () ++ str "uncaught Stream.Failure.") | Stream.Error txt -> hov 0 (str "Syntax error: " ++ str txt) | Token.Error txt -> hov 0 (str "Syntax error: " ++ str txt) | Sys_error msg -> hov 0 (anomaly_string () ++ str "uncaught exception Sys_error " ++ str (guill msg) ++ report() ) | UserError(s,pps) -> hov 1 (str "User error: " ++ where s ++ pps) | Out_of_memory -> hov 0 (str "Out of memory") | Stack_overflow -> hov 0 (str "Stack overflow") | Anomaly (s,pps) -> hov 1 (anomaly_string () ++ where s ++ pps ++ report ()) | Match_failure(filename,pos1,pos2) -> hov 1 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++ str " at line " ++ int pos1 ++ str " character " ++ int pos2 ++ report ()) | Not_found -> hov 0 (anomaly_string () ++ str "uncaught exception Not_found" ++ report ()) | Failure s -> hov 0 (str "Failure: " ++ str s ++ report ()) | Invalid_argument s -> hov 0 (anomaly_string () ++ str "uncaught exception Invalid_argument " ++ str (guill s) ++ report ()) | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.") | Univ.UniverseInconsistency (o,u,v) -> let msg = if !Flags.debug (*!Constrextern.print_universes*) then spc() ++ str "(cannot enforce" ++ spc() ++ (*Univ.pr_uni u ++*) spc() ++ str (match o with Univ.Lt -> "<" | Univ.Le -> "<=" | Univ.Eq -> "=") ++ spc() ++ (*Univ.pr_uni v ++*) str")" else mt() in hov 0 (str "Error: Universe inconsistency" ++ msg ++ str ".") | TypeError(ctx,te) -> (* hov 0 (str "Error:" ++ spc () ++ Himsg.explain_type_error ctx *) (* te)*) hov 0 (str "Type error") | Indtypes.InductiveError e -> hov 0 (str "Error related to inductive types") (* let ctx = Check.get_env() in hov 0 (str "Error:" ++ spc () ++ Himsg.explain_inductive_error ctx e)*) | Loc.Exc_located (loc,exc) -> hov 0 ((if loc = dummy_loc then (mt ()) else (str"At location " ++ print_loc loc ++ str":" ++ fnl ())) ++ explain_exn exc) | Assert_failure (s,b,e) -> hov 0 (anomaly_string () ++ str "assert failure" ++ spc () ++ (if s = "" then mt () else (str ("(file \"" ^ s ^ "\", line ") ++ int b ++ str ", characters " ++ int e ++ str "-" ++ int (e+6) ++ str ")")) ++ report ()) | reraise -> hov 0 (anomaly_string () ++ str "Uncaught exception " ++ str (Printexc.to_string reraise)++report()) let parse_args argv = let rec parse = function | [] -> () | "-impredicative-set" :: rem -> set_engagement Declarations.ImpredicativeSet; parse rem | "-coqlib" :: s :: rem -> if not (exists_dir s) then (msgnl (str ("Directory '"^s^"' does not exist")); exit 1); Flags.coqlib := s; Flags.coqlib_spec := true; parse rem | ("-I"|"-include") :: d :: "-as" :: p :: rem -> set_include d p; parse rem | ("-I"|"-include") :: d :: "-as" :: [] -> usage () | ("-I"|"-include") :: d :: rem -> set_default_include d; parse rem | ("-I"|"-include") :: [] -> usage () | "-R" :: d :: "-as" :: p :: rem -> set_rec_include d p;parse rem | "-R" :: d :: "-as" :: [] -> usage () | "-R" :: d :: p :: rem -> set_rec_include d p;parse rem | "-R" :: ([] | [_]) -> usage () | "-debug" :: rem -> set_debug (); parse rem | "-where" :: _ -> print_endline (Envars.coqlib ()); exit 0 | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () | ("-v"|"--version") :: _ -> version () | "-boot" :: rem -> boot := true; parse rem | ("-m" | "--memory") :: rem -> Check_stat.memory_stat := true; parse rem | ("-o" | "--output-context") :: rem -> Check_stat.output_context := true; parse rem | "-no-hash-consing" :: rem -> Flags.hash_cons_proofs := false; parse rem | "-admit" :: s :: rem -> add_admit s; parse rem | "-admit" :: [] -> usage () | "-norec" :: s :: rem -> add_norec s; parse rem | "-norec" :: [] -> usage () | "-silent" :: rem -> Flags.make_silent true; parse rem | s :: _ when s<>"" && s.[0]='-' -> msgnl (str "Unknown option " ++ str s); exit 1 | s :: rem -> add_compile s; parse rem in try parse (List.tl (Array.to_list argv)) with | UserError(_,s) as e -> begin try Stream.empty s; exit 1 with Stream.Failure -> msgnl (explain_exn e); exit 1 end | e -> begin msgnl (explain_exn e); exit 1 end (* To prevent from doing the initialization twice *) let initialized = ref false let init_with_argv argv = if not !initialized then begin initialized := true; Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) try parse_args argv; if_verbose print_header (); init_load_path (); engage (); with e -> flush_all(); message "Error during initialization :"; msgnl (explain_exn e); exit 1 end let init() = init_with_argv Sys.argv let run () = try compile_files (); flush_all() with e -> (flush_all(); Pp.ppnl(explain_exn e); flush_all(); exit 1) let start () = init(); run(); Check_stat.stats(); exit 0 coq-8.4pl4/checker/check.mllib0000644000175000017500000000044312326224777015336 0ustar stephstephCoq_config Pp_control Pp Compat Flags Segmenttree Unicodetable Util Option Hashcons System Envars Predicate Rtree Names Univ Esubst Validate Term Declarations Environ Closure Reduction Type_errors Modops Inductive Typeops Indtypes Subtyping Mod_checking Safe_typing Check Check_stat Checker coq-8.4pl4/checker/include0000644000175000017500000001126112326224777014606 0ustar stephsteph(* -*-tuareg-*- *) (* Caml script to include for debugging the checker. Usage: from the checker/ directory launch ocaml toplevel and then type #use"include";; This command loads the relevent modules, defines some pretty printers, and provides functions to interactively check modules (mainly run_l and norec). *) #cd "..";; #directory "lib";; #directory "kernel";; #directory "checker";; #directory "+camlp4";; #directory "+camlp5";; #load "unix.cma";; #load "str.cma";; #load "gramlib.cma";; (*#load "toplevellib.cma";; #directory "/usr/lib/ocaml/compiler-libs/utils";; let _ = Clflags.recursive_types:=true;; *) #load "check.cma";; open Typeops;; open Check;; open Pp;; open Util;; open Names;; open Term;; open Environ;; open Declarations;; open Mod_checking;; let pr_id id = str(string_of_id id) let pr_na = function Name id -> pr_id id | _ -> str"_";; let prdp dp = pp(str(string_of_dirpath dp));; (* let prc c = pp(Himsg.pr_lconstr_env (Check.get_env()) c);; let prcs cs = prc (Declarations.force cs);; let pru u = pp(str(Univ.string_of_universe u));;*) let pru u = pp(Univ.pr_uni u);; let prlab l = pp(str(string_of_label l));; let prid id = pp(pr_id id);; let prcon c = pp(Indtypes.prcon c);; let prkn kn = pp(Indtypes.prkn kn);; let prus g = pp(Univ.pr_universes g);; let prcstrs c = let g = Univ.merge_constraints c Univ.initial_universes in pp(Univ.pr_universes g);; (*let prcstrs c = pp(Univ.pr_constraints c);; *) (* let prenvu e = let u = universes e in let pu = str "UNIVERSES:"++fnl()++str" "++hov 0 (Univ.pr_universes u) ++fnl() in pp pu;; let prenv e = let ctx1 = named_context e in let ctx2 = rel_context e in let pe = hov 1 (str"[" ++ prlist_with_sep spc (fun (na,_,_) -> pr_id na) (List.rev ctx1)++ str"]") ++ spc() ++ hov 1 (str"[" ++ prlist_with_sep spc (fun (na,_,_) -> pr_na na) (List.rev ctx2)++ str"]") in pp pe;; *) (* let prsub s = let string_of_mp mp = let s = string_of_mp mp in (match mp with MPbound _ -> "#bound."|_->"")^s in pp (hv 0 (fold_subst (fun msid mp strm -> str "S " ++ str (debug_string_of_msid msid) ++ str " |-> " ++ str (string_of_mp mp) ++ fnl() ++ strm) (fun mbid mp strm -> str"B " ++ str (debug_string_of_mbid mbid) ++ str " |-> " ++ str (string_of_mp mp) ++ fnl() ++ strm) (fun mp1 mp strm -> str"P " ++ str (string_of_mp mp1) ++ str " |-> " ++ str (string_of_mp mp) ++ fnl() ++ strm) s (mt()))) ;; *) #install_printer prid;; #install_printer prcon;; #install_printer prlab;; #install_printer prdp;; #install_printer prkn;; #install_printer pru;; (* #install_printer prc;; #install_printer prcs;; *) #install_printer prcstrs;; (*#install_printer prus;;*) (*#install_printer prenv;;*) (*#install_printer prenvu;; #install_printer prsub;;*) Checker.init_with_argv [|""|];; Flags.make_silent false;; Flags.debug := true;; Sys.catch_break true;; let module_of_file f = let (_,mb,_,_) = Obj.magic ((intern_from_file f).library_compiled) in (mb:module_body) ;; let mod_access m fld = match m.mod_expr with Some(SEBstruct l) -> List.assoc fld l | _ -> failwith "bad structure type" ;; let parse_dp s = make_dirpath(List.map id_of_string (List.rev (Str.split(Str.regexp"\\.") s))) ;; let parse_sp s = let l = List.rev (Str.split(Str.regexp"\\.") s) in {dirpath=List.tl l; basename=List.hd l};; let parse_kn s = let l = List.rev (Str.split(Str.regexp"\\.") s) in let dp = make_dirpath(List.map id_of_string(List.tl l)) in make_kn(MPfile dp) empty_dirpath (label_of_id (id_of_string (List.hd l))) ;; let parse_con s = let l = List.rev (Str.split(Str.regexp"\\.") s) in let dp = make_dirpath(List.map id_of_string(List.tl l)) in make_con(MPfile dp) empty_dirpath (label_of_id (id_of_string (List.hd l))) ;; let get_mod dp = lookup_module dp (Safe_typing.get_env()) ;; let get_mod_type dp = lookup_modtype dp (Safe_typing.get_env()) ;; let get_cst kn = lookup_constant kn (Safe_typing.get_env()) ;; let read_mod s f = let lib = intern_from_file (parse_dp s,f) in ((Obj.magic lib.library_compiled): dir_path * module_body * (dir_path * Digest.t) list * engagement option);; let deref_mod md s = let (Some (SEBstruct l)) = md.mod_expr in List.assoc (label_of_id(id_of_string s)) l ;; let expln f x = try f x with UserError(_,strm) as e -> msgnl strm; raise e let admit_l l = let l = List.map parse_sp l in Check.recheck_library ~admit:l ~check:l;; let run_l l = Check.recheck_library ~admit:[] ~check:(List.map parse_sp l);; let norec q = Check.recheck_library ~norec:[parse_sp q] ~admit:[] ~check:[];; (* admit_l["Bool";"OrderedType";"DecidableType"];; run_l["FSetInterface"];; *) coq-8.4pl4/checker/reduction.ml0000644000175000017500000003657112326224777015601 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | Zupdate _::s -> is_empty_stack s | Zshift _::s -> is_empty_stack s | _ -> false (* Compute the lift to be performed on a term placed in a given stack *) let el_stack el stk = let n = List.fold_left (fun i z -> match z with Zshift n -> i+n | _ -> i) 0 stk in el_shft n el let compare_stack_shape stk1 stk2 = let rec compare_rec bal stk1 stk2 = match (stk1,stk2) with ([],[]) -> bal=0 | ((Zupdate _|Zshift _)::s1, _) -> compare_rec bal s1 stk2 | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2 | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2 | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 | (Zcase(c1,_,_)::s1, Zcase(c2,_,_)::s2) -> bal=0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> bal=0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 | (_,_) -> false in compare_rec 0 stk1 stk2 type lft_constr_stack_elt = Zlapp of (lift * fconstr) array | Zlfix of (lift * fconstr) * lft_constr_stack | Zlcase of case_info * lift * fconstr * fconstr array and lft_constr_stack = lft_constr_stack_elt list let rec zlapp v = function Zlapp v2 :: s -> zlapp (Array.append v v2) s | s -> Zlapp v :: s let pure_stack lfts stk = let rec pure_rec lfts stk = match stk with [] -> (lfts,[]) | zi::s -> (match (zi,pure_rec lfts s) with (Zupdate _,lpstk) -> lpstk | (Zshift n,(l,pstk)) -> (el_shft n l, pstk) | (Zapp a, (l,pstk)) -> (l,zlapp (Array.map (fun t -> (l,t)) a) pstk) | (Zfix(fx,a),(l,pstk)) -> let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) | (Zcase(ci,p,br),(l,pstk)) -> (l,Zlcase(ci,l,p,br)::pstk)) in snd (pure_rec lfts stk) (****************************************************************************) (* Reduction Functions *) (****************************************************************************) let whd_betaiotazeta x = match x with | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> x | _ -> whd_val (create_clos_infos betaiotazeta empty_env) (inject x) let whd_betadeltaiota env t = match t with | (Sort _|Meta _|Evar _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> t | _ -> whd_val (create_clos_infos betadeltaiota env) (inject t) let whd_betadeltaiota_nolet env t = match t with | (Sort _|Meta _|Evar _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t | _ -> whd_val (create_clos_infos betadeltaiotanolet env) (inject t) (* Beta *) let beta_appvect c v = let rec stacklam env t stack = match t, stack with Lambda(_,_,c), arg::stacktl -> stacklam (arg::env) c stacktl | _ -> applist (substl env t, stack) in stacklam [] c (Array.to_list v) (********************************************************************) (* Conversion *) (********************************************************************) (* Conversion utility functions *) type 'a conversion_function = env -> 'a -> 'a -> unit exception NotConvertible exception NotConvertibleVect of int let compare_stacks f fmind lft1 stk1 lft2 stk2 = let rec cmp_rec pstk1 pstk2 = match (pstk1,pstk2) with | (z1::s1, z2::s2) -> cmp_rec s1 s2; (match (z1,z2) with | (Zlapp a1,Zlapp a2) -> array_iter2 f a1 a2 | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> f fx1 fx2; cmp_rec a1 a2 | (Zlcase(ci1,l1,p1,br1),Zlcase(ci2,l2,p2,br2)) -> if not (fmind ci1.ci_ind ci2.ci_ind) then raise NotConvertible; f (l1,p1) (l2,p2); array_iter2 (fun c1 c2 -> f (l1,c1) (l2,c2)) br1 br2 | _ -> assert false) | _ -> () in if compare_stack_shape stk1 stk2 then cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2) else raise NotConvertible (* Convertibility of sorts *) type conv_pb = | CONV | CUMUL let sort_cmp univ pb s0 s1 = match (s0,s1) with | (Prop c1, Prop c2) when pb = CUMUL -> if c1 = Pos & c2 = Null then raise NotConvertible | (Prop c1, Prop c2) -> if c1 <> c2 then raise NotConvertible | (Prop c1, Type u) -> (match pb with CUMUL -> () | _ -> raise NotConvertible) | (Type u1, Type u2) -> if not (match pb with | CONV -> check_eq univ u1 u2 | CUMUL -> check_geq univ u2 u1) then raise NotConvertible | (_, _) -> raise NotConvertible let rec no_arg_available = function | [] -> true | Zupdate _ :: stk -> no_arg_available stk | Zshift _ :: stk -> no_arg_available stk | Zapp v :: stk -> Array.length v = 0 && no_arg_available stk | Zcase _ :: _ -> true | Zfix _ :: _ -> true let rec no_nth_arg_available n = function | [] -> true | Zupdate _ :: stk -> no_nth_arg_available n stk | Zshift _ :: stk -> no_nth_arg_available n stk | Zapp v :: stk -> let k = Array.length v in if n >= k then no_nth_arg_available (n-k) stk else false | Zcase _ :: _ -> true | Zfix _ :: _ -> true let rec no_case_available = function | [] -> true | Zupdate _ :: stk -> no_case_available stk | Zshift _ :: stk -> no_case_available stk | Zapp _ :: stk -> no_case_available stk | Zcase _ :: _ -> false | Zfix _ :: _ -> true let in_whnf (t,stk) = match fterm_of t with | (FLetIn _ | FCases _ | FApp _ | FCLOS _ | FLIFT _ | FCast _) -> false | FLambda _ -> no_arg_available stk | FConstruct _ -> no_case_available stk | FCoFix _ -> no_case_available stk | FFix(((ri,n),(_,_,_)),_) -> no_nth_arg_available ri.(n) stk | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _) -> true | FLOCKED -> assert false let oracle_order fl1 fl2 = match fl1,fl2 with ConstKey c1, ConstKey c2 -> (*height c1 > height c2*)false | _, ConstKey _ -> true | _ -> false (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv univ cv_pb infos lft1 lft2 term1 term2 = eqappr univ cv_pb infos (lft1, (term1,[])) (lft2, (term2,[])) (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *) and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = Util.check_for_interrupt (); (* First head reduce both terms *) let rec whd_both (t1,stk1) (t2,stk2) = let st1' = whd_stack infos t1 stk1 in let st2' = whd_stack infos t2 stk2 in (* Now, whd_stack on term2 might have modified st1 (due to sharing), and st1 might not be in whnf anymore. If so, we iterate ccnv. *) if in_whnf st1' then (st1',st2') else whd_both st1' st2' in let ((hd1,v1),(hd2,v2)) = whd_both st1 st2 in let appr1 = (lft1,(hd1,v1)) and appr2 = (lft2,(hd2,v2)) in (* compute the lifts that apply to the head of the term (hd1 and hd2) *) let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in match (fterm_of hd1, fterm_of hd2) with (* case of leaves *) | (FAtom a1, FAtom a2) -> (match a1, a2 with | (Sort s1, Sort s2) -> assert (is_empty_stack v1 && is_empty_stack v2); sort_cmp univ cv_pb s1 s2 | (Meta n, Meta m) -> if n=m then convert_stacks univ infos lft1 lft2 v1 v2 else raise NotConvertible | _ -> raise NotConvertible) | (FEvar (ev1,args1), FEvar (ev2,args2)) -> if ev1=ev2 then (convert_stacks univ infos lft1 lft2 v1 v2; convert_vect univ infos el1 el2 args1 args2) else raise NotConvertible (* 2 index known to be bound to no constant *) | (FRel n, FRel m) -> if reloc_rel n el1 = reloc_rel m el2 then convert_stacks univ infos lft1 lft2 v1 v2 else raise NotConvertible (* 2 constants, 2 local defined vars or 2 defined rels *) | (FFlex fl1, FFlex fl2) -> (try (* try first intensional equality *) if eq_table_key fl1 fl2 then convert_stacks univ infos lft1 lft2 v1 v2 else raise NotConvertible with NotConvertible -> (* else the oracle tells which constant is to be expanded *) let (app1,app2) = if oracle_order fl1 fl2 then match unfold_reference infos fl1 with | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2) | None -> (match unfold_reference infos fl2 with | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2)) | None -> raise NotConvertible) else match unfold_reference infos fl2 with | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2)) | None -> (match unfold_reference infos fl1 with | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2) | None -> raise NotConvertible) in eqappr univ cv_pb infos app1 app2) (* other constructors *) | (FLambda _, FLambda _) -> (* Inconsistency: we tolerate that v1, v2 contain shift and update but we throw them away *) assert (is_empty_stack v1 && is_empty_stack v2); let (_,ty1,bd1) = destFLambda mk_clos hd1 in let (_,ty2,bd2) = destFLambda mk_clos hd2 in ccnv univ CONV infos el1 el2 ty1 ty2; ccnv univ CONV infos (el_lift el1) (el_lift el2) bd1 bd2 | (FProd (_,c1,c2), FProd (_,c'1,c'2)) -> assert (is_empty_stack v1 && is_empty_stack v2); (* Luo's system *) ccnv univ CONV infos el1 el2 c1 c'1; ccnv univ cv_pb infos (el_lift el1) (el_lift el2) c2 c'2 (* Eta-expansion on the fly *) | (FLambda _, _) -> if v1 <> [] then anomaly "conversion was given unreduced term (FLambda)"; let (_,_ty1,bd1) = destFLambda mk_clos hd1 in eqappr univ CONV infos (el_lift lft1,(bd1,[])) (el_lift lft2,(hd2,eta_expand_stack v2)) | (_, FLambda _) -> if v2 <> [] then anomaly "conversion was given unreduced term (FLambda)"; let (_,_ty2,bd2) = destFLambda mk_clos hd2 in eqappr univ CONV infos (el_lift lft1,(hd1,eta_expand_stack v1)) (el_lift lft2,(bd2,[])) (* only one constant, defined var or defined rel *) | (FFlex fl1, _) -> (match unfold_reference infos fl1 with | Some def1 -> eqappr univ cv_pb infos (lft1, whd_stack infos def1 v1) appr2 | None -> raise NotConvertible) | (_, FFlex fl2) -> (match unfold_reference infos fl2 with | Some def2 -> eqappr univ cv_pb infos appr1 (lft2, whd_stack infos def2 v2) | None -> raise NotConvertible) (* Inductive types: MutInd MutConstruct Fix Cofix *) | (FInd ind1, FInd ind2) -> if mind_equiv_infos infos ind1 ind2 then convert_stacks univ infos lft1 lft2 v1 v2 else raise NotConvertible | (FConstruct (ind1,j1), FConstruct (ind2,j2)) -> if j1 = j2 && mind_equiv_infos infos ind1 ind2 then convert_stacks univ infos lft1 lft2 v1 v2 else raise NotConvertible | (FFix ((op1,(_,tys1,cl1)),e1), FFix((op2,(_,tys2,cl2)),e2)) -> if op1 = op2 then let n = Array.length cl1 in let fty1 = Array.map (mk_clos e1) tys1 in let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in convert_vect univ infos el1 el2 fty1 fty2; convert_vect univ infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2; convert_stacks univ infos lft1 lft2 v1 v2 else raise NotConvertible | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> if op1 = op2 then let n = Array.length cl1 in let fty1 = Array.map (mk_clos e1) tys1 in let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in convert_vect univ infos el1 el2 fty1 fty2; convert_vect univ infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2; convert_stacks univ infos lft1 lft2 v1 v2 else raise NotConvertible (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) | ( (FLetIn _, _) | (FCases _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) | (_, FLetIn _) | (_,FCases _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) | (FLOCKED,_) | (_,FLOCKED) ) -> assert false (* In all other cases, terms are not convertible *) | _ -> raise NotConvertible and convert_stacks univ infos lft1 lft2 stk1 stk2 = compare_stacks (fun (l1,t1) (l2,t2) -> ccnv univ CONV infos l1 l2 t1 t2) (mind_equiv_infos infos) lft1 stk1 lft2 stk2 and convert_vect univ infos lft1 lft2 v1 v2 = array_iter2 (fun t1 t2 -> ccnv univ CONV infos lft1 lft2 t1 t2) v1 v2 let clos_fconv cv_pb env t1 t2 = let infos = create_clos_infos betaiotazeta env in let univ = universes env in ccnv univ cv_pb infos el_id el_id (inject t1) (inject t2) let fconv cv_pb env t1 t2 = if eq_constr t1 t2 then () else clos_fconv cv_pb env t1 t2 let conv = fconv CONV let conv_leq = fconv CUMUL (* option for conversion : no compilation for the checker *) let vm_conv = fconv (********************************************************************) (* Special-Purpose Reduction *) (********************************************************************) (* pseudo-reduction rule: * [hnf_prod_app env s (Prod(_,B)) N --> B[N] * with an HNF on the first argument to produce a product. * if this does not work, then we use the string S as part of our * error message. *) let hnf_prod_app env t n = match whd_betadeltaiota env t with | Prod (_,_,b) -> subst1 n b | _ -> anomaly "hnf_prod_app: Need a product" let hnf_prod_applist env t nl = List.fold_left (hnf_prod_app env) t nl (* Dealing with arities *) let dest_prod env = let rec decrec env m c = let t = whd_betadeltaiota env c in match t with | Prod (n,a,c0) -> let d = (n,None,a) in decrec (push_rel d env) (d::m) c0 | _ -> m,t in decrec env empty_rel_context (* The same but preserving lets *) let dest_prod_assum env = let rec prodec_rec env l ty = let rty = whd_betadeltaiota_nolet env ty in match rty with | Prod (x,t,c) -> let d = (x,None,t) in prodec_rec (push_rel d env) (d::l) c | LetIn (x,b,t,c) -> let d = (x,Some b,t) in prodec_rec (push_rel d env) (d::l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> l,rty in prodec_rec env empty_rel_context let dest_arity env c = let l, c = dest_prod_assum env c in match c with | Sort s -> l,s | _ -> error "not an arity" coq-8.4pl4/checker/closure.ml0000644000175000017500000006643712326224777015265 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* red_kind val fVAR : identifier -> red_kind val no_red : reds val red_add : reds -> red_kind -> reds val mkflags : red_kind list -> reds val red_set : reds -> red_kind -> bool end module RedFlags = (struct (* [r_const=(true,cl)] means all constants but those in [cl] *) (* [r_const=(false,cl)] means only those in [cl] *) (* [r_delta=true] just mean [r_const=(true,[])] *) type reds = { r_beta : bool; r_delta : bool; r_const : transparent_state; r_zeta : bool; r_evar : bool; r_iota : bool } type red_kind = BETA | DELTA | IOTA | ZETA | CONST of constant | VAR of identifier let fBETA = BETA let fDELTA = DELTA let fIOTA = IOTA let fZETA = ZETA let fCONST kn = CONST kn let fVAR id = VAR id let no_red = { r_beta = false; r_delta = false; r_const = all_opaque; r_zeta = false; r_evar = false; r_iota = false } let red_add red = function | BETA -> { red with r_beta = true } | DELTA -> { red with r_delta = true; r_const = all_transparent } | CONST kn -> let (l1,l2) = red.r_const in { red with r_const = l1, Cpred.add kn l2 } | IOTA -> { red with r_iota = true } | ZETA -> { red with r_zeta = true } | VAR id -> let (l1,l2) = red.r_const in { red with r_const = Idpred.add id l1, l2 } let mkflags = List.fold_left red_add no_red let red_set red = function | BETA -> incr_cnt red.r_beta beta | CONST kn -> let (_,l) = red.r_const in let c = Cpred.mem kn l in incr_cnt c delta | VAR id -> (* En attendant d'avoir des kn pour les Var *) let (l,_) = red.r_const in let c = Idpred.mem id l in incr_cnt c delta | ZETA -> incr_cnt red.r_zeta zeta | IOTA -> incr_cnt red.r_iota iota | DELTA -> (* Used for Rel/Var defined in context *) incr_cnt red.r_delta delta end : RedFlagsSig) open RedFlags let betadeltaiota = mkflags [fBETA;fDELTA;fZETA;fIOTA] let betadeltaiotanolet = mkflags [fBETA;fDELTA;fIOTA] let betaiotazeta = mkflags [fBETA;fIOTA;fZETA] (* specification of the reduction function *) (* Flags of reduction and cache of constants: 'a is a type that may be * mapped to constr. 'a infos implements a cache for constants and * abstractions, storing a representation (of type 'a) of the body of * this constant or abstraction. * * i_tab is the cache table of the results * * i_repr is the function to get the representation from the current * state of the cache and the body of the constant. The result * is stored in the table. * * i_rels = (4,[(1,c);(3,d)]) means there are 4 free rel variables * and only those with index 1 and 3 have bodies which are c and d resp. * * i_vars is the list of _defined_ named variables. * * ref_value_cache searchs in the tab, otherwise uses i_repr to * compute the result and store it in the table. If the constant can't * be unfolded, returns None, but does not store this failure. * This * doesn't take the RESET into account. You mustn't keep such a table * after a Reset. * This type is not exported. Only its two * instantiations (cbv or lazy) are. *) type table_key = | ConstKey of constant | VarKey of identifier | RelKey of int type 'a infos = { i_flags : reds; i_repr : 'a infos -> constr -> 'a; i_env : env; i_rels : int * (int * constr) list; i_vars : (identifier * constr) list; i_tab : (table_key, 'a) Hashtbl.t } let ref_value_cache info ref = try Some (Hashtbl.find info.i_tab ref) with Not_found -> try let body = match ref with | RelKey n -> let (s,l) = info.i_rels in lift n (List.assoc (s-n) l) | VarKey id -> List.assoc id info.i_vars | ConstKey cst -> constant_value info.i_env cst in let v = info.i_repr info body in Hashtbl.add info.i_tab ref v; Some v with | Not_found (* List.assoc *) | NotEvaluableConst _ (* Const *) -> None let defined_vars flags env = (* if red_local_const (snd flags) then*) fold_named_context (fun (id,b,_) e -> match b with | None -> e | Some body -> (id, body)::e) (named_context env) ~init:[] (* else []*) let defined_rels flags env = (* if red_local_const (snd flags) then*) fold_rel_context (fun (id,b,t) (i,subs) -> match b with | None -> (i+1, subs) | Some body -> (i+1, (i,body) :: subs)) (rel_context env) ~init:(0,[]) (* else (0,[])*) let mind_equiv_infos info = mind_equiv info.i_env let eq_table_key k1 k2 = match k1,k2 with | ConstKey con1 ,ConstKey con2 -> eq_con_chk con1 con2 | _,_ -> k1=k2 let create mk_cl flgs env = { i_flags = flgs; i_repr = mk_cl; i_env = env; i_rels = defined_rels flgs env; i_vars = defined_vars flgs env; i_tab = Hashtbl.create 17 } (**********************************************************************) (* Lazy reduction: the one used in kernel operations *) (* type of shared terms. fconstr and frterm are mutually recursive. * Clone of the constr structure, but completely mutable, and * annotated with reduction state (reducible or not). * - FLIFT is a delayed shift; allows sharing between 2 lifted copies * of a given term. * - FCLOS is a delayed substitution applied to a constr * - FLOCKED is used to erase the content of a reference that must * be updated. This is to allow the garbage collector to work * before the term is computed. *) (* Norm means the term is fully normalized and cannot create a redex when substituted Cstr means the term is in head normal form and that it can create a redex when substituted (i.e. constructor, fix, lambda) Whnf means we reached the head normal form and that it cannot create a redex when substituted Red is used for terms that might be reduced *) type red_state = Norm | Cstr | Whnf | Red let neutr = function | (Whnf|Norm) -> Whnf | (Red|Cstr) -> Red type fconstr = { mutable norm: red_state; mutable term: fterm } and fterm = | FRel of int | FAtom of constr (* Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key | FInd of inductive | FConstruct of constructor | FApp of fconstr * fconstr array | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCases of case_info * fconstr * fconstr * fconstr array | FLambda of int * (name * constr) list * constr * fconstr subs | FProd of name * fconstr * fconstr | FLetIn of name * fconstr * fconstr * constr * fconstr subs | FEvar of existential_key * fconstr array | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED let fterm_of v = v.term let set_norm v = v.norm <- Norm (* Could issue a warning if no is still Red, pointing out that we loose sharing. *) let update v1 (no,t) = if !share then (v1.norm <- no; v1.term <- t; v1) else {norm=no;term=t} (**********************************************************************) (* The type of (machine) stacks (= lambda-bar-calculus' contexts) *) type stack_member = | Zapp of fconstr array | Zcase of case_info * fconstr * fconstr array | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr and stack = stack_member list let append_stack v s = if Array.length v = 0 then s else match s with | Zapp l :: s -> Zapp (Array.append v l) :: s | _ -> Zapp v :: s (* Collapse the shifts in the stack *) let zshift n s = match (n,s) with (0,_) -> s | (_,Zshift(k)::s) -> Zshift(n+k)::s | _ -> Zshift(n)::s (* Lifting. Preserves sharing (useful only for cell with norm=Red). lft_fconstr always create a new cell, while lift_fconstr avoids it when the lift is 0. *) let rec lft_fconstr n ft = match ft.term with | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)) -> ft | FRel i -> {norm=Norm;term=FRel(i+n)} | FLambda(k,tys,f,e) -> {norm=Cstr; term=FLambda(k,tys,f,subs_shft(n,e))} | FFix(fx,e) -> {norm=Cstr; term=FFix(fx,subs_shft(n,e))} | FCoFix(cfx,e) -> {norm=Cstr; term=FCoFix(cfx,subs_shft(n,e))} | FLIFT(k,m) -> lft_fconstr (n+k) m | FLOCKED -> assert false | _ -> {norm=ft.norm; term=FLIFT(n,ft)} let lift_fconstr k f = if k=0 then f else lft_fconstr k f let lift_fconstr_vect k v = if k=0 then v else Array.map (fun f -> lft_fconstr k f) v let clos_rel e i = match expand_rel i e with | Inl(n,mt) -> lift_fconstr n mt | Inr(k,None) -> {norm=Norm; term= FRel k} | Inr(k,Some p) -> lift_fconstr (k-p) {norm=Red;term=FFlex(RelKey p)} (* since the head may be reducible, we might introduce lifts of 0 *) let compact_stack head stk = let rec strip_rec depth = function | Zshift(k)::s -> strip_rec (depth+k) s | Zupdate(m)::s -> (* Be sure to create a new cell otherwise sharing would be lost by the update operation *) let h' = lft_fconstr depth head in let _ = update m (h'.norm,h'.term) in strip_rec depth s | stk -> zshift depth stk in strip_rec 0 stk (* Put an update mark in the stack, only if needed *) let zupdate m s = if !share & m.norm = Red then let s' = compact_stack m s in let _ = m.term <- FLOCKED in Zupdate(m)::s' else s (* Closure optimization: *) let rec compact_constr (lg, subs as s) c k = match c with Rel i -> if i < k then c,s else (try Rel (k + lg - list_index (i-k+1) subs), (lg,subs) with Not_found -> Rel (k+lg), (lg+1, (i-k+1)::subs)) | (Sort _|Var _|Meta _|Ind _|Const _|Construct _) -> c,s | Evar(ev,v) -> let (v',s) = compact_vect s v k in if v==v' then c,s else Evar(ev,v'),s | Cast(a,ck,b) -> let (a',s) = compact_constr s a k in let (b',s) = compact_constr s b k in if a==a' && b==b' then c,s else Cast(a', ck, b'), s | App(f,v) -> let (f',s) = compact_constr s f k in let (v',s) = compact_vect s v k in if f==f' && v==v' then c,s else App(f',v'), s | Lambda(n,a,b) -> let (a',s) = compact_constr s a k in let (b',s) = compact_constr s b (k+1) in if a==a' && b==b' then c,s else Lambda(n,a',b'), s | Prod(n,a,b) -> let (a',s) = compact_constr s a k in let (b',s) = compact_constr s b (k+1) in if a==a' && b==b' then c,s else Prod(n,a',b'), s | LetIn(n,a,ty,b) -> let (a',s) = compact_constr s a k in let (ty',s) = compact_constr s ty k in let (b',s) = compact_constr s b (k+1) in if a==a' && ty==ty' && b==b' then c,s else LetIn(n,a',ty',b'), s | Fix(fi,(na,ty,bd)) -> let (ty',s) = compact_vect s ty k in let (bd',s) = compact_vect s bd (k+Array.length ty) in if ty==ty' && bd==bd' then c,s else Fix(fi,(na,ty',bd')), s | CoFix(i,(na,ty,bd)) -> let (ty',s) = compact_vect s ty k in let (bd',s) = compact_vect s bd (k+Array.length ty) in if ty==ty' && bd==bd' then c,s else CoFix(i,(na,ty',bd')), s | Case(ci,p,a,br) -> let (p',s) = compact_constr s p k in let (a',s) = compact_constr s a k in let (br',s) = compact_vect s br k in if p==p' && a==a' && br==br' then c,s else Case(ci,p',a',br'),s and compact_vect s v k = compact_v [] s v k (Array.length v - 1) and compact_v acc s v k i = if i < 0 then let v' = Array.of_list acc in if array_for_all2 (==) v v' then v,s else v',s else let (a',s') = compact_constr s v.(i) k in compact_v (a'::acc) s' v k (i-1) (* Computes the minimal environment of a closure. Idea: if the subs is not identity, the term will have to be reallocated entirely (to propagate the substitution). So, computing the set of free variables does not change the complexity. *) let optimise_closure env c = if is_subs_id env then (env,c) else let (c',(_,s)) = compact_constr (0,[]) c 1 in let env' = Array.map (fun i -> clos_rel env i) (Array.of_list s) in (subs_cons (env', subs_id 0),c') let mk_lambda env t = let (env,t) = optimise_closure env t in let (rvars,t') = decompose_lam t in FLambda(List.length rvars, List.rev rvars, t', env) let destFLambda clos_fun t = match t.term with FLambda(_,[(na,ty)],b,e) -> (na,clos_fun e ty,clos_fun (subs_lift e) b) | FLambda(n,(na,ty)::tys,b,e) -> (na,clos_fun e ty,{norm=Cstr;term=FLambda(n-1,tys,b,subs_lift e)}) | _ -> assert false (* Optimization: do not enclose variables in a closure. Makes variable access much faster *) let mk_clos e t = match t with | Rel i -> clos_rel e i | Var x -> { norm = Red; term = FFlex (VarKey x) } | Const c -> { norm = Red; term = FFlex (ConstKey c) } | Meta _ | Sort _ -> { norm = Norm; term = FAtom t } | Ind kn -> { norm = Norm; term = FInd kn } | Construct kn -> { norm = Cstr; term = FConstruct kn } | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _) -> {norm = Red; term = FCLOS(t,e)} let mk_clos_vect env v = Array.map (mk_clos env) v (* Translate the head constructor of t from constr to fconstr. This function is parameterized by the function to apply on the direct subterms. Could be used insted of mk_clos. *) let mk_clos_deep clos_fun env t = match t with | (Rel _|Ind _|Const _|Construct _|Var _|Meta _ | Sort _) -> mk_clos env t | Cast (a,k,b) -> { norm = Red; term = FCast (clos_fun env a, k, clos_fun env b)} | App (f,v) -> { norm = Red; term = FApp (clos_fun env f, Array.map (clos_fun env) v) } | Case (ci,p,c,v) -> { norm = Red; term = FCases (ci, clos_fun env p, clos_fun env c, Array.map (clos_fun env) v) } | Fix fx -> { norm = Cstr; term = FFix (fx, env) } | CoFix cfx -> { norm = Cstr; term = FCoFix(cfx,env) } | Lambda _ -> { norm = Cstr; term = mk_lambda env t } | Prod (n,t,c) -> { norm = Whnf; term = FProd (n, clos_fun env t, clos_fun (subs_lift env) c) } | LetIn (n,b,t,c) -> { norm = Red; term = FLetIn (n, clos_fun env b, clos_fun env t, c, env) } | Evar(ev,args) -> { norm = Whnf; term = FEvar(ev,Array.map (clos_fun env) args) } (* A better mk_clos? *) let mk_clos2 = mk_clos_deep mk_clos (* The inverse of mk_clos_deep: move back to constr *) let rec to_constr constr_fun lfts v = match v.term with | FRel i -> Rel (reloc_rel i lfts) | FFlex (RelKey p) -> Rel (reloc_rel p lfts) | FFlex (VarKey x) -> Var x | FAtom c -> exliftn lfts c | FCast (a,k,b) -> Cast (constr_fun lfts a, k, constr_fun lfts b) | FFlex (ConstKey op) -> Const op | FInd op -> Ind op | FConstruct op -> Construct op | FCases (ci,p,c,ve) -> Case (ci, constr_fun lfts p, constr_fun lfts c, Array.map (constr_fun lfts) ve) | FFix ((op,(lna,tys,bds)),e) -> let n = Array.length bds in let ftys = Array.map (mk_clos e) tys in let fbds = Array.map (mk_clos (subs_liftn n e)) bds in let lfts' = el_liftn n lfts in Fix (op, (lna, Array.map (constr_fun lfts) ftys, Array.map (constr_fun lfts') fbds)) | FCoFix ((op,(lna,tys,bds)),e) -> let n = Array.length bds in let ftys = Array.map (mk_clos e) tys in let fbds = Array.map (mk_clos (subs_liftn n e)) bds in let lfts' = el_liftn (Array.length bds) lfts in CoFix (op, (lna, Array.map (constr_fun lfts) ftys, Array.map (constr_fun lfts') fbds)) | FApp (f,ve) -> App (constr_fun lfts f, Array.map (constr_fun lfts) ve) | FLambda _ -> let (na,ty,bd) = destFLambda mk_clos2 v in Lambda (na, constr_fun lfts ty, constr_fun (el_lift lfts) bd) | FProd (n,t,c) -> Prod (n, constr_fun lfts t, constr_fun (el_lift lfts) c) | FLetIn (n,b,t,f,e) -> let fc = mk_clos2 (subs_lift e) f in LetIn (n, constr_fun lfts b, constr_fun lfts t, constr_fun (el_lift lfts) fc) | FEvar (ev,args) -> Evar(ev,Array.map (constr_fun lfts) args) | FLIFT (k,a) -> to_constr constr_fun (el_shft k lfts) a | FCLOS (t,env) -> let fr = mk_clos2 env t in let unfv = update v (fr.norm,fr.term) in to_constr constr_fun lfts unfv | FLOCKED -> assert false (*mkVar(id_of_string"_LOCK_")*) (* This function defines the correspondance between constr and fconstr. When we find a closure whose substitution is the identity, then we directly return the constr to avoid possibly huge reallocation. *) let term_of_fconstr = let rec term_of_fconstr_lift lfts v = match v.term with | FCLOS(t,env) when is_subs_id env & is_lift_id lfts -> t | FLambda(_,tys,f,e) when is_subs_id e & is_lift_id lfts -> compose_lam (List.rev tys) f | FFix(fx,e) when is_subs_id e & is_lift_id lfts -> Fix fx | FCoFix(cfx,e) when is_subs_id e & is_lift_id lfts -> CoFix cfx | _ -> to_constr term_of_fconstr_lift lfts v in term_of_fconstr_lift el_id (* fstrong applies unfreeze_fun recursively on the (freeze) term and * yields a term. Assumes that the unfreeze_fun never returns a * FCLOS term. let rec fstrong unfreeze_fun lfts v = to_constr (fstrong unfreeze_fun) lfts (unfreeze_fun v) *) let rec zip m stk = match stk with | [] -> m | Zapp args :: s -> zip {norm=neutr m.norm; term=FApp(m, args)} s | Zcase(ci,p,br)::s -> let t = FCases(ci, p, m, br) in zip {norm=neutr m.norm; term=t} s | Zfix(fx,par)::s -> zip fx (par @ append_stack [|m|] s) | Zshift(n)::s -> zip (lift_fconstr n m) s | Zupdate(rf)::s -> zip (update rf (m.norm,m.term)) s let fapp_stack (m,stk) = zip m stk (*********************************************************************) (* The assertions in the functions below are granted because they are called only when m is a constructor, a cofix (strip_update_shift_app), a fix (get_nth_arg) or an abstraction (strip_update_shift, through get_arg). *) (* optimised for the case where there are no shifts... *) let strip_update_shift_app head stk = assert (head.norm <> Red); let rec strip_rec rstk h depth = function | Zshift(k) as e :: s -> strip_rec (e::rstk) (lift_fconstr k h) (depth+k) s | (Zapp args :: s) -> strip_rec (Zapp args :: rstk) {norm=h.norm;term=FApp(h,args)} depth s | Zupdate(m)::s -> strip_rec rstk (update m (h.norm,h.term)) depth s | stk -> (depth,List.rev rstk, stk) in strip_rec [] head 0 stk let get_nth_arg head n stk = assert (head.norm <> Red); let rec strip_rec rstk h n = function | Zshift(k) as e :: s -> strip_rec (e::rstk) (lift_fconstr k h) n s | Zapp args::s' -> let q = Array.length args in if n >= q then strip_rec (Zapp args::rstk) {norm=h.norm;term=FApp(h,args)} (n-q) s' else let bef = Array.sub args 0 n in let aft = Array.sub args (n+1) (q-n-1) in let stk' = List.rev (if n = 0 then rstk else (Zapp bef :: rstk)) in (Some (stk', args.(n)), append_stack aft s') | Zupdate(m)::s -> strip_rec rstk (update m (h.norm,h.term)) n s | s -> (None, List.rev rstk @ s) in strip_rec [] head n stk (* Beta reduction: look for an applied argument in the stack. Since the encountered update marks are removed, h must be a whnf *) let rec get_args n tys f e stk = match stk with Zupdate r :: s -> let _hd = update r (Cstr,FLambda(n,tys,f,e)) in get_args n tys f e s | Zshift k :: s -> get_args n tys f (subs_shft (k,e)) s | Zapp l :: s -> let na = Array.length l in if n == na then (Inl (subs_cons(l,e)),s) else if n < na then (* more arguments *) let args = Array.sub l 0 n in let eargs = Array.sub l n (na-n) in (Inl (subs_cons(args,e)), Zapp eargs :: s) else (* more lambdas *) let etys = list_skipn na tys in get_args (n-na) etys f (subs_cons(l,e)) s | _ -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk) (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *) let rec eta_expand_stack = function | (Zapp _ | Zfix _ | Zcase _ | Zshift _ | Zupdate _ as e) :: s -> e :: eta_expand_stack s | [] -> [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]] (* Iota reduction: extract the arguments to be passed to the Case branches *) let rec reloc_rargs_rec depth stk = match stk with Zapp args :: s -> Zapp (lift_fconstr_vect depth args) :: reloc_rargs_rec depth s | Zshift(k)::s -> if k=depth then s else reloc_rargs_rec (depth-k) s | _ -> stk let reloc_rargs depth stk = if depth = 0 then stk else reloc_rargs_rec depth stk let rec drop_parameters depth n stk = match stk with Zapp args::s -> let q = Array.length args in if n > q then drop_parameters depth (n-q) s else if n = q then reloc_rargs depth s else let aft = Array.sub args n (q-n) in reloc_rargs depth (append_stack aft s) | Zshift(k)::s -> drop_parameters (depth-k) n s | [] -> assert (n=0); [] | _ -> assert false (* we know that n < stack_args_size(stk) *) (* Iota reduction: expansion of a fixpoint. * Given a fixpoint and a substitution, returns the corresponding * fixpoint body, and the substitution in which it should be * evaluated: its first variables are the fixpoint bodies * * FCLOS(fix Fi {F0 := T0 .. Fn-1 := Tn-1}, S) * -> (S. FCLOS(F0,S) . ... . FCLOS(Fn-1,S), Ti) *) (* does not deal with FLIFT *) let contract_fix_vect fix = let (thisbody, make_body, env, nfix) = match fix with | FFix (((reci,i),(_,_,bds as rdcl)),env) -> (bds.(i), (fun j -> { norm = Cstr; term = FFix (((reci,j),rdcl),env) }), env, Array.length bds) | FCoFix ((i,(_,_,bds as rdcl)),env) -> (bds.(i), (fun j -> { norm = Cstr; term = FCoFix ((j,rdcl),env) }), env, Array.length bds) | _ -> assert false in (subs_cons(Array.init nfix make_body, env), thisbody) (*********************************************************************) (* A machine that inspects the head of a term until it finds an atom or a subterm that may produce a redex (abstraction, constructor, cofix, letin, constant), or a neutral term (product, inductive) *) let rec knh m stk = match m.term with | FLIFT(k,a) -> knh a (zshift k stk) | FCLOS(t,e) -> knht e t (zupdate m stk) | FLOCKED -> assert false | FApp(a,b) -> knh a (append_stack b (zupdate m stk)) | FCases(ci,p,t,br) -> knh t (Zcase(ci,p,br)::zupdate m stk) | FFix(((ri,n),(_,_,_)),_) -> (match get_nth_arg m ri.(n) stk with (Some(pars,arg),stk') -> knh arg (Zfix(m,pars)::stk') | (None, stk') -> (m,stk')) | FCast(t,_,_) -> knh t stk (* cases where knh stops *) | (FFlex _|FLetIn _|FConstruct _|FEvar _| FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) -> (m, stk) (* The same for pure terms *) and knht e t stk = match t with | App(a,b) -> knht e a (append_stack (mk_clos_vect e b) stk) | Case(ci,p,t,br) -> knht e t (Zcase(ci, mk_clos e p, mk_clos_vect e br)::stk) | Fix _ -> knh (mk_clos2 e t) stk | Cast(a,_,_) -> knht e a stk | Rel n -> knh (clos_rel e n) stk | (Lambda _|Prod _|Construct _|CoFix _|Ind _| LetIn _|Const _|Var _|Evar _|Meta _|Sort _) -> (mk_clos2 e t, stk) (************************************************************************) (* Computes a weak head normal form from the result of knh. *) let rec knr info m stk = match m.term with | FLambda(n,tys,f,e) when red_set info.i_flags fBETA -> (match get_args n tys f e stk with Inl e', s -> knit info e' f s | Inr lam, s -> (lam,s)) | FFlex(ConstKey kn) when red_set info.i_flags (fCONST kn) -> (match ref_value_cache info (ConstKey kn) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FFlex(VarKey id) when red_set info.i_flags (fVAR id) -> (match ref_value_cache info (VarKey id) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FFlex(RelKey k) when red_set info.i_flags fDELTA -> (match ref_value_cache info (RelKey k) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FConstruct(ind,c) when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with (depth, args, Zcase(ci,_,br)::s) -> assert (ci.ci_npar>=0); let rargs = drop_parameters depth ci.ci_npar args in kni info br.(c-1) (rargs@s) | (_, cargs, Zfix(fx,par)::s) -> let rarg = fapp_stack(m,cargs) in let stk' = par @ append_stack [|rarg|] s in let (fxe,fxbd) = contract_fix_vect fx.term in knit info fxe fxbd stk' | (_,args,s) -> (m,args@s)) | FCoFix _ when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with (_, args, ((Zcase _::_) as stk')) -> let (fxe,fxbd) = contract_fix_vect m.term in knit info fxe fxbd (args@stk') | (_,args,s) -> (m,args@s)) | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA -> knit info (subs_cons([|v|],e)) bd stk | _ -> (m,stk) (* Computes the weak head normal form of a term *) and kni info m stk = let (hm,s) = knh m stk in knr info hm s and knit info e t stk = let (ht,s) = knht e t stk in knr info ht s let kh info v stk = fapp_stack(kni info v stk) (************************************************************************) (* Initialization and then normalization *) (* weak reduction *) let whd_val info v = with_stats (lazy (term_of_fconstr (kh info v []))) let inject = mk_clos (subs_id 0) let whd_stack infos m stk = let k = kni infos m stk in let _ = fapp_stack k in (* to unlock Zupdates! *) k (* cache of constants: the body is computed only when needed. *) type clos_infos = fconstr infos let create_clos_infos flgs env = create (fun _ -> inject) flgs env let unfold_reference = ref_value_cache coq-8.4pl4/checker/typeops.mli0000644000175000017500000000170712326224777015452 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> constr val infer_type : env -> constr -> sorts val check_ctxt : env -> rel_context -> env val check_named_ctxt : env -> named_context -> env val check_polymorphic_arity : env -> rel_context -> polymorphic_arity -> unit val type_of_constant_type : env -> constant_type -> constr coq-8.4pl4/README.doc0000755000175000017500000000120512326224777013260 0ustar stephsteph The Coq documentation ===================== The Coq documentation includes: - a reference manual; - a generic tutorial on Coq; - a tutorial on recursive types; - a document presenting the Coq standard library; - a list of questions/answers in the FAQ style All these documents are available online from the Coq official site (http://coq.inria.fr), either as PS/PDF files or as HTML documents. The sources of the documentation are available along with the sources of the Coq proof assistant. It is released under the Open Publication License (see file doc/LICENSE in the sources of Coq) coq-8.4pl4/README0000644000175000017500000000344212326224777012516 0ustar stephsteph THE COQ V8 SYSTEM ================= INSTALLATION. ============= See the file INSTALL for installation procedure. DOCUMENTATION. ============== The documentation is part of the archive in directory doc. The documentation of the last released version is available on the Coq web site at http://coq.inria.fr/doc. CHANGES. ======== There is a file named CHANGES that explains the differences and the incompatibilities since last versions. If you upgrade Coq, please read it carefully. AVAILABILITY. ============= Coq is available at http://coq.inria.fr, or, for older versions at ftp://ftp.inria.fr/INRIA/Projects/LogiCal/coq. THE COQ CLUB. ============= The Coq Club moderated mailing list is meant to be a standard way to discuss questions about the Coq system and related topics. The submission address is: coq-club@inria.fr The topics to be discussed in the club should include: * technical problems; * questions about proof developments; * suggestions and questions about the implementation; * announcements of proofs; * theoretical questions about typed lambda-calculi which are closely related to Coq. To be added to, or removed from, the mailing list, please write to: coq-club-request@inria.fr Please use also this address for any questions/suggestions about the Coq Club. It might sometimes take a few days before your messages get forwarded. BUGS REPORT. ============ Send your bug reports by filling a form at http://coq.inria.fr/bugs To be effective, bug reports should mention the Caml version used to compile and run Coq, the Coq version (coqtop -v), the configuration used, and include a complete source example leading to the bug. coq-8.4pl4/parsing/0000755000175000017500000000000012365131026013261 5ustar stephstephcoq-8.4pl4/parsing/g_xml.ml40000644000175000017500000002371312326224777015030 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ctag then user_err_loc (loc,"",str "closing xml tag " ++ str ctag ++ str "does not match open xml tag " ++ str otag ++ str ".") let xml_eoi = (Gram.entry_create "xml_eoi" : xml Gram.entry) GEXTEND Gram GLOBAL: xml_eoi; xml_eoi: [ [ x = xml; EOI -> x ] ] ; xml: [ [ "<"; otag = IDENT; attrs = LIST0 attr; ">"; l = LIST1 xml; "<"; "/"; ctag = IDENT; ">" -> check_tags loc otag ctag; XmlTag (loc,ctag,attrs,l) | "<"; tag = IDENT; attrs = LIST0 attr; "/"; ">" -> XmlTag (loc,tag,attrs,[]) ] ] ; attr: [ [ name = IDENT; "="; data = STRING -> (name, (loc, data)) ] ] ; END (* Errors *) let error_expect_two_arguments loc = user_err_loc (loc,"",str "wrong number of arguments (expect two).") let error_expect_one_argument loc = user_err_loc (loc,"",str "wrong number of arguments (expect one).") let error_expect_no_argument loc = user_err_loc (loc,"",str "wrong number of arguments (expect none).") (* Interpreting attributes *) let nmtoken (loc,a) = try int_of_string a with Failure _ -> user_err_loc (loc,"",str "nmtoken expected.") let get_xml_attr s al = try List.assoc s al with Not_found -> error ("No attribute "^s) (* Interpreting specific attributes *) let ident_of_cdata (loc,a) = id_of_string a let uri_of_data s = let n = String.index s ':' in let p = String.index s '.' in let s = String.sub s (n+2) (p-n-2) in for i=0 to String.length s - 1 do if s.[i]='/' then s.[i]<-'.' done; qualid_of_string s let constant_of_cdata (loc,a) = Nametab.locate_constant (uri_of_data a) let global_of_cdata (loc,a) = Nametab.locate (uri_of_data a) let inductive_of_cdata a = match global_of_cdata a with | IndRef (kn,_) -> kn | _ -> anomaly "XML parser: not an inductive" let ltacref_of_cdata (loc,a) = (loc,locate_tactic (uri_of_data a)) let sort_of_cdata (loc,a) = match a with | "Prop" -> GProp Null | "Set" -> GProp Pos | "Type" -> GType None | _ -> user_err_loc (loc,"",str "sort expected.") let get_xml_sort al = sort_of_cdata (get_xml_attr "value" al) let get_xml_inductive_kn al = inductive_of_cdata (* uriType apparent synonym of uri *) (try get_xml_attr "uri" al with e when Errors.noncritical e -> get_xml_attr "uriType" al) let get_xml_constant al = constant_of_cdata (get_xml_attr "uri" al) let get_xml_inductive al = (get_xml_inductive_kn al, nmtoken (get_xml_attr "noType" al)) let get_xml_constructor al = (get_xml_inductive al, nmtoken (get_xml_attr "noConstr" al)) let get_xml_binder al = try Name (ident_of_cdata (List.assoc "binder" al)) with Not_found -> Anonymous let get_xml_ident al = ident_of_cdata (get_xml_attr "binder" al) let get_xml_name al = ident_of_cdata (get_xml_attr "name" al) let get_xml_noFun al = nmtoken (get_xml_attr "noFun" al) let get_xml_no al = nmtoken (get_xml_attr "no" al) (* A leak in the xml dtd: arities of constructor need to know global env *) let compute_branches_lengths ind = let (_,mip) = Inductive.lookup_mind_specif (Global.env()) ind in mip.Declarations.mind_consnrealdecls let compute_inductive_nargs ind = Inductiveops.inductive_nargs (Global.env()) ind (* Interpreting constr as a glob_constr *) let rec interp_xml_constr = function | XmlTag (loc,"REL",al,[]) -> GVar (loc, get_xml_ident al) | XmlTag (loc,"VAR",al,[]) -> error "XML parser: unable to interp free variables" | XmlTag (loc,"LAMBDA",al,(_::_ as xl)) -> let body,decls = list_sep_last xl in let ctx = List.map interp_xml_decl decls in List.fold_right (fun (na,t) b -> GLambda (loc, na, Explicit, t, b)) ctx (interp_xml_target body) | XmlTag (loc,"PROD",al,(_::_ as xl)) -> let body,decls = list_sep_last xl in let ctx = List.map interp_xml_decl decls in List.fold_right (fun (na,t) b -> GProd (loc, na, Explicit, t, b)) ctx (interp_xml_target body) | XmlTag (loc,"LETIN",al,(_::_ as xl)) -> let body,defs = list_sep_last xl in let ctx = List.map interp_xml_def defs in List.fold_right (fun (na,t) b -> GLetIn (loc, na, t, b)) ctx (interp_xml_target body) | XmlTag (loc,"APPLY",_,x::xl) -> GApp (loc, interp_xml_constr x, List.map interp_xml_constr xl) | XmlTag (loc,"instantiate",_, (XmlTag (_,("CONST"|"MUTIND"|"MUTCONSTRUCT"),_,_) as x)::xl) -> GApp (loc, interp_xml_constr x, List.map interp_xml_arg xl) | XmlTag (loc,"META",al,xl) -> GEvar (loc, get_xml_no al, Some (List.map interp_xml_substitution xl)) | XmlTag (loc,"CONST",al,[]) -> GRef (loc, ConstRef (get_xml_constant al)) | XmlTag (loc,"MUTCASE",al,x::y::yl) -> let ind = get_xml_inductive al in let p = interp_xml_patternsType x in let tm = interp_xml_inductiveTerm y in let vars = compute_branches_lengths ind in let brs = list_map_i (fun i c -> (i,vars.(i),interp_xml_pattern c)) 0 yl in let mat = simple_cases_matrix_of_branches ind brs in let nparams,n = compute_inductive_nargs ind in let nal,rtn = return_type_of_predicate ind nparams n p in GCases (loc,RegularStyle,rtn,[tm,nal],mat) | XmlTag (loc,"MUTIND",al,[]) -> GRef (loc, IndRef (get_xml_inductive al)) | XmlTag (loc,"MUTCONSTRUCT",al,[]) -> GRef (loc, ConstructRef (get_xml_constructor al)) | XmlTag (loc,"FIX",al,xl) -> let li,lnct = List.split (List.map interp_xml_FixFunction xl) in let ln,lc,lt = list_split3 lnct in let lctx = List.map (fun _ -> []) ln in GRec (loc, GFix (Array.of_list li, get_xml_noFun al), Array.of_list ln, Array.of_list lctx, Array.of_list lc, Array.of_list lt) | XmlTag (loc,"COFIX",al,xl) -> let ln,lc,lt = list_split3 (List.map interp_xml_CoFixFunction xl) in GRec (loc, GCoFix (get_xml_noFun al), Array.of_list ln, [||], Array.of_list lc, Array.of_list lt) | XmlTag (loc,"CAST",al,[x1;x2]) -> GCast (loc, interp_xml_term x1, CastConv (DEFAULTcast, interp_xml_type x2)) | XmlTag (loc,"SORT",al,[]) -> GSort (loc, get_xml_sort al) | XmlTag (loc,s,_,_) -> user_err_loc (loc,"", str "Unexpected tag " ++ str s ++ str ".") and interp_xml_tag s = function | XmlTag (loc,tag,al,xl) when tag=s -> (loc,al,xl) | XmlTag (loc,tag,_,_) -> user_err_loc (loc, "", str "Expect tag " ++ str s ++ str " but find " ++ str s ++ str ".") and interp_xml_constr_alias s x = match interp_xml_tag s x with | (_,_,[x]) -> interp_xml_constr x | (loc,_,_) -> error_expect_one_argument loc and interp_xml_term x = interp_xml_constr_alias "term" x and interp_xml_type x = interp_xml_constr_alias "type" x and interp_xml_target x = interp_xml_constr_alias "target" x and interp_xml_body x = interp_xml_constr_alias "body" x and interp_xml_pattern x = interp_xml_constr_alias "pattern" x and interp_xml_patternsType x = interp_xml_constr_alias "patternsType" x and interp_xml_inductiveTerm x = interp_xml_constr_alias "inductiveTerm" x and interp_xml_arg x = interp_xml_constr_alias "arg" x and interp_xml_substitution x = interp_xml_constr_alias "substitution" x (* no support for empty substitution from official dtd *) and interp_xml_decl_alias s x = match interp_xml_tag s x with | (_,al,[x]) -> (get_xml_binder al, interp_xml_constr x) | (loc,_,_) -> error_expect_one_argument loc and interp_xml_def x = interp_xml_decl_alias "def" x and interp_xml_decl x = interp_xml_decl_alias "decl" x and interp_xml_recursionOrder x = let (loc, al, l) = interp_xml_tag "RecursionOrder" x in let (locs, s) = get_xml_attr "type" al in match s with "Structural" -> (match l with [] -> GStructRec | _ -> error_expect_no_argument loc) | "WellFounded" -> (match l with [c] -> GWfRec (interp_xml_type c) | _ -> error_expect_one_argument loc) | "Measure" -> (match l with [m;r] -> GMeasureRec (interp_xml_type m, Some (interp_xml_type r)) | _ -> error_expect_two_arguments loc) | _ -> user_err_loc (locs,"",str "Invalid recursion order.") and interp_xml_FixFunction x = match interp_xml_tag "FixFunction" x with | (loc,al,[x1;x2;x3]) -> (* Not in official cic.dtd, not in constr *) ((Some (nmtoken (get_xml_attr "recIndex" al)), interp_xml_recursionOrder x1), (get_xml_name al, interp_xml_type x2, interp_xml_body x3)) | (loc,al,[x1;x2]) -> ((Some (nmtoken (get_xml_attr "recIndex" al)), GStructRec), (get_xml_name al, interp_xml_type x1, interp_xml_body x2)) | (loc,_,_) -> error_expect_one_argument loc and interp_xml_CoFixFunction x = match interp_xml_tag "CoFixFunction" x with | (loc,al,[x1;x2]) -> (get_xml_name al, interp_xml_type x1, interp_xml_body x2) | (loc,_,_) -> error_expect_one_argument loc (* Interpreting tactic argument *) let rec interp_xml_tactic_arg = function | XmlTag (loc,"TERM",[],[x]) -> ConstrMayEval (ConstrTerm (interp_xml_constr x,None)) | XmlTag (loc,"CALL",al,xl) -> let ltacref = ltacref_of_cdata (get_xml_attr "uri" al) in TacCall(loc,ArgArg ltacref,List.map interp_xml_tactic_arg xl) | XmlTag (loc,s,_,_) -> user_err_loc (loc,"", str "Unexpected tag " ++ str s ++ str ".") let parse_tactic_arg ch = interp_xml_tactic_arg (Pcoq.Gram.entry_parse xml_eoi (Pcoq.Gram.parsable (Stream.of_channel ch))) coq-8.4pl4/parsing/ppconstr.mli0000644000175000017500000000722212326224777015654 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* local_binder list * constr_expr val extract_prod_binders : constr_expr -> local_binder list * constr_expr val split_fix : int -> constr_expr -> constr_expr -> local_binder list * constr_expr * constr_expr val prec_less : int -> int * Ppextend.parenRelation -> bool val pr_tight_coma : unit -> std_ppcmds val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds val pr_metaid : identifier -> std_ppcmds val pr_lident : identifier located -> std_ppcmds val pr_lname : name located -> std_ppcmds val pr_with_comments : loc -> std_ppcmds -> std_ppcmds val pr_com_at : int -> std_ppcmds val pr_sep_com : (unit -> std_ppcmds) -> (constr_expr -> std_ppcmds) -> constr_expr -> std_ppcmds val pr_id : identifier -> std_ppcmds val pr_name : name -> std_ppcmds val pr_qualid : qualid -> std_ppcmds val pr_patvar : patvar -> std_ppcmds val pr_with_occurrences : ('a -> std_ppcmds) -> 'a with_occurrences -> std_ppcmds val pr_red_expr : ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> ('a,'b,'c) red_expr_gen -> std_ppcmds val pr_may_eval : ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> ('c -> std_ppcmds) -> ('a,'b,'c) may_eval -> std_ppcmds val pr_glob_sort : glob_sort -> std_ppcmds val pr_guard_annot : (constr_expr -> std_ppcmds) -> local_binder list -> ('a * Names.identifier) option * recursion_order_expr -> std_ppcmds val pr_binders : local_binder list -> std_ppcmds val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds val pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds val pr_constr_expr : constr_expr -> std_ppcmds val pr_lconstr_expr : constr_expr -> std_ppcmds val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds type term_pr = { pr_constr_expr : constr_expr -> std_ppcmds; pr_lconstr_expr : constr_expr -> std_ppcmds; pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds; pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds } val set_term_pr : term_pr -> unit val default_term_pr : term_pr (** The modular constr printer. [modular_constr_pr pr s p t] prints the head of the term [t] and calls [pr] on its subterms. [s] is typically {!Pp.mt} and [p] is [lsimpleconstr] for "constr" printers and [ltop] for "lconstr" printers (spiwack: we might need more specification here). We can make a new modular constr printer by overriding certain branches, for instance if we want to build a printer which prints "Prop" as "Omega" instead we can proceed as follows: let my_modular_constr_pr pr s p = function | CSort (_,GProp Null) -> str "Omega" | t -> modular_constr_pr pr s p t Which has the same type. We can turn a modular printer into a printer by taking its fixpoint. *) type precedence val lsimpleconstr : precedence val ltop : precedence val modular_constr_pr : ((unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds) -> (unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds coq-8.4pl4/parsing/q_coqast.ml40000644000175000017500000006034412326224777015535 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 && s.[0] == '$' let purge_str s = if String.length s == 0 || s.[0] <> '$' then s else String.sub s 1 (String.length s - 1) let anti loc x = expl_anti loc <:expr< $lid:purge_str x$ >> (* We don't give location for tactic quotation! *) let loc = dummy_loc let dloc = <:expr< Util.dummy_loc >> let mlexpr_of_ident id = <:expr< Names.id_of_string $str:Names.string_of_id id$ >> let mlexpr_of_name = function | Names.Anonymous -> <:expr< Names.Anonymous >> | Names.Name id -> <:expr< Names.Name (Names.id_of_string $str:Names.string_of_id id$) >> let mlexpr_of_dirpath dir = let l = Names.repr_dirpath dir in <:expr< Names.make_dirpath $mlexpr_of_list mlexpr_of_ident l$ >> let mlexpr_of_qualid qid = let (dir, id) = repr_qualid qid in <:expr< make_qualid $mlexpr_of_dirpath dir$ $mlexpr_of_ident id$ >> let mlexpr_of_reference = function | Libnames.Qualid (loc,qid) -> <:expr< Libnames.Qualid $dloc$ $mlexpr_of_qualid qid$ >> | Libnames.Ident (loc,id) -> <:expr< Libnames.Ident $dloc$ $mlexpr_of_ident id$ >> let mlexpr_of_located f (loc,x) = <:expr< ($dloc$, $f x$) >> let mlexpr_of_loc loc = <:expr< $dloc$ >> let mlexpr_of_by_notation f = function | Genarg.AN x -> <:expr< Genarg.AN $f x$ >> | Genarg.ByNotation (loc,s,sco) -> <:expr< Genarg.ByNotation $dloc$ $str:s$ $mlexpr_of_option mlexpr_of_string sco$ >> let mlexpr_of_intro_pattern = function | Genarg.IntroWildcard -> <:expr< Genarg.IntroWildcard >> | Genarg.IntroAnonymous -> <:expr< Genarg.IntroAnonymous >> | Genarg.IntroFresh id -> <:expr< Genarg.IntroFresh (mlexpr_of_ident $dloc$ id) >> | Genarg.IntroForthcoming b -> <:expr< Genarg.IntroForthcoming (mlexpr_of_bool $dloc$ b) >> | Genarg.IntroIdentifier id -> <:expr< Genarg.IntroIdentifier (mlexpr_of_ident $dloc$ id) >> | Genarg.IntroOrAndPattern _ | Genarg.IntroRewrite _ -> failwith "mlexpr_of_intro_pattern: TODO" let mlexpr_of_ident_option = mlexpr_of_option (mlexpr_of_ident) let mlexpr_of_or_metaid f = function | Tacexpr.AI a -> <:expr< Tacexpr.AI $f a$ >> | Tacexpr.MetaId (_,id) -> <:expr< Tacexpr.AI $anti loc id$ >> let mlexpr_of_quantified_hypothesis = function | Glob_term.AnonHyp n -> <:expr< Glob_term.AnonHyp $mlexpr_of_int n$ >> | Glob_term.NamedHyp id -> <:expr< Glob_term.NamedHyp $mlexpr_of_ident id$ >> let mlexpr_of_or_var f = function | Glob_term.ArgArg x -> <:expr< Glob_term.ArgArg $f x$ >> | Glob_term.ArgVar id -> <:expr< Glob_term.ArgVar $mlexpr_of_located mlexpr_of_ident id$ >> let mlexpr_of_hyp = mlexpr_of_or_metaid (mlexpr_of_located mlexpr_of_ident) let mlexpr_of_occs = mlexpr_of_pair mlexpr_of_bool (mlexpr_of_list (mlexpr_of_or_var mlexpr_of_int)) let mlexpr_of_occurrences f = mlexpr_of_pair mlexpr_of_occs f let mlexpr_of_hyp_location = function | occs, Termops.InHyp -> <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Termops.InHyp) >> | occs, Termops.InHypTypeOnly -> <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Termops.InHypTypeOnly) >> | occs, Termops.InHypValueOnly -> <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Termops.InHypValueOnly) >> let mlexpr_of_clause cl = <:expr< {Tacexpr.onhyps= $mlexpr_of_option (mlexpr_of_list mlexpr_of_hyp_location) cl.Tacexpr.onhyps$; Tacexpr.concl_occs= $mlexpr_of_occs cl.Tacexpr.concl_occs$} >> let mlexpr_of_red_flags { Glob_term.rBeta = bb; Glob_term.rIota = bi; Glob_term.rZeta = bz; Glob_term.rDelta = bd; Glob_term.rConst = l } = <:expr< { Glob_term.rBeta = $mlexpr_of_bool bb$; Glob_term.rIota = $mlexpr_of_bool bi$; Glob_term.rZeta = $mlexpr_of_bool bz$; Glob_term.rDelta = $mlexpr_of_bool bd$; Glob_term.rConst = $mlexpr_of_list (mlexpr_of_by_notation mlexpr_of_reference) l$ } >> let mlexpr_of_explicitation = function | Topconstr.ExplByName id -> <:expr< Topconstr.ExplByName $mlexpr_of_ident id$ >> | Topconstr.ExplByPos (n,_id) -> <:expr< Topconstr.ExplByPos $mlexpr_of_int n$ >> let mlexpr_of_binding_kind = function | Glob_term.Implicit -> <:expr< Glob_term.Implicit >> | Glob_term.Explicit -> <:expr< Glob_term.Explicit >> let mlexpr_of_binder_kind = function | Topconstr.Default b -> <:expr< Topconstr.Default $mlexpr_of_binding_kind b$ >> | Topconstr.Generalized (b,b',b'') -> <:expr< Topconstr.TypeClass $mlexpr_of_binding_kind b$ $mlexpr_of_binding_kind b'$ $mlexpr_of_bool b''$ >> let rec mlexpr_of_constr = function | Topconstr.CRef (Libnames.Ident (loc,id)) when is_meta (string_of_id id) -> anti loc (string_of_id id) | Topconstr.CRef r -> <:expr< Topconstr.CRef $mlexpr_of_reference r$ >> | Topconstr.CFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO" | Topconstr.CCoFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO" | Topconstr.CArrow (loc,a,b) -> <:expr< Topconstr.CArrow $dloc$ $mlexpr_of_constr a$ $mlexpr_of_constr b$ >> | Topconstr.CProdN (loc,l,a) -> <:expr< Topconstr.CProdN $dloc$ $mlexpr_of_list (mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_binder_kind mlexpr_of_constr) l$ $mlexpr_of_constr a$ >> | Topconstr.CLambdaN (loc,l,a) -> <:expr< Topconstr.CLambdaN $dloc$ $mlexpr_of_list (mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_binder_kind mlexpr_of_constr) l$ $mlexpr_of_constr a$ >> | Topconstr.CLetIn (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO" | Topconstr.CAppExpl (loc,a,l) -> <:expr< Topconstr.CAppExpl $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_reference a$ $mlexpr_of_list mlexpr_of_constr l$ >> | Topconstr.CApp (loc,a,l) -> <:expr< Topconstr.CApp $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_constr a$ $mlexpr_of_list (mlexpr_of_pair mlexpr_of_constr (mlexpr_of_option (mlexpr_of_located mlexpr_of_explicitation))) l$ >> | Topconstr.CCases (loc,_,_,_,_) -> failwith "mlexpr_of_constr: TODO" | Topconstr.CHole (loc, None) -> <:expr< Topconstr.CHole $dloc$ None >> | Topconstr.CHole (loc, Some _) -> failwith "mlexpr_of_constr: TODO CHole (Some _)" | Topconstr.CNotation(_,ntn,(subst,substl,[])) -> <:expr< Topconstr.CNotation $dloc$ $mlexpr_of_string ntn$ ($mlexpr_of_list mlexpr_of_constr subst$, $mlexpr_of_list (mlexpr_of_list mlexpr_of_constr) substl$,[]) >> | Topconstr.CPatVar (loc,n) -> <:expr< Topconstr.CPatVar $dloc$ $mlexpr_of_pair mlexpr_of_bool mlexpr_of_ident n$ >> | _ -> failwith "mlexpr_of_constr: TODO" let mlexpr_of_occ_constr = mlexpr_of_occurrences mlexpr_of_constr let mlexpr_of_red_expr = function | Glob_term.Red b -> <:expr< Glob_term.Red $mlexpr_of_bool b$ >> | Glob_term.Hnf -> <:expr< Glob_term.Hnf >> | Glob_term.Simpl o -> <:expr< Glob_term.Simpl $mlexpr_of_option mlexpr_of_occ_constr o$ >> | Glob_term.Cbv f -> <:expr< Glob_term.Cbv $mlexpr_of_red_flags f$ >> | Glob_term.Lazy f -> <:expr< Glob_term.Lazy $mlexpr_of_red_flags f$ >> | Glob_term.Unfold l -> let f1 = mlexpr_of_by_notation mlexpr_of_reference in let f = mlexpr_of_list (mlexpr_of_occurrences f1) in <:expr< Glob_term.Unfold $f l$ >> | Glob_term.Fold l -> <:expr< Glob_term.Fold $mlexpr_of_list mlexpr_of_constr l$ >> | Glob_term.Pattern l -> let f = mlexpr_of_list mlexpr_of_occ_constr in <:expr< Glob_term.Pattern $f l$ >> | Glob_term.CbvVm -> <:expr< Glob_term.CbvVm >> | Glob_term.ExtraRedExpr s -> <:expr< Glob_term.ExtraRedExpr $mlexpr_of_string s$ >> let rec mlexpr_of_argtype loc = function | Genarg.BoolArgType -> <:expr< Genarg.BoolArgType >> | Genarg.IntArgType -> <:expr< Genarg.IntArgType >> | Genarg.IntOrVarArgType -> <:expr< Genarg.IntOrVarArgType >> | Genarg.RefArgType -> <:expr< Genarg.RefArgType >> | Genarg.PreIdentArgType -> <:expr< Genarg.PreIdentArgType >> | Genarg.IntroPatternArgType -> <:expr< Genarg.IntroPatternArgType >> | Genarg.IdentArgType b -> <:expr< Genarg.IdentArgType $mlexpr_of_bool b$ >> | Genarg.VarArgType -> <:expr< Genarg.VarArgType >> | Genarg.StringArgType -> <:expr< Genarg.StringArgType >> | Genarg.QuantHypArgType -> <:expr< Genarg.QuantHypArgType >> | Genarg.OpenConstrArgType (b1,b2) -> <:expr< Genarg.OpenConstrArgType ($mlexpr_of_bool b1$, $mlexpr_of_bool b2$) >> | Genarg.ConstrWithBindingsArgType -> <:expr< Genarg.ConstrWithBindingsArgType >> | Genarg.BindingsArgType -> <:expr< Genarg.BindingsArgType >> | Genarg.RedExprArgType -> <:expr< Genarg.RedExprArgType >> | Genarg.SortArgType -> <:expr< Genarg.SortArgType >> | Genarg.ConstrArgType -> <:expr< Genarg.ConstrArgType >> | Genarg.ConstrMayEvalArgType -> <:expr< Genarg.ConstrMayEvalArgType >> | Genarg.List0ArgType t -> <:expr< Genarg.List0ArgType $mlexpr_of_argtype loc t$ >> | Genarg.List1ArgType t -> <:expr< Genarg.List1ArgType $mlexpr_of_argtype loc t$ >> | Genarg.OptArgType t -> <:expr< Genarg.OptArgType $mlexpr_of_argtype loc t$ >> | Genarg.PairArgType (t1,t2) -> let t1 = mlexpr_of_argtype loc t1 in let t2 = mlexpr_of_argtype loc t2 in <:expr< Genarg.PairArgType $t1$ $t2$ >> | Genarg.ExtraArgType s -> <:expr< Genarg.ExtraArgType $str:s$ >> let rec mlexpr_of_may_eval f = function | Glob_term.ConstrEval (r,c) -> <:expr< Glob_term.ConstrEval $mlexpr_of_red_expr r$ $f c$ >> | Glob_term.ConstrContext ((loc,id),c) -> let id = mlexpr_of_ident id in <:expr< Glob_term.ConstrContext (loc,$id$) $f c$ >> | Glob_term.ConstrTypeOf c -> <:expr< Glob_term.ConstrTypeOf $mlexpr_of_constr c$ >> | Glob_term.ConstrTerm c -> <:expr< Glob_term.ConstrTerm $mlexpr_of_constr c$ >> let mlexpr_of_binding_kind = function | Glob_term.ExplicitBindings l -> let l = mlexpr_of_list (mlexpr_of_triple mlexpr_of_loc mlexpr_of_quantified_hypothesis mlexpr_of_constr) l in <:expr< Glob_term.ExplicitBindings $l$ >> | Glob_term.ImplicitBindings l -> let l = mlexpr_of_list mlexpr_of_constr l in <:expr< Glob_term.ImplicitBindings $l$ >> | Glob_term.NoBindings -> <:expr< Glob_term.NoBindings >> let mlexpr_of_binding = mlexpr_of_pair mlexpr_of_binding_kind mlexpr_of_constr let mlexpr_of_constr_with_binding = mlexpr_of_pair mlexpr_of_constr mlexpr_of_binding_kind let mlexpr_of_move_location f = function | Tacexpr.MoveAfter id -> <:expr< Tacexpr.MoveAfter $f id$ >> | Tacexpr.MoveBefore id -> <:expr< Tacexpr.MoveBefore $f id$ >> | Tacexpr.MoveToEnd b -> <:expr< Tacexpr.MoveToEnd $mlexpr_of_bool b$ >> let mlexpr_of_induction_arg = function | Tacexpr.ElimOnConstr c -> <:expr< Tacexpr.ElimOnConstr $mlexpr_of_constr_with_binding c$ >> | Tacexpr.ElimOnIdent (_,id) -> <:expr< Tacexpr.ElimOnIdent $dloc$ $mlexpr_of_ident id$ >> | Tacexpr.ElimOnAnonHyp n -> <:expr< Tacexpr.ElimOnAnonHyp $mlexpr_of_int n$ >> let mlexpr_of_clause_pattern _ = failwith "mlexpr_of_clause_pattern: TODO" let mlexpr_of_pattern_ast = mlexpr_of_constr let mlexpr_of_entry_type = function _ -> failwith "mlexpr_of_entry_type: TODO" let mlexpr_of_match_pattern = function | Tacexpr.Term t -> <:expr< Tacexpr.Term $mlexpr_of_pattern_ast t$ >> | Tacexpr.Subterm (b,ido,t) -> <:expr< Tacexpr.Subterm $mlexpr_of_bool b$ $mlexpr_of_option mlexpr_of_ident ido$ $mlexpr_of_pattern_ast t$ >> let mlexpr_of_match_context_hyps = function | Tacexpr.Hyp (id,l) -> let f = mlexpr_of_located mlexpr_of_name in <:expr< Tacexpr.Hyp $f id$ $mlexpr_of_match_pattern l$ >> | Tacexpr.Def (id,v,l) -> let f = mlexpr_of_located mlexpr_of_name in <:expr< Tacexpr.Def $f id$ $mlexpr_of_match_pattern v$ $mlexpr_of_match_pattern l$ >> let mlexpr_of_match_rule f = function | Tacexpr.Pat (l,mp,t) -> <:expr< Tacexpr.Pat $mlexpr_of_list mlexpr_of_match_context_hyps l$ $mlexpr_of_match_pattern mp$ $f t$ >> | Tacexpr.All t -> <:expr< Tacexpr.All $f t$ >> let mlexpr_of_message_token = function | Tacexpr.MsgString s -> <:expr< Tacexpr.MsgString $str:s$ >> | Tacexpr.MsgInt n -> <:expr< Tacexpr.MsgInt $mlexpr_of_int n$ >> | Tacexpr.MsgIdent id -> <:expr< Tacexpr.MsgIdent $mlexpr_of_hyp id$ >> let mlexpr_of_debug = function | Tacexpr.Off -> <:expr< Tacexpr.Off >> | Tacexpr.Debug -> <:expr< Tacexpr.Debug >> | Tacexpr.Info -> <:expr< Tacexpr.Info >> let rec mlexpr_of_atomic_tactic = function (* Basic tactics *) | Tacexpr.TacIntroPattern pl -> let pl = mlexpr_of_list (mlexpr_of_located mlexpr_of_intro_pattern) pl in <:expr< Tacexpr.TacIntroPattern $pl$ >> | Tacexpr.TacIntrosUntil h -> <:expr< Tacexpr.TacIntrosUntil $mlexpr_of_quantified_hypothesis h$ >> | Tacexpr.TacIntroMove (idopt,idopt') -> let idopt = mlexpr_of_ident_option idopt in let idopt'= mlexpr_of_move_location mlexpr_of_hyp idopt' in <:expr< Tacexpr.TacIntroMove $idopt$ $idopt'$ >> | Tacexpr.TacAssumption -> <:expr< Tacexpr.TacAssumption >> | Tacexpr.TacExact c -> <:expr< Tacexpr.TacExact $mlexpr_of_constr c$ >> | Tacexpr.TacExactNoCheck c -> <:expr< Tacexpr.TacExactNoCheck $mlexpr_of_constr c$ >> | Tacexpr.TacVmCastNoCheck c -> <:expr< Tacexpr.TacVmCastNoCheck $mlexpr_of_constr c$ >> | Tacexpr.TacApply (b,false,cb,None) -> <:expr< Tacexpr.TacApply $mlexpr_of_bool b$ False $mlexpr_of_list mlexpr_of_constr_with_binding cb$ None >> | Tacexpr.TacElim (false,cb,cbo) -> let cb = mlexpr_of_constr_with_binding cb in let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in <:expr< Tacexpr.TacElim False $cb$ $cbo$ >> | Tacexpr.TacElimType c -> <:expr< Tacexpr.TacElimType $mlexpr_of_constr c$ >> | Tacexpr.TacCase (false,cb) -> let cb = mlexpr_of_constr_with_binding cb in <:expr< Tacexpr.TacCase False $cb$ >> | Tacexpr.TacCaseType c -> <:expr< Tacexpr.TacCaseType $mlexpr_of_constr c$ >> | Tacexpr.TacFix (ido,n) -> let ido = mlexpr_of_ident_option ido in let n = mlexpr_of_int n in <:expr< Tacexpr.TacFix $ido$ $n$ >> | Tacexpr.TacMutualFix (b,id,n,l) -> let b = mlexpr_of_bool b in let id = mlexpr_of_ident id in let n = mlexpr_of_int n in let f =mlexpr_of_triple mlexpr_of_ident mlexpr_of_int mlexpr_of_constr in let l = mlexpr_of_list f l in <:expr< Tacexpr.TacMutualFix $b$ $id$ $n$ $l$ >> | Tacexpr.TacCofix ido -> let ido = mlexpr_of_ident_option ido in <:expr< Tacexpr.TacCofix $ido$ >> | Tacexpr.TacMutualCofix (b,id,l) -> let b = mlexpr_of_bool b in let id = mlexpr_of_ident id in let f = mlexpr_of_pair mlexpr_of_ident mlexpr_of_constr in let l = mlexpr_of_list f l in <:expr< Tacexpr.TacMutualCofix $b$ $id$ $l$ >> | Tacexpr.TacCut c -> <:expr< Tacexpr.TacCut $mlexpr_of_constr c$ >> | Tacexpr.TacAssert (t,ipat,c) -> let ipat = mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern) ipat in <:expr< Tacexpr.TacAssert $mlexpr_of_option mlexpr_of_tactic t$ $ipat$ $mlexpr_of_constr c$ >> | Tacexpr.TacGeneralize cl -> <:expr< Tacexpr.TacGeneralize $mlexpr_of_list (mlexpr_of_pair mlexpr_of_occ_constr mlexpr_of_name) cl$ >> | Tacexpr.TacGeneralizeDep c -> <:expr< Tacexpr.TacGeneralizeDep $mlexpr_of_constr c$ >> | Tacexpr.TacLetTac (na,c,cl,b,e) -> let na = mlexpr_of_name na in let cl = mlexpr_of_clause_pattern cl in <:expr< Tacexpr.TacLetTac $na$ $mlexpr_of_constr c$ $cl$ $mlexpr_of_bool b$ (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern) e) >> (* Derived basic tactics *) | Tacexpr.TacSimpleInductionDestruct (isrec,h) -> <:expr< Tacexpr.TacSimpleInductionDestruct $mlexpr_of_bool isrec$ $mlexpr_of_quantified_hypothesis h$ >> | Tacexpr.TacInductionDestruct (isrec,ev,l) -> <:expr< Tacexpr.TacInductionDestruct $mlexpr_of_bool isrec$ $mlexpr_of_bool ev$ $mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair mlexpr_of_induction_arg (mlexpr_of_pair (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern)) (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern))))) (mlexpr_of_option mlexpr_of_constr_with_binding) (mlexpr_of_option mlexpr_of_clause) l$ >> (* Context management *) | Tacexpr.TacClear (b,l) -> let l = mlexpr_of_list (mlexpr_of_hyp) l in <:expr< Tacexpr.TacClear $mlexpr_of_bool b$ $l$ >> | Tacexpr.TacClearBody l -> let l = mlexpr_of_list (mlexpr_of_hyp) l in <:expr< Tacexpr.TacClearBody $l$ >> | Tacexpr.TacMove (dep,id1,id2) -> <:expr< Tacexpr.TacMove $mlexpr_of_bool dep$ $mlexpr_of_hyp id1$ $mlexpr_of_move_location mlexpr_of_hyp id2$ >> (* Constructors *) | Tacexpr.TacLeft (ev,l) -> <:expr< Tacexpr.TacLeft $mlexpr_of_bool ev$ $mlexpr_of_binding_kind l$>> | Tacexpr.TacRight (ev,l) -> <:expr< Tacexpr.TacRight $mlexpr_of_bool ev$ $mlexpr_of_binding_kind l$>> | Tacexpr.TacSplit (ev,b,l) -> <:expr< Tacexpr.TacSplit ($mlexpr_of_bool ev$,$mlexpr_of_bool b$,$mlexpr_of_list mlexpr_of_binding_kind l$)>> | Tacexpr.TacAnyConstructor (ev,t) -> <:expr< Tacexpr.TacAnyConstructor $mlexpr_of_bool ev$ $mlexpr_of_option mlexpr_of_tactic t$>> | Tacexpr.TacConstructor (ev,n,l) -> let n = mlexpr_of_or_var mlexpr_of_int n in <:expr< Tacexpr.TacConstructor $mlexpr_of_bool ev$ $n$ $mlexpr_of_binding_kind l$>> (* Conversion *) | Tacexpr.TacReduce (r,cl) -> let l = mlexpr_of_clause cl in <:expr< Tacexpr.TacReduce $mlexpr_of_red_expr r$ $l$ >> | Tacexpr.TacChange (p,c,cl) -> let l = mlexpr_of_clause cl in let g = mlexpr_of_option mlexpr_of_constr in <:expr< Tacexpr.TacChange $g p$ $mlexpr_of_constr c$ $l$ >> (* Equivalence relations *) | Tacexpr.TacReflexivity -> <:expr< Tacexpr.TacReflexivity >> | Tacexpr.TacSymmetry ido -> <:expr< Tacexpr.TacSymmetry $mlexpr_of_clause ido$ >> | Tacexpr.TacTransitivity c -> <:expr< Tacexpr.TacTransitivity $mlexpr_of_option mlexpr_of_constr c$ >> (* Automation tactics *) | Tacexpr.TacAuto (debug,n,lems,l) -> let d = mlexpr_of_debug debug in let n = mlexpr_of_option (mlexpr_of_or_var mlexpr_of_int) n in let lems = mlexpr_of_list mlexpr_of_constr lems in let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in <:expr< Tacexpr.TacAuto $d$ $n$ $lems$ $l$ >> | Tacexpr.TacTrivial (debug,lems,l) -> let d = mlexpr_of_debug debug in let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in let lems = mlexpr_of_list mlexpr_of_constr lems in <:expr< Tacexpr.TacTrivial $d$ $lems$ $l$ >> | _ -> failwith "Quotation of atomic tactic expressions: TODO" and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function | Tacexpr.TacAtom (loc,t) -> <:expr< Tacexpr.TacAtom $dloc$ $mlexpr_of_atomic_tactic t$ >> | Tacexpr.TacThen (t1,[||],t2,[||]) -> <:expr< Tacexpr.TacThen $mlexpr_of_tactic t1$ [||] $mlexpr_of_tactic t2$ [||]>> | Tacexpr.TacThens (t,tl) -> <:expr< Tacexpr.TacThens $mlexpr_of_tactic t$ $mlexpr_of_list mlexpr_of_tactic tl$>> | Tacexpr.TacFirst tl -> <:expr< Tacexpr.TacFirst $mlexpr_of_list mlexpr_of_tactic tl$ >> | Tacexpr.TacSolve tl -> <:expr< Tacexpr.TacSolve $mlexpr_of_list mlexpr_of_tactic tl$ >> | Tacexpr.TacTry t -> <:expr< Tacexpr.TacTry $mlexpr_of_tactic t$ >> | Tacexpr.TacOrelse (t1,t2) -> <:expr< Tacexpr.TacOrelse $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$ >> | Tacexpr.TacDo (n,t) -> <:expr< Tacexpr.TacDo $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_tactic t$ >> | Tacexpr.TacTimeout (n,t) -> <:expr< Tacexpr.TacTimeout $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_tactic t$ >> | Tacexpr.TacRepeat t -> <:expr< Tacexpr.TacRepeat $mlexpr_of_tactic t$ >> | Tacexpr.TacProgress t -> <:expr< Tacexpr.TacProgress $mlexpr_of_tactic t$ >> | Tacexpr.TacId l -> <:expr< Tacexpr.TacId $mlexpr_of_list mlexpr_of_message_token l$ >> | Tacexpr.TacFail (n,l) -> <:expr< Tacexpr.TacFail $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_list mlexpr_of_message_token l$ >> (* | Tacexpr.TacInfo t -> TacInfo (loc,f t) | Tacexpr.TacRec (id,(idl,t)) -> TacRec (loc,(id,(idl,f t))) | Tacexpr.TacRecIn (l,t) -> TacRecIn(loc,List.map (fun (id,t) -> (id,f t)) l,f t) *) | Tacexpr.TacLetIn (isrec,l,t) -> let f = mlexpr_of_pair (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_ident) mlexpr_of_tactic_arg in <:expr< Tacexpr.TacLetIn $mlexpr_of_bool isrec$ $mlexpr_of_list f l$ $mlexpr_of_tactic t$ >> | Tacexpr.TacMatch (lz,t,l) -> <:expr< Tacexpr.TacMatch $mlexpr_of_bool lz$ $mlexpr_of_tactic t$ $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>> | Tacexpr.TacMatchGoal (lz,lr,l) -> <:expr< Tacexpr.TacMatchGoal $mlexpr_of_bool lz$ $mlexpr_of_bool lr$ $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>> | Tacexpr.TacFun (idol,body) -> <:expr< Tacexpr.TacFun ($mlexpr_of_list mlexpr_of_ident_option idol$, $mlexpr_of_tactic body$) >> | Tacexpr.TacArg (_,Tacexpr.MetaIdArg (_,true,id)) -> anti loc id | Tacexpr.TacArg (_,t) -> <:expr< Tacexpr.TacArg $dloc$ $mlexpr_of_tactic_arg t$ >> | Tacexpr.TacComplete t -> <:expr< Tacexpr.TacComplete $mlexpr_of_tactic t$ >> | _ -> failwith "Quotation of tactic expressions: TODO" and mlexpr_of_tactic_arg = function | Tacexpr.MetaIdArg (loc,true,id) -> anti loc id | Tacexpr.MetaIdArg (loc,false,id) -> <:expr< Tacexpr.ConstrMayEval (Glob_term.ConstrTerm $anti loc id$) >> | Tacexpr.TacCall (loc,t,tl) -> <:expr< Tacexpr.TacCall $dloc$ $mlexpr_of_reference t$ $mlexpr_of_list mlexpr_of_tactic_arg tl$>> | Tacexpr.Tacexp t -> <:expr< Tacexpr.Tacexp $mlexpr_of_tactic t$ >> | Tacexpr.ConstrMayEval c -> <:expr< Tacexpr.ConstrMayEval $mlexpr_of_may_eval mlexpr_of_constr c$ >> | Tacexpr.Reference r -> <:expr< Tacexpr.Reference $mlexpr_of_reference r$ >> | _ -> failwith "mlexpr_of_tactic_arg: TODO" IFDEF CAMLP5 THEN let not_impl x = let desc = if Obj.is_block (Obj.repr x) then "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) else "int_val = " ^ string_of_int (Obj.magic x) in failwith (" PaAcc (loc, patt_of_expr e1, patt_of_expr e2) | ExApp (_, e1, e2) -> PaApp (loc, patt_of_expr e1, patt_of_expr e2) | ExLid (_, x) when x = vala "loc" -> PaAny loc | ExLid (_, s) -> PaLid (loc, s) | ExUid (_, s) -> PaUid (loc, s) | ExStr (_, s) -> PaStr (loc, s) | ExAnt (_, e) -> PaAnt (loc, patt_of_expr e) | _ -> not_impl e let fconstr e = let ee s = mlexpr_of_constr (Pcoq.Gram.entry_parse e (Pcoq.Gram.parsable (Stream.of_string s))) in let ep s = patt_of_expr (ee s) in Quotation.ExAst (ee, ep) let ftac e = let ee s = mlexpr_of_tactic (Pcoq.Gram.entry_parse e (Pcoq.Gram.parsable (Stream.of_string s))) in let ep s = patt_of_expr (ee s) in Quotation.ExAst (ee, ep) let _ = Quotation.add "constr" (fconstr Pcoq.Constr.constr_eoi); Quotation.add "tactic" (ftac Pcoq.Tactic.tactic_eoi); Quotation.default := "constr" ELSE open Pcaml let expand_constr_quot_expr loc _loc_name_opt contents = mlexpr_of_constr (Pcoq.Gram.parse_string Pcoq.Constr.constr_eoi loc contents) let expand_tactic_quot_expr loc _loc_name_opt contents = mlexpr_of_tactic (Pcoq.Gram.parse_string Pcoq.Tactic.tactic_eoi loc contents) let _ = (* FIXME: for the moment, we add quotations in expressions only, not pattern *) Quotation.add "constr" Quotation.DynAst.expr_tag expand_constr_quot_expr; Quotation.add "tactic" Quotation.DynAst.expr_tag expand_tactic_quot_expr; Quotation.default := "constr" END coq-8.4pl4/parsing/pcoq.mli0000644000175000017500000002373612326224777014756 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Gram.symbol val gram_token_of_string : string -> Gram.symbol (** The superclass of all grammar entries *) type grammar_object (** Add one extension at some camlp4 position of some camlp4 entry *) val grammar_extend : grammar_object Gram.entry -> gram_assoc option (** for reinitialization if ever needed *) -> Gram.extend_statment -> unit (** Remove the last n extensions *) val remove_grammars : int -> unit (** The type of typed grammar objects *) type typed_entry (** The possible types for extensible grammars *) type entry_type = argument_type val type_of_typed_entry : typed_entry -> entry_type val object_of_typed_entry : typed_entry -> grammar_object Gram.entry val weaken_entry : 'a Gram.entry -> grammar_object Gram.entry (** Temporary activate camlp4 verbosity *) val camlp4_verbosity : bool -> ('a -> unit) -> 'a -> unit (** Parse a string *) val parse_string : 'a Gram.entry -> string -> 'a val eoi_entry : 'a Gram.entry -> 'a Gram.entry val map_entry : ('a -> 'b) -> 'a Gram.entry -> 'b Gram.entry (** Table of Coq statically defined grammar entries *) type gram_universe (** There are four predefined universes: "prim", "constr", "tactic", "vernac" *) val get_univ : string -> gram_universe val uprim : gram_universe val uconstr : gram_universe val utactic : gram_universe val uvernac : gram_universe val create_entry : gram_universe -> string -> entry_type -> typed_entry val create_generic_entry : string -> ('a, rlevel) abstract_argument_type -> 'a Gram.entry module Prim : sig open Util open Names open Libnames val preident : string Gram.entry val ident : identifier Gram.entry val name : name located Gram.entry val identref : identifier located Gram.entry val pattern_ident : identifier Gram.entry val pattern_identref : identifier located Gram.entry val base_ident : identifier Gram.entry val natural : int Gram.entry val bigint : Bigint.bigint Gram.entry val integer : int Gram.entry val string : string Gram.entry val qualid : qualid located Gram.entry val fullyqualid : identifier list located Gram.entry val reference : reference Gram.entry val by_notation : (loc * string * string option) Gram.entry val smart_global : reference or_by_notation Gram.entry val dirpath : dir_path Gram.entry val ne_string : string Gram.entry val ne_lstring : string located Gram.entry val var : identifier located Gram.entry end module Constr : sig val constr : constr_expr Gram.entry val constr_eoi : constr_expr Gram.entry val lconstr : constr_expr Gram.entry val binder_constr : constr_expr Gram.entry val operconstr : constr_expr Gram.entry val ident : identifier Gram.entry val global : reference Gram.entry val sort : glob_sort Gram.entry val pattern : cases_pattern_expr Gram.entry val constr_pattern : constr_expr Gram.entry val lconstr_pattern : constr_expr Gram.entry val closed_binder : local_binder list Gram.entry val binder : local_binder list Gram.entry (* closed_binder or variable *) val binders : local_binder list Gram.entry (* list of binder *) val open_binders : local_binder list Gram.entry val binders_fixannot : (local_binder list * (identifier located option * recursion_order_expr)) Gram.entry val typeclass_constraint : (name located * bool * constr_expr) Gram.entry val record_declaration : constr_expr Gram.entry val appl_arg : (constr_expr * explicitation located option) Gram.entry end module Module : sig val module_expr : module_ast Gram.entry val module_type : module_ast Gram.entry end module Tactic : sig open Glob_term val open_constr : open_constr_expr Gram.entry val open_constr_wTC : open_constr_expr Gram.entry val casted_open_constr : open_constr_expr Gram.entry val constr_with_bindings : constr_expr with_bindings Gram.entry val bindings : constr_expr bindings Gram.entry val constr_may_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry val quantified_hypothesis : quantified_hypothesis Gram.entry val int_or_var : int or_var Gram.entry val red_expr : raw_red_expr Gram.entry val simple_tactic : raw_atomic_tactic_expr Gram.entry val simple_intropattern : Genarg.intro_pattern_expr located Gram.entry val tactic_arg : raw_tactic_arg Gram.entry val tactic_expr : raw_tactic_expr Gram.entry val binder_tactic : raw_tactic_expr Gram.entry val tactic : raw_tactic_expr Gram.entry val tactic_eoi : raw_tactic_expr Gram.entry end module Vernac_ : sig open Decl_kinds val gallina : vernac_expr Gram.entry val gallina_ext : vernac_expr Gram.entry val command : vernac_expr Gram.entry val syntax : vernac_expr Gram.entry val vernac : vernac_expr Gram.entry val rec_definition : (fixpoint_expr * decl_notation list) Gram.entry val vernac_eoi : vernac_expr Gram.entry end (** The main entry: reads an optional vernac command *) val main_entry : (loc * vernac_expr) option Gram.entry (** Mapping formal entries into concrete ones *) (** Binding constr entry keys to entries and symbols *) val interp_constr_entry_key : bool (** true for cases_pattern *) -> constr_entry_key -> grammar_object Gram.entry * int option val symbol_of_constr_prod_entry_key : gram_assoc option -> constr_entry_key -> bool -> constr_prod_entry_key -> Gram.symbol (** General entry keys *) (** This intermediate abstract representation of entries can both be reified into mlexpr for the ML extensions and dynamically interpreted as entries for the Coq level extensions *) type prod_entry_key = | Alist1 of prod_entry_key | Alist1sep of prod_entry_key * string | Alist0 of prod_entry_key | Alist0sep of prod_entry_key * string | Aopt of prod_entry_key | Amodifiers of prod_entry_key | Aself | Anext | Atactic of int | Agram of Gram.internal_entry | Aentry of string * string (** Binding general entry keys to symbols *) val symbol_of_prod_entry_key : prod_entry_key -> Gram.symbol (** Interpret entry names of the form "ne_constr_list" as entry keys *) val interp_entry_name : bool (** true to fail on unknown entry *) -> int option -> string -> string -> entry_type * prod_entry_key (** Registering/resetting the level of a constr entry *) val find_position : bool (** true if for creation in pattern entry; false if in constr entry *) -> gram_assoc option -> int option -> gram_position option * gram_assoc option * string option * (** for reinitialization: *) gram_assoc option val synchronize_level_positions : unit -> unit val register_empty_levels : bool -> int list -> (gram_position option * gram_assoc option * string option * gram_assoc option) list val remove_levels : int -> unit val level_of_snterml : Gram.symbol -> int coq-8.4pl4/parsing/g_constr.ml40000644000175000017500000003650212326224777015540 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* c | (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, CastConv (DEFAULTcast, ty)) let binders_of_names l = List.map (fun (loc, na) -> LocalRawAssum ([loc, na], Default Explicit, CHole (loc, Some (Evd.BinderType na)))) l let binders_of_lidents l = List.map (fun (loc, id) -> LocalRawAssum ([loc, Name id], Default Glob_term.Explicit, CHole (loc, Some (Evd.BinderType (Name id))))) l let mk_fixb (id,bl,ann,body,(loc,tyc)) = let ty = match tyc with Some ty -> ty | None -> CHole (loc, None) in (id,ann,bl,ty,body) let mk_cofixb (id,bl,ann,body,(loc,tyc)) = let _ = Option.map (fun (aloc,_) -> Util.user_err_loc (aloc,"Constr:mk_cofixb", Pp.str"Annotation forbidden in cofix expression.")) (fst ann) in let ty = match tyc with Some ty -> ty | None -> CHole (loc, None) in (id,bl,ty,body) let mk_fix(loc,kw,id,dcls) = if kw then let fb = List.map mk_fixb dcls in CFix(loc,id,fb) else let fb = List.map mk_cofixb dcls in CCoFix(loc,id,fb) let mk_single_fix (loc,kw,dcl) = let (id,_,_,_,_) = dcl in mk_fix(loc,kw,id,[dcl]) let err () = raise Stream.Failure (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) (* admissible notation "(x t)" *) let lpar_id_coloneq = Gram.Entry.of_parser "test_lpar_id_coloneq" (fun strm -> match get_tok (stream_nth 0 strm) with | KEYWORD "(" -> (match get_tok (stream_nth 1 strm) with | IDENT s -> (match get_tok (stream_nth 2 strm) with | KEYWORD ":=" -> stream_njunk 3 strm; Names.id_of_string s | _ -> err ()) | _ -> err ()) | _ -> err ()) let impl_ident_head = Gram.Entry.of_parser "impl_ident_head" (fun strm -> match get_tok (stream_nth 0 strm) with | KEYWORD "{" -> (match get_tok (stream_nth 1 strm) with | IDENT ("wf"|"struct"|"measure") -> err () | IDENT s -> stream_njunk 2 strm; Names.id_of_string s | _ -> err ()) | _ -> err ()) let name_colon = Gram.Entry.of_parser "name_colon" (fun strm -> match get_tok (stream_nth 0 strm) with | IDENT s -> (match get_tok (stream_nth 1 strm) with | KEYWORD ":" -> stream_njunk 2 strm; Name (Names.id_of_string s) | _ -> err ()) | KEYWORD "_" -> (match get_tok (stream_nth 1 strm) with | KEYWORD ":" -> stream_njunk 2 strm; Anonymous | _ -> err ()) | _ -> err ()) let aliasvar = function CPatAlias (loc, _, id) -> Some (loc,Name id) | _ -> None GEXTEND Gram GLOBAL: binder_constr lconstr constr operconstr sort global constr_pattern lconstr_pattern Constr.ident closed_binder open_binders binder binders binders_fixannot record_declaration typeclass_constraint pattern appl_arg; Constr.ident: [ [ id = Prim.ident -> id (* This is used in quotations and Syntax *) | id = METAIDENT -> id_of_string id ] ] ; Prim.name: [ [ "_" -> (loc, Anonymous) ] ] ; global: [ [ r = Prim.reference -> r ] ] ; constr_pattern: [ [ c = constr -> c ] ] ; lconstr_pattern: [ [ c = lconstr -> c ] ] ; sort: [ [ "Set" -> GProp Pos | "Prop" -> GProp Null | "Type" -> GType None ] ] ; lconstr: [ [ c = operconstr LEVEL "200" -> c ] ] ; constr: [ [ c = operconstr LEVEL "8" -> c | "@"; f=global -> CAppExpl(loc,(None,f),[]) ] ] ; operconstr: [ "200" RIGHTA [ c = binder_constr -> c ] | "100" RIGHTA [ c1 = operconstr; "<:"; c2 = binder_constr -> CCast(loc,c1, CastConv (VMcast,c2)) | c1 = operconstr; "<:"; c2 = SELF -> CCast(loc,c1, CastConv (VMcast,c2)) | c1 = operconstr; ":";c2 = binder_constr -> CCast(loc,c1, CastConv (DEFAULTcast,c2)) | c1 = operconstr; ":"; c2 = SELF -> CCast(loc,c1, CastConv (DEFAULTcast,c2)) | c1 = operconstr; ":>" -> CCast(loc,c1, CastCoerce) ] | "99" RIGHTA [ ] | "90" RIGHTA [ c1 = operconstr; "->"; c2 = binder_constr -> CArrow(loc,c1,c2) | c1 = operconstr; "->"; c2 = SELF -> CArrow(loc,c1,c2)] | "10" LEFTA [ f=operconstr; args=LIST1 appl_arg -> CApp(loc,(None,f),args) | "@"; f=global; args=LIST0 NEXT -> CAppExpl(loc,(None,f),args) | "@"; (locid,id) = pattern_identref; args=LIST1 identref -> let args = List.map (fun x -> CRef (Ident x), None) args in CApp(loc,(None,CPatVar(locid,(true,id))),args) ] | "9" [ ".."; c = operconstr LEVEL "0"; ".." -> CAppExpl (loc,(None,Ident (loc,Topconstr.ldots_var)),[c]) ] | "8" [ ] | "1" LEFTA [ c=operconstr; ".("; f=global; args=LIST0 appl_arg; ")" -> CApp(loc,(Some (List.length args+1),CRef f),args@[c,None]) | c=operconstr; ".("; "@"; f=global; args=LIST0 (operconstr LEVEL "9"); ")" -> CAppExpl(loc,(Some (List.length args+1),f),args@[c]) | c=operconstr; "%"; key=IDENT -> CDelimiters (loc,key,c) ] | "0" [ c=atomic_constr -> c | c=match_constr -> c | "("; c = operconstr LEVEL "200"; ")" -> (match c with CPrim (_,Numeral z) when Bigint.is_pos_or_zero z -> CNotation(loc,"( _ )",([c],[],[])) | _ -> c) | "{|"; c = record_declaration; "|}" -> c | "`{"; c = operconstr LEVEL "200"; "}" -> CGeneralization (loc, Implicit, None, c) | "`("; c = operconstr LEVEL "200"; ")" -> CGeneralization (loc, Explicit, None, c) ] ] ; forall: [ [ "forall" -> () ] ] ; lambda: [ [ "fun" -> () ] ] ; record_declaration: [ [ fs = LIST0 record_field_declaration SEP ";" -> CRecord (loc, None, fs) (* | c = lconstr; "with"; fs = LIST1 record_field_declaration SEP ";" -> *) (* CRecord (loc, Some c, fs) *) ] ] ; record_field_declaration: [ [ id = global; params = LIST0 identref; ":="; c = lconstr -> (id, Topconstr.abstract_constr_expr c (binders_of_lidents params)) ] ] ; binder_constr: [ [ forall; bl = open_binders; ","; c = operconstr LEVEL "200" -> mkCProdN loc bl c | lambda; bl = open_binders; "=>"; c = operconstr LEVEL "200" -> mkCLambdaN loc bl c | "let"; id=name; bl = binders; ty = type_cstr; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> let loc1 = join_loc (local_binders_loc bl) (constr_loc c1) in CLetIn(loc,id,mkCLambdaN loc1 bl (mk_cast(c1,ty)),c2) | "let"; fx = single_fix; "in"; c = operconstr LEVEL "200" -> let fixp = mk_single_fix fx in let (li,id) = match fixp with CFix(_,id,_) -> id | CCoFix(_,id,_) -> id | _ -> assert false in CLetIn(loc,(li,Name id),fixp,c) | "let"; lb = ["("; l=LIST0 name SEP ","; ")" -> l | "()" -> []]; po = return_type; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> CLetTuple (loc,lb,po,c1,c2) | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> CCases (loc, LetPatternStyle, None, [(c1,(None,None))], [(loc, [(loc,[p])], c2)]) | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> CCases (loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, None))], [(loc, [(loc, [p])], c2)]) | "let"; "'"; p=pattern; "in"; t = operconstr LEVEL "200"; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> CCases (loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, Some t))], [(loc, [(loc, [p])], c2)]) | "if"; c=operconstr LEVEL "200"; po = return_type; "then"; b1=operconstr LEVEL "200"; "else"; b2=operconstr LEVEL "200" -> CIf (loc, c, po, b1, b2) | c=fix_constr -> c ] ] ; appl_arg: [ [ id = lpar_id_coloneq; c=lconstr; ")" -> (c,Some (loc,ExplByName id)) | c=operconstr LEVEL "9" -> (c,None) ] ] ; atomic_constr: [ [ g=global -> CRef g | s=sort -> CSort (loc,s) | n=INT -> CPrim (loc, Numeral (Bigint.of_string n)) | s=string -> CPrim (loc, String s) | "_" -> CHole (loc, None) | id=pattern_ident -> CPatVar(loc,(false,id)) ] ] ; fix_constr: [ [ fx1=single_fix -> mk_single_fix fx1 | (_,kw,dcl1)=single_fix; "with"; dcls=LIST1 fix_decl SEP "with"; "for"; id=identref -> mk_fix(loc,kw,id,dcl1::dcls) ] ] ; single_fix: [ [ kw=fix_kw; dcl=fix_decl -> (loc,kw,dcl) ] ] ; fix_kw: [ [ "fix" -> true | "cofix" -> false ] ] ; fix_decl: [ [ id=identref; bl=binders_fixannot; ty=type_cstr; ":="; c=operconstr LEVEL "200" -> (id,fst bl,snd bl,c,ty) ] ] ; match_constr: [ [ "match"; ci=LIST1 case_item SEP ","; ty=OPT case_type; "with"; br=branches; "end" -> CCases(loc,RegularStyle,ty,ci,br) ] ] ; case_item: [ [ c=operconstr LEVEL "100"; p=pred_pattern -> (c,p) ] ] ; pred_pattern: [ [ ona = OPT ["as"; id=name -> id]; ty = OPT ["in"; t=lconstr -> t] -> (ona,ty) ] ] ; case_type: [ [ "return"; ty = operconstr LEVEL "100" -> ty ] ] ; return_type: [ [ a = OPT [ na = OPT["as"; na=name -> na]; ty = case_type -> (na,ty) ] -> match a with | None -> None, None | Some (na,t) -> (na, Some t) ] ] ; branches: [ [ OPT"|"; br=LIST0 eqn SEP "|" -> br ] ] ; mult_pattern: [ [ pl = LIST1 pattern LEVEL "99" SEP "," -> (loc,pl) ] ] ; eqn: [ [ pll = LIST1 mult_pattern SEP "|"; "=>"; rhs = lconstr -> (loc,pll,rhs) ] ] ; recordpattern: [ [ id = global; ":="; pat = pattern -> (id, pat) ] ] ; pattern: [ "200" RIGHTA [ ] | "100" RIGHTA [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CPatOr (loc,p::pl) ] | "99" RIGHTA [ ] | "10" LEFTA [ p = pattern; "as"; id = ident -> CPatAlias (loc, p, id) ] | "9" RIGHTA [ p = pattern; lp = LIST1 NEXT -> (match p with | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp) | _ -> Util.user_err_loc (cases_pattern_expr_loc p, "compound_pattern", Pp.str "Constructor expected.")) |"@"; r = Prim.reference; lp = LIST1 NEXT -> CPatCstrExpl (loc, r, lp) ] | "1" LEFTA [ c = pattern; "%"; key=IDENT -> CPatDelimiters (loc,key,c) ] | "0" [ r = Prim.reference -> CPatAtom (loc,Some r) | "{|"; pat = LIST0 recordpattern SEP ";" ; "|}" -> CPatRecord (loc, pat) | "_" -> CPatAtom (loc,None) | "("; p = pattern LEVEL "200"; ")" -> (match p with CPatPrim (_,Numeral z) when Bigint.is_pos_or_zero z -> CPatNotation(loc,"( _ )",([p],[])) | _ -> p) | n = INT -> CPatPrim (loc, Numeral (Bigint.of_string n)) | s = string -> CPatPrim (loc, String s) ] ] ; impl_ident_tail: [ [ "}" -> fun id -> LocalRawAssum([id], Default Implicit, CHole(loc, None)) | idl=LIST1 name; ":"; c=lconstr; "}" -> (fun id -> LocalRawAssum (id::idl,Default Implicit,c)) | idl=LIST1 name; "}" -> (fun id -> LocalRawAssum (id::idl,Default Implicit,CHole (loc, None))) | ":"; c=lconstr; "}" -> (fun id -> LocalRawAssum ([id],Default Implicit,c)) ] ] ; fixannot: [ [ "{"; IDENT "struct"; id=identref; "}" -> (Some id, CStructRec) | "{"; IDENT "wf"; rel=constr; id=OPT identref; "}" -> (id, CWfRec rel) | "{"; IDENT "measure"; m=constr; id=OPT identref; rel=OPT constr; "}" -> (id, CMeasureRec (m,rel)) ] ] ; binders_fixannot: [ [ id = impl_ident_head; assum = impl_ident_tail; bl = binders_fixannot -> (assum (loc, Name id) :: fst bl), snd bl | f = fixannot -> [], f | b = binder; bl = binders_fixannot -> b @ fst bl, snd bl | -> [], (None, CStructRec) ] ] ; open_binders: (* Same as binders but parentheses around a closed binder are optional if the latter is unique *) [ [ (* open binder *) id = name; idl = LIST0 name; ":"; c = lconstr -> [LocalRawAssum (id::idl,Default Explicit,c)] (* binders factorized with open binder *) | id = name; idl = LIST0 name; bl = binders -> binders_of_names (id::idl) @ bl | id1 = name; ".."; id2 = name -> [LocalRawAssum ([id1;(loc,Name ldots_var);id2], Default Explicit,CHole (loc,None))] | bl = closed_binder; bl' = binders -> bl@bl' ] ] ; binders: [ [ l = LIST0 binder -> List.flatten l ] ] ; binder: [ [ id = name -> [LocalRawAssum ([id],Default Explicit,CHole (loc, None))] | bl = closed_binder -> bl ] ] ; closed_binder: [ [ "("; id=name; idl=LIST1 name; ":"; c=lconstr; ")" -> [LocalRawAssum (id::idl,Default Explicit,c)] | "("; id=name; ":"; c=lconstr; ")" -> [LocalRawAssum ([id],Default Explicit,c)] | "("; id=name; ":="; c=lconstr; ")" -> [LocalRawDef (id,c)] | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" -> [LocalRawDef (id,CCast (join_loc (constr_loc t) loc,c, CastConv (DEFAULTcast,t)))] | "{"; id=name; "}" -> [LocalRawAssum ([id],Default Implicit,CHole (loc, None))] | "{"; id=name; idl=LIST1 name; ":"; c=lconstr; "}" -> [LocalRawAssum (id::idl,Default Implicit,c)] | "{"; id=name; ":"; c=lconstr; "}" -> [LocalRawAssum ([id],Default Implicit,c)] | "{"; id=name; idl=LIST1 name; "}" -> List.map (fun id -> LocalRawAssum ([id],Default Implicit,CHole (loc, None))) (id::idl) | "`("; tc = LIST1 typeclass_constraint SEP "," ; ")" -> List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Explicit, b), t)) tc | "`{"; tc = LIST1 typeclass_constraint SEP "," ; "}" -> List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Implicit, b), t)) tc ] ] ; typeclass_constraint: [ [ "!" ; c = operconstr LEVEL "200" -> (loc, Anonymous), true, c | "{"; id = name; "}"; ":" ; expl = [ "!" -> true | -> false ] ; c = operconstr LEVEL "200" -> id, expl, c | iid=name_colon ; expl = [ "!" -> true | -> false ] ; c = operconstr LEVEL "200" -> (loc, iid), expl, c | c = operconstr LEVEL "200" -> (loc, Anonymous), false, c ] ] ; type_cstr: [ [ c=OPT [":"; c=lconstr -> c] -> (loc,c) ] ] ; END;; coq-8.4pl4/parsing/extend.ml0000644000175000017500000000277212326224777015127 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [] | ":"; l = LIST1 [id = IDENT -> id ] -> l ] ] ; command: [ [ IDENT "Goal"; c = lconstr -> VernacGoal c | IDENT "Proof" -> VernacProof (None,None) | IDENT "Proof" ; IDENT "Mode" ; mn = string -> VernacProofMode mn | IDENT "Proof"; "with"; ta = tactic; l = OPT [ "using"; l = LIST0 identref -> l ] -> VernacProof (Some ta, l) | IDENT "Proof"; "using"; l = LIST0 identref; ta = OPT [ "with"; ta = tactic -> ta ] -> VernacProof (ta,Some l) | IDENT "Proof"; c = lconstr -> VernacExactProof c | IDENT "Abort" -> VernacAbort None | IDENT "Abort"; IDENT "All" -> VernacAbortAll | IDENT "Abort"; id = identref -> VernacAbort (Some id) | IDENT "Existential"; n = natural; c = constr_body -> VernacSolveExistential (n,c) | IDENT "Admitted" -> VernacEndProof Admitted | IDENT "Qed" -> VernacEndProof (Proved (true,None)) | IDENT "Save" -> VernacEndProof (Proved (true,None)) | IDENT "Save"; tok = thm_token; id = identref -> VernacEndProof (Proved (true,Some (id,Some tok))) | IDENT "Save"; id = identref -> VernacEndProof (Proved (true,Some (id,None))) | IDENT "Defined" -> VernacEndProof (Proved (false,None)) | IDENT "Defined"; id=identref -> VernacEndProof (Proved (false,Some (id,None))) | IDENT "Restart" -> VernacRestart | IDENT "Undo" -> VernacUndo 1 | IDENT "Undo"; n = natural -> VernacUndo n | IDENT "Undo"; IDENT "To"; n = natural -> VernacUndoTo n | IDENT "Focus" -> VernacFocus None | IDENT "Focus"; n = natural -> VernacFocus (Some n) | IDENT "Unfocus" -> VernacUnfocus | IDENT "Unfocused" -> VernacUnfocused | IDENT "Show" -> VernacShow (ShowGoal OpenSubgoals) | IDENT "Show"; n = natural -> VernacShow (ShowGoal (NthGoal n)) | IDENT "Show"; IDENT "Goal"; n = string -> VernacShow (ShowGoal (GoalId n)) | IDENT "Show"; IDENT "Implicit"; IDENT "Arguments"; n = OPT natural -> VernacShow (ShowGoalImplicitly n) | IDENT "Show"; IDENT "Node" -> VernacShow ShowNode | IDENT "Show"; IDENT "Script" -> VernacShow ShowScript | IDENT "Show"; IDENT "Existentials" -> VernacShow ShowExistentials | IDENT "Show"; IDENT "Tree" -> VernacShow ShowTree | IDENT "Show"; IDENT "Conjectures" -> VernacShow ShowProofNames | IDENT "Show"; IDENT "Proof" -> VernacShow ShowProof | IDENT "Show"; IDENT "Intro" -> VernacShow (ShowIntros false) | IDENT "Show"; IDENT "Intros" -> VernacShow (ShowIntros true) | IDENT "Show"; IDENT "Match"; id = identref -> VernacShow (ShowMatch id) | IDENT "Show"; IDENT "Thesis" -> VernacShow ShowThesis | IDENT "Guarded" -> VernacCheckGuard (* Hints for Auto and EAuto *) | IDENT "Create"; IDENT "HintDb" ; id = IDENT ; b = [ "discriminated" -> true | -> false ] -> VernacCreateHintDb (use_module_locality (), id, b) | IDENT "Remove"; IDENT "Hints"; ids = LIST1 global; dbnames = opt_hintbases -> VernacRemoveHints (use_module_locality (), dbnames, ids) | IDENT "Hint"; local = obsolete_locality; h = hint; dbnames = opt_hintbases -> VernacHints (enforce_module_locality local,dbnames, h) (* Declare "Resolve" explicitly so as to be able to later extend with "Resolve ->" and "Resolve <-" *) | IDENT "Hint"; IDENT "Resolve"; lc = LIST1 constr; n = OPT natural; dbnames = opt_hintbases -> VernacHints (use_module_locality (),dbnames, HintsResolve (List.map (fun x -> (n, true, x)) lc)) ] ]; obsolete_locality: [ [ IDENT "Local" -> true | -> false ] ] ; hint: [ [ IDENT "Resolve"; lc = LIST1 constr; n = OPT natural -> HintsResolve (List.map (fun x -> (n, true, x)) lc) | IDENT "Immediate"; lc = LIST1 constr -> HintsImmediate lc | IDENT "Transparent"; lc = LIST1 global -> HintsTransparency (lc, true) | IDENT "Opaque"; lc = LIST1 global -> HintsTransparency (lc, false) | IDENT "Unfold"; lqid = LIST1 global -> HintsUnfold lqid | IDENT "Constructors"; lc = LIST1 global -> HintsConstructors lc | IDENT "Extern"; n = natural; c = OPT constr_pattern ; "=>"; tac = tactic -> HintsExtern (n,c,tac) ] ] ; constr_body: [ [ ":="; c = lconstr -> c | ":"; t = lconstr; ":="; c = lconstr -> CCast(loc,c, Glob_term.CastConv (Term.DEFAULTcast,t)) ] ] ; END coq-8.4pl4/parsing/vernacextend.ml40000644000175000017500000000672612326224777016415 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* e | GramNonTerminal(loc,t,_,Some p)::l -> let p = Names.string_of_id p in let loc = join_loc loc (MLast.loc_of_expr e) in let e = make_let e l in <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >> | _::l -> make_let e l let check_unicity s l = let l' = List.map (fun (_,l,_) -> extract_signature l) l in if not (Util.list_distinct l') then Pp.warning_with !Pp_control.err_ft ("Two distinct rules of entry "^s^" have the same\n"^ "non-terminals in the same order: put them in distinct vernac entries") let make_clause (_,pt,e) = (make_patt pt, vala (Some (make_when (MLast.loc_of_expr e) pt)), make_let e pt) let make_fun_clauses loc s l = check_unicity s l; Compat.make_fun loc (List.map make_clause l) let mlexpr_of_clause = mlexpr_of_list (fun (a,b,c) -> mlexpr_of_list make_prod_item (Option.List.cons (Option.map (fun a -> GramTerminal a) a) b)) let declare_command loc s nt cl = let se = mlexpr_of_string s in let gl = mlexpr_of_clause cl in let funcl = make_fun_clauses loc s cl in declare_str_items loc [ <:str_item< do { try Vernacinterp.vinterp_add $se$ $funcl$ with [ e when Errors.noncritical e -> Pp.msg_warning (Stream.iapp (Pp.str ("Exception in vernac extend " ^ $se$ ^": ")) (Errors.print e)) ]; Egrammar.extend_vernac_command_grammar $se$ $nt$ $gl$ } >> ] open Pcaml open PcamlSig EXTEND GLOBAL: str_item; str_item: [ [ "VERNAC"; "COMMAND"; "EXTEND"; s = UIDENT; OPT "|"; l = LIST1 rule SEP "|"; "END" -> declare_command loc s <:expr> l | "VERNAC"; nt = LIDENT ; "EXTEND"; s = UIDENT; OPT "|"; l = LIST1 rule SEP "|"; "END" -> declare_command loc s <:expr> l ] ] ; (* spiwack: comment-by-guessing: it seems that the isolated string (which otherwise could have been another argument) is not passed to the VernacExtend interpreter function to discriminate between the clauses. *) rule: [ [ "["; s = STRING; l = LIST0 args; "]"; "->"; "["; e = Pcaml.expr; "]" -> if s = "" then Util.user_err_loc (loc,"",Pp.str"Command name is empty."); (Some s,l,<:expr< fun () -> $e$ >>) | "[" ; "-" ; l = LIST1 args ; "]" ; "->" ; "[" ; e = Pcaml.expr ; "]" -> (None,l,<:expr< fun () -> $e$ >>) ] ] ; args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let t, g = interp_entry_name false None e "" in GramNonTerminal (loc, t, g, Some (Names.id_of_string s)) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let t, g = interp_entry_name false None e sep in GramNonTerminal (loc, t, g, Some (Names.id_of_string s)) | s = STRING -> GramTerminal s ] ] ; END ;; coq-8.4pl4/parsing/printer.mli0000644000175000017500000001441312326224777015467 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> std_ppcmds val pr_lconstr : constr -> std_ppcmds val pr_constr_env : env -> constr -> std_ppcmds val pr_constr : constr -> std_ppcmds (** Same, but resilient to [Nametab] errors. Prints fully-qualified names when [shortest_qualid_of_global] has failed. Prints "??" in case of remaining issues (such as reference not in env). *) val safe_pr_lconstr_env : env -> constr -> std_ppcmds val safe_pr_lconstr : constr -> std_ppcmds val safe_pr_constr_env : env -> constr -> std_ppcmds val safe_pr_constr : constr -> std_ppcmds val pr_open_constr_env : env -> open_constr -> std_ppcmds val pr_open_constr : open_constr -> std_ppcmds val pr_open_lconstr_env : env -> open_constr -> std_ppcmds val pr_open_lconstr : open_constr -> std_ppcmds val pr_constr_under_binders_env : env -> constr_under_binders -> std_ppcmds val pr_constr_under_binders : constr_under_binders -> std_ppcmds val pr_lconstr_under_binders_env : env -> constr_under_binders -> std_ppcmds val pr_lconstr_under_binders : constr_under_binders -> std_ppcmds val pr_goal_concl_style_env : env -> types -> std_ppcmds val pr_ltype_env : env -> types -> std_ppcmds val pr_ltype : types -> std_ppcmds val pr_type_env : env -> types -> std_ppcmds val pr_type : types -> std_ppcmds val pr_ljudge_env : env -> unsafe_judgment -> std_ppcmds * std_ppcmds val pr_ljudge : unsafe_judgment -> std_ppcmds * std_ppcmds val pr_lglob_constr_env : env -> glob_constr -> std_ppcmds val pr_lglob_constr : glob_constr -> std_ppcmds val pr_glob_constr_env : env -> glob_constr -> std_ppcmds val pr_glob_constr : glob_constr -> std_ppcmds val pr_lconstr_pattern_env : env -> constr_pattern -> std_ppcmds val pr_lconstr_pattern : constr_pattern -> std_ppcmds val pr_constr_pattern_env : env -> constr_pattern -> std_ppcmds val pr_constr_pattern : constr_pattern -> std_ppcmds val pr_cases_pattern : cases_pattern -> std_ppcmds val pr_sort : sorts -> std_ppcmds (** Printing global references using names as short as possible *) val pr_global_env : Idset.t -> global_reference -> std_ppcmds val pr_global : global_reference -> std_ppcmds val pr_constant : env -> constant -> std_ppcmds val pr_existential : env -> existential -> std_ppcmds val pr_constructor : env -> constructor -> std_ppcmds val pr_inductive : env -> inductive -> std_ppcmds val pr_evaluable_reference : evaluable_global_reference -> std_ppcmds (** Contexts *) val pr_ne_context_of : std_ppcmds -> env -> std_ppcmds val pr_var_decl : env -> named_declaration -> std_ppcmds val pr_rel_decl : env -> rel_declaration -> std_ppcmds val pr_named_context : env -> named_context -> std_ppcmds val pr_named_context_of : env -> std_ppcmds val pr_rel_context : env -> rel_context -> std_ppcmds val pr_rel_context_of : env -> std_ppcmds val pr_context_of : env -> std_ppcmds (** Predicates *) val pr_predicate : ('a -> std_ppcmds) -> (bool * 'a list) -> std_ppcmds val pr_cpred : Cpred.t -> std_ppcmds val pr_idpred : Idpred.t -> std_ppcmds val pr_transparent_state : transparent_state -> std_ppcmds (** Proofs *) val pr_goal : goal sigma -> std_ppcmds val pr_subgoals : ?pr_first:bool -> string option -> evar_map -> evar list -> int list -> goal list -> std_ppcmds val pr_subgoal : int -> evar_map -> goal list -> std_ppcmds val pr_concl : int -> evar_map -> goal -> std_ppcmds val pr_open_subgoals : unit -> std_ppcmds val pr_nth_open_subgoal : int -> std_ppcmds val pr_evar : (evar * evar_info) -> std_ppcmds val pr_evars_int : int -> (evar * evar_info) list -> std_ppcmds val pr_prim_rule : prim_rule -> std_ppcmds (** Emacs/proof general support (emacs_str s) outputs - s if emacs mode, - nothing otherwise. This function was previously used to insert special chars like [(String.make 1 (Char.chr 253))] to parenthesize sub-parts of the proof context for proof by pointing. This part of the code is removed for now because it interacted badly with utf8. We may put it back some day using some xml-like tags instead of special chars. See for example the tag in the prompt when in emacs mode. *) val emacs_str : string -> string (** Backwards compatibility *) val prterm : constr -> std_ppcmds (** = pr_lconstr *) (** spiwack: printer function for sets of Environ.assumption. It is used primarily by the Print Assumption command. *) val pr_assumptionset : env -> Term.types Assumptions.ContextObjectMap.t ->std_ppcmds val pr_goal_by_id : string -> std_ppcmds type printer_pr = { pr_subgoals : ?pr_first:bool -> string option -> evar_map -> evar list -> int list -> goal list -> std_ppcmds; pr_subgoal : int -> evar_map -> goal list -> std_ppcmds; pr_goal : goal sigma -> std_ppcmds; };; val set_printer_pr : printer_pr -> unit val default_printer_pr : printer_pr val pr_instance_gmap : (global_reference, Typeclasses.instance Names.Cmap.t) Gmap.t -> Pp.std_ppcmds (** Inductive declarations *) val pr_mutual_inductive_body : env -> mutual_inductive -> Declarations.mutual_inductive_body -> std_ppcmds coq-8.4pl4/parsing/ppconstr.ml0000644000175000017500000005070312326224777015505 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* str"," ++ spc() let pr_tight_coma () = str "," ++ cut () let latom = 0 let lprod = 200 let llambda = 200 let lif = 200 let lletin = 200 let lletpattern = 200 let lfix = 200 let larrow = 90 let lcast = 100 let larg = 9 let lapp = 10 let lposint = 0 let lnegint = 35 (* must be consistent with Notation "- x" *) let ltop = (200,E) let lproj = 1 let ldelim = 1 let lsimpleconstr = (8,E) let lsimplepatt = (1,E) let prec_less child (parent,assoc) = if parent < 0 && child = lprod then true else let parent = abs parent in match assoc with | E -> (<=) child parent | L -> (<) child parent | Prec n -> child<=n | Any -> true let prec_of_prim_token = function | Numeral p -> if Bigint.is_pos_or_zero p then lposint else lnegint | String _ -> latom open Notation let print_hunks n pr pr_binders (terms,termlists,binders) unp = let env = ref terms and envlist = ref termlists and bll = ref binders in let pop r = let a = List.hd !r in r := List.tl !r; a in let rec aux = function | [] -> mt () | UnpMetaVar (_,prec) :: l -> let c = pop env in pr (n,prec) c ++ aux l | UnpListMetaVar (_,prec,sl) :: l -> let cl = pop envlist in let pp1 = prlist_with_sep (fun () -> aux sl) (pr (n,prec)) cl in let pp2 = aux l in pp1 ++ pp2 | UnpBinderListMetaVar (_,isopen,sl) :: l -> let cl = pop bll in pr_binders (fun () -> aux sl) isopen cl ++ aux l | UnpTerminal s :: l -> str s ++ aux l | UnpBox (b,sub) :: l -> (* Keep order: side-effects *) let pp1 = ppcmd_of_box b (aux sub) in let pp2 = aux l in pp1 ++ pp2 | UnpCut cut :: l -> ppcmd_of_cut cut ++ aux l in aux unp let pr_notation pr pr_binders s env = let unpl, level = find_notation_printing_rule s in print_hunks level pr pr_binders env unpl, level let pr_delimiters key strm = strm ++ str ("%"^key) let pr_generalization bk ak c = let hd, tl = match bk with | Implicit -> "{", "}" | Explicit -> "(", ")" in (* TODO: syntax Abstraction Kind *) str "`" ++ str hd ++ c ++ str tl let pr_com_at n = if Flags.do_beautify() && n <> 0 then comment n else mt() let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp) let pr_sep_com sep f c = pr_with_comments (constr_loc c) (sep() ++ f c) let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)" let pr_universe = Univ.pr_uni let pr_glob_sort = function | GProp Term.Null -> str "Prop" | GProp Term.Pos -> str "Set" | GType u -> hov 0 (str "Type" ++ pr_opt (pr_in_comment pr_universe) u) let pr_id = pr_id let pr_name = pr_name let pr_qualid = pr_qualid let pr_patvar = pr_id let pr_expl_args pr (a,expl) = match expl with | None -> pr (lapp,L) a | Some (_,ExplByPos (n,_id)) -> anomaly("Explicitation by position not implemented") | Some (_,ExplByName id) -> str "(" ++ pr_id id ++ str ":=" ++ pr ltop a ++ str ")" let pr_opt_type pr = function | CHole _ -> mt () | t -> cut () ++ str ":" ++ pr t let pr_opt_type_spc pr = function | CHole _ -> mt () | t -> str " :" ++ pr_sep_com (fun()->brk(1,2)) (pr ltop) t let pr_lident (loc,id) = if loc <> dummy_loc then let (b,_) = unloc loc in pr_located pr_id (make_loc (b,b+String.length(string_of_id id)),id) else pr_id id let pr_lname = function (loc,Name id) -> pr_lident (loc,id) | lna -> pr_located pr_name lna let pr_or_var pr = function | ArgArg x -> pr x | ArgVar (loc,s) -> pr_lident (loc,s) let pr_prim_token = function | Numeral n -> str (Bigint.to_string n) | String s -> qs s let pr_evar pr n l = hov 0 (str (Evd.string_of_existential n) ++ (match l with | Some l -> spc () ++ pr_in_comment (fun l -> str"[" ++ hov 0 (prlist_with_sep pr_comma (pr ltop) l) ++ str"]") (List.rev l) | None -> mt())) let las = lapp let lpator = 100 let lpatrec = 0 let rec pr_patt sep inh p = let (strm,prec) = match p with | CPatRecord (_, l) -> let pp (c, p) = pr_reference c ++ spc() ++ str ":=" ++ pr_patt spc (lpatrec, Any) p in str "{| " ++ prlist_with_sep pr_semicolon pp l ++ str " |}", lpatrec | CPatAlias (_,p,id) -> pr_patt mt (las,E) p ++ str " as " ++ pr_id id, las | CPatCstr (_,c,[]) -> pr_reference c, latom | CPatCstr (_,c,args) -> pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp | CPatCstrExpl (_,c,args) -> str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp | CPatAtom (_,None) -> str "_", latom | CPatAtom (_,Some r) -> pr_reference r, latom | CPatOr (_,pl) -> hov 0 (prlist_with_sep pr_bar (pr_patt spc (lpator,L)) pl), lpator | CPatNotation (_,"( _ )",([p],[])) -> pr_patt (fun()->str"(") (max_int,E) p ++ str")", latom | CPatNotation (_,s,(l,ll)) -> pr_notation (pr_patt mt) (fun _ _ _ -> mt()) s (l,ll,[]) | CPatPrim (_,p) -> pr_prim_token p, latom | CPatDelimiters (_,k,p) -> pr_delimiters k (pr_patt mt lsimplepatt p), 1 in let loc = cases_pattern_expr_loc p in pr_with_comments loc (sep() ++ if prec_less prec inh then strm else surround strm) let pr_patt = pr_patt mt let pr_eqn pr (loc,pl,rhs) = let pl = List.map snd pl in spc() ++ hov 4 (pr_with_comments loc (str "| " ++ hov 0 (prlist_with_sep pr_bar (prlist_with_sep sep_v (pr_patt ltop)) pl ++ str " =>") ++ pr_sep_com spc (pr ltop) rhs)) let begin_of_binder = function LocalRawDef((loc,_),_) -> fst (unloc loc) | LocalRawAssum((loc,_)::_,_,_) -> fst (unloc loc) | _ -> assert false let begin_of_binders = function | b::_ -> begin_of_binder b | _ -> 0 let surround_impl k p = match k with | Explicit -> str"(" ++ p ++ str")" | Implicit -> str"{" ++ p ++ str"}" let surround_implicit k p = match k with | Explicit -> p | Implicit -> (str"{" ++ p ++ str"}") let pr_binder many pr (nal,k,t) = match k with | Generalized (b, b', t') -> assert (b=Implicit); begin match nal with |[loc,Anonymous] -> hov 1 (str"`" ++ (surround_impl b' ((if t' then str "!" else mt ()) ++ pr t))) |[loc,Name id] -> hov 1 (str "`" ++ (surround_impl b' (pr_lident (loc,id) ++ str " : " ++ (if t' then str "!" else mt()) ++ pr t))) |_ -> anomaly "List of generalized binders have alwais one element." end | Default b -> match t with | CHole _ -> let s = prlist_with_sep spc pr_lname nal in hov 1 (surround_implicit b s) | _ -> let s = prlist_with_sep spc pr_lname nal ++ str " : " ++ pr t in hov 1 (if many then surround_impl b s else surround_implicit b s) let pr_binder_among_many pr_c = function | LocalRawAssum (nal,k,t) -> pr_binder true pr_c (nal,k,t) | LocalRawDef (na,c) -> let c,topt = match c with | CCast(_,c, CastConv (_,t)) -> c, t | _ -> c, CHole (dummy_loc, None) in surround (pr_lname na ++ pr_opt_type pr_c topt ++ str":=" ++ cut() ++ pr_c c) let pr_undelimited_binders sep pr_c = prlist_with_sep sep (pr_binder_among_many pr_c) let pr_delimited_binders kw sep pr_c bl = let n = begin_of_binders bl in match bl with | [LocalRawAssum (nal,k,t)] -> pr_com_at n ++ kw() ++ pr_binder false pr_c (nal,k,t) | LocalRawAssum _ :: _ as bdl -> pr_com_at n ++ kw() ++ pr_undelimited_binders sep pr_c bdl | _ -> assert false let pr_binders_gen pr_c sep is_open = if is_open then pr_delimited_binders mt sep pr_c else pr_undelimited_binders sep pr_c let rec extract_prod_binders = function (* | CLetIn (loc,na,b,c) as x -> let bl,c = extract_prod_binders c in if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*) | CProdN (loc,[],c) -> extract_prod_binders c | CProdN (loc,(nal,bk,t)::bl,c) -> let bl,c = extract_prod_binders (CProdN(loc,bl,c)) in LocalRawAssum (nal,bk,t) :: bl, c | c -> [], c let rec extract_lam_binders = function (* | CLetIn (loc,na,b,c) as x -> let bl,c = extract_lam_binders c in if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*) | CLambdaN (loc,[],c) -> extract_lam_binders c | CLambdaN (loc,(nal,bk,t)::bl,c) -> let bl,c = extract_lam_binders (CLambdaN(loc,bl,c)) in LocalRawAssum (nal,bk,t) :: bl, c | c -> [], c let split_lambda = function | CLambdaN (loc,[[na],bk,t],c) -> (na,t,c) | CLambdaN (loc,([na],bk,t)::bl,c) -> (na,t,CLambdaN(loc,bl,c)) | CLambdaN (loc,(na::nal,bk,t)::bl,c) -> (na,t,CLambdaN(loc,(nal,bk,t)::bl,c)) | _ -> anomaly "ill-formed fixpoint body" let rename na na' t c = match (na,na') with | (_,Name id), (_,Name id') -> (na',t,replace_vars_constr_expr [id,id'] c) | (_,Name id), (_,Anonymous) -> (na,t,c) | _ -> (na',t,c) let split_product na' = function | CArrow (loc,t,c) -> (na',t,c) | CProdN (loc,[[na],bk,t],c) -> rename na na' t c | CProdN (loc,([na],bk,t)::bl,c) -> rename na na' t (CProdN(loc,bl,c)) | CProdN (loc,(na::nal,bk,t)::bl,c) -> rename na na' t (CProdN(loc,(nal,bk,t)::bl,c)) | _ -> anomaly "ill-formed fixpoint body" let rec split_fix n typ def = if n = 0 then ([],typ,def) else let (na,_,def) = split_lambda def in let (na,t,typ) = split_product na typ in let (bl,typ,def) = split_fix (n-1) typ def in (LocalRawAssum ([na],default_binder_kind,t)::bl,typ,def) let pr_recursive_decl pr pr_dangling dangling_with_for id bl annot t c = let pr_body = if dangling_with_for then pr_dangling else pr in pr_id id ++ str" " ++ hov 0 (pr_undelimited_binders spc (pr ltop) bl ++ annot) ++ pr_opt_type_spc pr t ++ str " :=" ++ pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c let pr_guard_annot pr_aux bl (n,ro) = match n with | None -> mt () | Some (loc, id) -> match (ro : Topconstr.recursion_order_expr) with | CStructRec -> let names_of_binder = function | LocalRawAssum (nal,_,_) -> nal | LocalRawDef (_,_) -> [] in let ids = List.flatten (List.map names_of_binder bl) in if List.length ids > 1 then spc() ++ str "{struct " ++ pr_id id ++ str"}" else mt() | CWfRec c -> spc() ++ str "{wf " ++ pr_aux c ++ spc() ++ pr_id id ++ str"}" | CMeasureRec (m,r) -> spc() ++ str "{measure " ++ pr_aux m ++ spc() ++ pr_id id++ (match r with None -> mt() | Some r -> str" on " ++ pr_aux r) ++ str"}" let pr_fixdecl pr prd dangling_with_for ((_,id),ro,bl,t,c) = let annot = pr_guard_annot (pr lsimpleconstr) bl ro in pr_recursive_decl pr prd dangling_with_for id bl annot t c let pr_cofixdecl pr prd dangling_with_for ((_,id),bl,t,c) = pr_recursive_decl pr prd dangling_with_for id bl (mt()) t c let pr_recursive pr_decl id = function | [] -> anomaly "(co)fixpoint with no definition" | [d1] -> pr_decl false d1 | dl -> prlist_with_sep (fun () -> fnl() ++ str "with ") (pr_decl true) dl ++ fnl() ++ str "for " ++ pr_id id let pr_asin pr (na,indnalopt) = (match na with (* Decision of printing "_" or not moved to constrextern.ml *) | Some na -> spc () ++ str "as " ++ pr_lname na | None -> mt ()) ++ (match indnalopt with | None -> mt () | Some t -> spc () ++ str "in " ++ pr lsimpleconstr t) let pr_case_item pr (tm,asin) = hov 0 (pr (lcast,E) tm ++ pr_asin pr asin) let pr_case_type pr po = match po with | None | Some (CHole _) -> mt() | Some p -> spc() ++ hov 2 (str "return" ++ pr_sep_com spc (pr lsimpleconstr) p) let pr_simple_return_type pr na po = (match na with | Some (_,Name id) -> spc () ++ str "as " ++ pr_id id | _ -> mt ()) ++ pr_case_type pr po let pr_proj pr pr_app a f l = hov 0 (pr (lproj,E) a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")") let pr_appexpl pr f l = hov 2 ( str "@" ++ pr_reference f ++ prlist (pr_sep_com spc (pr (lapp,L))) l) let pr_app pr a l = hov 2 ( pr (lapp,L) a ++ prlist (fun a -> spc () ++ pr_expl_args pr a) l) let pr_forall () = str"forall" ++ spc () let pr_fun () = str"fun" ++ spc () let pr_fun_sep = str " =>" let pr_dangling_with_for sep pr inherited a = match a with | (CFix (_,_,[_])|CCoFix(_,_,[_])) -> pr sep (latom,E) a | _ -> pr sep inherited a let pr pr sep inherited a = let (strm,prec) = match a with | CRef r -> pr_reference r, latom | CFix (_,id,fix) -> hov 0 (str"fix " ++ pr_recursive (pr_fixdecl (pr mt) (pr_dangling_with_for mt pr)) (snd id) fix), lfix | CCoFix (_,id,cofix) -> hov 0 (str "cofix " ++ pr_recursive (pr_cofixdecl (pr mt) (pr_dangling_with_for mt pr)) (snd id) cofix), lfix | CArrow (_,a,b) -> hov 0 (pr mt (larrow,L) a ++ str " ->" ++ pr (fun () ->brk(1,0)) (-larrow,E) b), larrow | CProdN _ -> let (bl,a) = extract_prod_binders a in hov 0 ( hov 2 (pr_delimited_binders pr_forall spc (pr mt ltop) bl) ++ str "," ++ pr spc ltop a), lprod | CLambdaN _ -> let (bl,a) = extract_lam_binders a in hov 0 ( hov 2 (pr_delimited_binders pr_fun spc (pr mt ltop) bl) ++ pr_fun_sep ++ pr spc ltop a), llambda | CLetIn (_,(_,Name x),(CFix(_,(_,x'),[_])|CCoFix(_,(_,x'),[_]) as fx), b) when x=x' -> hv 0 ( hov 2 (str "let " ++ pr mt ltop fx ++ str " in") ++ pr spc ltop b), lletin | CLetIn (_,x,a,b) -> hv 0 ( hov 2 (str "let " ++ pr_lname x ++ str " :=" ++ pr spc ltop a ++ str " in") ++ pr spc ltop b), lletin | CAppExpl (_,(Some i,f),l) -> let l1,l2 = list_chop i l in let c,l1 = list_sep_last l1 in let p = pr_proj (pr mt) pr_appexpl c f l1 in if l2<>[] then p ++ prlist (pr spc (lapp,L)) l2, lapp else p, lproj | CAppExpl (_,(None,Ident (_,var)),[t]) | CApp (_,(_,CRef(Ident(_,var))),[t,None]) when var = Topconstr.ldots_var -> hov 0 (str ".." ++ pr spc (latom,E) t ++ spc () ++ str ".."), larg | CAppExpl (_,(None,f),l) -> pr_appexpl (pr mt) f l, lapp | CApp (_,(Some i,f),l) -> let l1,l2 = list_chop i l in let c,l1 = list_sep_last l1 in assert (snd c = None); let p = pr_proj (pr mt) pr_app (fst c) f l1 in if l2<>[] then p ++ prlist (fun a -> spc () ++ pr_expl_args (pr mt) a) l2, lapp else p, lproj | CApp (_,(None,a),l) -> pr_app (pr mt) a l, lapp | CRecord (_,w,l) -> let beg = match w with | None -> spc () | Some t -> spc () ++ pr spc ltop t ++ spc () ++ str"with" ++ spc () in hv 0 (str"{|" ++ beg ++ prlist_with_sep pr_semicolon (fun (id, c) -> h 1 (pr_reference id ++ spc () ++ str":=" ++ pr spc ltop c)) l ++ str" |}"), latom | CCases (_,LetPatternStyle,rtntypopt,[c,asin],[(_,[(loc,[p])],b)]) -> hv 0 ( str "let '" ++ hov 0 (pr_patt ltop p ++ pr_asin (pr_dangling_with_for mt pr) asin ++ str " :=" ++ pr spc ltop c ++ pr_case_type (pr_dangling_with_for mt pr) rtntypopt ++ str " in" ++ pr spc ltop b)), lletpattern | CCases(_,_,rtntypopt,c,eqns) -> v 0 (hv 0 (str "match" ++ brk (1,2) ++ hov 0 ( prlist_with_sep sep_v (pr_case_item (pr_dangling_with_for mt pr)) c ++ pr_case_type (pr_dangling_with_for mt pr) rtntypopt) ++ spc () ++ str "with") ++ prlist (pr_eqn (pr mt)) eqns ++ spc() ++ str "end"), latom | CLetTuple (_,nal,(na,po),c,b) -> hv 0 ( str "let " ++ hov 0 (str "(" ++ prlist_with_sep sep_v pr_lname nal ++ str ")" ++ pr_simple_return_type (pr mt) na po ++ str " :=" ++ pr spc ltop c ++ str " in") ++ pr spc ltop b), lletin | CIf (_,c,(na,po),b1,b2) -> (* On force les parenthÃĻses autour d'un "if" sous-terme (mÊme si le parsing est lui plus tolÃĐrant) *) hv 0 ( hov 1 (str "if " ++ pr mt ltop c ++ pr_simple_return_type (pr mt) na po) ++ spc () ++ hov 0 (str "then" ++ pr (fun () -> brk (1,1)) ltop b1) ++ spc () ++ hov 0 (str "else" ++ pr (fun () -> brk (1,1)) ltop b2)), lif | CHole _ -> str "_", latom | CEvar (_,n,l) -> pr_evar (pr mt) n l, latom | CPatVar (_,(_,p)) -> str "?" ++ pr_patvar p, latom | CSort (_,s) -> pr_glob_sort s, latom | CCast (_,a,CastConv (k,b)) -> let s = match k with VMcast -> "<:" | DEFAULTcast | REVERTcast -> ":" in hv 0 (pr mt (lcast,L) a ++ cut () ++ str s ++ pr mt (-lcast,E) b), lcast | CCast (_,a,CastCoerce) -> hv 0 (pr mt (lcast,L) a ++ cut () ++ str ":>"), lcast | CNotation (_,"( _ )",([t],[],[])) -> pr (fun()->str"(") (max_int,L) t ++ str")", latom | CNotation (_,s,env) -> pr_notation (pr mt) (pr_binders_gen (pr mt ltop)) s env | CGeneralization (_,bk,ak,c) -> pr_generalization bk ak (pr mt ltop c), latom | CPrim (_,p) -> pr_prim_token p, prec_of_prim_token p | CDelimiters (_,sc,a) -> pr_delimiters sc (pr mt (ldelim,E) a), ldelim in let loc = constr_loc a in pr_with_comments loc (sep() ++ if prec_less prec inherited then strm else surround strm) type term_pr = { pr_constr_expr : constr_expr -> std_ppcmds; pr_lconstr_expr : constr_expr -> std_ppcmds; pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds; pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds } type precedence = Ppextend.precedence * Ppextend.parenRelation let modular_constr_pr = pr let rec fix rf x =rf (fix rf) x let pr = fix modular_constr_pr mt let pr_simpleconstr = function | CAppExpl (_,(None,f),[]) -> str "@" ++ pr_reference f | c -> pr lsimpleconstr c let default_term_pr = { pr_constr_expr = pr_simpleconstr; pr_lconstr_expr = pr ltop; pr_constr_pattern_expr = pr_simpleconstr; pr_lconstr_pattern_expr = pr ltop } let term_pr = ref default_term_pr let set_term_pr = (:=) term_pr let pr_constr_expr c = !term_pr.pr_constr_expr c let pr_lconstr_expr c = !term_pr.pr_lconstr_expr c let pr_constr_pattern_expr c = !term_pr.pr_constr_pattern_expr c let pr_lconstr_pattern_expr c = !term_pr.pr_lconstr_pattern_expr c let pr_cases_pattern_expr = pr_patt ltop let pr_binders = pr_undelimited_binders spc (pr ltop) let pr_with_occurrences pr occs = match occs with ((false,[]),c) -> pr c | ((nowhere_except_in,nl),c) -> hov 1 (pr c ++ spc() ++ str"at " ++ (if nowhere_except_in then mt() else str "- ") ++ hov 0 (prlist_with_sep spc (pr_or_var int) nl)) let pr_red_flag pr r = (if r.rBeta then pr_arg str "beta" else mt ()) ++ (if r.rIota then pr_arg str "iota" else mt ()) ++ (if r.rZeta then pr_arg str "zeta" else mt ()) ++ (if r.rConst = [] then if r.rDelta then pr_arg str "delta" else mt () else pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++ hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]")) open Genarg let pr_metaid id = str"?" ++ pr_id id let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) = function | Red false -> str "red" | Hnf -> str "hnf" | Simpl o -> str "simpl" ++ pr_opt (pr_with_occurrences pr_pattern) o | Cbv f -> if f = {rBeta=true;rIota=true;rZeta=true;rDelta=true;rConst=[]} then str "compute" else hov 1 (str "cbv" ++ pr_red_flag pr_ref f) | Lazy f -> hov 1 (str "lazy" ++ pr_red_flag pr_ref f) | Unfold l -> hov 1 (str "unfold" ++ spc() ++ prlist_with_sep pr_comma (pr_with_occurrences pr_ref) l) | Fold l -> hov 1 (str "fold" ++ prlist (pr_arg pr_constr) l) | Pattern l -> hov 1 (str "pattern" ++ pr_arg (prlist_with_sep pr_comma (pr_with_occurrences pr_constr)) l) | Red true -> error "Shouldn't be accessible from user." | ExtraRedExpr s -> str s | CbvVm -> str "vm_compute" let rec pr_may_eval test prc prlc pr2 pr3 = function | ConstrEval (r,c) -> hov 0 (str "eval" ++ brk (1,1) ++ pr_red_expr (prc,prlc,pr2,pr3) r ++ str " in" ++ spc() ++ prc c) | ConstrContext ((_,id),c) -> hov 0 (str "context " ++ pr_id id ++ spc () ++ str "[" ++ prlc c ++ str "]") | ConstrTypeOf c -> hov 1 (str "type of" ++ spc() ++ prc c) | ConstrTerm c when test c -> h 0 (str "(" ++ prc c ++ str ")") | ConstrTerm c -> prc c let pr_may_eval a = pr_may_eval (fun _ -> false) a coq-8.4pl4/parsing/tacextend.ml40000644000175000017500000001772012326224777015702 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <:patt< [] >> | GramNonTerminal(loc',_,_,Some p)::l -> let p = Names.string_of_id p in <:patt< [ $lid:p$ :: $make_patt l$ ] >> | _::l -> make_patt l let rec make_when loc = function | [] -> <:expr< True >> | GramNonTerminal(loc',t,_,Some p)::l -> let p = Names.string_of_id p in let l = make_when loc l in let loc = join_loc loc' loc in let t = mlexpr_of_argtype loc' t in <:expr< Genarg.genarg_tag $lid:p$ = $t$ && $l$ >> | _::l -> make_when loc l let rec make_let e = function | [] -> e | GramNonTerminal(loc,t,_,Some p)::l -> let p = Names.string_of_id p in let loc = join_loc loc (MLast.loc_of_expr e) in let e = make_let e l in let v = <:expr< Genarg.out_gen $make_wit loc t$ $lid:p$ >> in <:expr< let $lid:p$ = $v$ in $e$ >> | _::l -> make_let e l let rec extract_signature = function | [] -> [] | GramNonTerminal (_,t,_,_) :: l -> t :: extract_signature l | _::l -> extract_signature l let check_unicity s l = let l' = List.map (fun (l,_) -> extract_signature l) l in if not (Util.list_distinct l') then Pp.warning_with !Pp_control.err_ft ("Two distinct rules of tactic entry "^s^" have the same\n"^ "non-terminals in the same order: put them in distinct tactic entries") let make_clause (pt,e) = (make_patt pt, vala (Some (make_when (MLast.loc_of_expr e) pt)), make_let e pt) let make_fun_clauses loc s l = check_unicity s l; Compat.make_fun loc (List.map make_clause l) let rec make_args = function | [] -> <:expr< [] >> | GramNonTerminal(loc,t,_,Some p)::l -> let p = Names.string_of_id p in <:expr< [ Genarg.in_gen $make_wit loc t$ $lid:p$ :: $make_args l$ ] >> | _::l -> make_args l let rec make_eval_tactic e = function | [] -> e | GramNonTerminal(loc,tag,_,Some p)::l when is_tactic_genarg tag -> let p = Names.string_of_id p in let loc = join_loc loc (MLast.loc_of_expr e) in let e = make_eval_tactic e l in <:expr< let $lid:p$ = $lid:p$ in $e$ >> | _::l -> make_eval_tactic e l let rec make_fun e = function | [] -> e | GramNonTerminal(loc,_,_,Some p)::l -> let p = Names.string_of_id p in <:expr< fun $lid:p$ -> $make_fun e l$ >> | _::l -> make_fun e l let mlexpr_terminals_of_grammar_tactic_prod_item_expr = function | GramTerminal s -> <:expr< Some $mlexpr_of_string s$ >> | GramNonTerminal (loc,nt,_,sopt) -> <:expr< None >> let make_prod_item = function | GramTerminal s -> <:expr< Egrammar.GramTerminal $str:s$ >> | GramNonTerminal (loc,nt,g,sopt) -> <:expr< Egrammar.GramNonTerminal $default_loc$ $mlexpr_of_argtype loc nt$ $mlexpr_of_prod_entry_key g$ $mlexpr_of_option mlexpr_of_ident sopt$ >> let mlexpr_of_clause = mlexpr_of_list (fun (a,b) -> mlexpr_of_list make_prod_item a) let rec make_tags loc = function | [] -> <:expr< [] >> | GramNonTerminal(loc',t,_,Some p)::l -> let l = make_tags loc l in let loc = join_loc loc' loc in let t = mlexpr_of_argtype loc' t in <:expr< [ $t$ :: $l$ ] >> | _::l -> make_tags loc l let make_one_printing_rule se (pt,e) = let level = mlexpr_of_int 0 in (* only level 0 supported here *) let loc = MLast.loc_of_expr e in let prods = mlexpr_of_list mlexpr_terminals_of_grammar_tactic_prod_item_expr pt in <:expr< ($se$, $make_tags loc pt$, ($level$, $prods$)) >> let make_printing_rule se = mlexpr_of_list (make_one_printing_rule se) let rec possibly_empty_subentries loc = function | [] -> [] | (s,prodsl) :: l -> let rec aux = function | [] -> (false,<:expr< None >>) | prods :: rest -> try let l = List.map (function | GramNonTerminal(_,(List0ArgType _| OptArgType _| ExtraArgType _ as t),_,_)-> (* This possibly parses epsilon *) let rawwit = make_rawwit loc t in <:expr< match Genarg.default_empty_value $rawwit$ with [ None -> failwith "" | Some v -> Tacinterp.intern_genarg Tacinterp.fully_empty_glob_sign (Genarg.in_gen $rawwit$ v) ] >> | GramTerminal _ | GramNonTerminal(_,_,_,_) -> (* This does not parse epsilon (this Exit is static time) *) raise Exit) prods in if has_extraarg prods then (true,<:expr< try Some $mlexpr_of_list (fun x -> x) l$ with [ Failure "" -> $snd (aux rest)$ ] >>) else (true, <:expr< Some $mlexpr_of_list (fun x -> x) l$ >>) with Exit -> aux rest in let (nonempty,v) = aux prodsl in if nonempty then (s,v) :: possibly_empty_subentries loc l else possibly_empty_subentries loc l let possibly_atomic loc prods = let l = list_map_filter (function | GramTerminal s :: l, _ -> Some (s,l) | _ -> None) prods in possibly_empty_subentries loc (list_factorize_left l) let declare_tactic loc s cl = let se = mlexpr_of_string s in let pp = make_printing_rule se cl in let gl = mlexpr_of_clause cl in let hide_tac (p,e) = (* reste a definir les fonctions cachees avec des noms frais *) let stac = "h_"^s in let e = make_fun <:expr< Refiner.abstract_extended_tactic $mlexpr_of_string s$ $make_args p$ $make_eval_tactic e p$ >> p in <:str_item< value $lid:stac$ = $e$ >> in let hidden = if List.length cl = 1 then List.map hide_tac cl else [] in let atomic_tactics = mlexpr_of_list (mlexpr_of_pair mlexpr_of_string (fun x -> x)) (possibly_atomic loc cl) in declare_str_items loc (hidden @ [ <:str_item< do { try let _=Tacinterp.add_tactic $se$ $make_fun_clauses loc s cl$ in List.iter (fun (s,l) -> match l with [ Some l -> Tacinterp.add_primitive_tactic s (Tacexpr.TacAtom($default_loc$, Tacexpr.TacExtend($default_loc$,$se$,l))) | None -> () ]) $atomic_tactics$ with [ e when Errors.noncritical e -> Pp.msg_warning (Stream.iapp (Pp.str ("Exception in tactic extend " ^ $se$ ^": ")) (Errors.print e)) ]; Egrammar.extend_tactic_grammar $se$ $gl$; List.iter Pptactic.declare_extra_tactic_pprule $pp$; } >> ]) open Pcaml open PcamlSig EXTEND GLOBAL: str_item; str_item: [ [ "TACTIC"; "EXTEND"; s = tac_name; OPT "|"; l = LIST1 tacrule SEP "|"; "END" -> declare_tactic loc s l ] ] ; tacrule: [ [ "["; l = LIST1 tacargs; "]"; "->"; "["; e = Pcaml.expr; "]" -> if match List.hd l with GramNonTerminal _ -> true | _ -> false then (* En attendant la syntaxe de tacticielles *) failwith "Tactic syntax must start with an identifier"; (l,e) ] ] ; tacargs: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let t, g = interp_entry_name false None e "" in GramNonTerminal (loc, t, g, Some (Names.id_of_string s)) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let t, g = interp_entry_name false None e sep in GramNonTerminal (loc, t, g, Some (Names.id_of_string s)) | s = STRING -> if s = "" then Util.user_err_loc (loc,"",Pp.str "Empty terminal."); GramTerminal s ] ] ; tac_name: [ [ s = LIDENT -> s | s = UIDENT -> s ] ] ; END coq-8.4pl4/parsing/g_ltac.ml40000644000175000017500000002034412326224777015150 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* a | e -> Tacexp (e:raw_tactic_expr) (* Tactics grammar rules *) GEXTEND Gram GLOBAL: tactic Vernac_.command tactic_expr binder_tactic tactic_arg constr_may_eval; tactic_then_last: [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) | -> [||] ] ] ; tactic_then_gen: [ [ ta = tactic_expr; "|"; (first,last) = tactic_then_gen -> (ta::first, last) | ta = tactic_expr; ".."; l = tactic_then_last -> ([], Some (ta, l)) | ".."; l = tactic_then_last -> ([], Some (TacId [], l)) | ta = tactic_expr -> ([ta], None) | "|"; (first,last) = tactic_then_gen -> (TacId [] :: first, last) | -> ([TacId []], None) ] ] ; tactic_expr: [ "5" RIGHTA [ te = binder_tactic -> te ] | "4" LEFTA [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, [||], ta1, [||]) | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0, [||], ta1, [||]) | ta0 = tactic_expr; ";"; "["; (first,tail) = tactic_then_gen; "]" -> match tail with | Some (t,last) -> TacThen (ta0, Array.of_list first, t, last) | None -> TacThens (ta0,first) ] | "3" RIGHTA [ IDENT "try"; ta = tactic_expr -> TacTry ta | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta) | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> TacTimeout (n,ta) | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta | IDENT "progress"; ta = tactic_expr -> TacProgress ta (*To do: put Abstract in Refiner*) | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None) | IDENT "abstract"; tc = NEXT; "using"; s = ident -> TacAbstract (tc,Some s) ] (*End of To do*) | "2" RIGHTA [ ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1) | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ] | "1" RIGHTA [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> TacMatchGoal (b,false,mrl) | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; mrl = match_context_list; "end" -> TacMatchGoal (b,true,mrl) | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> TacMatch (b,c,mrl) | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> TacFirst l | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> TacSolve l | IDENT "idtac"; l = LIST0 message_token -> TacId l | IDENT "fail"; n = [ n = int_or_var -> n | -> fail_default_value ]; l = LIST0 message_token -> TacFail (n,l) | IDENT "external"; com = STRING; req = STRING; la = LIST1 tactic_arg -> TacArg (loc,TacExternal (loc,com,req,la)) | st = simple_tactic -> TacAtom (loc,st) | a = may_eval_arg -> TacArg(loc,a) | IDENT "constr"; ":"; id = METAIDENT -> TacArg(loc,MetaIdArg (loc,false,id)) | IDENT "constr"; ":"; c = Constr.constr -> TacArg(loc,ConstrMayEval(ConstrTerm c)) | IDENT "ipattern"; ":"; ipat = simple_intropattern -> TacArg(loc,IntroPattern ipat) | r = reference; la = LIST0 tactic_arg -> TacArg(loc,TacCall (loc,r,la)) ] | "0" [ "("; a = tactic_expr; ")" -> a | a = tactic_atom -> TacArg (loc,a) ] ] ; (* binder_tactic: level 5 of tactic_expr *) binder_tactic: [ RIGHTA [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> TacFun (it,body) | "let"; isrec = [IDENT "rec" -> true | -> false]; llc = LIST1 let_clause SEP "with"; "in"; body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body) | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ] ; (* Tactic arguments *) tactic_arg: [ [ IDENT "ltac"; ":"; a = tactic_expr LEVEL "0" -> arg_of_expr a | IDENT "ltac"; ":"; n = natural -> Integer n | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat | a = may_eval_arg -> a | r = reference -> Reference r | c = Constr.constr -> ConstrMayEval (ConstrTerm c) (* Unambigous entries: tolerated w/o "ltac:" modifier *) | id = METAIDENT -> MetaIdArg (loc,true,id) | "()" -> TacVoid ] ] ; may_eval_arg: [ [ c = constr_eval -> ConstrMayEval c | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l ] ] ; fresh_id: [ [ s = STRING -> ArgArg s | id = ident -> ArgVar (loc,id) ] ] ; constr_eval: [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> ConstrEval (rtc,c) | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> ConstrContext (id,c) | IDENT "type"; IDENT "of"; c = Constr.constr -> ConstrTypeOf c ] ] ; constr_may_eval: (* For extensions *) [ [ c = constr_eval -> c | c = Constr.constr -> ConstrTerm c ] ] ; tactic_atom: [ [ id = METAIDENT -> MetaIdArg (loc,true,id) | n = integer -> Integer n | r = reference -> TacCall (loc,r,[]) | "()" -> TacVoid ] ] ; match_key: [ [ "match" -> false | "lazymatch" -> true ] ] ; input_fun: [ [ "_" -> None | l = ident -> Some l ] ] ; let_clause: [ [ id = identref; ":="; te = tactic_expr -> (id, arg_of_expr te) | id = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> (id, arg_of_expr (TacFun(args,te))) ] ] ; match_pattern: [ [ IDENT "context"; oid = OPT Constr.ident; "["; pc = Constr.lconstr_pattern; "]" -> Subterm (false,oid, pc) | IDENT "appcontext"; oid = OPT Constr.ident; "["; pc = Constr.lconstr_pattern; "]" -> Subterm (true,oid, pc) | pc = Constr.lconstr_pattern -> Term pc ] ] ; match_hyps: [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt) | na = name; ":="; mpv = match_pattern -> let t, ty = match mpv with | Term t -> (match t with | CCast (loc, t, CastConv (_, ty)) -> Term t, Some (Term ty) | _ -> mpv, None) | _ -> mpv, None in Def (na, t, Option.default (Term (CHole (dummy_loc, None))) ty) ] ] ; match_context_rule: [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; "=>"; te = tactic_expr -> Pat (largs, mp, te) | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te) | "_"; "=>"; te = tactic_expr -> All te ] ] ; match_context_list: [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ] ; match_rule: [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te) | "_"; "=>"; te = tactic_expr -> All te ] ] ; match_list: [ [ mrl = LIST1 match_rule SEP "|" -> mrl | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ] ; message_token: [ [ id = identref -> MsgIdent (AI id) | s = STRING -> MsgString s | n = integer -> MsgInt n ] ] ; ltac_def_kind: [ [ ":=" -> false | "::=" -> true ] ] ; (* Definitions for tactics *) tacdef_body: [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> (name, redef, TacFun (it, body)) | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> (name, redef, body) ] ] ; tactic: [ [ tac = tactic_expr -> tac ] ] ; Vernac_.command: [ [ IDENT "Ltac"; l = LIST1 tacdef_body SEP "with" -> VernacDeclareTacticDefinition (use_module_locality (), true, l) ] ] ; END coq-8.4pl4/parsing/pptactic.mli0000644000175000017500000000714012326224777015612 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* std_ppcmds) -> 'a or_var -> std_ppcmds val pr_or_metaid : ('a -> std_ppcmds) -> 'a or_metaid -> std_ppcmds val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds type 'a raw_extra_genarg_printer = (constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) -> (tolerability -> raw_tactic_expr -> std_ppcmds) -> 'a -> std_ppcmds type 'a glob_extra_genarg_printer = (glob_constr_and_expr -> std_ppcmds) -> (glob_constr_and_expr -> std_ppcmds) -> (tolerability -> glob_tactic_expr -> std_ppcmds) -> 'a -> std_ppcmds type 'a extra_genarg_printer = (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) -> (tolerability -> glob_tactic_expr -> std_ppcmds) -> 'a -> std_ppcmds (** if the boolean is false then the extension applies only to old syntax *) val declare_extra_genarg_pprule : ('c raw_abstract_argument_type * 'c raw_extra_genarg_printer) -> ('a glob_abstract_argument_type * 'a glob_extra_genarg_printer) -> ('b typed_abstract_argument_type * 'b extra_genarg_printer) -> unit type grammar_terminals = string option list (** if the boolean is false then the extension applies only to old syntax *) val declare_extra_tactic_pprule : string * argument_type list * (int * grammar_terminals) -> unit val exists_extra_tactic_pprule : string -> argument_type list -> bool val pr_raw_generic : (constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) -> (tolerability -> raw_tactic_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) -> (Libnames.reference -> std_ppcmds) -> rlevel generic_argument -> std_ppcmds val pr_raw_extend: (constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) -> (tolerability -> raw_tactic_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) -> int -> string -> raw_generic_argument list -> std_ppcmds val pr_glob_extend: (glob_constr_and_expr -> std_ppcmds) -> (glob_constr_and_expr -> std_ppcmds) -> (tolerability -> glob_tactic_expr -> std_ppcmds) -> (glob_constr_pattern_and_expr -> std_ppcmds) -> int -> string -> glob_generic_argument list -> std_ppcmds val pr_extend : (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) -> (tolerability -> glob_tactic_expr -> std_ppcmds) -> (constr_pattern -> std_ppcmds) -> int -> string -> typed_generic_argument list -> std_ppcmds val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds val pr_raw_tactic : env -> raw_tactic_expr -> std_ppcmds val pr_raw_tactic_level : env -> tolerability -> raw_tactic_expr -> std_ppcmds val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds val pr_tactic : env -> Proof_type.tactic_expr -> std_ppcmds val pr_hintbases : string list option -> std_ppcmds val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds val pr_bindings : ('constr -> std_ppcmds) -> ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds coq-8.4pl4/parsing/highparsing.mllib0000644000175000017500000000006212326224777016620 0ustar stephstephG_constr G_vernac G_prim G_proofs G_tactic G_ltac coq-8.4pl4/parsing/g_vernac.ml40000644000175000017500000011533412326224777015507 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ->"; ":<"; "<:"; "where"; "at" ] let _ = List.iter Lexer.add_keyword vernac_kw (* Rem: do not join the different GEXTEND into one, it breaks native *) (* compilation on PowerPC and Sun architectures *) let check_command = Gram.entry_create "vernac:check_command" let tactic_mode = Gram.entry_create "vernac:tactic_command" let noedit_mode = Gram.entry_create "vernac:noedit_command" let subprf = Gram.entry_create "vernac:subprf" let class_rawexpr = Gram.entry_create "vernac:class_rawexpr" let thm_token = Gram.entry_create "vernac:thm_token" let def_body = Gram.entry_create "vernac:def_body" let decl_notation = Gram.entry_create "vernac:decl_notation" let record_field = Gram.entry_create "vernac:record_field" let of_type_with_opt_coercion = Gram.entry_create "vernac:of_type_with_opt_coercion" let subgoal_command = Gram.entry_create "proof_mode:subgoal_command" let instance_name = Gram.entry_create "vernac:instance_name" let command_entry = ref noedit_mode let set_command_entry e = command_entry := e let get_command_entry () = !command_entry (* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for proof editing and changes nothing else). Then sets it as the default proof mode. *) let set_tactic_mode () = set_command_entry tactic_mode let set_noedit_mode () = set_command_entry noedit_mode let _ = Proof_global.register_proof_mode {Proof_global. name = "Classic" ; set = set_tactic_mode ; reset = set_noedit_mode } let default_command_entry = Gram.Entry.of_parser "command_entry" (fun strm -> Gram.parse_tokens_after_filter (get_command_entry ()) strm) let no_hook _ _ = () GEXTEND Gram GLOBAL: vernac gallina_ext tactic_mode noedit_mode subprf subgoal_command; vernac: FIRST [ [ IDENT "Time"; v = vernac -> VernacTime v | IDENT "Timeout"; n = natural; v = vernac -> VernacTimeout(n,v) | IDENT "Fail"; v = vernac -> VernacFail v | locality; v = vernac_aux -> v ] ] ; vernac_aux: (* Better to parse "." here: in case of failure (e.g. in coerce_to_var), *) (* "." is still in the stream and discard_to_dot works correctly *) [ [ g = gallina; "." -> g | g = gallina_ext; "." -> g | c = command; "." -> c | c = syntax; "." -> c | "["; l = LIST1 located_vernac; "]"; "." -> VernacList l | c = subprf -> c ] ] ; vernac_aux: LAST [ [ prfcom = default_command_entry -> prfcom ] ] ; locality: [ [ IDENT "Local" -> locality_flag := Some (loc,true) | IDENT "Global" -> locality_flag := Some (loc,false) | -> locality_flag := None ] ] ; noedit_mode: [ [ c = subgoal_command -> c None] ] ; tactic_mode: [ [ gln = OPT[n=natural; ":" -> n]; tac = subgoal_command -> tac gln ] ] ; subprf: [ [ "-" -> VernacBullet Dash | "*" -> VernacBullet Star | "+" -> VernacBullet Plus | "{" -> VernacSubproof None | "}" -> VernacEndSubproof ] ] ; subgoal_command: [ [ c = check_command; "." -> fun g -> c g | tac = Tactic.tactic; use_dft_tac = [ "." -> false | "..." -> true ] -> (fun g -> let g = Option.default 1 g in VernacSolve(g,tac,use_dft_tac)) ] ] ; located_vernac: [ [ v = vernac -> loc, v ] ] ; END let test_plurial_form = function | [(_,([_],_))] -> Flags.if_verbose msg_warning (str "Keywords Variables/Hypotheses/Parameters expect more than one assumption") | _ -> () let test_plurial_form_types = function | [([_],_)] -> Flags.if_verbose msg_warning (str "Keywords Implicit Types expect more than one type") | _ -> () (* Gallina declarations *) GEXTEND Gram GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion record_field decl_notation rec_definition; gallina: (* Definition, Theorem, Variable, Axiom, ... *) [ [ thm = thm_token; id = identref; bl = binders; ":"; c = lconstr; l = LIST0 [ "with"; id = identref; bl = binders; ":"; c = lconstr -> (Some id,(bl,c,None)) ] -> VernacStartTheoremProof (thm,(Some id,(bl,c,None))::l, false, no_hook) | stre = assumption_token; nl = inline; bl = assum_list -> VernacAssumption (stre, nl, bl) | stre = assumptions_token; nl = inline; bl = assum_list -> test_plurial_form bl; VernacAssumption (stre, nl, bl) | (f,d) = def_token; id = identref; b = def_body -> VernacDefinition (d, id, b, f) (* Gallina inductive declarations *) | f = finite_token; indl = LIST1 inductive_definition SEP "with" -> let (k,f) = f in let indl=List.map (fun ((a,b,c,d),e) -> ((a,b,c,k,d),e)) indl in VernacInductive (f,false,indl) | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> VernacFixpoint recs | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> VernacCoFixpoint corecs | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> VernacScheme l | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from"; l = LIST1 identref SEP "," -> VernacCombinedScheme (id, l) ] ] ; gallina_ext: [ [ b = record_token; infer = infer_token; oc = opt_coercion; name = identref; ps = binders; s = OPT [ ":"; s = lconstr -> s ]; cfs = [ ":="; l = constructor_list_or_record_decl -> l | -> RecordDecl (None, []) ] -> let (recf,indf) = b in VernacInductive (indf,infer,[((oc,name),ps,s,recf,cfs),[]]) ] ] ; thm_token: [ [ "Theorem" -> Theorem | IDENT "Lemma" -> Lemma | IDENT "Fact" -> Fact | IDENT "Remark" -> Remark | IDENT "Corollary" -> Corollary | IDENT "Proposition" -> Proposition | IDENT "Property" -> Property ] ] ; def_token: [ [ "Definition" -> no_hook, (Global, Definition) | IDENT "Let" -> no_hook, (Local, Definition) | IDENT "Example" -> no_hook, (Global, Example) | IDENT "SubClass" -> Class.add_subclass_hook, (use_locality_exp (), SubClass) ] ] ; assumption_token: [ [ "Hypothesis" -> (Local, Logical) | "Variable" -> (Local, Definitional) | "Axiom" -> (Global, Logical) | "Parameter" -> (Global, Definitional) | IDENT "Conjecture" -> (Global, Conjectural) ] ] ; assumptions_token: [ [ IDENT "Hypotheses" -> (Local, Logical) | IDENT "Variables" -> (Local, Definitional) | IDENT "Axioms" -> (Global, Logical) | IDENT "Parameters" -> (Global, Definitional) ] ] ; inline: [ [ IDENT "Inline"; "("; i = INT; ")" -> Some (int_of_string i) | IDENT "Inline" -> Some (Flags.get_inline_level()) | -> None] ] ; finite_token: [ [ "Inductive" -> (Inductive_kw,Finite) | "CoInductive" -> (CoInductive,CoFinite) ] ] ; infer_token: [ [ IDENT "Infer" -> true | -> false ] ] ; record_token: [ [ IDENT "Record" -> (Record,BiFinite) | IDENT "Structure" -> (Structure,BiFinite) | IDENT "Class" -> (Class true,BiFinite) ] ] ; (* Simple definitions *) def_body: [ [ bl = binders; ":="; red = reduce; c = lconstr -> (match c with CCast(_,c, Glob_term.CastConv (Term.DEFAULTcast,t)) -> DefineBody (bl, red, c, Some t) | _ -> DefineBody (bl, red, c, None)) | bl = binders; ":"; t = lconstr; ":="; red = reduce; c = lconstr -> DefineBody (bl, red, c, Some t) | bl = binders; ":"; t = lconstr -> ProveBody (bl, t) ] ] ; reduce: [ [ IDENT "Eval"; r = Tactic.red_expr; "in" -> Some r | -> None ] ] ; one_decl_notation: [ [ ntn = ne_lstring; ":="; c = constr; scopt = OPT [ ":"; sc = IDENT -> sc] -> (ntn,c,scopt) ] ] ; decl_notation: [ [ "where"; l = LIST1 one_decl_notation SEP IDENT "and" -> l | -> [] ] ] ; (* Inductives and records *) inductive_definition: [ [ id = identref; oc = opt_coercion; indpar = binders; c = OPT [ ":"; c = lconstr -> c ]; ":="; lc = constructor_list_or_record_decl; ntn = decl_notation -> (((oc,id),indpar,c,lc),ntn) ] ] ; constructor_list_or_record_decl: [ [ "|"; l = LIST1 constructor SEP "|" -> Constructors l | id = identref ; c = constructor_type; "|"; l = LIST0 constructor SEP "|" -> Constructors ((c id)::l) | id = identref ; c = constructor_type -> Constructors [ c id ] | cstr = identref; "{"; fs = LIST0 record_field SEP ";"; "}" -> RecordDecl (Some cstr,fs) | "{";fs = LIST0 record_field SEP ";"; "}" -> RecordDecl (None,fs) | -> Constructors [] ] ] ; (* csort: [ [ s = sort -> CSort (loc,s) ] ] ; *) opt_coercion: [ [ ">" -> true | -> false ] ] ; (* (co)-fixpoints *) rec_definition: [ [ id = identref; bl = binders_fixannot; ty = type_cstr; def = OPT [":="; def = lconstr -> def]; ntn = decl_notation -> let bl, annot = bl in ((id,annot,bl,ty,def),ntn) ] ] ; corec_definition: [ [ id = identref; bl = binders; ty = type_cstr; def = OPT [":="; def = lconstr -> def]; ntn = decl_notation -> ((id,bl,ty,def),ntn) ] ] ; type_cstr: [ [ ":"; c=lconstr -> c | -> CHole (loc, None) ] ] ; (* Inductive schemes *) scheme: [ [ kind = scheme_kind -> (None,kind) | id = identref; ":="; kind = scheme_kind -> (Some id,kind) ] ] ; scheme_kind: [ [ IDENT "Induction"; "for"; ind = smart_global; IDENT "Sort"; s = sort-> InductionScheme(true,ind,s) | IDENT "Minimality"; "for"; ind = smart_global; IDENT "Sort"; s = sort-> InductionScheme(false,ind,s) | IDENT "Elimination"; "for"; ind = smart_global; IDENT "Sort"; s = sort-> CaseScheme(true,ind,s) | IDENT "Case"; "for"; ind = smart_global; IDENT "Sort"; s = sort-> CaseScheme(false,ind,s) | IDENT "Equality"; "for" ; ind = smart_global -> EqualityScheme(ind) ] ] ; (* Various Binders *) (* (* ... without coercions *) binder_nodef: [ [ b = binder_let -> (match b with LocalRawAssum(l,ty) -> (l,ty) | LocalRawDef _ -> Util.user_err_loc (loc,"fix_param",Pp.str"defined binder not allowed here.")) ] ] ; *) (* ... with coercions *) record_field: [ [ bd = record_binder; pri = OPT [ "|"; n = natural -> n ]; ntn = decl_notation -> (bd,pri),ntn ] ] ; record_binder_body: [ [ l = binders; oc = of_type_with_opt_coercion; t = lconstr -> fun id -> (oc,AssumExpr (id,mkCProdN loc l t)) | l = binders; oc = of_type_with_opt_coercion; t = lconstr; ":="; b = lconstr -> fun id -> (oc,DefExpr (id,mkCLambdaN loc l b,Some (mkCProdN loc l t))) | l = binders; ":="; b = lconstr -> fun id -> match b with | CCast(_,b, Glob_term.CastConv (_, t)) -> (None,DefExpr(id,mkCLambdaN loc l b,Some (mkCProdN loc l t))) | _ -> (None,DefExpr(id,mkCLambdaN loc l b,None)) ] ] ; record_binder: [ [ id = name -> (None,AssumExpr(id,CHole (loc, None))) | id = name; f = record_binder_body -> f id ] ] ; assum_list: [ [ bl = LIST1 assum_coe -> bl | b = simple_assum_coe -> [b] ] ] ; assum_coe: [ [ "("; a = simple_assum_coe; ")" -> a ] ] ; simple_assum_coe: [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr -> (oc <> None,(idl,c)) ] ] ; constructor_type: [[ l = binders; t= [ coe = of_type_with_opt_coercion; c = lconstr -> fun l id -> (coe <> None,(id,mkCProdN loc l c)) | -> fun l id -> (false,(id,mkCProdN loc l (CHole (loc, None)))) ] -> t l ]] ; constructor: [ [ id = identref; c=constructor_type -> c id ] ] ; of_type_with_opt_coercion: [ [ ":>>" -> Some false | ":>"; ">" -> Some false | ":>" -> Some true | ":"; ">"; ">" -> Some false | ":"; ">" -> Some true | ":" -> None ] ] ; END (* Modules and Sections *) GEXTEND Gram GLOBAL: gallina_ext module_expr module_type; gallina_ext: [ [ (* Interactive module declaration *) IDENT "Module"; export = export_token; id = identref; bl = LIST0 module_binder; sign = of_module_type; body = is_module_expr -> VernacDefineModule (export, id, bl, sign, body) | IDENT "Module"; "Type"; id = identref; bl = LIST0 module_binder; sign = check_module_types; body = is_module_type -> VernacDeclareModuleType (id, bl, sign, body) | IDENT "Declare"; IDENT "Module"; export = export_token; id = identref; bl = LIST0 module_binder; ":"; mty = module_type_inl -> VernacDeclareModule (export, id, bl, mty) (* Section beginning *) | IDENT "Section"; id = identref -> VernacBeginSection id | IDENT "Chapter"; id = identref -> VernacBeginSection id (* This end a Section a Module or a Module Type *) | IDENT "End"; id = identref -> VernacEndSegment id (* Requiring an already compiled module *) | IDENT "Require"; export = export_token; qidl = LIST1 global -> VernacRequire (export, None, qidl) | IDENT "Require"; export = export_token; filename = ne_string -> VernacRequireFrom (export, None, filename) | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl) | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl) | IDENT "Include"; e = module_type_inl; l = LIST0 ext_module_expr -> VernacInclude(e::l) | IDENT "Include"; "Type"; e = module_type_inl; l = LIST0 ext_module_type -> Flags.if_verbose msg_warning (str "Include Type is deprecated; use Include instead"); VernacInclude(e::l) ] ] ; export_token: [ [ IDENT "Import" -> Some false | IDENT "Export" -> Some true | -> None ] ] ; ext_module_type: [ [ "<+"; mty = module_type_inl -> mty ] ] ; ext_module_expr: [ [ "<+"; mexpr = module_expr_inl -> mexpr ] ] ; check_module_type: [ [ "<:"; mty = module_type_inl -> mty ] ] ; check_module_types: [ [ mtys = LIST0 check_module_type -> mtys ] ] ; of_module_type: [ [ ":"; mty = module_type_inl -> Enforce mty | mtys = check_module_types -> Check mtys ] ] ; is_module_type: [ [ ":="; mty = module_type_inl ; l = LIST0 ext_module_type -> (mty::l) | -> [] ] ] ; is_module_expr: [ [ ":="; mexpr = module_expr_inl; l = LIST0 ext_module_expr -> (mexpr::l) | -> [] ] ] ; functor_app_annot: [ [ IDENT "inline"; "at"; IDENT "level"; i = INT -> [InlineAt (int_of_string i)], [] | IDENT "no"; IDENT "inline" -> [NoInline], [] | IDENT "scope"; sc1 = IDENT; IDENT "to"; sc2 = IDENT -> [], [sc1,sc2] ] ] ; functor_app_annots: [ [ "["; l = LIST1 functor_app_annot SEP ","; "]" -> let inl,scs = List.split l in let inl = match List.concat inl with | [] -> DefaultInline | [inl] -> inl | _ -> error "Functor application with redundant inline annotations" in { ann_inline = inl; ann_scope_subst = List.concat scs } | -> { ann_inline = DefaultInline; ann_scope_subst = [] } ] ] ; module_expr_inl: [ [ "!"; me = module_expr -> (me, { ann_inline = NoInline; ann_scope_subst = []}) | me = module_expr; a = functor_app_annots -> (me,a) ] ] ; module_type_inl: [ [ "!"; me = module_type -> (me, { ann_inline = NoInline; ann_scope_subst = []}) | me = module_type; a = functor_app_annots -> (me,a) ] ] ; (* Module binder *) module_binder: [ [ "("; export = export_token; idl = LIST1 identref; ":"; mty = module_type_inl; ")" -> (export,idl,mty) ] ] ; (* Module expressions *) module_expr: [ [ me = module_expr_atom -> me | me1 = module_expr; me2 = module_expr_atom -> CMapply (loc,me1,me2) ] ] ; module_expr_atom: [ [ qid = qualid -> CMident qid | "("; me = module_expr; ")" -> me ] ] ; with_declaration: [ [ "Definition"; fqid = fullyqualid; ":="; c = Constr.lconstr -> CWith_Definition (fqid,c) | IDENT "Module"; fqid = fullyqualid; ":="; qid = qualid -> CWith_Module (fqid,qid) ] ] ; module_type: [ [ qid = qualid -> CMident qid | "("; mt = module_type; ")" -> mt | mty = module_type; me = module_expr_atom -> CMapply (loc,mty,me) | mty = module_type; "with"; decl = with_declaration -> CMwith (loc,mty,decl) ] ] ; END (* Extensions: implicits, coercions, etc. *) GEXTEND Gram GLOBAL: gallina_ext instance_name; gallina_ext: [ [ (* Transparent and Opaque *) IDENT "Transparent"; l = LIST1 smart_global -> VernacSetOpacity (use_non_locality (),[Conv_oracle.transparent,l]) | IDENT "Opaque"; l = LIST1 smart_global -> VernacSetOpacity (use_non_locality (),[Conv_oracle.Opaque, l]) | IDENT "Strategy"; l = LIST1 [ lev=strategy_level; "["; q=LIST1 smart_global; "]" -> (lev,q)] -> VernacSetOpacity (use_locality (),l) (* Canonical structure *) | IDENT "Canonical"; IDENT "Structure"; qid = global -> VernacCanonical (AN qid) | IDENT "Canonical"; IDENT "Structure"; ntn = by_notation -> VernacCanonical (ByNotation ntn) | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in VernacDefinition ((Global,CanonicalStructure),(dummy_loc,s),d, (fun _ -> Recordops.declare_canonical_structure)) (* Coercions *) | IDENT "Coercion"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in VernacDefinition ((use_locality_exp (),Coercion),(dummy_loc,s),d,Class.add_coercion_hook) | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in VernacDefinition ((enforce_locality_exp true,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacIdentityCoercion (enforce_locality_exp true, f, s, t) | IDENT "Identity"; IDENT "Coercion"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacIdentityCoercion (use_locality_exp (), f, s, t) | IDENT "Coercion"; IDENT "Local"; qid = global; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacCoercion (enforce_locality_exp true, AN qid, s, t) | IDENT "Coercion"; IDENT "Local"; ntn = by_notation; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacCoercion (enforce_locality_exp true, ByNotation ntn, s, t) | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacCoercion (use_locality_exp (), AN qid, s, t) | IDENT "Coercion"; ntn = by_notation; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacCoercion (use_locality_exp (), ByNotation ntn, s, t) | IDENT "Context"; c = binders -> VernacContext c | IDENT "Instance"; namesup = instance_name; ":"; expl = [ "!" -> Glob_term.Implicit | -> Glob_term.Explicit ] ; t = operconstr LEVEL "200"; pri = OPT [ "|"; i = natural -> i ] ; props = [ ":="; "{"; r = record_declaration; "}" -> Some r | ":="; c = lconstr -> Some c | -> None ] -> VernacInstance (false, not (use_section_locality ()), snd namesup, (fst namesup, expl, t), props, pri) | IDENT "Existing"; IDENT "Instance"; id = global -> VernacDeclareInstances (not (use_section_locality ()), [id]) | IDENT "Existing"; IDENT "Instances"; ids = LIST1 global -> VernacDeclareInstances (not (use_section_locality ()), ids) | IDENT "Existing"; IDENT "Class"; is = global -> VernacDeclareClass is (* Arguments *) | IDENT "Arguments"; qid = smart_global; impl = LIST1 [ l = LIST0 [ item = argument_spec -> let id, r, s = item in [`Id (id,r,s,false,false)] | "/" -> [`Slash] | "("; items = LIST1 argument_spec; ")"; sc = OPT scope -> let f x = match sc, x with | None, x -> x | x, None -> Option.map (fun y -> loc, y) x | Some _, Some _ -> error "scope declared twice" in List.map (fun (id,r,s) -> `Id(id,r,f s,false,false)) items | "["; items = LIST1 argument_spec; "]"; sc = OPT scope -> let f x = match sc, x with | None, x -> x | x, None -> Option.map (fun y -> loc, y) x | Some _, Some _ -> error "scope declared twice" in List.map (fun (id,r,s) -> `Id(id,r,f s,true,false)) items | "{"; items = LIST1 argument_spec; "}"; sc = OPT scope -> let f x = match sc, x with | None, x -> x | x, None -> Option.map (fun y -> loc, y) x | Some _, Some _ -> error "scope declared twice" in List.map (fun (id,r,s) -> `Id(id,r,f s,true,true)) items ] -> l ] SEP ","; mods = OPT [ ":"; l = LIST1 arguments_modifier SEP "," -> l ] -> let mods = match mods with None -> [] | Some l -> List.flatten l in let impl = List.map List.flatten impl in let rec aux n (narg, impl) = function | `Id x :: tl -> aux (n+1) (narg, impl@[x]) tl | `Slash :: tl -> aux (n+1) (n, impl) tl | [] -> narg, impl in let nargs, impl = List.split (List.map (aux 0 (-1, [])) impl) in let nargs, rest = List.hd nargs, List.tl nargs in if List.exists ((<>) nargs) rest then error "All arguments lists must have the same length"; let err_incompat x y = error ("Options \""^x^"\" and \""^y^"\" are incompatible") in if nargs > 0 && List.mem `SimplNeverUnfold mods then err_incompat "simpl never" "/"; if List.mem `SimplNeverUnfold mods && List.mem `SimplDontExposeCase mods then err_incompat "simpl never" "simpl nomatch"; VernacArguments (use_section_locality(), qid, impl, nargs, mods) (* moved there so that camlp5 factors it with the previous rule *) | IDENT "Arguments"; IDENT "Scope"; qid = smart_global; "["; scl = LIST0 [ "_" -> None | sc = IDENT -> Some sc ]; "]" -> Flags.if_verbose msg_warning (str "Arguments Scope is deprecated; use Arguments instead"); VernacArgumentsScope (use_section_locality (),qid,scl) (* Implicit *) | IDENT "Implicit"; IDENT "Arguments"; qid = smart_global; pos = LIST0 [ "["; l = LIST0 implicit_name; "]" -> List.map (fun (id,b,f) -> (ExplByName id,b,f)) l ] -> Flags.if_verbose msg_warning (str "Implicit Arguments is deprecated; use Arguments instead"); VernacDeclareImplicits (use_section_locality (),qid,pos) | IDENT "Implicit"; "Type"; bl = reserv_list -> VernacReserve bl | IDENT "Implicit"; IDENT "Types"; bl = reserv_list -> test_plurial_form_types bl; VernacReserve bl | IDENT "Generalizable"; gen = [IDENT "All"; IDENT "Variables" -> Some [] | IDENT "No"; IDENT "Variables" -> None | ["Variable" | IDENT "Variables"]; idl = LIST1 identref -> Some idl ] -> VernacGeneralizable (use_non_locality (), gen) ] ] ; arguments_modifier: [ [ IDENT "simpl"; IDENT "nomatch" -> [`SimplDontExposeCase] | IDENT "simpl"; IDENT "never" -> [`SimplNeverUnfold] | IDENT "default"; IDENT "implicits" -> [`DefaultImplicits] | IDENT "clear"; IDENT "implicits" -> [`ClearImplicits] | IDENT "clear"; IDENT "scopes" -> [`ClearScopes] | IDENT "rename" -> [`Rename] | IDENT "extra"; IDENT "scopes" -> [`ExtraScopes] | IDENT "clear"; IDENT "scopes"; IDENT "and"; IDENT "implicits" -> [`ClearImplicits; `ClearScopes] | IDENT "clear"; IDENT "implicits"; IDENT "and"; IDENT "scopes" -> [`ClearImplicits; `ClearScopes] ] ] ; implicit_name: [ [ "!"; id = ident -> (id, false, true) | id = ident -> (id,false,false) | "["; "!"; id = ident; "]" -> (id,true,true) | "["; id = ident; "]" -> (id,true, false) ] ] ; scope: [ [ "%"; key = IDENT -> key ] ] ; argument_spec: [ [ b = OPT "!"; id = name ; s = OPT scope -> snd id, b <> None, Option.map (fun x -> loc, x) s ] ]; strategy_level: [ [ IDENT "expand" -> Conv_oracle.Expand | IDENT "opaque" -> Conv_oracle.Opaque | n=INT -> Conv_oracle.Level (int_of_string n) | "-"; n=INT -> Conv_oracle.Level (- int_of_string n) | IDENT "transparent" -> Conv_oracle.transparent ] ] ; instance_name: [ [ name = identref; sup = OPT binders -> (let (loc,id) = name in (loc, Name id)), (Option.default [] sup) | -> (loc, Anonymous), [] ] ] ; reserv_list: [ [ bl = LIST1 reserv_tuple -> bl | b = simple_reserv -> [b] ] ] ; reserv_tuple: [ [ "("; a = simple_reserv; ")" -> a ] ] ; simple_reserv: [ [ idl = LIST1 identref; ":"; c = lconstr -> (idl,c) ] ] ; END GEXTEND Gram GLOBAL: command check_command class_rawexpr; command: [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l (* Hack! Should be in grammar_ext, but camlp4 factorize badly *) | IDENT "Declare"; IDENT "Instance"; namesup = instance_name; ":"; expl = [ "!" -> Glob_term.Implicit | -> Glob_term.Explicit ] ; t = operconstr LEVEL "200"; pri = OPT [ "|"; i = natural -> i ] -> VernacInstance (true, not (use_section_locality ()), snd namesup, (fst namesup, expl, t), None, pri) (* System directory *) | IDENT "Pwd" -> VernacChdir None | IDENT "Cd" -> VernacChdir None | IDENT "Cd"; dir = ne_string -> VernacChdir (Some dir) (* Toplevel control *) | IDENT "Drop" -> VernacToplevelControl Drop | IDENT "Quit" -> VernacToplevelControl Quit | IDENT "Load"; verbosely = [ IDENT "Verbose" -> true | -> false ]; s = [ s = ne_string -> s | s = IDENT -> s ] -> VernacLoad (verbosely, s) | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 ne_string -> VernacDeclareMLModule (use_locality (), l) | IDENT "Locate"; l = locatable -> VernacLocate l (* Managing load paths *) | IDENT "Add"; IDENT "LoadPath"; dir = ne_string; alias = as_dirpath -> VernacAddLoadPath (false, dir, alias) | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = ne_string; alias = as_dirpath -> VernacAddLoadPath (true, dir, alias) | IDENT "Remove"; IDENT "LoadPath"; dir = ne_string -> VernacRemoveLoadPath dir (* For compatibility *) | IDENT "AddPath"; dir = ne_string; "as"; alias = as_dirpath -> VernacAddLoadPath (false, dir, alias) | IDENT "AddRecPath"; dir = ne_string; "as"; alias = as_dirpath -> VernacAddLoadPath (true, dir, alias) | IDENT "DelPath"; dir = ne_string -> VernacRemoveLoadPath dir (* Type-Checking (pas dans le refman) *) | "Type"; c = lconstr -> VernacGlobalCheck c (* Printing (careful factorization of entries) *) | IDENT "Print"; p = printable -> VernacPrint p | IDENT "Print"; qid = smart_global -> VernacPrint (PrintName qid) | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> VernacPrint (PrintModuleType qid) | IDENT "Print"; IDENT "Module"; qid = global -> VernacPrint (PrintModule qid) | IDENT "Inspect"; n = natural -> VernacPrint (PrintInspect n) | IDENT "About"; qid = smart_global -> VernacPrint (PrintAbout qid) (* Searching the environment *) | IDENT "Search"; c = constr_pattern; l = in_or_out_modules -> VernacSearch (SearchHead c, l) | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules -> VernacSearch (SearchPattern c, l) | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules -> VernacSearch (SearchRewrite c, l) | IDENT "SearchAbout"; s = searchabout_query; l = searchabout_queries -> let (sl,m) = l in VernacSearch (SearchAbout (s::sl), m) (* compatibility format of SearchAbout, with "[ ... ]" *) | IDENT "SearchAbout"; "["; sl = LIST1 searchabout_query; "]"; l = in_or_out_modules -> VernacSearch (SearchAbout sl, l) | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = ne_string -> VernacAddMLPath (false, dir) | IDENT "Add"; IDENT "Rec"; IDENT "ML"; IDENT "Path"; dir = ne_string -> VernacAddMLPath (true, dir) (* Pour intervenir sur les tables de paramčtres *) | "Set"; table = option_table; v = option_value -> VernacSetOption (use_locality_full(),table,v) | "Set"; table = option_table -> VernacSetOption (use_locality_full(),table,BoolValue true) | IDENT "Unset"; table = option_table -> VernacUnsetOption (use_locality_full(),table) | IDENT "Print"; IDENT "Table"; table = option_table -> VernacPrintOption table | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value -> VernacAddOption ([table;field], v) (* Un value global ci-dessous va ętre caché par un field au dessus! *) (* En fait, on donne priorité aux tables secondaires *) (* Pas de syntaxe pour les tables tertiaires pour cause de conflit *) (* (mais de toutes faįons, pas utilisées) *) | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value -> VernacAddOption ([table], v) | IDENT "Test"; table = option_table; "for"; v = LIST1 option_ref_value -> VernacMemOption (table, v) | IDENT "Test"; table = option_table -> VernacPrintOption table | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value -> VernacRemoveOption ([table;field], v) | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value -> VernacRemoveOption ([table], v) ]] ; check_command: (* TODO: rapprocher Eval et Check *) [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = lconstr -> fun g -> VernacCheckMayEval (Some r, g, c) | IDENT "Compute"; c = lconstr -> fun g -> VernacCheckMayEval (Some Glob_term.CbvVm, g, c) | IDENT "Check"; c = lconstr -> fun g -> VernacCheckMayEval (None, g, c) ] ] ; printable: [ [ IDENT "Term"; qid = smart_global -> PrintName qid | IDENT "All" -> PrintFullContext | IDENT "Section"; s = global -> PrintSectionContext s | IDENT "Grammar"; ent = IDENT -> (* This should be in "syntax" section but is here for factorization*) PrintGrammar ent | IDENT "LoadPath"; dir = OPT dirpath -> PrintLoadPath dir | IDENT "Modules" -> error "Print Modules is obsolete; use Print Libraries instead" | IDENT "Libraries" -> PrintModules | IDENT "ML"; IDENT "Path" -> PrintMLLoadPath | IDENT "ML"; IDENT "Modules" -> PrintMLModules | IDENT "Graph" -> PrintGraph | IDENT "Classes" -> PrintClasses | IDENT "TypeClasses" -> PrintTypeClasses | IDENT "Instances"; qid = smart_global -> PrintInstances qid | IDENT "Ltac"; qid = global -> PrintLtac qid | IDENT "Coercions" -> PrintCoercions | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr -> PrintCoercionPaths (s,t) | IDENT "Canonical"; IDENT "Projections" -> PrintCanonicalConversions | IDENT "Tables" -> PrintTables | IDENT "Options" -> PrintTables (* A Synonymous to Tables *) | IDENT "Hint" -> PrintHintGoal | IDENT "Hint"; qid = smart_global -> PrintHint qid | IDENT "Hint"; "*" -> PrintHintDb | IDENT "HintDb"; s = IDENT -> PrintHintDbName s | "Rewrite"; IDENT "HintDb"; s = IDENT -> PrintRewriteHintDbName s | IDENT "Scopes" -> PrintScopes | IDENT "Scope"; s = IDENT -> PrintScope s | IDENT "Visibility"; s = OPT [x = IDENT -> x ] -> PrintVisibility s | IDENT "Implicit"; qid = smart_global -> PrintImplicit qid | IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses (false, fopt) | IDENT "Sorted"; IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses (true, fopt) | IDENT "Assumptions"; qid = smart_global -> PrintAssumptions (false, qid) | IDENT "Opaque"; IDENT "Dependencies"; qid = smart_global -> PrintAssumptions (true, qid) ] ] ; class_rawexpr: [ [ IDENT "Funclass" -> FunClass | IDENT "Sortclass" -> SortClass | qid = smart_global -> RefClass qid ] ] ; locatable: [ [ qid = smart_global -> LocateTerm qid | IDENT "File"; f = ne_string -> LocateFile f | IDENT "Library"; qid = global -> LocateLibrary qid | IDENT "Module"; qid = global -> LocateModule qid | IDENT "Ltac"; qid = global -> LocateTactic qid ] ] ; option_value: [ [ n = integer -> IntValue (Some n) | s = STRING -> StringValue s ] ] ; option_ref_value: [ [ id = global -> QualidRefValue id | s = STRING -> StringRefValue s ] ] ; option_table: [ [ fl = LIST1 [ x = IDENT -> x ] -> fl ]] ; as_dirpath: [ [ d = OPT [ "as"; d = dirpath -> d ] -> d ] ] ; ne_in_or_out_modules: [ [ IDENT "inside"; l = LIST1 global -> SearchInside l | IDENT "outside"; l = LIST1 global -> SearchOutside l ] ] ; in_or_out_modules: [ [ m = ne_in_or_out_modules -> m | -> SearchOutside [] ] ] ; comment: [ [ c = constr -> CommentConstr c | s = STRING -> CommentString s | n = natural -> CommentInt n ] ] ; positive_search_mark: [ [ "-" -> false | -> true ] ] ; scope: [ [ "%"; key = IDENT -> key ] ] ; searchabout_query: [ [ b = positive_search_mark; s = ne_string; sc = OPT scope -> (b, SearchString (s,sc)) | b = positive_search_mark; p = constr_pattern -> (b, SearchSubPattern p) ] ] ; searchabout_queries: [ [ m = ne_in_or_out_modules -> ([],m) | s = searchabout_query; l = searchabout_queries -> let (sl,m) = l in (s::sl,m) | -> ([],SearchOutside []) ] ] ; END; GEXTEND Gram command: [ [ (* State management *) IDENT "Write"; IDENT "State"; s = IDENT -> VernacWriteState s | IDENT "Write"; IDENT "State"; s = ne_string -> VernacWriteState s | IDENT "Restore"; IDENT "State"; s = IDENT -> VernacRestoreState s | IDENT "Restore"; IDENT "State"; s = ne_string -> VernacRestoreState s (* Resetting *) | IDENT "Reset"; IDENT "Initial" -> VernacResetInitial | IDENT "Reset"; id = identref -> VernacResetName id | IDENT "Back" -> VernacBack 1 | IDENT "Back"; n = natural -> VernacBack n | IDENT "BackTo"; n = natural -> VernacBackTo n | IDENT "Backtrack"; n = natural ; m = natural ; p = natural -> VernacBacktrack (n,m,p) (* Tactic Debugger *) | IDENT "Debug"; IDENT "On" -> VernacSetOption (None,["Ltac";"Debug"], BoolValue true) | IDENT "Debug"; IDENT "Off" -> VernacSetOption (None,["Ltac";"Debug"], BoolValue false) (* registration of a custom reduction *) | IDENT "Declare"; IDENT "Reduction"; s = IDENT; ":="; r = Tactic.red_expr -> VernacDeclareReduction (use_locality(),s,r) ] ]; END ;; (* Grammar extensions *) GEXTEND Gram GLOBAL: syntax; syntax: [ [ IDENT "Open"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> VernacOpenCloseScope (enforce_section_locality local,true,sc) | IDENT "Close"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> VernacOpenCloseScope (enforce_section_locality local,false,sc) | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT -> VernacDelimiters (sc,key) | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl) | IDENT "Infix"; local = obsolete_locality; op = ne_lstring; ":="; p = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; sc = OPT [ ":"; sc = IDENT -> sc ] -> VernacInfix (enforce_module_locality local,(op,modl),p,sc) | IDENT "Notation"; local = obsolete_locality; id = identref; idl = LIST0 ident; ":="; c = constr; b = only_parsing -> VernacSyntacticDefinition (id,(idl,c),enforce_module_locality local,b) | IDENT "Notation"; local = obsolete_locality; s = ne_lstring; ":="; c = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; sc = OPT [ ":"; sc = IDENT -> sc ] -> VernacNotation (enforce_module_locality local,c,(s,modl),sc) | IDENT "Tactic"; IDENT "Notation"; n = tactic_level; pil = LIST1 production_item; ":="; t = Tactic.tactic -> VernacTacticNotation (n,pil,t) | IDENT "Reserved"; IDENT "Infix"; s = ne_lstring; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] -> Metasyntax.check_infix_modifiers l; let (loc,s) = s in VernacSyntaxExtension (use_module_locality(),((loc,"x '"^s^"' y"),l)) | IDENT "Reserved"; IDENT "Notation"; local = obsolete_locality; s = ne_lstring; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] -> VernacSyntaxExtension (enforce_module_locality local,(s,l)) (* "Print" "Grammar" should be here but is in "command" entry in order to factorize with other "Print"-based vernac entries *) ] ] ; only_parsing: [ [ "("; IDENT "only"; IDENT "parsing"; ")" -> Some Flags.Current | "("; IDENT "compat"; s = STRING; ")" -> Some (Coqinit.get_compat_version s) | -> None ] ] ; obsolete_locality: [ [ IDENT "Local" -> true | -> false ] ] ; tactic_level: [ [ "("; "at"; IDENT "level"; n = natural; ")" -> n | -> 0 ] ] ; level: [ [ IDENT "level"; n = natural -> NumLevel n | IDENT "next"; IDENT "level" -> NextLevel ] ] ; syntax_modifier: [ [ "at"; IDENT "level"; n = natural -> SetLevel n | IDENT "left"; IDENT "associativity" -> SetAssoc LeftA | IDENT "right"; IDENT "associativity" -> SetAssoc RightA | IDENT "no"; IDENT "associativity" -> SetAssoc NonA | IDENT "only"; IDENT "parsing" -> SetOnlyParsing Flags.Current | IDENT "compat"; s = STRING -> SetOnlyParsing (Coqinit.get_compat_version s) | IDENT "format"; s = [s = STRING -> (loc,s)] -> SetFormat s | x = IDENT; ","; l = LIST1 [id = IDENT -> id ] SEP ","; "at"; lev = level -> SetItemLevel (x::l,lev) | x = IDENT; "at"; lev = level -> SetItemLevel ([x],lev) | x = IDENT; typ = syntax_extension_type -> SetEntryType (x,typ) ] ] ; syntax_extension_type: [ [ IDENT "ident" -> ETName | IDENT "global" -> ETReference | IDENT "bigint" -> ETBigint | IDENT "binder" -> ETBinder true | IDENT "closed"; IDENT "binder" -> ETBinder false ] ] ; production_item: [ [ s = ne_string -> TacTerm s | nt = IDENT; po = OPT [ "("; p = ident; sep = [ -> "" | ","; sep = STRING -> sep ]; ")" -> (p,sep) ] -> TacNonTerm (loc,nt,po) ] ] ; END coq-8.4pl4/parsing/tactic_printer.mli0000644000175000017500000000167512326224777017024 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* named_context -> proof_tree -> std_ppcmds val pr_rule : rule -> std_ppcmds val pr_tactic : tactic_expr -> std_ppcmds val print_script : ?nochange:bool -> evar_map -> proof_tree -> std_ppcmds val print_treescript : ?nochange:bool -> evar_map -> proof_tree -> std_ppcmds coq-8.4pl4/parsing/prettyp.ml0000644000175000017500000006542412326224777015352 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* * on May-June 2006 for implementation of abstraction of pretty-printing of objects. *) open Pp open Util open Names open Nameops open Term open Termops open Declarations open Inductive open Inductiveops open Sign open Reduction open Environ open Declare open Impargs open Libobject open Printer open Printmod open Libnames open Nametab open Recordops type object_pr = { print_inductive : mutual_inductive -> std_ppcmds; print_constant_with_infos : constant -> std_ppcmds; print_section_variable : variable -> std_ppcmds; print_syntactic_def : kernel_name -> std_ppcmds; print_module : bool -> Names.module_path -> std_ppcmds; print_modtype : module_path -> std_ppcmds; print_named_decl : identifier * constr option * types -> std_ppcmds; print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option; print_context : bool -> int option -> Lib.library_segment -> std_ppcmds; print_typed_value_in_env : Environ.env -> Term.constr * Term.types -> Pp.std_ppcmds; print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Topconstr.constr_expr -> unsafe_judgment -> std_ppcmds; } let gallina_print_module = print_module let gallina_print_modtype = print_modtype (**************) (** Utilities *) let print_closed_sections = ref false let pr_infos_list l = v 0 (prlist_with_sep cut (fun x -> x) l) ++ fnl() let with_line_skip l = if l = [] then mt() else fnl() ++ pr_infos_list l let blankline = mt() (* add a blank sentence in the list of infos *) let add_colon prefix = if ismt prefix then mt () else prefix ++ str ": " let int_or_no n = if n=0 then str "no" else int n (*******************) (** Basic printing *) let print_basename sp = pr_global (ConstRef sp) let print_ref reduce ref = let typ = Global.type_of_global ref in let typ = if reduce then let ctx,ccl = Reductionops.splay_prod_assum (Global.env()) Evd.empty typ in it_mkProd_or_LetIn ccl ctx else typ in hov 0 (pr_global ref ++ str " :" ++ spc () ++ pr_ltype typ) (********************************) (** Printing implicit arguments *) let conjugate_verb_to_be = function [_] -> "is" | _ -> "are" let pr_impl_name imp = pr_id (name_of_implicit imp) let print_impargs_by_name max = function | [] -> [] | impls -> [hov 0 (str (plural (List.length impls) "Argument") ++ spc() ++ prlist_with_sep pr_comma pr_impl_name impls ++ spc() ++ str (conjugate_verb_to_be impls) ++ str" implicit" ++ (if max then strbrk " and maximally inserted" else mt()))] let print_one_impargs_list l = let imps = List.filter is_status_implicit l in let maximps = List.filter Impargs.maximal_insertion_of imps in let nonmaximps = list_subtract imps maximps in print_impargs_by_name false nonmaximps @ print_impargs_by_name true maximps let print_impargs_list prefix l = let l = extract_impargs_data l in List.flatten (List.map (fun (cond,imps) -> match cond with | None -> List.map (fun pp -> add_colon prefix ++ pp) (print_one_impargs_list imps) | Some (n1,n2) -> [v 2 (prlist_with_sep cut (fun x -> x) [(if ismt prefix then str "When" else prefix ++ str ", when") ++ str " applied to " ++ (if n1 = n2 then int_or_no n2 else if n1 = 0 then str "less than " ++ int n2 else int n1 ++ str " to " ++ int_or_no n2) ++ str (plural n2 " argument") ++ str ":"; v 0 (prlist_with_sep cut (fun x -> x) (if List.exists is_status_implicit imps then print_one_impargs_list imps else [str "No implicit arguments"]))])]) l) let print_renames_list prefix l = if l = [] then [] else [add_colon prefix ++ str "Arguments are renamed to " ++ hv 2 (prlist_with_sep pr_comma (fun x -> x) (List.map pr_name l))] let need_expansion impl ref = let typ = Global.type_of_global ref in let ctx = (prod_assum typ) in let nprods = List.length (List.filter (fun (_,b,_) -> b=None) ctx) in impl <> [] & List.length impl >= nprods & let _,lastimpl = list_chop nprods impl in List.filter is_status_implicit lastimpl <> [] let print_impargs ref = let ref = Smartlocate.smart_global ref in let impl = implicits_of_global ref in let has_impl = impl <> [] in (* Need to reduce since implicits are computed with products flattened *) pr_infos_list ([ print_ref (need_expansion (select_impargs_size 0 impl) ref) ref; blankline ] @ (if has_impl then print_impargs_list (mt()) impl else [str "No implicit arguments"])) (*********************) (** Printing Scopes *) let print_argument_scopes prefix = function | [Some sc] -> [add_colon prefix ++ str"Argument scope is [" ++ str sc ++ str"]"] | l when not (List.for_all ((=) None) l) -> [add_colon prefix ++ hov 2 (str"Argument scopes are" ++ spc() ++ str "[" ++ prlist_with_sep spc (function Some sc -> str sc | None -> str "_") l ++ str "]")] | _ -> [] (*****************************) (** Printing simpl behaviour *) let print_simpl_behaviour ref = match Tacred.get_simpl_behaviour ref with | None -> [] | Some (recargs, nargs, flags) -> let never = List.mem `SimplNeverUnfold flags in let nomatch = List.mem `SimplDontExposeCase flags in let pp_nomatch = spc() ++ if nomatch then str "avoiding to expose match constructs" else str"" in let pp_recargs = spc() ++ str "when the " ++ let rec aux = function | [] -> mt() | [x] -> str (ordinal (x+1)) | [x;y] -> str (ordinal (x+1)) ++ str " and " ++ str (ordinal (y+1)) | x::tl -> str (ordinal (x+1)) ++ str ", " ++ aux tl in aux recargs ++ str (plural (List.length recargs) " argument") ++ str (plural (if List.length recargs >= 2 then 1 else 2) " evaluate") ++ str " to a constructor" in let pp_nargs = spc() ++ str "when applied to " ++ int nargs ++ str (plural nargs " argument") in [hov 2 (str "The simpl tactic " ++ match recargs, nargs, never with | _,_, true -> str "never unfolds " ++ pr_global ref | [], 0, _ -> str "always unfolds " ++ pr_global ref | _::_, n, _ when n < 0 -> str "unfolds " ++ pr_global ref ++ pp_recargs ++ pp_nomatch | _::_, n, _ when n > List.fold_left max 0 recargs -> str "unfolds " ++ pr_global ref ++ pp_recargs ++ str " and" ++ pp_nargs ++ pp_nomatch | _::_, _, _ -> str "unfolds " ++ pr_global ref ++ pp_recargs ++ pp_nomatch | [], n, _ when n > 0 -> str "unfolds " ++ pr_global ref ++ pp_nargs ++ pp_nomatch | _ -> str "unfolds " ++ pr_global ref ++ pp_nomatch )] ;; (*********************) (** Printing Opacity *) type opacity = | FullyOpaque | TransparentMaybeOpacified of Conv_oracle.level let opacity env = function | VarRef v when pi2 (Environ.lookup_named v env) <> None -> Some(TransparentMaybeOpacified (Conv_oracle.get_strategy(VarKey v))) | ConstRef cst -> let cb = Environ.lookup_constant cst env in (match cb.const_body with | Undef _ -> None | OpaqueDef _ -> Some FullyOpaque | Def _ -> Some (TransparentMaybeOpacified (Conv_oracle.get_strategy(ConstKey cst)))) | _ -> None let print_opacity ref = match opacity (Global.env()) ref with | None -> [] | Some s -> [pr_global ref ++ str " is " ++ str (match s with | FullyOpaque -> "opaque" | TransparentMaybeOpacified Conv_oracle.Opaque -> "basically transparent but considered opaque for reduction" | TransparentMaybeOpacified lev when lev = Conv_oracle.transparent -> "transparent" | TransparentMaybeOpacified (Conv_oracle.Level n) -> "transparent (with expansion weight "^string_of_int n^")" | TransparentMaybeOpacified Conv_oracle.Expand -> "transparent (with minimal expansion weight)")] (*******************) (* *) let print_name_infos ref = let impls = implicits_of_global ref in let scopes = Notation.find_arguments_scope ref in let renames = try List.hd (Arguments_renaming.arguments_names ref) with Not_found -> [] in let type_info_for_implicit = if need_expansion (select_impargs_size 0 impls) ref then (* Need to reduce since implicits are computed with products flattened *) [str "Expanded type for implicit arguments"; print_ref true ref; blankline] else [] in type_info_for_implicit @ print_renames_list (mt()) renames @ print_impargs_list (mt()) impls @ print_argument_scopes (mt()) scopes let print_id_args_data test pr id l = if List.exists test l then pr (str "For " ++ pr_id id) l else [] let print_args_data_of_inductive_ids get test pr sp mipv = List.flatten (Array.to_list (Array.mapi (fun i mip -> print_id_args_data test pr mip.mind_typename (get (IndRef (sp,i))) @ List.flatten (Array.to_list (Array.mapi (fun j idc -> print_id_args_data test pr idc (get (ConstructRef ((sp,i),j+1)))) mip.mind_consnames))) mipv)) let print_inductive_implicit_args = print_args_data_of_inductive_ids implicits_of_global (fun l -> positions_of_implicits l <> []) print_impargs_list let print_inductive_renames = print_args_data_of_inductive_ids (fun r -> try List.hd (Arguments_renaming.arguments_names r) with e when Errors.noncritical e -> []) ((<>) Anonymous) print_renames_list let print_inductive_argument_scopes = print_args_data_of_inductive_ids Notation.find_arguments_scope ((<>) None) print_argument_scopes (*********************) (* "Locate" commands *) type logical_name = | Term of global_reference | Dir of global_dir_reference | Syntactic of kernel_name | ModuleType of qualid * module_path | Undefined of qualid let locate_any_name ref = let module N = Nametab in let (loc,qid) = qualid_of_reference ref in try Term (N.locate qid) with Not_found -> try Syntactic (N.locate_syndef qid) with Not_found -> try Dir (N.locate_dir qid) with Not_found -> try ModuleType (qid, N.locate_modtype qid) with Not_found -> Undefined qid let pr_located_qualid = function | Term ref -> let ref_str = match ref with ConstRef _ -> "Constant" | IndRef _ -> "Inductive" | ConstructRef _ -> "Constructor" | VarRef _ -> "Variable" in str ref_str ++ spc () ++ pr_path (Nametab.path_of_global ref) | Syntactic kn -> str "Notation" ++ spc () ++ pr_path (Nametab.path_of_syndef kn) | Dir dir -> let s,dir = match dir with | DirOpenModule (dir,_) -> "Open Module", dir | DirOpenModtype (dir,_) -> "Open Module Type", dir | DirOpenSection (dir,_) -> "Open Section", dir | DirModule (dir,_) -> "Module", dir | DirClosedSection dir -> "Closed Section", dir in str s ++ spc () ++ pr_dirpath dir | ModuleType (qid,_) -> str "Module Type" ++ spc () ++ pr_path (Nametab.full_name_modtype qid) | Undefined qid -> pr_qualid qid ++ spc () ++ str "not a defined object." let print_located_qualid ref = let (loc,qid) = qualid_of_reference ref in let module N = Nametab in let expand = function | TrueGlobal ref -> Term ref, N.shortest_qualid_of_global Idset.empty ref | SynDef kn -> Syntactic kn, N.shortest_qualid_of_syndef Idset.empty kn in match List.map expand (N.locate_extended_all qid) with | [] -> let (dir,id) = repr_qualid qid in if dir = empty_dirpath then str "No object of basename " ++ pr_id id else str "No object of suffix " ++ pr_qualid qid | l -> prlist_with_sep fnl (fun (o,oqid) -> hov 2 (pr_located_qualid o ++ (if oqid <> qid then spc() ++ str "(shorter name to refer to it in current context is " ++ pr_qualid oqid ++ str")" else mt ()))) l (******************************************) (**** Printing declarations and judgments *) (**** Gallina layer *****) let gallina_print_typed_value_in_env env (trm,typ) = (pr_lconstr_env env trm ++ fnl () ++ str " : " ++ pr_ltype_env env typ ++ fnl ()) (* To be improved; the type should be used to provide the types in the abstractions. This should be done recursively inside pr_lconstr, so that the pretty-print of a proposition (P:(nat->nat)->Prop)(P [u]u) synthesizes the type nat of the abstraction on u *) let print_named_def name body typ = let pbody = pr_lconstr body in let ptyp = pr_ltype typ in let pbody = if isCast body then surround pbody else pbody in (str "*** [" ++ str name ++ str " " ++ hov 0 (str ":=" ++ brk (1,2) ++ pbody ++ spc () ++ str ":" ++ brk (1,2) ++ ptyp) ++ str "]") let print_named_assum name typ = str "*** [" ++ str name ++ str " : " ++ pr_ltype typ ++ str "]" let gallina_print_named_decl (id,c,typ) = let s = string_of_id id in match c with | Some body -> print_named_def s body typ | None -> print_named_assum s typ let assumptions_for_print lna = List.fold_right (fun na env -> add_name na env) lna empty_names_context (*********************) (* *) let gallina_print_inductive sp = let env = Global.env() in let mib = Environ.lookup_mind sp env in let mipv = mib.mind_packets in pr_mutual_inductive_body env sp mib ++ fnl () ++ with_line_skip (print_inductive_renames sp mipv @ print_inductive_implicit_args sp mipv @ print_inductive_argument_scopes sp mipv) let print_named_decl id = gallina_print_named_decl (Global.lookup_named id) ++ fnl () let gallina_print_section_variable id = print_named_decl id ++ with_line_skip (print_name_infos (VarRef id)) let print_body = function | Some lc -> pr_lconstr (Declarations.force lc) | None -> (str"") let print_typed_body (val_0,typ) = (print_body val_0 ++ fnl () ++ str " : " ++ pr_ltype typ) let ungeneralized_type_of_constant_type = function | PolymorphicArity (ctx,a) -> mkArity (ctx, Type a.poly_level) | NonPolymorphicType t -> t let print_constant with_values sep sp = let cb = Global.lookup_constant sp in let val_0 = body_of_constant cb in let typ = ungeneralized_type_of_constant_type cb.const_type in hov 0 ( match val_0 with | None -> str"*** [ " ++ print_basename sp ++ str " : " ++ cut () ++ pr_ltype typ ++ str" ]" | _ -> print_basename sp ++ str sep ++ cut () ++ (if with_values then print_typed_body (val_0,typ) else pr_ltype typ)) ++ fnl () let gallina_print_constant_with_infos sp = print_constant true " = " sp ++ with_line_skip (print_name_infos (ConstRef sp)) let gallina_print_syntactic_def kn = let qid = Nametab.shortest_qualid_of_syndef Idset.empty kn and (vars,a) = Syntax_def.search_syntactic_definition kn in let c = Topconstr.glob_constr_of_aconstr dummy_loc a in hov 2 (hov 4 (str "Notation " ++ pr_qualid qid ++ prlist (fun id -> spc () ++ pr_id id) (List.map fst vars) ++ spc () ++ str ":=") ++ spc () ++ Constrextern.without_symbols pr_glob_constr c) ++ fnl () let gallina_print_leaf_entry with_values ((sp,kn as oname),lobj) = let sep = if with_values then " = " else " : " and tag = object_tag lobj in match (oname,tag) with | (_,"VARIABLE") -> (* Outside sections, VARIABLES still exist but only with universes constraints *) (try Some(print_named_decl (basename sp)) with Not_found -> None) | (_,"CONSTANT") -> Some (print_constant with_values sep (constant_of_kn kn)) | (_,"INDUCTIVE") -> Some (gallina_print_inductive (mind_of_kn kn)) | (_,"MODULE") -> let (mp,_,l) = repr_kn kn in Some (print_module with_values (MPdot (mp,l))) | (_,"MODULE TYPE") -> let (mp,_,l) = repr_kn kn in Some (print_modtype (MPdot (mp,l))) | (_,("AUTOHINT"|"GRAMMAR"|"SYNTAXCONSTANT"|"PPSYNTAX"|"TOKEN"|"CLASS"| "COERCION"|"REQUIRE"|"END-SECTION"|"STRUCTURE")) -> None (* To deal with forgotten cases... *) | (_,s) -> None let gallina_print_library_entry with_values ent = let pr_name (sp,_) = pr_id (basename sp) in match ent with | (oname,Lib.Leaf lobj) -> gallina_print_leaf_entry with_values (oname,lobj) | (oname,Lib.OpenedSection (dir,_)) -> Some (str " >>>>>>> Section " ++ pr_name oname) | (oname,Lib.ClosedSection _) -> Some (str " >>>>>>> Closed Section " ++ pr_name oname) | (_,Lib.CompilingLibrary (dir,_)) -> Some (str " >>>>>>> Library " ++ pr_dirpath dir) | (oname,Lib.OpenedModule _) -> Some (str " >>>>>>> Module " ++ pr_name oname) | (oname,Lib.ClosedModule _) -> Some (str " >>>>>>> Closed Module " ++ pr_name oname) | (_,Lib.FrozenState _) -> None let gallina_print_context with_values = let rec prec n = function | h::rest when n = None or Option.get n > 0 -> (match gallina_print_library_entry with_values h with | None -> prec n rest | Some pp -> prec (Option.map ((+) (-1)) n) rest ++ pp ++ fnl ()) | _ -> mt () in prec let gallina_print_eval red_fun env evmap _ {uj_val=trm;uj_type=typ} = let ntrm = red_fun env evmap trm in (str " = " ++ gallina_print_typed_value_in_env env (ntrm,typ)) (******************************************) (**** Printing abstraction layer *) let default_object_pr = { print_inductive = gallina_print_inductive; print_constant_with_infos = gallina_print_constant_with_infos; print_section_variable = gallina_print_section_variable; print_syntactic_def = gallina_print_syntactic_def; print_module = gallina_print_module; print_modtype = gallina_print_modtype; print_named_decl = gallina_print_named_decl; print_library_entry = gallina_print_library_entry; print_context = gallina_print_context; print_typed_value_in_env = gallina_print_typed_value_in_env; print_eval = gallina_print_eval; } let object_pr = ref default_object_pr let set_object_pr = (:=) object_pr let print_inductive x = !object_pr.print_inductive x let print_constant_with_infos c = !object_pr.print_constant_with_infos c let print_section_variable c = !object_pr.print_section_variable c let print_syntactic_def x = !object_pr.print_syntactic_def x let print_module x = !object_pr.print_module x let print_modtype x = !object_pr.print_modtype x let print_named_decl x = !object_pr.print_named_decl x let print_library_entry x = !object_pr.print_library_entry x let print_context x = !object_pr.print_context x let print_typed_value_in_env x = !object_pr.print_typed_value_in_env x let print_eval x = !object_pr.print_eval x (******************************************) (**** Printing declarations and judgments *) (**** Abstract layer *****) let print_typed_value x = print_typed_value_in_env (Global.env ()) x let print_judgment env {uj_val=trm;uj_type=typ} = print_typed_value_in_env env (trm, typ) let print_safe_judgment env j = let trm = Safe_typing.j_val j in let typ = Safe_typing.j_type j in print_typed_value_in_env env (trm, typ) (*********************) (* *) let print_full_context () = print_context true None (Lib.contents_after None) let print_full_context_typ () = print_context false None (Lib.contents_after None) let print_full_pure_context () = let rec prec = function | ((_,kn),Lib.Leaf lobj)::rest -> let pp = match object_tag lobj with | "CONSTANT" -> let con = Global.constant_of_delta_kn kn in let cb = Global.lookup_constant con in let typ = ungeneralized_type_of_constant_type cb.const_type in hov 0 ( match cb.const_body with | Undef _ -> str "Parameter " ++ print_basename con ++ str " : " ++ cut () ++ pr_ltype typ | OpaqueDef lc -> str "Theorem " ++ print_basename con ++ cut () ++ str " : " ++ pr_ltype typ ++ str "." ++ fnl () ++ str "Proof " ++ pr_lconstr (Declarations.force_opaque lc) | Def c -> str "Definition " ++ print_basename con ++ cut () ++ str " : " ++ pr_ltype typ ++ cut () ++ str " := " ++ pr_lconstr (Declarations.force c)) ++ str "." ++ fnl () ++ fnl () | "INDUCTIVE" -> let mind = Global.mind_of_delta_kn kn in let mib = Global.lookup_mind mind in pr_mutual_inductive_body (Global.env()) mind mib ++ str "." ++ fnl () ++ fnl () | "MODULE" -> (* TODO: make it reparsable *) let (mp,_,l) = repr_kn kn in print_module true (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () | "MODULE TYPE" -> (* TODO: make it reparsable *) (* TODO: make it reparsable *) let (mp,_,l) = repr_kn kn in print_modtype (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () | _ -> mt () in prec rest ++ pp | _::rest -> prec rest | _ -> mt () in prec (Lib.contents_after None) (* For printing an inductive definition with its constructors and elimination, assume that the declaration of constructors and eliminations follows the definition of the inductive type *) (* This is designed to print the contents of an opened section *) let read_sec_context r = let loc,qid = qualid_of_reference r in let dir = try Nametab.locate_section qid with Not_found -> user_err_loc (loc,"read_sec_context", str "Unknown section.") in let rec get_cxt in_cxt = function | (_,Lib.OpenedSection ((dir',_),_) as hd)::rest -> if dir = dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest | (_,Lib.ClosedSection _)::rest -> error "Cannot print the contents of a closed section." (* LEM: Actually, we could if we wanted to. *) | [] -> [] | hd::rest -> get_cxt (hd::in_cxt) rest in let cxt = (Lib.contents_after None) in List.rev (get_cxt [] cxt) let print_sec_context sec = print_context true None (read_sec_context sec) let print_sec_context_typ sec = print_context false None (read_sec_context sec) let print_any_name = function | Term (ConstRef sp) -> print_constant_with_infos sp | Term (IndRef (sp,_)) -> print_inductive sp | Term (ConstructRef ((sp,_),_)) -> print_inductive sp | Term (VarRef sp) -> print_section_variable sp | Syntactic kn -> print_syntactic_def kn | Dir (DirModule(dirpath,(mp,_))) -> print_module (printable_body dirpath) mp | Dir _ -> mt () | ModuleType (_,kn) -> print_modtype kn | Undefined qid -> try (* Var locale de but, pas var de section... donc pas d'implicits *) let dir,str = repr_qualid qid in if (repr_dirpath dir) <> [] then raise Not_found; let (_,c,typ) = Global.lookup_named str in (print_named_decl (str,c,typ)) with Not_found -> errorlabstrm "print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") let print_name = function | Genarg.ByNotation (loc,ntn,sc) -> print_any_name (Term (Notation.interp_notation_as_global_reference loc (fun _ -> true) ntn sc)) | Genarg.AN ref -> print_any_name (locate_any_name ref) let print_opaque_name qid = let env = Global.env () in match global qid with | ConstRef cst -> let cb = Global.lookup_constant cst in if constant_has_body cb then print_constant_with_infos cst else error "Not a defined constant." | IndRef (sp,_) -> print_inductive sp | ConstructRef cstr -> let ty = Inductiveops.type_of_constructor env cstr in print_typed_value (mkConstruct cstr, ty) | VarRef id -> let (_,c,ty) = lookup_named id env in print_named_decl (id,c,ty) let print_about_any loc k = match k with | Term ref -> Dumpglob.add_glob loc ref; pr_infos_list (print_ref false ref :: blankline :: print_name_infos ref @ print_simpl_behaviour ref @ print_opacity ref @ [hov 0 (str "Expands to: " ++ pr_located_qualid k)]) | Syntactic kn -> let () = match Syntax_def.search_syntactic_definition kn with | [],Topconstr.ARef ref -> Dumpglob.add_glob loc ref | _ -> () in v 0 ( print_syntactic_def kn ++ hov 0 (str "Expands to: " ++ pr_located_qualid k)) ++ fnl() | Dir _ | ModuleType _ | Undefined _ -> hov 0 (pr_located_qualid k) ++ fnl() let print_about = function | Genarg.ByNotation (loc,ntn,sc) -> print_about_any loc (Term (Notation.interp_notation_as_global_reference loc (fun _ -> true) ntn sc)) | Genarg.AN ref -> print_about_any (loc_of_reference ref) (locate_any_name ref) (* for debug *) let inspect depth = print_context false (Some depth) (Lib.contents_after None) (*************************************************************************) (* Pretty-printing functions coming from classops.ml *) open Classops let print_coercion_value v = pr_lconstr (get_coercion_value v) let print_class i = let cl,_ = class_info_from_index i in pr_class cl let print_path ((i,j),p) = hov 2 ( str"[" ++ hov 0 (prlist_with_sep pr_semicolon print_coercion_value p) ++ str"] : ") ++ print_class i ++ str" >-> " ++ print_class j let _ = Classops.install_path_printer print_path let print_graph () = prlist_with_sep pr_fnl print_path (inheritance_graph()) let print_classes () = prlist_with_sep pr_spc pr_class (classes()) let print_coercions () = prlist_with_sep pr_spc print_coercion_value (coercions()) let index_of_class cl = try fst (class_info cl) with e when Errors.noncritical e -> errorlabstrm "index_of_class" (pr_class cl ++ spc() ++ str "not a defined class.") let print_path_between cls clt = let i = index_of_class cls in let j = index_of_class clt in let p = try lookup_path_between_class (i,j) with e when Errors.noncritical e -> errorlabstrm "index_cl_of_id" (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt ++ str ".") in print_path ((i,j),p) let print_canonical_projections () = prlist_with_sep pr_fnl (fun ((r1,r2),o) -> pr_cs_pattern r2 ++ str " <- " ++ pr_global r1 ++ str " ( " ++ pr_lconstr o.o_DEF ++ str " )") (canonical_projections ()) (*************************************************************************) (*************************************************************************) (* Pretty-printing functions for type classes *) open Typeclasses let pr_typeclass env t = print_ref false t.cl_impl ++ fnl () let print_typeclasses () = let env = Global.env () in prlist_with_sep fnl (pr_typeclass env) (typeclasses ()) let pr_instance env i = (* gallina_print_constant_with_infos i.is_impl *) (* lighter *) print_ref false (instance_impl i) ++ fnl () let print_all_instances () = let env = Global.env () in let inst = all_instances () in prlist_with_sep fnl (pr_instance env) inst let print_instances r = let env = Global.env () in let inst = instances r in prlist_with_sep fnl (pr_instance env) inst coq-8.4pl4/parsing/ppvernac.ml0000644000175000017500000011161112326224777015447 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* dummy_loc then let (b,_) = unloc loc in pr_located pr_id (make_loc (b,b+String.length(string_of_id id)),id) else pr_id id let string_of_fqid fqid = String.concat "." (List.map string_of_id fqid) let pr_fqid fqid = str (string_of_fqid fqid) let pr_lfqid (loc,fqid) = if loc <> dummy_loc then let (b,_) = unloc loc in pr_located pr_fqid (make_loc (b,b+String.length(string_of_fqid fqid)),fqid) else pr_fqid fqid let pr_lname = function (loc,Name id) -> pr_lident (loc,id) | lna -> pr_located pr_name lna let pr_smart_global = pr_or_by_notation pr_reference let pr_ltac_ref = Libnames.pr_reference let pr_module = Libnames.pr_reference let pr_import_module = Libnames.pr_reference let sep_end = function | VernacBullet _ | VernacSubproof None | VernacEndSubproof -> str"" | _ -> str"." (* Warning: [pr_raw_tactic] globalises and fails if globalisation fails *) let pr_raw_tactic_env l env t = pr_glob_tactic env (Tacinterp.glob_tactic_env l env t) let pr_gen env t = pr_raw_generic pr_constr_expr pr_lconstr_expr (pr_raw_tactic_level env) pr_constr_expr pr_reference t let pr_raw_tactic tac = pr_raw_tactic (Global.env()) tac let rec extract_signature = function | [] -> [] | Egrammar.GramNonTerminal (_,t,_,_) :: l -> t :: extract_signature l | _::l -> extract_signature l let rec match_vernac_rule tys = function [] -> raise Not_found | pargs::rls -> if extract_signature pargs = tys then pargs else match_vernac_rule tys rls let sep = fun _ -> spc() let sep_v2 = fun _ -> str"," ++ spc() let pr_ne_sep sep pr = function [] -> mt() | l -> sep() ++ pr l let pr_set_entry_type = function | ETName -> str"ident" | ETReference -> str"global" | ETPattern -> str"pattern" | ETConstr _ -> str"constr" | ETOther (_,e) -> str e | ETBigint -> str "bigint" | ETBinder true -> str "binder" | ETBinder false -> str "closed binder" | ETBinderList _ | ETConstrList _ -> failwith "Internal entry type" let strip_meta id = let s = string_of_id id in if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1)) else id let pr_production_item = function | TacNonTerm (loc,nt,Some (p,sep)) -> let pp_sep = if sep <> "" then str "," ++ quote (str sep) else mt () in str nt ++ str"(" ++ pr_id (strip_meta p) ++ pp_sep ++ str")" | TacNonTerm (loc,nt,None) -> str nt | TacTerm s -> qs s let pr_comment pr_c = function | CommentConstr c -> pr_c c | CommentString s -> qs s | CommentInt n -> int n let pr_in_out_modules = function | SearchInside l -> spc() ++ str"inside" ++ spc() ++ prlist_with_sep sep pr_module l | SearchOutside [] -> mt() | SearchOutside l -> spc() ++ str"outside" ++ spc() ++ prlist_with_sep sep pr_module l let pr_search_about (b,c) = (if b then str "-" else mt()) ++ match c with | SearchSubPattern p -> pr_constr_pattern_expr p | SearchString (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc let pr_search a b pr_p = match a with | SearchHead c -> str"Search" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchPattern c -> str"SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchRewrite c -> str"SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchAbout sl -> str"SearchAbout" ++ spc() ++ str "[" ++ prlist_with_sep spc pr_search_about sl ++ str "]" ++ pr_in_out_modules b let pr_locality_full = function | None -> mt() | Some true -> str"Local " | Some false -> str"Global " let pr_locality local = if local then str "Local " else str "" let pr_non_locality local = if local then str "" else str "Global " let pr_section_locality local = if Lib.sections_are_opened () && not local then str "Global " else if not (Lib.sections_are_opened ()) && local then str "Local " else mt () let pr_explanation (e,b,f) = let a = match e with | ExplByPos (n,_) -> anomaly "No more supported" | ExplByName id -> pr_id id in let a = if f then str"!" ++ a else a in if b then str "[" ++ a ++ str "]" else a let pr_option_ref_value = function | QualidRefValue id -> pr_reference id | StringRefValue s -> qs s let pr_printoption table b = prlist_with_sep spc str table ++ pr_opt (prlist_with_sep sep pr_option_ref_value) b let pr_set_option a b = let pr_opt_value = function | IntValue None -> assert false (* This should not happen because of the grammar *) | IntValue (Some n) -> spc() ++ int n | StringValue s -> spc() ++ str s | BoolValue b -> mt() in pr_printoption a None ++ pr_opt_value b let pr_topcmd _ = str"(* : No printer for toplevel commands *)" let pr_destruct_location = function | Tacexpr.ConclLocation () -> str"Conclusion" | Tacexpr.HypLocation b -> if b then str"Discardable Hypothesis" else str"Hypothesis" let pr_opt_hintbases l = match l with | [] -> mt() | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z let pr_hints local db h pr_c pr_pat = let opth = pr_opt_hintbases db in let pph = match h with | HintsResolve l -> str "Resolve " ++ prlist_with_sep sep (fun (pri, _, c) -> pr_c c ++ match pri with Some x -> spc () ++ str"(" ++ int x ++ str")" | None -> mt ()) l | HintsImmediate l -> str"Immediate" ++ spc() ++ prlist_with_sep sep pr_c l | HintsUnfold l -> str "Unfold " ++ prlist_with_sep sep pr_reference l | HintsTransparency (l, b) -> str (if b then "Transparent " else "Opaque ") ++ prlist_with_sep sep pr_reference l | HintsConstructors c -> str"Constructors" ++ spc() ++ prlist_with_sep spc pr_reference c | HintsExtern (n,c,tac) -> let pat = match c with None -> mt () | Some pat -> pr_pat pat in str "Extern" ++ spc() ++ int n ++ spc() ++ pat ++ str" =>" ++ spc() ++ pr_raw_tactic tac in hov 2 (str"Hint "++pr_locality local ++ pph ++ opth) let pr_with_declaration pr_c = function | CWith_Definition (id,c) -> let p = pr_c c in str"Definition" ++ spc() ++ pr_lfqid id ++ str" := " ++ p | CWith_Module (id,qid) -> str"Module" ++ spc() ++ pr_lfqid id ++ str" := " ++ pr_located pr_qualid qid let rec pr_module_ast pr_c = function | CMident qid -> spc () ++ pr_located pr_qualid qid | CMwith (_,mty,decl) -> let m = pr_module_ast pr_c mty in let p = pr_with_declaration pr_c decl in m ++ spc() ++ str"with" ++ spc() ++ p | CMapply (_,me1,(CMident _ as me2)) -> pr_module_ast pr_c me1 ++ spc() ++ pr_module_ast pr_c me2 | CMapply (_,me1,me2) -> pr_module_ast pr_c me1 ++ spc() ++ hov 1 (str"(" ++ pr_module_ast pr_c me2 ++ str")") let pr_annot { ann_inline = ann; ann_scope_subst = scl } = let sep () = if scl=[] then mt () else str "," in if ann = DefaultInline && scl = [] then mt () else str " [" ++ (match ann with | DefaultInline -> mt () | NoInline -> str "no inline" ++ sep () | InlineAt i -> str "inline at level " ++ int i ++ sep ()) ++ prlist_with_sep (fun () -> str ", ") (fun (sc1,sc2) -> str ("scope "^sc1^" to "^sc2)) scl ++ str "]" let pr_module_ast_inl pr_c (mast,ann) = pr_module_ast pr_c mast ++ pr_annot ann let pr_of_module_type prc = function | Enforce mty -> str ":" ++ pr_module_ast_inl prc mty | Check mtys -> prlist_strict (fun m -> str "<:" ++ pr_module_ast_inl prc m) mtys let pr_require_token = function | Some true -> str "Export " | Some false -> str "Import " | None -> mt() let pr_module_vardecls pr_c (export,idl,(mty,inl)) = let m = pr_module_ast pr_c mty in (* Update the Nametab for interpreting the body of module/modtype *) let lib_dir = Lib.library_dp() in List.iter (fun (_,id) -> Declaremods.process_module_bindings [id] [make_mbid lib_dir id, (Modintern.interp_modtype (Global.env()) mty, inl)]) idl; (* Builds the stream *) spc() ++ hov 1 (str"(" ++ pr_require_token export ++ prlist_with_sep spc pr_lident idl ++ str":" ++ m ++ str")") let pr_module_binders l pr_c = (* Effet de bord complexe pour garantir la declaration des noms des modules parametres dans la Nametab des l'appel de pr_module_binders malgre l'aspect paresseux des streams *) let ml = List.map (pr_module_vardecls pr_c) l in prlist (fun id -> id) ml let pr_module_binders_list l pr_c = pr_module_binders l pr_c let pr_type_option pr_c = function | CHole (loc, k) -> mt() | _ as c -> brk(0,2) ++ str":" ++ pr_c c let pr_decl_notation prc ((loc,ntn),c,scopt) = fnl () ++ str "where " ++ qs ntn ++ str " := " ++ prc c ++ pr_opt (fun sc -> str ": " ++ str sc) scopt let pr_binders_arg = pr_ne_sep spc pr_binders let pr_and_type_binders_arg bl = pr_binders_arg bl let pr_onescheme (idop,schem) = match schem with | InductionScheme (dep,ind,s) -> (match idop with | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() | None -> spc () ) ++ hov 0 ((if dep then str"Induction for" else str"Minimality for") ++ spc() ++ pr_smart_global ind) ++ spc() ++ hov 0 (str"Sort" ++ spc() ++ pr_glob_sort s) | CaseScheme (dep,ind,s) -> (match idop with | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() | None -> spc () ) ++ hov 0 ((if dep then str"Elimination for" else str"Case for") ++ spc() ++ pr_smart_global ind) ++ spc() ++ hov 0 (str"Sort" ++ spc() ++ pr_glob_sort s) | EqualityScheme ind -> (match idop with | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() | None -> spc() ) ++ hov 0 (str"Equality for") ++ spc() ++ pr_smart_global ind let begin_of_inductive = function [] -> 0 | (_,((loc,_),_))::_ -> fst (unloc loc) let pr_class_rawexpr = function | FunClass -> str"Funclass" | SortClass -> str"Sortclass" | RefClass qid -> pr_smart_global qid let pr_assumption_token many = function | (Local,Logical) -> str (if many then "Hypotheses" else "Hypothesis") | (Local,Definitional) -> str (if many then "Variables" else "Variable") | (Global,Logical) -> str (if many then "Axioms" else "Axiom") | (Global,Definitional) -> str (if many then "Parameters" else "Parameter") | (Global,Conjectural) -> str"Conjecture" | (Local,Conjectural) -> anomaly "Don't know how to beautify a local conjecture" let pr_params pr_c (xl,(c,t)) = hov 2 (prlist_with_sep sep pr_lident xl ++ spc() ++ (if c then str":>" else str":" ++ spc() ++ pr_c t)) let rec factorize = function | [] -> [] | (c,(idl,t))::l -> match factorize l with | (xl,t')::l' when t' = (c,t) -> (idl@xl,t')::l' | l' -> (idl,(c,t))::l' let pr_ne_params_list pr_c l = match factorize l with | [p] -> pr_params pr_c p | l -> prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params pr_c p ++ str ")")) l (* prlist_with_sep pr_semicolon (pr_params pr_c) *) let pr_thm_token k = str (string_of_theorem_kind k) let pr_syntax_modifier = function | SetItemLevel (l,NextLevel) -> prlist_with_sep sep_v2 str l ++ spc() ++ str"at next level" | SetItemLevel (l,NumLevel n) -> prlist_with_sep sep_v2 str l ++ spc() ++ str"at level" ++ spc() ++ int n | SetLevel n -> str"at level" ++ spc() ++ int n | SetAssoc LeftA -> str"left associativity" | SetAssoc RightA -> str"right associativity" | SetAssoc NonA -> str"no associativity" | SetEntryType (x,typ) -> str x ++ spc() ++ pr_set_entry_type typ | SetOnlyParsing Flags.Current -> str"only parsing" | SetOnlyParsing v -> str("compat \"" ^ Flags.pr_version v ^ "\"") | SetFormat s -> str"format " ++ pr_located qs s let pr_syntax_modifiers = function | [] -> mt() | l -> spc() ++ hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")") let print_level n = if n <> 0 then str " (at level " ++ int n ++ str ")" else mt () let pr_grammar_tactic_rule n (_,pil,t) = hov 2 (str "Tactic Notation" ++ print_level n ++ spc() ++ hov 0 (prlist_with_sep sep pr_production_item pil ++ spc() ++ str":=" ++ spc() ++ pr_raw_tactic t)) let pr_statement head (id,(bl,c,guard)) = assert (id<>None); hov 1 (head ++ spc() ++ pr_lident (Option.get id) ++ spc() ++ (match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++ pr_opt (pr_guard_annot pr_lconstr_expr bl) guard ++ str":" ++ pr_spc_lconstr c) (**************************************) (* Pretty printer for vernac commands *) (**************************************) let make_pr_vernac pr_constr pr_lconstr = let pr_constrarg c = spc () ++ pr_constr c in let pr_lconstrarg c = spc () ++ pr_lconstr c in let pr_intarg n = spc () ++ int n in let pr_oc = function None -> str" :" | Some true -> str" :>" | Some false -> str" :>>" in let pr_record_field ((x, pri), ntn) = let prx = match x with | (oc,AssumExpr (id,t)) -> hov 1 (pr_lname id ++ pr_oc oc ++ spc() ++ pr_lconstr_expr t) | (oc,DefExpr(id,b,opt)) -> (match opt with | Some t -> hov 1 (pr_lname id ++ pr_oc oc ++ spc() ++ pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b) | None -> hov 1 (pr_lname id ++ str" :=" ++ spc() ++ pr_lconstr b)) in let prpri = match pri with None -> mt() | Some i -> str "| " ++ int i in prx ++ prpri ++ prlist (pr_decl_notation pr_constr) ntn in let pr_record_decl b c fs = pr_opt pr_lident c ++ str"{" ++ hv 0 (prlist_with_sep pr_semicolon pr_record_field fs ++ str"}") in let rec pr_vernac = function (* Proof management *) | VernacAbortAll -> str "Abort All" | VernacRestart -> str"Restart" | VernacUnfocus -> str"Unfocus" | VernacUnfocused -> str"Unfocused" | VernacGoal c -> str"Goal" ++ pr_lconstrarg c | VernacAbort id -> str"Abort" ++ pr_opt pr_lident id | VernacUndo i -> if i=1 then str"Undo" else str"Undo" ++ pr_intarg i | VernacUndoTo i -> str"Undo" ++ spc() ++ str"To" ++ pr_intarg i | VernacBacktrack (i,j,k) -> str "Backtrack" ++ spc() ++ prlist_with_sep sep int [i;j;k] | VernacFocus i -> str"Focus" ++ pr_opt int i | VernacShow s -> let pr_goal_reference = function | OpenSubgoals -> mt () | NthGoal n -> spc () ++ int n | GoalId n -> spc () ++ str n in let pr_showable = function | ShowGoal n -> str"Show" ++ pr_goal_reference n | ShowGoalImplicitly n -> str"Show Implicit Arguments" ++ pr_opt int n | ShowProof -> str"Show Proof" | ShowNode -> str"Show Node" | ShowScript -> str"Show Script" | ShowExistentials -> str"Show Existentials" | ShowTree -> str"Show Tree" | ShowProofNames -> str"Show Conjectures" | ShowIntros b -> str"Show " ++ (if b then str"Intros" else str"Intro") | ShowMatch id -> str"Show Match " ++ pr_lident id | ShowThesis -> str "Show Thesis" in pr_showable s | VernacCheckGuard -> str"Guarded" (* Resetting *) | VernacResetName id -> str"Reset" ++ spc() ++ pr_lident id | VernacResetInitial -> str"Reset Initial" | VernacBack i -> if i=1 then str"Back" else str"Back" ++ pr_intarg i | VernacBackTo i -> str"BackTo" ++ pr_intarg i (* State management *) | VernacWriteState s -> str"Write State" ++ spc () ++ qs s | VernacRestoreState s -> str"Restore State" ++ spc() ++ qs s (* Control *) | VernacList l -> hov 2 (str"[" ++ spc() ++ prlist (fun v -> pr_located pr_vernac v ++ sep_end (snd v) ++ fnl()) l ++ spc() ++ str"]") | VernacLoad (f,s) -> str"Load" ++ if f then (spc() ++ str"Verbose" ++ spc()) else spc() ++ qs s | VernacTime v -> str"Time" ++ spc() ++ pr_vernac v | VernacTimeout(n,v) -> str"Timeout " ++ int n ++ spc() ++ pr_vernac v | VernacFail v -> str"Fail" ++ spc() ++ pr_vernac v (* Syntax *) | VernacTacticNotation (n,r,e) -> pr_grammar_tactic_rule n ("",r,e) | VernacOpenCloseScope (local,opening,sc) -> pr_section_locality local ++ str (if opening then "Open " else "Close ") ++ str "Scope" ++ spc() ++ str sc | VernacDelimiters (sc,key) -> str"Delimit Scope" ++ spc () ++ str sc ++ spc() ++ str "with " ++ str key | VernacBindScope (sc,cll) -> str"Bind Scope" ++ spc () ++ str sc ++ spc() ++ str "with " ++ prlist_with_sep spc pr_class_rawexpr cll | VernacArgumentsScope (local,q,scl) -> let pr_opt_scope = function | None -> str"_" | Some sc -> str sc in pr_section_locality local ++ str"Arguments Scope" ++ spc() ++ pr_smart_global q ++ spc() ++ str"[" ++ prlist_with_sep sep pr_opt_scope scl ++ str"]" | VernacInfix (local,((_,s),mv),q,sn) -> (* A Verifier *) hov 0 (hov 0 (pr_locality local ++ str"Infix " ++ qs s ++ str " :=" ++ pr_constrarg q) ++ pr_syntax_modifiers mv ++ (match sn with | None -> mt() | Some sc -> spc() ++ str":" ++ spc() ++ str sc)) | VernacNotation (local,c,((_,s),l),opt) -> let ps = let n = String.length s in if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' then let s' = String.sub s 1 (n-2) in if String.contains s' '\'' then qs s else str s' else qs s in hov 2 (pr_locality local ++ str"Notation" ++ spc() ++ ps ++ str " :=" ++ pr_constrarg c ++ pr_syntax_modifiers l ++ (match opt with | None -> mt() | Some sc -> str" :" ++ spc() ++ str sc)) | VernacSyntaxExtension (local,(s,l)) -> pr_locality local ++ str"Reserved Notation" ++ spc() ++ pr_located qs s ++ pr_syntax_modifiers l (* Gallina *) | VernacDefinition (d,id,b,f) -> (* A verifier... *) let pr_def_token dk = str (string_of_definition_kind dk) in let pr_reduce = function | None -> mt() | Some r -> str"Eval" ++ spc() ++ pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) r ++ str" in" ++ spc() in let pr_def_body = function | DefineBody (bl,red,body,d) -> let ty = match d with | None -> mt() | Some ty -> spc() ++ str":" ++ pr_spc_lconstr ty in (pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr body)) | ProveBody (bl,t) -> (pr_binders_arg bl, str" :" ++ pr_spc_lconstr t, None) in let (binds,typ,c) = pr_def_body b in hov 2 (pr_def_token d ++ spc() ++ pr_lident id ++ binds ++ typ ++ (match c with | None -> mt() | Some cc -> str" :=" ++ spc() ++ cc)) | VernacStartTheoremProof (ki,l,_,_) -> hov 1 (pr_statement (pr_thm_token ki) (List.hd l) ++ prlist (pr_statement (spc () ++ str "with")) (List.tl l)) | VernacEndProof Admitted -> str"Admitted" | VernacEndProof (Proved (opac,o)) -> (match o with | None -> if opac then str"Qed" else str"Defined" | Some (id,th) -> (match th with | None -> (if opac then str"Save" else str"Defined") ++ spc() ++ pr_lident id | Some tok -> str"Save" ++ spc() ++ pr_thm_token tok ++ spc() ++ pr_lident id)) | VernacExactProof c -> hov 2 (str"Proof" ++ pr_lconstrarg c) | VernacAssumption (stre,_,l) -> let n = List.length (List.flatten (List.map fst (List.map snd l))) in hov 2 (pr_assumption_token (n > 1) stre ++ spc() ++ pr_ne_params_list pr_lconstr_expr l) | VernacInductive (f,i,l) -> let pr_constructor (coe,(id,c)) = hov 2 (pr_lident id ++ str" " ++ (if coe then str":>" else str":") ++ pr_spc_lconstr c) in let pr_constructor_list b l = match l with | Constructors [] -> mt() | Constructors l -> pr_com_at (begin_of_inductive l) ++ fnl() ++ str (if List.length l = 1 then " " else " | ") ++ prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l | RecordDecl (c,fs) -> spc() ++ pr_record_decl b c fs in let pr_oneind key (((coe,id),indpar,s,k,lc),ntn) = hov 0 ( str key ++ spc() ++ (if i then str"Infer " else str"") ++ (if coe then str"> " else str"") ++ pr_lident id ++ pr_and_type_binders_arg indpar ++ spc() ++ Option.cata (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) (mt()) s ++ str" :=") ++ pr_constructor_list k lc ++ prlist (pr_decl_notation pr_constr) ntn in let key = let (_,_,_,k,_),_ = List.hd l in match k with Record -> "Record" | Structure -> "Structure" | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive" | Class _ -> "Class" in hov 1 (pr_oneind key (List.hd l)) ++ (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l)) | VernacFixpoint recs -> let pr_onerec = function | ((loc,id),ro,bl,type_,def),ntn -> let annot = pr_guard_annot pr_lconstr_expr bl ro in pr_id id ++ pr_binders_arg bl ++ annot ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_ ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++ prlist (pr_decl_notation pr_constr) ntn in hov 0 (str "Fixpoint" ++ spc() ++ prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onerec recs) | VernacCoFixpoint corecs -> let pr_onecorec (((loc,id),bl,c,def),ntn) = pr_id id ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ spc() ++ pr_lconstr_expr c ++ pr_opt (fun def -> str" :=" ++ brk(1,2) ++ pr_lconstr def) def ++ prlist (pr_decl_notation pr_constr) ntn in hov 0 (str "CoFixpoint" ++ spc() ++ prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onecorec corecs) | VernacScheme l -> hov 2 (str"Scheme" ++ spc() ++ prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onescheme l) | VernacCombinedScheme (id, l) -> hov 2 (str"Combined Scheme" ++ spc() ++ pr_lident id ++ spc() ++ str"from" ++ spc() ++ prlist_with_sep (fun _ -> fnl() ++ str", ") pr_lident l) (* Gallina extensions *) | VernacBeginSection id -> hov 2 (str"Section" ++ spc () ++ pr_lident id) | VernacEndSegment id -> hov 2 (str"End" ++ spc() ++ pr_lident id) | VernacRequire (exp,spe,l) -> hov 2 (str "Require" ++ spc() ++ pr_require_token exp ++ (match spe with | None -> mt() | Some flag -> (if flag then str"Specification" else str"Implementation") ++ spc ()) ++ prlist_with_sep sep pr_module l) | VernacImport (f,l) -> (if f then str"Export" else str"Import") ++ spc() ++ prlist_with_sep sep pr_import_module l | VernacCanonical q -> str"Canonical Structure" ++ spc() ++ pr_smart_global q | VernacCoercion (s,id,c1,c2) -> hov 1 ( str"Coercion" ++ (match s with | Local -> spc() ++ str"Local" ++ spc() | Global -> spc()) ++ pr_smart_global id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2) | VernacIdentityCoercion (s,id,c1,c2) -> hov 1 ( str"Identity Coercion" ++ (match s with | Local -> spc() ++ str"Local" ++ spc() | Global -> spc()) ++ pr_lident id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2) | VernacInstance (abst,glob, sup, (instid, bk, cl), props, pri) -> hov 1 ( pr_non_locality (not glob) ++ (if abst then str"Declare " else mt ()) ++ str"Instance" ++ (match snd instid with Name id -> spc () ++ pr_lident (fst instid, id) ++ spc () | Anonymous -> mt ()) ++ pr_and_type_binders_arg sup ++ str":" ++ spc () ++ pr_constr_expr cl ++ spc () ++ (match props with | Some p -> spc () ++ str":=" ++ spc () ++ pr_constr_expr p | None -> mt())) | VernacContext l -> hov 1 ( str"Context" ++ spc () ++ pr_and_type_binders_arg l) | VernacDeclareInstances (glob, ids) -> hov 1 (pr_non_locality (not glob) ++ str"Existing" ++ spc () ++ str(plural (List.length ids) "Instance") ++ spc () ++ prlist_with_sep spc pr_reference ids) | VernacDeclareClass id -> hov 1 (str"Existing" ++ spc () ++ str"Class" ++ spc () ++ pr_reference id) (* Modules and Module Types *) | VernacDefineModule (export,m,bl,tys,bd) -> let b = pr_module_binders_list bl pr_lconstr in hov 2 (str"Module" ++ spc() ++ pr_require_token export ++ pr_lident m ++ b ++ pr_of_module_type pr_lconstr tys ++ (if bd = [] then mt () else str ":= ") ++ prlist_with_sep (fun () -> str " <+ ") (pr_module_ast_inl pr_lconstr) bd) | VernacDeclareModule (export,id,bl,m1) -> let b = pr_module_binders_list bl pr_lconstr in hov 2 (str"Declare Module" ++ spc() ++ pr_require_token export ++ pr_lident id ++ b ++ pr_module_ast_inl pr_lconstr m1) | VernacDeclareModuleType (id,bl,tyl,m) -> let b = pr_module_binders_list bl pr_lconstr in let pr_mt = pr_module_ast_inl pr_lconstr in hov 2 (str"Module Type " ++ pr_lident id ++ b ++ prlist_strict (fun m -> str " <: " ++ pr_mt m) tyl ++ (if m = [] then mt () else str ":= ") ++ prlist_with_sep (fun () -> str " <+ ") pr_mt m) | VernacInclude (mexprs) -> let pr_m = pr_module_ast_inl pr_lconstr in hov 2 (str"Include " ++ prlist_with_sep (fun () -> str " <+ ") pr_m mexprs) (* Solving *) | VernacSolve (i,tac,deftac) -> (if i = 1 then mt() else int i ++ str ": ") ++ pr_raw_tactic tac ++ (try if deftac then str ".." else mt () with UserError _|Loc.Exc_located _ -> mt()) | VernacSolveExistential (i,c) -> str"Existential " ++ int i ++ pr_lconstrarg c (* Auxiliary file and library management *) | VernacRequireFrom (exp,spe,f) -> hov 2 (str"Require" ++ spc() ++ pr_require_token exp ++ (match spe with | None -> mt() | Some false -> str"Implementation" ++ spc() | Some true -> str"Specification" ++ spc ()) ++ qs f) | VernacAddLoadPath (fl,s,d) -> hov 2 (str"Add" ++ (if fl then str" Rec " else spc()) ++ str"LoadPath" ++ spc() ++ qs s ++ (match d with | None -> mt() | Some dir -> spc() ++ str"as" ++ spc() ++ pr_dirpath dir)) | VernacRemoveLoadPath s -> str"Remove LoadPath" ++ qs s | VernacAddMLPath (fl,s) -> str"Add" ++ (if fl then str" Rec " else spc()) ++ str"ML Path" ++ qs s | VernacDeclareMLModule (local, l) -> pr_locality local ++ hov 2 (str"Declare ML Module" ++ spc() ++ prlist_with_sep sep qs l) | VernacChdir s -> str"Cd" ++ pr_opt qs s (* Commands *) | VernacDeclareTacticDefinition (local,rc,l) -> let pr_tac_body (id, redef, body) = let idl, body = match body with | Tacexpr.TacFun (idl,b) -> idl,b | _ -> [], body in pr_ltac_ref id ++ prlist (function None -> str " _" | Some id -> spc () ++ pr_id id) idl ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) ++ let idl = List.map Option.get (List.filter (fun x -> not (x=None)) idl)in pr_raw_tactic_env (idl @ List.map coerce_reference_to_id (List.map (fun (x, _, _) -> x) (List.filter (fun (_, redef, _) -> not redef) l))) (Global.env()) body in hov 1 (pr_locality local ++ str "Ltac " ++ prlist_with_sep (fun () -> fnl() ++ str"with ") pr_tac_body l) | VernacCreateHintDb (local,dbname,b) -> hov 1 (pr_locality local ++ str "Create HintDb " ++ str dbname ++ (if b then str" discriminated" else mt ())) | VernacRemoveHints (local, dbnames, ids) -> hov 1 (pr_locality local ++ str "Remove Hints " ++ prlist_with_sep spc (fun r -> pr_id (coerce_reference_to_id r)) ids ++ pr_opt_hintbases dbnames) | VernacHints (local,dbnames,h) -> pr_hints local dbnames h pr_constr pr_constr_pattern_expr | VernacSyntacticDefinition (id,(ids,c),local,onlyparsing) -> hov 2 (pr_locality local ++ str"Notation " ++ pr_lident id ++ spc () ++ prlist (fun x -> spc() ++ pr_id x) ids ++ str":=" ++ pr_constrarg c ++ pr_syntax_modifiers (match onlyparsing with None -> [] | Some v -> [SetOnlyParsing v])) | VernacDeclareImplicits (local,q,[]) -> hov 2 (pr_section_locality local ++ str"Implicit Arguments" ++ spc() ++ pr_smart_global q) | VernacDeclareImplicits (local,q,impls) -> hov 1 (pr_section_locality local ++ str"Implicit Arguments " ++ spc() ++ pr_smart_global q ++ spc() ++ prlist_with_sep spc (fun imps -> str"[" ++ prlist_with_sep sep pr_explanation imps ++ str"]") impls) | VernacArguments (local, q, impl, nargs, mods) -> hov 2 (pr_section_locality local ++ str"Arguments" ++ spc() ++ pr_smart_global q ++ let pr_s = function None -> str"" | Some (_,s) -> str "%" ++ str s in let pr_if b x = if b then x else str "" in let pr_br imp max x = match imp, max with | true, false -> str "[" ++ x ++ str "]" | true, true -> str "{" ++ x ++ str "}" | _ -> x in let rec aux n l = match n, l with | 0, l -> spc () ++ str"/" ++ aux ~-1 l | _, [] -> mt() | n, (id,k,s,imp,max) :: tl -> spc() ++ pr_br imp max (pr_if k (str"!") ++ pr_name id ++ pr_s s) ++ aux (n-1) tl in prlist_with_sep (fun () -> str", ") (aux nargs) impl ++ if mods <> [] then str" : " else str"" ++ prlist_with_sep (fun () -> str", " ++ spc()) (function | `SimplDontExposeCase -> str "simpl nomatch" | `SimplNeverUnfold -> str "simpl never" | `DefaultImplicits -> str "default implicits" | `Rename -> str "rename" | `ExtraScopes -> str "extra scopes" | `ClearImplicits -> str "clear implicits" | `ClearScopes -> str "clear scopes") mods) | VernacReserve bl -> let n = List.length (List.flatten (List.map fst bl)) in hov 2 (str"Implicit Type" ++ str (if n > 1 then "s " else " ") ++ pr_ne_params_list pr_lconstr_expr (List.map (fun sb -> false,sb) bl)) | VernacGeneralizable (local, g) -> hov 1 (pr_locality local ++ str"Generalizable Variable" ++ match g with | None -> str "s none" | Some [] -> str "s all" | Some idl -> str (if List.length idl > 1 then "s " else " ") ++ prlist_with_sep spc pr_lident idl) | VernacSetOpacity(b,[k,l]) when k=Conv_oracle.transparent -> hov 1 (str"Transparent" ++ pr_non_locality b ++ spc() ++ prlist_with_sep sep pr_smart_global l) | VernacSetOpacity(b,[Conv_oracle.Opaque,l]) -> hov 1 (str"Opaque" ++ pr_non_locality b ++ spc() ++ prlist_with_sep sep pr_smart_global l) | VernacSetOpacity (local,l) -> let pr_lev = function Conv_oracle.Opaque -> str"opaque" | Conv_oracle.Expand -> str"expand" | l when l = Conv_oracle.transparent -> str"transparent" | Conv_oracle.Level n -> int n in let pr_line (l,q) = hov 2 (pr_lev l ++ spc() ++ str"[" ++ prlist_with_sep sep pr_smart_global q ++ str"]") in hov 1 (pr_non_locality local ++ str"Strategy" ++ spc() ++ hv 0 (prlist_with_sep sep pr_line l)) | VernacUnsetOption (l,na) -> hov 1 (pr_locality_full l ++ str"Unset" ++ spc() ++ pr_printoption na None) | VernacSetOption (l,na,v) -> hov 2 (pr_locality_full l ++ str"Set" ++ spc() ++ pr_set_option na v) | VernacAddOption (na,l) -> hov 2 (str"Add" ++ spc() ++ pr_printoption na (Some l)) | VernacRemoveOption (na,l) -> hov 2 (str"Remove" ++ spc() ++ pr_printoption na (Some l)) | VernacMemOption (na,l) -> hov 2 (str"Test" ++ spc() ++ pr_printoption na (Some l)) | VernacPrintOption na -> hov 2 (str"Test" ++ spc() ++ pr_printoption na None) | VernacCheckMayEval (r,io,c) -> let pr_mayeval r c = match r with | Some r0 -> hov 2 (str"Eval" ++ spc() ++ pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r0 ++ spc() ++ str"in" ++ spc () ++ pr_lconstr c) | None -> hov 2 (str"Check" ++ spc() ++ pr_lconstr c) in (if io = None then mt() else int (Option.get io) ++ str ": ") ++ pr_mayeval r c | VernacGlobalCheck c -> hov 2 (str"Type" ++ pr_constrarg c) | VernacDeclareReduction (b,s,r) -> pr_locality b ++ str "Declare Reduction " ++ str s ++ str " := " ++ pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r | VernacPrint p -> let pr_printable = function | PrintFullContext -> str"Print All" | PrintSectionContext s -> str"Print Section" ++ spc() ++ Libnames.pr_reference s | PrintGrammar ent -> str"Print Grammar" ++ spc() ++ str ent | PrintLoadPath dir -> str"Print LoadPath" ++ pr_opt pr_dirpath dir | PrintModules -> str"Print Modules" | PrintMLLoadPath -> str"Print ML Path" | PrintMLModules -> str"Print ML Modules" | PrintGraph -> str"Print Graph" | PrintClasses -> str"Print Classes" | PrintTypeClasses -> str"Print TypeClasses" | PrintInstances qid -> str"Print Instances" ++ spc () ++ pr_smart_global qid | PrintLtac qid -> str"Print Ltac" ++ spc() ++ pr_ltac_ref qid | PrintCoercions -> str"Print Coercions" | PrintCoercionPaths (s,t) -> str"Print Coercion Paths" ++ spc() ++ pr_class_rawexpr s ++ spc() ++ pr_class_rawexpr t | PrintCanonicalConversions -> str"Print Canonical Structures" | PrintTables -> str"Print Tables" | PrintHintGoal -> str"Print Hint" | PrintHint qid -> str"Print Hint" ++ spc() ++ pr_smart_global qid | PrintHintDb -> str"Print Hint *" | PrintHintDbName s -> str"Print HintDb" ++ spc() ++ str s | PrintRewriteHintDbName s -> str"Print Rewrite HintDb" ++ spc() ++ str s | PrintUniverses (b, fopt) -> Printf.ksprintf str "Print %sUniverses" (if b then "Sorted " else "") ++ pr_opt str fopt | PrintName qid -> str"Print" ++ spc() ++ pr_smart_global qid | PrintModuleType qid -> str"Print Module Type" ++ spc() ++ pr_reference qid | PrintModule qid -> str"Print Module" ++ spc() ++ pr_reference qid | PrintInspect n -> str"Inspect" ++ spc() ++ int n | PrintScopes -> str"Print Scopes" | PrintScope s -> str"Print Scope" ++ spc() ++ str s | PrintVisibility s -> str"Print Visibility" ++ pr_opt str s | PrintAbout qid -> str"About" ++ spc() ++ pr_smart_global qid | PrintImplicit qid -> str"Print Implicit" ++ spc() ++ pr_smart_global qid (* spiwack: command printing all the axioms and section variables used in a term *) | PrintAssumptions (b,qid) -> (if b then str"Print Assumptions" else str"Print Opaque Dependencies") ++ spc() ++ pr_smart_global qid in pr_printable p | VernacSearch (sea,sea_r) -> pr_search sea sea_r pr_constr_pattern_expr | VernacLocate loc -> let pr_locate =function | LocateTerm qid -> pr_smart_global qid | LocateFile f -> str"File" ++ spc() ++ qs f | LocateLibrary qid -> str"Library" ++ spc () ++ pr_module qid | LocateModule qid -> str"Module" ++ spc () ++ pr_module qid | LocateTactic qid -> str"Ltac" ++ spc () ++ pr_ltac_ref qid in str"Locate" ++ spc() ++ pr_locate loc | VernacComments l -> hov 2 (str"Comments" ++ spc() ++ prlist_with_sep sep (pr_comment pr_constr) l) | VernacNop -> mt() (* Toplevel control *) | VernacToplevelControl exn -> pr_topcmd exn (* For extension *) | VernacExtend (s,c) -> pr_extend s c | VernacProof (None, None) -> str "Proof" | VernacProof (None, Some l) -> str "Proof using" ++spc()++ prlist pr_lident l | VernacProof (Some te, None) -> str "Proof with" ++ spc() ++ pr_raw_tactic te | VernacProof (Some te, Some l) -> str "Proof using" ++spc()++ prlist pr_lident l ++ spc() ++ str "with" ++ spc() ++pr_raw_tactic te | VernacProofMode s -> str ("Proof Mode "^s) | VernacBullet b -> begin match b with | Dash -> str"-" | Star -> str"*" | Plus -> str"+" end ++ spc() | VernacSubproof None -> str "{" | VernacSubproof (Some i) -> str "BeginSubproof " ++ pr_int i | VernacEndSubproof -> str "}" and pr_extend s cl = let pr_arg a = try pr_gen (Global.env()) a with Failure _ -> str ("") in try let rls = List.assoc s (Egrammar.get_extend_vernac_grammars()) in let rl = match_vernac_rule (List.map Genarg.genarg_tag cl) rls in let start,rl,cl = match rl with | Egrammar.GramTerminal s :: rl -> str s, rl, cl | Egrammar.GramNonTerminal _ :: rl -> pr_arg (List.hd cl), rl, List.tl cl | [] -> anomaly "Empty entry" in let (pp,_) = List.fold_left (fun (strm,args) pi -> let pp,args = match pi with | Egrammar.GramNonTerminal _ -> (pr_arg (List.hd args), List.tl args) | Egrammar.GramTerminal s -> (str s, args) in (strm ++ spc() ++ pp), args) (start,cl) rl in hov 1 pp with Not_found -> hov 1 (str ("TODO("^s) ++ prlist_with_sep sep pr_arg cl ++ str ")") in pr_vernac let pr_vernac v = make_pr_vernac pr_constr_expr pr_lconstr_expr v ++ sep_end v coq-8.4pl4/parsing/lexer.ml40000644000175000017500000004772212326224777015047 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* None with | Some tt' -> CharMap.add c (insert tt' (i + 1)) (CharMap.remove c tt.branch) | None -> let tt' = {node = None; branch = CharMap.empty} in CharMap.add c (insert tt' (i + 1)) tt.branch in { node = tt.node; branch = br } in insert ttree 0 (* Search a string in a dictionary: raises [Not_found] if the word is not present. *) let ttree_find ttree str = let rec proc_rec tt i = if i == String.length str then tt else proc_rec (CharMap.find str.[i] tt.branch) (i+1) in proc_rec ttree 0 (* Removes a string from a dictionary: returns an equal dictionary if the word not present. *) let ttree_remove ttree str = let rec remove tt i = if i == String.length str then {node = None; branch = tt.branch} else let c = str.[i] in let br = match try Some (CharMap.find c tt.branch) with Not_found -> None with | Some tt' -> CharMap.add c (remove tt' (i + 1)) (CharMap.remove c tt.branch) | None -> tt.branch in { node = tt.node; branch = br } in remove ttree 0 (* Errors occuring while lexing (explained as "Lexer error: ...") *) module Error = struct type t = | Illegal_character | Unterminated_comment | Unterminated_string | Undefined_token | Bad_token of string | UnsupportedUnicode of int exception E of t let to_string x = "Syntax Error: Lexer: " ^ (match x with | Illegal_character -> "Illegal character" | Unterminated_comment -> "Unterminated comment" | Unterminated_string -> "Unterminated string" | Undefined_token -> "Undefined token" | Bad_token tok -> Format.sprintf "Bad token %S" tok | UnsupportedUnicode x -> Printf.sprintf "Unsupported Unicode character (0x%x)" x) let print ppf x = Format.fprintf ppf "%s@." (to_string x) end open Error let err loc str = Loc.raise (make_loc loc) (Error.E str) let bad_token str = raise (Error.E (Bad_token str)) (* Lexer conventions on tokens *) type token_kind = | Utf8Token of (utf8_status * int) | AsciiChar | EmptyStream let error_unsupported_unicode_character n unicode cs = let bp = Stream.count cs in err (bp,bp+n) (UnsupportedUnicode unicode) let error_utf8 cs = let bp = Stream.count cs in Stream.junk cs; (* consume the char to avoid read it and fail again *) err (bp, bp+1) Illegal_character let utf8_char_size cs = function (* Utf8 leading byte *) | '\x00'..'\x7F' -> 1 | '\xC0'..'\xDF' -> 2 | '\xE0'..'\xEF' -> 3 | '\xF0'..'\xF7' -> 4 | _ (* '\x80'..\xBF'|'\xF8'..'\xFF' *) -> error_utf8 cs let njunk n = Util.repeat n Stream.junk let check_utf8_trailing_byte cs c = if Char.code c land 0xC0 <> 0x80 then error_utf8 cs (* Recognize utf8 blocks (of length less than 4 bytes) *) (* but don't certify full utf8 compliance (e.g. no emptyness check) *) let lookup_utf8_tail c cs = let c1 = Char.code c in if c1 land 0x40 = 0 or c1 land 0x38 = 0x38 then error_utf8 cs else let n, unicode = if c1 land 0x20 = 0 then match Stream.npeek 2 cs with | [_;c2] -> check_utf8_trailing_byte cs c2; 2, (c1 land 0x1F) lsl 6 + (Char.code c2 land 0x3F) | _ -> error_utf8 cs else if c1 land 0x10 = 0 then match Stream.npeek 3 cs with | [_;c2;c3] -> check_utf8_trailing_byte cs c2; check_utf8_trailing_byte cs c3; 3, (c1 land 0x0F) lsl 12 + (Char.code c2 land 0x3F) lsl 6 + (Char.code c3 land 0x3F) | _ -> error_utf8 cs else match Stream.npeek 4 cs with | [_;c2;c3;c4] -> check_utf8_trailing_byte cs c2; check_utf8_trailing_byte cs c3; check_utf8_trailing_byte cs c4; 4, (c1 land 0x07) lsl 18 + (Char.code c2 land 0x3F) lsl 12 + (Char.code c3 land 0x3F) lsl 6 + (Char.code c4 land 0x3F) | _ -> error_utf8 cs in try classify_unicode unicode, n with UnsupportedUtf8 -> njunk n cs; error_unsupported_unicode_character n unicode cs let lookup_utf8 cs = match Stream.peek cs with | Some ('\x00'..'\x7F') -> AsciiChar | Some ('\x80'..'\xFF' as c) -> Utf8Token (lookup_utf8_tail c cs) | None -> EmptyStream let unlocated f x = try f x with Loc.Exc_located (_,exc) -> raise exc let check_keyword str = let rec loop_symb = parser | [< ' (' ' | '\n' | '\r' | '\t' | '"') >] -> bad_token str | [< s >] -> match unlocated lookup_utf8 s with | Utf8Token (_,n) -> njunk n s; loop_symb s | AsciiChar -> Stream.junk s; loop_symb s | EmptyStream -> () in loop_symb (Stream.of_string str) let check_keyword_to_add s = try check_keyword s with Error.E (UnsupportedUnicode unicode) -> Flags.if_verbose msg_warning (strbrk (Printf.sprintf "Token '%s' contains unicode character 0x%x which will not be parsable." s unicode)) let check_ident str = let rec loop_id intail = parser | [< ' ('a'..'z' | 'A'..'Z' | '_'); s >] -> loop_id true s | [< ' ('0'..'9' | ''') when intail; s >] -> loop_id true s | [< s >] -> match unlocated lookup_utf8 s with | Utf8Token (UnicodeLetter, n) -> njunk n s; loop_id true s | Utf8Token (UnicodeIdentPart, n) when intail -> njunk n s; loop_id true s | EmptyStream -> () | Utf8Token _ | AsciiChar -> bad_token str in loop_id false (Stream.of_string str) let is_ident str = try let _ = check_ident str in true with Error.E _ -> false (* Keyword and symbol dictionary *) let token_tree = ref empty_ttree let is_keyword s = try match (ttree_find !token_tree s).node with None -> false | Some _ -> true with Not_found -> false let add_keyword str = if not (is_keyword str) then begin check_keyword_to_add str; token_tree := ttree_add !token_tree str end let remove_keyword str = token_tree := ttree_remove !token_tree str (* Freeze and unfreeze the state of the lexer *) type frozen_t = ttree let freeze () = !token_tree let unfreeze tt = token_tree := tt let init () = unfreeze empty_ttree let _ = init() (* The string buffering machinery *) let buff = ref (String.create 80) let store len x = if len >= String.length !buff then buff := !buff ^ String.create (String.length !buff); !buff.[len] <- x; succ len let rec nstore n len cs = if n>0 then nstore (n-1) (store len (Stream.next cs)) cs else len let get_buff len = String.sub !buff 0 len (* The classical lexer: idents, numbers, quoted strings, comments *) let rec ident_tail len = parser | [< ' ('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_' as c); s >] -> ident_tail (store len c) s | [< s >] -> match lookup_utf8 s with | Utf8Token ((UnicodeIdentPart | UnicodeLetter), n) -> ident_tail (nstore n len s) s | _ -> len let rec number len = parser | [< ' ('0'..'9' as c); s >] -> number (store len c) s | [< >] -> len let rec string in_comments bp len = parser | [< ''"'; esc=(parser [<''"' >] -> true | [< >] -> false); s >] -> if esc then string in_comments bp (store len '"') s else len | [< ''('; s >] -> (parser | [< ''*'; s >] -> string (Option.map succ in_comments) bp (store (store len '(') '*') s | [< >] -> string in_comments bp (store len '(') s) s | [< ''*'; s >] -> (parser | [< '')'; s >] -> if in_comments = Some 0 then msg_warning (str "Not interpreting \"*)\" as the end of current non-terminated comment because it occurs in a non-terminated string of the comment."); let in_comments = Option.map pred in_comments in string in_comments bp (store (store len '*') ')') s | [< >] -> string in_comments bp (store len '*') s) s | [< 'c; s >] -> string in_comments bp (store len c) s | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string (* Hook for exporting comment into xml theory files *) let xml_output_comment = ref (fun _ -> ()) let set_xml_output_comment f = xml_output_comment := f (* Utilities for comments in beautify *) let comment_begin = ref None let comm_loc bp = if !comment_begin=None then comment_begin := Some bp let current = Buffer.create 8192 let between_com = ref true type com_state = int option * string * bool let restore_com_state (o,s,b) = comment_begin := o; Buffer.clear current; Buffer.add_string current s; between_com := b let dflt_com = (None,"",true) let com_state () = let s = (!comment_begin, Buffer.contents current, !between_com) in restore_com_state dflt_com; s let real_push_char c = Buffer.add_char current c (* Add a char if it is between two commands, if it is a newline or if the last char is not a space itself. *) let push_char c = if !between_com || List.mem c ['\n';'\r'] || (List.mem c [' ';'\t']&& (Buffer.length current = 0 || not (let s = Buffer.contents current in List.mem s.[String.length s - 1] [' ';'\t';'\n';'\r']))) then real_push_char c let push_string s = Buffer.add_string current s let null_comment s = let rec null i = i<0 || (List.mem s.[i] [' ';'\t';'\n';'\r'] && null (i-1)) in null (String.length s - 1) let comment_stop ep = let current_s = Buffer.contents current in if !Flags.xml_export && Buffer.length current > 0 && (!between_com || not(null_comment current_s)) then !xml_output_comment current_s; (if Flags.do_beautify() && Buffer.length current > 0 && (!between_com || not(null_comment current_s)) then let bp = match !comment_begin with Some bp -> bp | None -> msgerrnl(str"No begin location for comment '"++str current_s ++str"' ending at "++int ep); ep-1 in Pp.comments := ((bp,ep),current_s) :: !Pp.comments); Buffer.clear current; comment_begin := None; between_com := false (* Does not unescape!!! *) let rec comm_string bp = parser | [< ''"' >] -> push_string "\"" | [< ''\\'; _ = (parser [< ' ('"' | '\\' as c) >] -> if c='"' then real_push_char c; real_push_char c | [< >] -> real_push_char '\\'); s >] -> comm_string bp s | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string | [< 'c; s >] -> real_push_char c; comm_string bp s let rec comment bp = parser bp2 | [< ''('; _ = (parser | [< ''*'; s >] -> push_string "(*"; comment bp s | [< >] -> push_string "(" ); s >] -> comment bp s | [< ''*'; _ = parser | [< '')' >] -> push_string "*)"; | [< s >] -> real_push_char '*'; comment bp s >] -> () | [< ''"'; s >] -> if Flags.do_beautify() then (push_string"\"";comm_string bp2 s) else ignore (string (Some 0) bp2 0 s); comment bp s | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_comment | [< 'z; s >] -> real_push_char z; comment bp s (* Parse a special token, using the [token_tree] *) (* Peek as much utf-8 lexemes as possible *) (* and retain the longest valid special token obtained *) let rec progress_further last nj tt cs = try progress_from_byte last nj tt cs (List.nth (Stream.npeek (nj+1) cs) nj) with Failure _ -> last and update_longest_valid_token last nj tt cs = match tt.node with | Some _ as last' -> for i=1 to nj do Stream.junk cs done; progress_further last' 0 tt cs | None -> progress_further last nj tt cs (* nj is the number of char peeked since last valid token *) (* n the number of char in utf8 block *) and progress_utf8 last nj n c tt cs = try let tt = CharMap.find c tt.branch in if n=1 then update_longest_valid_token last (nj+n) tt cs else match Util.list_skipn (nj+1) (Stream.npeek (nj+n) cs) with | l when List.length l = n-1 -> List.iter (check_utf8_trailing_byte cs) l; let tt = List.fold_left (fun tt c -> CharMap.find c tt.branch) tt l in update_longest_valid_token last (nj+n) tt cs | _ -> error_utf8 cs with Not_found -> last and progress_from_byte last nj tt cs c = progress_utf8 last nj (utf8_char_size cs c) c tt cs let find_keyword id s = let tt = ttree_find !token_tree id in match progress_further tt.node 0 tt s with | None -> raise Not_found | Some c -> KEYWORD c (* Must be a special token *) let process_chars bp c cs = let t = progress_from_byte None (-1) !token_tree cs c in let ep = Stream.count cs in match t with | Some t -> (KEYWORD t, (bp, ep)) | None -> let ep' = bp + utf8_char_size cs c in njunk (ep' - ep) cs; err (bp, ep') Undefined_token let token_of_special c s = match c with | '$' -> METAIDENT s | '.' -> FIELD s | _ -> assert false (* Parse what follows a dot / a dollar *) let parse_after_special c bp = parser | [< ' ('a'..'z' | 'A'..'Z' | '_' as d); len = ident_tail (store 0 d) >] -> token_of_special c (get_buff len) | [< s >] -> match lookup_utf8 s with | Utf8Token (UnicodeLetter, n) -> token_of_special c (get_buff (ident_tail (nstore n 0 s) s)) | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars bp c s) (* Parse what follows a question mark *) let parse_after_qmark bp s = match Stream.peek s with | Some ('a'..'z' | 'A'..'Z' | '_') -> LEFTQMARK | None -> KEYWORD "?" | _ -> match lookup_utf8 s with | Utf8Token (UnicodeLetter, _) -> LEFTQMARK | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars bp '?' s) let blank_or_eof cs = match Stream.peek cs with | None -> true | Some (' ' | '\t' | '\n' |'\r') -> true | _ -> false (* Parse a token in a char stream *) let rec next_token = parser bp | [< '' ' | '\t' | '\n' |'\r' as c; s >] -> comm_loc bp; push_char c; next_token s | [< ''$' as c; t = parse_after_special c bp >] ep -> comment_stop bp; (t, (ep, bp)) | [< ''.' as c; t = parse_after_special c bp; s >] ep -> comment_stop bp; (* We enforce that "." should either be part of a larger keyword, for instance ".(", or followed by a blank or eof. *) if t = KEYWORD "." then begin if not (blank_or_eof s) then err (bp,ep+1) Undefined_token; if Flags.do_beautify() then between_com := true; end; (t, (bp,ep)) | [< ''?'; s >] ep -> let t = parse_after_qmark bp s in comment_stop bp; (t, (ep, bp)) | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); len = ident_tail (store 0 c); s >] ep -> let id = get_buff len in comment_stop bp; (try find_keyword id s with Not_found -> IDENT id), (bp, ep) | [< ' ('0'..'9' as c); len = number (store 0 c) >] ep -> comment_stop bp; (INT (get_buff len), (bp, ep)) | [< ''\"'; len = string None bp 0 >] ep -> comment_stop bp; (STRING (get_buff len), (bp, ep)) | [< ' ('(' as c); t = parser | [< ''*'; s >] -> comm_loc bp; push_string "(*"; comment bp s; next_token s | [< t = process_chars bp c >] -> comment_stop bp; t >] -> t | [< s >] -> match lookup_utf8 s with | Utf8Token (UnicodeLetter, n) -> let len = ident_tail (nstore n 0 s) s in let id = get_buff len in let ep = Stream.count s in comment_stop bp; (try find_keyword id s with Not_found -> IDENT id), (bp, ep) | AsciiChar | Utf8Token ((UnicodeSymbol | UnicodeIdentPart), _) -> let t = process_chars bp (Stream.next s) s in comment_stop bp; t | EmptyStream -> comment_stop bp; (EOI, (bp, bp + 1)) (* (* Debug: uncomment this for tracing tokens seen by coq...*) let next_token s = let (t,(bp,ep)) = next_token s in Printf.eprintf "[%s]\n%!" (Tok.to_string t); (t,(bp,ep)) *) (* Location table system for creating tables associating a token count to its location in a char stream (the source) *) let locerr () = invalid_arg "Lexer: location function" let loct_create () = Hashtbl.create 207 let loct_func loct i = try Hashtbl.find loct i with Not_found -> locerr () let loct_add loct i loc = Hashtbl.add loct i loc let current_location_table = ref (loct_create ()) type location_table = (int, loc) Hashtbl.t let location_table () = !current_location_table let restore_location_table t = current_location_table := t let location_function n = loct_func !current_location_table n (** {6 The lexer of Coq} *) (** Note: removing a token. We do nothing because [remove_token] is called only when removing a grammar rule with [Grammar.delete_rule]. The latter command is called only when unfreezing the state of the grammar entries (see GRAMMAR summary, file env/metasyntax.ml). Therefore, instead of removing tokens one by one, we unfreeze the state of the lexer. This restores the behaviour of the lexer. B.B. *) IFDEF CAMLP5 THEN type te = Tok.t (** Names of tokens, for this lexer, used in Grammar error messages *) let token_text = function | ("", t) -> "'" ^ t ^ "'" | ("IDENT", "") -> "identifier" | ("IDENT", t) -> "'" ^ t ^ "'" | ("INT", "") -> "integer" | ("INT", s) -> "'" ^ s ^ "'" | ("STRING", "") -> "string" | ("EOI", "") -> "end of input" | (con, "") -> con | (con, prm) -> con ^ " \"" ^ prm ^ "\"" let func cs = let loct = loct_create () in let ts = Stream.from (fun i -> let (tok, loc) = next_token cs in loct_add loct i (make_loc loc); Some tok) in current_location_table := loct; (ts, loct_func loct) let lexer = { Token.tok_func = func; Token.tok_using = (fun pat -> match Tok.of_pattern pat with | KEYWORD s -> add_keyword s | _ -> ()); Token.tok_removing = (fun _ -> ()); Token.tok_match = Tok.match_pattern; Token.tok_comm = None; Token.tok_text = token_text } ELSE (* official camlp4 for ocaml >= 3.10 *) module M_ = Camlp4.ErrorHandler.Register (Error) module Loc = Loc module Token = struct include Tok (* Cf. tok.ml *) module Loc = Loc module Error = Camlp4.Struct.EmptyError module Filter = struct type token_filter = (Tok.t * Loc.t) Stream.t -> (Tok.t * Loc.t) Stream.t type t = unit let mk _is_kwd = () let keyword_added () kwd _ = add_keyword kwd let keyword_removed () _ = () let filter () x = x let define_filter () _ = () end end let mk () _init_loc(*FIXME*) cs = let loct = loct_create () in let rec self = parser i [< (tok, loc) = next_token; s >] -> let loc = make_loc loc in loct_add loct i loc; [< '(tok, loc); self s >] | [< >] -> [< >] in current_location_table := loct; self cs END (** Terminal symbols interpretation *) let is_ident_not_keyword s = is_ident s && not (is_keyword s) let is_number s = let rec aux i = String.length s = i or match s.[i] with '0'..'9' -> aux (i+1) | _ -> false in aux 0 let strip s = let len = let rec loop i len = if i = String.length s then len else if s.[i] == ' ' then loop (i + 1) len else loop (i + 1) (len + 1) in loop 0 0 in if len == String.length s then s else let s' = String.create len in let rec loop i i' = if i == String.length s then s' else if s.[i] == ' ' then loop (i + 1) i' else begin s'.[i'] <- s.[i]; loop (i + 1) (i' + 1) end in loop 0 0 let terminal s = let s = strip s in if s = "" then Util.error "empty token."; if is_ident_not_keyword s then IDENT s else if is_number s then INT s else KEYWORD s coq-8.4pl4/parsing/tok.mli0000644000175000017500000000202712326224777014577 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string val to_string : t -> string val print : Format.formatter -> t -> unit val match_keyword : string -> t -> bool (** for camlp5 *) val of_pattern : string*string -> t val to_pattern : t -> string*string val match_pattern : string*string -> t -> string coq-8.4pl4/parsing/q_util.mli0000644000175000017500000000232412326224777015277 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* MLast.expr) -> 'a list -> MLast.expr val mlexpr_of_pair : ('a -> MLast.expr) -> ('b -> MLast.expr) -> 'a * 'b -> MLast.expr val mlexpr_of_triple : ('a -> MLast.expr) -> ('b -> MLast.expr) -> ('c -> MLast.expr) -> 'a * 'b * 'c -> MLast.expr val mlexpr_of_quadruple : ('a -> MLast.expr) -> ('b -> MLast.expr) -> ('c -> MLast.expr) -> ('d -> MLast.expr) -> 'a * 'b * 'c * 'd -> MLast.expr val mlexpr_of_bool : bool -> MLast.expr val mlexpr_of_int : int -> MLast.expr val mlexpr_of_string : string -> MLast.expr val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr val mlexpr_of_prod_entry_key : Pcoq.prod_entry_key -> MLast.expr coq-8.4pl4/parsing/extrawit.mli0000644000175000017500000000427212326224777015655 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (raw_tactic_expr,rlevel) abstract_argument_type val globwit_tactic : int -> (glob_tactic_expr,glevel) abstract_argument_type val wit_tactic : int -> (glob_tactic_expr,tlevel) abstract_argument_type val rawwit_tactic0 : (raw_tactic_expr,rlevel) abstract_argument_type val globwit_tactic0 : (glob_tactic_expr,glevel) abstract_argument_type val wit_tactic0 : (glob_tactic_expr,tlevel) abstract_argument_type val rawwit_tactic1 : (raw_tactic_expr,rlevel) abstract_argument_type val globwit_tactic1 : (glob_tactic_expr,glevel) abstract_argument_type val wit_tactic1 : (glob_tactic_expr,tlevel) abstract_argument_type val rawwit_tactic2 : (raw_tactic_expr,rlevel) abstract_argument_type val globwit_tactic2 : (glob_tactic_expr,glevel) abstract_argument_type val wit_tactic2 : (glob_tactic_expr,tlevel) abstract_argument_type val rawwit_tactic3 : (raw_tactic_expr,rlevel) abstract_argument_type val globwit_tactic3 : (glob_tactic_expr,glevel) abstract_argument_type val wit_tactic3 : (glob_tactic_expr,tlevel) abstract_argument_type val rawwit_tactic4 : (raw_tactic_expr,rlevel) abstract_argument_type val globwit_tactic4 : (glob_tactic_expr,glevel) abstract_argument_type val wit_tactic4 : (glob_tactic_expr,tlevel) abstract_argument_type val rawwit_tactic5 : (raw_tactic_expr,rlevel) abstract_argument_type val globwit_tactic5 : (glob_tactic_expr,glevel) abstract_argument_type val wit_tactic5 : (glob_tactic_expr,tlevel) abstract_argument_type val is_tactic_genarg : argument_type -> bool val tactic_genarg_level : string -> int option coq-8.4pl4/parsing/ppvernac.mli0000644000175000017500000000135412326224777015622 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* std_ppcmds coq-8.4pl4/parsing/lexer.mli0000644000175000017500000000233512326224777015123 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val remove_keyword : string -> unit val is_keyword : string -> bool val location_function : int -> loc (** for coqdoc *) type location_table val location_table : unit -> location_table val restore_location_table : location_table -> unit val check_ident : string -> unit val is_ident : string -> bool val check_keyword : string -> unit type frozen_t val freeze : unit -> frozen_t val unfreeze : frozen_t -> unit val init : unit -> unit type com_state val com_state: unit -> com_state val restore_com_state: com_state -> unit val set_xml_output_comment : (string -> unit) -> unit val terminal : string -> Tok.t (** The lexer of Coq: *) include Compat.LexerSig coq-8.4pl4/parsing/pptactic.ml0000644000175000017500000011515412326224777015446 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* std_ppcmds) -> (constr_expr -> std_ppcmds) -> (tolerability -> raw_tactic_expr -> std_ppcmds) -> 'a -> std_ppcmds type 'a glob_extra_genarg_printer = (glob_constr_and_expr -> std_ppcmds) -> (glob_constr_and_expr -> std_ppcmds) -> (tolerability -> glob_tactic_expr -> std_ppcmds) -> 'a -> std_ppcmds type 'a extra_genarg_printer = (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) -> (tolerability -> glob_tactic_expr -> std_ppcmds) -> 'a -> std_ppcmds let genarg_pprule = ref Stringmap.empty let declare_extra_genarg_pprule (rawwit, f) (globwit, g) (wit, h) = let s = match unquote wit with | ExtraArgType s -> s | _ -> error "Can declare a pretty-printing rule only for extra argument types." in let f prc prlc prtac x = f prc prlc prtac (out_gen rawwit x) in let g prc prlc prtac x = g prc prlc prtac (out_gen globwit x) in let h prc prlc prtac x = h prc prlc prtac (out_gen wit x) in genarg_pprule := Stringmap.add s (f,g,h) !genarg_pprule let pr_arg pr x = spc () ++ pr x let pr_or_var pr = function | ArgArg x -> pr x | ArgVar (_,s) -> pr_id s let pr_or_metaid pr = function | AI x -> pr x | _ -> failwith "pr_hyp_location: unexpected quotation meta-variable" let pr_and_short_name pr (c,_) = pr c let pr_or_by_notation f = function | AN v -> f v | ByNotation (_,s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc let pr_located pr (loc,x) = pr x let pr_evaluable_reference = function | EvalVarRef id -> pr_id id | EvalConstRef sp -> pr_global (Libnames.ConstRef sp) let pr_quantified_hypothesis = function | AnonHyp n -> int n | NamedHyp id -> pr_id id let pr_binding prc = function | loc, NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c) | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) let pr_bindings prc prlc = function | ImplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ prlist_with_sep spc prc l | ExplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l | NoBindings -> mt () let pr_bindings_no_with prc prlc = function | ImplicitBindings l -> brk (1,1) ++ prlist_with_sep spc prc l | ExplicitBindings l -> brk (1,1) ++ prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l | NoBindings -> mt () let pr_with_bindings prc prlc (c,bl) = prc c ++ hv 0 (pr_bindings prc prlc bl) let pr_with_constr prc = function | None -> mt () | Some c -> spc () ++ hov 1 (str "with" ++ spc () ++ prc c) let rec pr_message_token prid = function | MsgString s -> qs s | MsgInt n -> int n | MsgIdent id -> prid id let pr_fresh_ids = prlist (fun s -> spc() ++ pr_or_var qs s) let with_evars ev s = if ev then "e" ^ s else s let if_pattern_ident b pr c = (if b then str "?" else mt()) ++ pr c let rec pr_raw_generic prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generic_argument) = match Genarg.genarg_tag x with | BoolArgType -> str (if out_gen rawwit_bool x then "true" else "false") | IntArgType -> int (out_gen rawwit_int x) | IntOrVarArgType -> pr_or_var pr_int (out_gen rawwit_int_or_var x) | StringArgType -> str "\"" ++ str (out_gen rawwit_string x) ++ str "\"" | PreIdentArgType -> str (out_gen rawwit_pre_ident x) | IntroPatternArgType -> pr_intro_pattern (out_gen rawwit_intro_pattern x) | IdentArgType b -> if_pattern_ident b pr_id (out_gen rawwit_ident x) | VarArgType -> pr_located pr_id (out_gen rawwit_var x) | RefArgType -> prref (out_gen rawwit_ref x) | SortArgType -> pr_glob_sort (out_gen rawwit_sort x) | ConstrArgType -> prc (out_gen rawwit_constr x) | ConstrMayEvalArgType -> pr_may_eval prc prlc (pr_or_by_notation prref) prpat (out_gen rawwit_constr_may_eval x) | QuantHypArgType -> pr_quantified_hypothesis (out_gen rawwit_quant_hyp x) | RedExprArgType -> pr_red_expr (prc,prlc,pr_or_by_notation prref,prpat) (out_gen rawwit_red_expr x) | OpenConstrArgType (b1,b2) -> prc (snd (out_gen (rawwit_open_constr_gen (b1,b2)) x)) | ConstrWithBindingsArgType -> pr_with_bindings prc prlc (out_gen rawwit_constr_with_bindings x) | BindingsArgType -> pr_bindings_no_with prc prlc (out_gen rawwit_bindings x) | List0ArgType _ -> hov 0 (pr_sequence (pr_raw_generic prc prlc prtac prpat prref) (fold_list0 (fun a l -> a::l) x [])) | List1ArgType _ -> hov 0 (pr_sequence (pr_raw_generic prc prlc prtac prpat prref) (fold_list1 (fun a l -> a::l) x [])) | OptArgType _ -> hov 0 (fold_opt (pr_raw_generic prc prlc prtac prpat prref) (mt()) x) | PairArgType _ -> hov 0 (fold_pair (fun a b -> pr_sequence (pr_raw_generic prc prlc prtac prpat prref) [a;b]) x) | ExtraArgType s -> try pi1 (Stringmap.find s !genarg_pprule) prc prlc prtac x with Not_found -> str "[no printer for " ++ str s ++ str "]" let rec pr_glob_generic prc prlc prtac prpat x = match Genarg.genarg_tag x with | BoolArgType -> str (if out_gen globwit_bool x then "true" else "false") | IntArgType -> int (out_gen globwit_int x) | IntOrVarArgType -> pr_or_var pr_int (out_gen globwit_int_or_var x) | StringArgType -> str "\"" ++ str (out_gen globwit_string x) ++ str "\"" | PreIdentArgType -> str (out_gen globwit_pre_ident x) | IntroPatternArgType -> pr_intro_pattern (out_gen globwit_intro_pattern x) | IdentArgType b -> if_pattern_ident b pr_id (out_gen globwit_ident x) | VarArgType -> pr_located pr_id (out_gen globwit_var x) | RefArgType -> pr_or_var (pr_located pr_global) (out_gen globwit_ref x) | SortArgType -> pr_glob_sort (out_gen globwit_sort x) | ConstrArgType -> prc (out_gen globwit_constr x) | ConstrMayEvalArgType -> pr_may_eval prc prlc (pr_or_var (pr_and_short_name pr_evaluable_reference)) prpat (out_gen globwit_constr_may_eval x) | QuantHypArgType -> pr_quantified_hypothesis (out_gen globwit_quant_hyp x) | RedExprArgType -> pr_red_expr (prc,prlc,pr_or_var (pr_and_short_name pr_evaluable_reference),prpat) (out_gen globwit_red_expr x) | OpenConstrArgType (b1,b2) -> prc (snd (out_gen (globwit_open_constr_gen (b1,b2)) x)) | ConstrWithBindingsArgType -> pr_with_bindings prc prlc (out_gen globwit_constr_with_bindings x) | BindingsArgType -> pr_bindings_no_with prc prlc (out_gen globwit_bindings x) | List0ArgType _ -> hov 0 (pr_sequence (pr_glob_generic prc prlc prtac prpat) (fold_list0 (fun a l -> a::l) x [])) | List1ArgType _ -> hov 0 (pr_sequence (pr_glob_generic prc prlc prtac prpat) (fold_list1 (fun a l -> a::l) x [])) | OptArgType _ -> hov 0 (fold_opt (pr_glob_generic prc prlc prtac prpat) (mt()) x) | PairArgType _ -> hov 0 (fold_pair (fun a b -> pr_sequence (pr_glob_generic prc prlc prtac prpat) [a;b]) x) | ExtraArgType s -> try pi2 (Stringmap.find s !genarg_pprule) prc prlc prtac x with Not_found -> str "[no printer for " ++ str s ++ str "]" open Closure let rec pr_generic prc prlc prtac prpat x = match Genarg.genarg_tag x with | BoolArgType -> str (if out_gen wit_bool x then "true" else "false") | IntArgType -> int (out_gen wit_int x) | IntOrVarArgType -> pr_or_var pr_int (out_gen wit_int_or_var x) | StringArgType -> str "\"" ++ str (out_gen wit_string x) ++ str "\"" | PreIdentArgType -> str (out_gen wit_pre_ident x) | IntroPatternArgType -> pr_intro_pattern (out_gen wit_intro_pattern x) | IdentArgType b -> if_pattern_ident b pr_id (out_gen wit_ident x) | VarArgType -> pr_id (out_gen wit_var x) | RefArgType -> pr_global (out_gen wit_ref x) | SortArgType -> pr_sort (out_gen wit_sort x) | ConstrArgType -> prc (out_gen wit_constr x) | ConstrMayEvalArgType -> prc (out_gen wit_constr_may_eval x) | QuantHypArgType -> pr_quantified_hypothesis (out_gen wit_quant_hyp x) | RedExprArgType -> pr_red_expr (prc,prlc,pr_evaluable_reference,prpat) (out_gen wit_red_expr x) | OpenConstrArgType (b1,b2) -> prc (snd (out_gen (wit_open_constr_gen (b1,b2)) x)) | ConstrWithBindingsArgType -> let (c,b) = (out_gen wit_constr_with_bindings x).Evd.it in pr_with_bindings prc prlc (c,b) | BindingsArgType -> pr_bindings_no_with prc prlc (out_gen wit_bindings x).Evd.it | List0ArgType _ -> hov 0 (pr_sequence (pr_generic prc prlc prtac prpat) (fold_list0 (fun a l -> a::l) x [])) | List1ArgType _ -> hov 0 (pr_sequence (pr_generic prc prlc prtac prpat) (fold_list1 (fun a l -> a::l) x [])) | OptArgType _ -> hov 0 (fold_opt (pr_generic prc prlc prtac prpat) (mt()) x) | PairArgType _ -> hov 0 (fold_pair (fun a b -> pr_sequence (pr_generic prc prlc prtac prpat) [a;b]) x) | ExtraArgType s -> try pi3 (Stringmap.find s !genarg_pprule) prc prlc prtac x with Not_found -> str "[no printer for " ++ str s ++ str "]" let rec tacarg_using_rule_token pr_gen = function | Some s :: l, al -> str s :: tacarg_using_rule_token pr_gen (l,al) | None :: l, a :: al -> let print_it = match genarg_tag a with | OptArgType _ -> fold_opt (fun _ -> true) false a | _ -> true in let r = tacarg_using_rule_token pr_gen (l,al) in if print_it then pr_gen a :: r else r | [], [] -> [] | _ -> failwith "Inconsistent arguments of extended tactic" let pr_tacarg_using_rule pr_gen l= pr_sequence (fun x -> x) (tacarg_using_rule_token pr_gen l) let pr_extend_gen pr_gen lev s l = try let tags = List.map genarg_tag l in let (lev',pl) = Hashtbl.find prtac_tab (s,tags) in let p = pr_tacarg_using_rule pr_gen (pl,l) in if lev' > lev then surround p else p with Not_found -> str s ++ spc() ++ pr_sequence pr_gen l ++ str" (* Generic printer *)" let pr_raw_extend prc prlc prtac prpat = pr_extend_gen (pr_raw_generic prc prlc prtac prpat pr_reference) let pr_glob_extend prc prlc prtac prpat = pr_extend_gen (pr_glob_generic prc prlc prtac prpat) let pr_extend prc prlc prtac prpat = pr_extend_gen (pr_generic prc prlc prtac prpat) (**********************************************************************) (* The tactic printer *) let strip_prod_binders_expr n ty = let rec strip_ty acc n ty = match ty with Topconstr.CProdN(_,bll,a) -> let nb = List.fold_left (fun i (nal,_,_) -> i + List.length nal) 0 bll in let bll = List.map (fun (x, _, y) -> x, y) bll in if nb >= n then (List.rev (bll@acc)), a else strip_ty (bll@acc) (n-nb) a | Topconstr.CArrow(_,a,b) -> if n=1 then (List.rev (([(dummy_loc,Anonymous)],a)::acc), b) else strip_ty (([(dummy_loc,Anonymous)],a)::acc) (n-1) b | _ -> error "Cannot translate fix tactic: not enough products" in strip_ty [] n ty let pr_ltac_or_var pr = function | ArgArg x -> pr x | ArgVar (loc,id) -> pr_with_comments loc (pr_id id) let pr_ltac_constant sp = pr_qualid (Nametab.shortest_qualid_of_tactic sp) let pr_evaluable_reference_env env = function | EvalVarRef id -> pr_id id | EvalConstRef sp -> Nametab.pr_global_env (Termops.vars_of_env env) (Libnames.ConstRef sp) let pr_esubst prc l = let pr_qhyp = function (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")" | (_,NamedHyp id,c) -> str "(" ++ pr_id id ++ str" := " ++ prc c ++ str ")" in prlist_with_sep spc pr_qhyp l let pr_bindings_gen for_ex prlc prc = function | ImplicitBindings l -> spc () ++ hv 2 ((if for_ex then mt() else str "with" ++ spc ()) ++ prlist_with_sep spc prc l) | ExplicitBindings l -> spc () ++ hv 2 ((if for_ex then mt() else str "with" ++ spc ()) ++ pr_esubst prlc l) | NoBindings -> mt () let pr_bindings prlc prc = pr_bindings_gen false prlc prc let pr_with_bindings prlc prc (c,bl) = hov 1 (prc c ++ pr_bindings prlc prc bl) let pr_as_ipat pat = str "as " ++ pr_intro_pattern pat let pr_eqn_ipat pat = str "eqn:" ++ pr_intro_pattern pat let pr_with_induction_names = function | None, None -> mt () | Some eqpat, None -> spc () ++ hov 1 (pr_eqn_ipat eqpat) | None, Some ipat -> spc () ++ hov 1 (pr_as_ipat ipat) | Some eqpat, Some ipat -> spc () ++ hov 1 (pr_as_ipat ipat ++ spc () ++ pr_eqn_ipat eqpat) let pr_as_intro_pattern ipat = spc () ++ hov 1 (str "as" ++ spc () ++ pr_intro_pattern ipat) let pr_with_inversion_names = function | None -> mt () | Some ipat -> pr_as_intro_pattern ipat let pr_as_ipat = function | None -> mt () | Some ipat -> pr_as_intro_pattern ipat let pr_as_name = function | Anonymous -> mt () | Name id -> str " as " ++ pr_lident (dummy_loc,id) let pr_pose_as_style prc na c = spc() ++ prc c ++ pr_as_name na let pr_pose prlc prc na c = match na with | Anonymous -> spc() ++ prc c | Name id -> spc() ++ surround (pr_id id ++ str " :=" ++ spc() ++ prlc c) let pr_assertion _prlc prc ipat c = match ipat with (* Use this "optimisation" or use only the general case ? | IntroIdentifier id -> spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c) *) | ipat -> spc() ++ prc c ++ pr_as_ipat ipat let pr_assumption prlc prc ipat c = match ipat with (* Use this "optimisation" or use only the general case ? | IntroIdentifier id -> spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c) *) | ipat -> spc() ++ prc c ++ pr_as_ipat ipat let pr_by_tactic prt = function | TacId [] -> mt () | tac -> spc() ++ str "by " ++ prt tac let pr_hyp_location pr_id = function | occs, Termops.InHyp -> spc () ++ pr_with_occurrences pr_id occs | occs, Termops.InHypTypeOnly -> spc () ++ pr_with_occurrences (fun id -> str "(type of " ++ pr_id id ++ str ")") occs | occs, Termops.InHypValueOnly -> spc () ++ pr_with_occurrences (fun id -> str "(value of " ++ pr_id id ++ str ")") occs let pr_in pp = spc () ++ hov 0 (str "in" ++ pp) let pr_simple_hyp_clause pr_id = function | [] -> mt () | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l) let pr_in_hyp_as pr_id = function | None -> mt () | Some (id,ipat) -> pr_simple_hyp_clause pr_id [id] ++ pr_as_ipat ipat let pr_clauses default_is_concl pr_id = function | { onhyps=Some []; concl_occs=occs } when occs = all_occurrences_expr & default_is_concl = Some true -> mt () | { onhyps=None; concl_occs=occs } when occs = all_occurrences_expr & default_is_concl = Some false -> mt () | { onhyps=None; concl_occs=occs } -> if occs = no_occurrences_expr then pr_in (str " * |-") else pr_in (pr_with_occurrences (fun () -> str " *") (occs,())) | { onhyps=Some l; concl_occs=occs } -> pr_in (prlist_with_sep (fun () -> str",") (pr_hyp_location pr_id) l ++ (if occs = no_occurrences_expr then mt () else pr_with_occurrences (fun () -> str" |- *") (occs,()))) let pr_orient b = if b then mt () else str "<- " let pr_multi = function | Precisely 1 -> mt () | Precisely n -> pr_int n ++ str "!" | UpTo n -> pr_int n ++ str "?" | RepeatStar -> str "?" | RepeatPlus -> str "!" let pr_induction_arg prlc prc = function | ElimOnConstr c -> pr_with_bindings prlc prc c | ElimOnIdent (loc,id) -> pr_with_comments loc (pr_id id) | ElimOnAnonHyp n -> int n let pr_induction_kind = function | SimpleInversion -> str "simple inversion" | FullInversion -> str "inversion" | FullInversionClear -> str "inversion_clear" let pr_lazy lz = if lz then str "lazy" else mt () let pr_match_pattern pr_pat = function | Term a -> pr_pat a | Subterm (b,None,a) -> (if b then str"appcontext [" else str "context [") ++ pr_pat a ++ str "]" | Subterm (b,Some id,a) -> (if b then str"appcontext " else str "context ") ++ pr_id id ++ str "[" ++ pr_pat a ++ str "]" let pr_match_hyps pr_pat = function | Hyp (nal,mp) -> pr_lname nal ++ str ":" ++ pr_match_pattern pr_pat mp | Def (nal,mv,mp) -> pr_lname nal ++ str ":=" ++ pr_match_pattern pr_pat mv ++ str ":" ++ pr_match_pattern pr_pat mp let pr_match_rule m pr pr_pat = function | Pat ([],mp,t) when m -> pr_match_pattern pr_pat mp ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t (* | Pat (rl,mp,t) -> hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl ++ (if rl <> [] then spc () else mt ()) ++ hov 0 (str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t)) *) | Pat (rl,mp,t) -> hov 0 ( hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl) ++ (if rl <> [] then spc () else mt ()) ++ hov 0 ( str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t)) | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t let pr_funvar = function | None -> spc () ++ str "_" | Some id -> spc () ++ pr_id id let pr_let_clause k pr (id,(bl,t)) = hov 0 (str k ++ pr_lident id ++ prlist pr_funvar bl ++ str " :=" ++ brk (1,1) ++ pr (TacArg (dummy_loc,t))) let pr_let_clauses recflag pr = function | hd::tl -> hv 0 (pr_let_clause (if recflag then "let rec " else "let ") pr hd ++ prlist (fun t -> spc () ++ pr_let_clause "with " pr t) tl) | [] -> anomaly "LetIn must declare at least one binding" let pr_seq_body pr tl = hv 0 (str "[ " ++ prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++ str " ]") let pr_opt_tactic pr = function | TacId [] -> mt () | t -> pr t let pr_then_gen pr tf tm tl = hv 0 (str "[ " ++ prvect_with_sep mt (fun t -> pr t ++ spc () ++ str "| ") tf ++ pr_opt_tactic pr tm ++ str ".." ++ prvect_with_sep mt (fun t -> spc () ++ str "| " ++ pr t) tl ++ str " ]") let pr_hintbases = function | None -> spc () ++ str "with *" | Some [] -> mt () | Some l -> spc () ++ hov 2 (str "with" ++ prlist (fun s -> spc () ++ str s) l) let pr_auto_using prc = function | [] -> mt () | l -> spc () ++ hov 2 (str "using" ++ spc () ++ prlist_with_sep pr_comma prc l) let string_of_debug = function | Off -> "" | Debug -> "debug " | Info -> "info_" let pr_then () = str ";" let ltop = (5,E) let lseq = 4 let ltactical = 3 let lorelse = 2 let llet = 5 let lfun = 5 let lcomplete = 1 let labstract = 3 let lmatch = 1 let latom = 0 let lcall = 1 let leval = 1 let ltatom = 1 let linfo = 5 let level_of (n,p) = match p with E -> n | L -> n-1 | Prec n -> n | Any -> lseq open Closure (** A printer for tactics that polymorphically works on the three "raw", "glob" and "typed" levels; in practice, the environment is used only at the glob and typed level: it is used to feed the constr printers *) let make_pr_tac (pr_tac_level,pr_constr,pr_lconstr,pr_pat, pr_cst,pr_ind,pr_ref,pr_ident, pr_extend,strip_prod_binders) env = (* The environment is not used by the tactic printer: it is passed to the constr and cst printers; hence we can make some abbreviations *) let pr_constr = pr_constr env in let pr_lconstr = pr_lconstr env in let pr_lpat = pr_pat true in let pr_pat = pr_pat false in let pr_cst = pr_cst env in let pr_ind = pr_ind env in let pr_tac_level = pr_tac_level env in (* Other short cuts *) let pr_bindings = pr_bindings pr_lconstr pr_constr in let pr_ex_bindings = pr_bindings_gen true pr_lconstr pr_constr in let pr_with_bindings = pr_with_bindings pr_lconstr pr_constr in let pr_extend = pr_extend pr_constr pr_lconstr pr_tac_level pr_pat in let pr_red_expr = pr_red_expr (pr_constr,pr_lconstr,pr_cst,pr_pat) in let pr_constrarg c = spc () ++ pr_constr c in let pr_lconstrarg c = spc () ++ pr_lconstr c in let pr_intarg n = spc () ++ int n in (* Some printing combinators *) let pr_eliminator cb = str "using" ++ pr_arg pr_with_bindings cb in let extract_binders = function | Tacexp (TacFun (lvar,body)) -> (lvar,Tacexp body) | body -> ([],body) in let pr_binder_fix (nal,t) = (* match t with | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal | _ ->*) let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr_lconstr t in spc() ++ hov 1 (str"(" ++ s ++ str")") in let pr_fix_tac (id,n,c) = let rec set_nth_name avoid n = function (nal,ty)::bll -> if n <= List.length nal then match list_chop (n-1) nal with _, (_,Name id) :: _ -> id, (nal,ty)::bll | bef, (loc,Anonymous) :: aft -> let id = next_ident_away (id_of_string"y") avoid in id, ((bef@(loc,Name id)::aft, ty)::bll) | _ -> assert false else let (id,bll') = set_nth_name avoid (n-List.length nal) bll in (id,(nal,ty)::bll') | [] -> assert false in let (bll,ty) = strip_prod_binders n c in let names = List.fold_left (fun ln (nal,_) -> List.fold_left (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln) ln nal) [] bll in let idarg,bll = set_nth_name names n bll in let annot = if List.length names = 1 then mt() else spc() ++ str"{struct " ++ pr_id idarg ++ str"}" in hov 1 (str"(" ++ pr_id id ++ prlist pr_binder_fix bll ++ annot ++ str" :" ++ pr_lconstrarg ty ++ str")") in (* spc() ++ hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ pr_constrarg c) *) let pr_cofix_tac (id,c) = hov 1 (str"(" ++ pr_id id ++ str" :" ++ pr_lconstrarg c ++ str")") in (* Printing tactics as arguments *) let rec pr_atom0 = function | TacIntroPattern [] -> str "intros" | TacIntroMove (None,hto) when hto = no_move -> str "intro" | TacAssumption -> str "assumption" | TacAnyConstructor (false,None) -> str "constructor" | TacAnyConstructor (true,None) -> str "econstructor" | TacTrivial (d,[],Some []) -> str (string_of_debug d ^ "trivial") | TacAuto (d,None,[],Some []) -> str (string_of_debug d ^ "auto") | TacReflexivity -> str "reflexivity" | TacClear (true,[]) -> str "clear" | t -> str "(" ++ pr_atom1 t ++ str ")" (* Main tactic printer *) and pr_atom1 = function | TacExtend (loc,s,l) -> pr_with_comments loc (pr_extend 1 s l) | TacAlias (loc,s,l,_) -> pr_with_comments loc (pr_extend 1 s (List.map snd l)) (* Basic tactics *) | TacIntroPattern [] as t -> pr_atom0 t | TacIntroPattern (_::_ as p) -> hov 1 (str "intros" ++ spc () ++ prlist_with_sep spc pr_intro_pattern p) | TacIntrosUntil h -> hv 1 (str "intros until" ++ pr_arg pr_quantified_hypothesis h) | TacIntroMove (None,hto) as t when hto = no_move -> pr_atom0 t | TacIntroMove (Some id,hto) when hto = no_move -> str "intro " ++ pr_id id | TacIntroMove (ido,hto) -> hov 1 (str"intro" ++ pr_opt pr_id ido ++ pr_move_location pr_ident hto) | TacAssumption as t -> pr_atom0 t | TacExact c -> hov 1 (str "exact" ++ pr_constrarg c) | TacExactNoCheck c -> hov 1 (str "exact_no_check" ++ pr_constrarg c) | TacVmCastNoCheck c -> hov 1 (str "vm_cast_no_check" ++ pr_constrarg c) | TacApply (a,ev,cb,inhyp) -> hov 1 ((if a then mt() else str "simple ") ++ str (with_evars ev "apply") ++ spc () ++ prlist_with_sep pr_comma pr_with_bindings cb ++ pr_in_hyp_as pr_ident inhyp) | TacElim (ev,cb,cbo) -> hov 1 (str (with_evars ev "elim") ++ pr_arg pr_with_bindings cb ++ pr_opt pr_eliminator cbo) | TacElimType c -> hov 1 (str "elimtype" ++ pr_constrarg c) | TacCase (ev,cb) -> hov 1 (str (with_evars ev "case") ++ spc () ++ pr_with_bindings cb) | TacCaseType c -> hov 1 (str "casetype" ++ pr_constrarg c) | TacFix (ido,n) -> hov 1 (str "fix" ++ pr_opt pr_id ido ++ pr_intarg n) | TacMutualFix (hidden,id,n,l) -> if hidden then str "idtac" (* should caught before! *) else hov 1 (str "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc() ++ str"with " ++ prlist_with_sep spc pr_fix_tac l) | TacCofix ido -> hov 1 (str "cofix" ++ pr_opt pr_id ido) | TacMutualCofix (hidden,id,l) -> if hidden then str "idtac" (* should be caught before! *) else hov 1 (str "cofix" ++ spc () ++ pr_id id ++ spc() ++ str"with " ++ prlist_with_sep spc pr_cofix_tac l) | TacCut c -> hov 1 (str "cut" ++ pr_constrarg c) | TacAssert (Some tac,ipat,c) -> hov 1 (str "assert" ++ pr_assumption pr_lconstr pr_constr ipat c ++ pr_by_tactic (pr_tac_level ltop) tac) | TacAssert (None,ipat,c) -> hov 1 (str "pose proof" ++ pr_assertion pr_lconstr pr_constr ipat c) | TacGeneralize l -> hov 1 (str "generalize" ++ spc () ++ prlist_with_sep pr_comma (fun (cl,na) -> pr_with_occurrences pr_constr cl ++ pr_as_name na) l) | TacGeneralizeDep c -> hov 1 (str "generalize" ++ spc () ++ str "dependent" ++ pr_constrarg c) | TacLetTac (na,c,cl,true,_) when cl = nowhere -> hov 1 (str "pose" ++ pr_pose pr_lconstr pr_constr na c) | TacLetTac (na,c,cl,b,e) -> hov 1 ((if b then str "set" else str "remember") ++ (if b then pr_pose pr_lconstr else pr_pose_as_style) pr_constr na c ++ pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++ pr_clauses (Some b) pr_ident cl) (* | TacInstantiate (n,c,ConclLocation ()) -> hov 1 (str "instantiate" ++ spc() ++ hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++ pr_lconstrarg c ++ str ")" )) | TacInstantiate (n,c,HypLocation (id,hloc)) -> hov 1 (str "instantiate" ++ spc() ++ hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++ pr_lconstrarg c ++ str ")" ) ++ str "in" ++ pr_hyp_location pr_ident (id,[],(hloc,ref None))) *) (* Derived basic tactics *) | TacSimpleInductionDestruct (isrec,h) -> hov 1 (str "simple " ++ str (if isrec then "induction" else "destruct") ++ pr_arg pr_quantified_hypothesis h) | TacInductionDestruct (isrec,ev,(l,el,cl)) -> hov 1 (str (with_evars ev (if isrec then "induction" else "destruct")) ++ spc () ++ prlist_with_sep pr_comma (fun (h,ids) -> pr_induction_arg pr_lconstr pr_constr h ++ pr_with_induction_names ids) l ++ pr_opt pr_eliminator el ++ pr_opt_no_spc (pr_clauses None pr_ident) cl) | TacDoubleInduction (h1,h2) -> hov 1 (str "double induction" ++ pr_arg pr_quantified_hypothesis h1 ++ pr_arg pr_quantified_hypothesis h2) | TacDecomposeAnd c -> hov 1 (str "decompose record" ++ pr_constrarg c) | TacDecomposeOr c -> hov 1 (str "decompose sum" ++ pr_constrarg c) | TacDecompose (l,c) -> hov 1 (str "decompose" ++ spc () ++ hov 0 (str "[" ++ prlist_with_sep spc pr_ind l ++ str "]" ++ pr_constrarg c)) | TacSpecialize (n,c) -> hov 1 (str "specialize" ++ spc () ++ pr_opt int n ++ pr_with_bindings c) | TacLApply c -> hov 1 (str "lapply" ++ pr_constrarg c) (* Automation tactics *) | TacTrivial (_,[],Some []) as x -> pr_atom0 x | TacTrivial (d,lems,db) -> hov 0 (str (string_of_debug d ^ "trivial") ++ pr_auto_using pr_constr lems ++ pr_hintbases db) | TacAuto (_,None,[],Some []) as x -> pr_atom0 x | TacAuto (d,n,lems,db) -> hov 0 (str (string_of_debug d ^ "auto") ++ pr_opt (pr_or_var int) n ++ pr_auto_using pr_constr lems ++ pr_hintbases db) (* Context management *) | TacClear (true,[]) as t -> pr_atom0 t | TacClear (keep,l) -> hov 1 (str "clear" ++ spc () ++ (if keep then str "- " else mt ()) ++ prlist_with_sep spc pr_ident l) | TacClearBody l -> hov 1 (str "clearbody" ++ spc () ++ prlist_with_sep spc pr_ident l) | TacMove (b,id1,id2) -> (* Rem: only b = true is available for users *) assert b; hov 1 (str "move" ++ brk (1,1) ++ pr_ident id1 ++ pr_move_location pr_ident id2) | TacRename l -> hov 1 (str "rename" ++ brk (1,1) ++ prlist_with_sep (fun () -> str "," ++ brk (1,1)) (fun (i1,i2) -> pr_ident i1 ++ spc () ++ str "into" ++ spc () ++ pr_ident i2) l) | TacRevert l -> hov 1 (str "revert" ++ spc () ++ prlist_with_sep spc pr_ident l) (* Constructors *) | TacLeft (ev,l) -> hov 1 (str (with_evars ev "left") ++ pr_bindings l) | TacRight (ev,l) -> hov 1 (str (with_evars ev "right") ++ pr_bindings l) | TacSplit (ev,false,l) -> hov 1 (str (with_evars ev "split") ++ prlist_with_sep pr_comma pr_bindings l) | TacSplit (ev,true,l) -> hov 1 (str (with_evars ev "exists") ++ prlist_with_sep (fun () -> str",") pr_ex_bindings l) | TacAnyConstructor (ev,Some t) -> hov 1 (str (with_evars ev "constructor") ++ pr_arg (pr_tac_level (latom,E)) t) | TacAnyConstructor (ev,None) as t -> pr_atom0 t | TacConstructor (ev,n,l) -> hov 1 (str (with_evars ev "constructor") ++ pr_or_var pr_intarg n ++ pr_bindings l) (* Conversion *) | TacReduce (r,h) -> hov 1 (pr_red_expr r ++ pr_clauses (Some true) pr_ident h) | TacChange (op,c,h) -> hov 1 (str "change" ++ brk (1,1) ++ (match op with None -> mt() | Some p -> pr_pat p ++ spc () ++ str "with ") ++ pr_constr c ++ pr_clauses (Some true) pr_ident h) (* Equivalence relations *) | TacReflexivity as x -> pr_atom0 x | TacSymmetry cls -> str "symmetry" ++ pr_clauses (Some true) pr_ident cls | TacTransitivity (Some c) -> str "transitivity" ++ pr_constrarg c | TacTransitivity None -> str "etransitivity" (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> hov 1 (str (with_evars ev "rewrite") ++ spc () ++ prlist_with_sep (fun () -> str ","++spc()) (fun (b,m,c) -> pr_orient b ++ pr_multi m ++ pr_with_bindings c) l ++ pr_clauses (Some true) pr_ident cl ++ (match by with Some by -> pr_by_tactic (pr_tac_level ltop) by | None -> mt())) | TacInversion (DepInversion (k,c,ids),hyp) -> hov 1 (str "dependent " ++ pr_induction_kind k ++ spc () ++ pr_quantified_hypothesis hyp ++ pr_with_inversion_names ids ++ pr_with_constr pr_constr c) | TacInversion (NonDepInversion (k,cl,ids),hyp) -> hov 1 (pr_induction_kind k ++ spc () ++ pr_quantified_hypothesis hyp ++ pr_with_inversion_names ids ++ pr_simple_hyp_clause pr_ident cl) | TacInversion (InversionUsing (c,cl),hyp) -> hov 1 (str "inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ spc () ++ str "using" ++ spc () ++ pr_constr c ++ pr_simple_hyp_clause pr_ident cl) in let rec pr_tac inherited tac = let (strm,prec) = match tac with | TacAbstract (t,None) -> str "abstract " ++ pr_tac (labstract,L) t, labstract | TacAbstract (t,Some s) -> hov 0 (str "abstract (" ++ pr_tac (labstract,L) t ++ str")" ++ spc () ++ str "using " ++ pr_id s), labstract | TacLetIn (recflag,llc,u) -> let llc = List.map (fun (id,t) -> (id,extract_binders t)) llc in v 0 (hv 0 (pr_let_clauses recflag (pr_tac ltop) llc ++ str " in") ++ fnl () ++ pr_tac (llet,E) u), llet | TacMatch (lz,t,lrul) -> hov 0 (pr_lazy lz ++ str "match " ++ pr_tac ltop t ++ str " with" ++ prlist (fun r -> fnl () ++ str "| " ++ pr_match_rule true (pr_tac ltop) pr_lpat r) lrul ++ fnl() ++ str "end"), lmatch | TacMatchGoal (lz,lr,lrul) -> hov 0 (pr_lazy lz ++ str (if lr then "match reverse goal with" else "match goal with") ++ prlist (fun r -> fnl () ++ str "| " ++ pr_match_rule false (pr_tac ltop) pr_lpat r) lrul ++ fnl() ++ str "end"), lmatch | TacFun (lvar,body) -> hov 2 (str "fun" ++ prlist pr_funvar lvar ++ str " =>" ++ spc () ++ pr_tac (lfun,E) body), lfun | TacThens (t,tl) -> hov 1 (pr_tac (lseq,E) t ++ pr_then () ++ spc () ++ pr_seq_body (pr_tac ltop) tl), lseq | TacThen (t1,[||],t2,[||]) -> hov 1 (pr_tac (lseq,E) t1 ++ pr_then () ++ spc () ++ pr_tac (lseq,L) t2), lseq | TacThen (t1,tf,t2,tl) -> hov 1 (pr_tac (lseq,E) t1 ++ pr_then () ++ spc () ++ pr_then_gen (pr_tac ltop) tf t2 tl), lseq | TacTry t -> hov 1 (str "try" ++ spc () ++ pr_tac (ltactical,E) t), ltactical | TacDo (n,t) -> hov 1 (str "do " ++ pr_or_var int n ++ spc () ++ pr_tac (ltactical,E) t), ltactical | TacTimeout (n,t) -> hov 1 (str "timeout " ++ pr_or_var int n ++ spc () ++ pr_tac (ltactical,E) t), ltactical | TacRepeat t -> hov 1 (str "repeat" ++ spc () ++ pr_tac (ltactical,E) t), ltactical | TacProgress t -> hov 1 (str "progress" ++ spc () ++ pr_tac (ltactical,E) t), ltactical | TacInfo t -> hov 1 (str "info" ++ spc () ++ pr_tac (ltactical,E) t), linfo | TacOrelse (t1,t2) -> hov 1 (pr_tac (lorelse,L) t1 ++ str " ||" ++ brk (1,1) ++ pr_tac (lorelse,E) t2), lorelse | TacFail (n,l) -> hov 1 (str "fail" ++ (if n=ArgArg 0 then mt () else pr_arg (pr_or_var int) n) ++ prlist (pr_arg (pr_message_token pr_ident)) l), latom | TacFirst tl -> str "first" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet | TacSolve tl -> str "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet | TacComplete t -> pr_tac (lcomplete,E) t, lcomplete | TacId l -> str "idtac" ++ prlist (pr_arg (pr_message_token pr_ident)) l, latom | TacAtom (loc,TacAlias (_,s,l,_)) -> pr_with_comments loc (pr_extend (level_of inherited) s (List.map snd l)), latom | TacAtom (loc,t) -> pr_with_comments loc (hov 1 (pr_atom1 t)), ltatom | TacArg(_,Tacexp e) -> pr_tac_level (latom,E) e, latom | TacArg(_,ConstrMayEval (ConstrTerm c)) -> str "constr:" ++ pr_constr c, latom | TacArg(_,ConstrMayEval c) -> pr_may_eval pr_constr pr_lconstr pr_cst pr_pat c, leval | TacArg(_,TacFreshId l) -> str "fresh" ++ pr_fresh_ids l, latom | TacArg(_,Integer n) -> int n, latom | TacArg(_,TacCall(loc,f,[])) -> pr_ref f, latom | TacArg(_,TacCall(loc,f,l)) -> pr_with_comments loc (hov 1 (pr_ref f ++ spc () ++ prlist_with_sep spc pr_tacarg l)), lcall | TacArg (_,a) -> pr_tacarg a, latom in if prec_less prec inherited then strm else str"(" ++ strm ++ str")" and pr_tacarg = function | TacDynamic (loc,t) -> pr_with_comments loc (str ("")) | MetaIdArg (loc,true,s) -> pr_with_comments loc (str ("$" ^ s)) | MetaIdArg (loc,false,s) -> pr_with_comments loc (str ("constr: $" ^ s)) | IntroPattern ipat -> str "ipattern:" ++ pr_intro_pattern ipat | TacVoid -> str "()" | Reference r -> pr_ref r | ConstrMayEval c -> pr_may_eval pr_constr pr_lconstr pr_cst pr_pat c | TacFreshId l -> str "fresh" ++ pr_fresh_ids l | TacExternal (_,com,req,la) -> str "external" ++ spc() ++ qs com ++ spc() ++ qs req ++ spc() ++ prlist_with_sep spc pr_tacarg la | (TacCall _|Tacexp _|Integer _) as a -> str "ltac:" ++ pr_tac (latom,E) (TacArg (dummy_loc,a)) in (pr_tac, pr_match_rule) let strip_prod_binders_glob_constr n (ty,_) = let rec strip_ty acc n ty = if n=0 then (List.rev acc, (ty,None)) else match ty with Glob_term.GProd(loc,na,Explicit,a,b) -> strip_ty (([dummy_loc,na],(a,None))::acc) (n-1) b | _ -> error "Cannot translate fix tactic: not enough products" in strip_ty [] n ty let strip_prod_binders_constr n ty = let rec strip_ty acc n ty = if n=0 then (List.rev acc, ty) else match Term.kind_of_term ty with Term.Prod(na,a,b) -> strip_ty (([dummy_loc,na],a)::acc) (n-1) b | _ -> error "Cannot translate fix tactic: not enough products" in strip_ty [] n ty let drop_env f _env = f let pr_constr_or_lconstr_pattern_expr b = if b then pr_lconstr_pattern_expr else pr_constr_pattern_expr let rec raw_printers = (pr_raw_tactic_level, drop_env pr_constr_expr, drop_env pr_lconstr_expr, pr_constr_or_lconstr_pattern_expr, drop_env (pr_or_by_notation pr_reference), drop_env (pr_or_by_notation pr_reference), pr_reference, pr_or_metaid pr_lident, pr_raw_extend, strip_prod_binders_expr) and pr_raw_tactic_level env n (t:raw_tactic_expr) = fst (make_pr_tac raw_printers env) n t let pr_and_constr_expr pr (c,_) = pr c let pr_pat_and_constr_expr b (c,_) = pr_and_constr_expr ((if b then pr_lglob_constr_env else pr_glob_constr_env) (Global.env())) c let rec glob_printers = (pr_glob_tactic_level, (fun env -> pr_and_constr_expr (pr_glob_constr_env env)), (fun env -> pr_and_constr_expr (pr_lglob_constr_env env)), pr_pat_and_constr_expr, (fun env -> pr_or_var (pr_and_short_name (pr_evaluable_reference_env env))), (fun env -> pr_or_var (pr_inductive env)), pr_ltac_or_var (pr_located pr_ltac_constant), pr_lident, pr_glob_extend, strip_prod_binders_glob_constr) and pr_glob_tactic_level env n (t:glob_tactic_expr) = fst (make_pr_tac glob_printers env) n t let pr_constr_or_lconstr_pattern b = if b then pr_lconstr_pattern else pr_constr_pattern let typed_printers = (pr_glob_tactic_level, pr_constr_env, pr_lconstr_env, pr_constr_or_lconstr_pattern, pr_evaluable_reference_env, pr_inductive, pr_ltac_constant, pr_id, pr_extend, strip_prod_binders_constr) let pr_tactic_level env = fst (make_pr_tac typed_printers env) let pr_raw_tactic env = pr_raw_tactic_level env ltop let pr_glob_tactic env = pr_glob_tactic_level env ltop let pr_tactic env = pr_tactic_level env ltop let _ = Tactic_debug.set_tactic_printer (fun x -> pr_glob_tactic (Global.env()) x) let _ = Tactic_debug.set_match_pattern_printer (fun env hyp -> pr_match_pattern (pr_constr_pattern_env env) hyp) let _ = Tactic_debug.set_match_rule_printer (fun rl -> pr_match_rule false (pr_glob_tactic (Global.env())) (fun (_,p) -> pr_constr_pattern p) rl) open Extrawit let pr_tac_polymorphic n _ _ prtac = prtac (n,E) let _ = for i=0 to 5 do declare_extra_genarg_pprule (rawwit_tactic i, pr_tac_polymorphic i) (globwit_tactic i, pr_tac_polymorphic i) (wit_tactic i, pr_tac_polymorphic i) done coq-8.4pl4/parsing/extend.mli0000644000175000017500000000266412326224777015300 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* > let apply_ref f l = <:expr< Glob_term.GApp ($dloc$, Glob_term.GRef ($dloc$, Lazy.force $f$), $mlexpr_of_list (fun x -> x) l$) >> EXTEND GLOBAL: expr; expr: [ [ "PATTERN"; "["; c = constr; "]" -> <:expr< snd (Pattern.pattern_of_glob_constr $c$) >> ] ] ; sort: [ [ "Set" -> GProp Pos | "Prop" -> GProp Null | "Type" -> GType None ] ] ; ident: [ [ s = string -> <:expr< Names.id_of_string $str:s$ >> ] ] ; name: [ [ "_" -> <:expr< Anonymous >> | id = ident -> <:expr< Name $id$ >> ] ] ; string: [ [ s = UIDENT -> s | s = LIDENT -> s ] ] ; constr: [ "200" RIGHTA [ LIDENT "forall"; id = ident; ":"; c1 = constr; ","; c2 = constr -> <:expr< Glob_term.GProd ($dloc$,Name $id$,Glob_term.Explicit,$c1$,$c2$) >> | "fun"; id = ident; ":"; c1 = constr; "=>"; c2 = constr -> <:expr< Glob_term.GLambda ($dloc$,Name $id$,Glob_term.Explicit,$c1$,$c2$) >> | "let"; id = ident; ":="; c1 = constr; "in"; c2 = constr -> <:expr< Glob_term.RLetin ($dloc$,Name $id$,$c1$,$c2$) >> (* fix todo *) ] | "100" RIGHTA [ c1 = constr; ":"; c2 = SELF -> <:expr< Glob_term.GCast($dloc$,$c1$,DEFAULTcast,$c2$) >> ] | "90" RIGHTA [ c1 = constr; "->"; c2 = SELF -> <:expr< Glob_term.GProd ($dloc$,Anonymous,Glob_term.Explicit,$c1$,$c2$) >> ] | "75" RIGHTA [ "~"; c = constr -> apply_ref <:expr< coq_not_ref >> [c] ] | "70" RIGHTA [ c1 = constr; "="; c2 = NEXT; ":>"; t = NEXT -> apply_ref <:expr< coq_eq_ref >> [t;c1;c2] ] | "10" LEFTA [ f = constr; args = LIST1 NEXT -> let args = mlexpr_of_list (fun x -> x) args in <:expr< Glob_term.GApp ($dloc$,$f$,$args$) >> ] | "0" [ s = sort -> <:expr< Glob_term.GSort ($dloc$,s) >> | id = ident -> <:expr< Glob_term.GVar ($dloc$,$id$) >> | "_" -> <:expr< Glob_term.GHole ($dloc$, QuestionMark (Define False)) >> | "?"; id = ident -> <:expr< Glob_term.GPatVar($dloc$,(False,$id$)) >> | "{"; c1 = constr; "}"; "+"; "{"; c2 = constr; "}" -> apply_ref <:expr< coq_sumbool_ref >> [c1;c2] | "%"; e = string -> <:expr< Glob_term.GRef ($dloc$,Lazy.force $lid:e$) >> | c = match_constr -> c | "("; c = constr LEVEL "200"; ")" -> c ] ] ; match_constr: [ [ "match"; c = constr LEVEL "100"; (ty,nal) = match_type; "with"; OPT"|"; br = LIST0 eqn SEP "|"; "end" -> let br = mlexpr_of_list (fun x -> x) br in <:expr< Glob_term.GCases ($dloc$,$ty$,[($c$,$nal$)],$br$) >> ] ] ; match_type: [ [ "as"; id = ident; "in"; ind = LIDENT; nal = LIST0 name; "return"; ty = constr LEVEL "100" -> let nal = mlexpr_of_list (fun x -> x) nal in <:expr< Some $ty$ >>, <:expr< (Name $id$, Some ($dloc$,$lid:ind$,$nal$)) >> | -> <:expr< None >>, <:expr< (Anonymous, None) >> ] ] ; eqn: [ [ (lid,pl) = pattern; "=>"; rhs = constr -> let lid = mlexpr_of_list (fun x -> x) lid in <:expr< ($dloc$,$lid$,[$pl$],$rhs$) >> ] ] ; pattern: [ [ "%"; e = string; lip = LIST0 patvar -> let lp = mlexpr_of_list (fun (_,x) -> x) lip in let lid = List.flatten (List.map fst lip) in lid, <:expr< Glob_term.PatCstr ($dloc$,$lid:e$,$lp$,Anonymous) >> | p = patvar -> p | "("; p = pattern; ")" -> p ] ] ; patvar: [ [ "_" -> [], <:expr< Glob_term.PatVar ($dloc$,Anonymous) >> | id = ident -> [id], <:expr< Glob_term.PatVar ($dloc$,Name $id$) >> ] ] ; END;; (* Example open Coqlib let a = PATTERN [ match ?X with %path_of_S n => n | %path_of_O => ?X end ] *) coq-8.4pl4/parsing/printmod.mli0000644000175000017500000000135612326224777015642 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool val print_module : bool -> module_path -> std_ppcmds val print_modtype : module_path -> std_ppcmds coq-8.4pl4/parsing/tok.ml0000644000175000017500000000561312326224777014432 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* s | IDENT s -> s | STRING s -> s | METAIDENT s -> s | PATTERNIDENT s -> s | FIELD s -> s | INT s -> s | LEFTQMARK -> "?" | EOI -> "" let to_string = function | KEYWORD s -> Format.sprintf "%S" s | IDENT s -> Format.sprintf "IDENT %S" s | METAIDENT s -> Format.sprintf "METAIDENT %S" s | PATTERNIDENT s -> Format.sprintf "PATTERNIDENT %S" s | FIELD s -> Format.sprintf "FIELD %S" s | INT s -> Format.sprintf "INT %s" s | STRING s -> Format.sprintf "STRING %S" s | LEFTQMARK -> "LEFTQMARK" | EOI -> "EOI" let match_keyword kwd = function | KEYWORD kwd' when kwd = kwd' -> true | _ -> false let print ppf tok = Format.fprintf ppf "%s" (to_string tok) (** For camlp5, conversion from/to [Plexing.pattern], and a match function analoguous to [Plexing.default_match] *) let of_pattern = function | "", s -> KEYWORD s | "IDENT", s -> IDENT s | "METAIDENT", s -> METAIDENT s | "PATTERNIDENT", s -> PATTERNIDENT s | "FIELD", s -> FIELD s | "INT", s -> INT s | "STRING", s -> STRING s | "LEFTQMARK", _ -> LEFTQMARK | "EOI", _ -> EOI | _ -> failwith "Tok.of_pattern: not a constructor" let to_pattern = function | KEYWORD s -> "", s | IDENT s -> "IDENT", s | METAIDENT s -> "METAIDENT", s | PATTERNIDENT s -> "PATTERNIDENT", s | FIELD s -> "FIELD", s | INT s -> "INT", s | STRING s -> "STRING", s | LEFTQMARK -> "LEFTQMARK", "" | EOI -> "EOI", "" let match_pattern = let err () = raise Stream.Failure in function | "", "" -> (function KEYWORD s -> s | _ -> err ()) | "IDENT", "" -> (function IDENT s -> s | _ -> err ()) | "METAIDENT", "" -> (function METAIDENT s -> s | _ -> err ()) | "PATTERNIDENT", "" -> (function PATTERNIDENT s -> s | _ -> err ()) | "FIELD", "" -> (function FIELD s -> s | _ -> err ()) | "INT", "" -> (function INT s -> s | _ -> err ()) | "STRING", "" -> (function STRING s -> s | _ -> err ()) | "LEFTQMARK", "" -> (function LEFTQMARK -> "" | _ -> err ()) | "EOI", "" -> (function EOI -> "" | _ -> err ()) | pat -> let tok = of_pattern pat in function tok' -> if tok = tok' then snd pat else err () coq-8.4pl4/parsing/egrammar.mli0000644000175000017500000000473212326224777015602 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val extend_tactic_grammar : string -> grammar_prod_item list list -> unit val extend_vernac_command_grammar : string -> vernac_expr Gram.entry option -> grammar_prod_item list list -> unit val get_extend_vernac_grammars : unit -> (string * grammar_prod_item list list) list (** For a declared grammar, returns the rule + the ordered entry types of variables in the rule (for use in the interpretation) *) val recover_notation_grammar : notation -> (precedence * tolerability list) -> notation_var_internalization_type list * notation_grammar val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b coq-8.4pl4/parsing/pcoq.ml40000644000175000017500000006375012326224777014671 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (*

    (p-q)*r = p*r-q*r. Proof. intros H. rewrite 3 (mul_comm _ r). now apply mul_sub_distr_l. Qed. Lemma sub_lt_mono_l p q r: q

    p r-p < r-q. Proof. intros Hqp Hpr. apply (add_lt_mono_r p). rewrite sub_add by trivial. apply le_lt_trans with ((r-q)+q). rewrite sub_add by (now apply lt_trans with p). apply le_refl. now apply add_lt_mono_l. Qed. Lemma sub_compare_mono_l p q r : q

    r

    (p-q ?= p-r) = (r ?= q). Proof. intros Hqp Hrp. case (compare_spec r q); intros H. subst. apply compare_refl. apply sub_lt_mono_l; trivial. apply lt_gt, sub_lt_mono_l; trivial. Qed. Lemma sub_compare_mono_r p q r : p p (q-p ?= r-p) = (q ?= r). Proof. intros. rewrite <- (add_compare_mono_r p), 2 sub_add; trivial. Qed. Lemma sub_lt_mono_r p q r : q

    r q-r < p-r. Proof. intros. unfold lt. rewrite sub_compare_mono_r; trivial. now apply lt_trans with q. Qed. Lemma sub_decr n m : m n-m < n. Proof. intros. apply add_lt_mono_r with m. rewrite sub_add; trivial. apply lt_add_r. Qed. Lemma add_sub_assoc p q r : r p+(q-r) = p+q-r. Proof. intros. apply add_reg_r with r. rewrite <- add_assoc, !sub_add; trivial. rewrite add_comm. apply lt_trans with q; trivial using lt_add_r. Qed. Lemma sub_add_distr p q r : q+r < p -> p-(q+r) = p-q-r. Proof. intros. assert (q < p) by (apply lt_trans with (q+r); trivial using lt_add_r). rewrite (add_comm q r) in *. apply add_reg_r with (r+q). rewrite sub_add by trivial. rewrite add_assoc, !sub_add; trivial. apply (add_lt_mono_r q). rewrite sub_add; trivial. Qed. Lemma sub_sub_distr p q r : r q-r < p -> p-(q-r) = p+r-q. Proof. intros. apply add_reg_r with ((q-r)+r). rewrite add_assoc, !sub_add; trivial. rewrite <- (sub_add q r); trivial. now apply add_lt_mono_r. Qed. (** Recursive equations for [sub] *) Lemma sub_xO_xO n m : m n~0 - m~0 = (n-m)~0. Proof. intros H. unfold sub. simpl. now destruct (sub_mask_pos n m H) as (p, ->). Qed. Lemma sub_xI_xI n m : m n~1 - m~1 = (n-m)~0. Proof. intros H. unfold sub. simpl. now destruct (sub_mask_pos n m H) as (p, ->). Qed. Lemma sub_xI_xO n m : m n~1 - m~0 = (n-m)~1. Proof. intros H. unfold sub. simpl. now destruct (sub_mask_pos n m) as (p, ->). Qed. Lemma sub_xO_xI n m : n~0 - m~1 = pred_double (n-m). Proof. unfold sub. simpl. rewrite sub_mask_carry_spec. now destruct (sub_mask n m) as [|[r|r|]|]. Qed. (** Properties of subtraction with underflow *) Lemma sub_mask_neg_iff' p q : sub_mask p q = IsNeg <-> p < q. Proof. rewrite lt_iff_add. apply sub_mask_neg_iff. Qed. Lemma sub_mask_neg p q : p sub_mask p q = IsNeg. Proof. apply sub_mask_neg_iff'. Qed. Lemma sub_le p q : p<=q -> p-q = 1. Proof. unfold le, sub. rewrite compare_sub_mask. destruct sub_mask; easy'. Qed. Lemma sub_lt p q : p p-q = 1. Proof. intros. now apply sub_le, lt_le_incl. Qed. Lemma sub_diag p : p-p = 1. Proof. unfold sub. now rewrite sub_mask_diag. Qed. (** ** Results concerning [size] and [size_nat] *) Lemma size_nat_monotone p q : p (size_nat p <= size_nat q)%nat. Proof. assert (le0 : forall n, (0<=n)%nat) by (induction n; auto). assert (leS : forall n m, (n<=m -> S n <= S m)%nat) by (induction 1; auto). revert q. induction p; destruct q; simpl; intros; auto; easy || apply leS; red in H; simpl_compare_in H. apply IHp. red. now destruct (p?=q). destruct (compare_spec p q); subst; now auto. Qed. Lemma size_gt p : p < 2^(size p). Proof. induction p; simpl; try rewrite pow_succ_r; try easy. apply le_succ_l in IHp. now apply le_succ_l. Qed. Lemma size_le p : 2^(size p) <= p~0. Proof. induction p; simpl; try rewrite pow_succ_r; try easy. apply mul_le_mono_l. apply le_lteq; left. rewrite xI_succ_xO. apply lt_succ_r, IHp. Qed. (** ** Properties of [min] and [max] *) (** First, the specification *) Lemma max_l : forall x y, y<=x -> max x y = x. Proof. intros x y H. unfold max. case compare_spec; auto. intros H'. apply le_nlt in H. now elim H. Qed. Lemma max_r : forall x y, x<=y -> max x y = y. Proof. unfold le, max. intros x y. destruct compare; easy'. Qed. Lemma min_l : forall x y, x<=y -> min x y = x. Proof. unfold le, min. intros x y. destruct compare; easy'. Qed. Lemma min_r : forall x y, y<=x -> min x y = y. Proof. intros x y H. unfold min. case compare_spec; auto. intros H'. apply le_nlt in H. now elim H'. Qed. (** We hence obtain all the generic properties of [min] and [max]. *) Include UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. Ltac order := Private_Tac.order. (** Minimum, maximum and constant one *) Lemma max_1_l n : max 1 n = n. Proof. unfold max. case compare_spec; auto. intros H. apply lt_nle in H. elim H. apply le_1_l. Qed. Lemma max_1_r n : max n 1 = n. Proof. rewrite max_comm. apply max_1_l. Qed. Lemma min_1_l n : min 1 n = 1. Proof. unfold min. case compare_spec; auto. intros H. apply lt_nle in H. elim H. apply le_1_l. Qed. Lemma min_1_r n : min n 1 = 1. Proof. rewrite min_comm. apply min_1_l. Qed. (** Minimum, maximum and operations (consequences of monotonicity) *) Lemma succ_max_distr n m : succ (max n m) = max (succ n) (succ m). Proof. symmetry. apply max_monotone. intros x x'. apply succ_le_mono. Qed. Lemma succ_min_distr n m : succ (min n m) = min (succ n) (succ m). Proof. symmetry. apply min_monotone. intros x x'. apply succ_le_mono. Qed. Lemma add_max_distr_l n m p : max (p + n) (p + m) = p + max n m. Proof. apply max_monotone. intros x x'. apply add_le_mono_l. Qed. Lemma add_max_distr_r n m p : max (n + p) (m + p) = max n m + p. Proof. rewrite 3 (add_comm _ p). apply add_max_distr_l. Qed. Lemma add_min_distr_l n m p : min (p + n) (p + m) = p + min n m. Proof. apply min_monotone. intros x x'. apply add_le_mono_l. Qed. Lemma add_min_distr_r n m p : min (n + p) (m + p) = min n m + p. Proof. rewrite 3 (add_comm _ p). apply add_min_distr_l. Qed. Lemma mul_max_distr_l n m p : max (p * n) (p * m) = p * max n m. Proof. apply max_monotone. intros x x'. apply mul_le_mono_l. Qed. Lemma mul_max_distr_r n m p : max (n * p) (m * p) = max n m * p. Proof. rewrite 3 (mul_comm _ p). apply mul_max_distr_l. Qed. Lemma mul_min_distr_l n m p : min (p * n) (p * m) = p * min n m. Proof. apply min_monotone. intros x x'. apply mul_le_mono_l. Qed. Lemma mul_min_distr_r n m p : min (n * p) (m * p) = min n m * p. Proof. rewrite 3 (mul_comm _ p). apply mul_min_distr_l. Qed. (** ** Results concerning [iter_op] *) Lemma iter_op_succ : forall A (op:A->A->A), (forall x y z, op x (op y z) = op (op x y) z) -> forall p a, iter_op op (succ p) a = op a (iter_op op p a). Proof. induction p; simpl; intros; trivial. rewrite H. apply IHp. Qed. (** ** Results about [of_nat] and [of_succ_nat] *) Lemma of_nat_succ (n:nat) : of_succ_nat n = of_nat (S n). Proof. induction n. trivial. simpl. f_equal. now rewrite IHn. Qed. Lemma pred_of_succ_nat (n:nat) : pred (of_succ_nat n) = of_nat n. Proof. destruct n. trivial. simpl pred. rewrite pred_succ. apply of_nat_succ. Qed. Lemma succ_of_nat (n:nat) : n<>O -> succ (of_nat n) = of_succ_nat n. Proof. rewrite of_nat_succ. destruct n; trivial. now destruct 1. Qed. (** ** Correctness proofs for the square root function *) Inductive SqrtSpec : positive*mask -> positive -> Prop := | SqrtExact s x : x=s*s -> SqrtSpec (s,IsNul) x | SqrtApprox s r x : x=s*s+r -> r <= s~0 -> SqrtSpec (s,IsPos r) x. Lemma sqrtrem_step_spec f g p x : (f=xO \/ f=xI) -> (g=xO \/ g=xI) -> SqrtSpec p x -> SqrtSpec (sqrtrem_step f g p) (g (f x)). Proof. intros Hf Hg [ s _ -> | s r _ -> Hr ]. (* exact *) unfold sqrtrem_step. destruct Hf,Hg; subst; simpl; constructor; now rewrite ?square_xO. (* approx *) assert (Hfg : forall p q, g (f (p+q)) = p~0~0 + g (f q)) by (intros; destruct Hf, Hg; now subst). unfold sqrtrem_step, leb. case compare_spec; [intros EQ | intros LT | intros GT]. (* - EQ *) rewrite <- EQ, sub_mask_diag. constructor. destruct Hg; subst g; destr_eq EQ. destruct Hf; subst f; destr_eq EQ. subst. now rewrite square_xI. (* - LT *) destruct (sub_mask_pos' _ _ LT) as (y & -> & H). constructor. rewrite Hfg, <- H. now rewrite square_xI, add_assoc. clear Hfg. rewrite <- lt_succ_r in Hr. change (r < s~1) in Hr. rewrite <- lt_succ_r, (add_lt_mono_l (s~0~1)), H. simpl. rewrite add_carry_spec, add_diag. simpl. destruct Hf,Hg; subst; red; simpl_compare; now rewrite Hr. (* - GT *) constructor. now rewrite Hfg, square_xO. apply lt_succ_r, GT. Qed. Lemma sqrtrem_spec p : SqrtSpec (sqrtrem p) p. Proof. revert p. fix 1. destruct p; try destruct p; try (constructor; easy); apply sqrtrem_step_spec; auto. Qed. Lemma sqrt_spec p : let s := sqrt p in s*s <= p < (succ s)*(succ s). Proof. simpl. assert (H:=sqrtrem_spec p). unfold sqrt in *. destruct sqrtrem as (s,rm); simpl. inversion_clear H; subst. (* exact *) split. reflexivity. apply mul_lt_mono; apply lt_succ_diag_r. (* approx *) split. apply lt_le_incl, lt_add_r. rewrite <- add_1_l, mul_add_distr_r, !mul_add_distr_l, !mul_1_r, !mul_1_l. rewrite add_assoc, (add_comm _ r). apply add_lt_mono_r. now rewrite <- add_assoc, add_diag, add_1_l, lt_succ_r. Qed. (** ** Correctness proofs for the gcd function *) Lemma divide_add_cancel_l p q r : (p | r) -> (p | q + r) -> (p | q). Proof. intros (s,Hs) (t,Ht). exists (t-s). rewrite mul_sub_distr_r. rewrite <- Hs, <- Ht. symmetry. apply add_sub. apply mul_lt_mono_r with p. rewrite <- Hs, <- Ht, add_comm. apply lt_add_r. Qed. Lemma divide_xO_xI p q r : (p | q~0) -> (p | r~1) -> (p | q). Proof. intros (s,Hs) (t,Ht). destruct p. destruct s; try easy. simpl in Hs. destr_eq Hs. now exists s. rewrite mul_xO_r in Ht; discriminate. exists q; now rewrite mul_1_r. Qed. Lemma divide_xO_xO p q : (p~0|q~0) <-> (p|q). Proof. split; intros (r,H); simpl in *. rewrite mul_xO_r in H. destr_eq H. now exists r. exists r; simpl. rewrite mul_xO_r. f_equal; auto. Qed. Lemma divide_mul_l p q r : (p|q) -> (p|q*r). Proof. intros (s,H). exists (s*r). rewrite <- mul_assoc, (mul_comm r p), mul_assoc. now f_equal. Qed. Lemma divide_mul_r p q r : (p|r) -> (p|q*r). Proof. rewrite mul_comm. apply divide_mul_l. Qed. (** The first component of ggcd is gcd *) Lemma ggcdn_gcdn : forall n a b, fst (ggcdn n a b) = gcdn n a b. Proof. induction n. simpl; auto. destruct a, b; simpl; auto; try case compare_spec; simpl; trivial; rewrite <- IHn; destruct ggcdn as (g,(u,v)); simpl; auto. Qed. Lemma ggcd_gcd : forall a b, fst (ggcd a b) = gcd a b. Proof. unfold ggcd, gcd. intros. apply ggcdn_gcdn. Qed. (** The other components of ggcd are indeed the correct factors. *) Ltac destr_pggcdn IHn := match goal with |- context [ ggcdn _ ?x ?y ] => generalize (IHn x y); destruct ggcdn as (g,(u,v)); simpl end. Lemma ggcdn_correct_divisors : forall n a b, let '(g,(aa,bb)) := ggcdn n a b in a = g*aa /\ b = g*bb. Proof. induction n. simpl; auto. destruct a, b; simpl; auto; try case compare_spec; try destr_pggcdn IHn. (* Eq *) intros ->. now rewrite mul_comm. (* Lt *) intros (H',H) LT; split; auto. rewrite mul_add_distr_l, mul_xO_r, <- H, <- H'. simpl. f_equal. symmetry. rewrite add_comm. now apply sub_add. (* Gt *) intros (H',H) LT; split; auto. rewrite mul_add_distr_l, mul_xO_r, <- H, <- H'. simpl. f_equal. symmetry. rewrite add_comm. now apply sub_add. (* Then... *) intros (H,H'); split; auto. rewrite mul_xO_r, H'; auto. intros (H,H'); split; auto. rewrite mul_xO_r, H; auto. intros (H,H'); split; subst; auto. Qed. Lemma ggcd_correct_divisors : forall a b, let '(g,(aa,bb)) := ggcd a b in a=g*aa /\ b=g*bb. Proof. unfold ggcd. intros. apply ggcdn_correct_divisors. Qed. (** We can use this fact to prove a part of the gcd correctness *) Lemma gcd_divide_l : forall a b, (gcd a b | a). Proof. intros a b. rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b). destruct ggcd as (g,(aa,bb)); simpl. intros (H,_). exists aa. now rewrite mul_comm. Qed. Lemma gcd_divide_r : forall a b, (gcd a b | b). Proof. intros a b. rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b). destruct ggcd as (g,(aa,bb)); simpl. intros (_,H). exists bb. now rewrite mul_comm. Qed. (** We now prove directly that gcd is the greatest amongst common divisors *) Lemma gcdn_greatest : forall n a b, (size_nat a + size_nat b <= n)%nat -> forall p, (p|a) -> (p|b) -> (p|gcdn n a b). Proof. induction n. destruct a, b; simpl; inversion 1. destruct a, b; simpl; try case compare_spec; simpl; auto. (* Lt *) intros LT LE p Hp1 Hp2. apply IHn; clear IHn; trivial. apply le_S_n in LE. eapply Le.le_trans; [|eapply LE]. rewrite plus_comm, <- plus_n_Sm, <- plus_Sn_m. apply plus_le_compat; trivial. apply size_nat_monotone, sub_decr, LT. apply divide_xO_xI with a; trivial. apply (divide_add_cancel_l p _ a~1); trivial. now rewrite <- sub_xI_xI, sub_add. (* Gt *) intros LT LE p Hp1 Hp2. apply IHn; clear IHn; trivial. apply le_S_n in LE. eapply Le.le_trans; [|eapply LE]. apply plus_le_compat; trivial. apply size_nat_monotone, sub_decr, LT. apply divide_xO_xI with b; trivial. apply (divide_add_cancel_l p _ b~1); trivial. now rewrite <- sub_xI_xI, sub_add. (* a~1 b~0 *) intros LE p Hp1 Hp2. apply IHn; clear IHn; trivial. apply le_S_n in LE. simpl. now rewrite plus_n_Sm. apply divide_xO_xI with a; trivial. (* a~0 b~1 *) intros LE p Hp1 Hp2. apply IHn; clear IHn; trivial. simpl. now apply le_S_n. apply divide_xO_xI with b; trivial. (* a~0 b~0 *) intros LE p Hp1 Hp2. destruct p. change (gcdn n a b)~0 with (2*(gcdn n a b)). apply divide_mul_r. apply IHn; clear IHn. apply le_S_n in LE. apply le_Sn_le. now rewrite plus_n_Sm. apply divide_xO_xI with p; trivial. now exists 1. apply divide_xO_xI with p; trivial. now exists 1. apply divide_xO_xO. apply IHn; clear IHn. apply le_S_n in LE. apply le_Sn_le. now rewrite plus_n_Sm. now apply divide_xO_xO. now apply divide_xO_xO. exists (gcdn n a b)~0. now rewrite mul_1_r. Qed. Lemma gcd_greatest : forall a b p, (p|a) -> (p|b) -> (p|gcd a b). Proof. intros. apply gcdn_greatest; auto. Qed. (** As a consequence, the rests after division by gcd are relatively prime *) Lemma ggcd_greatest : forall a b, let (aa,bb) := snd (ggcd a b) in forall p, (p|aa) -> (p|bb) -> p=1. Proof. intros. generalize (gcd_greatest a b) (ggcd_correct_divisors a b). rewrite <- ggcd_gcd. destruct ggcd as (g,(aa,bb)); simpl. intros H (EQa,EQb) p Hp1 Hp2; subst. assert (H' : (g*p | g)). apply H. destruct Hp1 as (r,Hr). exists r. now rewrite mul_assoc, (mul_comm r g), <- mul_assoc, <- Hr. destruct Hp2 as (r,Hr). exists r. now rewrite mul_assoc, (mul_comm r g), <- mul_assoc, <- Hr. destruct H' as (q,H'). rewrite (mul_comm g p), mul_assoc in H'. apply mul_eq_1 with q; rewrite mul_comm. now apply mul_reg_r with g. Qed. End Pos. (** Exportation of notations *) Infix "+" := Pos.add : positive_scope. Infix "-" := Pos.sub : positive_scope. Infix "*" := Pos.mul : positive_scope. Infix "^" := Pos.pow : positive_scope. Infix "?=" := Pos.compare (at level 70, no associativity) : positive_scope. Infix "=?" := Pos.eqb (at level 70, no associativity) : positive_scope. Infix "<=?" := Pos.leb (at level 70, no associativity) : positive_scope. Infix "=" := Pos.ge : positive_scope. Infix ">" := Pos.gt : positive_scope. Notation "x <= y <= z" := (x <= y /\ y <= z) : positive_scope. Notation "x <= y < z" := (x <= y /\ y < z) : positive_scope. Notation "x < y < z" := (x < y /\ y < z) : positive_scope. Notation "x < y <= z" := (x < y /\ y <= z) : positive_scope. Notation "( p | q )" := (Pos.divide p q) (at level 0) : positive_scope. (** Compatibility notations *) Notation positive := positive (only parsing). Notation positive_rect := positive_rect (only parsing). Notation positive_rec := positive_rec (only parsing). Notation positive_ind := positive_ind (only parsing). Notation xI := xI (only parsing). Notation xO := xO (only parsing). Notation xH := xH (only parsing). Notation IsNul := Pos.IsNul (only parsing). Notation IsPos := Pos.IsPos (only parsing). Notation IsNeg := Pos.IsNeg (only parsing). Notation Psucc := Pos.succ (compat "8.3"). Notation Pplus := Pos.add (compat "8.3"). Notation Pplus_carry := Pos.add_carry (compat "8.3"). Notation Ppred := Pos.pred (compat "8.3"). Notation Piter_op := Pos.iter_op (compat "8.3"). Notation Piter_op_succ := Pos.iter_op_succ (compat "8.3"). Notation Pmult_nat := (Pos.iter_op plus) (compat "8.3"). Notation nat_of_P := Pos.to_nat (compat "8.3"). Notation P_of_succ_nat := Pos.of_succ_nat (compat "8.3"). Notation Pdouble_minus_one := Pos.pred_double (compat "8.3"). Notation positive_mask := Pos.mask (compat "8.3"). Notation positive_mask_rect := Pos.mask_rect (compat "8.3"). Notation positive_mask_ind := Pos.mask_ind (compat "8.3"). Notation positive_mask_rec := Pos.mask_rec (compat "8.3"). Notation Pdouble_plus_one_mask := Pos.succ_double_mask (compat "8.3"). Notation Pdouble_mask := Pos.double_mask (compat "8.3"). Notation Pdouble_minus_two := Pos.double_pred_mask (compat "8.3"). Notation Pminus_mask := Pos.sub_mask (compat "8.3"). Notation Pminus_mask_carry := Pos.sub_mask_carry (compat "8.3"). Notation Pminus := Pos.sub (compat "8.3"). Notation Pmult := Pos.mul (compat "8.3"). Notation iter_pos := @Pos.iter (compat "8.3"). Notation Ppow := Pos.pow (compat "8.3"). Notation Pdiv2 := Pos.div2 (compat "8.3"). Notation Pdiv2_up := Pos.div2_up (compat "8.3"). Notation Psize := Pos.size_nat (compat "8.3"). Notation Psize_pos := Pos.size (compat "8.3"). Notation Pcompare := Pos.compare_cont (compat "8.3"). Notation Plt := Pos.lt (compat "8.3"). Notation Pgt := Pos.gt (compat "8.3"). Notation Ple := Pos.le (compat "8.3"). Notation Pge := Pos.ge (compat "8.3"). Notation Pmin := Pos.min (compat "8.3"). Notation Pmax := Pos.max (compat "8.3"). Notation Peqb := Pos.eqb (compat "8.3"). Notation positive_eq_dec := Pos.eq_dec (compat "8.3"). Notation xI_succ_xO := Pos.xI_succ_xO (compat "8.3"). Notation Psucc_discr := Pos.succ_discr (compat "8.3"). Notation Psucc_o_double_minus_one_eq_xO := Pos.succ_pred_double (compat "8.3"). Notation Pdouble_minus_one_o_succ_eq_xI := Pos.pred_double_succ (compat "8.3"). Notation xO_succ_permute := Pos.double_succ (compat "8.3"). Notation double_moins_un_xO_discr := Pos.pred_double_xO_discr (compat "8.3"). Notation Psucc_not_one := Pos.succ_not_1 (compat "8.3"). Notation Ppred_succ := Pos.pred_succ (compat "8.3"). Notation Psucc_pred := Pos.succ_pred_or (compat "8.3"). Notation Psucc_inj := Pos.succ_inj (compat "8.3"). Notation Pplus_carry_spec := Pos.add_carry_spec (compat "8.3"). Notation Pplus_comm := Pos.add_comm (compat "8.3"). Notation Pplus_succ_permute_r := Pos.add_succ_r (compat "8.3"). Notation Pplus_succ_permute_l := Pos.add_succ_l (compat "8.3"). Notation Pplus_no_neutral := Pos.add_no_neutral (compat "8.3"). Notation Pplus_carry_plus := Pos.add_carry_add (compat "8.3"). Notation Pplus_reg_r := Pos.add_reg_r (compat "8.3"). Notation Pplus_reg_l := Pos.add_reg_l (compat "8.3"). Notation Pplus_carry_reg_r := Pos.add_carry_reg_r (compat "8.3"). Notation Pplus_carry_reg_l := Pos.add_carry_reg_l (compat "8.3"). Notation Pplus_assoc := Pos.add_assoc (compat "8.3"). Notation Pplus_xO := Pos.add_xO (compat "8.3"). Notation Pplus_xI_double_minus_one := Pos.add_xI_pred_double (compat "8.3"). Notation Pplus_xO_double_minus_one := Pos.add_xO_pred_double (compat "8.3"). Notation Pplus_diag := Pos.add_diag (compat "8.3"). Notation PeanoView := Pos.PeanoView (compat "8.3"). Notation PeanoOne := Pos.PeanoOne (compat "8.3"). Notation PeanoSucc := Pos.PeanoSucc (compat "8.3"). Notation PeanoView_rect := Pos.PeanoView_rect (compat "8.3"). Notation PeanoView_ind := Pos.PeanoView_ind (compat "8.3"). Notation PeanoView_rec := Pos.PeanoView_rec (compat "8.3"). Notation peanoView_xO := Pos.peanoView_xO (compat "8.3"). Notation peanoView_xI := Pos.peanoView_xI (compat "8.3"). Notation peanoView := Pos.peanoView (compat "8.3"). Notation PeanoView_iter := Pos.PeanoView_iter (compat "8.3"). Notation eq_dep_eq_positive := Pos.eq_dep_eq_positive (compat "8.3"). Notation PeanoViewUnique := Pos.PeanoViewUnique (compat "8.3"). Notation Prect := Pos.peano_rect (compat "8.3"). Notation Prect_succ := Pos.peano_rect_succ (compat "8.3"). Notation Prect_base := Pos.peano_rect_base (compat "8.3"). Notation Prec := Pos.peano_rec (compat "8.3"). Notation Pind := Pos.peano_ind (compat "8.3"). Notation Pcase := Pos.peano_case (compat "8.3"). Notation Pmult_1_r := Pos.mul_1_r (compat "8.3"). Notation Pmult_Sn_m := Pos.mul_succ_l (compat "8.3"). Notation Pmult_xO_permute_r := Pos.mul_xO_r (compat "8.3"). Notation Pmult_xI_permute_r := Pos.mul_xI_r (compat "8.3"). Notation Pmult_comm := Pos.mul_comm (compat "8.3"). Notation Pmult_plus_distr_l := Pos.mul_add_distr_l (compat "8.3"). Notation Pmult_plus_distr_r := Pos.mul_add_distr_r (compat "8.3"). Notation Pmult_assoc := Pos.mul_assoc (compat "8.3"). Notation Pmult_xI_mult_xO_discr := Pos.mul_xI_mul_xO_discr (compat "8.3"). Notation Pmult_xO_discr := Pos.mul_xO_discr (compat "8.3"). Notation Pmult_reg_r := Pos.mul_reg_r (compat "8.3"). Notation Pmult_reg_l := Pos.mul_reg_l (compat "8.3"). Notation Pmult_1_inversion_l := Pos.mul_eq_1_l (compat "8.3"). Notation Psquare_xO := Pos.square_xO (compat "8.3"). Notation Psquare_xI := Pos.square_xI (compat "8.3"). Notation iter_pos_swap_gen := Pos.iter_swap_gen (compat "8.3"). Notation iter_pos_swap := Pos.iter_swap (compat "8.3"). Notation iter_pos_succ := Pos.iter_succ (compat "8.3"). Notation iter_pos_plus := Pos.iter_add (compat "8.3"). Notation iter_pos_invariant := Pos.iter_invariant (compat "8.3"). Notation Ppow_1_r := Pos.pow_1_r (compat "8.3"). Notation Ppow_succ_r := Pos.pow_succ_r (compat "8.3"). Notation Peqb_refl := Pos.eqb_refl (compat "8.3"). Notation Peqb_eq := Pos.eqb_eq (compat "8.3"). Notation Pcompare_refl_id := Pos.compare_cont_refl (compat "8.3"). Notation Pcompare_eq_iff := Pos.compare_eq_iff (compat "8.3"). Notation Pcompare_Gt_Lt := Pos.compare_cont_Gt_Lt (compat "8.3"). Notation Pcompare_eq_Lt := Pos.compare_lt_iff (compat "8.3"). Notation Pcompare_Lt_Gt := Pos.compare_cont_Lt_Gt (compat "8.3"). Notation Pcompare_antisym := Pos.compare_cont_antisym (compat "8.3"). Notation ZC1 := Pos.gt_lt (compat "8.3"). Notation ZC2 := Pos.lt_gt (compat "8.3"). Notation Pcompare_spec := Pos.compare_spec (compat "8.3"). Notation Pcompare_p_Sp := Pos.lt_succ_diag_r (compat "8.3"). Notation Pcompare_succ_succ := Pos.compare_succ_succ (compat "8.3"). Notation Pcompare_1 := Pos.nlt_1_r (compat "8.3"). Notation Plt_1 := Pos.nlt_1_r (compat "8.3"). Notation Plt_1_succ := Pos.lt_1_succ (compat "8.3"). Notation Plt_lt_succ := Pos.lt_lt_succ (compat "8.3"). Notation Plt_irrefl := Pos.lt_irrefl (compat "8.3"). Notation Plt_trans := Pos.lt_trans (compat "8.3"). Notation Plt_ind := Pos.lt_ind (compat "8.3"). Notation Ple_lteq := Pos.le_lteq (compat "8.3"). Notation Ple_refl := Pos.le_refl (compat "8.3"). Notation Ple_lt_trans := Pos.le_lt_trans (compat "8.3"). Notation Plt_le_trans := Pos.lt_le_trans (compat "8.3"). Notation Ple_trans := Pos.le_trans (compat "8.3"). Notation Plt_succ_r := Pos.lt_succ_r (compat "8.3"). Notation Ple_succ_l := Pos.le_succ_l (compat "8.3"). Notation Pplus_compare_mono_l := Pos.add_compare_mono_l (compat "8.3"). Notation Pplus_compare_mono_r := Pos.add_compare_mono_r (compat "8.3"). Notation Pplus_lt_mono_l := Pos.add_lt_mono_l (compat "8.3"). Notation Pplus_lt_mono_r := Pos.add_lt_mono_r (compat "8.3"). Notation Pplus_lt_mono := Pos.add_lt_mono (compat "8.3"). Notation Pplus_le_mono_l := Pos.add_le_mono_l (compat "8.3"). Notation Pplus_le_mono_r := Pos.add_le_mono_r (compat "8.3"). Notation Pplus_le_mono := Pos.add_le_mono (compat "8.3"). Notation Pmult_compare_mono_l := Pos.mul_compare_mono_l (compat "8.3"). Notation Pmult_compare_mono_r := Pos.mul_compare_mono_r (compat "8.3"). Notation Pmult_lt_mono_l := Pos.mul_lt_mono_l (compat "8.3"). Notation Pmult_lt_mono_r := Pos.mul_lt_mono_r (compat "8.3"). Notation Pmult_lt_mono := Pos.mul_lt_mono (compat "8.3"). Notation Pmult_le_mono_l := Pos.mul_le_mono_l (compat "8.3"). Notation Pmult_le_mono_r := Pos.mul_le_mono_r (compat "8.3"). Notation Pmult_le_mono := Pos.mul_le_mono (compat "8.3"). Notation Plt_plus_r := Pos.lt_add_r (compat "8.3"). Notation Plt_not_plus_l := Pos.lt_not_add_l (compat "8.3"). Notation Ppow_gt_1 := Pos.pow_gt_1 (compat "8.3"). Notation Ppred_mask := Pos.pred_mask (compat "8.3"). Notation Pminus_mask_succ_r := Pos.sub_mask_succ_r (compat "8.3"). Notation Pminus_mask_carry_spec := Pos.sub_mask_carry_spec (compat "8.3"). Notation Pminus_succ_r := Pos.sub_succ_r (compat "8.3"). Notation Pminus_mask_diag := Pos.sub_mask_diag (compat "8.3"). Notation Pplus_minus_eq := Pos.add_sub (compat "8.3"). Notation Pmult_minus_distr_l := Pos.mul_sub_distr_l (compat "8.3"). Notation Pminus_lt_mono_l := Pos.sub_lt_mono_l (compat "8.3"). Notation Pminus_compare_mono_l := Pos.sub_compare_mono_l (compat "8.3"). Notation Pminus_compare_mono_r := Pos.sub_compare_mono_r (compat "8.3"). Notation Pminus_lt_mono_r := Pos.sub_lt_mono_r (compat "8.3"). Notation Pminus_decr := Pos.sub_decr (compat "8.3"). Notation Pminus_xI_xI := Pos.sub_xI_xI (compat "8.3"). Notation Pplus_minus_assoc := Pos.add_sub_assoc (compat "8.3"). Notation Pminus_plus_distr := Pos.sub_add_distr (compat "8.3"). Notation Pminus_minus_distr := Pos.sub_sub_distr (compat "8.3"). Notation Pminus_mask_Lt := Pos.sub_mask_neg (compat "8.3"). Notation Pminus_Lt := Pos.sub_lt (compat "8.3"). Notation Pminus_Eq := Pos.sub_diag (compat "8.3"). Notation Psize_monotone := Pos.size_nat_monotone (compat "8.3"). Notation Psize_pos_gt := Pos.size_gt (compat "8.3"). Notation Psize_pos_le := Pos.size_le (compat "8.3"). (** More complex compatibility facts, expressed as lemmas (to preserve scopes for instance) *) Lemma Peqb_true_eq x y : Pos.eqb x y = true -> x=y. Proof. apply Pos.eqb_eq. Qed. Lemma Pcompare_eq_Gt p q : (p ?= q) = Gt <-> p > q. Proof. reflexivity. Qed. Lemma Pplus_one_succ_r p : Pos.succ p = p + 1. Proof (eq_sym (Pos.add_1_r p)). Lemma Pplus_one_succ_l p : Pos.succ p = 1 + p. Proof (eq_sym (Pos.add_1_l p)). Lemma Pcompare_refl p : Pos.compare_cont p p Eq = Eq. Proof (Pos.compare_cont_refl p Eq). Lemma Pcompare_Eq_eq : forall p q, Pos.compare_cont p q Eq = Eq -> p = q. Proof Pos.compare_eq. Lemma ZC4 p q : Pos.compare_cont p q Eq = CompOpp (Pos.compare_cont q p Eq). Proof (Pos.compare_antisym q p). Lemma Ppred_minus p : Pos.pred p = p - 1. Proof (eq_sym (Pos.sub_1_r p)). Lemma Pminus_mask_Gt p q : p > q -> exists h : positive, Pos.sub_mask p q = IsPos h /\ q + h = p /\ (h = 1 \/ Pos.sub_mask_carry p q = IsPos (Pos.pred h)). Proof. intros H. apply Pos.gt_lt in H. destruct (Pos.sub_mask_pos p q H) as (r & U). exists r. repeat split; trivial. now apply Pos.sub_mask_pos_iff. destruct (Pos.eq_dec r 1) as [EQ|NE]; [now left|right]. rewrite Pos.sub_mask_carry_spec, U. destruct r; trivial. now elim NE. Qed. Lemma Pplus_minus : forall p q, p > q -> q+(p-q) = p. Proof. intros. rewrite Pos.add_comm. now apply Pos.sub_add, Pos.gt_lt. Qed. (** Discontinued results of little interest and little/zero use in user contributions: Pplus_carry_no_neutral Pplus_carry_pred_eq_plus Pcompare_not_Eq Pcompare_Lt_Lt Pcompare_Lt_eq_Lt Pcompare_Gt_Gt Pcompare_Gt_eq_Gt Psucc_lt_compat Psucc_le_compat ZC3 Pcompare_p_Sq Pminus_mask_carry_diag Pminus_mask_IsNeg ZL10 ZL11 double_eq_zero_inversion double_plus_one_zero_discr double_plus_one_eq_one_inversion double_eq_one_discr Infix "/" := Pdiv2 : positive_scope. *) (** Old stuff, to remove someday *) Lemma Dcompare : forall r:comparison, r = Eq \/ r = Lt \/ r = Gt. Proof. destruct r; auto. Qed. (** Incompatibilities : - [(_ ?= _)%positive] expects no arg now, and designates [Pos.compare] which is convertible but syntactically distinct to [Pos.compare_cont .. .. Eq]. - [Pmult_nat] cannot be unfolded (unfold [Pos.iter_op] instead). *) coq-8.4pl4/theories/PArith/intro.tex0000644000175000017500000000024012326224777016515 0ustar stephsteph\section{Binary positive integers : PArith}\label{PArith} Here are defined various arithmetical notions and their properties, similar to those of {\tt Arith}. coq-8.4pl4/theories/PArith/BinPosDef.v0000644000175000017500000003217412326224777016653 0ustar stephsteph(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (succ p)~0 | p~0 => p~1 | 1 => 1~0 end. (** ** Addition *) Fixpoint add x y := match x, y with | p~1, q~1 => (add_carry p q)~0 | p~1, q~0 => (add p q)~1 | p~1, 1 => (succ p)~0 | p~0, q~1 => (add p q)~1 | p~0, q~0 => (add p q)~0 | p~0, 1 => p~1 | 1, q~1 => (succ q)~0 | 1, q~0 => q~1 | 1, 1 => 1~0 end with add_carry x y := match x, y with | p~1, q~1 => (add_carry p q)~1 | p~1, q~0 => (add_carry p q)~0 | p~1, 1 => (succ p)~1 | p~0, q~1 => (add_carry p q)~0 | p~0, q~0 => (add p q)~1 | p~0, 1 => (succ p)~0 | 1, q~1 => (succ q)~1 | 1, q~0 => (succ q)~0 | 1, 1 => 1~1 end. Infix "+" := add : positive_scope. (** ** Operation [x -> 2*x-1] *) Fixpoint pred_double x := match x with | p~1 => p~0~1 | p~0 => (pred_double p)~1 | 1 => 1 end. (** ** Predecessor *) Definition pred x := match x with | p~1 => p~0 | p~0 => pred_double p | 1 => 1 end. (** ** The predecessor of a positive number can be seen as a [N] *) Definition pred_N x := match x with | p~1 => Npos (p~0) | p~0 => Npos (pred_double p) | 1 => N0 end. (** ** An auxiliary type for subtraction *) Inductive mask : Set := | IsNul : mask | IsPos : positive -> mask | IsNeg : mask. (** ** Operation [x -> 2*x+1] *) Definition succ_double_mask (x:mask) : mask := match x with | IsNul => IsPos 1 | IsNeg => IsNeg | IsPos p => IsPos p~1 end. (** ** Operation [x -> 2*x] *) Definition double_mask (x:mask) : mask := match x with | IsNul => IsNul | IsNeg => IsNeg | IsPos p => IsPos p~0 end. (** ** Operation [x -> 2*x-2] *) Definition double_pred_mask x : mask := match x with | p~1 => IsPos p~0~0 | p~0 => IsPos (pred_double p)~0 | 1 => IsNul end. (** ** Predecessor with mask *) Definition pred_mask (p : mask) : mask := match p with | IsPos 1 => IsNul | IsPos q => IsPos (pred q) | IsNul => IsNeg | IsNeg => IsNeg end. (** ** Subtraction, result as a mask *) Fixpoint sub_mask (x y:positive) {struct y} : mask := match x, y with | p~1, q~1 => double_mask (sub_mask p q) | p~1, q~0 => succ_double_mask (sub_mask p q) | p~1, 1 => IsPos p~0 | p~0, q~1 => succ_double_mask (sub_mask_carry p q) | p~0, q~0 => double_mask (sub_mask p q) | p~0, 1 => IsPos (pred_double p) | 1, 1 => IsNul | 1, _ => IsNeg end with sub_mask_carry (x y:positive) {struct y} : mask := match x, y with | p~1, q~1 => succ_double_mask (sub_mask_carry p q) | p~1, q~0 => double_mask (sub_mask p q) | p~1, 1 => IsPos (pred_double p) | p~0, q~1 => double_mask (sub_mask_carry p q) | p~0, q~0 => succ_double_mask (sub_mask_carry p q) | p~0, 1 => double_pred_mask p | 1, _ => IsNeg end. (** ** Subtraction, result as a positive, returning 1 if [x<=y] *) Definition sub x y := match sub_mask x y with | IsPos z => z | _ => 1 end. Infix "-" := sub : positive_scope. (** ** Multiplication *) Fixpoint mul x y := match x with | p~1 => y + (mul p y)~0 | p~0 => (mul p y)~0 | 1 => y end. Infix "*" := mul : positive_scope. (** ** Iteration over a positive number *) Fixpoint iter (n:positive) {A} (f:A -> A) (x:A) : A := match n with | xH => f x | xO n' => iter n' f (iter n' f x) | xI n' => f (iter n' f (iter n' f x)) end. (** ** Power *) Definition pow (x y:positive) := iter y (mul x) 1. Infix "^" := pow : positive_scope. (** ** Square *) Fixpoint square p := match p with | p~1 => (square p + p)~0~1 | p~0 => (square p)~0~0 | 1 => 1 end. (** ** Division by 2 rounded below but for 1 *) Definition div2 p := match p with | 1 => 1 | p~0 => p | p~1 => p end. (** Division by 2 rounded up *) Definition div2_up p := match p with | 1 => 1 | p~0 => p | p~1 => succ p end. (** ** Number of digits in a positive number *) Fixpoint size_nat p : nat := match p with | 1 => S O | p~1 => S (size_nat p) | p~0 => S (size_nat p) end. (** Same, with positive output *) Fixpoint size p := match p with | 1 => 1 | p~1 => succ (size p) | p~0 => succ (size p) end. (** ** Comparison on binary positive numbers *) Fixpoint compare_cont (x y:positive) (r:comparison) {struct y} : comparison := match x, y with | p~1, q~1 => compare_cont p q r | p~1, q~0 => compare_cont p q Gt | p~1, 1 => Gt | p~0, q~1 => compare_cont p q Lt | p~0, q~0 => compare_cont p q r | p~0, 1 => Gt | 1, q~1 => Lt | 1, q~0 => Lt | 1, 1 => r end. Definition compare x y := compare_cont x y Eq. Infix "?=" := compare (at level 70, no associativity) : positive_scope. Definition min p p' := match p ?= p' with | Lt | Eq => p | Gt => p' end. Definition max p p' := match p ?= p' with | Lt | Eq => p' | Gt => p end. (** ** Boolean equality and comparisons *) Fixpoint eqb p q {struct q} := match p, q with | p~1, q~1 => eqb p q | p~0, q~0 => eqb p q | 1, 1 => true | _, _ => false end. Definition leb x y := match x ?= y with Gt => false | _ => true end. Definition ltb x y := match x ?= y with Lt => true | _ => false end. Infix "=?" := eqb (at level 70, no associativity) : positive_scope. Infix "<=?" := leb (at level 70, no associativity) : positive_scope. Infix "positive) p := match p with | (s, IsPos r) => let s' := s~0~1 in let r' := g (f r) in if s' <=? r' then (s~1, sub_mask r' s') else (s~0, IsPos r') | (s,_) => (s~0, sub_mask (g (f 1)) 4) end. Fixpoint sqrtrem p : positive * mask := match p with | 1 => (1,IsNul) | 2 => (1,IsPos 1) | 3 => (1,IsPos 2) | p~0~0 => sqrtrem_step xO xO (sqrtrem p) | p~0~1 => sqrtrem_step xO xI (sqrtrem p) | p~1~0 => sqrtrem_step xI xO (sqrtrem p) | p~1~1 => sqrtrem_step xI xI (sqrtrem p) end. Definition sqrt p := fst (sqrtrem p). (** ** Greatest Common Divisor *) Definition divide p q := exists r, q = r*p. Notation "( p | q )" := (divide p q) (at level 0) : positive_scope. (** Instead of the Euclid algorithm, we use here the Stein binary algorithm, which is faster for this representation. This algorithm is almost structural, but in the last cases we do some recursive calls on subtraction, hence the need for a counter. *) Fixpoint gcdn (n : nat) (a b : positive) : positive := match n with | O => 1 | S n => match a,b with | 1, _ => 1 | _, 1 => 1 | a~0, b~0 => (gcdn n a b)~0 | _ , b~0 => gcdn n a b | a~0, _ => gcdn n a b | a'~1, b'~1 => match a' ?= b' with | Eq => a | Lt => gcdn n (b'-a') a | Gt => gcdn n (a'-b') b end end end. (** We'll show later that we need at most (log2(a.b)) loops *) Definition gcd (a b : positive) := gcdn (size_nat a + size_nat b)%nat a b. (** Generalized Gcd, also computing the division of a and b by the gcd *) Fixpoint ggcdn (n : nat) (a b : positive) : (positive*(positive*positive)) := match n with | O => (1,(a,b)) | S n => match a,b with | 1, _ => (1,(1,b)) | _, 1 => (1,(a,1)) | a~0, b~0 => let (g,p) := ggcdn n a b in (g~0,p) | _, b~0 => let '(g,(aa,bb)) := ggcdn n a b in (g,(aa, bb~0)) | a~0, _ => let '(g,(aa,bb)) := ggcdn n a b in (g,(aa~0, bb)) | a'~1, b'~1 => match a' ?= b' with | Eq => (a,(1,1)) | Lt => let '(g,(ba,aa)) := ggcdn n (b'-a') a in (g,(aa, aa + ba~0)) | Gt => let '(g,(ab,bb)) := ggcdn n (a'-b') b in (g,(bb + ab~0, bb)) end end end. Definition ggcd (a b: positive) := ggcdn (size_nat a + size_nat b)%nat a b. (** Local copies of the not-yet-available [N.double] and [N.succ_double] *) Definition Nsucc_double x := match x with | N0 => Npos 1 | Npos p => Npos p~1 end. Definition Ndouble n := match n with | N0 => N0 | Npos p => Npos p~0 end. (** Operation over bits. *) (** Logical [or] *) Fixpoint lor (p q : positive) : positive := match p, q with | 1, q~0 => q~1 | 1, _ => q | p~0, 1 => p~1 | _, 1 => p | p~0, q~0 => (lor p q)~0 | p~0, q~1 => (lor p q)~1 | p~1, q~0 => (lor p q)~1 | p~1, q~1 => (lor p q)~1 end. (** Logical [and] *) Fixpoint land (p q : positive) : N := match p, q with | 1, q~0 => N0 | 1, _ => Npos 1 | p~0, 1 => N0 | _, 1 => Npos 1 | p~0, q~0 => Ndouble (land p q) | p~0, q~1 => Ndouble (land p q) | p~1, q~0 => Ndouble (land p q) | p~1, q~1 => Nsucc_double (land p q) end. (** Logical [diff] *) Fixpoint ldiff (p q:positive) : N := match p, q with | 1, q~0 => Npos 1 | 1, _ => N0 | _~0, 1 => Npos p | p~1, 1 => Npos (p~0) | p~0, q~0 => Ndouble (ldiff p q) | p~0, q~1 => Ndouble (ldiff p q) | p~1, q~1 => Ndouble (ldiff p q) | p~1, q~0 => Nsucc_double (ldiff p q) end. (** [xor] *) Fixpoint lxor (p q:positive) : N := match p, q with | 1, 1 => N0 | 1, q~0 => Npos (q~1) | 1, q~1 => Npos (q~0) | p~0, 1 => Npos (p~1) | p~0, q~0 => Ndouble (lxor p q) | p~0, q~1 => Nsucc_double (lxor p q) | p~1, 1 => Npos (p~0) | p~1, q~0 => Nsucc_double (lxor p q) | p~1, q~1 => Ndouble (lxor p q) end. (** Shifts. NB: right shift of 1 stays at 1. *) Definition shiftl_nat (p:positive)(n:nat) := nat_iter n xO p. Definition shiftr_nat (p:positive)(n:nat) := nat_iter n div2 p. Definition shiftl (p:positive)(n:N) := match n with | N0 => p | Npos n => iter n xO p end. Definition shiftr (p:positive)(n:N) := match n with | N0 => p | Npos n => iter n div2 p end. (** Checking whether a particular bit is set or not *) Fixpoint testbit_nat (p:positive) : nat -> bool := match p with | 1 => fun n => match n with | O => true | S _ => false end | p~0 => fun n => match n with | O => false | S n' => testbit_nat p n' end | p~1 => fun n => match n with | O => true | S n' => testbit_nat p n' end end. (** Same, but with index in N *) Fixpoint testbit (p:positive)(n:N) := match p, n with | p~0, N0 => false | _, N0 => true | 1, _ => false | p~0, Npos n => testbit p (pred_N n) | p~1, Npos n => testbit p (pred_N n) end. (** ** From binary positive numbers to Peano natural numbers *) Definition iter_op {A}(op:A->A->A) := fix iter (p:positive)(a:A) : A := match p with | 1 => a | p~0 => iter p (op a a) | p~1 => op a (iter p (op a a)) end. Definition to_nat (x:positive) : nat := iter_op plus x (S O). (** ** From Peano natural numbers to binary positive numbers *) (** A version preserving positive numbers, and sending 0 to 1. *) Fixpoint of_nat (n:nat) : positive := match n with | O => 1 | S O => 1 | S x => succ (of_nat x) end. (* Another version that converts [n] into [n+1] *) Fixpoint of_succ_nat (n:nat) : positive := match n with | O => 1 | S x => succ (of_succ_nat x) end. End Pos.coq-8.4pl4/theories/Strings/0000755000175000017500000000000012365131022015065 5ustar stephstephcoq-8.4pl4/theories/Strings/vo.itarget0000644000175000017500000000002312326224777017106 0ustar stephstephAscii.vo String.vo coq-8.4pl4/theories/Strings/Ascii.v0000644000175000017500000001030112326224777016320 0ustar stephsteph(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Ascii c a1 a2 a3 a4 a5 a6 a7 end. (** Definition of a decidable function that is effective *) Definition ascii_dec : forall a b : ascii, {a = b} + {a <> b}. decide equality; apply bool_dec. Defined. (** * Conversion between natural numbers modulo 256 and ascii characters *) (** Auxillary function that turns a positive into an ascii by looking at the last 8 bits, ie z mod 2^8 *) Definition ascii_of_pos : positive -> ascii := let loop := fix loop n p := match n with | O => zero | S n' => match p with | xH => one | xI p' => shift true (loop n' p') | xO p' => shift false (loop n' p') end end in loop 8. (** Conversion from [N] to [ascii] *) Definition ascii_of_N (n : N) := match n with | N0 => zero | Npos p => ascii_of_pos p end. (** Same for [nat] *) Definition ascii_of_nat (a : nat) := ascii_of_N (N.of_nat a). (** The opposite functions *) Local Open Scope list_scope. Fixpoint N_of_digits (l:list bool) : N := match l with | nil => 0 | b :: l' => (if b then 1 else 0) + 2*(N_of_digits l') end%N. Definition N_of_ascii (a : ascii) : N := let (a0,a1,a2,a3,a4,a5,a6,a7) := a in N_of_digits (a0::a1::a2::a3::a4::a5::a6::a7::nil). Definition nat_of_ascii (a : ascii) : nat := N.to_nat (N_of_ascii a). (** Proofs that we have indeed opposite function (below 256) *) Theorem ascii_N_embedding : forall a : ascii, ascii_of_N (N_of_ascii a) = a. Proof. destruct a as [[|][|][|][|][|][|][|][|]]; vm_compute; reflexivity. Qed. Theorem N_ascii_embedding : forall n:N, (n < 256)%N -> N_of_ascii (ascii_of_N n) = n. Proof. destruct n. reflexivity. do 8 (destruct p; [ | | intros; vm_compute; reflexivity ]); intro H; vm_compute in H; destruct p; discriminate. Qed. Theorem ascii_nat_embedding : forall a : ascii, ascii_of_nat (nat_of_ascii a) = a. Proof. destruct a as [[|][|][|][|][|][|][|][|]]; compute; reflexivity. Qed. Theorem nat_ascii_embedding : forall n : nat, n < 256 -> nat_of_ascii (ascii_of_nat n) = n. Proof. intros. unfold nat_of_ascii, ascii_of_nat. rewrite N_ascii_embedding. apply Nat2N.id. unfold N.lt. change 256%N with (N.of_nat 256). rewrite <- Nat2N.inj_compare. rewrite <- Compare_dec.nat_compare_lt. auto. Qed. (** * Concrete syntax *) (** Ascii characters can be represented in scope char_scope as follows: - ["c"] represents itself if c is a character of code < 128, - [""""] is an exception: it represents the ascii character 34 (double quote), - ["nnn"] represents the ascii character of decimal code nnn. For instance, both ["065"] and ["A"] denote the character `uppercase A', and both ["034"] and [""""] denote the character `double quote'. Notice that the ascii characters of code >= 128 do not denote stand-alone utf8 characters so that only the notation "nnn" is available for them (unless your terminal is able to represent them, which is typically not the case in coqide). *) Local Open Scope char_scope. Example Space := " ". Example DoubleQuote := """". Example Beep := "007". coq-8.4pl4/theories/Strings/String.v0000644000175000017500000002666212326224777016557 0ustar stephsteph(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string -> string. Delimit Scope string_scope with string. Bind Scope string_scope with string. Local Open Scope string_scope. (** Equality is decidable *) Definition string_dec : forall s1 s2 : string, {s1 = s2} + {s1 <> s2}. decide equality; apply ascii_dec. Defined. (** *** Concatenation of strings *) Reserved Notation "x ++ y" (right associativity, at level 60). Fixpoint append (s1 s2 : string) : string := match s1 with | EmptyString => s2 | String c s1' => String c (s1' ++ s2) end where "s1 ++ s2" := (append s1 s2) : string_scope. (******************************) (** Length *) (******************************) Fixpoint length (s : string) : nat := match s with | EmptyString => 0 | String c s' => S (length s') end. (******************************) (** Nth character of a string *) (******************************) Fixpoint get (n : nat) (s : string) {struct s} : option ascii := match s with | EmptyString => None | String c s' => match n with | O => Some c | S n' => get n' s' end end. (** Two lists that are identical through get are syntactically equal *) Theorem get_correct : forall s1 s2 : string, (forall n : nat, get n s1 = get n s2) <-> s1 = s2. Proof. intros s1; elim s1; simpl. intros s2; case s2; simpl; split; auto. intros H; generalize (H 0); intros H1; inversion H1. intros; discriminate. intros a s1' Rec s2; case s2; simpl; split; auto. intros H; generalize (H 0); intros H1; inversion H1. intros; discriminate. intros H; generalize (H 0); simpl; intros H1; inversion H1. case (Rec s). intros H0; rewrite H0; auto. intros n; exact (H (S n)). intros H; injection H; intros H1 H2 n; case n; auto. rewrite H2; trivial. rewrite H1; auto. Qed. (** The first elements of [s1 ++ s2] are the ones of [s1] *) Theorem append_correct1 : forall (s1 s2 : string) (n : nat), n < length s1 -> get n s1 = get n (s1 ++ s2). Proof. intros s1; elim s1; simpl; auto. intros s2 n H; inversion H. intros a s1' Rec s2 n; case n; simpl; auto. intros n0 H; apply Rec; auto. apply lt_S_n; auto. Qed. (** The last elements of [s1 ++ s2] are the ones of [s2] *) Theorem append_correct2 : forall (s1 s2 : string) (n : nat), get n s2 = get (n + length s1) (s1 ++ s2). Proof. intros s1; elim s1; simpl; auto. intros s2 n; rewrite plus_comm; simpl; auto. intros a s1' Rec s2 n; case n; simpl; auto. generalize (Rec s2 0); simpl; auto. intros. rewrite <- Plus.plus_Snm_nSm; auto. Qed. (** *** Substrings *) (** [substring n m s] returns the substring of [s] that starts at position [n] and of length [m]; if this does not make sense it returns [""] *) Fixpoint substring (n m : nat) (s : string) : string := match n, m, s with | 0, 0, _ => EmptyString | 0, S m', EmptyString => s | 0, S m', String c s' => String c (substring 0 m' s') | S n', _, EmptyString => s | S n', _, String c s' => substring n' m s' end. (** The substring is included in the initial string *) Theorem substring_correct1 : forall (s : string) (n m p : nat), p < m -> get p (substring n m s) = get (p + n) s. Proof. intros s; elim s; simpl; auto. intros n; case n; simpl; auto. intros m; case m; simpl; auto. intros a s' Rec; intros n; case n; simpl; auto. intros m; case m; simpl; auto. intros p H; inversion H. intros m' p; case p; simpl; auto. intros n0 H; apply Rec; simpl; auto. apply Lt.lt_S_n; auto. intros n' m p H; rewrite <- Plus.plus_Snm_nSm; simpl; auto. Qed. (** The substring has at most [m] elements *) Theorem substring_correct2 : forall (s : string) (n m p : nat), m <= p -> get p (substring n m s) = None. Proof. intros s; elim s; simpl; auto. intros n; case n; simpl; auto. intros m; case m; simpl; auto. intros a s' Rec; intros n; case n; simpl; auto. intros m; case m; simpl; auto. intros m' p; case p; simpl; auto. intros H; inversion H. intros n0 H; apply Rec; simpl; auto. apply Le.le_S_n; auto. Qed. (** *** Test functions *) (** Test if [s1] is a prefix of [s2] *) Fixpoint prefix (s1 s2 : string) {struct s2} : bool := match s1 with | EmptyString => true | String a s1' => match s2 with | EmptyString => false | String b s2' => match ascii_dec a b with | left _ => prefix s1' s2' | right _ => false end end end. (** If [s1] is a prefix of [s2], it is the [substring] of length [length s1] starting at position [O] of [s2] *) Theorem prefix_correct : forall s1 s2 : string, prefix s1 s2 = true <-> substring 0 (length s1) s2 = s1. Proof. intros s1; elim s1; simpl; auto. intros s2; case s2; simpl; split; auto. intros a s1' Rec s2; case s2; simpl; auto. split; intros; discriminate. intros b s2'; case (ascii_dec a b); simpl; auto. intros e; case (Rec s2'); intros H1 H2; split; intros H3; auto. rewrite e; rewrite H1; auto. apply H2; injection H3; auto. intros n; split; intros; try discriminate. case n; injection H; auto. Qed. (** Test if, starting at position [n], [s1] occurs in [s2]; if so it returns the position *) Fixpoint index (n : nat) (s1 s2 : string) : option nat := match s2, n with | EmptyString, 0 => match s1 with | EmptyString => Some 0 | String a s1' => None end | EmptyString, S n' => None | String b s2', 0 => if prefix s1 s2 then Some 0 else match index 0 s1 s2' with | Some n => Some (S n) | None => None end | String b s2', S n' => match index n' s1 s2' with | Some n => Some (S n) | None => None end end. (* Dirty trick to avoid locally that prefix reduces itself *) Opaque prefix. (** If the result of [index] is [Some m], [s1] in [s2] at position [m] *) Theorem index_correct1 : forall (n m : nat) (s1 s2 : string), index n s1 s2 = Some m -> substring m (length s1) s2 = s1. Proof. intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl; auto. intros n; case n; simpl; auto. intros m s1; case s1; simpl; auto. intros H; injection H; intros H1; rewrite <- H1; auto. intros; discriminate. intros; discriminate. intros b s2' Rec n m s1. case n; simpl; auto. generalize (prefix_correct s1 (String b s2')); case (prefix s1 (String b s2')). intros H0 H; injection H; intros H1; rewrite <- H1; auto. case H0; simpl; auto. case m; simpl; auto. case (index 0 s1 s2'); intros; discriminate. intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto. intros x H H0 H1; apply H; injection H1; auto. intros; discriminate. intros n'; case m; simpl; auto. case (index n' s1 s2'); intros; discriminate. intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto. intros x H H1; apply H; injection H1; auto. intros; discriminate. Qed. (** If the result of [index] is [Some m], [s1] does not occur in [s2] before [m] *) Theorem index_correct2 : forall (n m : nat) (s1 s2 : string), index n s1 s2 = Some m -> forall p : nat, n <= p -> p < m -> substring p (length s1) s2 <> s1. Proof. intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl; auto. intros n; case n; simpl; auto. intros m s1; case s1; simpl; auto. intros H; injection H; intros H1; rewrite <- H1. intros p H0 H2; inversion H2. intros; discriminate. intros; discriminate. intros b s2' Rec n m s1. case n; simpl; auto. generalize (prefix_correct s1 (String b s2')); case (prefix s1 (String b s2')). intros H0 H; injection H; intros H1; rewrite <- H1; auto. intros p H2 H3; inversion H3. case m; simpl; auto. case (index 0 s1 s2'); intros; discriminate. intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto. intros x H H0 H1 p; try case p; simpl; auto. intros H2 H3; red; intros H4; case H0. intros H5 H6; absurd (false = true); auto with bool. intros n0 H2 H3; apply H; auto. injection H1; auto. apply Le.le_O_n. apply Lt.lt_S_n; auto. intros; discriminate. intros n'; case m; simpl; auto. case (index n' s1 s2'); intros; discriminate. intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto. intros x H H0 p; case p; simpl; auto. intros H1; inversion H1; auto. intros n0 H1 H2; apply H; auto. injection H0; auto. apply Le.le_S_n; auto. apply Lt.lt_S_n; auto. intros; discriminate. Qed. (** If the result of [index] is [None], [s1] does not occur in [s2] after [n] *) Theorem index_correct3 : forall (n m : nat) (s1 s2 : string), index n s1 s2 = None -> s1 <> EmptyString -> n <= m -> substring m (length s1) s2 <> s1. Proof. intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl; auto. intros n; case n; simpl; auto. intros m s1; case s1; simpl; auto. case m; intros; red; intros; discriminate. intros n' m; case m; auto. intros s1; case s1; simpl; auto. intros b s2' Rec n m s1. case n; simpl; auto. generalize (prefix_correct s1 (String b s2')); case (prefix s1 (String b s2')). intros; discriminate. case m; simpl; auto with bool. case s1; simpl; auto. intros a s H H0 H1 H2; red; intros H3; case H. intros H4 H5; absurd (false = true); auto with bool. case s1; simpl; auto. intros a s n0 H H0 H1 H2; change (substring n0 (length (String a s)) s2' <> String a s); apply (Rec 0); auto. generalize H0; case (index 0 (String a s) s2'); simpl; auto; intros; discriminate. apply Le.le_O_n. intros n'; case m; simpl; auto. intros H H0 H1; inversion H1. intros n0 H H0 H1; apply (Rec n'); auto. generalize H; case (index n' s1 s2'); simpl; auto; intros; discriminate. apply Le.le_S_n; auto. Qed. (* Back to normal for prefix *) Transparent prefix. (** If we are searching for the [Empty] string and the answer is no this means that [n] is greater than the size of [s] *) Theorem index_correct4 : forall (n : nat) (s : string), index n EmptyString s = None -> length s < n. Proof. intros n s; generalize n; clear n; elim s; simpl; auto. intros n; case n; simpl; auto. intros; discriminate. intros; apply Lt.lt_O_Sn. intros a s' H n; case n; simpl; auto. intros; discriminate. intros n'; generalize (H n'); case (index n' EmptyString s'); simpl; auto. intros; discriminate. intros H0 H1; apply Lt.lt_n_S; auto. Qed. (** Same as [index] but with no optional type, we return [0] when it does not occur *) Definition findex n s1 s2 := match index n s1 s2 with | Some n => n | None => 0 end. (** *** Concrete syntax *) (** The concrete syntax for strings in scope string_scope follows the Coq convention for strings: all ascii characters of code less than 128 are litteral to the exception of the character `double quote' which must be doubled. Strings that involve ascii characters of code >= 128 which are not part of a valid utf8 sequence of characters are not representable using the Coq string notation (use explicitly the String constructor with the ascii codes of the characters). *) Example HelloWorld := " ""Hello world!"" ". coq-8.4pl4/theories/Relations/0000755000175000017500000000000012365131022015374 5ustar stephstephcoq-8.4pl4/theories/Relations/Operators_Properties.v0000644000175000017500000002766012326224777022011 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* clos_trans R x y. Proof. induction 1. left; assumption. right with y; auto. left; auto. Qed. Lemma clos_trans_t1n : forall x y, clos_trans R x y -> clos_trans_1n R x y. Proof. induction 1. left; assumption. generalize IHclos_trans2; clear IHclos_trans2; induction IHclos_trans1. right with y; auto. right with y; auto. eapply IHIHclos_trans1; auto. apply clos_t1n_trans; auto. Qed. Lemma clos_trans_t1n_iff : forall x y, clos_trans R x y <-> clos_trans_1n R x y. Proof. split. apply clos_trans_t1n. apply clos_t1n_trans. Qed. (** Direct transitive closure vs right-step extension *) Lemma clos_tn1_trans : forall x y, clos_trans_n1 R x y -> clos_trans R x y. Proof. induction 1. left; assumption. right with y; auto. left; assumption. Qed. Lemma clos_trans_tn1 : forall x y, clos_trans R x y -> clos_trans_n1 R x y. Proof. induction 1. left; assumption. elim IHclos_trans2. intro y0; right with y. auto. auto. intros. right with y0; auto. Qed. Lemma clos_trans_tn1_iff : forall x y, clos_trans R x y <-> clos_trans_n1 R x y. Proof. split. apply clos_trans_tn1. apply clos_tn1_trans. Qed. (** Direct reflexive-transitive closure is equivalent to transitivity by left-step extension *) Lemma clos_rt1n_step : forall x y, R x y -> clos_refl_trans_1n R x y. Proof. intros x y H. right with y;[assumption|left]. Qed. Lemma clos_rtn1_step : forall x y, R x y -> clos_refl_trans_n1 R x y. Proof. intros x y H. right with x;[assumption|left]. Qed. Lemma clos_rt1n_rt : forall x y, clos_refl_trans_1n R x y -> clos_refl_trans R x y. Proof. induction 1. constructor 2. constructor 3 with y; auto. constructor 1; auto. Qed. Lemma clos_rt_rt1n : forall x y, clos_refl_trans R x y -> clos_refl_trans_1n R x y. Proof. induction 1. apply clos_rt1n_step; assumption. left. generalize IHclos_refl_trans2; clear IHclos_refl_trans2; induction IHclos_refl_trans1; auto. right with y; auto. eapply IHIHclos_refl_trans1; auto. apply clos_rt1n_rt; auto. Qed. Lemma clos_rt_rt1n_iff : forall x y, clos_refl_trans R x y <-> clos_refl_trans_1n R x y. Proof. split. apply clos_rt_rt1n. apply clos_rt1n_rt. Qed. (** Direct reflexive-transitive closure is equivalent to transitivity by right-step extension *) Lemma clos_rtn1_rt : forall x y, clos_refl_trans_n1 R x y -> clos_refl_trans R x y. Proof. induction 1. constructor 2. constructor 3 with y; auto. constructor 1; assumption. Qed. Lemma clos_rt_rtn1 : forall x y, clos_refl_trans R x y -> clos_refl_trans_n1 R x y. Proof. induction 1. apply clos_rtn1_step; auto. left. elim IHclos_refl_trans2; auto. intros. right with y0; auto. Qed. Lemma clos_rt_rtn1_iff : forall x y, clos_refl_trans R x y <-> clos_refl_trans_n1 R x y. Proof. split. apply clos_rt_rtn1. apply clos_rtn1_rt. Qed. (** Induction on the left transitive step *) Lemma clos_refl_trans_ind_left : forall (x:A) (P:A -> Prop), P x -> (forall y z:A, clos_refl_trans R x y -> P y -> R y z -> P z) -> forall z:A, clos_refl_trans R x z -> P z. Proof. intros. revert H H0. induction H1; intros; auto with sets. apply H1 with x; auto with sets. apply IHclos_refl_trans2. apply IHclos_refl_trans1; auto with sets. intros. apply H0 with y0; auto with sets. apply rt_trans with y; auto with sets. Qed. (** Induction on the right transitive step *) Lemma rt1n_ind_right : forall (P : A -> Prop) (z:A), P z -> (forall x y, R x y -> clos_refl_trans_1n R y z -> P y -> P x) -> forall x, clos_refl_trans_1n R x z -> P x. induction 3; auto. apply H0 with y; auto. Qed. Lemma clos_refl_trans_ind_right : forall (P : A -> Prop) (z:A), P z -> (forall x y, R x y -> P y -> clos_refl_trans R y z -> P x) -> forall x, clos_refl_trans R x z -> P x. intros P z Hz IH x Hxz. apply clos_rt_rt1n_iff in Hxz. elim Hxz using rt1n_ind_right; auto. clear x Hxz. intros x y Hxy Hyz Hy. apply clos_rt_rt1n_iff in Hyz. eauto. Qed. (** Direct reflexive-symmetric-transitive closure is equivalent to transitivity by symmetric left-step extension *) Lemma clos_rst1n_rst : forall x y, clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans R x y. Proof. induction 1. constructor 2. constructor 4 with y; auto. case H;[constructor 1|constructor 3; constructor 1]; auto. Qed. Lemma clos_rst1n_trans : forall x y z, clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans_1n R y z -> clos_refl_sym_trans_1n R x z. induction 1. auto. intros; right with y; eauto. Qed. Lemma clos_rst1n_sym : forall x y, clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans_1n R y x. Proof. intros x y H; elim H. constructor 1. intros x0 y0 z D H0 H1; apply clos_rst1n_trans with y0; auto. right with x0. tauto. left. Qed. Lemma clos_rst_rst1n : forall x y, clos_refl_sym_trans R x y -> clos_refl_sym_trans_1n R x y. induction 1. constructor 2 with y; auto. constructor 1. constructor 1. apply clos_rst1n_sym; auto. eapply clos_rst1n_trans; eauto. Qed. Lemma clos_rst_rst1n_iff : forall x y, clos_refl_sym_trans R x y <-> clos_refl_sym_trans_1n R x y. Proof. split. apply clos_rst_rst1n. apply clos_rst1n_rst. Qed. (** Direct reflexive-symmetric-transitive closure is equivalent to transitivity by symmetric right-step extension *) Lemma clos_rstn1_rst : forall x y, clos_refl_sym_trans_n1 R x y -> clos_refl_sym_trans R x y. Proof. induction 1. constructor 2. constructor 4 with y; auto. case H;[constructor 1|constructor 3; constructor 1]; auto. Qed. Lemma clos_rstn1_trans : forall x y z, clos_refl_sym_trans_n1 R x y -> clos_refl_sym_trans_n1 R y z -> clos_refl_sym_trans_n1 R x z. Proof. intros x y z H1 H2. induction H2. auto. intros. right with y0; eauto. Qed. Lemma clos_rstn1_sym : forall x y, clos_refl_sym_trans_n1 R x y -> clos_refl_sym_trans_n1 R y x. Proof. intros x y H; elim H. constructor 1. intros y0 z D H0 H1. apply clos_rstn1_trans with y0; auto. right with z. tauto. left. Qed. Lemma clos_rst_rstn1 : forall x y, clos_refl_sym_trans R x y -> clos_refl_sym_trans_n1 R x y. Proof. induction 1. constructor 2 with x; auto. constructor 1. constructor 1. apply clos_rstn1_sym; auto. eapply clos_rstn1_trans; eauto. Qed. Lemma clos_rst_rstn1_iff : forall x y, clos_refl_sym_trans R x y <-> clos_refl_sym_trans_n1 R x y. Proof. split. apply clos_rst_rstn1. apply clos_rstn1_rst. Qed. End Equivalences. End Properties. (* begin hide *) (* Compatibility *) Notation trans_tn1 := clos_trans_tn1 (only parsing). Notation tn1_trans := clos_tn1_trans (only parsing). Notation tn1_trans_equiv := clos_trans_tn1_iff (only parsing). Notation trans_t1n := clos_trans_t1n (only parsing). Notation t1n_trans := clos_t1n_trans (only parsing). Notation t1n_trans_equiv := clos_trans_t1n_iff (only parsing). Notation R_rtn1 := clos_rtn1_step (only parsing). Notation trans_rt1n := clos_rt_rt1n (only parsing). Notation rt1n_trans := clos_rt1n_rt (only parsing). Notation rt1n_trans_equiv := clos_rt_rt1n_iff (only parsing). Notation R_rt1n := clos_rt1n_step (only parsing). Notation trans_rtn1 := clos_rt_rtn1 (only parsing). Notation rtn1_trans := clos_rtn1_rt (only parsing). Notation rtn1_trans_equiv := clos_rt_rtn1_iff (only parsing). Notation rts1n_rts := clos_rst1n_rst (only parsing). Notation rts_1n_trans := clos_rst1n_trans (only parsing). Notation rts1n_sym := clos_rst1n_sym (only parsing). Notation rts_rts1n := clos_rst_rst1n (only parsing). Notation rts_rts1n_equiv := clos_rst_rst1n_iff (only parsing). Notation rtsn1_rts := clos_rstn1_rst (only parsing). Notation rtsn1_trans := clos_rstn1_trans (only parsing). Notation rtsn1_sym := clos_rstn1_sym (only parsing). Notation rts_rtsn1 := clos_rst_rstn1 (only parsing). Notation rts_rtsn1_equiv := clos_rst_rstn1_iff (only parsing). (* end hide *) coq-8.4pl4/theories/Relations/vo.itarget0000644000175000017500000000012312326224777017416 0ustar stephstephOperators_Properties.vo Relation_Definitions.vo Relation_Operators.vo Relations.vo coq-8.4pl4/theories/Relations/Relation_Operators.v0000644000175000017500000001652012326224777021423 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Prop := | t_step (y:A) : R x y -> clos_trans x y | t_trans (y z:A) : clos_trans x y -> clos_trans y z -> clos_trans x z. (** Alternative definition by transitive extension on the left *) Inductive clos_trans_1n (x: A) : A -> Prop := | t1n_step (y:A) : R x y -> clos_trans_1n x y | t1n_trans (y z:A) : R x y -> clos_trans_1n y z -> clos_trans_1n x z. (** Alternative definition by transitive extension on the right *) Inductive clos_trans_n1 (x: A) : A -> Prop := | tn1_step (y:A) : R x y -> clos_trans_n1 x y | tn1_trans (y z:A) : R y z -> clos_trans_n1 x y -> clos_trans_n1 x z. End Transitive_Closure. (** ** Reflexive-transitive closure *) Section Reflexive_Transitive_Closure. Variable A : Type. Variable R : relation A. (** Definition by direct reflexive-transitive closure *) Inductive clos_refl_trans (x:A) : A -> Prop := | rt_step (y:A) : R x y -> clos_refl_trans x y | rt_refl : clos_refl_trans x x | rt_trans (y z:A) : clos_refl_trans x y -> clos_refl_trans y z -> clos_refl_trans x z. (** Alternative definition by transitive extension on the left *) Inductive clos_refl_trans_1n (x: A) : A -> Prop := | rt1n_refl : clos_refl_trans_1n x x | rt1n_trans (y z:A) : R x y -> clos_refl_trans_1n y z -> clos_refl_trans_1n x z. (** Alternative definition by transitive extension on the right *) Inductive clos_refl_trans_n1 (x: A) : A -> Prop := | rtn1_refl : clos_refl_trans_n1 x x | rtn1_trans (y z:A) : R y z -> clos_refl_trans_n1 x y -> clos_refl_trans_n1 x z. End Reflexive_Transitive_Closure. (** ** Reflexive-symmetric-transitive closure *) Section Reflexive_Symmetric_Transitive_Closure. Variable A : Type. Variable R : relation A. (** Definition by direct reflexive-symmetric-transitive closure *) Inductive clos_refl_sym_trans : relation A := | rst_step (x y:A) : R x y -> clos_refl_sym_trans x y | rst_refl (x:A) : clos_refl_sym_trans x x | rst_sym (x y:A) : clos_refl_sym_trans x y -> clos_refl_sym_trans y x | rst_trans (x y z:A) : clos_refl_sym_trans x y -> clos_refl_sym_trans y z -> clos_refl_sym_trans x z. (** Alternative definition by symmetric-transitive extension on the left *) Inductive clos_refl_sym_trans_1n (x: A) : A -> Prop := | rst1n_refl : clos_refl_sym_trans_1n x x | rst1n_trans (y z:A) : R x y \/ R y x -> clos_refl_sym_trans_1n y z -> clos_refl_sym_trans_1n x z. (** Alternative definition by symmetric-transitive extension on the right *) Inductive clos_refl_sym_trans_n1 (x: A) : A -> Prop := | rstn1_refl : clos_refl_sym_trans_n1 x x | rstn1_trans (y z:A) : R y z \/ R z y -> clos_refl_sym_trans_n1 x y -> clos_refl_sym_trans_n1 x z. End Reflexive_Symmetric_Transitive_Closure. (** ** Converse of a relation *) Section Converse. Variable A : Type. Variable R : relation A. Definition transp (x y:A) := R y x. End Converse. (** ** Union of relations *) Section Union. Variable A : Type. Variables R1 R2 : relation A. Definition union (x y:A) := R1 x y \/ R2 x y. End Union. (** ** Disjoint union of relations *) Section Disjoint_Union. Variables A B : Type. Variable leA : A -> A -> Prop. Variable leB : B -> B -> Prop. Inductive le_AsB : A + B -> A + B -> Prop := | le_aa (x y:A) : leA x y -> le_AsB (inl _ x) (inl _ y) | le_ab (x:A) (y:B) : le_AsB (inl _ x) (inr _ y) | le_bb (x y:B) : leB x y -> le_AsB (inr _ x) (inr _ y). End Disjoint_Union. (** ** Lexicographic order on dependent pairs *) Section Lexicographic_Product. Variable A : Type. Variable B : A -> Type. Variable leA : A -> A -> Prop. Variable leB : forall x:A, B x -> B x -> Prop. Inductive lexprod : sigT B -> sigT B -> Prop := | left_lex : forall (x x':A) (y:B x) (y':B x'), leA x x' -> lexprod (existT B x y) (existT B x' y') | right_lex : forall (x:A) (y y':B x), leB x y y' -> lexprod (existT B x y) (existT B x y'). End Lexicographic_Product. (** ** Product of relations *) Section Symmetric_Product. Variable A : Type. Variable B : Type. Variable leA : A -> A -> Prop. Variable leB : B -> B -> Prop. Inductive symprod : A * B -> A * B -> Prop := | left_sym : forall x x':A, leA x x' -> forall y:B, symprod (x, y) (x', y) | right_sym : forall y y':B, leB y y' -> forall x:A, symprod (x, y) (x, y'). End Symmetric_Product. (** ** Multiset of two relations *) Section Swap. Variable A : Type. Variable R : A -> A -> Prop. Inductive swapprod : A * A -> A * A -> Prop := | sp_noswap x y (p:A * A) : symprod A A R R (x, y) p -> swapprod (x, y) p | sp_swap x y (p:A * A) : symprod A A R R (x, y) p -> swapprod (y, x) p. End Swap. Local Open Scope list_scope. Section Lexicographic_Exponentiation. Variable A : Set. Variable leA : A -> A -> Prop. Let Nil := nil (A:=A). Let List := list A. Inductive Ltl : List -> List -> Prop := | Lt_nil (a:A) (x:List) : Ltl Nil (a :: x) | Lt_hd (a b:A) : leA a b -> forall x y:list A, Ltl (a :: x) (b :: y) | Lt_tl (a:A) (x y:List) : Ltl x y -> Ltl (a :: x) (a :: y). Inductive Desc : List -> Prop := | d_nil : Desc Nil | d_one (x:A) : Desc (x :: Nil) | d_conc (x y:A) (l:List) : leA x y -> Desc (l ++ y :: Nil) -> Desc ((l ++ y :: Nil) ++ x :: Nil). Definition Pow : Set := sig Desc. Definition lex_exp (a b:Pow) : Prop := Ltl (proj1_sig a) (proj1_sig b). End Lexicographic_Exponentiation. Hint Unfold transp union: sets v62. Hint Resolve t_step rt_step rt_refl rst_step rst_refl: sets v62. Hint Immediate rst_sym: sets v62. (* begin hide *) (* Compatibility *) Notation rts1n_refl := rst1n_refl (only parsing). Notation rts1n_trans := rst1n_trans (only parsing). Notation rtsn1_refl := rstn1_refl (only parsing). Notation rtsn1_trans := rstn1_trans (only parsing). (* end hide *) coq-8.4pl4/theories/Relations/intro.tex0000755000175000017500000000134712326224777017302 0ustar stephsteph\section{Relations}\label{Relations} This library develops closure properties of relations. \begin{itemize} \item {\tt Relation\_Definitions.v} deals with the general notions about binary relations (orders, equivalences, ...) \item {\tt Relation\_Operators.v} and {\tt Rstar.v} define various closures of relations (by symmetry, by transitivity, ...) and lexicographic orderings. \item {\tt Operators\_Properties.v} states and proves facts on the various closures of a relation. \item {\tt Relations.v} puts {\tt Relation\_Definitions.v}, {\tt Relation\_Operators.v} and \\ {\tt Operators\_Properties.v} together. \item {\tt Newman.v} proves Newman's lemma on noetherian and locally confluent relations. \end{itemize} coq-8.4pl4/theories/Relations/Relations.v0000644000175000017500000000226412326224777017550 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* B) (r:relation B), equivalence B r -> equivalence A (fun x y:A => r (f x) (f y)). Proof. intros; split; elim H; red; auto. intros _ equiv_trans _ x y z H0 H1; apply equiv_trans with (f y); assumption. Qed. Lemma inverse_image_of_eq : forall (A B:Type) (f:A -> B), equivalence A (fun x y:A => f x = f y). Proof. split; red; [ (* reflexivity *) reflexivity | (* transitivity *) intros; transitivity (f y); assumption | (* symmetry *) intros; symmetry ; assumption ]. Qed. coq-8.4pl4/theories/Relations/Relation_Definitions.v0000644000175000017500000000443112326224777021716 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* A -> Prop. Variable R : relation. Section General_Properties_of_Relations. Definition reflexive : Prop := forall x:A, R x x. Definition transitive : Prop := forall x y z:A, R x y -> R y z -> R x z. Definition symmetric : Prop := forall x y:A, R x y -> R y x. Definition antisymmetric : Prop := forall x y:A, R x y -> R y x -> x = y. (* for compatibility with Equivalence in ../PROGRAMS/ALG/ *) Definition equiv := reflexive /\ transitive /\ symmetric. End General_Properties_of_Relations. Section Sets_of_Relations. Record preorder : Prop := { preord_refl : reflexive; preord_trans : transitive}. Record order : Prop := { ord_refl : reflexive; ord_trans : transitive; ord_antisym : antisymmetric}. Record equivalence : Prop := { equiv_refl : reflexive; equiv_trans : transitive; equiv_sym : symmetric}. Record PER : Prop := {per_sym : symmetric; per_trans : transitive}. End Sets_of_Relations. Section Relations_of_Relations. Definition inclusion (R1 R2:relation) : Prop := forall x y:A, R1 x y -> R2 x y. Definition same_relation (R1 R2:relation) : Prop := inclusion R1 R2 /\ inclusion R2 R1. Definition commut (R1 R2:relation) : Prop := forall x y:A, R1 y x -> forall z:A, R2 z y -> exists2 y' : A, R2 y' x & R1 z y'. End Relations_of_Relations. End Relation_Definition. Hint Unfold reflexive transitive antisymmetric symmetric: sets v62. Hint Resolve Build_preorder Build_order Build_equivalence Build_PER preord_refl preord_trans ord_refl ord_trans ord_antisym equiv_refl equiv_trans equiv_sym per_sym per_trans: sets v62. Hint Unfold inclusion same_relation commut: sets v62. coq-8.4pl4/theories/FSets/0000755000175000017500000000000012365131023014461 5ustar stephstephcoq-8.4pl4/theories/FSets/FMapFullAVL.v0000644000175000017500000005700512326224777016710 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Prop := | RBLeaf : avl (Leaf _) | RBNode : forall x e l r h, avl l -> avl r -> -(2) <= height l - height r <= 2 -> h = max (height l) (height r) + 1 -> avl (Node l x e r h). (** * Automation and dedicated tactics about [avl]. *) Hint Constructors avl. Lemma height_non_negative : forall (s : t elt), avl s -> height s >= 0. Proof. induction s; simpl; intros; auto with zarith. inv avl; intuition; omega_max. Qed. Ltac avl_nn_hyp H := let nz := fresh "nz" in assert (nz := height_non_negative H). Ltac avl_nn h := let t := type of h in match type of t with | Prop => avl_nn_hyp h | _ => match goal with H : avl h |- _ => avl_nn_hyp H end end. (* Repeat the previous tactic. Drawback: need to clear the [avl _] hyps ... Thank you Ltac *) Ltac avl_nns := match goal with | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns | _ => idtac end. (** * Basic results about [avl], [height] *) Lemma avl_node : forall x e l r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> avl (Node l x e r (max (height l) (height r) + 1)). Proof. intros; auto. Qed. Hint Resolve avl_node. (** Results about [height] *) Lemma height_0 : forall l, avl l -> height l = 0 -> l = Leaf _. Proof. destruct 1; intuition; simpl in *. avl_nns; simpl in *; exfalso; omega_max. Qed. (** * Empty map *) Lemma empty_avl : avl (empty elt). Proof. unfold empty; auto. Qed. (** * Helper functions *) Lemma create_avl : forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> avl (create l x e r). Proof. unfold create; auto. Qed. Lemma create_height : forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> height (create l x e r) = max (height l) (height r) + 1. Proof. unfold create; intros; auto. Qed. Lemma bal_avl : forall l x e r, avl l -> avl r -> -(3) <= height l - height r <= 3 -> avl (bal l x e r). Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; inv avl; simpl in *; match goal with |- avl (assert_false _ _ _ _) => avl_nns | _ => repeat apply create_avl; simpl in *; auto end; omega_max. Qed. Lemma bal_height_1 : forall l x e r, avl l -> avl r -> -(3) <= height l - height r <= 3 -> 0 <= height (bal l x e r) - max (height l) (height r) <= 1. Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; inv avl; avl_nns; simpl in *; omega_max. Qed. Lemma bal_height_2 : forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> height (bal l x e r) == max (height l) (height r) +1. Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; inv avl; avl_nns; simpl in *; omega_max. Qed. Ltac omega_bal := match goal with | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?e ?r ] => generalize (bal_height_1 x e H H') (bal_height_2 x e H H'); omega_max end. (** * Insertion *) Lemma add_avl_1 : forall m x e, avl m -> avl (add x e m) /\ 0 <= height (add x e m) - height m <= 1. Proof. intros m x e; functional induction (add x e m); intros; inv avl; simpl in *. intuition; try constructor; simpl; auto; try omega_max. (* LT *) destruct IHt; auto. split. apply bal_avl; auto; omega_max. omega_bal. (* EQ *) intuition; omega_max. (* GT *) destruct IHt; auto. split. apply bal_avl; auto; omega_max. omega_bal. Qed. Lemma add_avl : forall m x e, avl m -> avl (add x e m). Proof. intros; generalize (add_avl_1 x e H); intuition. Qed. Hint Resolve add_avl. (** * Extraction of minimum binding *) Lemma remove_min_avl_1 : forall l x e r h, avl (Node l x e r h) -> avl (remove_min l x e r)#1 /\ 0 <= height (Node l x e r h) - height (remove_min l x e r)#1 <= 1. Proof. intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. inv avl; simpl in *; split; auto. avl_nns; omega_max. inversion_clear H. rewrite e0 in IHp;simpl in IHp;destruct (IHp _x); auto. split; simpl in *. apply bal_avl; auto; omega_max. omega_bal. Qed. Lemma remove_min_avl : forall l x e r h, avl (Node l x e r h) -> avl (remove_min l x e r)#1. Proof. intros; generalize (remove_min_avl_1 H); intuition. Qed. (** * Merging two trees *) Lemma merge_avl_1 : forall m1 m2, avl m1 -> avl m2 -> -(2) <= height m1 - height m2 <= 2 -> avl (merge m1 m2) /\ 0<= height (merge m1 m2) - max (height m1) (height m2) <=1. Proof. intros m1 m2; functional induction (merge m1 m2); intros; try factornode _x _x0 _x1 _x2 _x3 as m1. simpl; split; auto; avl_nns; omega_max. simpl; split; auto; avl_nns; omega_max. generalize (remove_min_avl_1 H0). rewrite e1; destruct 1. split. apply bal_avl; auto. omega_max. omega_bal. Qed. Lemma merge_avl : forall m1 m2, avl m1 -> avl m2 -> -(2) <= height m1 - height m2 <= 2 -> avl (merge m1 m2). Proof. intros; generalize (merge_avl_1 H H0 H1); intuition. Qed. (** * Deletion *) Lemma remove_avl_1 : forall m x, avl m -> avl (remove x m) /\ 0 <= height m - height (remove x m) <= 1. Proof. intros m x; functional induction (remove x m); intros. split; auto; omega_max. (* LT *) inv avl. destruct (IHt H0). split. apply bal_avl; auto. omega_max. omega_bal. (* EQ *) inv avl. generalize (merge_avl_1 H0 H1 H2). intuition omega_max. (* GT *) inv avl. destruct (IHt H1). split. apply bal_avl; auto. omega_max. omega_bal. Qed. Lemma remove_avl : forall m x, avl m -> avl (remove x m). Proof. intros; generalize (remove_avl_1 x H); intuition. Qed. Hint Resolve remove_avl. (** * Join *) Lemma join_avl_1 : forall l x d r, avl l -> avl r -> avl (join l x d r) /\ 0<= height (join l x d r) - max (height l) (height r) <= 1. Proof. join_tac. split; simpl; auto. destruct (add_avl_1 x d H0). avl_nns; omega_max. set (l:=Node ll lx ld lr lh) in *. split; auto. destruct (add_avl_1 x d H). simpl (height (Leaf elt)). avl_nns; omega_max. inversion_clear H. assert (height (Node rl rx rd rr rh) = rh); auto. set (r := Node rl rx rd rr rh) in *; clearbody r. destruct (Hlr x d r H2 H0); clear Hrl Hlr. set (j := join lr x d r) in *; clearbody j. simpl. assert (-(3) <= height ll - height j <= 3) by omega_max. split. apply bal_avl; auto. omega_bal. inversion_clear H0. assert (height (Node ll lx ld lr lh) = lh); auto. set (l := Node ll lx ld lr lh) in *; clearbody l. destruct (Hrl H H1); clear Hrl Hlr. set (j := join l x d rl) in *; clearbody j. simpl. assert (-(3) <= height j - height rr <= 3) by omega_max. split. apply bal_avl; auto. omega_bal. clear Hrl Hlr. assert (height (Node ll lx ld lr lh) = lh); auto. assert (height (Node rl rx rd rr rh) = rh); auto. set (l := Node ll lx ld lr lh) in *; clearbody l. set (r := Node rl rx rd rr rh) in *; clearbody r. assert (-(2) <= height l - height r <= 2) by omega_max. split. apply create_avl; auto. rewrite create_height; auto; omega_max. Qed. Lemma join_avl : forall l x d r, avl l -> avl r -> avl (join l x d r). Proof. intros; destruct (join_avl_1 x d H H0); auto. Qed. Hint Resolve join_avl. (** concat *) Lemma concat_avl : forall m1 m2, avl m1 -> avl m2 -> avl (concat m1 m2). Proof. intros m1 m2; functional induction (concat m1 m2); auto. intros; apply join_avl; auto. generalize (remove_min_avl H0); rewrite e1; simpl; auto. Qed. Hint Resolve concat_avl. (** split *) Lemma split_avl : forall m x, avl m -> avl (split x m)#l /\ avl (split x m)#r. Proof. intros m x; functional induction (split x m); simpl; auto. rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition. simpl; inversion_clear 1; auto. rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition. Qed. End Elt. Hint Constructors avl. Section Map. Variable elt elt' : Type. Variable f : elt -> elt'. Lemma map_height : forall m, height (map f m) = height m. Proof. destruct m; simpl; auto. Qed. Lemma map_avl : forall m, avl m -> avl (map f m). Proof. induction m; simpl; auto. inversion_clear 1; constructor; auto; do 2 rewrite map_height; auto. Qed. End Map. Section Mapi. Variable elt elt' : Type. Variable f : key -> elt -> elt'. Lemma mapi_height : forall m, height (mapi f m) = height m. Proof. destruct m; simpl; auto. Qed. Lemma mapi_avl : forall m, avl m -> avl (mapi f m). Proof. induction m; simpl; auto. inversion_clear 1; constructor; auto; do 2 rewrite mapi_height; auto. Qed. End Mapi. Section Map_option. Variable elt elt' : Type. Variable f : key -> elt -> option elt'. Lemma map_option_avl : forall m, avl m -> avl (map_option f m). Proof. induction m; simpl; auto; intros. inv avl; destruct (f k e); auto using join_avl, concat_avl. Qed. End Map_option. Section Map2_opt. Variable elt elt' elt'' : Type. Variable f : key -> elt -> option elt' -> option elt''. Variable mapl : t elt -> t elt''. Variable mapr : t elt' -> t elt''. Hypothesis mapl_avl : forall m, avl m -> avl (mapl m). Hypothesis mapr_avl : forall m', avl m' -> avl (mapr m'). Notation map2_opt := (map2_opt f mapl mapr). Lemma map2_opt_avl : forall m1 m2, avl m1 -> avl m2 -> avl (map2_opt m1 m2). Proof. intros m1 m2; functional induction (map2_opt m1 m2); auto; factornode _x0 _x1 _x2 _x3 _x4 as r2; intros; destruct (split_avl x1 H0); rewrite e1 in *; simpl in *; inv avl; auto using join_avl, concat_avl. Qed. End Map2_opt. Section Map2. Variable elt elt' elt'' : Type. Variable f : option elt -> option elt' -> option elt''. Lemma map2_avl : forall m1 m2, avl m1 -> avl m2 -> avl (map2 f m1 m2). Proof. unfold map2; auto using map2_opt_avl, map_option_avl. Qed. End Map2. End AvlProofs. (** * Encapsulation We can implement [S] with balanced binary search trees. When compared to [FMapAVL], we maintain here two invariants (bst and avl) instead of only bst, which is enough for fulfilling the FMap interface. *) Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Module E := X. Module Import AvlProofs := AvlProofs I X. Import Raw. Import Raw.Proofs. Record bbst (elt:Type) := Bbst {this :> tree elt; is_bst : bst this; is_avl: avl this}. Definition t := bbst. Definition key := E.t. Section Elt. Variable elt elt' elt'': Type. Implicit Types m : t elt. Implicit Types x y : key. Implicit Types e : elt. Definition empty : t elt := Bbst (empty_bst elt) (empty_avl elt). Definition is_empty m : bool := is_empty m.(this). Definition add x e m : t elt := Bbst (add_bst x e m.(is_bst)) (add_avl x e m.(is_avl)). Definition remove x m : t elt := Bbst (remove_bst x m.(is_bst)) (remove_avl x m.(is_avl)). Definition mem x m : bool := mem x m.(this). Definition find x m : option elt := find x m.(this). Definition map f m : t elt' := Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)). Definition mapi (f:key->elt->elt') m : t elt' := Bbst (mapi_bst f m.(is_bst)) (mapi_avl f m.(is_avl)). Definition map2 f m (m':t elt') : t elt'' := Bbst (map2_bst f m.(is_bst) m'.(is_bst)) (map2_avl f m.(is_avl) m'.(is_avl)). Definition elements m : list (key*elt) := elements m.(this). Definition cardinal m := cardinal m.(this). Definition fold (A:Type) (f:key->elt->A->A) m i := fold (A:=A) f m.(this) i. Definition equal cmp m m' : bool := equal cmp m.(this) m'.(this). Definition MapsTo x e m : Prop := MapsTo x e m.(this). Definition In x m : Prop := In0 x m.(this). Definition Empty m : Prop := Empty m.(this). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt. Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt. Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. Proof. intros m; exact (@MapsTo_1 _ m.(this)). Qed. Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto. apply m.(is_bst). Qed. Lemma mem_2 : forall m x, mem x m = true -> In x m. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto. Qed. Lemma empty_1 : Empty empty. Proof. exact (@empty_1 elt). Qed. Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. Proof. intros m; exact (@is_empty_1 _ m.(this)). Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. Proof. intros m; exact (@is_empty_2 _ m.(this)). Qed. Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). Proof. intros m x y e; exact (@add_1 elt _ x y e). Qed. Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. intros m x y e e'; exact (@add_2 elt _ x y e e'). Qed. Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. Proof. intros m x y e e'; exact (@add_3 elt _ x y e e'). Qed. Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). Proof. unfold In, remove; intros m x y; rewrite In_alt; simpl; apply remove_1; auto. apply m.(is_bst). Qed. Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m x y e; exact (@remove_2 elt _ x y e m.(is_bst)). Qed. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed. Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. Proof. intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m; exact (@find_2 elt m.(this)). Qed. Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed. Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). Proof. intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto. Qed. Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto. Qed. Lemma elements_3 : forall m, sort lt_key (elements m). Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed. Lemma elements_3w : forall m, NoDupA eq_key (elements m). Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). Proof. intro m; exact (@elements_cardinal elt m.(this)). Qed. Definition Equal m m' := forall y, find y m = find y m'. Definition Equiv (eq_elt:elt->elt->Prop) m m' := (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb cmp := Equiv (Cmp cmp). Lemma Equivb_Equivb : forall cmp m m', Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. Proof. intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. generalize (H0 k); do 2 rewrite <- In_alt; intuition. generalize (H0 k); do 2 rewrite <- In_alt; intuition. Qed. Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. Proof. unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; intros; simpl in *; rewrite equal_Equivb; auto. Qed. Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; intros; simpl in *; rewrite <-equal_Equivb; auto. Qed. End Elt. Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed. Lemma map_2 : forall (elt elt':Type)(m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl. apply map_2; auto. Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. intros elt elt' m x f; unfold In in *; do 2 rewrite In_alt; simpl; apply mapi_2; auto. Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x m \/ In x m' -> find x (map2 f m m') = f (find x m) (find x m'). Proof. unfold find, map2, In; intros elt elt' elt'' m m' x f. do 2 rewrite In_alt; intros; simpl; apply map2_1; auto. apply m.(is_bst). apply m'.(is_bst). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Proof. unfold In, map2; intros elt elt' elt'' m m' x f. do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto. apply m.(is_bst). apply m'.(is_bst). Qed. End IntMake. Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Sord with Module Data := D with Module MapS.E := X. Module Data := D. Module Import MapS := IntMake(I)(X). Import AvlProofs. Import Raw.Proofs. Module Import MD := OrderedTypeFacts(D). Module LO := FMapList.Make_ord(X)(D). Definition t := MapS.t D.t. Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. Definition elements (m:t) := LO.MapS.Build_slist (Raw.Proofs.elements_sort m.(is_bst)). (** * As comparison function, we propose here a non-structural version faithful to the code of Ocaml's Map library, instead of the structural version of FMapAVL *) Fixpoint cardinal_e (e:Raw.enumeration D.t) := match e with | Raw.End => 0%nat | Raw.More _ _ r e => S (Raw.cardinal r + cardinal_e e) end. Lemma cons_cardinal_e : forall m e, cardinal_e (Raw.cons m e) = (Raw.cardinal m + cardinal_e e)%nat. Proof. induction m; simpl; intros; auto. rewrite IHm1; simpl; rewrite <- plus_n_Sm; auto with arith. Qed. Definition cardinal_e_2 ee := (cardinal_e (fst ee) + cardinal_e (snd ee))%nat. Function compare_aux (ee:Raw.enumeration D.t * Raw.enumeration D.t) { measure cardinal_e_2 ee } : comparison := match ee with | (Raw.End, Raw.End) => Eq | (Raw.End, Raw.More _ _ _ _) => Lt | (Raw.More _ _ _ _, Raw.End) => Gt | (Raw.More x1 d1 r1 e1, Raw.More x2 d2 r2 e2) => match X.compare x1 x2 with | EQ _ => match D.compare d1 d2 with | EQ _ => compare_aux (Raw.cons r1 e1, Raw.cons r2 e2) | LT _ => Lt | GT _ => Gt end | LT _ => Lt | GT _ => Gt end end. Proof. intros; unfold cardinal_e_2; simpl; abstract (do 2 rewrite cons_cardinal_e; romega with * ). Defined. Definition Cmp c := match c with | Eq => LO.eq_list | Lt => LO.lt_list | Gt => (fun l1 l2 => LO.lt_list l2 l1) end. Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, X.eq x1 x2 -> D.eq d1 d2 -> Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). Proof. destruct c; simpl; intros; MX.elim_comp; auto. Qed. Hint Resolve cons_Cmp. Lemma compare_aux_Cmp : forall e, Cmp (compare_aux e) (flatten_e (fst e)) (flatten_e (snd e)). Proof. intros e; functional induction (compare_aux e); simpl in *; auto; intros; try clear e0; try clear e3; try MX.elim_comp; auto. rewrite 2 cons_1 in IHc; auto. Qed. Lemma compare_Cmp : forall m1 m2, Cmp (compare_aux (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _))) (Raw.elements m1) (Raw.elements m2). Proof. intros. assert (H1:=cons_1 m1 (Raw.End _)). assert (H2:=cons_1 m2 (Raw.End _)). simpl in *; rewrite <- app_nil_end in *; rewrite <-H1,<-H2. apply (@compare_aux_Cmp (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _))). Qed. Definition eq (m1 m2 : t) := LO.eq_list (Raw.elements m1) (Raw.elements m2). Definition lt (m1 m2 : t) := LO.lt_list (Raw.elements m1) (Raw.elements m2). Definition compare (s s':t) : Compare lt eq s s'. Proof. destruct s as (s,b,a), s' as (s',b',a'). generalize (compare_Cmp s s'). destruct compare_aux; intros; [apply EQ|apply LT|apply GT]; red; auto. Defined. (* Proofs about [eq] and [lt] *) Definition selements (m1 : t) := LO.MapS.Build_slist (elements_sort m1.(is_bst)). Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2). Definition slt (m1 m2 : t) := LO.lt (selements m1) (selements m2). Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2. Proof. unfold eq, seq, selements, elements, LO.eq; intuition. Qed. Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2. Proof. unfold lt, slt, selements, elements, LO.lt; intuition. Qed. Lemma eq_1 : forall (m m' : t), MapS.Equivb cmp m m' -> eq m m'. Proof. intros m m'. rewrite eq_seq; unfold seq. rewrite Equivb_Equivb. rewrite Equivb_elements. auto using LO.eq_1. Qed. Lemma eq_2 : forall m m', eq m m' -> MapS.Equivb cmp m m'. Proof. intros m m'. rewrite eq_seq; unfold seq. rewrite Equivb_Equivb. rewrite Equivb_elements. intros. generalize (LO.eq_2 H). auto. Qed. Lemma eq_refl : forall m : t, eq m m. Proof. intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl. Qed. Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. Proof. intros m1 m2; rewrite 2 eq_seq; unfold seq; intros; apply LO.eq_sym; auto. Qed. Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. Proof. intros m1 m2 M3; rewrite 3 eq_seq; unfold seq. intros; eapply LO.eq_trans; eauto. Qed. Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. Proof. intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; intros; eapply LO.lt_trans; eauto. Qed. Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. Proof. intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; intros; apply LO.lt_not_eq; auto. Qed. End IntMake_ord. (* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *) Module Make (X: OrderedType) <: S with Module E := X :=IntMake(Z_as_Int)(X). Module Make_ord (X: OrderedType)(D: OrderedType) <: Sord with Module Data := D with Module MapS.E := X :=IntMake_ord(Z_as_Int)(X)(D). coq-8.4pl4/theories/FSets/FSetCompat.v0000644000175000017500000003617312326224777016707 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool. Definition In : elt -> t -> Prop := M.In. Definition Equal s s' := forall a : elt, In a s <-> In a s'. Definition Subset s s' := forall a : elt, In a s -> In a s'. Definition Empty s := forall a : elt, ~ In a s. Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. Definition empty : t := M.empty. Definition is_empty : t -> bool := M.is_empty. Definition mem : elt -> t -> bool := M.mem. Definition add : elt -> t -> t := M.add. Definition singleton : elt -> t := M.singleton. Definition remove : elt -> t -> t := M.remove. Definition union : t -> t -> t := M.union. Definition inter : t -> t -> t := M.inter. Definition diff : t -> t -> t := M.diff. Definition eq : t -> t -> Prop := M.eq. Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec. Definition equal : t -> t -> bool := M.equal. Definition subset : t -> t -> bool := M.subset. Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold. Definition for_all : (elt -> bool) -> t -> bool := M.for_all. Definition exists_ : (elt -> bool) -> t -> bool := M.exists_. Definition filter : (elt -> bool) -> t -> t := M.filter. Definition partition : (elt -> bool) -> t -> t * t:= M.partition. Definition cardinal : t -> nat := M.cardinal. Definition elements : t -> list elt := M.elements. Definition choose : t -> option elt := M.choose. Module MF := MSetFacts.WFacts M. Definition In_1 : forall s x y, E.eq x y -> In x s -> In y s := MF.In_1. Definition eq_refl : forall s, eq s s := @Equivalence_Reflexive _ _ M.eq_equiv. Definition eq_sym : forall s s', eq s s' -> eq s' s := @Equivalence_Symmetric _ _ M.eq_equiv. Definition eq_trans : forall s s' s'', eq s s' -> eq s' s'' -> eq s s'' := @Equivalence_Transitive _ _ M.eq_equiv. Definition mem_1 : forall s x, In x s -> mem x s = true := MF.mem_1. Definition mem_2 : forall s x, mem x s = true -> In x s := MF.mem_2. Definition equal_1 : forall s s', Equal s s' -> equal s s' = true := MF.equal_1. Definition equal_2 : forall s s', equal s s' = true -> Equal s s' := MF.equal_2. Definition subset_1 : forall s s', Subset s s' -> subset s s' = true := MF.subset_1. Definition subset_2 : forall s s', subset s s' = true -> Subset s s' := MF.subset_2. Definition empty_1 : Empty empty := MF.empty_1. Definition is_empty_1 : forall s, Empty s -> is_empty s = true := MF.is_empty_1. Definition is_empty_2 : forall s, is_empty s = true -> Empty s := MF.is_empty_2. Definition add_1 : forall s x y, E.eq x y -> In y (add x s) := MF.add_1. Definition add_2 : forall s x y, In y s -> In y (add x s) := MF.add_2. Definition add_3 : forall s x y, ~ E.eq x y -> In y (add x s) -> In y s := MF.add_3. Definition remove_1 : forall s x y, E.eq x y -> ~ In y (remove x s) := MF.remove_1. Definition remove_2 : forall s x y, ~ E.eq x y -> In y s -> In y (remove x s) := MF.remove_2. Definition remove_3 : forall s x y, In y (remove x s) -> In y s := MF.remove_3. Definition union_1 : forall s s' x, In x (union s s') -> In x s \/ In x s' := MF.union_1. Definition union_2 : forall s s' x, In x s -> In x (union s s') := MF.union_2. Definition union_3 : forall s s' x, In x s' -> In x (union s s') := MF.union_3. Definition inter_1 : forall s s' x, In x (inter s s') -> In x s := MF.inter_1. Definition inter_2 : forall s s' x, In x (inter s s') -> In x s' := MF.inter_2. Definition inter_3 : forall s s' x, In x s -> In x s' -> In x (inter s s') := MF.inter_3. Definition diff_1 : forall s s' x, In x (diff s s') -> In x s := MF.diff_1. Definition diff_2 : forall s s' x, In x (diff s s') -> ~ In x s' := MF.diff_2. Definition diff_3 : forall s s' x, In x s -> ~ In x s' -> In x (diff s s') := MF.diff_3. Definition singleton_1 : forall x y, In y (singleton x) -> E.eq x y := MF.singleton_1. Definition singleton_2 : forall x y, E.eq x y -> In y (singleton x) := MF.singleton_2. Definition fold_1 : forall s (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i := MF.fold_1. Definition cardinal_1 : forall s, cardinal s = length (elements s) := MF.cardinal_1. Definition filter_1 : forall s x f, compat_bool E.eq f -> In x (filter f s) -> In x s := MF.filter_1. Definition filter_2 : forall s x f, compat_bool E.eq f -> In x (filter f s) -> f x = true := MF.filter_2. Definition filter_3 : forall s x f, compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s) := MF.filter_3. Definition for_all_1 : forall s f, compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true := MF.for_all_1. Definition for_all_2 : forall s f, compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s := MF.for_all_2. Definition exists_1 : forall s f, compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true := MF.exists_1. Definition exists_2 : forall s f, compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s := MF.exists_2. Definition partition_1 : forall s f, compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s) := MF.partition_1. Definition partition_2 : forall s f, compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s) := MF.partition_2. Definition choose_1 : forall s x, choose s = Some x -> In x s := MF.choose_1. Definition choose_2 : forall s, choose s = None -> Empty s := MF.choose_2. Definition elements_1 : forall s x, In x s -> InA E.eq x (elements s) := MF.elements_1. Definition elements_2 : forall s x, InA E.eq x (elements s) -> In x s := MF.elements_2. Definition elements_3w : forall s, NoDupA E.eq (elements s) := MF.elements_3w. End Backport_WSets. (** * From new Sets to new ones *) Module Backport_Sets (E:OrderedType.OrderedType) (M:MSetInterface.Sets with Definition E.t := E.t with Definition E.eq := E.eq with Definition E.lt := E.lt) <: FSetInterface.S with Module E:=E. Include Backport_WSets E M. Implicit Type s : t. Implicit Type x y : elt. Definition lt : t -> t -> Prop := M.lt. Definition min_elt : t -> option elt := M.min_elt. Definition max_elt : t -> option elt := M.max_elt. Definition min_elt_1 : forall s x, min_elt s = Some x -> In x s := M.min_elt_spec1. Definition min_elt_2 : forall s x y, min_elt s = Some x -> In y s -> ~ E.lt y x := M.min_elt_spec2. Definition min_elt_3 : forall s, min_elt s = None -> Empty s := M.min_elt_spec3. Definition max_elt_1 : forall s x, max_elt s = Some x -> In x s := M.max_elt_spec1. Definition max_elt_2 : forall s x y, max_elt s = Some x -> In y s -> ~ E.lt x y := M.max_elt_spec2. Definition max_elt_3 : forall s, max_elt s = None -> Empty s := M.max_elt_spec3. Definition elements_3 : forall s, sort E.lt (elements s) := M.elements_spec2. Definition choose_3 : forall s s' x y, choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y := M.choose_spec3. Definition lt_trans : forall s s' s'', lt s s' -> lt s' s'' -> lt s s'' := @StrictOrder_Transitive _ _ M.lt_strorder. Lemma lt_not_eq : forall s s', lt s s' -> ~ eq s s'. Proof. unfold lt, eq. intros s s' Hlt Heq. rewrite Heq in Hlt. apply (StrictOrder_Irreflexive s'); auto. Qed. Definition compare : forall s s', Compare lt eq s s'. Proof. intros s s'; destruct (CompSpec2Type (M.compare_spec s s')); [ apply EQ | apply LT | apply GT ]; auto. Defined. Module E := E. End Backport_Sets. (** * From old Weak Sets to new ones. *) Module Update_WSets (E:Equalities.DecidableType) (M:FSetInterface.WS with Definition E.t := E.t with Definition E.eq := E.eq) <: MSetInterface.WSetsOn E. Definition elt := E.t. Definition t := M.t. Implicit Type s : t. Implicit Type x y : elt. Implicit Type f : elt -> bool. Definition In : elt -> t -> Prop := M.In. Definition Equal s s' := forall a : elt, In a s <-> In a s'. Definition Subset s s' := forall a : elt, In a s -> In a s'. Definition Empty s := forall a : elt, ~ In a s. Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. Definition empty : t := M.empty. Definition is_empty : t -> bool := M.is_empty. Definition mem : elt -> t -> bool := M.mem. Definition add : elt -> t -> t := M.add. Definition singleton : elt -> t := M.singleton. Definition remove : elt -> t -> t := M.remove. Definition union : t -> t -> t := M.union. Definition inter : t -> t -> t := M.inter. Definition diff : t -> t -> t := M.diff. Definition eq : t -> t -> Prop := M.eq. Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec. Definition equal : t -> t -> bool := M.equal. Definition subset : t -> t -> bool := M.subset. Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold. Definition for_all : (elt -> bool) -> t -> bool := M.for_all. Definition exists_ : (elt -> bool) -> t -> bool := M.exists_. Definition filter : (elt -> bool) -> t -> t := M.filter. Definition partition : (elt -> bool) -> t -> t * t:= M.partition. Definition cardinal : t -> nat := M.cardinal. Definition elements : t -> list elt := M.elements. Definition choose : t -> option elt := M.choose. Module MF := FSetFacts.WFacts M. Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In. Proof. intros x x' Hx s s' Hs. subst. apply MF.In_eq_iff; auto. Qed. Instance eq_equiv : Equivalence eq := _. Section Spec. Variable s s': t. Variable x y : elt. Lemma mem_spec : mem x s = true <-> In x s. Proof. intros; symmetry; apply MF.mem_iff. Qed. Lemma equal_spec : equal s s' = true <-> Equal s s'. Proof. intros; symmetry; apply MF.equal_iff. Qed. Lemma subset_spec : subset s s' = true <-> Subset s s'. Proof. intros; symmetry; apply MF.subset_iff. Qed. Definition empty_spec : Empty empty := M.empty_1. Lemma is_empty_spec : is_empty s = true <-> Empty s. Proof. intros; symmetry; apply MF.is_empty_iff. Qed. Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s. Proof. intros. rewrite MF.add_iff. intuition. Qed. Lemma remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x. Proof. intros. rewrite MF.remove_iff. intuition. Qed. Lemma singleton_spec : In y (singleton x) <-> E.eq y x. Proof. intros; rewrite MF.singleton_iff. intuition. Qed. Definition union_spec : In x (union s s') <-> In x s \/ In x s' := @MF.union_iff s s' x. Definition inter_spec : In x (inter s s') <-> In x s /\ In x s' := @MF.inter_iff s s' x. Definition diff_spec : In x (diff s s') <-> In x s /\ ~In x s' := @MF.diff_iff s s' x. Definition fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (flip f) (elements s) i := @M.fold_1 s. Definition cardinal_spec : cardinal s = length (elements s) := @M.cardinal_1 s. Lemma elements_spec1 : InA E.eq x (elements s) <-> In x s. Proof. intros; symmetry; apply MF.elements_iff. Qed. Definition elements_spec2w : NoDupA E.eq (elements s) := @M.elements_3w s. Definition choose_spec1 : choose s = Some x -> In x s := @M.choose_1 s x. Definition choose_spec2 : choose s = None -> Empty s := @M.choose_2 s. Definition filter_spec : forall f, Proper (E.eq==>Logic.eq) f -> (In x (filter f s) <-> In x s /\ f x = true) := @MF.filter_iff s x. Definition partition_spec1 : forall f, Proper (E.eq==>Logic.eq) f -> Equal (fst (partition f s)) (filter f s) := @M.partition_1 s. Definition partition_spec2 : forall f, Proper (E.eq==>Logic.eq) f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s) := @M.partition_2 s. Lemma for_all_spec : forall f, Proper (E.eq==>Logic.eq) f -> (for_all f s = true <-> For_all (fun x => f x = true) s). Proof. intros; symmetry; apply MF.for_all_iff; auto. Qed. Lemma exists_spec : forall f, Proper (E.eq==>Logic.eq) f -> (exists_ f s = true <-> Exists (fun x => f x = true) s). Proof. intros; symmetry; apply MF.exists_iff; auto. Qed. End Spec. End Update_WSets. (** * From old Sets to new ones. *) Module Update_Sets (E:Orders.OrderedType) (M:FSetInterface.S with Definition E.t := E.t with Definition E.eq := E.eq with Definition E.lt := E.lt) <: MSetInterface.Sets with Module E:=E. Include Update_WSets E M. Implicit Type s : t. Implicit Type x y : elt. Definition lt : t -> t -> Prop := M.lt. Definition min_elt : t -> option elt := M.min_elt. Definition max_elt : t -> option elt := M.max_elt. Definition min_elt_spec1 : forall s x, min_elt s = Some x -> In x s := M.min_elt_1. Definition min_elt_spec2 : forall s x y, min_elt s = Some x -> In y s -> ~ E.lt y x := M.min_elt_2. Definition min_elt_spec3 : forall s, min_elt s = None -> Empty s := M.min_elt_3. Definition max_elt_spec1 : forall s x, max_elt s = Some x -> In x s := M.max_elt_1. Definition max_elt_spec2 : forall s x y, max_elt s = Some x -> In y s -> ~ E.lt x y := M.max_elt_2. Definition max_elt_spec3 : forall s, max_elt s = None -> Empty s := M.max_elt_3. Definition elements_spec2 : forall s, sort E.lt (elements s) := M.elements_3. Definition choose_spec3 : forall s s' x y, choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y := M.choose_3. Instance lt_strorder : StrictOrder lt. Proof. split. intros x Hx. apply (M.lt_not_eq Hx); auto with *. exact M.lt_trans. Qed. Instance lt_compat : Proper (eq==>eq==>iff) lt. Proof. apply proper_sym_impl_iff_2; auto with *. intros s s' Hs u u' Hu H. assert (H0 : lt s' u). destruct (M.compare s' u) as [H'|H'|H']; auto. elim (M.lt_not_eq H). transitivity s'; auto with *. elim (M.lt_not_eq (M.lt_trans H H')); auto. destruct (M.compare s' u') as [H'|H'|H']; auto. elim (M.lt_not_eq H). transitivity u'; auto with *. transitivity s'; auto with *. elim (M.lt_not_eq (M.lt_trans H' H0)); auto with *. Qed. Definition compare s s' := match M.compare s s' with | EQ _ => Eq | LT _ => Lt | GT _ => Gt end. Lemma compare_spec : forall s s', CompSpec eq lt s s' (compare s s'). Proof. intros; unfold compare; destruct M.compare; auto. Qed. Module E := E. End Update_Sets. coq-8.4pl4/theories/FSets/FSetPositive.v0000644000175000017500000011175512326224777017266 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool -> tree -> tree. Scheme tree_ind := Induction for tree Sort Prop. Definition t := tree. Definition empty := Leaf. Fixpoint is_empty (m : t) : bool := match m with | Leaf => true | Node l b r => negb b &&& is_empty l &&& is_empty r end. Fixpoint mem (i : positive) (m : t) : bool := match m with | Leaf => false | Node l o r => match i with | 1 => o | i~0 => mem i l | i~1 => mem i r end end. Fixpoint add (i : positive) (m : t) : t := match m with | Leaf => match i with | 1 => Node Leaf true Leaf | i~0 => Node (add i Leaf) false Leaf | i~1 => Node Leaf false (add i Leaf) end | Node l o r => match i with | 1 => Node l true r | i~0 => Node (add i l) o r | i~1 => Node l o (add i r) end end. Definition singleton i := add i empty. (** helper function to avoid creating empty trees that are not leaves *) Definition node l (b: bool) r := if b then Node l b r else match l,r with | Leaf,Leaf => Leaf | _,_ => Node l false r end. Fixpoint remove (i : positive) (m : t) : t := match m with | Leaf => Leaf | Node l o r => match i with | 1 => node l false r | i~0 => node (remove i l) o r | i~1 => node l o (remove i r) end end. Fixpoint union (m m': t) := match m with | Leaf => m' | Node l o r => match m' with | Leaf => m | Node l' o' r' => Node (union l l') (o||o') (union r r') end end. Fixpoint inter (m m': t) := match m with | Leaf => Leaf | Node l o r => match m' with | Leaf => Leaf | Node l' o' r' => node (inter l l') (o&&o') (inter r r') end end. Fixpoint diff (m m': t) := match m with | Leaf => Leaf | Node l o r => match m' with | Leaf => m | Node l' o' r' => node (diff l l') (o&&negb o') (diff r r') end end. Fixpoint equal (m m': t): bool := match m with | Leaf => is_empty m' | Node l o r => match m' with | Leaf => is_empty m | Node l' o' r' => eqb o o' &&& equal l l' &&& equal r r' end end. Fixpoint subset (m m': t): bool := match m with | Leaf => true | Node l o r => match m' with | Leaf => is_empty m | Node l' o' r' => (negb o ||| o') &&& subset l l' &&& subset r r' end end. (** reverses [y] and concatenate it with [x] *) Fixpoint rev_append y x := match y with | 1 => x | y~1 => rev_append y x~1 | y~0 => rev_append y x~0 end. Infix "@" := rev_append (at level 60). Definition rev x := x@1. Section Fold. Variables B : Type. Variable f : positive -> B -> B. (** the additional argument, [i], records the current path, in reverse order (this should be more efficient: we reverse this argument only at present nodes only, rather than at each node of the tree). we also use this convention in all functions below *) Fixpoint xfold (m : t) (v : B) (i : positive) := match m with | Leaf => v | Node l true r => xfold r (f (rev i) (xfold l v i~0)) i~1 | Node l false r => xfold r (xfold l v i~0) i~1 end. Definition fold m i := xfold m i 1. End Fold. Section Quantifiers. Variable f : positive -> bool. Fixpoint xforall (m : t) (i : positive) := match m with | Leaf => true | Node l o r => (negb o ||| f (rev i)) &&& xforall r i~1 &&& xforall l i~0 end. Definition for_all m := xforall m 1. Fixpoint xexists (m : t) (i : positive) := match m with | Leaf => false | Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0 end. Definition exists_ m := xexists m 1. Fixpoint xfilter (m : t) (i : positive) := match m with | Leaf => Leaf | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1) end. Definition filter m := xfilter m 1. Fixpoint xpartition (m : t) (i : positive) := match m with | Leaf => (Leaf,Leaf) | Node l o r => let (lt,lf) := xpartition l i~0 in let (rt,rf) := xpartition r i~1 in if o then let fi := f (rev i) in (node lt fi rt, node lf (negb fi) rf) else (node lt false rt, node lf false rf) end. Definition partition m := xpartition m 1. End Quantifiers. (** uses [a] to accumulate values rather than doing a lot of concatenations *) Fixpoint xelements (m : t) (i : positive) (a: list positive) := match m with | Leaf => a | Node l false r => xelements l i~0 (xelements r i~1 a) | Node l true r => xelements l i~0 (rev i :: xelements r i~1 a) end. Definition elements (m : t) := xelements m 1 nil. Fixpoint cardinal (m : t) : nat := match m with | Leaf => O | Node l false r => (cardinal l + cardinal r)%nat | Node l true r => S (cardinal l + cardinal r) end. Definition omap (f: elt -> elt) x := match x with | None => None | Some i => Some (f i) end. (** would it be more efficient to use a path like in the above functions ? *) Fixpoint choose (m: t) := match m with | Leaf => None | Node l o r => if o then Some 1 else match choose l with | None => omap xI (choose r) | Some i => Some i~0 end end. Fixpoint min_elt (m: t) := match m with | Leaf => None | Node l o r => match min_elt l with | None => if o then Some 1 else omap xI (min_elt r) | Some i => Some i~0 end end. Fixpoint max_elt (m: t) := match m with | Leaf => None | Node l o r => match max_elt r with | None => if o then Some 1 else omap xO (max_elt l) | Some i => Some i~1 end end. (** lexicographic product, defined using a notation to keep things lazy *) Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end. Definition compare_bool a b := match a,b with | false, true => Lt | true, false => Gt | _,_ => Eq end. Fixpoint compare_fun (m m': t): comparison := match m,m' with | Leaf,_ => if is_empty m' then Eq else Lt | _,Leaf => if is_empty m then Eq else Gt | Node l o r,Node l' o' r' => lex (compare_bool o o') (lex (compare_fun l l') (compare_fun r r')) end. Definition In i t := mem i t = true. Definition Equal s s' := forall a : elt, In a s <-> In a s'. Definition Subset s s' := forall a : elt, In a s -> In a s'. Definition Empty s := forall a : elt, ~ In a s. Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. Notation "s [=] t" := (Equal s t) (at level 70, no associativity). Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). Definition eq := Equal. Definition lt m m' := compare_fun m m' = Lt. (** Specification of [In] *) Lemma In_1: forall s x y, E.eq x y -> In x s -> In y s. Proof. intros s x y ->. trivial. Qed. (** Specification of [eq] *) Lemma eq_refl: forall s, eq s s. Proof. unfold eq, Equal. reflexivity. Qed. Lemma eq_sym: forall s s', eq s s' -> eq s' s. Proof. unfold eq, Equal. intros. symmetry. trivial. Qed. Lemma eq_trans: forall s s' s'', eq s s' -> eq s' s'' -> eq s s''. Proof. unfold eq, Equal. intros ? ? ? H ? ?. rewrite H. trivial. Qed. (** Specification of [mem] *) Lemma mem_1: forall s x, In x s -> mem x s = true. Proof. unfold In. trivial. Qed. Lemma mem_2: forall s x, mem x s = true -> In x s. Proof. unfold In. trivial. Qed. (** Additional lemmas for mem *) Lemma mem_Leaf: forall x, mem x Leaf = false. Proof. destruct x; trivial. Qed. (** Specification of [empty] *) Lemma empty_1 : Empty empty. Proof. unfold Empty, In. intro. rewrite mem_Leaf. discriminate. Qed. (** Specification of node *) Lemma mem_node: forall x l o r, mem x (node l o r) = mem x (Node l o r). Proof. intros x l o r. case o; trivial. destruct l; trivial. destruct r; trivial. symmetry. destruct x. apply mem_Leaf. apply mem_Leaf. reflexivity. Qed. Local Opaque node. (** Specification of [is_empty] *) Lemma is_empty_spec: forall s, Empty s <-> is_empty s = true. Proof. unfold Empty, In. induction s as [|l IHl o r IHr]; simpl. setoid_rewrite mem_Leaf. firstorder. rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- IHl, <- IHr. clear IHl IHr. destruct o; simpl; split. intro H. elim (H 1). reflexivity. intuition discriminate. intro H. split. split. reflexivity. intro a. apply (H a~0). intro a. apply (H a~1). intros H [a|a|]; apply H || intro; discriminate. Qed. Lemma is_empty_1: forall s, Empty s -> is_empty s = true. Proof. intro. rewrite is_empty_spec. trivial. Qed. Lemma is_empty_2: forall s, is_empty s = true -> Empty s. Proof. intro. rewrite is_empty_spec. trivial. Qed. (** Specification of [subset] *) Lemma subset_Leaf_s: forall s, Leaf [<=] s. Proof. intros s i Hi. elim (empty_1 Hi). Qed. Lemma subset_spec: forall s s', s [<=] s' <-> subset s s' = true. Proof. induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl. split; intros. reflexivity. apply subset_Leaf_s. split; intros. reflexivity. apply subset_Leaf_s. rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- 2is_empty_spec. destruct o; simpl. split. intro H. elim (@empty_1 1). apply H. reflexivity. intuition discriminate. split; intro H. split. split. reflexivity. unfold Empty. intros a H1. apply (@empty_1 (a~0)). apply H. assumption. unfold Empty. intros a H1. apply (@empty_1 (a~1)). apply H. assumption. destruct H as [[_ Hl] Hr]. intros [i|i|] Hi. elim (Hr i Hi). elim (Hl i Hi). discriminate. rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- IHl, <- IHr. clear. destruct o; simpl. split; intro H. split. split. destruct o'; trivial. specialize (H 1). unfold In in H. simpl in H. apply H. reflexivity. intros i Hi. apply (H i~0). apply Hi. intros i Hi. apply (H i~1). apply Hi. destruct H as [[Ho' Hl] Hr]. rewrite Ho'. intros i Hi. destruct i. apply (Hr i). assumption. apply (Hl i). assumption. assumption. split; intros. split. split. reflexivity. intros i Hi. apply (H i~0). apply Hi. intros i Hi. apply (H i~1). apply Hi. intros i Hi. destruct i; destruct H as [[H Hl] Hr]. apply (Hr i). assumption. apply (Hl i). assumption. discriminate Hi. Qed. Lemma subset_1: forall s s', Subset s s' -> subset s s' = true. Proof. intros s s'. apply -> subset_spec; trivial. Qed. Lemma subset_2: forall s s', subset s s' = true -> Subset s s'. Proof. intros s s'. apply <- subset_spec; trivial. Qed. (** Specification of [equal] (via subset) *) Lemma equal_subset: forall s s', equal s s' = subset s s' && subset s' s. Proof. induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl; trivial. destruct o. reflexivity. rewrite andb_comm. reflexivity. rewrite <- 6andb_lazy_alt. rewrite eq_iff_eq_true. rewrite 7andb_true_iff, eqb_true_iff. rewrite IHl, IHr, 2andb_true_iff. clear IHl IHr. intuition subst. destruct o'; reflexivity. destruct o'; reflexivity. destruct o; auto. destruct o'; trivial. Qed. Lemma equal_spec: forall s s', Equal s s' <-> equal s s' = true. Proof. intros. rewrite equal_subset. rewrite andb_true_iff. rewrite <- 2subset_spec. unfold Equal, Subset. firstorder. Qed. Lemma equal_1: forall s s', Equal s s' -> equal s s' = true. Proof. intros s s'. apply -> equal_spec; trivial. Qed. Lemma equal_2: forall s s', equal s s' = true -> Equal s s'. Proof. intros s s'. apply <- equal_spec; trivial. Qed. Lemma eq_dec : forall s s', { eq s s' } + { ~ eq s s' }. Proof. unfold eq. intros. case_eq (equal s s'); intro H. left. apply equal_2, H. right. abstract (intro H'; rewrite (equal_1 H') in H; discriminate). Defined. (** (Specified) definition of [compare] *) Lemma lex_Opp: forall u v u' v', u = CompOpp u' -> v = CompOpp v' -> lex u v = CompOpp (lex u' v'). Proof. intros ? ? u' ? -> ->. case u'; reflexivity. Qed. Lemma compare_bool_inv: forall b b', compare_bool b b' = CompOpp (compare_bool b' b). Proof. intros [|] [|]; reflexivity. Qed. Lemma compare_inv: forall s s', compare_fun s s' = CompOpp (compare_fun s' s). Proof. induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']; trivial. unfold compare_fun. case is_empty; reflexivity. unfold compare_fun. case is_empty; reflexivity. simpl. rewrite compare_bool_inv. case compare_bool; simpl; trivial; apply lex_Opp; auto. Qed. Lemma lex_Eq: forall u v, lex u v = Eq <-> u=Eq /\ v=Eq. Proof. intros u v; destruct u; intuition discriminate. Qed. Lemma compare_bool_Eq: forall b1 b2, compare_bool b1 b2 = Eq <-> eqb b1 b2 = true. Proof. intros [|] [|]; intuition discriminate. Qed. Lemma compare_equal: forall s s', compare_fun s s' = Eq <-> equal s s' = true. Proof. induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']. simpl. tauto. unfold compare_fun, equal. case is_empty; intuition discriminate. unfold compare_fun, equal. case is_empty; intuition discriminate. simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff. rewrite <- IHl, <- IHr, <- compare_bool_Eq. clear IHl IHr. rewrite and_assoc. rewrite <- 2lex_Eq. reflexivity. Qed. Lemma compare_gt: forall s s', compare_fun s s' = Gt -> lt s' s. Proof. unfold lt. intros s s'. rewrite compare_inv. case compare_fun; trivial; intros; discriminate. Qed. Lemma compare_eq: forall s s', compare_fun s s' = Eq -> eq s s'. Proof. unfold eq. intros s s'. rewrite compare_equal, equal_spec. trivial. Qed. Lemma compare : forall s s' : t, Compare lt eq s s'. Proof. intros. case_eq (compare_fun s s'); intro H. apply EQ. apply compare_eq, H. apply LT. assumption. apply GT. apply compare_gt, H. Defined. Section lt_spec. Inductive ct: comparison -> comparison -> comparison -> Prop := | ct_xxx: forall x, ct x x x | ct_xex: forall x, ct x Eq x | ct_exx: forall x, ct Eq x x | ct_glx: forall x, ct Gt Lt x | ct_lgx: forall x, ct Lt Gt x. Lemma ct_cxe: forall x, ct (CompOpp x) x Eq. Proof. destruct x; constructor. Qed. Lemma ct_xce: forall x, ct x (CompOpp x) Eq. Proof. destruct x; constructor. Qed. Lemma ct_lxl: forall x, ct Lt x Lt. Proof. destruct x; constructor. Qed. Lemma ct_gxg: forall x, ct Gt x Gt. Proof. destruct x; constructor. Qed. Lemma ct_xll: forall x, ct x Lt Lt. Proof. destruct x; constructor. Qed. Lemma ct_xgg: forall x, ct x Gt Gt. Proof. destruct x; constructor. Qed. Local Hint Constructors ct: ct. Local Hint Resolve ct_cxe ct_xce ct_lxl ct_xll ct_gxg ct_xgg: ct. Ltac ct := trivial with ct. Lemma ct_lex: forall u v w u' v' w', ct u v w -> ct u' v' w' -> ct (lex u u') (lex v v') (lex w w'). Proof. intros u v w u' v' w' H H'. inversion_clear H; inversion_clear H'; ct; destruct w; ct; destruct w'; ct. Qed. Lemma ct_compare_bool: forall a b c, ct (compare_bool a b) (compare_bool b c) (compare_bool a c). Proof. intros [|] [|] [|]; constructor. Qed. Lemma compare_x_Leaf: forall s, compare_fun s Leaf = if is_empty s then Eq else Gt. Proof. intros. rewrite compare_inv. simpl. case (is_empty s); reflexivity. Qed. Lemma compare_empty_x: forall a, is_empty a = true -> forall b, compare_fun a b = if is_empty b then Eq else Lt. Proof. induction a as [|l IHl o r IHr]; trivial. destruct o. intro; discriminate. simpl is_empty. rewrite <- andb_lazy_alt, andb_true_iff. intros [Hl Hr]. destruct b as [|l' [|] r']; simpl compare_fun; trivial. rewrite Hl, Hr. trivial. rewrite (IHl Hl), (IHr Hr). simpl. case (is_empty l'); case (is_empty r'); trivial. Qed. Lemma compare_x_empty: forall a, is_empty a = true -> forall b, compare_fun b a = if is_empty b then Eq else Gt. Proof. setoid_rewrite <- compare_x_Leaf. intros. rewrite 2(compare_inv b), (compare_empty_x _ H). reflexivity. Qed. Lemma ct_compare_fun: forall a b c, ct (compare_fun a b) (compare_fun b c) (compare_fun a c). Proof. induction a as [|l IHl o r IHr]; intros s' s''. destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']; ct. rewrite compare_inv. ct. unfold compare_fun at 1. case_eq (is_empty (Node l' o' r')); intro H'. rewrite (compare_empty_x _ H'). ct. unfold compare_fun at 2. case_eq (is_empty (Node l'' o'' r'')); intro H''. rewrite (compare_x_empty _ H''), H'. ct. ct. destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']. ct. unfold compare_fun at 2. rewrite compare_x_Leaf. case_eq (is_empty (Node l o r)); intro H. rewrite (compare_empty_x _ H). ct. case_eq (is_empty (Node l'' o'' r'')); intro H''. rewrite (compare_x_empty _ H''), H. ct. ct. rewrite 2 compare_x_Leaf. case_eq (is_empty (Node l o r)); intro H. rewrite compare_inv, (compare_x_empty _ H). ct. case_eq (is_empty (Node l' o' r')); intro H'. rewrite (compare_x_empty _ H'), H. ct. ct. simpl compare_fun. apply ct_lex. apply ct_compare_bool. apply ct_lex; trivial. Qed. End lt_spec. Lemma lt_trans: forall s s' s'', lt s s' -> lt s' s'' -> lt s s''. Proof. unfold lt. intros a b c. assert (H := ct_compare_fun a b c). inversion_clear H; trivial; intros; discriminate. Qed. Lemma lt_not_eq: forall s s', lt s s' -> ~ eq s s'. Proof. unfold lt, eq. intros s s' H H'. rewrite equal_spec, <- compare_equal in H'. congruence. Qed. (** Specification of [add] *) Lemma add_spec: forall x y s, In y (add x s) <-> x=y \/ In y s. Proof. unfold In. induction x; intros [y|y|] [|l o r]; simpl mem; try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; intuition congruence. Qed. Lemma add_1: forall s x y, x = y -> In y (add x s). Proof. intros. apply <- add_spec. left. assumption. Qed. Lemma add_2: forall s x y, In y s -> In y (add x s). Proof. intros. apply <- add_spec. right. assumption. Qed. Lemma add_3: forall s x y, x<>y -> In y (add x s) -> In y s. Proof. intros s x y H. rewrite add_spec. intros [->|?]; trivial. elim H; trivial. Qed. (** Specification of [remove] *) Lemma remove_spec: forall x y s, In y (remove x s) <-> x<>y /\ In y s. Proof. unfold In. induction x; intros [y|y|] [|l o r]; simpl remove; rewrite ?mem_node; simpl mem; try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; intuition congruence. Qed. Lemma remove_1: forall s x y, x=y -> ~ In y (remove x s). Proof. intros. rewrite remove_spec. tauto. Qed. Lemma remove_2: forall s x y, x<>y -> In y s -> In y (remove x s). Proof. intros. rewrite remove_spec. split; assumption. Qed. Lemma remove_3: forall s x y, In y (remove x s) -> In y s. Proof. intros s x y. rewrite remove_spec. tauto. Qed. (** Specification of [singleton] *) Lemma singleton_1: forall x y, In y (singleton x) -> x=y. Proof. unfold singleton. intros x y. rewrite add_spec. unfold In. rewrite mem_Leaf. intuition discriminate. Qed. Lemma singleton_2: forall x y, x = y -> In y (singleton x). Proof. unfold singleton. intros. apply add_1. assumption. Qed. (** Specification of [union] *) Lemma union_spec: forall x s s', In x (union s s') <-> In x s \/ In x s'. Proof. unfold In. induction x; destruct s; destruct s'; simpl union; simpl mem; try (rewrite IHx; clear IHx); try intuition congruence. apply orb_true_iff. Qed. Lemma union_1: forall s s' x, In x (union s s') -> In x s \/ In x s'. Proof. intros. apply -> union_spec. assumption. Qed. Lemma union_2: forall s s' x, In x s -> In x (union s s'). Proof. intros. apply <- union_spec. left. assumption. Qed. Lemma union_3: forall s s' x, In x s' -> In x (union s s'). Proof. intros. apply <- union_spec. right. assumption. Qed. (** Specification of [inter] *) Lemma inter_spec: forall x s s', In x (inter s s') <-> In x s /\ In x s'. Proof. unfold In. induction x; destruct s; destruct s'; simpl inter; rewrite ?mem_node; simpl mem; try (rewrite IHx; clear IHx); try intuition congruence. apply andb_true_iff. Qed. Lemma inter_1: forall s s' x, In x (inter s s') -> In x s. Proof. intros s s' x. rewrite inter_spec. tauto. Qed. Lemma inter_2: forall s s' x, In x (inter s s') -> In x s'. Proof. intros s s' x. rewrite inter_spec. tauto. Qed. Lemma inter_3: forall s s' x, In x s -> In x s' -> In x (inter s s'). Proof. intros. rewrite inter_spec. split; assumption. Qed. (** Specification of [diff] *) Lemma diff_spec: forall x s s', In x (diff s s') <-> In x s /\ ~ In x s'. Proof. unfold In. induction x; destruct s; destruct s' as [|l' o' r']; simpl diff; rewrite ?mem_node; simpl mem; try (rewrite IHx; clear IHx); try intuition congruence. rewrite andb_true_iff. destruct o'; intuition discriminate. Qed. Lemma diff_1: forall s s' x, In x (diff s s') -> In x s. Proof. intros s s' x. rewrite diff_spec. tauto. Qed. Lemma diff_2: forall s s' x, In x (diff s s') -> ~ In x s'. Proof. intros s s' x. rewrite diff_spec. tauto. Qed. Lemma diff_3: forall s s' x, In x s -> ~ In x s' -> In x (diff s s'). Proof. intros. rewrite diff_spec. split; assumption. Qed. (** Specification of [fold] *) Lemma fold_1: forall s (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. Proof. unfold fold, elements. intros s A i f. revert s i. set (f' := fun a e => f e a). assert (H: forall s i j acc, fold_left f' acc (xfold f s i j) = fold_left f' (xelements s j acc) i). induction s as [|l IHl o r IHr]; intros; trivial. destruct o; simpl xelements; simpl xfold. rewrite IHr, <- IHl. reflexivity. rewrite IHr. apply IHl. intros. exact (H s i 1 nil). Qed. (** Specification of [cardinal] *) Lemma cardinal_1: forall s, cardinal s = length (elements s). Proof. unfold elements. assert (H: forall s j acc, (cardinal s + length acc)%nat = length (xelements s j acc)). induction s as [|l IHl b r IHr]; intros j acc; simpl; trivial. destruct b. rewrite <- IHl. simpl. rewrite <- IHr. rewrite <- plus_n_Sm, Plus.plus_assoc. reflexivity. rewrite <- IHl, <- IHr. rewrite Plus.plus_assoc. reflexivity. intros. rewrite <- H. simpl. rewrite Plus.plus_comm. reflexivity. Qed. (** Specification of [filter] *) Lemma xfilter_spec: forall f s x i, In x (xfilter f s i) <-> In x s /\ f (i@x) = true. Proof. intro f. unfold In. induction s as [|l IHl o r IHr]; intros x i; simpl xfilter. rewrite mem_Leaf. intuition discriminate. rewrite mem_node. destruct x; simpl. rewrite IHr. reflexivity. rewrite IHl. reflexivity. rewrite <- andb_lazy_alt. apply andb_true_iff. Qed. Lemma filter_1 : forall s x f, compat_bool E.eq f -> In x (filter f s) -> In x s. Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed. Lemma filter_2 : forall s x f, compat_bool E.eq f -> In x (filter f s) -> f x = true. Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed. Lemma filter_3 : forall s x f, compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed. (** Specification of [for_all] *) Lemma xforall_spec: forall f s i, xforall f s i = true <-> For_all (fun x => f (i@x) = true) s. Proof. unfold For_all, In. intro f. induction s as [|l IHl o r IHr]; intros i; simpl. setoid_rewrite mem_Leaf. intuition discriminate. rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff. rewrite IHl, IHr. clear IHl IHr. split. intros [[Hi Hr] Hl] x. destruct x; simpl; intro H. apply Hr, H. apply Hl, H. rewrite H in Hi. assumption. intro H; intuition. specialize (H 1). destruct o. apply H. reflexivity. reflexivity. apply H. assumption. apply H. assumption. Qed. Lemma for_all_1 : forall s f, compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true. Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed. Lemma for_all_2 : forall s f, compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s. Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed. (** Specification of [exists] *) Lemma xexists_spec: forall f s i, xexists f s i = true <-> Exists (fun x => f (i@x) = true) s. Proof. unfold Exists, In. intro f. induction s as [|l IHl o r IHr]; intros i; simpl. setoid_rewrite mem_Leaf. firstorder. rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff. rewrite IHl, IHr. clear IHl IHr. split. intros [[Hi|[x Hr]]|[x Hl]]. exists 1. exact Hi. exists x~1. exact Hr. exists x~0. exact Hl. intros [[x|x|] H]; eauto. Qed. Lemma exists_1 : forall s f, compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed. Lemma exists_2 : forall s f, compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed. (** Specification of [partition] *) Lemma partition_filter : forall s f, partition f s = (filter f s, filter (fun x => negb (f x)) s). Proof. unfold partition, filter. intros s f. generalize 1 as j. induction s as [|l IHl o r IHr]; intro j. reflexivity. destruct o; simpl; rewrite IHl, IHr; reflexivity. Qed. Lemma partition_1 : forall s f, compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). Proof. intros. rewrite partition_filter. apply eq_refl. Qed. Lemma partition_2 : forall s f, compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). Proof. intros. rewrite partition_filter. apply eq_refl. Qed. (** Specification of [elements] *) Notation InL := (InA E.eq). Lemma xelements_spec: forall s j acc y, InL y (xelements s j acc) <-> InL y acc \/ exists x, y=(j@x) /\ mem x s = true. Proof. induction s as [|l IHl o r IHr]; simpl. intros. split; intro H. left. assumption. destruct H as [H|[x [Hx Hx']]]. assumption. elim (empty_1 Hx'). intros j acc y. case o. rewrite IHl. rewrite InA_cons. rewrite IHr. clear IHl IHr. split. intros [[H|[H|[x [-> H]]]]|[x [-> H]]]; eauto. right. exists x~1. auto. right. exists x~0. auto. intros [H|[x [-> H]]]. eauto. destruct x. left. right. right. exists x; auto. right. exists x; auto. left. left. reflexivity. rewrite IHl, IHr. clear IHl IHr. split. intros [[H|[x [-> H]]]|[x [-> H]]]. eauto. right. exists x~1. auto. right. exists x~0. auto. intros [H|[x [-> H]]]. eauto. destruct x. left. right. exists x; auto. right. exists x; auto. discriminate. Qed. Lemma elements_1: forall s x, In x s -> InL x (elements s). Proof. unfold elements, In. intros. rewrite xelements_spec. right. exists x. auto. Qed. Lemma elements_2: forall s x, InL x (elements s) -> In x s. Proof. unfold elements, In. intros s x H. rewrite xelements_spec in H. destruct H as [H|[y [H H']]]. inversion_clear H. rewrite H. assumption. Qed. Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y). Proof. induction j; intros; simpl; auto. Qed. Lemma elements_3: forall s, sort E.lt (elements s). Proof. unfold elements. assert (H: forall s j acc, sort E.lt acc -> (forall x y, In x s -> InL y acc -> E.lt (j@x) y) -> sort E.lt (xelements s j acc)). induction s as [|l IHl o r IHr]; simpl; trivial. intros j acc Hacc Hsacc. destruct o. apply IHl. constructor. apply IHr. apply Hacc. intros x y Hx Hy. apply Hsacc; assumption. case_eq (xelements r j~1 acc). constructor. intros z q H. constructor. assert (H': InL z (xelements r j~1 acc)). rewrite H. constructor. reflexivity. clear H q. rewrite xelements_spec in H'. destruct H' as [Hy|[x [-> Hx]]]. apply (Hsacc 1 z); trivial. reflexivity. simpl. apply lt_rev_append. exact I. intros x y Hx Hy. inversion_clear Hy. rewrite H. simpl. apply lt_rev_append. exact I. rewrite xelements_spec in H. destruct H as [Hy|[z [-> Hy]]]. apply Hsacc; assumption. simpl. apply lt_rev_append. exact I. apply IHl. apply IHr. apply Hacc. intros x y Hx Hy. apply Hsacc; assumption. intros x y Hx Hy. rewrite xelements_spec in Hy. destruct Hy as [Hy|[z [-> Hy]]]. apply Hsacc; assumption. simpl. apply lt_rev_append. exact I. intros. apply H. constructor. intros x y _ H'. inversion H'. Qed. Lemma elements_3w: forall s, NoDupA E.eq (elements s). Proof. intro. apply SortA_NoDupA with E.lt. constructor. intro. apply E.eq_refl. intro. apply E.eq_sym. intro. apply E.eq_trans. constructor. intros x H. apply E.lt_not_eq in H. apply H. reflexivity. intro. apply E.lt_trans. intros ? ? <- ? ? <-. reflexivity. apply elements_3. Qed. (** Specification of [choose] *) Lemma choose_1: forall s x, choose s = Some x -> In x s. Proof. induction s as [| l IHl o r IHr]; simpl. intros. discriminate. destruct o. intros x H. injection H; intros; subst. reflexivity. revert IHl. case choose. intros p Hp x H. injection H; intros; subst; clear H. apply Hp. reflexivity. intros _ x. revert IHr. case choose. intros p Hp H. injection H; intros; subst; clear H. apply Hp. reflexivity. intros. discriminate. Qed. Lemma choose_2: forall s, choose s = None -> Empty s. Proof. unfold Empty, In. intros s H. induction s as [|l IHl o r IHr]. intro. apply empty_1. destruct o. discriminate. simpl in H. destruct (choose l). discriminate. destruct (choose r). discriminate. intros [a|a|]. apply IHr. reflexivity. apply IHl. reflexivity. discriminate. Qed. Lemma choose_empty: forall s, is_empty s = true -> choose s = None. Proof. intros s Hs. case_eq (choose s); trivial. intros p Hp. apply choose_1 in Hp. apply is_empty_2 in Hs. elim (Hs _ Hp). Qed. Lemma choose_3': forall s s', Equal s s' -> choose s = choose s'. Proof. setoid_rewrite equal_spec. induction s as [|l IHl o r IHr]. intros. symmetry. apply choose_empty. assumption. destruct s' as [|l' o' r']. generalize (Node l o r) as s. simpl. intros. apply choose_empty. rewrite <- equal_spec in H. apply eq_sym in H. rewrite equal_spec in H. assumption. simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff, eqb_true_iff. intros [[<- Hl] Hr]. rewrite (IHl _ Hl), (IHr _ Hr). reflexivity. Qed. Lemma choose_3: forall s s' x y, choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. Proof. intros s s' x y Hx Hy H. apply choose_3' in H. congruence. Qed. (** Specification of [min_elt] *) Lemma min_elt_1: forall s x, min_elt s = Some x -> In x s. Proof. unfold In. induction s as [| l IHl o r IHr]; simpl. intros. discriminate. intros x. destruct (min_elt l); intros. injection H. intros <-. apply IHl. reflexivity. destruct o; simpl. injection H. intros <-. reflexivity. destruct (min_elt r); simpl in *. injection H. intros <-. apply IHr. reflexivity. discriminate. Qed. Lemma min_elt_3: forall s, min_elt s = None -> Empty s. Proof. unfold Empty, In. intros s H. induction s as [|l IHl o r IHr]. intro. apply empty_1. intros [a|a|]. apply IHr. revert H. clear. simpl. destruct (min_elt r); trivial. case min_elt; intros; try discriminate. destruct o; discriminate. apply IHl. revert H. clear. simpl. destruct (min_elt l); trivial. intro; discriminate. revert H. clear. simpl. case min_elt; intros; try discriminate. destruct o; discriminate. Qed. Lemma min_elt_2: forall s x y, min_elt s = Some x -> In y s -> ~ E.lt y x. Proof. unfold In. induction s as [|l IHl o r IHr]; intros x y H H'. discriminate. simpl in H. case_eq (min_elt l). intros p Hp. rewrite Hp in H. injection H; intros <-. destruct y as [z|z|]; simpl; intro; trivial. apply (IHl p z); trivial. intro Hp; rewrite Hp in H. apply min_elt_3 in Hp. destruct o. injection H. intros <- Hl. clear H. destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). destruct (min_elt r). injection H. intros <-. clear H. destruct y as [z|z|]. apply (IHr p z); trivial. elim (Hp _ H'). discriminate. discriminate. Qed. (** Specification of [max_elt] *) Lemma max_elt_1: forall s x, max_elt s = Some x -> In x s. Proof. unfold In. induction s as [| l IHl o r IHr]; simpl. intros. discriminate. intros x. destruct (max_elt r); intros. injection H. intros <-. apply IHr. reflexivity. destruct o; simpl. injection H. intros <-. reflexivity. destruct (max_elt l); simpl in *. injection H. intros <-. apply IHl. reflexivity. discriminate. Qed. Lemma max_elt_3: forall s, max_elt s = None -> Empty s. Proof. unfold Empty, In. intros s H. induction s as [|l IHl o r IHr]. intro. apply empty_1. intros [a|a|]. apply IHr. revert H. clear. simpl. destruct (max_elt r); trivial. intro; discriminate. apply IHl. revert H. clear. simpl. destruct (max_elt l); trivial. case max_elt; intros; try discriminate. destruct o; discriminate. revert H. clear. simpl. case max_elt; intros; try discriminate. destruct o; discriminate. Qed. Lemma max_elt_2: forall s x y, max_elt s = Some x -> In y s -> ~ E.lt x y. Proof. unfold In. induction s as [|l IHl o r IHr]; intros x y H H'. discriminate. simpl in H. case_eq (max_elt r). intros p Hp. rewrite Hp in H. injection H; intros <-. destruct y as [z|z|]; simpl; intro; trivial. apply (IHr p z); trivial. intro Hp; rewrite Hp in H. apply max_elt_3 in Hp. destruct o. injection H. intros <- Hl. clear H. destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). destruct (max_elt l). injection H. intros <-. clear H. destruct y as [z|z|]. elim (Hp _ H'). apply (IHl p z); trivial. discriminate. discriminate. Qed. End PositiveSet. coq-8.4pl4/theories/FSets/vo.itarget0000644000175000017500000000045612326224777016513 0ustar stephstephFMapAVL.vo FMapFacts.vo FMapFullAVL.vo FMapInterface.vo FMapList.vo FMapPositive.vo FMaps.vo FMapWeakList.vo FSetCompat.vo FSetAVL.vo FSetPositive.vo FSetBridge.vo FSetDecide.vo FSetEqProperties.vo FSetFacts.vo FSetInterface.vo FSetList.vo FSetProperties.vo FSets.vo FSetToFiniteSet.vo FSetWeakList.vo coq-8.4pl4/theories/FSets/FSetAVL.v0000644000175000017500000000443312326224777016100 0ustar stephsteph(* -*- coding: utf-8 -*- *) (***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (In x s <-> In y s). Proof. split; apply In_1; auto. Qed. Lemma mem_iff : In x s <-> mem x s = true. Proof. split; [apply mem_1|apply mem_2]. Qed. Lemma not_mem_iff : ~In x s <-> mem x s = false. Proof. rewrite mem_iff; destruct (mem x s); intuition. Qed. Lemma equal_iff : s[=]s' <-> equal s s' = true. Proof. split; [apply equal_1|apply equal_2]. Qed. Lemma subset_iff : s[<=]s' <-> subset s s' = true. Proof. split; [apply subset_1|apply subset_2]. Qed. Lemma empty_iff : In x empty <-> False. Proof. intuition; apply (empty_1 H). Qed. Lemma is_empty_iff : Empty s <-> is_empty s = true. Proof. split; [apply is_empty_1|apply is_empty_2]. Qed. Lemma singleton_iff : In y (singleton x) <-> E.eq x y. Proof. split; [apply singleton_1|apply singleton_2]. Qed. Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s. Proof. split; [ | destruct 1; [apply add_1|apply add_2]]; auto. destruct (eq_dec x y) as [E|E]; auto. intro H; right; exact (add_3 E H). Qed. Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s) <-> In y s). Proof. split; [apply add_3|apply add_2]; auto. Qed. Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y. Proof. split; [split; [apply remove_3 with x |] | destruct 1; apply remove_2]; auto. intro. apply (remove_1 H0 H). Qed. Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s). Proof. split; [apply remove_3|apply remove_2]; auto. Qed. Lemma union_iff : In x (union s s') <-> In x s \/ In x s'. Proof. split; [apply union_1 | destruct 1; [apply union_2|apply union_3]]; auto. Qed. Lemma inter_iff : In x (inter s s') <-> In x s /\ In x s'. Proof. split; [split; [apply inter_1 with s' | apply inter_2 with s] | destruct 1; apply inter_3]; auto. Qed. Lemma diff_iff : In x (diff s s') <-> In x s /\ ~ In x s'. Proof. split; [split; [apply diff_1 with s' | apply diff_2 with s] | destruct 1; apply diff_3]; auto. Qed. Variable f : elt->bool. Lemma filter_iff : compat_bool E.eq f -> (In x (filter f s) <-> In x s /\ f x = true). Proof. split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto. Qed. Lemma for_all_iff : compat_bool E.eq f -> (For_all (fun x => f x = true) s <-> for_all f s = true). Proof. split; [apply for_all_1 | apply for_all_2]; auto. Qed. Lemma exists_iff : compat_bool E.eq f -> (Exists (fun x => f x = true) s <-> exists_ f s = true). Proof. split; [apply exists_1 | apply exists_2]; auto. Qed. Lemma elements_iff : In x s <-> InA E.eq x (elements s). Proof. split; [apply elements_1 | apply elements_2]. Qed. End IffSpec. (** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *) Ltac set_iff := repeat (progress ( rewrite add_iff || rewrite remove_iff || rewrite singleton_iff || rewrite union_iff || rewrite inter_iff || rewrite diff_iff || rewrite empty_iff)). (** * Specifications written using boolean predicates *) Section BoolSpec. Variable s s' s'' : t. Variable x y z : elt. Lemma mem_b : E.eq x y -> mem x s = mem y s. Proof. intros. generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H). destruct (mem x s); destruct (mem y s); intuition. Qed. Lemma empty_b : mem y empty = false. Proof. generalize (empty_iff y)(mem_iff empty y). destruct (mem y empty); intuition. Qed. Lemma add_b : mem y (add x s) = eqb x y || mem y s. Proof. generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb. destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition. Qed. Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s. Proof. intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H). destruct (mem y s); destruct (mem y (add x s)); intuition. Qed. Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y). Proof. generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb. destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition. Qed. Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s. Proof. intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H). destruct (mem y s); destruct (mem y (remove x s)); intuition. Qed. Lemma singleton_b : mem y (singleton x) = eqb x y. Proof. generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb. destruct (eq_dec x y); destruct (mem y (singleton x)); intuition. Qed. Lemma union_b : mem x (union s s') = mem x s || mem x s'. Proof. generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x). destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition. Qed. Lemma inter_b : mem x (inter s s') = mem x s && mem x s'. Proof. generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x). destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition. Qed. Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s'). Proof. generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x). destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition. Qed. Lemma elements_b : mem x s = existsb (eqb x) (elements s). Proof. generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)). rewrite InA_alt. destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros. symmetry. rewrite H1. destruct H0 as (H0,_). destruct H0 as (a,(Ha1,Ha2)); [ intuition |]. exists a; intuition. unfold eqb; destruct (eq_dec x a); auto. rewrite <- H. rewrite H0. destruct H1 as (H1,_). destruct H1 as (a,(Ha1,Ha2)); [intuition|]. exists a; intuition. unfold eqb in *; destruct (eq_dec x a); auto; discriminate. Qed. Variable f : elt->bool. Lemma filter_b : compat_bool E.eq f -> mem x (filter f s) = mem x s && f x. Proof. intros. generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H). destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition. Qed. Lemma for_all_b : compat_bool E.eq f -> for_all f s = forallb f (elements s). Proof. intros. generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s). unfold For_all. destruct (forallb f (elements s)); destruct (for_all f s); auto; intros. rewrite <- H1; intros. destruct H0 as (H0,_). rewrite (H2 x0) in H3. rewrite (InA_alt E.eq x0 (elements s)) in H3. destruct H3 as (a,(Ha1,Ha2)). rewrite (H _ _ Ha1). apply H0; auto. symmetry. rewrite H0; intros. destruct H1 as (_,H1). apply H1; auto. rewrite H2. rewrite InA_alt; eauto. Qed. Lemma exists_b : compat_bool E.eq f -> exists_ f s = existsb f (elements s). Proof. intros. generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s). unfold Exists. destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros. rewrite <- H1; intros. destruct H0 as (H0,_). destruct H0 as (a,(Ha1,Ha2)); auto. exists a; split; auto. rewrite H2; rewrite InA_alt; eauto. symmetry. rewrite H0. destruct H1 as (_,H1). destruct H1 as (a,(Ha1,Ha2)); auto. rewrite (H2 a) in Ha1. rewrite (InA_alt E.eq a (elements s)) in Ha1. destruct Ha1 as (b,(Hb1,Hb2)). exists b; auto. rewrite <- (H _ _ Hb1); auto. Qed. End BoolSpec. (** * [E.eq] and [Equal] are setoid equalities *) Instance E_ST : Equivalence E.eq. Proof. constructor ; red; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans]. Qed. Instance Equal_ST : Equivalence Equal. Proof. constructor ; red; [apply eq_refl | apply eq_sym | apply eq_trans]. Qed. Instance In_m : Proper (E.eq ==> Equal ==> iff) In. Proof. unfold Equal; intros x y H s s' H0. rewrite (In_eq_iff s H); auto. Qed. Instance is_empty_m : Proper (Equal==> Logic.eq) is_empty. Proof. unfold Equal; intros s s' H. generalize (is_empty_iff s)(is_empty_iff s'). destruct (is_empty s); destruct (is_empty s'); unfold Empty; auto; intros. symmetry. rewrite <- H1; intros a Ha. rewrite <- (H a) in Ha. destruct H0 as (_,H0). exact (H0 Logic.eq_refl _ Ha). rewrite <- H0; intros a Ha. rewrite (H a) in Ha. destruct H1 as (_,H1). exact (H1 Logic.eq_refl _ Ha). Qed. Instance Empty_m : Proper (Equal ==> iff) Empty. Proof. repeat red; intros; do 2 rewrite is_empty_iff; rewrite H; intuition. Qed. Instance mem_m : Proper (E.eq ==> Equal ==> Logic.eq) mem. Proof. unfold Equal; intros x y H s s' H0. generalize (H0 x); clear H0; rewrite (In_eq_iff s' H). generalize (mem_iff s x)(mem_iff s' y). destruct (mem x s); destruct (mem y s'); intuition. Qed. Instance singleton_m : Proper (E.eq ==> Equal) singleton. Proof. unfold Equal; intros x y H a. do 2 rewrite singleton_iff; split; intros. apply E.eq_trans with x; auto. apply E.eq_trans with y; auto. Qed. Instance add_m : Proper (E.eq==>Equal==>Equal) add. Proof. unfold Equal; intros x y H s s' H0 a. do 2 rewrite add_iff; rewrite H; rewrite H0; intuition. Qed. Instance remove_m : Proper (E.eq==>Equal==>Equal) remove. Proof. unfold Equal; intros x y H s s' H0 a. do 2 rewrite remove_iff; rewrite H; rewrite H0; intuition. Qed. Instance union_m : Proper (Equal==>Equal==>Equal) union. Proof. unfold Equal; intros s s' H s'' s''' H0 a. do 2 rewrite union_iff; rewrite H; rewrite H0; intuition. Qed. Instance inter_m : Proper (Equal==>Equal==>Equal) inter. Proof. unfold Equal; intros s s' H s'' s''' H0 a. do 2 rewrite inter_iff; rewrite H; rewrite H0; intuition. Qed. Instance diff_m : Proper (Equal==>Equal==>Equal) diff. Proof. unfold Equal; intros s s' H s'' s''' H0 a. do 2 rewrite diff_iff; rewrite H; rewrite H0; intuition. Qed. Instance Subset_m : Proper (Equal==>Equal==>iff) Subset. Proof. unfold Equal, Subset; firstorder. Qed. Instance subset_m : Proper (Equal ==> Equal ==> Logic.eq) subset. Proof. intros s s' H s'' s''' H0. generalize (subset_iff s s'') (subset_iff s' s'''). destruct (subset s s''); destruct (subset s' s'''); auto; intros. rewrite H in H1; rewrite H0 in H1; intuition. rewrite H in H1; rewrite H0 in H1; intuition. Qed. Instance equal_m : Proper (Equal ==> Equal ==> Logic.eq) equal. Proof. intros s s' H s'' s''' H0. generalize (equal_iff s s'') (equal_iff s' s'''). destruct (equal s s''); destruct (equal s' s'''); auto; intros. rewrite H in H1; rewrite H0 in H1; intuition. rewrite H in H1; rewrite H0 in H1; intuition. Qed. (* [Subset] is a setoid order *) Lemma Subset_refl : forall s, s[<=]s. Proof. red; auto. Qed. Lemma Subset_trans : forall s s' s'', s[<=]s'->s'[<=]s''->s[<=]s''. Proof. unfold Subset; eauto. Qed. Add Relation t Subset reflexivity proved by Subset_refl transitivity proved by Subset_trans as SubsetSetoid. Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> Basics.impl) In | 1. Proof. simpl_relation. eauto with set. Qed. Add Morphism Empty with signature Subset --> Basics.impl as Empty_s_m. Proof. unfold Subset, Empty, Basics.impl; firstorder. Qed. Add Morphism add with signature E.eq ==> Subset ++> Subset as add_s_m. Proof. unfold Subset; intros x y H s s' H0 a. do 2 rewrite add_iff; rewrite H; intuition. Qed. Add Morphism remove with signature E.eq ==> Subset ++> Subset as remove_s_m. Proof. unfold Subset; intros x y H s s' H0 a. do 2 rewrite remove_iff; rewrite H; intuition. Qed. Add Morphism union with signature Subset ++> Subset ++> Subset as union_s_m. Proof. unfold Equal; intros s s' H s'' s''' H0 a. do 2 rewrite union_iff; intuition. Qed. Add Morphism inter with signature Subset ++> Subset ++> Subset as inter_s_m. Proof. unfold Equal; intros s s' H s'' s''' H0 a. do 2 rewrite inter_iff; intuition. Qed. Add Morphism diff with signature Subset ++> Subset --> Subset as diff_s_m. Proof. unfold Subset; intros s s' H s'' s''' H0 a. do 2 rewrite diff_iff; intuition. Qed. (* [fold], [filter], [for_all], [exists_] and [partition] cannot be proved morphism without additional hypothesis on [f]. For instance: *) Lemma filter_equal : forall f, compat_bool E.eq f -> forall s s', s[=]s' -> filter f s [=] filter f s'. Proof. unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto. Qed. Lemma filter_ext : forall f f', compat_bool E.eq f -> (forall x, f x = f' x) -> forall s s', s[=]s' -> filter f s [=] filter f' s'. Proof. intros f f' Hf Hff' s s' Hss' x. do 2 (rewrite filter_iff; auto). rewrite Hff', Hss'; intuition. repeat red; intros; rewrite <- 2 Hff'; auto. Qed. Lemma filter_subset : forall f, compat_bool E.eq f -> forall s s', s[<=]s' -> filter f s [<=] filter f s'. Proof. unfold Subset; intros; rewrite filter_iff in *; intuition. Qed. (* For [elements], [min_elt], [max_elt] and [choose], we would need setoid structures on [list elt] and [option elt]. *) (* Later: Add Morphism cardinal ; cardinal_m. *) End WFacts_fun. (** Now comes variants for self-contained weak sets and for full sets. For these variants, only one argument is necessary. Thanks to the subtyping [WS<=S], the [Facts] functor which is meant to be used on modules [(M:S)] can simply be an alias of [WFacts]. *) Module WFacts (M:WS) := WFacts_fun M.E M. Module Facts := WFacts. coq-8.4pl4/theories/FSets/FMapFacts.v0000644000175000017500000020066312326224777016503 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constructor; congruence. (** * Facts about weak maps *) Module WFacts_fun (E:DecidableType)(Import M:WSfun E). Notation eq_dec := E.eq_dec. Definition eqb x y := if eq_dec x y then true else false. Lemma eq_bool_alt : forall b b', b=b' <-> (b=true <-> b'=true). Proof. destruct b; destruct b'; intuition. Qed. Lemma eq_option_alt : forall (elt:Type)(o o':option elt), o=o' <-> (forall e, o=Some e <-> o'=Some e). Proof. split; intros. subst; split; auto. destruct o; destruct o'; try rewrite H; auto. symmetry; rewrite <- H; auto. Qed. Lemma MapsTo_fun : forall (elt:Type) m x (e e':elt), MapsTo x e m -> MapsTo x e' m -> e=e'. Proof. intros. generalize (find_1 H) (find_1 H0); clear H H0. intros; rewrite H in H0; injection H0; auto. Qed. (** ** Specifications written using equivalences *) Section IffSpec. Variable elt elt' elt'': Type. Implicit Type m: t elt. Implicit Type x y z: key. Implicit Type e: elt. Lemma In_iff : forall m x y, E.eq x y -> (In x m <-> In y m). Proof. unfold In. split; intros (e0,H0); exists e0. apply (MapsTo_1 H H0); auto. apply (MapsTo_1 (E.eq_sym H) H0); auto. Qed. Lemma MapsTo_iff : forall m x y e, E.eq x y -> (MapsTo x e m <-> MapsTo y e m). Proof. split; apply MapsTo_1; auto. Qed. Lemma mem_in_iff : forall m x, In x m <-> mem x m = true. Proof. split; [apply mem_1|apply mem_2]. Qed. Lemma not_mem_in_iff : forall m x, ~In x m <-> mem x m = false. Proof. intros; rewrite mem_in_iff; destruct (mem x m); intuition. Qed. Lemma In_dec : forall m x, { In x m } + { ~ In x m }. Proof. intros. generalize (mem_in_iff m x). destruct (mem x m); [left|right]; intuition. Qed. Lemma find_mapsto_iff : forall m x e, MapsTo x e m <-> find x m = Some e. Proof. split; [apply find_1|apply find_2]. Qed. Lemma not_find_in_iff : forall m x, ~In x m <-> find x m = None. Proof. split; intros. rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff. split; try discriminate. intro H'; elim H; exists e; auto. intros (e,He); rewrite find_mapsto_iff,H in He; discriminate. Qed. Lemma in_find_iff : forall m x, In x m <-> find x m <> None. Proof. intros; rewrite <- not_find_in_iff, mem_in_iff. destruct mem; intuition. Qed. Lemma equal_iff : forall m m' cmp, Equivb cmp m m' <-> equal cmp m m' = true. Proof. split; [apply equal_1|apply equal_2]. Qed. Lemma empty_mapsto_iff : forall x e, MapsTo x e (empty elt) <-> False. Proof. intuition; apply (empty_1 H). Qed. Lemma empty_in_iff : forall x, In x (empty elt) <-> False. Proof. unfold In. split; [intros (e,H); rewrite empty_mapsto_iff in H|]; intuition. Qed. Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true. Proof. split; [apply is_empty_1|apply is_empty_2]. Qed. Lemma add_mapsto_iff : forall m x y e e', MapsTo y e' (add x e m) <-> (E.eq x y /\ e=e') \/ (~E.eq x y /\ MapsTo y e' m). Proof. intros. intuition. destruct (eq_dec x y); [left|right]. split; auto. symmetry; apply (MapsTo_fun (e':=e) H); auto with map. split; auto; apply add_3 with x e; auto. subst; auto with map. Qed. Lemma add_in_iff : forall m x y e, In y (add x e m) <-> E.eq x y \/ In y m. Proof. unfold In; split. intros (e',H). destruct (eq_dec x y) as [E|E]; auto. right; exists e'; auto. apply (add_3 E H). destruct (eq_dec x y) as [E|E]; auto. intros. exists e; apply add_1; auto. intros [H|(e',H)]. destruct E; auto. exists e'; apply add_2; auto. Qed. Lemma add_neq_mapsto_iff : forall m x y e e', ~ E.eq x y -> (MapsTo y e' (add x e m) <-> MapsTo y e' m). Proof. split; [apply add_3|apply add_2]; auto. Qed. Lemma add_neq_in_iff : forall m x y e, ~ E.eq x y -> (In y (add x e m) <-> In y m). Proof. split; intros (e',H0); exists e'. apply (add_3 H H0). apply add_2; auto. Qed. Lemma remove_mapsto_iff : forall m x y e, MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m. Proof. intros. split; intros. split. assert (In y (remove x m)) by (exists e; auto). intro H1; apply (remove_1 H1 H0). apply remove_3 with x; auto. apply remove_2; intuition. Qed. Lemma remove_in_iff : forall m x y, In y (remove x m) <-> ~E.eq x y /\ In y m. Proof. unfold In; split. intros (e,H). split. assert (In y (remove x m)) by (exists e; auto). intro H1; apply (remove_1 H1 H0). exists e; apply remove_3 with x; auto. intros (H,(e,H0)); exists e; apply remove_2; auto. Qed. Lemma remove_neq_mapsto_iff : forall m x y e, ~ E.eq x y -> (MapsTo y e (remove x m) <-> MapsTo y e m). Proof. split; [apply remove_3|apply remove_2]; auto. Qed. Lemma remove_neq_in_iff : forall m x y, ~ E.eq x y -> (In y (remove x m) <-> In y m). Proof. split; intros (e',H0); exists e'. apply (remove_3 H0). apply remove_2; auto. Qed. Lemma elements_mapsto_iff : forall m x e, MapsTo x e m <-> InA (@eq_key_elt _) (x,e) (elements m). Proof. split; [apply elements_1 | apply elements_2]. Qed. Lemma elements_in_iff : forall m x, In x m <-> exists e, InA (@eq_key_elt _) (x,e) (elements m). Proof. unfold In; split; intros (e,H); exists e; [apply elements_1 | apply elements_2]; auto. Qed. Lemma map_mapsto_iff : forall m x b (f : elt -> elt'), MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m. Proof. split. case_eq (find x m); intros. exists e. split. apply (MapsTo_fun (m:=map f m) (x:=x)); auto with map. apply find_2; auto with map. assert (In x (map f m)) by (exists b; auto). destruct (map_2 H1) as (a,H2). rewrite (find_1 H2) in H; discriminate. intros (a,(H,H0)). subst b; auto with map. Qed. Lemma map_in_iff : forall m x (f : elt -> elt'), In x (map f m) <-> In x m. Proof. split; intros; eauto with map. destruct H as (a,H). exists (f a); auto with map. Qed. Lemma mapi_in_iff : forall m x (f:key->elt->elt'), In x (mapi f m) <-> In x m. Proof. split; intros; eauto with map. destruct H as (a,H). destruct (mapi_1 f H) as (y,(H0,H1)). exists (f y a); auto. Qed. (** Unfortunately, we don't have simple equivalences for [mapi] and [MapsTo]. The only correct one needs compatibility of [f]. *) Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), MapsTo x b (mapi f m) -> exists a y, E.eq y x /\ b = f y a /\ MapsTo x a m. Proof. intros; case_eq (find x m); intros. exists e. destruct (@mapi_1 _ _ m x e f) as (y,(H1,H2)). apply find_2; auto with map. exists y; repeat split; auto with map. apply (MapsTo_fun (m:=mapi f m) (x:=x)); auto with map. assert (In x (mapi f m)) by (exists b; auto). destruct (mapi_2 H1) as (a,H2). rewrite (find_1 H2) in H0; discriminate. Qed. Lemma mapi_1bis : forall m x e (f:key->elt->elt'), (forall x y e, E.eq x y -> f x e = f y e) -> MapsTo x e m -> MapsTo x (f x e) (mapi f m). Proof. intros. destruct (mapi_1 f H0) as (y,(H1,H2)). replace (f x e) with (f y e) by auto. auto. Qed. Lemma mapi_mapsto_iff : forall m x b (f:key->elt->elt'), (forall x y e, E.eq x y -> f x e = f y e) -> (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m). Proof. split. intros. destruct (mapi_inv H0) as (a,(y,(H1,(H2,H3)))). exists a; split; auto. subst b; auto. intros (a,(H0,H1)). subst b. apply mapi_1bis; auto. Qed. (** Things are even worse for [map2] : we don't try to state any equivalence, see instead boolean results below. *) End IffSpec. (** Useful tactic for simplifying expressions like [In y (add x e (remove z m))] *) Ltac map_iff := repeat (progress ( rewrite add_mapsto_iff || rewrite add_in_iff || rewrite remove_mapsto_iff || rewrite remove_in_iff || rewrite empty_mapsto_iff || rewrite empty_in_iff || rewrite map_mapsto_iff || rewrite map_in_iff || rewrite mapi_in_iff)). (** ** Specifications written using boolean predicates *) Section BoolSpec. Lemma mem_find_b : forall (elt:Type)(m:t elt)(x:key), mem x m = if find x m then true else false. Proof. intros. generalize (find_mapsto_iff m x)(mem_in_iff m x); unfold In. destruct (find x m); destruct (mem x m); auto. intros. rewrite <- H0; exists e; rewrite H; auto. intuition. destruct H0 as (e,H0). destruct (H e); intuition discriminate. Qed. Variable elt elt' elt'' : Type. Implicit Types m : t elt. Implicit Types x y z : key. Implicit Types e : elt. Lemma mem_b : forall m x y, E.eq x y -> mem x m = mem y m. Proof. intros. generalize (mem_in_iff m x) (mem_in_iff m y)(In_iff m H). destruct (mem x m); destruct (mem y m); intuition. Qed. Lemma find_o : forall m x y, E.eq x y -> find x m = find y m. Proof. intros. rewrite eq_option_alt. intro e. rewrite <- 2 find_mapsto_iff. apply MapsTo_iff; auto. Qed. Lemma empty_o : forall x, find x (empty elt) = None. Proof. intros. rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff, empty_mapsto_iff; now intuition. Qed. Lemma empty_a : forall x, mem x (empty elt) = false. Proof. intros. case_eq (mem x (empty elt)); intros; auto. generalize (mem_2 H). rewrite empty_in_iff; intuition. Qed. Lemma add_eq_o : forall m x y e, E.eq x y -> find y (add x e m) = Some e. Proof. auto with map. Qed. Lemma add_neq_o : forall m x y e, ~ E.eq x y -> find y (add x e m) = find y m. Proof. intros. rewrite eq_option_alt. intro e'. rewrite <- 2 find_mapsto_iff. apply add_neq_mapsto_iff; auto. Qed. Hint Resolve add_neq_o : map. Lemma add_o : forall m x y e, find y (add x e m) = if eq_dec x y then Some e else find y m. Proof. intros; destruct (eq_dec x y); auto with map. Qed. Lemma add_eq_b : forall m x y e, E.eq x y -> mem y (add x e m) = true. Proof. intros; rewrite mem_find_b; rewrite add_eq_o; auto. Qed. Lemma add_neq_b : forall m x y e, ~E.eq x y -> mem y (add x e m) = mem y m. Proof. intros; do 2 rewrite mem_find_b; rewrite add_neq_o; auto. Qed. Lemma add_b : forall m x y e, mem y (add x e m) = eqb x y || mem y m. Proof. intros; do 2 rewrite mem_find_b; rewrite add_o; unfold eqb. destruct (eq_dec x y); simpl; auto. Qed. Lemma remove_eq_o : forall m x y, E.eq x y -> find y (remove x m) = None. Proof. intros. rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff, remove_mapsto_iff; now intuition. Qed. Hint Resolve remove_eq_o : map. Lemma remove_neq_o : forall m x y, ~ E.eq x y -> find y (remove x m) = find y m. Proof. intros. rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff, remove_neq_mapsto_iff; now intuition. Qed. Hint Resolve remove_neq_o : map. Lemma remove_o : forall m x y, find y (remove x m) = if eq_dec x y then None else find y m. Proof. intros; destruct (eq_dec x y); auto with map. Qed. Lemma remove_eq_b : forall m x y, E.eq x y -> mem y (remove x m) = false. Proof. intros; rewrite mem_find_b; rewrite remove_eq_o; auto. Qed. Lemma remove_neq_b : forall m x y, ~ E.eq x y -> mem y (remove x m) = mem y m. Proof. intros; do 2 rewrite mem_find_b; rewrite remove_neq_o; auto. Qed. Lemma remove_b : forall m x y, mem y (remove x m) = negb (eqb x y) && mem y m. Proof. intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb. destruct (eq_dec x y); auto. Qed. Definition option_map (A B:Type)(f:A->B)(o:option A) : option B := match o with | Some a => Some (f a) | None => None end. Lemma map_o : forall m x (f:elt->elt'), find x (map f m) = option_map f (find x m). Proof. intros. generalize (find_mapsto_iff (map f m) x) (find_mapsto_iff m x) (fun b => map_mapsto_iff m x b f). destruct (find x (map f m)); destruct (find x m); simpl; auto; intros. rewrite <- H; rewrite H1; exists e0; rewrite H0; auto. destruct (H e) as [_ H2]. rewrite H1 in H2. destruct H2 as (a,(_,H2)); auto. rewrite H0 in H2; discriminate. rewrite <- H; rewrite H1; exists e; rewrite H0; auto. Qed. Lemma map_b : forall m x (f:elt->elt'), mem x (map f m) = mem x m. Proof. intros; do 2 rewrite mem_find_b; rewrite map_o. destruct (find x m); simpl; auto. Qed. Lemma mapi_b : forall m x (f:key->elt->elt'), mem x (mapi f m) = mem x m. Proof. intros. generalize (mem_in_iff (mapi f m) x) (mem_in_iff m x) (mapi_in_iff m x f). destruct (mem x (mapi f m)); destruct (mem x m); simpl; auto; intros. symmetry; rewrite <- H0; rewrite <- H1; rewrite H; auto. rewrite <- H; rewrite H1; rewrite H0; auto. Qed. Lemma mapi_o : forall m x (f:key->elt->elt'), (forall x y e, E.eq x y -> f x e = f y e) -> find x (mapi f m) = option_map (f x) (find x m). Proof. intros. generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x) (fun b => mapi_mapsto_iff m x b H). destruct (find x (mapi f m)); destruct (find x m); simpl; auto; intros. rewrite <- H0; rewrite H2; exists e0; rewrite H1; auto. destruct (H0 e) as [_ H3]. rewrite H2 in H3. destruct H3 as (a,(_,H3)); auto. rewrite H1 in H3; discriminate. rewrite <- H0; rewrite H2; exists e; rewrite H1; auto. Qed. Lemma map2_1bis : forall (m: t elt)(m': t elt') x (f:option elt->option elt'->option elt''), f None None = None -> find x (map2 f m m') = f (find x m) (find x m'). Proof. intros. case_eq (find x m); intros. rewrite <- H0. apply map2_1; auto with map. left; exists e; auto with map. case_eq (find x m'); intros. rewrite <- H0; rewrite <- H1. apply map2_1; auto. right; exists e; auto with map. rewrite H. case_eq (find x (map2 f m m')); intros; auto with map. assert (In x (map2 f m m')) by (exists e; auto with map). destruct (map2_2 H3) as [(e0,H4)|(e0,H4)]. rewrite (find_1 H4) in H0; discriminate. rewrite (find_1 H4) in H1; discriminate. Qed. Lemma elements_o : forall m x, find x m = findA (eqb x) (elements m). Proof. intros. rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff, elements_mapsto_iff. unfold eqb. rewrite <- findA_NoDupA; intuition; try apply elements_3w; eauto. Qed. Lemma elements_b : forall m x, mem x m = existsb (fun p => eqb x (fst p)) (elements m). Proof. intros. generalize (mem_in_iff m x)(elements_in_iff m x) (existsb_exists (fun p => eqb x (fst p)) (elements m)). destruct (mem x m); destruct (existsb (fun p => eqb x (fst p)) (elements m)); auto; intros. symmetry; rewrite H1. destruct H0 as (H0,_). destruct H0 as (e,He); [ intuition |]. rewrite InA_alt in He. destruct He as ((y,e'),(Ha1,Ha2)). compute in Ha1; destruct Ha1; subst e'. exists (y,e); split; simpl; auto. unfold eqb; destruct (eq_dec x y); intuition. rewrite <- H; rewrite H0. destruct H1 as (H1,_). destruct H1 as ((y,e),(Ha1,Ha2)); [intuition|]. simpl in Ha2. unfold eqb in *; destruct (eq_dec x y); auto; try discriminate. exists e; rewrite InA_alt. exists (y,e); intuition. compute; auto. Qed. End BoolSpec. Section Equalities. Variable elt:Type. (** Another characterisation of [Equal] *) Lemma Equal_mapsto_iff : forall m1 m2 : t elt, Equal m1 m2 <-> (forall k e, MapsTo k e m1 <-> MapsTo k e m2). Proof. intros m1 m2. split; [intros Heq k e|intros Hiff]. rewrite 2 find_mapsto_iff, Heq. split; auto. intro k. rewrite eq_option_alt. intro e. rewrite <- 2 find_mapsto_iff; auto. Qed. (** * Relations between [Equal], [Equiv] and [Equivb]. *) (** First, [Equal] is [Equiv] with Leibniz on elements. *) Lemma Equal_Equiv : forall (m m' : t elt), Equal m m' <-> Equiv Logic.eq m m'. Proof. intros. rewrite Equal_mapsto_iff. split; intros. split. split; intros (e,Hin); exists e; [rewrite <- H|rewrite H]; auto. intros; apply MapsTo_fun with m k; auto; rewrite H; auto. split; intros H'. destruct H. assert (Hin : In k m') by (rewrite <- H; exists e; auto). destruct Hin as (e',He'). rewrite (H0 k e e'); auto. destruct H. assert (Hin : In k m) by (rewrite H; exists e; auto). destruct Hin as (e',He'). rewrite <- (H0 k e' e); auto. Qed. (** [Equivb] and [Equiv] and equivalent when [eq_elt] and [cmp] are related. *) Section Cmp. Variable eq_elt : elt->elt->Prop. Variable cmp : elt->elt->bool. Definition compat_cmp := forall e e', cmp e e' = true <-> eq_elt e e'. Lemma Equiv_Equivb : compat_cmp -> forall m m', Equiv eq_elt m m' <-> Equivb cmp m m'. Proof. unfold Equivb, Equiv, Cmp; intuition. red in H; rewrite H; eauto. red in H; rewrite <-H; eauto. Qed. End Cmp. (** Composition of the two last results: relation between [Equal] and [Equivb]. *) Lemma Equal_Equivb : forall cmp, (forall e e', cmp e e' = true <-> e = e') -> forall (m m':t elt), Equal m m' <-> Equivb cmp m m'. Proof. intros; rewrite Equal_Equiv. apply Equiv_Equivb; auto. Qed. Lemma Equal_Equivb_eqdec : forall eq_elt_dec : (forall e e', { e = e' } + { e <> e' }), let cmp := fun e e' => if eq_elt_dec e e' then true else false in forall (m m':t elt), Equal m m' <-> Equivb cmp m m'. Proof. intros; apply Equal_Equivb. unfold cmp; clear cmp; intros. destruct eq_elt_dec; now intuition. Qed. End Equalities. (** * [Equal] is a setoid equality. *) Lemma Equal_refl : forall (elt:Type)(m : t elt), Equal m m. Proof. red; reflexivity. Qed. Lemma Equal_sym : forall (elt:Type)(m m' : t elt), Equal m m' -> Equal m' m. Proof. unfold Equal; auto. Qed. Lemma Equal_trans : forall (elt:Type)(m m' m'' : t elt), Equal m m' -> Equal m' m'' -> Equal m m''. Proof. unfold Equal; congruence. Qed. Definition Equal_ST : forall elt:Type, Equivalence (@Equal elt). Proof. constructor; red; [apply Equal_refl | apply Equal_sym | apply Equal_trans]. Qed. Add Relation key E.eq reflexivity proved by E.eq_refl symmetry proved by E.eq_sym transitivity proved by E.eq_trans as KeySetoid. Arguments Equal {elt} m m'. Add Parametric Relation (elt : Type) : (t elt) Equal reflexivity proved by (@Equal_refl elt) symmetry proved by (@Equal_sym elt) transitivity proved by (@Equal_trans elt) as EqualSetoid. Add Parametric Morphism elt : (@In elt) with signature E.eq ==> Equal ==> iff as In_m. Proof. unfold Equal; intros k k' Hk m m' Hm. rewrite (In_iff m Hk), in_find_iff, in_find_iff, Hm; intuition. Qed. Add Parametric Morphism elt : (@MapsTo elt) with signature E.eq ==> eq ==> Equal ==> iff as MapsTo_m. Proof. unfold Equal; intros k k' Hk e m m' Hm. rewrite (MapsTo_iff m e Hk), find_mapsto_iff, find_mapsto_iff, Hm; intuition. Qed. Add Parametric Morphism elt : (@Empty elt) with signature Equal ==> iff as Empty_m. Proof. unfold Empty; intros m m' Hm; intuition. rewrite <-Hm in H0; eauto. rewrite Hm in H0; eauto. Qed. Add Parametric Morphism elt : (@is_empty elt) with signature Equal ==> eq as is_empty_m. Proof. intros m m' Hm. rewrite eq_bool_alt, <-is_empty_iff, <-is_empty_iff, Hm; intuition. Qed. Add Parametric Morphism elt : (@mem elt) with signature E.eq ==> Equal ==> eq as mem_m. Proof. intros k k' Hk m m' Hm. rewrite eq_bool_alt, <- mem_in_iff, <-mem_in_iff, Hk, Hm; intuition. Qed. Add Parametric Morphism elt : (@find elt) with signature E.eq ==> Equal ==> eq as find_m. Proof. intros k k' Hk m m' Hm. rewrite eq_option_alt. intro e. rewrite <- 2 find_mapsto_iff, Hk, Hm. split; auto. Qed. Add Parametric Morphism elt : (@add elt) with signature E.eq ==> eq ==> Equal ==> Equal as add_m. Proof. intros k k' Hk e m m' Hm y. rewrite add_o, add_o; do 2 destruct eq_dec; auto. elim n; rewrite <-Hk; auto. elim n; rewrite Hk; auto. Qed. Add Parametric Morphism elt : (@remove elt) with signature E.eq ==> Equal ==> Equal as remove_m. Proof. intros k k' Hk m m' Hm y. rewrite remove_o, remove_o; do 2 destruct eq_dec; auto. elim n; rewrite <-Hk; auto. elim n; rewrite Hk; auto. Qed. Add Parametric Morphism elt elt' : (@map elt elt') with signature eq ==> Equal ==> Equal as map_m. Proof. intros f m m' Hm y. rewrite map_o, map_o, Hm; auto. Qed. (* Later: Add Morphism cardinal *) (* old name: *) Notation not_find_mapsto_iff := not_find_in_iff. End WFacts_fun. (** * Same facts for self-contained weak sets and for full maps *) Module WFacts (M:WS) := WFacts_fun M.E M. Module Facts := WFacts. (** * Additional Properties for weak maps Results about [fold], [elements], induction principles... *) Module WProperties_fun (E:DecidableType)(M:WSfun E). Module Import F:=WFacts_fun E M. Import M. Section Elt. Variable elt:Type. Definition Add x (e:elt) m m' := forall y, find y m' = find y (add x e m). Notation eqke := (@eq_key_elt elt). Notation eqk := (@eq_key elt). Instance eqk_equiv : Equivalence eqk. Proof. unfold eq_key; split; eauto. Qed. Instance eqke_equiv : Equivalence eqke. Proof. unfold eq_key_elt; split; repeat red; firstorder. eauto with *. congruence. Qed. (** Complements about InA, NoDupA and findA *) Lemma InA_eqke_eqk : forall k1 k2 e1 e2 l, E.eq k1 k2 -> InA eqke (k1,e1) l -> InA eqk (k2,e2) l. Proof. intros k1 k2 e1 e2 l Hk. rewrite 2 InA_alt. intros ((k',e') & (Hk',He') & H); simpl in *. exists (k',e'); split; auto. red; simpl; eauto. Qed. Lemma NoDupA_eqk_eqke : forall l, NoDupA eqk l -> NoDupA eqke l. Proof. induction 1; auto. constructor; auto. destruct x as (k,e). eauto using InA_eqke_eqk. Qed. Lemma findA_rev : forall l k, NoDupA eqk l -> findA (eqb k) l = findA (eqb k) (rev l). Proof. intros. case_eq (findA (eqb k) l). intros. symmetry. unfold eqb. rewrite <- findA_NoDupA, InA_rev, findA_NoDupA by (eauto using NoDupA_rev with *); eauto. case_eq (findA (eqb k) (rev l)); auto. intros e. unfold eqb. rewrite <- findA_NoDupA, InA_rev, findA_NoDupA by (eauto using NoDupA_rev with *). intro Eq; rewrite Eq; auto. Qed. (** * Elements *) Lemma elements_Empty : forall m:t elt, Empty m <-> elements m = nil. Proof. intros. unfold Empty. split; intros. assert (forall a, ~ List.In a (elements m)). red; intros. apply (H (fst a) (snd a)). rewrite elements_mapsto_iff. rewrite InA_alt; exists a; auto. split; auto; split; auto. destruct (elements m); auto. elim (H0 p); simpl; auto. red; intros. rewrite elements_mapsto_iff in H0. rewrite InA_alt in H0; destruct H0. rewrite H in H0; destruct H0 as (_,H0); inversion H0. Qed. Lemma elements_empty : elements (@empty elt) = nil. Proof. rewrite <-elements_Empty; apply empty_1. Qed. (** * Conversions between maps and association lists. *) Definition uncurry {U V W : Type} (f : U -> V -> W) : U*V -> W := fun p => f (fst p) (snd p). Definition of_list (l : list (key*elt)) := List.fold_right (uncurry (@add _)) (empty _) l. Definition to_list := elements. Lemma of_list_1 : forall l k e, NoDupA eqk l -> (MapsTo k e (of_list l) <-> InA eqke (k,e) l). Proof. induction l as [|(k',e') l IH]; simpl; intros k e Hnodup. rewrite empty_mapsto_iff, InA_nil; intuition. unfold uncurry; simpl. inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. specialize (IH k e Hnodup'); clear Hnodup'. rewrite add_mapsto_iff, InA_cons, <- IH. unfold eq_key_elt at 1; simpl. split; destruct 1 as [H|H]; try (intuition;fail). destruct (eq_dec k k'); [left|right]; split; auto. contradict Hnotin. apply InA_eqke_eqk with k e; intuition. Qed. Lemma of_list_1b : forall l k, NoDupA eqk l -> find k (of_list l) = findA (eqb k) l. Proof. induction l as [|(k',e') l IH]; simpl; intros k Hnodup. apply empty_o. unfold uncurry; simpl. inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. specialize (IH k Hnodup'); clear Hnodup'. rewrite add_o, IH. unfold eqb; do 2 destruct eq_dec; auto; elim n; eauto. Qed. Lemma of_list_2 : forall l, NoDupA eqk l -> equivlistA eqke l (to_list (of_list l)). Proof. intros l Hnodup (k,e). rewrite <- elements_mapsto_iff, of_list_1; intuition. Qed. Lemma of_list_3 : forall s, Equal (of_list (to_list s)) s. Proof. intros s k. rewrite of_list_1b, elements_o; auto. apply elements_3w. Qed. (** * Fold *) (** Alternative specification via [fold_right] *) Lemma fold_spec_right m (A:Type)(i:A)(f : key -> elt -> A -> A) : fold f m i = List.fold_right (uncurry f) i (rev (elements m)). Proof. rewrite fold_1. symmetry. apply fold_left_rev_right. Qed. (** ** Induction principles about fold contributed by S. Lescuyer *) (** In the following lemma, the step hypothesis is deliberately restricted to the precise map m we are considering. *) Lemma fold_rec : forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), forall (i:A)(m:t elt), (forall m, Empty m -> P m i) -> (forall k e a m' m'', MapsTo k e m -> ~In k m' -> Add k e m' m'' -> P m' a -> P m'' (f k e a)) -> P m (fold f m i). Proof. intros A P f i m Hempty Hstep. rewrite fold_spec_right. set (F:=uncurry f). set (l:=rev (elements m)). assert (Hstep' : forall k e a m' m'', InA eqke (k,e) l -> ~In k m' -> Add k e m' m'' -> P m' a -> P m'' (F (k,e) a)). intros k e a m' m'' H ? ? ?; eapply Hstep; eauto. revert H; unfold l; rewrite InA_rev, elements_mapsto_iff; auto with *. assert (Hdup : NoDupA eqk l). unfold l. apply NoDupA_rev; try red; unfold eq_key ; eauto with *. apply elements_3w. assert (Hsame : forall k, find k m = findA (eqb k) l). intros k. unfold l. rewrite elements_o, findA_rev; auto. apply elements_3w. clearbody l. clearbody F. clear Hstep f. revert m Hsame. induction l. (* empty *) intros m Hsame; simpl. apply Hempty. intros k e. rewrite find_mapsto_iff, Hsame; simpl; discriminate. (* step *) intros m Hsame; destruct a as (k,e); simpl. apply Hstep' with (of_list l); auto. rewrite InA_cons; left; red; auto. inversion_clear Hdup. contradict H. destruct H as (e',He'). apply InA_eqke_eqk with k e'; auto. rewrite <- of_list_1; auto. intro k'. rewrite Hsame, add_o, of_list_1b. simpl. unfold eqb. do 2 destruct eq_dec; auto; elim n; eauto. inversion_clear Hdup; auto. apply IHl. intros; eapply Hstep'; eauto. inversion_clear Hdup; auto. intros; apply of_list_1b. inversion_clear Hdup; auto. Qed. (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this case, [P] must be compatible with equality of sets *) Theorem fold_rec_bis : forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), forall (i:A)(m:t elt), (forall m m' a, Equal m m' -> P m a -> P m' a) -> (P (empty _) i) -> (forall k e a m', MapsTo k e m -> ~In k m' -> P m' a -> P (add k e m') (f k e a)) -> P m (fold f m i). Proof. intros A P f i m Pmorphism Pempty Pstep. apply fold_rec; intros. apply Pmorphism with (empty _); auto. intro k. rewrite empty_o. case_eq (find k m0); auto; intros e'; rewrite <- find_mapsto_iff. intro H'; elim (H k e'); auto. apply Pmorphism with (add k e m'); try intro; auto. Qed. Lemma fold_rec_nodep : forall (A:Type)(P : A -> Type)(f : key -> elt -> A -> A)(i:A)(m:t elt), P i -> (forall k e a, MapsTo k e m -> P a -> P (f k e a)) -> P (fold f m i). Proof. intros; apply fold_rec_bis with (P:=fun _ => P); auto. Qed. (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : the step hypothesis must here be applicable anywhere. At the same time, it looks more like an induction principle, and hence can be easier to use. *) Lemma fold_rec_weak : forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A)(i:A), (forall m m' a, Equal m m' -> P m a -> P m' a) -> P (empty _) i -> (forall k e a m, ~In k m -> P m a -> P (add k e m) (f k e a)) -> forall m, P m (fold f m i). Proof. intros; apply fold_rec_bis; auto. Qed. Lemma fold_rel : forall (A B:Type)(R : A -> B -> Type) (f : key -> elt -> A -> A)(g : key -> elt -> B -> B)(i : A)(j : B) (m : t elt), R i j -> (forall k e a b, MapsTo k e m -> R a b -> R (f k e a) (g k e b)) -> R (fold f m i) (fold g m j). Proof. intros A B R f g i j m Rempty Rstep. rewrite 2 fold_spec_right. set (l:=rev (elements m)). assert (Rstep' : forall k e a b, InA eqke (k,e) l -> R a b -> R (f k e a) (g k e b)) by (intros; apply Rstep; auto; rewrite elements_mapsto_iff, <- InA_rev; auto with *). clearbody l; clear Rstep m. induction l; simpl; auto. apply Rstep'; auto. destruct a; simpl; rewrite InA_cons; left; red; auto. Qed. (** From the induction principle on [fold], we can deduce some general induction principles on maps. *) Lemma map_induction : forall P : t elt -> Type, (forall m, Empty m -> P m) -> (forall m m', P m -> forall x e, ~In x m -> Add x e m m' -> P m') -> forall m, P m. Proof. intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. Qed. Lemma map_induction_bis : forall P : t elt -> Type, (forall m m', Equal m m' -> P m -> P m') -> P (empty _) -> (forall x e m, ~In x m -> P m -> P (add x e m)) -> forall m, P m. Proof. intros. apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. Qed. (** [fold] can be used to reconstruct the same initial set. *) Lemma fold_identity : forall m : t elt, Equal (fold (@add _) m (empty _)) m. Proof. intros. apply fold_rec with (P:=fun m acc => Equal acc m); auto with map. intros m' Heq k'. rewrite empty_o. case_eq (find k' m'); auto; intros e'; rewrite <- find_mapsto_iff. intro; elim (Heq k' e'); auto. intros k e a m' m'' _ _ Hadd Heq k'. red in Heq. rewrite Hadd, 2 add_o, Heq; auto. Qed. Section Fold_More. (** ** Additional properties of fold *) (** When a function [f] is compatible and allows transpositions, we can compute [fold f] in any order. *) Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A). (** This is more convenient than a [compat_op eqke ...]. In fact, every [compat_op], [compat_bool], etc, should become a [Proper] someday. *) Hypothesis Comp : Proper (E.eq==>eq==>eqA==>eqA) f. Lemma fold_init : forall m i i', eqA i i' -> eqA (fold f m i) (fold f m i'). Proof. intros. apply fold_rel with (R:=eqA); auto. intros. apply Comp; auto. Qed. Lemma fold_Empty : forall m i, Empty m -> eqA (fold f m i) i. Proof. intros. apply fold_rec_nodep with (P:=fun a => eqA a i). reflexivity. intros. elim (H k e); auto. Qed. (** As noticed by P. Casteran, asking for the general [SetoidList.transpose] here is too restrictive. Think for instance of [f] being [M.add] : in general, [M.add k e (M.add k e' m)] is not equivalent to [M.add k e' (M.add k e m)]. Fortunately, we will never encounter this situation during a real [fold], since the keys received by this [fold] are unique. Hence we can ask the transposition property to hold only for non-equal keys. This idea could be push slightly further, by asking the transposition property to hold only for (non-equal) keys living in the map given to [fold]. Please contact us if you need such a version. FSets could also benefit from a restricted [transpose], but for this case the gain is unclear. *) Definition transpose_neqkey := forall k k' e e' a, ~E.eq k k' -> eqA (f k e (f k' e' a)) (f k' e' (f k e a)). Hypothesis Tra : transpose_neqkey. Lemma fold_commutes : forall i m k e, ~In k m -> eqA (fold f m (f k e i)) (f k e (fold f m i)). Proof. intros i m k e Hnotin. apply fold_rel with (R:= fun a b => eqA a (f k e b)); auto. reflexivity. intros. transitivity (f k0 e0 (f k e b)). apply Comp; auto. apply Tra; auto. contradict Hnotin; rewrite <- Hnotin; exists e0; auto. Qed. Hint Resolve NoDupA_eqk_eqke NoDupA_rev elements_3w : map. Lemma fold_Equal : forall m1 m2 i, Equal m1 m2 -> eqA (fold f m1 i) (fold f m2 i). Proof. intros. rewrite 2 fold_spec_right. assert (NoDupA eqk (rev (elements m1))) by (auto with *). assert (NoDupA eqk (rev (elements m2))) by (auto with *). apply fold_right_equivlistA_restr with (R:=complement eqk)(eqA:=eqke); auto with *. intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *; apply Comp; auto. unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto. intros (k,e) (k',e'); unfold eq_key, uncurry; simpl; auto. rewrite <- NoDupA_altdef; auto. intros (k,e). rewrite 2 InA_rev, <- 2 elements_mapsto_iff, 2 find_mapsto_iff, H; auto with *. Qed. Lemma fold_Add : forall m1 m2 k e i, ~In k m1 -> Add k e m1 m2 -> eqA (fold f m2 i) (f k e (fold f m1 i)). Proof. intros. rewrite 2 fold_spec_right. set (f':=uncurry f). change (f k e (fold_right f' i (rev (elements m1)))) with (f' (k,e) (fold_right f' i (rev (elements m1)))). assert (NoDupA eqk (rev (elements m1))) by (auto with *). assert (NoDupA eqk (rev (elements m2))) by (auto with *). apply fold_right_add_restr with (R:=complement eqk)(eqA:=eqke)(eqB:=eqA); auto with *. intros (k1,e1) (k2,e2) (Hk,He) a a' Ha; unfold f'; simpl in *. apply Comp; auto. unfold complement, eq_key_elt, eq_key; repeat red; intuition eauto. unfold f'; intros (k1,e1) (k2,e2); unfold eq_key, uncurry; simpl; auto. rewrite <- NoDupA_altdef; auto. rewrite InA_rev, <- elements_mapsto_iff by (auto with *). firstorder. intros (a,b). rewrite InA_cons, 2 InA_rev, <- 2 elements_mapsto_iff, 2 find_mapsto_iff by (auto with *). unfold eq_key_elt; simpl. rewrite H0. rewrite add_o. destruct (eq_dec k a) as [EQ|NEQ]; split; auto. intros EQ'; inversion EQ'; auto. intuition; subst; auto. elim H. exists b; rewrite EQ; auto with map. intuition. elim NEQ; auto. Qed. Lemma fold_add : forall m k e i, ~In k m -> eqA (fold f (add k e m) i) (f k e (fold f m i)). Proof. intros. apply fold_Add; try red; auto. Qed. End Fold_More. (** * Cardinal *) Lemma cardinal_fold : forall m : t elt, cardinal m = fold (fun _ _ => S) m 0. Proof. intros; rewrite cardinal_1, fold_1. symmetry; apply fold_left_length; auto. Qed. Lemma cardinal_Empty : forall m : t elt, Empty m <-> cardinal m = 0. Proof. intros. rewrite cardinal_1, elements_Empty. destruct (elements m); intuition; discriminate. Qed. Lemma Equal_cardinal : forall m m' : t elt, Equal m m' -> cardinal m = cardinal m'. Proof. intros; do 2 rewrite cardinal_fold. apply fold_Equal with (eqA:=eq); compute; auto. Qed. Lemma cardinal_1 : forall m : t elt, Empty m -> cardinal m = 0. Proof. intros; rewrite <- cardinal_Empty; auto. Qed. Lemma cardinal_2 : forall m m' x e, ~ In x m -> Add x e m m' -> cardinal m' = S (cardinal m). Proof. intros; do 2 rewrite cardinal_fold. change S with ((fun _ _ => S) x e). apply fold_Add with (eqA:=eq); compute; auto. Qed. Lemma cardinal_inv_1 : forall m : t elt, cardinal m = 0 -> Empty m. Proof. intros; rewrite cardinal_Empty; auto. Qed. Hint Resolve cardinal_inv_1 : map. Lemma cardinal_inv_2 : forall m n, cardinal m = S n -> { p : key*elt | MapsTo (fst p) (snd p) m }. Proof. intros; rewrite M.cardinal_1 in *. generalize (elements_mapsto_iff m). destruct (elements m); try discriminate. exists p; auto. rewrite H0; destruct p; simpl; auto. constructor; red; auto. Qed. Lemma cardinal_inv_2b : forall m, cardinal m <> 0 -> { p : key*elt | MapsTo (fst p) (snd p) m }. Proof. intros. generalize (@cardinal_inv_2 m); destruct cardinal. elim H;auto. eauto. Qed. (** * Additional notions over maps *) Definition Disjoint (m m' : t elt) := forall k, ~(In k m /\ In k m'). Definition Partition (m m1 m2 : t elt) := Disjoint m1 m2 /\ (forall k e, MapsTo k e m <-> MapsTo k e m1 \/ MapsTo k e m2). (** * Emulation of some functions lacking in the interface *) Definition filter (f : key -> elt -> bool)(m : t elt) := fold (fun k e m => if f k e then add k e m else m) m (empty _). Definition for_all (f : key -> elt -> bool)(m : t elt) := fold (fun k e b => if f k e then b else false) m true. Definition exists_ (f : key -> elt -> bool)(m : t elt) := fold (fun k e b => if f k e then true else b) m false. Definition partition (f : key -> elt -> bool)(m : t elt) := (filter f m, filter (fun k e => negb (f k e)) m). (** [update] adds to [m1] all the bindings of [m2]. It can be seen as an [union] operator which gives priority to its 2nd argument in case of binding conflit. *) Definition update (m1 m2 : t elt) := fold (@add _) m2 m1. (** [restrict] keeps from [m1] only the bindings whose key is in [m2]. It can be seen as an [inter] operator, with priority to its 1st argument in case of binding conflit. *) Definition restrict (m1 m2 : t elt) := filter (fun k _ => mem k m2) m1. (** [diff] erases from [m1] all bindings whose key is in [m2]. *) Definition diff (m1 m2 : t elt) := filter (fun k _ => negb (mem k m2)) m1. Section Specs. Variable f : key -> elt -> bool. Hypothesis Hf : Proper (E.eq==>eq==>eq) f. Lemma filter_iff : forall m k e, MapsTo k e (filter f m) <-> MapsTo k e m /\ f k e = true. Proof. unfold filter. set (f':=fun k e m => if f k e then add k e m else m). intro m. pattern m, (fold f' m (empty _)). apply fold_rec. intros m' Hm' k e. rewrite empty_mapsto_iff. intuition. elim (Hm' k e); auto. intros k e acc m1 m2 Hke Hn Hadd IH k' e'. change (Equal m2 (add k e m1)) in Hadd; rewrite Hadd. unfold f'; simpl. case_eq (f k e); intros Hfke; simpl; rewrite !add_mapsto_iff, IH; clear IH; intuition. rewrite <- Hfke; apply Hf; auto. destruct (eq_dec k k') as [Hk|Hk]; [left|right]; auto. elim Hn; exists e'; rewrite Hk; auto. assert (f k e = f k' e') by (apply Hf; auto). congruence. Qed. Lemma for_all_iff : forall m, for_all f m = true <-> (forall k e, MapsTo k e m -> f k e = true). Proof. unfold for_all. set (f':=fun k e b => if f k e then b else false). intro m. pattern m, (fold f' m true). apply fold_rec. intros m' Hm'. split; auto. intros _ k e Hke. elim (Hm' k e); auto. intros k e b m1 m2 _ Hn Hadd IH. clear m. change (Equal m2 (add k e m1)) in Hadd. unfold f'; simpl. case_eq (f k e); intros Hfke. (* f k e = true *) rewrite IH. clear IH. split; intros Hmapsto k' e' Hke'. rewrite Hadd, add_mapsto_iff in Hke'. destruct Hke' as [(?,?)|(?,?)]; auto. rewrite <- Hfke; apply Hf; auto. apply Hmapsto. rewrite Hadd, add_mapsto_iff; right; split; auto. contradict Hn; exists e'; rewrite Hn; auto. (* f k e = false *) split; try discriminate. intros Hmapsto. rewrite <- Hfke. apply Hmapsto. rewrite Hadd, add_mapsto_iff; auto. Qed. Lemma exists_iff : forall m, exists_ f m = true <-> (exists p, MapsTo (fst p) (snd p) m /\ f (fst p) (snd p) = true). Proof. unfold exists_. set (f':=fun k e b => if f k e then true else b). intro m. pattern m, (fold f' m false). apply fold_rec. intros m' Hm'. split; try discriminate. intros ((k,e),(Hke,_)); simpl in *. elim (Hm' k e); auto. intros k e b m1 m2 _ Hn Hadd IH. clear m. change (Equal m2 (add k e m1)) in Hadd. unfold f'; simpl. case_eq (f k e); intros Hfke. (* f k e = true *) split; [intros _|auto]. exists (k,e); simpl; split; auto. rewrite Hadd, add_mapsto_iff; auto. (* f k e = false *) rewrite IH. clear IH. split; intros ((k',e'),(Hke1,Hke2)); simpl in *. exists (k',e'); simpl; split; auto. rewrite Hadd, add_mapsto_iff; right; split; auto. contradict Hn. exists e'; rewrite Hn; auto. rewrite Hadd, add_mapsto_iff in Hke1. destruct Hke1 as [(?,?)|(?,?)]. assert (f k' e' = f k e) by (apply Hf; auto). congruence. exists (k',e'); auto. Qed. End Specs. Lemma Disjoint_alt : forall m m', Disjoint m m' <-> (forall k e e', MapsTo k e m -> MapsTo k e' m' -> False). Proof. unfold Disjoint; split. intros H k v v' H1 H2. apply H with k; split. exists v; trivial. exists v'; trivial. intros H k ((v,Hv),(v',Hv')). eapply H; eauto. Qed. Section Partition. Variable f : key -> elt -> bool. Hypothesis Hf : Proper (E.eq==>eq==>eq) f. Lemma partition_iff_1 : forall m m1 k e, m1 = fst (partition f m) -> (MapsTo k e m1 <-> MapsTo k e m /\ f k e = true). Proof. unfold partition; simpl; intros. subst m1. apply filter_iff; auto. Qed. Lemma partition_iff_2 : forall m m2 k e, m2 = snd (partition f m) -> (MapsTo k e m2 <-> MapsTo k e m /\ f k e = false). Proof. unfold partition; simpl; intros. subst m2. rewrite filter_iff. split; intros (H,H'); split; auto. destruct (f k e); simpl in *; auto. rewrite H'; auto. repeat red; intros. f_equal. apply Hf; auto. Qed. Lemma partition_Partition : forall m m1 m2, partition f m = (m1,m2) -> Partition m m1 m2. Proof. intros. split. rewrite Disjoint_alt. intros k e e'. rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) by (rewrite H; auto). intros (U,V) (W,Z). rewrite <- (MapsTo_fun U W) in Z; congruence. intros k e. rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) by (rewrite H; auto). destruct (f k e); intuition. Qed. End Partition. Lemma Partition_In : forall m m1 m2 k, Partition m m1 m2 -> In k m -> {In k m1}+{In k m2}. Proof. intros m m1 m2 k Hm Hk. destruct (In_dec m1 k) as [H|H]; [left|right]; auto. destruct Hm as (Hm,Hm'). destruct Hk as (e,He); rewrite Hm' in He; destruct He. elim H; exists e; auto. exists e; auto. Defined. Lemma Disjoint_sym : forall m1 m2, Disjoint m1 m2 -> Disjoint m2 m1. Proof. intros m1 m2 H k (H1,H2). elim (H k); auto. Qed. Lemma Partition_sym : forall m m1 m2, Partition m m1 m2 -> Partition m m2 m1. Proof. intros m m1 m2 (H,H'); split. apply Disjoint_sym; auto. intros; rewrite H'; intuition. Qed. Lemma Partition_Empty : forall m m1 m2, Partition m m1 m2 -> (Empty m <-> (Empty m1 /\ Empty m2)). Proof. intros m m1 m2 (Hdisj,Heq). split. intro He. split; intros k e Hke; elim (He k e); rewrite Heq; auto. intros (He1,He2) k e Hke. rewrite Heq in Hke. destruct Hke. elim (He1 k e); auto. elim (He2 k e); auto. Qed. Lemma Partition_Add : forall m m' x e , ~In x m -> Add x e m m' -> forall m1 m2, Partition m' m1 m2 -> exists m3, (Add x e m3 m1 /\ Partition m m3 m2 \/ Add x e m3 m2 /\ Partition m m1 m3). Proof. unfold Partition. intros m m' x e Hn Hadd m1 m2 (Hdisj,Hor). assert (Heq : Equal m (remove x m')). change (Equal m' (add x e m)) in Hadd. rewrite Hadd. intro k. rewrite remove_o, add_o. destruct eq_dec as [He|Hne]; auto. rewrite <- He, <- not_find_in_iff; auto. assert (H : MapsTo x e m'). change (Equal m' (add x e m)) in Hadd; rewrite Hadd. apply add_1; auto. rewrite Hor in H; destruct H. (* first case : x in m1 *) exists (remove x m1); left. split; [|split]. (* add *) change (Equal m1 (add x e (remove x m1))). intro k. rewrite add_o, remove_o. destruct eq_dec as [He|Hne]; auto. rewrite <- He; apply find_1; auto. (* disjoint *) intros k (H1,H2). elim (Hdisj k). split; auto. rewrite remove_in_iff in H1; destruct H1; auto. (* mapsto *) intros k' e'. rewrite Heq, 2 remove_mapsto_iff, Hor. intuition. elim (Hdisj x); split; [exists e|exists e']; auto. apply MapsTo_1 with k'; auto. (* second case : x in m2 *) exists (remove x m2); right. split; [|split]. (* add *) change (Equal m2 (add x e (remove x m2))). intro k. rewrite add_o, remove_o. destruct eq_dec as [He|Hne]; auto. rewrite <- He; apply find_1; auto. (* disjoint *) intros k (H1,H2). elim (Hdisj k). split; auto. rewrite remove_in_iff in H2; destruct H2; auto. (* mapsto *) intros k' e'. rewrite Heq, 2 remove_mapsto_iff, Hor. intuition. elim (Hdisj x); split; [exists e'|exists e]; auto. apply MapsTo_1 with k'; auto. Qed. Lemma Partition_fold : forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A), Proper (E.eq==>eq==>eqA==>eqA) f -> transpose_neqkey eqA f -> forall m m1 m2 i, Partition m m1 m2 -> eqA (fold f m i) (fold f m1 (fold f m2 i)). Proof. intros A eqA st f Comp Tra. induction m as [m Hm|m m' IH k e Hn Hadd] using map_induction. intros m1 m2 i Hp. rewrite (fold_Empty (eqA:=eqA)); auto. rewrite (Partition_Empty Hp) in Hm. destruct Hm. rewrite 2 (fold_Empty (eqA:=eqA)); auto. reflexivity. intros m1 m2 i Hp. destruct (Partition_Add Hn Hadd Hp) as (m3,[(Hadd',Hp')|(Hadd',Hp')]). (* fst case: m3 is (k,e)::m1 *) assert (~In k m3). contradict Hn. destruct Hn as (e',He'). destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. transitivity (f k e (fold f m i)). apply fold_Add with (eqA:=eqA); auto. symmetry. transitivity (f k e (fold f m3 (fold f m2 i))). apply fold_Add with (eqA:=eqA); auto. apply Comp; auto. symmetry; apply IH; auto. (* snd case: m3 is (k,e)::m2 *) assert (~In k m3). contradict Hn. destruct Hn as (e',He'). destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. assert (~In k m1). contradict Hn. destruct Hn as (e',He'). destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. transitivity (f k e (fold f m i)). apply fold_Add with (eqA:=eqA); auto. transitivity (f k e (fold f m1 (fold f m3 i))). apply Comp; auto using IH. transitivity (fold f m1 (f k e (fold f m3 i))). symmetry. apply fold_commutes with (eqA:=eqA); auto. apply fold_init with (eqA:=eqA); auto. symmetry. apply fold_Add with (eqA:=eqA); auto. Qed. Lemma Partition_cardinal : forall m m1 m2, Partition m m1 m2 -> cardinal m = cardinal m1 + cardinal m2. Proof. intros. rewrite (cardinal_fold m), (cardinal_fold m1). set (f:=fun (_:key)(_:elt)=>S). setoid_replace (fold f m 0) with (fold f m1 (fold f m2 0)). rewrite <- cardinal_fold. apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto. apply Partition_fold with (eqA:=eq); repeat red; auto. Qed. Lemma Partition_partition : forall m m1 m2, Partition m m1 m2 -> let f := fun k (_:elt) => mem k m1 in Equal m1 (fst (partition f m)) /\ Equal m2 (snd (partition f m)). Proof. intros m m1 m2 Hm f. assert (Hf : Proper (E.eq==>eq==>eq) f). intros k k' Hk e e' _; unfold f; rewrite Hk; auto. set (m1':= fst (partition f m)). set (m2':= snd (partition f m)). split; rewrite Equal_mapsto_iff; intros k e. rewrite (@partition_iff_1 f Hf m m1') by auto. unfold f. rewrite <- mem_in_iff. destruct Hm as (Hm,Hm'). rewrite Hm'. intuition. exists e; auto. elim (Hm k); split; auto; exists e; auto. rewrite (@partition_iff_2 f Hf m m2') by auto. unfold f. rewrite <- not_mem_in_iff. destruct Hm as (Hm,Hm'). rewrite Hm'. intuition. elim (Hm k); split; auto; exists e; auto. elim H1; exists e; auto. Qed. Lemma update_mapsto_iff : forall m m' k e, MapsTo k e (update m m') <-> (MapsTo k e m' \/ (MapsTo k e m /\ ~In k m')). Proof. unfold update. intros m m'. pattern m', (fold (@add _) m' m). apply fold_rec. intros m0 Hm0 k e. assert (~In k m0) by (intros (e0,He0); apply (Hm0 k e0); auto). intuition. elim (Hm0 k e); auto. intros k e m0 m1 m2 _ Hn Hadd IH k' e'. change (Equal m2 (add k e m1)) in Hadd. rewrite Hadd, 2 add_mapsto_iff, IH, add_in_iff. clear IH. intuition. Qed. Lemma update_dec : forall m m' k e, MapsTo k e (update m m') -> { MapsTo k e m' } + { MapsTo k e m /\ ~In k m'}. Proof. intros m m' k e H. rewrite update_mapsto_iff in H. destruct (In_dec m' k) as [H'|H']; [left|right]; intuition. elim H'; exists e; auto. Defined. Lemma update_in_iff : forall m m' k, In k (update m m') <-> In k m \/ In k m'. Proof. intros m m' k. split. intros (e,H); rewrite update_mapsto_iff in H. destruct H; [right|left]; exists e; intuition. destruct (In_dec m' k) as [H|H]. destruct H as (e,H). intros _; exists e. rewrite update_mapsto_iff; left; auto. destruct 1 as [H'|H']; [|elim H; auto]. destruct H' as (e,H'). exists e. rewrite update_mapsto_iff; right; auto. Qed. Lemma diff_mapsto_iff : forall m m' k e, MapsTo k e (diff m m') <-> MapsTo k e m /\ ~In k m'. Proof. intros m m' k e. unfold diff. rewrite filter_iff. intuition. rewrite mem_1 in *; auto; discriminate. intros ? ? Hk _ _ _; rewrite Hk; auto. Qed. Lemma diff_in_iff : forall m m' k, In k (diff m m') <-> In k m /\ ~In k m'. Proof. intros m m' k. split. intros (e,H); rewrite diff_mapsto_iff in H. destruct H; split; auto. exists e; auto. intros ((e,H),H'); exists e; rewrite diff_mapsto_iff; auto. Qed. Lemma restrict_mapsto_iff : forall m m' k e, MapsTo k e (restrict m m') <-> MapsTo k e m /\ In k m'. Proof. intros m m' k e. unfold restrict. rewrite filter_iff. intuition. intros ? ? Hk _ _ _; rewrite Hk; auto. Qed. Lemma restrict_in_iff : forall m m' k, In k (restrict m m') <-> In k m /\ In k m'. Proof. intros m m' k. split. intros (e,H); rewrite restrict_mapsto_iff in H. destruct H; split; auto. exists e; auto. intros ((e,H),H'); exists e; rewrite restrict_mapsto_iff; auto. Qed. (** specialized versions analyzing only keys (resp. elements) *) Definition filter_dom (f : key -> bool) := filter (fun k _ => f k). Definition filter_range (f : elt -> bool) := filter (fun _ => f). Definition for_all_dom (f : key -> bool) := for_all (fun k _ => f k). Definition for_all_range (f : elt -> bool) := for_all (fun _ => f). Definition exists_dom (f : key -> bool) := exists_ (fun k _ => f k). Definition exists_range (f : elt -> bool) := exists_ (fun _ => f). Definition partition_dom (f : key -> bool) := partition (fun k _ => f k). Definition partition_range (f : elt -> bool) := partition (fun _ => f). End Elt. Add Parametric Morphism elt : (@cardinal elt) with signature Equal ==> eq as cardinal_m. Proof. intros; apply Equal_cardinal; auto. Qed. Add Parametric Morphism elt : (@Disjoint elt) with signature Equal ==> Equal ==> iff as Disjoint_m. Proof. intros m1 m1' Hm1 m2 m2' Hm2. unfold Disjoint. split; intros. rewrite <- Hm1, <- Hm2; auto. rewrite Hm1, Hm2; auto. Qed. Add Parametric Morphism elt : (@Partition elt) with signature Equal ==> Equal ==> Equal ==> iff as Partition_m. Proof. intros m1 m1' Hm1 m2 m2' Hm2 m3 m3' Hm3. unfold Partition. rewrite <- Hm2, <- Hm3. split; intros (H,H'); split; auto; intros. rewrite <- Hm1, <- Hm2, <- Hm3; auto. rewrite Hm1, Hm2, Hm3; auto. Qed. Add Parametric Morphism elt : (@update elt) with signature Equal ==> Equal ==> Equal as update_m. Proof. intros m1 m1' Hm1 m2 m2' Hm2. setoid_replace (update m1 m2) with (update m1' m2); unfold update. apply fold_Equal with (eqA:=Equal); auto. intros k k' Hk e e' He m m' Hm; rewrite Hk,He,Hm; red; auto. intros k k' e e' i Hneq x. rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. apply fold_init with (eqA:=Equal); auto. intros k k' Hk e e' He m m' Hm; rewrite Hk,He,Hm; red; auto. Qed. Add Parametric Morphism elt : (@restrict elt) with signature Equal ==> Equal ==> Equal as restrict_m. Proof. intros m1 m1' Hm1 m2 m2' Hm2. setoid_replace (restrict m1 m2) with (restrict m1' m2); unfold restrict, filter. apply fold_rel with (R:=Equal); try red; auto. intros k e i i' H Hii' x. pattern (mem k m2); rewrite Hm2. (* UGLY, see with Matthieu *) destruct mem; rewrite Hii'; auto. apply fold_Equal with (eqA:=Equal); auto. intros k k' Hk e e' He m m' Hm; simpl in *. pattern (mem k m2); rewrite Hk. (* idem *) destruct mem; rewrite ?Hk,?He,Hm; red; auto. intros k k' e e' i Hneq x. case_eq (mem k m2); case_eq (mem k' m2); intros; auto. rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. Qed. Add Parametric Morphism elt : (@diff elt) with signature Equal ==> Equal ==> Equal as diff_m. Proof. intros m1 m1' Hm1 m2 m2' Hm2. setoid_replace (diff m1 m2) with (diff m1' m2); unfold diff, filter. apply fold_rel with (R:=Equal); try red; auto. intros k e i i' H Hii' x. pattern (mem k m2); rewrite Hm2. (* idem *) destruct mem; simpl; rewrite Hii'; auto. apply fold_Equal with (eqA:=Equal); auto. intros k k' Hk e e' He m m' Hm; simpl in *. pattern (mem k m2); rewrite Hk. (* idem *) destruct mem; simpl; rewrite ?Hk,?He,Hm; red; auto. intros k k' e e' i Hneq x. case_eq (mem k m2); case_eq (mem k' m2); intros; simpl; auto. rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. Qed. End WProperties_fun. (** * Same Properties for self-contained weak maps and for full maps *) Module WProperties (M:WS) := WProperties_fun M.E M. Module Properties := WProperties. (** * Properties specific to maps with ordered keys *) Module OrdProperties (M:S). Module Import ME := OrderedTypeFacts M.E. Module Import O:=KeyOrderedType M.E. Module Import P:=Properties M. Import F. Import M. Section Elt. Variable elt:Type. Notation eqke := (@eqke elt). Notation eqk := (@eqk elt). Notation ltk := (@ltk elt). Notation cardinal := (@cardinal elt). Notation Equal := (@Equal elt). Notation Add := (@Add elt). Definition Above x (m:t elt) := forall y, In y m -> E.lt y x. Definition Below x (m:t elt) := forall y, In y m -> E.lt x y. Section Elements. Lemma sort_equivlistA_eqlistA : forall l l' : list (key*elt), sort ltk l -> sort ltk l' -> equivlistA eqke l l' -> eqlistA eqke l l'. Proof. apply SortA_equivlistA_eqlistA; eauto with *. Qed. Ltac clean_eauto := unfold O.eqke, O.ltk; simpl; intuition; eauto. Definition gtb (p p':key*elt) := match E.compare (fst p) (fst p') with GT _ => true | _ => false end. Definition leb p := fun p' => negb (gtb p p'). Definition elements_lt p m := List.filter (gtb p) (elements m). Definition elements_ge p m := List.filter (leb p) (elements m). Lemma gtb_1 : forall p p', gtb p p' = true <-> ltk p' p. Proof. intros (x,e) (y,e'); unfold gtb, O.ltk; simpl. destruct (E.compare x y); intuition; try discriminate; ME.order. Qed. Lemma leb_1 : forall p p', leb p p' = true <-> ~ltk p' p. Proof. intros (x,e) (y,e'); unfold leb, gtb, O.ltk; simpl. destruct (E.compare x y); intuition; try discriminate; ME.order. Qed. Lemma gtb_compat : forall p, Proper (eqke==>eq) (gtb p). Proof. red; intros (x,e) (a,e') (b,e'') H; red in H; simpl in *; destruct H. generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e'')); destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); auto. unfold O.ltk in *; simpl in *; intros. symmetry; rewrite H2. apply ME.eq_lt with a; auto. rewrite <- H1; auto. unfold O.ltk in *; simpl in *; intros. rewrite H1. apply ME.eq_lt with b; auto. rewrite <- H2; auto. Qed. Lemma leb_compat : forall p, Proper (eqke==>eq) (leb p). Proof. red; intros x a b H. unfold leb; f_equal; apply gtb_compat; auto. Qed. Hint Resolve gtb_compat leb_compat elements_3 : map. Lemma elements_split : forall p m, elements m = elements_lt p m ++ elements_ge p m. Proof. unfold elements_lt, elements_ge, leb; intros. apply filter_split with (eqA:=eqk) (ltA:=ltk); eauto with *. intros; destruct x; destruct y; destruct p. rewrite gtb_1 in H; unfold O.ltk in H; simpl in *. assert (~ltk (t1,e0) (k,e1)). unfold gtb, O.ltk in *; simpl in *. destruct (E.compare k t1); intuition; try discriminate; ME.order. unfold O.ltk in *; simpl in *; ME.order. Qed. Lemma elements_Add : forall m m' x e, ~In x m -> Add x e m m' -> eqlistA eqke (elements m') (elements_lt (x,e) m ++ (x,e):: elements_ge (x,e) m). Proof. intros; unfold elements_lt, elements_ge. apply sort_equivlistA_eqlistA; auto with *. apply (@SortA_app _ eqke); auto with *. apply (@filter_sort _ eqke); auto with *; clean_eauto. constructor; auto with map. apply (@filter_sort _ eqke); auto with *; clean_eauto. rewrite (@InfA_alt _ eqke); auto with *; try (clean_eauto; fail). intros. rewrite filter_InA in H1; auto with *; destruct H1. rewrite leb_1 in H2. destruct y; unfold O.ltk in *; simpl in *. rewrite <- elements_mapsto_iff in H1. assert (~E.eq x t0). contradict H. exists e0; apply MapsTo_1 with t0; auto. ME.order. apply (@filter_sort _ eqke); auto with *; clean_eauto. intros. rewrite filter_InA in H1; auto with *; destruct H1. rewrite gtb_1 in H3. destruct y; destruct x0; unfold O.ltk in *; simpl in *. inversion_clear H2. red in H4; simpl in *; destruct H4. ME.order. rewrite filter_InA in H4; auto with *; destruct H4. rewrite leb_1 in H4. unfold O.ltk in *; simpl in *; ME.order. red; intros a; destruct a. rewrite InA_app_iff, InA_cons, 2 filter_InA, <-2 elements_mapsto_iff, leb_1, gtb_1, find_mapsto_iff, (H0 t0), <- find_mapsto_iff, add_mapsto_iff by (auto with *). unfold O.eqke, O.ltk; simpl. destruct (E.compare t0 x); intuition. right; split; auto; ME.order. ME.order. elim H. exists e0; apply MapsTo_1 with t0; auto. right; right; split; auto; ME.order. ME.order. right; split; auto; ME.order. Qed. Lemma elements_Add_Above : forall m m' x e, Above x m -> Add x e m m' -> eqlistA eqke (elements m') (elements m ++ (x,e)::nil). Proof. intros. apply sort_equivlistA_eqlistA; auto with *. apply (@SortA_app _ eqke); auto with *. intros. inversion_clear H2. destruct x0; destruct y. rewrite <- elements_mapsto_iff in H1. unfold O.eqke, O.ltk in *; simpl in *; destruct H3. apply ME.lt_eq with x; auto. apply H; firstorder. inversion H3. red; intros a; destruct a. rewrite InA_app_iff, InA_cons, InA_nil, <- 2 elements_mapsto_iff, find_mapsto_iff, (H0 t0), <- find_mapsto_iff, add_mapsto_iff by (auto with *). unfold O.eqke; simpl. intuition. destruct (E.eq_dec x t0); auto. exfalso. assert (In t0 m). exists e0; auto. generalize (H t0 H1). ME.order. Qed. Lemma elements_Add_Below : forall m m' x e, Below x m -> Add x e m m' -> eqlistA eqke (elements m') ((x,e)::elements m). Proof. intros. apply sort_equivlistA_eqlistA; auto with *. change (sort ltk (((x,e)::nil) ++ elements m)). apply (@SortA_app _ eqke); auto with *. intros. inversion_clear H1. destruct y; destruct x0. rewrite <- elements_mapsto_iff in H2. unfold O.eqke, O.ltk in *; simpl in *; destruct H3. apply ME.eq_lt with x; auto. apply H; firstorder. inversion H3. red; intros a; destruct a. rewrite InA_cons, <- 2 elements_mapsto_iff, find_mapsto_iff, (H0 t0), <- find_mapsto_iff, add_mapsto_iff by (auto with *). unfold O.eqke; simpl. intuition. destruct (E.eq_dec x t0); auto. exfalso. assert (In t0 m). exists e0; auto. generalize (H t0 H1). ME.order. Qed. Lemma elements_Equal_eqlistA : forall (m m': t elt), Equal m m' -> eqlistA eqke (elements m) (elements m'). Proof. intros. apply sort_equivlistA_eqlistA; auto with *. red; intros. destruct x; do 2 rewrite <- elements_mapsto_iff. do 2 rewrite find_mapsto_iff; rewrite H; split; auto. Qed. End Elements. Section Min_Max_Elt. (** We emulate two [max_elt] and [min_elt] functions. *) Fixpoint max_elt_aux (l:list (key*elt)) := match l with | nil => None | (x,e)::nil => Some (x,e) | (x,e)::l => max_elt_aux l end. Definition max_elt m := max_elt_aux (elements m). Lemma max_elt_Above : forall m x e, max_elt m = Some (x,e) -> Above x (remove x m). Proof. red; intros. rewrite remove_in_iff in H0. destruct H0. rewrite elements_in_iff in H1. destruct H1. unfold max_elt in *. generalize (elements_3 m). revert x e H y x0 H0 H1. induction (elements m). simpl; intros; try discriminate. intros. destruct a; destruct l; simpl in *. injection H; clear H; intros; subst. inversion_clear H1. red in H; simpl in *; intuition. elim H0; eauto. inversion H. change (max_elt_aux (p::l) = Some (x,e)) in H. generalize (IHl x e H); clear IHl; intros IHl. inversion_clear H1; [ | inversion_clear H2; eauto ]. red in H3; simpl in H3; destruct H3. destruct p as (p1,p2). destruct (E.eq_dec p1 x). apply ME.lt_eq with p1; auto. inversion_clear H2. inversion_clear H5. red in H2; simpl in H2; ME.order. apply E.lt_trans with p1; auto. inversion_clear H2. inversion_clear H5. red in H2; simpl in H2; ME.order. eapply IHl; eauto. econstructor; eauto. red; eauto. inversion H2; auto. Qed. Lemma max_elt_MapsTo : forall m x e, max_elt m = Some (x,e) -> MapsTo x e m. Proof. intros. unfold max_elt in *. rewrite elements_mapsto_iff. induction (elements m). simpl; try discriminate. destruct a; destruct l; simpl in *. injection H; intros; subst; constructor; red; auto. constructor 2; auto. Qed. Lemma max_elt_Empty : forall m, max_elt m = None -> Empty m. Proof. intros. unfold max_elt in *. rewrite elements_Empty. induction (elements m); auto. destruct a; destruct l; simpl in *; try discriminate. assert (H':=IHl H); discriminate. Qed. Definition min_elt m : option (key*elt) := match elements m with | nil => None | (x,e)::_ => Some (x,e) end. Lemma min_elt_Below : forall m x e, min_elt m = Some (x,e) -> Below x (remove x m). Proof. unfold min_elt, Below; intros. rewrite remove_in_iff in H0; destruct H0. rewrite elements_in_iff in H1. destruct H1. generalize (elements_3 m). destruct (elements m). try discriminate. destruct p; injection H; intros; subst. inversion_clear H1. red in H2; destruct H2; simpl in *; ME.order. inversion_clear H4. rewrite (@InfA_alt _ eqke) in H3; eauto with *. apply (H3 (y,x0)); auto. Qed. Lemma min_elt_MapsTo : forall m x e, min_elt m = Some (x,e) -> MapsTo x e m. Proof. intros. unfold min_elt in *. rewrite elements_mapsto_iff. destruct (elements m). simpl; try discriminate. destruct p; simpl in *. injection H; intros; subst; constructor; red; auto. Qed. Lemma min_elt_Empty : forall m, min_elt m = None -> Empty m. Proof. intros. unfold min_elt in *. rewrite elements_Empty. destruct (elements m); auto. destruct p; simpl in *; discriminate. Qed. End Min_Max_Elt. Section Induction_Principles. Lemma map_induction_max : forall P : t elt -> Type, (forall m, Empty m -> P m) -> (forall m m', P m -> forall x e, Above x m -> Add x e m m' -> P m') -> forall m, P m. Proof. intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. apply X; apply cardinal_inv_1; auto. case_eq (max_elt m); intros. destruct p. assert (Add k e (remove k m) m). red; intros. rewrite add_o; rewrite remove_o; destruct (eq_dec k y); eauto. apply find_1; apply MapsTo_1 with k; auto. apply max_elt_MapsTo; auto. apply X0 with (remove k m) k e; auto with map. apply IHn. assert (S n = S (cardinal (remove k m))). rewrite Heqn. eapply cardinal_2; eauto with map. inversion H1; auto. eapply max_elt_Above; eauto. apply X; apply max_elt_Empty; auto. Qed. Lemma map_induction_min : forall P : t elt -> Type, (forall m, Empty m -> P m) -> (forall m m', P m -> forall x e, Below x m -> Add x e m m' -> P m') -> forall m, P m. Proof. intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. apply X; apply cardinal_inv_1; auto. case_eq (min_elt m); intros. destruct p. assert (Add k e (remove k m) m). red; intros. rewrite add_o; rewrite remove_o; destruct (eq_dec k y); eauto. apply find_1; apply MapsTo_1 with k; auto. apply min_elt_MapsTo; auto. apply X0 with (remove k m) k e; auto. apply IHn. assert (S n = S (cardinal (remove k m))). rewrite Heqn. eapply cardinal_2; eauto with map. inversion H1; auto. eapply min_elt_Below; eauto. apply X; apply min_elt_Empty; auto. Qed. End Induction_Principles. Section Fold_properties. (** The following lemma has already been proved on Weak Maps, but with one additionnal hypothesis (some [transpose] fact). *) Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) (f:key->elt->A->A)(i:A), Proper (E.eq==>eq==>eqA==>eqA) f -> Equal m1 m2 -> eqA (fold f m1 i) (fold f m2 i). Proof. intros m1 m2 A eqA st f i Hf Heq. rewrite 2 fold_spec_right. apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. intros (k,e) (k',e') (Hk,He) a a' Ha; simpl in *; apply Hf; auto. apply eqlistA_rev. apply elements_Equal_eqlistA. auto. Qed. Lemma fold_Add_Above : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), Above x m1 -> Add x e m1 m2 -> eqA (fold f m2 i) (f x e (fold f m1 i)). Proof. intros. rewrite 2 fold_spec_right. set (f':=uncurry f). transitivity (fold_right f' i (rev (elements m1 ++ (x,e)::nil))). apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *. apply P; auto. apply eqlistA_rev. apply elements_Add_Above; auto. rewrite distr_rev; simpl. reflexivity. Qed. Lemma fold_Add_Below : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), Below x m1 -> Add x e m1 m2 -> eqA (fold f m2 i) (fold f m1 (f x e i)). Proof. intros. rewrite 2 fold_spec_right. set (f':=uncurry f). transitivity (fold_right f' i (rev (((x,e)::nil)++elements m1))). apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *; apply P; auto. apply eqlistA_rev. simpl; apply elements_Add_Below; auto. rewrite distr_rev; simpl. rewrite fold_right_app. reflexivity. Qed. End Fold_properties. End Elt. End OrdProperties. coq-8.4pl4/theories/FSets/FMapWeakList.v0000644000175000017500000007030112326224777017160 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* is_empty m = true. Proof. unfold Empty, PX.MapsTo. intros m. case m;auto. intros p l inlist. destruct p. absurd (InA eqke (t0, e) ((t0, e) :: l));auto. Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. Proof. intros m. case m;auto. intros p l abs. inversion abs. Qed. (** * [mem] *) Function mem (k : key) (s : t elt) {struct s} : bool := match s with | nil => false | (k',_) :: l => if X.eq_dec k k' then true else mem k l end. Lemma mem_1 : forall m (Hm:NoDupA m) x, In x m -> mem x m = true. Proof. intros m Hm x; generalize Hm; clear Hm. functional induction (mem x m);intros NoDup belong1;trivial. inversion belong1. inversion H. inversion_clear NoDup. inversion_clear belong1. inversion_clear H1. compute in H2; destruct H2. contradiction. apply IHb; auto. exists x0; auto. Qed. Lemma mem_2 : forall m (Hm:NoDupA m) x, mem x m = true -> In x m. Proof. intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo. functional induction (mem x m); intros NoDup hyp; try discriminate. exists _x; auto. inversion_clear NoDup. destruct IHb; auto. exists x0; auto. Qed. (** * [find] *) Function find (k:key) (s: t elt) {struct s} : option elt := match s with | nil => None | (k',x)::s' => if X.eq_dec k k' then Some x else find k s' end. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m x. unfold PX.MapsTo. functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto. Qed. Lemma find_1 : forall m (Hm:NoDupA m) x e, MapsTo x e m -> find x m = Some e. Proof. intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo. functional induction (find x m);simpl; subst; try clear H_eq_1. inversion 2. do 2 inversion_clear 1. compute in H2; destruct H2; subst; trivial. elim H; apply InA_eqk with (x,e); auto. do 2 inversion_clear 1; auto. compute in H2; destruct H2; elim _x; auto. Qed. (* Not part of the exported specifications, used later for [combine]. *) Lemma find_eq : forall m (Hm:NoDupA m) x x', X.eq x x' -> find x m = find x' m. Proof. induction m; simpl; auto; destruct a; intros. inversion_clear Hm. rewrite (IHm H1 x x'); auto. destruct (X.eq_dec x t0); destruct (X.eq_dec x' t0); trivial. elim n; apply X.eq_trans with x; auto. elim n; apply X.eq_trans with x'; auto. Qed. (** * [add] *) Function add (k : key) (x : elt) (s : t elt) {struct s} : t elt := match s with | nil => (k,x) :: nil | (k',y) :: l => if X.eq_dec k k' then (k,x)::l else (k',y)::add k x l end. Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). Proof. intros m x y e; generalize y; clear y; unfold PX.MapsTo. functional induction (add x e m);simpl;auto. Qed. Lemma add_2 : forall m x y e e', ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. intros m x y e e'; generalize y e; clear y e; unfold PX.MapsTo. functional induction (add x e' m);simpl;auto. intros y' e'' eqky'; inversion_clear 1. destruct H0; simpl in *. elim eqky'; apply X.eq_trans with k'; auto. auto. intros y' e'' eqky'; inversion_clear 1; intuition. Qed. Lemma add_3 : forall m x y e e', ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. Proof. intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo. functional induction (add x e' m);simpl;auto. intros; apply (In_inv_3 H0); auto. constructor 2; apply (In_inv_3 H0); auto. inversion_clear 2; auto. Qed. Lemma add_3' : forall m x y e e', ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. Proof. intros m x y e e'. generalize y e; clear y e. functional induction (add x e' m);simpl;auto. inversion_clear 2. compute in H1; elim H; auto. inversion H1. constructor 2; inversion_clear H0; auto. compute in H1; elim H; auto. inversion_clear 2; auto. Qed. Lemma add_NoDup : forall m (Hm:NoDupA m) x e, NoDupA (add x e m). Proof. induction m. simpl; constructor; auto; red; inversion 1. intros. destruct a as (x',e'). simpl; case (X.eq_dec x x'); inversion_clear Hm; auto. constructor; auto. contradict H. apply InA_eqk with (x,e); auto. constructor; auto. contradict H; apply add_3' with x e; auto. Qed. (* Not part of the exported specifications, used later for [combine]. *) Lemma add_eq : forall m (Hm:NoDupA m) x a e, X.eq x a -> find x (add a e m) = Some e. Proof. intros. apply find_1; auto. apply add_NoDup; auto. apply add_1; auto. Qed. Lemma add_not_eq : forall m (Hm:NoDupA m) x a e, ~X.eq x a -> find x (add a e m) = find x m. Proof. intros. case_eq (find x m); intros. apply find_1; auto. apply add_NoDup; auto. apply add_2; auto. apply find_2; auto. case_eq (find x (add a e m)); intros; auto. rewrite <- H0; symmetry. apply find_1; auto. apply add_3 with a e; auto. apply find_2; auto. Qed. (** * [remove] *) Function remove (k : key) (s : t elt) {struct s} : t elt := match s with | nil => nil | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l end. Lemma remove_1 : forall m (Hm:NoDupA m) x y, X.eq x y -> ~ In y (remove x m). Proof. intros m Hm x y; generalize Hm; clear Hm. functional induction (remove x m);simpl;intros;auto. red; inversion 1; inversion H1. inversion_clear Hm. subst. contradict H0. destruct H0 as (e,H2); unfold PX.MapsTo in H2. apply InA_eqk with (y,e); auto. compute; apply X.eq_trans with x; auto. intro H2. destruct H2 as (e,H2); inversion_clear H2. compute in H0; destruct H0. elim _x; apply X.eq_trans with y; auto. inversion_clear Hm. elim (IHt0 H2 H). exists e; auto. Qed. Lemma remove_2 : forall m (Hm:NoDupA m) x y e, ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. functional induction (remove x m);auto. inversion_clear 3; auto. compute in H1; destruct H1. elim H; apply X.eq_trans with k'; auto. inversion_clear 1; inversion_clear 2; auto. Qed. Lemma remove_3 : forall m (Hm:NoDupA m) x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. functional induction (remove x m);auto. do 2 inversion_clear 1; auto. Qed. Lemma remove_3' : forall m (Hm:NoDupA m) x y e, InA eqk (y,e) (remove x m) -> InA eqk (y,e) m. Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. functional induction (remove x m);auto. do 2 inversion_clear 1; auto. Qed. Lemma remove_NoDup : forall m (Hm:NoDupA m) x, NoDupA (remove x m). Proof. induction m. simpl; intuition. intros. inversion_clear Hm. destruct a as (x',e'). simpl; case (X.eq_dec x x'); auto. constructor; auto. contradict H; apply remove_3' with x; auto. Qed. (** * [elements] *) Definition elements (m: t elt) := m. Lemma elements_1 : forall m x e, MapsTo x e m -> InA eqke (x,e) (elements m). Proof. auto. Qed. Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m. Proof. auto. Qed. Lemma elements_3w : forall m (Hm:NoDupA m), NoDupA (elements m). Proof. auto. Qed. (** * [fold] *) Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc : A) {struct m} : A := match m with | nil => acc | (k,e)::m' => fold f m' (f k e acc) end. Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros; functional induction (@fold A f m i); auto. Qed. (** * [equal] *) Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := match find k m' with | None => false | Some e' => cmp e e' end. Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := fold (fun k e b => andb (check cmp k e m') b) m true. Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool := andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m). Definition Submap cmp m m' := (forall k, In k m -> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). Definition Equivb cmp m m' := (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, Submap cmp m m' -> submap cmp m m' = true. Proof. unfold Submap, submap. induction m. simpl; auto. destruct a; simpl; intros. destruct H. inversion_clear Hm. assert (H3 : In t0 m'). apply H; exists e; auto. destruct H3 as (e', H3). unfold check at 2; rewrite (find_1 Hm' H3). rewrite (H0 t0); simpl; auto. eapply IHm; auto. split; intuition. apply H. destruct H5 as (e'',H5); exists e''; auto. apply H0 with k; auto. Qed. Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, submap cmp m m' = true -> Submap cmp m m'. Proof. unfold Submap, submap. induction m. simpl; auto. intuition. destruct H0; inversion H0. inversion H0. destruct a; simpl; intros. inversion_clear Hm. rewrite andb_b_true in H. assert (check cmp t0 e m' = true). clear H1 H0 Hm' IHm. set (b:=check cmp t0 e m') in *. generalize H; clear H; generalize b; clear b. induction m; simpl; auto; intros. destruct a; simpl in *. destruct (andb_prop _ _ (IHm _ H)); auto. rewrite H2 in H. destruct (IHm H1 m' Hm' cmp H); auto. unfold check in H2. case_eq (find t0 m'); [intros e' H5 | intros H5]; rewrite H5 in H2; try discriminate. split; intros. destruct H6 as (e0,H6); inversion_clear H6. compute in H7; destruct H7; subst. exists e'. apply PX.MapsTo_eq with t0; auto. apply find_2; auto. apply H3. exists e0; auto. inversion_clear H6. compute in H8; destruct H8; subst. rewrite (find_1 Hm' (PX.MapsTo_eq H6 H7)) in H5; congruence. apply H4 with k; auto. Qed. (** Specification of [equal] *) Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, Equivb cmp m m' -> equal cmp m m' = true. Proof. unfold Equivb, equal. intuition. apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder. Qed. Lemma equal_2 : forall m (Hm:NoDupA m) m' (Hm':NoDupA m') cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. unfold Equivb, equal. intros. destruct (andb_prop _ _ H); clear H. generalize (submap_2 Hm Hm' H0). generalize (submap_2 Hm' Hm H1). firstorder. Qed. Variable elt':Type. (** * [map] and [mapi] *) Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := match m with | nil => nil | (k,e)::m' => (k,f e) :: map f m' end. Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := match m with | nil => nil | (k,e)::m' => (k,f k e) :: mapi f m' end. End Elt. Section Elt2. (* A new section is necessary for previous definitions to work with different [elt], especially [MapsTo]... *) Variable elt elt' : Type. (** Specification of [map] *) Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros m x e f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m. inversion 1. destruct a as (x',e'). simpl. inversion_clear 1. constructor 1. unfold eqke in *; simpl in *; intuition congruence. constructor 2. unfold MapsTo in *; auto. Qed. Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. intros m x f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m; simpl. intros (e,abs). inversion abs. destruct a as (x',e). intros hyp. inversion hyp. clear hyp. inversion H; subst; rename x0 into e'. exists e; constructor. unfold eqke in *; simpl in *; intuition. destruct IHm as (e'',hyp). exists e'; auto. exists e''. constructor 2; auto. Qed. Lemma map_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f:elt->elt'), NoDupA (@eqk elt') (map f m). Proof. induction m; simpl; auto. intros. destruct a as (x',e'). inversion_clear Hm. constructor; auto. contradict H. (* il faut un map_1 avec eqk au lieu de eqke *) clear IHm H0. induction m; simpl in *; auto. inversion H. destruct a; inversion H; auto. Qed. (** Specification of [mapi] *) Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros m x e f. (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) induction m. inversion 1. destruct a as (x',e'). simpl. inversion_clear 1. exists x'. destruct H0; simpl in *. split; auto. constructor 1. unfold eqke in *; simpl in *; intuition congruence. destruct IHm as (y, hyp); auto. exists y; intuition. Qed. Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. intros m x f. (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) induction m; simpl. intros (e,abs). inversion abs. destruct a as (x',e). intros hyp. inversion hyp. clear hyp. inversion H; subst; rename x0 into e'. exists e; constructor. unfold eqke in *; simpl in *; intuition. destruct IHm as (e'',hyp). exists e'; auto. exists e''. constructor 2; auto. Qed. Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'), NoDupA (@eqk elt') (mapi f m). Proof. induction m; simpl; auto. intros. destruct a as (x',e'). inversion_clear Hm; auto. constructor; auto. contradict H. clear IHm H0. induction m; simpl in *; auto. inversion_clear H. destruct a; inversion_clear H; auto. Qed. End Elt2. Section Elt3. Variable elt elt' elt'' : Type. Notation oee' := (option elt * option elt')%type. Definition combine_l (m:t elt)(m':t elt') : t oee' := mapi (fun k e => (Some e, find k m')) m. Definition combine_r (m:t elt)(m':t elt') : t oee' := mapi (fun k e' => (find k m, Some e')) m'. Definition fold_right_pair (A B C:Type)(f:A->B->C->C)(l:list (A*B))(i:C) := List.fold_right (fun p => f (fst p) (snd p)) i l. Definition combine (m:t elt)(m':t elt') : t oee' := let l := combine_l m m' in let r := combine_r m m' in fold_right_pair (add (elt:=oee')) l r. Lemma fold_right_pair_NoDup : forall l r (Hl: NoDupA (eqk (elt:=oee')) l) (Hl: NoDupA (eqk (elt:=oee')) r), NoDupA (eqk (elt:=oee')) (fold_right_pair (add (elt:=oee')) l r). Proof. induction l; simpl; auto. destruct a; simpl; auto. inversion_clear 1. intros; apply add_NoDup; auto. Qed. Hint Resolve fold_right_pair_NoDup. Lemma combine_NoDup : forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), NoDupA (@eqk oee') (combine m m'). Proof. unfold combine, combine_r, combine_l. intros. set (f1 := fun (k : key) (e : elt) => (Some e, find k m')). set (f2 := fun (k : key) (e' : elt') => (find k m, Some e')). generalize (mapi_NoDup Hm f1). generalize (mapi_NoDup Hm' f2). set (l := mapi f1 m); clearbody l. set (r := mapi f2 m'); clearbody r. auto. Qed. Definition at_least_left (o:option elt)(o':option elt') := match o with | None => None | _ => Some (o,o') end. Definition at_least_right (o:option elt)(o':option elt') := match o' with | None => None | _ => Some (o,o') end. Lemma combine_l_1 : forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), find x (combine_l m m') = at_least_left (find x m) (find x m'). Proof. unfold combine_l. intros. case_eq (find x m); intros. simpl. apply find_1. apply mapi_NoDup; auto. destruct (mapi_1 (fun k e => (Some e, find k m')) (find_2 H)) as (y,(H0,H1)). rewrite (find_eq Hm' (X.eq_sym H0)); auto. simpl. case_eq (find x (mapi (fun k e => (Some e, find k m')) m)); intros; auto. destruct (@mapi_2 _ _ m x (fun k e => (Some e, find k m'))). exists p; apply find_2; auto. rewrite (find_1 Hm H1) in H; discriminate. Qed. Lemma combine_r_1 : forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), find x (combine_r m m') = at_least_right (find x m) (find x m'). Proof. unfold combine_r. intros. case_eq (find x m'); intros. simpl. apply find_1. apply mapi_NoDup; auto. destruct (mapi_1 (fun k e => (find k m, Some e)) (find_2 H)) as (y,(H0,H1)). rewrite (find_eq Hm (X.eq_sym H0)); auto. simpl. case_eq (find x (mapi (fun k e' => (find k m, Some e')) m')); intros; auto. destruct (@mapi_2 _ _ m' x (fun k e' => (find k m, Some e'))). exists p; apply find_2; auto. rewrite (find_1 Hm' H1) in H; discriminate. Qed. Definition at_least_one (o:option elt)(o':option elt') := match o, o' with | None, None => None | _, _ => Some (o,o') end. Lemma combine_1 : forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), find x (combine m m') = at_least_one (find x m) (find x m'). Proof. unfold combine. intros. generalize (combine_r_1 Hm Hm' x). generalize (combine_l_1 Hm Hm' x). assert (NoDupA (eqk (elt:=oee')) (combine_l m m')). unfold combine_l; apply mapi_NoDup; auto. assert (NoDupA (eqk (elt:=oee')) (combine_r m m')). unfold combine_r; apply mapi_NoDup; auto. set (l := combine_l m m') in *; clearbody l. set (r := combine_r m m') in *; clearbody r. set (o := find x m); clearbody o. set (o' := find x m'); clearbody o'. clear Hm' Hm m m'. induction l. destruct o; destruct o'; simpl; intros; discriminate || auto. destruct a; simpl in *; intros. destruct (X.eq_dec x t0); simpl in *. unfold at_least_left in H1. destruct o; simpl in *; try discriminate. inversion H1; subst. apply add_eq; auto. inversion_clear H; auto. inversion_clear H. rewrite <- IHl; auto. apply add_not_eq; auto. Qed. Variable f : option elt -> option elt' -> option elt''. Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := match o with | Some e => (k,e)::l | None => l end. Definition map2 m m' := let m0 : t oee' := combine m m' in let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in fold_right_pair (option_cons (A:=elt'')) m1 nil. Lemma map2_NoDup : forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), NoDupA (@eqk elt'') (map2 m m'). Proof. intros. unfold map2. assert (H0:=combine_NoDup Hm Hm'). set (l0:=combine m m') in *; clearbody l0. set (f':= fun p : oee' => f (fst p) (snd p)). assert (H1:=map_NoDup (elt' := option elt'') H0 f'). set (l1:=map f' l0) in *; clearbody l1. clear f' f H0 l0 Hm Hm' m m'. induction l1. simpl; auto. inversion_clear H1. destruct a; destruct o; simpl; auto. constructor; auto. contradict H. clear IHl1. induction l1. inversion H. inversion_clear H0. destruct a; destruct o; simpl in *; auto. inversion_clear H; auto. Qed. Definition at_least_one_then_f (o:option elt)(o':option elt') := match o, o' with | None, None => None | _, _ => f o o' end. Lemma map2_0 : forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). Proof. intros. unfold map2. assert (H:=combine_1 Hm Hm' x). assert (H2:=combine_NoDup Hm Hm'). set (f':= fun p : oee' => f (fst p) (snd p)). set (m0 := combine m m') in *; clearbody m0. set (o:=find x m) in *; clearbody o. set (o':=find x m') in *; clearbody o'. clear Hm Hm' m m'. generalize H; clear H. match goal with |- ?m=?n -> ?p=?q => assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end. induction m0; simpl in *; intuition. destruct o; destruct o'; simpl in *; try discriminate; auto. destruct a as (k,(oo,oo')); simpl in *. inversion_clear H2. destruct (X.eq_dec x k); simpl in *. (* x = k *) assert (at_least_one_then_f o o' = f oo oo'). destruct o; destruct o'; simpl in *; inversion_clear H; auto. rewrite H2. unfold f'; simpl. destruct (f oo oo'); simpl. destruct (X.eq_dec x k); try contradict n; auto. destruct (IHm0 H1) as (_,H4); apply H4; auto. case_eq (find x m0); intros; auto. elim H0. apply InA_eqk with (x,p); auto. apply InA_eqke_eqk. exact (find_2 H3). (* k < x *) unfold f'; simpl. destruct (f oo oo'); simpl. destruct (X.eq_dec x k); [ contradict n; auto | auto]. destruct (IHm0 H1) as (H3,_); apply H3; auto. destruct (IHm0 H1) as (H3,_); apply H3; auto. (* None -> None *) destruct a as (k,(oo,oo')). simpl. inversion_clear H2. destruct (X.eq_dec x k). (* x = k *) discriminate. (* k < x *) unfold f'; simpl. destruct (f oo oo'); simpl. destruct (X.eq_dec x k); [ contradict n; auto | auto]. destruct (IHm0 H1) as (_,H4); apply H4; auto. destruct (IHm0 H1) as (_,H4); apply H4; auto. Qed. (** Specification of [map2] *) Lemma map2_1 : forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), In x m \/ In x m' -> find x (map2 m m') = f (find x m) (find x m'). Proof. intros. rewrite map2_0; auto. destruct H as [(e,H)|(e,H)]. rewrite (find_1 Hm H). destruct (find x m'); simpl; auto. rewrite (find_1 Hm' H). destruct (find x m); simpl; auto. Qed. Lemma map2_2 : forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), In x (map2 m m') -> In x m \/ In x m'. Proof. intros. destruct H as (e,H). generalize (map2_0 Hm Hm' x). rewrite (find_1 (map2_NoDup Hm Hm') H). generalize (@find_2 _ m x). generalize (@find_2 _ m' x). destruct (find x m); destruct (find x m'); simpl; intros. left; exists e0; auto. left; exists e0; auto. right; exists e0; auto. discriminate. Qed. End Elt3. End Raw. Module Make (X: DecidableType) <: WS with Module E:=X. Module Raw := Raw X. Module E := X. Definition key := E.t. Record slist (elt:Type) := {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}. Definition t (elt:Type) := slist elt. Section Elt. Variable elt elt' elt'':Type. Implicit Types m : t elt. Implicit Types x y : key. Implicit Types e : elt. Definition empty : t elt := Build_slist (Raw.empty_NoDup elt). Definition is_empty m : bool := Raw.is_empty m.(this). Definition add x e m : t elt := Build_slist (Raw.add_NoDup m.(NoDup) x e). Definition find x m : option elt := Raw.find x m.(this). Definition remove x m : t elt := Build_slist (Raw.remove_NoDup m.(NoDup) x). Definition mem x m : bool := Raw.mem x m.(this). Definition map f m : t elt' := Build_slist (Raw.map_NoDup m.(NoDup) f). Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_NoDup m.(NoDup) f). Definition map2 f m (m':t elt') : t elt'' := Build_slist (Raw.map2_NoDup f m.(NoDup) m'.(NoDup)). Definition elements m : list (key*elt) := @Raw.elements elt m.(this). Definition cardinal m := length m.(this). Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f m.(this) i. Definition equal cmp m m' : bool := @Raw.equal elt cmp m.(this) m'.(this). Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this). Definition In x m : Prop := Raw.PX.In x m.(this). Definition Empty m : Prop := Raw.Empty m.(this). Definition Equal m m' := forall y, find y m = find y m'. Definition Equiv (eq_elt:elt->elt->Prop) m m' := (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. Proof. intros m; exact (@Raw.PX.MapsTo_eq elt m.(this)). Qed. Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. intros m; exact (@Raw.mem_1 elt m.(this) m.(NoDup)). Qed. Lemma mem_2 : forall m x, mem x m = true -> In x m. Proof. intros m; exact (@Raw.mem_2 elt m.(this) m.(NoDup)). Qed. Lemma empty_1 : Empty empty. Proof. exact (@Raw.empty_1 elt). Qed. Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. Proof. intros m; exact (@Raw.is_empty_1 elt m.(this)). Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. Proof. intros m; exact (@Raw.is_empty_2 elt m.(this)). Qed. Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). Proof. intros m; exact (@Raw.add_1 elt m.(this)). Qed. Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. intros m; exact (@Raw.add_2 elt m.(this)). Qed. Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. Proof. intros m; exact (@Raw.add_3 elt m.(this)). Qed. Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). Proof. intros m; exact (@Raw.remove_1 elt m.(this) m.(NoDup)). Qed. Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m; exact (@Raw.remove_2 elt m.(this) m.(NoDup)). Qed. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(NoDup)). Qed. Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(NoDup)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed. Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed. Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed. Lemma elements_3w : forall m, NoDupA eq_key (elements m). Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(NoDup)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). Proof. intros; reflexivity. Qed. Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed. Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed. Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed. End Elt. Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed. Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x m \/ In x m' -> find x (map2 f m m') = f (find x m) (find x m'). Proof. intros elt elt' elt'' m m' x f; exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Proof. intros elt elt' elt'' m m' x f; exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x). Qed. End Make. coq-8.4pl4/theories/FSets/FMaps.v0000644000175000017500000000137212326224777015701 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ... -> Pk -> P >> where [P]'s are defined by the grammar: << P ::= | Q | Empty F | Subset F F' | Equal F F' Q ::= | E.eq X X' | In X F | Q /\ Q' | Q \/ Q' | Q -> Q' | Q <-> Q' | ~ Q | True | False F ::= | S | empty | singleton X | add X F | remove X F | union F F' | inter F F' | diff F F' X ::= x1 | ... | xm S ::= s1 | ... | sn >> The tactic will also work on some goals that vary slightly from the above form: - The variables and hypotheses may be mixed in any order and may have already been introduced into the context. Moreover, there may be additional, unrelated hypotheses mixed in (these will be ignored). - A conjunction of hypotheses will be handled as easily as separate hypotheses, i.e., [P1 /\ P2 -> P] can be solved iff [P1 -> P2 -> P] can be solved. - [fsetdec] should solve any goal if the FSet-related hypotheses are contradictory. - [fsetdec] will first perform any necessary zeta and beta reductions and will invoke [subst] to eliminate any Coq equalities between finite sets or their elements. - If [E.eq] is convertible with Coq's equality, it will not matter which one is used in the hypotheses or conclusion. - The tactic can solve goals where the finite sets or set elements are expressed by Coq terms that are more complicated than variables. However, non-local definitions are not expanded, and Coq equalities between non-variable terms are not used. For example, this goal will be solved: << forall (f : t -> t), forall (g : elt -> elt), forall (s1 s2 : t), forall (x1 x2 : elt), Equal s1 (f s2) -> E.eq x1 (g (g x2)) -> In x1 s1 -> In (g (g x2)) (f s2) >> This one will not be solved: << forall (f : t -> t), forall (g : elt -> elt), forall (s1 s2 : t), forall (x1 x2 : elt), Equal s1 (f s2) -> E.eq x1 (g x2) -> In x1 s1 -> g x2 = g (g x2) -> In (g (g x2)) (f s2) >> *) (** * Facts and Tactics for Propositional Logic These lemmas and tactics are in a module so that they do not affect the namespace if you import the enclosing module [Decide]. *) Module FSetLogicalFacts. Require Export Decidable. Require Export Setoid. (** ** Lemmas and Tactics About Decidable Propositions *) (** ** Propositional Equivalences Involving Negation These are all written with the unfolded form of negation, since I am not sure if setoid rewriting will always perform conversion. *) (** ** Tactics for Negations *) Tactic Notation "fold" "any" "not" := repeat ( match goal with | H: context [?P -> False] |- _ => fold (~ P) in H | |- context [?P -> False] => fold (~ P) end). (** [push not using db] will pushes all negations to the leaves of propositions in the goal, using the lemmas in [db] to assist in checking the decidability of the propositions involved. If [using db] is omitted, then [core] will be used. Additional versions are provided to manipulate the hypotheses or the hypotheses and goal together. XXX: This tactic and the similar subsequent ones should have been defined using [autorewrite]. However, dealing with multiples rewrite sites and side-conditions is done more cleverly with the following explicit analysis of goals. *) Ltac or_not_l_iff P Q tac := (rewrite (or_not_l_iff_1 P Q) by tac) || (rewrite (or_not_l_iff_2 P Q) by tac). Ltac or_not_r_iff P Q tac := (rewrite (or_not_r_iff_1 P Q) by tac) || (rewrite (or_not_r_iff_2 P Q) by tac). Ltac or_not_l_iff_in P Q H tac := (rewrite (or_not_l_iff_1 P Q) in H by tac) || (rewrite (or_not_l_iff_2 P Q) in H by tac). Ltac or_not_r_iff_in P Q H tac := (rewrite (or_not_r_iff_1 P Q) in H by tac) || (rewrite (or_not_r_iff_2 P Q) in H by tac). Tactic Notation "push" "not" "using" ident(db) := let dec := solve_decidable using db in unfold not, iff; repeat ( match goal with | |- context [True -> False] => rewrite not_true_iff | |- context [False -> False] => rewrite not_false_iff | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec | |- context [(?P -> False) -> (?Q -> False)] => rewrite (contrapositive P Q) by dec | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec | |- context [?P \/ ?Q -> False] => rewrite (not_or_iff P Q) | |- context [?P /\ ?Q -> False] => rewrite (not_and_iff P Q) | |- context [(?P -> ?Q) -> False] => rewrite (not_imp_iff P Q) by dec end); fold any not. Tactic Notation "push" "not" := push not using core. Tactic Notation "push" "not" "in" "*" "|-" "using" ident(db) := let dec := solve_decidable using db in unfold not, iff in * |-; repeat ( match goal with | H: context [True -> False] |- _ => rewrite not_true_iff in H | H: context [False -> False] |- _ => rewrite not_false_iff in H | H: context [(?P -> False) -> False] |- _ => rewrite (not_not_iff P) in H by dec | H: context [(?P -> False) -> (?Q -> False)] |- _ => rewrite (contrapositive P Q) in H by dec | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec | H: context [(?P -> False) -> ?Q] |- _ => rewrite (imp_not_l P Q) in H by dec | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H | H: context [(?P -> ?Q) -> False] |- _ => rewrite (not_imp_iff P Q) in H by dec end); fold any not. Tactic Notation "push" "not" "in" "*" "|-" := push not in * |- using core. Tactic Notation "push" "not" "in" "*" "using" ident(db) := push not using db; push not in * |- using db. Tactic Notation "push" "not" "in" "*" := push not in * using core. (** A simple test case to see how this works. *) Lemma test_push : forall P Q R : Prop, decidable P -> decidable Q -> (~ True) -> (~ False) -> (~ ~ P) -> (~ (P /\ Q) -> ~ R) -> ((P /\ Q) \/ ~ R) -> (~ (P /\ Q) \/ R) -> (R \/ ~ (P /\ Q)) -> (~ R \/ (P /\ Q)) -> (~ P -> R) -> (~ ((R -> P) \/ (Q -> R))) -> (~ (P /\ R)) -> (~ (P -> R)) -> True. Proof. intros. push not in *. (* note that ~(R->P) remains (since R isnt decidable) *) tauto. Qed. (** [pull not using db] will pull as many negations as possible toward the top of the propositions in the goal, using the lemmas in [db] to assist in checking the decidability of the propositions involved. If [using db] is omitted, then [core] will be used. Additional versions are provided to manipulate the hypotheses or the hypotheses and goal together. *) Tactic Notation "pull" "not" "using" ident(db) := let dec := solve_decidable using db in unfold not, iff; repeat ( match goal with | |- context [True -> False] => rewrite not_true_iff | |- context [False -> False] => rewrite not_false_iff | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec | |- context [(?P -> False) -> (?Q -> False)] => rewrite (contrapositive P Q) by dec | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec | |- context [(?P -> False) /\ (?Q -> False)] => rewrite <- (not_or_iff P Q) | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q) | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec | |- context [(?Q -> False) /\ ?P] => rewrite <- (not_imp_rev_iff P Q) by dec end); fold any not. Tactic Notation "pull" "not" := pull not using core. Tactic Notation "pull" "not" "in" "*" "|-" "using" ident(db) := let dec := solve_decidable using db in unfold not, iff in * |-; repeat ( match goal with | H: context [True -> False] |- _ => rewrite not_true_iff in H | H: context [False -> False] |- _ => rewrite not_false_iff in H | H: context [(?P -> False) -> False] |- _ => rewrite (not_not_iff P) in H by dec | H: context [(?P -> False) -> (?Q -> False)] |- _ => rewrite (contrapositive P Q) in H by dec | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec | H: context [(?P -> False) -> ?Q] |- _ => rewrite (imp_not_l P Q) in H by dec | H: context [(?P -> False) /\ (?Q -> False)] |- _ => rewrite <- (not_or_iff P Q) in H | H: context [?P -> ?Q -> False] |- _ => rewrite <- (not_and_iff P Q) in H | H: context [?P /\ (?Q -> False)] |- _ => rewrite <- (not_imp_iff P Q) in H by dec | H: context [(?Q -> False) /\ ?P] |- _ => rewrite <- (not_imp_rev_iff P Q) in H by dec end); fold any not. Tactic Notation "pull" "not" "in" "*" "|-" := pull not in * |- using core. Tactic Notation "pull" "not" "in" "*" "using" ident(db) := pull not using db; pull not in * |- using db. Tactic Notation "pull" "not" "in" "*" := pull not in * using core. (** A simple test case to see how this works. *) Lemma test_pull : forall P Q R : Prop, decidable P -> decidable Q -> (~ True) -> (~ False) -> (~ ~ P) -> (~ (P /\ Q) -> ~ R) -> ((P /\ Q) \/ ~ R) -> (~ (P /\ Q) \/ R) -> (R \/ ~ (P /\ Q)) -> (~ R \/ (P /\ Q)) -> (~ P -> R) -> (~ (R -> P) /\ ~ (Q -> R)) -> (~ P \/ ~ R) -> (P /\ ~ R) -> (~ R /\ P) -> True. Proof. intros. pull not in *. tauto. Qed. End FSetLogicalFacts. Import FSetLogicalFacts. (** * Auxiliary Tactics Again, these lemmas and tactics are in a module so that they do not affect the namespace if you import the enclosing module [Decide]. *) Module FSetDecideAuxiliary. (** ** Generic Tactics We begin by defining a few generic, useful tactics. *) (** remove logical hypothesis inter-dependencies (fix #2136). *) Ltac no_logical_interdep := match goal with | H : ?P |- _ => match type of P with | Prop => match goal with H' : context [ H ] |- _ => clear dependent H' end | _ => fail end; no_logical_interdep | _ => idtac end. (** [if t then t1 else t2] executes [t] and, if it does not fail, then [t1] will be applied to all subgoals produced. If [t] fails, then [t2] is executed. *) Tactic Notation "if" tactic(t) "then" tactic(t1) "else" tactic(t2) := first [ t; first [ t1 | fail 2 ] | t2 ]. Ltac abstract_term t := if (is_var t) then fail "no need to abstract a variable" else (let x := fresh "x" in set (x := t) in *; try clearbody x). Ltac abstract_elements := repeat (match goal with | |- context [ singleton ?t ] => abstract_term t | _ : context [ singleton ?t ] |- _ => abstract_term t | |- context [ add ?t _ ] => abstract_term t | _ : context [ add ?t _ ] |- _ => abstract_term t | |- context [ remove ?t _ ] => abstract_term t | _ : context [ remove ?t _ ] |- _ => abstract_term t | |- context [ In ?t _ ] => abstract_term t | _ : context [ In ?t _ ] |- _ => abstract_term t end). (** [prop P holds by t] succeeds (but does not modify the goal or context) if the proposition [P] can be proved by [t] in the current context. Otherwise, the tactic fails. *) Tactic Notation "prop" constr(P) "holds" "by" tactic(t) := let H := fresh in assert P as H by t; clear H. (** This tactic acts just like [assert ... by ...] but will fail if the context already contains the proposition. *) Tactic Notation "assert" "new" constr(e) "by" tactic(t) := match goal with | H: e |- _ => fail 1 | _ => assert e by t end. (** [subst++] is similar to [subst] except that - it never fails (as [subst] does on recursive equations), - it substitutes locally defined variable for their definitions, - it performs beta reductions everywhere, which may arise after substituting a locally defined function for its definition. *) Tactic Notation "subst" "++" := repeat ( match goal with | x : _ |- _ => subst x end); cbv zeta beta in *. (** [decompose records] calls [decompose record H] on every relevant hypothesis [H]. *) Tactic Notation "decompose" "records" := repeat ( match goal with | H: _ |- _ => progress (decompose record H); clear H end). (** ** Discarding Irrelevant Hypotheses We will want to clear the context of any non-FSet-related hypotheses in order to increase the speed of the tactic. To do this, we will need to be able to decide which are relevant. We do this by making a simple inductive definition classifying the propositions of interest. *) Inductive FSet_elt_Prop : Prop -> Prop := | eq_Prop : forall (S : Type) (x y : S), FSet_elt_Prop (x = y) | eq_elt_prop : forall x y, FSet_elt_Prop (E.eq x y) | In_elt_prop : forall x s, FSet_elt_Prop (In x s) | True_elt_prop : FSet_elt_Prop True | False_elt_prop : FSet_elt_Prop False | conj_elt_prop : forall P Q, FSet_elt_Prop P -> FSet_elt_Prop Q -> FSet_elt_Prop (P /\ Q) | disj_elt_prop : forall P Q, FSet_elt_Prop P -> FSet_elt_Prop Q -> FSet_elt_Prop (P \/ Q) | impl_elt_prop : forall P Q, FSet_elt_Prop P -> FSet_elt_Prop Q -> FSet_elt_Prop (P -> Q) | not_elt_prop : forall P, FSet_elt_Prop P -> FSet_elt_Prop (~ P). Inductive FSet_Prop : Prop -> Prop := | elt_FSet_Prop : forall P, FSet_elt_Prop P -> FSet_Prop P | Empty_FSet_Prop : forall s, FSet_Prop (Empty s) | Subset_FSet_Prop : forall s1 s2, FSet_Prop (Subset s1 s2) | Equal_FSet_Prop : forall s1 s2, FSet_Prop (Equal s1 s2). (** Here is the tactic that will throw away hypotheses that are not useful (for the intended scope of the [fsetdec] tactic). *) Hint Constructors FSet_elt_Prop FSet_Prop : FSet_Prop. Ltac discard_nonFSet := repeat ( match goal with | H : context [ @Logic.eq ?T ?x ?y ] |- _ => if (change T with E.t in H) then fail else if (change T with t in H) then fail else clear H | H : ?P |- _ => if prop (FSet_Prop P) holds by (auto 100 with FSet_Prop) then fail else clear H end). (** ** Turning Set Operators into Propositional Connectives The lemmas from [FSetFacts] will be used to break down set operations into propositional formulas built over the predicates [In] and [E.eq] applied only to variables. We are going to use them with [autorewrite]. *) Hint Rewrite F.empty_iff F.singleton_iff F.add_iff F.remove_iff F.union_iff F.inter_iff F.diff_iff : set_simpl. Lemma eq_refl_iff (x : E.t) : E.eq x x <-> True. Proof. now split. Qed. Hint Rewrite eq_refl_iff : set_eq_simpl. (** ** Decidability of FSet Propositions *) (** [In] is decidable. *) Lemma dec_In : forall x s, decidable (In x s). Proof. red; intros; generalize (F.mem_iff s x); case (mem x s); intuition. Qed. (** [E.eq] is decidable. *) Lemma dec_eq : forall (x y : E.t), decidable (E.eq x y). Proof. red; intros x y; destruct (E.eq_dec x y); auto. Qed. (** The hint database [FSet_decidability] will be given to the [push_neg] tactic from the module [Negation]. *) Hint Resolve dec_In dec_eq : FSet_decidability. (** ** Normalizing Propositions About Equality We have to deal with the fact that [E.eq] may be convertible with Coq's equality. Thus, we will find the following tactics useful to replace one form with the other everywhere. *) (** The next tactic, [Logic_eq_to_E_eq], mentions the term [E.t]; thus, we must ensure that [E.t] is used in favor of any other convertible but syntactically distinct term. *) Ltac change_to_E_t := repeat ( match goal with | H : ?T |- _ => progress (change T with E.t in H); repeat ( match goal with | J : _ |- _ => progress (change T with E.t in J) | |- _ => progress (change T with E.t) end ) | H : forall x : ?T, _ |- _ => progress (change T with E.t in H); repeat ( match goal with | J : _ |- _ => progress (change T with E.t in J) | |- _ => progress (change T with E.t) end ) end). (** These two tactics take us from Coq's built-in equality to [E.eq] (and vice versa) when possible. *) Ltac Logic_eq_to_E_eq := repeat ( match goal with | H: _ |- _ => progress (change (@Logic.eq E.t) with E.eq in H) | |- _ => progress (change (@Logic.eq E.t) with E.eq) end). Ltac E_eq_to_Logic_eq := repeat ( match goal with | H: _ |- _ => progress (change E.eq with (@Logic.eq E.t) in H) | |- _ => progress (change E.eq with (@Logic.eq E.t)) end). (** This tactic works like the built-in tactic [subst], but at the level of set element equality (which may not be the convertible with Coq's equality). *) Ltac substFSet := repeat ( match goal with | H: E.eq ?x ?x |- _ => clear H | H: E.eq ?x ?y |- _ => rewrite H in *; clear H end); autorewrite with set_eq_simpl in *. (** ** Considering Decidability of Base Propositions This tactic adds assertions about the decidability of [E.eq] and [In] to the context. This is necessary for the completeness of the [fsetdec] tactic. However, in order to minimize the cost of proof search, we should be careful to not add more than we need. Once negations have been pushed to the leaves of the propositions, we only need to worry about decidability for those base propositions that appear in a negated form. *) Ltac assert_decidability := (** We actually don't want these rules to fire if the syntactic context in the patterns below is trivially empty, but we'll just do some clean-up at the afterward. *) repeat ( match goal with | H: context [~ E.eq ?x ?y] |- _ => assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) | H: context [~ In ?x ?s] |- _ => assert new (In x s \/ ~ In x s) by (apply dec_In) | |- context [~ E.eq ?x ?y] => assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) | |- context [~ In ?x ?s] => assert new (In x s \/ ~ In x s) by (apply dec_In) end); (** Now we eliminate the useless facts we added (because they would likely be very harmful to performance). *) repeat ( match goal with | _: ~ ?P, H : ?P \/ ~ ?P |- _ => clear H end). (** ** Handling [Empty], [Subset], and [Equal] This tactic instantiates universally quantified hypotheses (which arise from the unfolding of [Empty], [Subset], and [Equal]) for each of the set element expressions that is involved in some membership or equality fact. Then it throws away those hypotheses, which should no longer be needed. *) Ltac inst_FSet_hypotheses := repeat ( match goal with | H : forall a : E.t, _, _ : context [ In ?x _ ] |- _ => let P := type of (H x) in assert new P by (exact (H x)) | H : forall a : E.t, _ |- context [ In ?x _ ] => let P := type of (H x) in assert new P by (exact (H x)) | H : forall a : E.t, _, _ : context [ E.eq ?x _ ] |- _ => let P := type of (H x) in assert new P by (exact (H x)) | H : forall a : E.t, _ |- context [ E.eq ?x _ ] => let P := type of (H x) in assert new P by (exact (H x)) | H : forall a : E.t, _, _ : context [ E.eq _ ?x ] |- _ => let P := type of (H x) in assert new P by (exact (H x)) | H : forall a : E.t, _ |- context [ E.eq _ ?x ] => let P := type of (H x) in assert new P by (exact (H x)) end); repeat ( match goal with | H : forall a : E.t, _ |- _ => clear H end). (** ** The Core [fsetdec] Auxiliary Tactics *) (** Here is the crux of the proof search. Recursion through [intuition]! (This will terminate if I correctly understand the behavior of [intuition].) *) Ltac fsetdec_rec := progress substFSet; intuition fsetdec_rec. (** If we add [unfold Empty, Subset, Equal in *; intros;] to the beginning of this tactic, it will satisfy the same specification as the [fsetdec] tactic; however, it will be much slower than necessary without the pre-processing done by the wrapper tactic [fsetdec]. *) Ltac fsetdec_body := autorewrite with set_eq_simpl in *; inst_FSet_hypotheses; autorewrite with set_simpl set_eq_simpl in *; push not in * using FSet_decidability; substFSet; assert_decidability; auto; (intuition fsetdec_rec) || fail 1 "because the goal is beyond the scope of this tactic". End FSetDecideAuxiliary. Import FSetDecideAuxiliary. (** * The [fsetdec] Tactic Here is the top-level tactic (the only one intended for clients of this library). It's specification is given at the top of the file. *) Ltac fsetdec := (** We first unfold any occurrences of [iff]. *) unfold iff in *; (** We fold occurrences of [not] because it is better for [intros] to leave us with a goal of [~ P] than a goal of [False]. *) fold any not; intros; (** We don't care about the value of elements : complex ones are abstracted as new variables (avoiding potential dependencies, see bug #2464) *) abstract_elements; (** We remove dependencies to logical hypothesis. This way, later "clear" will work nicely (see bug #2136) *) no_logical_interdep; (** Now we decompose conjunctions, which will allow the [discard_nonFSet] and [assert_decidability] tactics to do a much better job. *) decompose records; discard_nonFSet; (** We unfold these defined propositions on finite sets. If our goal was one of them, then have one more item to introduce now. *) unfold Empty, Subset, Equal in *; intros; (** We now want to get rid of all uses of [=] in favor of [E.eq]. However, the best way to eliminate a [=] is in the context is with [subst], so we will try that first. In fact, we may as well convert uses of [E.eq] into [=] when possible before we do [subst] so that we can even more mileage out of it. Then we will convert all remaining uses of [=] back to [E.eq] when possible. We use [change_to_E_t] to ensure that we have a canonical name for set elements, so that [Logic_eq_to_E_eq] will work properly. *) change_to_E_t; E_eq_to_Logic_eq; subst++; Logic_eq_to_E_eq; (** The next optimization is to swap a negated goal with a negated hypothesis when possible. Any swap will improve performance by eliminating the total number of negations, but we will get the maximum benefit if we swap the goal with a hypotheses mentioning the same set element, so we try that first. If we reach the fourth branch below, we attempt any swap. However, to maintain completeness of this tactic, we can only perform such a swap with a decidable proposition; hence, we first test whether the hypothesis is an [FSet_elt_Prop], noting that any [FSet_elt_Prop] is decidable. *) pull not using FSet_decidability; unfold not in *; match goal with | H: (In ?x ?r) -> False |- (In ?x ?s) -> False => contradict H; fsetdec_body | H: (In ?x ?r) -> False |- (E.eq ?x ?y) -> False => contradict H; fsetdec_body | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False => contradict H; fsetdec_body | H: ?P -> False |- ?Q -> False => if prop (FSet_elt_Prop P) holds by (auto 100 with FSet_Prop) then (contradict H; fsetdec_body) else fsetdec_body | |- _ => fsetdec_body end. (** * Examples *) Module FSetDecideTestCases. Lemma test_eq_trans_1 : forall x y z s, E.eq x y -> ~ ~ E.eq z y -> In x s -> In z s. Proof. fsetdec. Qed. Lemma test_eq_trans_2 : forall x y z r s, In x (singleton y) -> ~ In z r -> ~ ~ In z (add y r) -> In x s -> In z s. Proof. fsetdec. Qed. Lemma test_eq_neq_trans_1 : forall w x y z s, E.eq x w -> ~ ~ E.eq x y -> ~ E.eq y z -> In w s -> In w (remove z s). Proof. fsetdec. Qed. Lemma test_eq_neq_trans_2 : forall w x y z r1 r2 s, In x (singleton w) -> ~ In x r1 -> In x (add y r1) -> In y r2 -> In y (remove z r2) -> In w s -> In w (remove z s). Proof. fsetdec. Qed. Lemma test_In_singleton : forall x, In x (singleton x). Proof. fsetdec. Qed. Lemma test_add_In : forall x y s, In x (add y s) -> ~ E.eq x y -> In x s. Proof. fsetdec. Qed. Lemma test_Subset_add_remove : forall x s, s [<=] (add x (remove x s)). Proof. fsetdec. Qed. Lemma test_eq_disjunction : forall w x y z, In w (add x (add y (singleton z))) -> E.eq w x \/ E.eq w y \/ E.eq w z. Proof. fsetdec. Qed. Lemma test_not_In_disj : forall x y s1 s2 s3 s4, ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> ~ (In x s1 \/ In x s4 \/ E.eq y x). Proof. fsetdec. Qed. Lemma test_not_In_conj : forall x y s1 s2 s3 s4, ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> ~ In x s1 /\ ~ In x s4 /\ ~ E.eq y x. Proof. fsetdec. Qed. Lemma test_iff_conj : forall a x s s', (In a s' <-> E.eq x a \/ In a s) -> (In a s' <-> In a (add x s)). Proof. fsetdec. Qed. Lemma test_set_ops_1 : forall x q r s, (singleton x) [<=] s -> Empty (union q r) -> Empty (inter (diff s q) (diff s r)) -> ~ In x s. Proof. fsetdec. Qed. Lemma eq_chain_test : forall x1 x2 x3 x4 s1 s2 s3 s4, Empty s1 -> In x2 (add x1 s1) -> In x3 s2 -> ~ In x3 (remove x2 s2) -> ~ In x4 s3 -> In x4 (add x3 s3) -> In x1 s4 -> Subset (add x4 s4) s4. Proof. fsetdec. Qed. Lemma test_too_complex : forall x y z r s, E.eq x y -> (In x (singleton y) -> r [<=] s) -> In z r -> In z s. Proof. (** [fsetdec] is not intended to solve this directly. *) intros until s; intros Heq H Hr; lapply H; fsetdec. Qed. Lemma function_test_1 : forall (f : t -> t), forall (g : elt -> elt), forall (s1 s2 : t), forall (x1 x2 : elt), Equal s1 (f s2) -> E.eq x1 (g (g x2)) -> In x1 s1 -> In (g (g x2)) (f s2). Proof. fsetdec. Qed. Lemma function_test_2 : forall (f : t -> t), forall (g : elt -> elt), forall (s1 s2 : t), forall (x1 x2 : elt), Equal s1 (f s2) -> E.eq x1 (g x2) -> In x1 s1 -> g x2 = g (g x2) -> In (g (g x2)) (f s2). Proof. (** [fsetdec] is not intended to solve this directly. *) intros until 3. intros g_eq. rewrite <- g_eq. fsetdec. Qed. Lemma test_baydemir : forall (f : t -> t), forall (s : t), forall (x y : elt), In x (add y (f s)) -> ~ E.eq x y -> In x (f s). Proof. fsetdec. Qed. End FSetDecideTestCases. End WDecide_fun. Require Import FSetInterface. (** Now comes variants for self-contained weak sets and for full sets. For these variants, only one argument is necessary. Thanks to the subtyping [WS<=S], the [Decide] functor which is meant to be used on modules [(M:S)] can simply be an alias of [WDecide]. *) Module WDecide (M:WS) := !WDecide_fun M.E M. Module Decide := WDecide. coq-8.4pl4/theories/FSets/FMapAVL.v0000644000175000017500000017377212326224777016077 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* key -> elt -> tree -> int -> tree. Notation t := tree. (** * Basic functions on trees: height and cardinal *) Definition height (m : t) : int := match m with | Leaf => 0 | Node _ _ _ _ h => h end. Fixpoint cardinal (m : t) : nat := match m with | Leaf => 0%nat | Node l _ _ r _ => S (cardinal l + cardinal r) end. (** * Empty Map *) Definition empty := Leaf. (** * Emptyness test *) Definition is_empty m := match m with Leaf => true | _ => false end. (** * Membership *) (** The [mem] function is deciding membership. It exploits the [bst] property to achieve logarithmic complexity. *) Fixpoint mem x m : bool := match m with | Leaf => false | Node l y _ r _ => match X.compare x y with | LT _ => mem x l | EQ _ => true | GT _ => mem x r end end. Fixpoint find x m : option elt := match m with | Leaf => None | Node l y d r _ => match X.compare x y with | LT _ => find x l | EQ _ => Some d | GT _ => find x r end end. (** * Helper functions *) (** [create l x r] creates a node, assuming [l] and [r] to be balanced and [|height l - height r| <= 2]. *) Definition create l x e r := Node l x e r (max (height l) (height r) + 1). (** [bal l x e r] acts as [create], but performs one step of rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *) Definition assert_false := create. Fixpoint bal l x d r := let hl := height l in let hr := height r in if gt_le_dec hl (hr+2) then match l with | Leaf => assert_false l x d r | Node ll lx ld lr _ => if ge_lt_dec (height ll) (height lr) then create ll lx ld (create lr x d r) else match lr with | Leaf => assert_false l x d r | Node lrl lrx lrd lrr _ => create (create ll lx ld lrl) lrx lrd (create lrr x d r) end end else if gt_le_dec hr (hl+2) then match r with | Leaf => assert_false l x d r | Node rl rx rd rr _ => if ge_lt_dec (height rr) (height rl) then create (create l x d rl) rx rd rr else match rl with | Leaf => assert_false l x d r | Node rll rlx rld rlr _ => create (create l x d rll) rlx rld (create rlr rx rd rr) end end else create l x d r. (** * Insertion *) Fixpoint add x d m := match m with | Leaf => Node Leaf x d Leaf 1 | Node l y d' r h => match X.compare x y with | LT _ => bal (add x d l) y d' r | EQ _ => Node l y d r h | GT _ => bal l y d' (add x d r) end end. (** * Extraction of minimum binding Morally, [remove_min] is to be applied to a non-empty tree [t = Node l x e r h]. Since we can't deal here with [assert false] for [t=Leaf], we pre-unpack [t] (and forget about [h]). *) Fixpoint remove_min l x d r : t*(key*elt) := match l with | Leaf => (r,(x,d)) | Node ll lx ld lr lh => let (l',m) := remove_min ll lx ld lr in (bal l' x d r, m) end. (** * Merging two trees [merge t1 t2] builds the union of [t1] and [t2] assuming all elements of [t1] to be smaller than all elements of [t2], and [|height t1 - height t2| <= 2]. *) Fixpoint merge s1 s2 := match s1,s2 with | Leaf, _ => s2 | _, Leaf => s1 | _, Node l2 x2 d2 r2 h2 => match remove_min l2 x2 d2 r2 with (s2',(x,d)) => bal s1 x d s2' end end. (** * Deletion *) Fixpoint remove x m := match m with | Leaf => Leaf | Node l y d r h => match X.compare x y with | LT _ => bal (remove x l) y d r | EQ _ => merge l r | GT _ => bal l y d (remove x r) end end. (** * join Same as [bal] but does not assume anything regarding heights of [l] and [r]. *) Fixpoint join l : key -> elt -> t -> t := match l with | Leaf => add | Node ll lx ld lr lh => fun x d => fix join_aux (r:t) : t := match r with | Leaf => add x d l | Node rl rx rd rr rh => if gt_le_dec lh (rh+2) then bal ll lx ld (join lr x d r) else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rd rr else create l x d r end end. (** * Splitting [split x m] returns a triple [(l, o, r)] where - [l] is the set of elements of [m] that are [< x] - [r] is the set of elements of [m] that are [> x] - [o] is the result of [find x m]. *) Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }. Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). Fixpoint split x m : triple := match m with | Leaf => << Leaf, None, Leaf >> | Node l y d r h => match X.compare x y with | LT _ => let (ll,o,rl) := split x l in << ll, o, join rl y d r >> | EQ _ => << l, Some d, r >> | GT _ => let (rl,o,rr) := split x r in << join l y d rl, o, rr >> end end. (** * Concatenation Same as [merge] but does not assume anything about heights. *) Definition concat m1 m2 := match m1, m2 with | Leaf, _ => m2 | _ , Leaf => m1 | _, Node l2 x2 d2 r2 _ => let (m2',xd) := remove_min l2 x2 d2 r2 in join m1 xd#1 xd#2 m2' end. (** * Elements *) (** [elements_tree_aux acc t] catenates the elements of [t] in infix order to the list [acc] *) Fixpoint elements_aux (acc : list (key*elt)) m : list (key*elt) := match m with | Leaf => acc | Node l x d r _ => elements_aux ((x,d) :: elements_aux acc r) l end. (** then [elements] is an instanciation with an empty [acc] *) Definition elements := elements_aux nil. (** * Fold *) Fixpoint fold (A : Type) (f : key -> elt -> A -> A) (m : t) : A -> A := fun a => match m with | Leaf => a | Node l x d r _ => fold f r (f x d (fold f l a)) end. (** * Comparison *) Variable cmp : elt->elt->bool. (** ** Enumeration of the elements of a tree *) Inductive enumeration := | End : enumeration | More : key -> elt -> t -> enumeration -> enumeration. (** [cons m e] adds the elements of tree [m] on the head of enumeration [e]. *) Fixpoint cons m e : enumeration := match m with | Leaf => e | Node l x d r h => cons l (More x d r e) end. (** One step of comparison of elements *) Definition equal_more x1 d1 (cont:enumeration->bool) e2 := match e2 with | End => false | More x2 d2 r2 e2 => match X.compare x1 x2 with | EQ _ => cmp d1 d2 &&& cont (cons r2 e2) | _ => false end end. (** Comparison of left tree, middle element, then right tree *) Fixpoint equal_cont m1 (cont:enumeration->bool) e2 := match m1 with | Leaf => cont e2 | Node l1 x1 d1 r1 _ => equal_cont l1 (equal_more x1 d1 (equal_cont r1 cont)) e2 end. (** Initial continuation *) Definition equal_end e2 := match e2 with End => true | _ => false end. (** The complete comparison *) Definition equal m1 m2 := equal_cont m1 equal_end (cons m2 End). End Elt. Notation t := tree. Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). Notation "t #l" := (t_left t) (at level 9, format "t '#l'"). Notation "t #o" := (t_opt t) (at level 9, format "t '#o'"). Notation "t #r" := (t_right t) (at level 9, format "t '#r'"). (** * Map *) Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := match m with | Leaf => Leaf _ | Node l x d r h => Node (map f l) x (f d) (map f r) h end. (* * Mapi *) Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' := match m with | Leaf => Leaf _ | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h end. (** * Map with removal *) Fixpoint map_option (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt) : t elt' := match m with | Leaf => Leaf _ | Node l x d r h => match f x d with | Some d' => join (map_option f l) x d' (map_option f r) | None => concat (map_option f l) (map_option f r) end end. (** * Optimized map2 Suggestion by B. Gregoire: a [map2] function with specialized arguments allowing to bypass some tree traversal. Instead of one [f0] of type [key -> option elt -> option elt' -> option elt''], we ask here for: - [f] which is a specialisation of [f0] when first option isn't [None] - [mapl] treats a [tree elt] with [f0] when second option is [None] - [mapr] treats a [tree elt'] with [f0] when first option is [None] The idea is that [mapl] and [mapr] can be instantaneous (e.g. the identity or some constant function). *) Section Map2_opt. Variable elt elt' elt'' : Type. Variable f : key -> elt -> option elt' -> option elt''. Variable mapl : t elt -> t elt''. Variable mapr : t elt' -> t elt''. Fixpoint map2_opt m1 m2 := match m1, m2 with | Leaf, _ => mapr m2 | _, Leaf => mapl m1 | Node l1 x1 d1 r1 h1, _ => let (l2',o2,r2') := split x1 m2 in match f x1 d1 o2 with | Some e => join (map2_opt l1 l2') x1 e (map2_opt r1 r2') | None => concat (map2_opt l1 l2') (map2_opt r1 r2') end end. End Map2_opt. (** * Map2 The [map2] function of the Map interface can be implemented via [map2_opt] and [map_option]. *) Section Map2. Variable elt elt' elt'' : Type. Variable f : option elt -> option elt' -> option elt''. Definition map2 : t elt -> t elt' -> t elt'' := map2_opt (fun _ d o => f (Some d) o) (map_option (fun _ d => f (Some d) None)) (map_option (fun _ d' => f None (Some d'))). End Map2. (** * Invariants *) Section Invariants. Variable elt : Type. (** ** Occurrence in a tree *) Inductive MapsTo (x : key)(e : elt) : t elt -> Prop := | MapsRoot : forall l r h y, X.eq x y -> MapsTo x e (Node l y e r h) | MapsLeft : forall l r h y e', MapsTo x e l -> MapsTo x e (Node l y e' r h) | MapsRight : forall l r h y e', MapsTo x e r -> MapsTo x e (Node l y e' r h). Inductive In (x : key) : t elt -> Prop := | InRoot : forall l r h y e, X.eq x y -> In x (Node l y e r h) | InLeft : forall l r h y e', In x l -> In x (Node l y e' r h) | InRight : forall l r h y e', In x r -> In x (Node l y e' r h). Definition In0 k m := exists e:elt, MapsTo k e m. (** ** Binary search trees *) (** [lt_tree x s]: all elements in [s] are smaller than [x] (resp. greater for [gt_tree]) *) Definition lt_tree x m := forall y, In y m -> X.lt y x. Definition gt_tree x m := forall y, In y m -> X.lt x y. (** [bst t] : [t] is a binary search tree *) Inductive bst : t elt -> Prop := | BSLeaf : bst (Leaf _) | BSNode : forall x e l r h, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (Node l x e r h). End Invariants. (** * Correctness proofs, isolated in a sub-module *) Module Proofs. Module MX := OrderedTypeFacts X. Module PX := KeyOrderedType X. Module L := FMapList.Raw X. Functional Scheme mem_ind := Induction for mem Sort Prop. Functional Scheme find_ind := Induction for find Sort Prop. Functional Scheme bal_ind := Induction for bal Sort Prop. Functional Scheme add_ind := Induction for add Sort Prop. Functional Scheme remove_min_ind := Induction for remove_min Sort Prop. Functional Scheme merge_ind := Induction for merge Sort Prop. Functional Scheme remove_ind := Induction for remove Sort Prop. Functional Scheme concat_ind := Induction for concat Sort Prop. Functional Scheme split_ind := Induction for split Sort Prop. Functional Scheme map_option_ind := Induction for map_option Sort Prop. Functional Scheme map2_opt_ind := Induction for map2_opt Sort Prop. (** * Automation and dedicated tactics. *) Hint Constructors tree MapsTo In bst. Hint Unfold lt_tree gt_tree. Tactic Notation "factornode" ident(l) ident(x) ident(d) ident(r) ident(h) "as" ident(s) := set (s:=Node l x d r h) in *; clearbody s; clear l x d r h. (** A tactic for cleaning hypothesis after use of functional induction. *) Ltac clearf := match goal with | H : (@Logic.eq (Compare _ _ _ _) _ _) |- _ => clear H; clearf | H : (@Logic.eq (sumbool _ _) _ _) |- _ => clear H; clearf | _ => idtac end. (** A tactic to repeat [inversion_clear] on all hyps of the form [(f (Node ...))] *) Ltac inv f := match goal with | H:f (Leaf _) |- _ => inversion_clear H; inv f | H:f _ (Leaf _) |- _ => inversion_clear H; inv f | H:f _ _ (Leaf _) |- _ => inversion_clear H; inv f | H:f _ _ _ (Leaf _) |- _ => inversion_clear H; inv f | H:f (Node _ _ _ _ _) |- _ => inversion_clear H; inv f | H:f _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f | H:f _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f | H:f _ _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f | _ => idtac end. Ltac inv_all f := match goal with | H: f _ |- _ => inversion_clear H; inv f | H: f _ _ |- _ => inversion_clear H; inv f | H: f _ _ _ |- _ => inversion_clear H; inv f | H: f _ _ _ _ |- _ => inversion_clear H; inv f | _ => idtac end. (** Helper tactic concerning order of elements. *) Ltac order := match goal with | U: lt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order | U: gt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order | _ => MX.order end. Ltac intuition_in := repeat progress (intuition; inv In; inv MapsTo). (* Function/Functional Scheme can't deal with internal fix. Let's do its job by hand: *) Ltac join_tac := intros l; induction l as [| ll _ lx ld lr Hlr lh]; [ | intros x d r; induction r as [| rl Hrl rx rd rr _ rh]; unfold join; [ | destruct (gt_le_dec lh (rh+2)) as [GT|LE]; [ match goal with |- context [ bal ?u ?v ?w ?z ] => replace (bal u v w z) with (bal ll lx ld (join lr x d (Node rl rx rd rr rh))); [ | auto] end | destruct (gt_le_dec rh (lh+2)) as [GT'|LE']; [ match goal with |- context [ bal ?u ?v ?w ?z ] => replace (bal u v w z) with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto] end | ] ] ] ]; intros. Section Elt. Variable elt:Type. Implicit Types m r : t elt. (** * Basic results about [MapsTo], [In], [lt_tree], [gt_tree], [height] *) (** Facts about [MapsTo] and [In]. *) Lemma MapsTo_In : forall k e m, MapsTo k e m -> In k m. Proof. induction 1; auto. Qed. Hint Resolve MapsTo_In. Lemma In_MapsTo : forall k m, In k m -> exists e, MapsTo k e m. Proof. induction 1; try destruct IHIn as (e,He); exists e; auto. Qed. Lemma In_alt : forall k m, In0 k m <-> In k m. Proof. split. intros (e,H); eauto. unfold In0; apply In_MapsTo; auto. Qed. Lemma MapsTo_1 : forall m x y e, X.eq x y -> MapsTo x e m -> MapsTo y e m. Proof. induction m; simpl; intuition_in; eauto. Qed. Hint Immediate MapsTo_1. Lemma In_1 : forall m x y, X.eq x y -> In x m -> In y m. Proof. intros m x y; induction m; simpl; intuition_in; eauto. Qed. Lemma In_node_iff : forall l x e r h y, In y (Node l x e r h) <-> In y l \/ X.eq y x \/ In y r. Proof. intuition_in. Qed. (** Results about [lt_tree] and [gt_tree] *) Lemma lt_leaf : forall x, lt_tree x (Leaf elt). Proof. unfold lt_tree; intros; intuition_in. Qed. Lemma gt_leaf : forall x, gt_tree x (Leaf elt). Proof. unfold gt_tree; intros; intuition_in. Qed. Lemma lt_tree_node : forall x y l r e h, lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y e r h). Proof. unfold lt_tree in *; intuition_in; order. Qed. Lemma gt_tree_node : forall x y l r e h, gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y e r h). Proof. unfold gt_tree in *; intuition_in; order. Qed. Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. Lemma lt_left : forall x y l r e h, lt_tree x (Node l y e r h) -> lt_tree x l. Proof. intuition_in. Qed. Lemma lt_right : forall x y l r e h, lt_tree x (Node l y e r h) -> lt_tree x r. Proof. intuition_in. Qed. Lemma gt_left : forall x y l r e h, gt_tree x (Node l y e r h) -> gt_tree x l. Proof. intuition_in. Qed. Lemma gt_right : forall x y l r e h, gt_tree x (Node l y e r h) -> gt_tree x r. Proof. intuition_in. Qed. Hint Resolve lt_left lt_right gt_left gt_right. Lemma lt_tree_not_in : forall x m, lt_tree x m -> ~ In x m. Proof. intros; intro; generalize (H _ H0); order. Qed. Lemma lt_tree_trans : forall x y, X.lt x y -> forall m, lt_tree x m -> lt_tree y m. Proof. eauto. Qed. Lemma gt_tree_not_in : forall x m, gt_tree x m -> ~ In x m. Proof. intros; intro; generalize (H _ H0); order. Qed. Lemma gt_tree_trans : forall x y, X.lt y x -> forall m, gt_tree x m -> gt_tree y m. Proof. eauto. Qed. Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. (** * Empty map *) Definition Empty m := forall (a:key)(e:elt) , ~ MapsTo a e m. Lemma empty_bst : bst (empty elt). Proof. unfold empty; auto. Qed. Lemma empty_1 : Empty (empty elt). Proof. unfold empty, Empty; intuition_in. Qed. (** * Emptyness test *) Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. Proof. destruct m as [|r x e l h]; simpl; auto. intro H; elim (H x e); auto. Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. Proof. destruct m; simpl; intros; try discriminate; red; intuition_in. Qed. (** * Membership *) Lemma mem_1 : forall m x, bst m -> In x m -> mem x m = true. Proof. intros m x; functional induction (mem x m); auto; intros; clearf; inv bst; intuition_in; order. Qed. Lemma mem_2 : forall m x, mem x m = true -> In x m. Proof. intros m x; functional induction (mem x m); auto; intros; discriminate. Qed. Lemma find_1 : forall m x e, bst m -> MapsTo x e m -> find x m = Some e. Proof. intros m x; functional induction (find x m); auto; intros; clearf; inv bst; intuition_in; simpl; auto; try solve [order | absurd (X.lt x y); eauto | absurd (X.lt y x); eauto]. Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m x; functional induction (find x m); subst; intros; clearf; try discriminate. constructor 2; auto. inversion H; auto. constructor 3; auto. Qed. Lemma find_iff : forall m x e, bst m -> (find x m = Some e <-> MapsTo x e m). Proof. split; auto using find_1, find_2. Qed. Lemma find_in : forall m x, find x m <> None -> In x m. Proof. intros. case_eq (find x m); [intros|congruence]. apply MapsTo_In with e; apply find_2; auto. Qed. Lemma in_find : forall m x, bst m -> In x m -> find x m <> None. Proof. intros. destruct (In_MapsTo H0) as (d,Hd). rewrite (find_1 H Hd); discriminate. Qed. Lemma find_in_iff : forall m x, bst m -> (find x m <> None <-> In x m). Proof. split; auto using find_in, in_find. Qed. Lemma not_find_iff : forall m x, bst m -> (find x m = None <-> ~In x m). Proof. split; intros. red; intros. elim (in_find H H1 H0). case_eq (find x m); [ intros | auto ]. elim H0; apply find_in; congruence. Qed. Lemma find_find : forall m m' x, find x m = find x m' <-> (forall d, find x m = Some d <-> find x m' = Some d). Proof. intros; destruct (find x m); destruct (find x m'); split; intros; try split; try congruence. rewrite H; auto. symmetry; rewrite <- H; auto. rewrite H; auto. Qed. Lemma find_mapsto_equiv : forall m m' x, bst m -> bst m' -> (find x m = find x m' <-> (forall d, MapsTo x d m <-> MapsTo x d m')). Proof. intros m m' x Hm Hm'. rewrite find_find. split; intros H d; specialize H with d. rewrite <- 2 find_iff; auto. rewrite 2 find_iff; auto. Qed. Lemma find_in_equiv : forall m m' x, bst m -> bst m' -> find x m = find x m' -> (In x m <-> In x m'). Proof. split; intros; apply find_in; [ rewrite <- H1 | rewrite H1 ]; apply in_find; auto. Qed. (** * Helper functions *) Lemma create_bst : forall l x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (create l x e r). Proof. unfold create; auto. Qed. Hint Resolve create_bst. Lemma create_in : forall l x e r y, In y (create l x e r) <-> X.eq y x \/ In y l \/ In y r. Proof. unfold create; split; [ inversion_clear 1 | ]; intuition. Qed. Lemma bal_bst : forall l x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (bal l x e r). Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; inv bst; repeat apply create_bst; auto; unfold create; try constructor; (apply lt_tree_node || apply gt_tree_node); auto; (eapply lt_tree_trans || eapply gt_tree_trans); eauto. Qed. Hint Resolve bal_bst. Lemma bal_in : forall l x e r y, In y (bal l x e r) <-> X.eq y x \/ In y l \/ In y r. Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; rewrite !create_in; intuition_in. Qed. Lemma bal_mapsto : forall l x e r y e', MapsTo y e' (bal l x e r) <-> MapsTo y e' (create l x e r). Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; unfold assert_false, create; intuition_in. Qed. Lemma bal_find : forall l x e r y, bst l -> bst r -> lt_tree x l -> gt_tree x r -> find y (bal l x e r) = find y (create l x e r). Proof. intros; rewrite find_mapsto_equiv; auto; intros; apply bal_mapsto. Qed. (** * Insertion *) Lemma add_in : forall m x y e, In y (add x e m) <-> X.eq y x \/ In y m. Proof. intros m x y e; functional induction (add x e m); auto; intros; try (rewrite bal_in, IHt); intuition_in. apply In_1 with x; auto. Qed. Lemma add_bst : forall m x e, bst m -> bst (add x e m). Proof. intros m x e; functional induction (add x e m); intros; inv bst; try apply bal_bst; auto; intro z; rewrite add_in; intuition. apply MX.eq_lt with x; auto. apply MX.lt_eq with x; auto. Qed. Hint Resolve add_bst. Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). Proof. intros m x y e; functional induction (add x e m); intros; inv bst; try rewrite bal_mapsto; unfold create; eauto. Qed. Lemma add_2 : forall m x y e e', ~X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. intros m x y e e'; induction m; simpl; auto. destruct (X.compare x k); intros; inv bst; try rewrite bal_mapsto; unfold create; auto; inv MapsTo; auto; order. Qed. Lemma add_3 : forall m x y e e', ~X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. Proof. intros m x y e e'; induction m; simpl; auto. intros; inv MapsTo; auto; order. destruct (X.compare x k); intro; try rewrite bal_mapsto; auto; unfold create; intros; inv MapsTo; auto; order. Qed. Lemma add_find : forall m x y e, bst m -> find y (add x e m) = match X.compare y x with EQ _ => Some e | _ => find y m end. Proof. intros. assert (~X.eq x y -> find y (add x e m) = find y m). intros; rewrite find_mapsto_equiv; auto. split; eauto using add_2, add_3. destruct X.compare; try (apply H0; order). auto using find_1, add_1. Qed. (** * Extraction of minimum binding *) Lemma remove_min_in : forall l x e r h y, In y (Node l x e r h) <-> X.eq y (remove_min l x e r)#2#1 \/ In y (remove_min l x e r)#1. Proof. intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. intuition_in. rewrite e0 in *; simpl; intros. rewrite bal_in, In_node_iff, IHp; intuition. Qed. Lemma remove_min_mapsto : forall l x e r h y e', MapsTo y e' (Node l x e r h) <-> ((X.eq y (remove_min l x e r)#2#1) /\ e' = (remove_min l x e r)#2#2) \/ MapsTo y e' (remove_min l x e r)#1. Proof. intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. intuition_in; subst; auto. rewrite e0 in *; simpl; intros. rewrite bal_mapsto; auto; unfold create. simpl in *;destruct (IHp _x y e'). intuition. inversion_clear H1; intuition. inversion_clear H3; intuition. Qed. Lemma remove_min_bst : forall l x e r h, bst (Node l x e r h) -> bst (remove_min l x e r)#1. Proof. intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. inv bst; auto. inversion_clear H; inversion_clear H0. apply bal_bst; auto. rewrite e0 in *; simpl in *; apply (IHp _x); auto. intro; intros. generalize (remove_min_in ll lx ld lr _x y). rewrite e0; simpl in *. destruct 1. apply H2; intuition. Qed. Hint Resolve remove_min_bst. Lemma remove_min_gt_tree : forall l x e r h, bst (Node l x e r h) -> gt_tree (remove_min l x e r)#2#1 (remove_min l x e r)#1. Proof. intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. inv bst; auto. inversion_clear H. intro; intro. rewrite e0 in *;simpl in *. generalize (IHp _x H0). generalize (remove_min_in ll lx ld lr _x m#1). rewrite e0; simpl; intros. rewrite (bal_in l' x d r y) in H. assert (In m#1 (Node ll lx ld lr _x)) by (rewrite H4; auto); clear H4. assert (X.lt m#1 x) by order. decompose [or] H; order. Qed. Hint Resolve remove_min_gt_tree. Lemma remove_min_find : forall l x e r h y, bst (Node l x e r h) -> find y (Node l x e r h) = match X.compare y (remove_min l x e r)#2#1 with | LT _ => None | EQ _ => Some (remove_min l x e r)#2#2 | GT _ => find y (remove_min l x e r)#1 end. Proof. intros. destruct X.compare. rewrite not_find_iff; auto. rewrite remove_min_in; red; destruct 1 as [H'|H']; [ order | ]. generalize (remove_min_gt_tree H H'); order. apply find_1; auto. rewrite remove_min_mapsto; auto. rewrite find_mapsto_equiv; eauto; intros. rewrite remove_min_mapsto; intuition; order. Qed. (** * Merging two trees *) Lemma merge_in : forall m1 m2 y, bst m1 -> bst m2 -> (In y (merge m1 m2) <-> In y m1 \/ In y m2). Proof. intros m1 m2; functional induction (merge m1 m2);intros; try factornode _x _x0 _x1 _x2 _x3 as m1. intuition_in. intuition_in. rewrite bal_in, remove_min_in, e1; simpl; intuition. Qed. Lemma merge_mapsto : forall m1 m2 y e, bst m1 -> bst m2 -> (MapsTo y e (merge m1 m2) <-> MapsTo y e m1 \/ MapsTo y e m2). Proof. intros m1 m2; functional induction (merge m1 m2); intros; try factornode _x _x0 _x1 _x2 _x3 as m1. intuition_in. intuition_in. rewrite bal_mapsto, remove_min_mapsto, e1; simpl; auto. unfold create. intuition; subst; auto. inversion_clear H1; intuition. Qed. Lemma merge_bst : forall m1 m2, bst m1 -> bst m2 -> (forall y1 y2 : key, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> bst (merge m1 m2). Proof. intros m1 m2; functional induction (merge m1 m2); intros; auto; try factornode _x _x0 _x1 _x2 _x3 as m1. apply bal_bst; auto. generalize (remove_min_bst H0); rewrite e1; simpl in *; auto. intro; intro. apply H1; auto. generalize (remove_min_in l2 x2 d2 r2 _x4 x); rewrite e1; simpl; intuition. generalize (remove_min_gt_tree H0); rewrite e1; simpl; auto. Qed. (** * Deletion *) Lemma remove_in : forall m x y, bst m -> (In y (remove x m) <-> ~ X.eq y x /\ In y m). Proof. intros m x; functional induction (remove x m); simpl; intros. intuition_in. (* LT *) inv bst; clear e0. rewrite bal_in; auto. generalize (IHt y0 H0); intuition; [ order | order | intuition_in ]. (* EQ *) inv bst; clear e0. rewrite merge_in; intuition; [ order | order | intuition_in ]. elim H4; eauto. (* GT *) inv bst; clear e0. rewrite bal_in; auto. generalize (IHt y0 H1); intuition; [ order | order | intuition_in ]. Qed. Lemma remove_bst : forall m x, bst m -> bst (remove x m). Proof. intros m x; functional induction (remove x m); simpl; intros. auto. (* LT *) inv bst. apply bal_bst; auto. intro; intro. rewrite (remove_in x y0 H0) in H; auto. destruct H; eauto. (* EQ *) inv bst. apply merge_bst; eauto. (* GT *) inv bst. apply bal_bst; auto. intro; intro. rewrite (remove_in x y0 H1) in H; auto. destruct H; eauto. Qed. Lemma remove_1 : forall m x y, bst m -> X.eq x y -> ~ In y (remove x m). Proof. intros; rewrite remove_in; intuition. Qed. Lemma remove_2 : forall m x y e, bst m -> ~X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m x y e; induction m; simpl; auto. destruct (X.compare x k); intros; inv bst; try rewrite bal_mapsto; unfold create; auto; try solve [inv MapsTo; auto]. rewrite merge_mapsto; auto. inv MapsTo; auto; order. Qed. Lemma remove_3 : forall m x y e, bst m -> MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m x y e; induction m; simpl; auto. destruct (X.compare x k); intros Bs; inv bst; try rewrite bal_mapsto; auto; unfold create. intros; inv MapsTo; auto. rewrite merge_mapsto; intuition. intros; inv MapsTo; auto. Qed. (** * join *) Lemma join_in : forall l x d r y, In y (join l x d r) <-> X.eq y x \/ In y l \/ In y r. Proof. join_tac. simpl. rewrite add_in; intuition_in. rewrite add_in; intuition_in. rewrite bal_in, Hlr; clear Hlr Hrl; intuition_in. rewrite bal_in, Hrl; clear Hlr Hrl; intuition_in. apply create_in. Qed. Lemma join_bst : forall l x d r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (join l x d r). Proof. join_tac; auto; try (simpl; auto; fail); inv bst; apply bal_bst; auto; clear Hrl Hlr; intro; intros; rewrite join_in in *. intuition; [ apply MX.lt_eq with x | ]; eauto. intuition; [ apply MX.eq_lt with x | ]; eauto. Qed. Hint Resolve join_bst. Lemma join_find : forall l x d r y, bst l -> bst r -> lt_tree x l -> gt_tree x r -> find y (join l x d r) = find y (create l x d r). Proof. join_tac; auto; inv bst; simpl (join (Leaf elt)); try (assert (X.lt lx x) by auto); try (assert (X.lt x rx) by auto); rewrite ?add_find, ?bal_find; auto. simpl; destruct X.compare; auto. rewrite not_find_iff; auto; intro; order. simpl; repeat (destruct X.compare; auto); try (order; fail). rewrite not_find_iff by auto; intro. assert (X.lt y x) by auto; order. simpl; rewrite Hlr; simpl; auto. repeat (destruct X.compare; auto); order. intros u Hu; rewrite join_in in Hu. destruct Hu as [Hu|[Hu|Hu]]; try generalize (H2 _ Hu); order. simpl; rewrite Hrl; simpl; auto. repeat (destruct X.compare; auto); order. intros u Hu; rewrite join_in in Hu. destruct Hu as [Hu|[Hu|Hu]]; order. Qed. (** * split *) Lemma split_in_1 : forall m x, bst m -> forall y, (In y (split x m)#l <-> In y m /\ X.lt y x). Proof. intros m x; functional induction (split x m); simpl; intros; inv bst; try clear e0. intuition_in. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. intuition_in; order. rewrite join_in. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. Qed. Lemma split_in_2 : forall m x, bst m -> forall y, (In y (split x m)#r <-> In y m /\ X.lt x y). Proof. intros m x; functional induction (split x m); subst; simpl; intros; inv bst; try clear e0. intuition_in. rewrite join_in. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. intuition_in; order. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. Qed. Lemma split_in_3 : forall m x, bst m -> (split x m)#o = find x m. Proof. intros m x; functional induction (split x m); subst; simpl; auto; intros; inv bst; try clear e0; destruct X.compare; try order; trivial; rewrite <- IHt, e1; auto. Qed. Lemma split_bst : forall m x, bst m -> bst (split x m)#l /\ bst (split x m)#r. Proof. intros m x; functional induction (split x m); subst; simpl; intros; inv bst; try clear e0; try rewrite e1 in *; simpl in *; intuition; apply join_bst; auto. intros y0. generalize (split_in_2 x H0 y0); rewrite e1; simpl; intuition. intros y0. generalize (split_in_1 x H1 y0); rewrite e1; simpl; intuition. Qed. Lemma split_lt_tree : forall m x, bst m -> lt_tree x (split x m)#l. Proof. intros m x B y Hy; rewrite split_in_1 in Hy; intuition. Qed. Lemma split_gt_tree : forall m x, bst m -> gt_tree x (split x m)#r. Proof. intros m x B y Hy; rewrite split_in_2 in Hy; intuition. Qed. Lemma split_find : forall m x y, bst m -> find y m = match X.compare y x with | LT _ => find y (split x m)#l | EQ _ => (split x m)#o | GT _ => find y (split x m)#r end. Proof. intros m x; functional induction (split x m); subst; simpl; intros; inv bst; try clear e0; try rewrite e1 in *; simpl in *; [ destruct X.compare; auto | .. ]; try match goal with E:split ?x ?t = _, B:bst ?t |- _ => generalize (split_in_1 x B)(split_in_2 x B)(split_bst x B); rewrite E; simpl; destruct 3 end. rewrite join_find, IHt; auto; clear IHt; simpl. repeat (destruct X.compare; auto); order. intro y1; rewrite H4; intuition. repeat (destruct X.compare; auto); order. rewrite join_find, IHt; auto; clear IHt; simpl. repeat (destruct X.compare; auto); order. intros y1; rewrite H; intuition. Qed. (** * Concatenation *) Lemma concat_in : forall m1 m2 y, In y (concat m1 m2) <-> In y m1 \/ In y m2. Proof. intros m1 m2; functional induction (concat m1 m2); intros; try factornode _x _x0 _x1 _x2 _x3 as m1. intuition_in. intuition_in. rewrite join_in, remove_min_in, e1; simpl; intuition. Qed. Lemma concat_bst : forall m1 m2, bst m1 -> bst m2 -> (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> bst (concat m1 m2). Proof. intros m1 m2; functional induction (concat m1 m2); intros; auto; try factornode _x _x0 _x1 _x2 _x3 as m1. apply join_bst; auto. change (bst (m2',xd)#1); rewrite <-e1; eauto. intros y Hy. apply H1; auto. rewrite remove_min_in, e1; simpl; auto. change (gt_tree (m2',xd)#2#1 (m2',xd)#1); rewrite <-e1; eauto. Qed. Hint Resolve concat_bst. Lemma concat_find : forall m1 m2 y, bst m1 -> bst m2 -> (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> find y (concat m1 m2) = match find y m2 with Some d => Some d | None => find y m1 end. Proof. intros m1 m2; functional induction (concat m1 m2); intros; auto; try factornode _x _x0 _x1 _x2 _x3 as m1. simpl; destruct (find y m2); auto. generalize (remove_min_find y H0)(remove_min_in l2 x2 d2 r2 _x4) (remove_min_bst H0)(remove_min_gt_tree H0); rewrite e1; simpl fst; simpl snd; intros. inv bst. rewrite H2, join_find; auto; clear H2. simpl; destruct X.compare; simpl; auto. destruct (find y m2'); auto. symmetry; rewrite not_find_iff; auto; intro. apply (MX.lt_not_gt l); apply H1; auto; rewrite H3; auto. intros z Hz; apply H1; auto; rewrite H3; auto. Qed. (** * Elements *) Notation eqk := (PX.eqk (elt:= elt)). Notation eqke := (PX.eqke (elt:= elt)). Notation ltk := (PX.ltk (elt:= elt)). Lemma elements_aux_mapsto : forall (s:t elt) acc x e, InA eqke (x,e) (elements_aux acc s) <-> MapsTo x e s \/ InA eqke (x,e) acc. Proof. induction s as [ | l Hl x e r Hr h ]; simpl; auto. intuition. inversion H0. intros. rewrite Hl. destruct (Hr acc x0 e0); clear Hl Hr. intuition; inversion_clear H3; intuition. destruct H0; simpl in *; subst; intuition. Qed. Lemma elements_mapsto : forall (s:t elt) x e, InA eqke (x,e) (elements s) <-> MapsTo x e s. Proof. intros; generalize (elements_aux_mapsto s nil x e); intuition. inversion_clear H0. Qed. Lemma elements_in : forall (s:t elt) x, L.PX.In x (elements s) <-> In x s. Proof. intros. unfold L.PX.In. rewrite <- In_alt; unfold In0. firstorder. exists x0. rewrite <- elements_mapsto; auto. exists x0. unfold L.PX.MapsTo; rewrite elements_mapsto; auto. Qed. Lemma elements_aux_sort : forall (s:t elt) acc, bst s -> sort ltk acc -> (forall x e y, InA eqke (x,e) acc -> In y s -> X.lt y x) -> sort ltk (elements_aux acc s). Proof. induction s as [ | l Hl y e r Hr h]; simpl; intuition. inv bst. apply Hl; auto. constructor. apply Hr; eauto. apply InA_InfA with (eqA:=eqke); auto with *. intros (y',e') H6. destruct (elements_aux_mapsto r acc y' e'); intuition. red; simpl; eauto. red; simpl; eauto. intros. inversion_clear H. destruct H7; simpl in *. order. destruct (elements_aux_mapsto r acc x e0); intuition eauto. Qed. Lemma elements_sort : forall s : t elt, bst s -> sort ltk (elements s). Proof. intros; unfold elements; apply elements_aux_sort; auto. intros; inversion H0. Qed. Hint Resolve elements_sort. Lemma elements_nodup : forall s : t elt, bst s -> NoDupA eqk (elements s). Proof. intros; apply PX.Sort_NoDupA; auto. Qed. Lemma elements_aux_cardinal : forall (m:t elt) acc, (length acc + cardinal m)%nat = length (elements_aux acc m). Proof. simple induction m; simpl; intuition. rewrite <- H; simpl. rewrite <- H0; omega. Qed. Lemma elements_cardinal : forall (m:t elt), cardinal m = length (elements m). Proof. exact (fun m => elements_aux_cardinal m nil). Qed. Lemma elements_app : forall (s:t elt) acc, elements_aux acc s = elements s ++ acc. Proof. induction s; simpl; intros; auto. rewrite IHs1, IHs2. unfold elements; simpl. rewrite 2 IHs1, IHs2, <- !app_nil_end, !app_ass; auto. Qed. Lemma elements_node : forall (t1 t2:t elt) x e z l, elements t1 ++ (x,e) :: elements t2 ++ l = elements (Node t1 x e t2 z) ++ l. Proof. unfold elements; simpl; intros. rewrite !elements_app, <- !app_nil_end, !app_ass; auto. Qed. (** * Fold *) Definition fold' (A : Type) (f : key -> elt -> A -> A)(s : t elt) := L.fold f (elements s). Lemma fold_equiv_aux : forall (A : Type) (s : t elt) (f : key -> elt -> A -> A) (a : A) acc, L.fold f (elements_aux acc s) a = L.fold f acc (fold f s a). Proof. simple induction s. simpl; intuition. simpl; intros. rewrite H. simpl. apply H0. Qed. Lemma fold_equiv : forall (A : Type) (s : t elt) (f : key -> elt -> A -> A) (a : A), fold f s a = fold' f s a. Proof. unfold fold', elements. simple induction s; simpl; auto; intros. rewrite fold_equiv_aux. rewrite H0. simpl; auto. Qed. Lemma fold_1 : forall (s:t elt)(Hs:bst s)(A : Type)(i:A)(f : key -> elt -> A -> A), fold f s i = fold_left (fun a p => f p#1 p#2 a) (elements s) i. Proof. intros. rewrite fold_equiv. unfold fold'. rewrite L.fold_1. unfold L.elements; auto. Qed. (** * Comparison *) (** [flatten_e e] returns the list of elements of the enumeration [e] i.e. the list of elements actually compared *) Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with | End => nil | More x e t r => (x,e) :: elements t ++ flatten_e r end. Lemma flatten_e_elements : forall (l:t elt) r x d z e, elements l ++ flatten_e (More x d r e) = elements (Node l x d r z) ++ flatten_e e. Proof. intros; simpl; apply elements_node. Qed. Lemma cons_1 : forall (s:t elt) e, flatten_e (cons s e) = elements s ++ flatten_e e. Proof. induction s; simpl; auto; intros. rewrite IHs1; apply flatten_e_elements; auto. Qed. (** Proof of correction for the comparison *) Variable cmp : elt->elt->bool. Definition IfEq b l1 l2 := L.equal cmp l1 l2 = b. Lemma cons_IfEq : forall b x1 x2 d1 d2 l1 l2, X.eq x1 x2 -> cmp d1 d2 = true -> IfEq b l1 l2 -> IfEq b ((x1,d1)::l1) ((x2,d2)::l2). Proof. unfold IfEq; destruct b; simpl; intros; destruct X.compare; simpl; try rewrite H0; auto; order. Qed. Lemma equal_end_IfEq : forall e2, IfEq (equal_end e2) nil (flatten_e e2). Proof. destruct e2; red; auto. Qed. Lemma equal_more_IfEq : forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l, IfEq (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> IfEq (equal_more cmp x1 d1 cont (More x2 d2 r2 e2)) ((x1,d1)::l) (flatten_e (More x2 d2 r2 e2)). Proof. unfold IfEq; simpl; intros; destruct X.compare; simpl; auto. rewrite <-andb_lazy_alt; f_equal; auto. Qed. Lemma equal_cont_IfEq : forall m1 cont e2 l, (forall e, IfEq (cont e) l (flatten_e e)) -> IfEq (equal_cont cmp m1 cont e2) (elements m1 ++ l) (flatten_e e2). Proof. induction m1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; simpl; intros; auto. rewrite <- elements_node; simpl. apply Hl1; auto. clear e2; intros [|x2 d2 r2 e2]. simpl; red; auto. apply equal_more_IfEq. rewrite <- cons_1; auto. Qed. Lemma equal_IfEq : forall (m1 m2:t elt), IfEq (equal cmp m1 m2) (elements m1) (elements m2). Proof. intros; unfold equal. rewrite (app_nil_end (elements m1)). replace (elements m2) with (flatten_e (cons m2 (End _))) by (rewrite cons_1; simpl; rewrite <-app_nil_end; auto). apply equal_cont_IfEq. intros. apply equal_end_IfEq; auto. Qed. Definition Equivb m m' := (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). Lemma Equivb_elements : forall s s', Equivb s s' <-> L.Equivb cmp (elements s) (elements s'). Proof. unfold Equivb, L.Equivb; split; split; intros. do 2 rewrite elements_in; firstorder. destruct H. apply (H2 k); rewrite <- elements_mapsto; auto. do 2 rewrite <- elements_in; firstorder. destruct H. apply (H2 k); unfold L.PX.MapsTo; rewrite elements_mapsto; auto. Qed. Lemma equal_Equivb : forall (s s': t elt), bst s -> bst s' -> (equal cmp s s' = true <-> Equivb s s'). Proof. intros s s' B B'. rewrite Equivb_elements, <- equal_IfEq. split; [apply L.equal_2|apply L.equal_1]; auto. Qed. End Elt. Section Map. Variable elt elt' : Type. Variable f : elt -> elt'. Lemma map_1 : forall (m: t elt)(x:key)(e:elt), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. induction m; simpl; inversion_clear 1; auto. Qed. Lemma map_2 : forall (m: t elt)(x:key), In x (map f m) -> In x m. Proof. induction m; simpl; inversion_clear 1; auto. Qed. Lemma map_bst : forall m, bst m -> bst (map f m). Proof. induction m; simpl; auto. inversion_clear 1; constructor; auto; red; auto using map_2. Qed. End Map. Section Mapi. Variable elt elt' : Type. Variable f : key -> elt -> elt'. Lemma mapi_1 : forall (m: tree elt)(x:key)(e:elt), MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. induction m; simpl; inversion_clear 1; auto. exists k; auto. destruct (IHm1 _ _ H0). exists x0; intuition. destruct (IHm2 _ _ H0). exists x0; intuition. Qed. Lemma mapi_2 : forall (m: t elt)(x:key), In x (mapi f m) -> In x m. Proof. induction m; simpl; inversion_clear 1; auto. Qed. Lemma mapi_bst : forall m, bst m -> bst (mapi f m). Proof. induction m; simpl; auto. inversion_clear 1; constructor; auto; red; auto using mapi_2. Qed. End Mapi. Section Map_option. Variable elt elt' : Type. Variable f : key -> elt -> option elt'. Hypothesis f_compat : forall x x' d, X.eq x x' -> f x d = f x' d. Lemma map_option_2 : forall (m:t elt)(x:key), In x (map_option f m) -> exists d, MapsTo x d m /\ f x d <> None. Proof. intros m; functional induction (map_option f m); simpl; auto; intros. inversion H. rewrite join_in in H; destruct H as [H|[H|H]]. exists d; split; auto; rewrite (f_compat d H), e0; discriminate. destruct (IHt _ H) as (d0 & ? & ?); exists d0; auto. destruct (IHt0 _ H) as (d0 & ? & ?); exists d0; auto. rewrite concat_in in H; destruct H as [H|H]. destruct (IHt _ H) as (d0 & ? & ?); exists d0; auto. destruct (IHt0 _ H) as (d0 & ? & ?); exists d0; auto. Qed. Lemma map_option_bst : forall m, bst m -> bst (map_option f m). Proof. intros m; functional induction (map_option f m); simpl; auto; intros; inv bst. apply join_bst; auto; intros y H; destruct (map_option_2 H) as (d0 & ? & ?); eauto using MapsTo_In. apply concat_bst; auto; intros y y' H H'. destruct (map_option_2 H) as (d0 & ? & ?). destruct (map_option_2 H') as (d0' & ? & ?). eapply X.lt_trans with x; eauto using MapsTo_In. Qed. Hint Resolve map_option_bst. Ltac nonify e := replace e with (@None elt) by (symmetry; rewrite not_find_iff; auto; intro; order). Lemma map_option_find : forall (m:t elt)(x:key), bst m -> find x (map_option f m) = match (find x m) with Some d => f x d | None => None end. Proof. intros m; functional induction (map_option f m); simpl; auto; intros; inv bst; rewrite join_find || rewrite concat_find; auto; simpl; try destruct X.compare; simpl; auto. rewrite (f_compat d e); auto. intros y H; destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In. intros y H; destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In. rewrite <- IHt, IHt0; auto; nonify (find x0 r); auto. rewrite IHt, IHt0; auto; nonify (find x0 r); nonify (find x0 l); auto. rewrite (f_compat d e); auto. rewrite <- IHt0, IHt; auto; nonify (find x0 l); auto. destruct (find x0 (map_option f r)); auto. intros y y' H H'. destruct (map_option_2 H) as (? & ? & ?). destruct (map_option_2 H') as (? & ? & ?). eapply X.lt_trans with x; eauto using MapsTo_In. Qed. End Map_option. Section Map2_opt. Variable elt elt' elt'' : Type. Variable f0 : key -> option elt -> option elt' -> option elt''. Variable f : key -> elt -> option elt' -> option elt''. Variable mapl : t elt -> t elt''. Variable mapr : t elt' -> t elt''. Hypothesis f0_f : forall x d o, f x d o = f0 x (Some d) o. Hypothesis mapl_bst : forall m, bst m -> bst (mapl m). Hypothesis mapr_bst : forall m', bst m' -> bst (mapr m'). Hypothesis mapl_f0 : forall x m, bst m -> find x (mapl m) = match find x m with Some d => f0 x (Some d) None | None => None end. Hypothesis mapr_f0 : forall x m', bst m' -> find x (mapr m') = match find x m' with Some d' => f0 x None (Some d') | None => None end. Hypothesis f0_compat : forall x x' o o', X.eq x x' -> f0 x o o' = f0 x' o o'. Notation map2_opt := (map2_opt f mapl mapr). Lemma map2_opt_2 : forall m m' y, bst m -> bst m' -> In y (map2_opt m m') -> In y m \/ In y m'. Proof. intros m m'; functional induction (map2_opt m m'); intros; auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; try (generalize (split_in_1 x1 H0 y)(split_in_2 x1 H0 y) (split_bst x1 H0); rewrite e1; simpl; destruct 3; inv bst). right; apply find_in. generalize (in_find (mapr_bst H0) H1); rewrite mapr_f0; auto. destruct (find y m2); auto; intros; discriminate. factornode l1 x1 d1 r1 _x as m1. left; apply find_in. generalize (in_find (mapl_bst H) H1); rewrite mapl_f0; auto. destruct (find y m1); auto; intros; discriminate. rewrite join_in in H1; destruct H1 as [H'|[H'|H']]; auto. destruct (IHt1 y H6 H4 H'); intuition. destruct (IHt0 y H7 H5 H'); intuition. rewrite concat_in in H1; destruct H1 as [H'|H']; auto. destruct (IHt1 y H6 H4 H'); intuition. destruct (IHt0 y H7 H5 H'); intuition. Qed. Lemma map2_opt_bst : forall m m', bst m -> bst m' -> bst (map2_opt m m'). Proof. intros m m'; functional induction (map2_opt m m'); intros; auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; inv bst; generalize (split_in_1 x1 H0)(split_in_2 x1 H0)(split_bst x1 H0); rewrite e1; simpl in *; destruct 3. apply join_bst; auto. intros y Hy; specialize H with y. destruct (map2_opt_2 H1 H6 Hy); intuition. intros y Hy; specialize H5 with y. destruct (map2_opt_2 H2 H7 Hy); intuition. apply concat_bst; auto. intros y y' Hy Hy'; specialize H with y; specialize H5 with y'. apply X.lt_trans with x1. destruct (map2_opt_2 H1 H6 Hy); intuition. destruct (map2_opt_2 H2 H7 Hy'); intuition. Qed. Hint Resolve map2_opt_bst. Ltac map2_aux := match goal with | H : In ?x _ \/ In ?x ?m, H' : find ?x ?m = find ?x ?m', B:bst ?m, B':bst ?m' |- _ => destruct H; [ intuition_in; order | rewrite <-(find_in_equiv B B' H'); auto ] end. Ltac nonify t := match t with (find ?y (map2_opt ?m ?m')) => replace t with (@None elt''); [ | symmetry; rewrite not_find_iff; auto; intro; destruct (@map2_opt_2 m m' y); auto; order ] end. Lemma map2_opt_1 : forall m m' y, bst m -> bst m' -> In y m \/ In y m' -> find y (map2_opt m m') = f0 y (find y m) (find y m'). Proof. intros m m'; functional induction (map2_opt m m'); intros; auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; try (generalize (split_in_1 x1 H0)(split_in_2 x1 H0) (split_in_3 x1 H0)(split_bst x1 H0)(split_find x1 y H0) (split_lt_tree (x:=x1) H0)(split_gt_tree (x:=x1) H0); rewrite e1; simpl in *; destruct 4; intros; inv bst; subst o2; rewrite H7, ?join_find, ?concat_find; auto). simpl; destruct H1; [ inversion_clear H1 | ]. rewrite mapr_f0; auto. generalize (in_find H0 H1); destruct (find y m2); intuition. factornode l1 x1 d1 r1 _x as m1. destruct H1; [ | inversion_clear H1 ]. rewrite mapl_f0; auto. generalize (in_find H H1); destruct (find y m1); intuition. simpl; destruct X.compare; auto. apply IHt1; auto; map2_aux. rewrite (@f0_compat y x1), <- f0_f; auto. apply IHt0; auto; map2_aux. intros z Hz; destruct (@map2_opt_2 l1 l2' z); auto. intros z Hz; destruct (@map2_opt_2 r1 r2' z); auto. destruct X.compare. nonify (find y (map2_opt r1 r2')). apply IHt1; auto; map2_aux. nonify (find y (map2_opt r1 r2')). nonify (find y (map2_opt l1 l2')). rewrite (@f0_compat y x1), <- f0_f; auto. nonify (find y (map2_opt l1 l2')). rewrite IHt0; auto; [ | map2_aux ]. destruct (f0 y (find y r1) (find y r2')); auto. intros y1 y2 Hy1 Hy2; apply X.lt_trans with x1. destruct (@map2_opt_2 l1 l2' y1); auto. destruct (@map2_opt_2 r1 r2' y2); auto. Qed. End Map2_opt. Section Map2. Variable elt elt' elt'' : Type. Variable f : option elt -> option elt' -> option elt''. Lemma map2_bst : forall m m', bst m -> bst m' -> bst (map2 f m m'). Proof. unfold map2; intros. apply map2_opt_bst with (fun _ => f); auto using map_option_bst; intros; rewrite map_option_find; auto. Qed. Lemma map2_1 : forall m m' y, bst m -> bst m' -> In y m \/ In y m' -> find y (map2 f m m') = f (find y m) (find y m'). Proof. unfold map2; intros. rewrite (map2_opt_1 (f0:=fun _ => f)); auto using map_option_bst; intros; rewrite map_option_find; auto. Qed. Lemma map2_2 : forall m m' y, bst m -> bst m' -> In y (map2 f m m') -> In y m \/ In y m'. Proof. unfold map2; intros. eapply map2_opt_2 with (f0:=fun _ => f); try eassumption; trivial; intros. apply map_option_bst; auto. apply map_option_bst; auto. rewrite map_option_find; auto. rewrite map_option_find; auto. Qed. End Map2. End Proofs. End Raw. (** * Encapsulation Now, in order to really provide a functor implementing [S], we need to encapsulate everything into a type of balanced binary search trees. *) Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Module E := X. Module Raw := Raw I X. Import Raw.Proofs. Record bst (elt:Type) := Bst {this :> Raw.tree elt; is_bst : Raw.bst this}. Definition t := bst. Definition key := E.t. Section Elt. Variable elt elt' elt'': Type. Implicit Types m : t elt. Implicit Types x y : key. Implicit Types e : elt. Definition empty : t elt := Bst (empty_bst elt). Definition is_empty m : bool := Raw.is_empty m.(this). Definition add x e m : t elt := Bst (add_bst x e m.(is_bst)). Definition remove x m : t elt := Bst (remove_bst x m.(is_bst)). Definition mem x m : bool := Raw.mem x m.(this). Definition find x m : option elt := Raw.find x m.(this). Definition map f m : t elt' := Bst (map_bst f m.(is_bst)). Definition mapi (f:key->elt->elt') m : t elt' := Bst (mapi_bst f m.(is_bst)). Definition map2 f m (m':t elt') : t elt'' := Bst (map2_bst f m.(is_bst) m'.(is_bst)). Definition elements m : list (key*elt) := Raw.elements m.(this). Definition cardinal m := Raw.cardinal m.(this). Definition fold (A:Type) (f:key->elt->A->A) m i := Raw.fold (A:=A) f m.(this) i. Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this). Definition MapsTo x e m : Prop := Raw.MapsTo x e m.(this). Definition In x m : Prop := Raw.In0 x m.(this). Definition Empty m : Prop := Empty m.(this). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt. Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt. Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. Proof. intros m; exact (@MapsTo_1 _ m.(this)). Qed. Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto. apply m.(is_bst). Qed. Lemma mem_2 : forall m x, mem x m = true -> In x m. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto. Qed. Lemma empty_1 : Empty empty. Proof. exact (@empty_1 elt). Qed. Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. Proof. intros m; exact (@is_empty_1 _ m.(this)). Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. Proof. intros m; exact (@is_empty_2 _ m.(this)). Qed. Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). Proof. intros m x y e; exact (@add_1 elt _ x y e). Qed. Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. intros m x y e e'; exact (@add_2 elt _ x y e e'). Qed. Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. Proof. intros m x y e e'; exact (@add_3 elt _ x y e e'). Qed. Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). Proof. unfold In, remove; intros m x y; rewrite In_alt; simpl; apply remove_1; auto. apply m.(is_bst). Qed. Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m x y e; exact (@remove_2 elt _ x y e m.(is_bst)). Qed. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed. Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. Proof. intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m; exact (@find_2 elt m.(this)). Qed. Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed. Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). Proof. intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto. Qed. Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto. Qed. Lemma elements_3 : forall m, sort lt_key (elements m). Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed. Lemma elements_3w : forall m, NoDupA eq_key (elements m). Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). Proof. intro m; exact (@elements_cardinal elt m.(this)). Qed. Definition Equal m m' := forall y, find y m = find y m'. Definition Equiv (eq_elt:elt->elt->Prop) m m' := (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb cmp := Equiv (Cmp cmp). Lemma Equivb_Equivb : forall cmp m m', Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. Proof. intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. generalize (H0 k); do 2 rewrite <- In_alt; intuition. generalize (H0 k); do 2 rewrite <- In_alt; intuition. Qed. Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. Proof. unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; intros; simpl in *; rewrite equal_Equivb; auto. Qed. Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; intros; simpl in *; rewrite <-equal_Equivb; auto. Qed. End Elt. Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed. Lemma map_2 : forall (elt elt':Type)(m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl. apply map_2; auto. Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. intros elt elt' m x f; unfold In in *; do 2 rewrite In_alt; simpl; apply mapi_2; auto. Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x m \/ In x m' -> find x (map2 f m m') = f (find x m) (find x m'). Proof. unfold find, map2, In; intros elt elt' elt'' m m' x f. do 2 rewrite In_alt; intros; simpl; apply map2_1; auto. apply m.(is_bst). apply m'.(is_bst). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Proof. unfold In, map2; intros elt elt' elt'' m m' x f. do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto. apply m.(is_bst). apply m'.(is_bst). Qed. End IntMake. Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Sord with Module Data := D with Module MapS.E := X. Module Data := D. Module Import MapS := IntMake(I)(X). Module LO := FMapList.Make_ord(X)(D). Module R := Raw. Module P := Raw.Proofs. Definition t := MapS.t D.t. Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. (** One step of comparison of elements *) Definition compare_more x1 d1 (cont:R.enumeration D.t -> comparison) e2 := match e2 with | R.End => Gt | R.More x2 d2 r2 e2 => match X.compare x1 x2 with | EQ _ => match D.compare d1 d2 with | EQ _ => cont (R.cons r2 e2) | LT _ => Lt | GT _ => Gt end | LT _ => Lt | GT _ => Gt end end. (** Comparison of left tree, middle element, then right tree *) Fixpoint compare_cont s1 (cont:R.enumeration D.t -> comparison) e2 := match s1 with | R.Leaf => cont e2 | R.Node l1 x1 d1 r1 _ => compare_cont l1 (compare_more x1 d1 (compare_cont r1 cont)) e2 end. (** Initial continuation *) Definition compare_end (e2:R.enumeration D.t) := match e2 with R.End => Eq | _ => Lt end. (** The complete comparison *) Definition compare_pure s1 s2 := compare_cont s1 compare_end (R.cons s2 (Raw.End _)). (** Correctness of this comparison *) Definition Cmp c := match c with | Eq => LO.eq_list | Lt => LO.lt_list | Gt => (fun l1 l2 => LO.lt_list l2 l1) end. Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, X.eq x1 x2 -> D.eq d1 d2 -> Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). Proof. destruct c; simpl; intros; P.MX.elim_comp; auto. Qed. Hint Resolve cons_Cmp. Lemma compare_end_Cmp : forall e2, Cmp (compare_end e2) nil (P.flatten_e e2). Proof. destruct e2; simpl; auto. Qed. Lemma compare_more_Cmp : forall x1 d1 cont x2 d2 r2 e2 l, Cmp (cont (R.cons r2 e2)) l (R.elements r2 ++ P.flatten_e e2) -> Cmp (compare_more x1 d1 cont (R.More x2 d2 r2 e2)) ((x1,d1)::l) (P.flatten_e (R.More x2 d2 r2 e2)). Proof. simpl; intros; destruct X.compare; simpl; try destruct D.compare; simpl; auto; P.MX.elim_comp; auto. Qed. Lemma compare_cont_Cmp : forall s1 cont e2 l, (forall e, Cmp (cont e) l (P.flatten_e e)) -> Cmp (compare_cont s1 cont e2) (R.elements s1 ++ l) (P.flatten_e e2). Proof. induction s1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; simpl; intros; auto. rewrite <- P.elements_node; simpl. apply Hl1; auto. clear e2. intros [|x2 d2 r2 e2]. simpl; auto. apply compare_more_Cmp. rewrite <- P.cons_1; auto. Qed. Lemma compare_Cmp : forall s1 s2, Cmp (compare_pure s1 s2) (R.elements s1) (R.elements s2). Proof. intros; unfold compare_pure. rewrite (app_nil_end (R.elements s1)). replace (R.elements s2) with (P.flatten_e (R.cons s2 (R.End _))) by (rewrite P.cons_1; simpl; rewrite <- app_nil_end; auto). auto using compare_cont_Cmp, compare_end_Cmp. Qed. (** The dependent-style [compare] *) Definition eq (m1 m2 : t) := LO.eq_list (elements m1) (elements m2). Definition lt (m1 m2 : t) := LO.lt_list (elements m1) (elements m2). Definition compare (s s':t) : Compare lt eq s s'. Proof. destruct s as (s,b), s' as (s',b'). generalize (compare_Cmp s s'). destruct compare_pure; intros; [apply EQ|apply LT|apply GT]; red; auto. Defined. (* Proofs about [eq] and [lt] *) Definition selements (m1 : t) := LO.MapS.Build_slist (P.elements_sort m1.(is_bst)). Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2). Definition slt (m1 m2 : t) := LO.lt (selements m1) (selements m2). Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2. Proof. unfold eq, seq, selements, elements, LO.eq; intuition. Qed. Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2. Proof. unfold lt, slt, selements, elements, LO.lt; intuition. Qed. Lemma eq_1 : forall (m m' : t), Equivb cmp m m' -> eq m m'. Proof. intros m m'. rewrite eq_seq; unfold seq. rewrite Equivb_Equivb. rewrite P.Equivb_elements. auto using LO.eq_1. Qed. Lemma eq_2 : forall m m', eq m m' -> Equivb cmp m m'. Proof. intros m m'. rewrite eq_seq; unfold seq. rewrite Equivb_Equivb. rewrite P.Equivb_elements. intros. generalize (LO.eq_2 H). auto. Qed. Lemma eq_refl : forall m : t, eq m m. Proof. intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl. Qed. Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. Proof. intros m1 m2; rewrite 2 eq_seq; unfold seq; intros; apply LO.eq_sym; auto. Qed. Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. Proof. intros m1 m2 M3; rewrite 3 eq_seq; unfold seq. intros; eapply LO.eq_trans; eauto. Qed. Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. Proof. intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; intros; eapply LO.lt_trans; eauto. Qed. Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. Proof. intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; intros; apply LO.lt_not_eq; auto. Qed. End IntMake_ord. (* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *) Module Make (X: OrderedType) <: S with Module E := X :=IntMake(Z_as_Int)(X). Module Make_ord (X: OrderedType)(D: OrderedType) <: Sord with Module Data := D with Module MapS.E := X :=IntMake_ord(Z_as_Int)(X)(D). coq-8.4pl4/theories/FSets/FSetProperties.v0000644000175000017500000010440212326224777017607 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constructor; congruence. (** First, a functor for Weak Sets in functorial version. *) Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Module Import Dec := WDecide_fun E M. Module Import FM := Dec.F (* FSetFacts.WFacts_fun E M *). Import M. Lemma In_dec : forall x s, {In x s} + {~ In x s}. Proof. intros; generalize (mem_iff s x); case (mem x s); intuition. Qed. Definition Add x s s' := forall y, In y s' <-> E.eq x y \/ In y s. Lemma Add_Equal : forall x s s', Add x s s' <-> s' [=] add x s. Proof. unfold Add. split; intros. red; intros. rewrite H; clear H. fsetdec. fsetdec. Qed. Ltac expAdd := repeat rewrite Add_Equal. Section BasicProperties. Variable s s' s'' s1 s2 s3 : t. Variable x x' : elt. Lemma equal_refl : s[=]s. Proof. fsetdec. Qed. Lemma equal_sym : s[=]s' -> s'[=]s. Proof. fsetdec. Qed. Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3. Proof. fsetdec. Qed. Lemma subset_refl : s[<=]s. Proof. fsetdec. Qed. Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3. Proof. fsetdec. Qed. Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'. Proof. fsetdec. Qed. Lemma subset_equal : s[=]s' -> s[<=]s'. Proof. fsetdec. Qed. Lemma subset_empty : empty[<=]s. Proof. fsetdec. Qed. Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2. Proof. fsetdec. Qed. Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3. Proof. fsetdec. Qed. Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2. Proof. fsetdec. Qed. Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2. Proof. fsetdec. Qed. Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2. Proof. fsetdec. Qed. Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1. Proof. intuition fsetdec. Qed. Lemma empty_is_empty_1 : Empty s -> s[=]empty. Proof. fsetdec. Qed. Lemma empty_is_empty_2 : s[=]empty -> Empty s. Proof. fsetdec. Qed. Lemma add_equal : In x s -> add x s [=] s. Proof. fsetdec. Qed. Lemma add_add : add x (add x' s) [=] add x' (add x s). Proof. fsetdec. Qed. Lemma remove_equal : ~ In x s -> remove x s [=] s. Proof. fsetdec. Qed. Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'. Proof. fsetdec. Qed. Lemma add_remove : In x s -> add x (remove x s) [=] s. Proof. fsetdec. Qed. Lemma remove_add : ~In x s -> remove x (add x s) [=] s. Proof. fsetdec. Qed. Lemma singleton_equal_add : singleton x [=] add x empty. Proof. fsetdec. Qed. Lemma remove_singleton_empty : In x s -> remove x s [=] empty -> singleton x [=] s. Proof. fsetdec. Qed. Lemma union_sym : union s s' [=] union s' s. Proof. fsetdec. Qed. Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'. Proof. fsetdec. Qed. Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''. Proof. fsetdec. Qed. Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''. Proof. fsetdec. Qed. Lemma union_assoc : union (union s s') s'' [=] union s (union s' s''). Proof. fsetdec. Qed. Lemma add_union_singleton : add x s [=] union (singleton x) s. Proof. fsetdec. Qed. Lemma union_add : union (add x s) s' [=] add x (union s s'). Proof. fsetdec. Qed. Lemma union_remove_add_1 : union (remove x s) (add x s') [=] union (add x s) (remove x s'). Proof. fsetdec. Qed. Lemma union_remove_add_2 : In x s -> union (remove x s) (add x s') [=] union s s'. Proof. fsetdec. Qed. Lemma union_subset_1 : s [<=] union s s'. Proof. fsetdec. Qed. Lemma union_subset_2 : s' [<=] union s s'. Proof. fsetdec. Qed. Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''. Proof. fsetdec. Qed. Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''. Proof. fsetdec. Qed. Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'. Proof. fsetdec. Qed. Lemma empty_union_1 : Empty s -> union s s' [=] s'. Proof. fsetdec. Qed. Lemma empty_union_2 : Empty s -> union s' s [=] s'. Proof. fsetdec. Qed. Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). Proof. fsetdec. Qed. Lemma inter_sym : inter s s' [=] inter s' s. Proof. fsetdec. Qed. Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s. Proof. fsetdec. Qed. Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''. Proof. fsetdec. Qed. Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''. Proof. fsetdec. Qed. Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s''). Proof. fsetdec. Qed. Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s''). Proof. fsetdec. Qed. Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s''). Proof. fsetdec. Qed. Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s'). Proof. fsetdec. Qed. Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'. Proof. fsetdec. Qed. Lemma empty_inter_1 : Empty s -> Empty (inter s s'). Proof. fsetdec. Qed. Lemma empty_inter_2 : Empty s' -> Empty (inter s s'). Proof. fsetdec. Qed. Lemma inter_subset_1 : inter s s' [<=] s. Proof. fsetdec. Qed. Lemma inter_subset_2 : inter s s' [<=] s'. Proof. fsetdec. Qed. Lemma inter_subset_3 : s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'. Proof. fsetdec. Qed. Lemma empty_diff_1 : Empty s -> Empty (diff s s'). Proof. fsetdec. Qed. Lemma empty_diff_2 : Empty s -> diff s' s [=] s'. Proof. fsetdec. Qed. Lemma diff_subset : diff s s' [<=] s. Proof. fsetdec. Qed. Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty. Proof. fsetdec. Qed. Lemma remove_diff_singleton : remove x s [=] diff s (singleton x). Proof. fsetdec. Qed. Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. Proof. fsetdec. Qed. Lemma diff_inter_all : union (diff s s') (inter s s') [=] s. Proof. fsetdec. Qed. Lemma Add_add : Add x s (add x s). Proof. expAdd; fsetdec. Qed. Lemma Add_remove : In x s -> Add x (remove x s) s. Proof. expAdd; fsetdec. Qed. Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s''). Proof. expAdd; fsetdec. Qed. Lemma inter_Add : In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s''). Proof. expAdd; fsetdec. Qed. Lemma union_Equal : In x s'' -> Add x s s' -> union s s'' [=] union s' s''. Proof. expAdd; fsetdec. Qed. Lemma inter_Add_2 : ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''. Proof. expAdd; fsetdec. Qed. End BasicProperties. Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set. Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal remove_equal singleton_equal_add union_subset_equal union_equal_1 union_equal_2 union_assoc add_union_singleton union_add union_subset_1 union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2 inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2 empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove Equal_remove add_add : set. (** * Properties of elements *) Lemma elements_Empty : forall s, Empty s <-> elements s = nil. Proof. intros. unfold Empty. split; intros. assert (forall a, ~ List.In a (elements s)). red; intros. apply (H a). rewrite elements_iff. rewrite InA_alt; exists a; auto. destruct (elements s); auto. elim (H0 e); simpl; auto. red; intros. rewrite elements_iff in H0. rewrite InA_alt in H0; destruct H0. rewrite H in H0; destruct H0 as (_,H0); inversion H0. Qed. Lemma elements_empty : elements empty = nil. Proof. rewrite <-elements_Empty; auto with set. Qed. (** * Conversions between lists and sets *) Definition of_list (l : list elt) := List.fold_right add empty l. Definition to_list := elements. Lemma of_list_1 : forall l x, In x (of_list l) <-> InA E.eq x l. Proof. induction l; simpl; intro x. rewrite empty_iff, InA_nil. intuition. rewrite add_iff, InA_cons, IHl. intuition. Qed. Lemma of_list_2 : forall l, equivlistA E.eq (to_list (of_list l)) l. Proof. unfold to_list; red; intros. rewrite <- elements_iff; apply of_list_1. Qed. Lemma of_list_3 : forall s, of_list (to_list s) [=] s. Proof. unfold to_list; red; intros. rewrite of_list_1; symmetry; apply elements_iff. Qed. (** * Fold *) Section Fold. (** Alternative specification via [fold_right] *) Lemma fold_spec_right (s:t)(A:Type)(i:A)(f : elt -> A -> A) : fold f s i = List.fold_right f i (rev (elements s)). Proof. rewrite fold_1. symmetry. apply fold_left_rev_right. Qed. Notation NoDup := (NoDupA E.eq). Notation InA := (InA E.eq). (** ** Induction principles for fold (contributed by S. Lescuyer) *) (** In the following lemma, the step hypothesis is deliberately restricted to the precise set s we are considering. *) Theorem fold_rec : forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), (forall s', Empty s' -> P s' i) -> (forall x a s' s'', In x s -> ~In x s' -> Add x s' s'' -> P s' a -> P s'' (f x a)) -> P s (fold f s i). Proof. intros A P f i s Pempty Pstep. rewrite fold_spec_right. set (l:=rev (elements s)). assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' -> P s' a -> P s'' (f x a)). intros; eapply Pstep; eauto. rewrite elements_iff, <- InA_rev; auto with *. assert (Hdup : NoDup l) by (unfold l; eauto using elements_3w, NoDupA_rev with *). assert (Hsame : forall x, In x s <-> InA x l) by (unfold l; intros; rewrite elements_iff, InA_rev; intuition). clear Pstep; clearbody l; revert s Hsame; induction l. (* empty *) intros s Hsame; simpl. apply Pempty. intro x. rewrite Hsame, InA_nil; intuition. (* step *) intros s Hsame; simpl. apply Pstep' with (of_list l); auto. inversion_clear Hdup; rewrite of_list_1; auto. red. intros. rewrite Hsame, of_list_1, InA_cons; intuition. apply IHl. intros; eapply Pstep'; eauto. inversion_clear Hdup; auto. exact (of_list_1 l). Qed. (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this case, [P] must be compatible with equality of sets *) Theorem fold_rec_bis : forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), (forall s s' a, s[=]s' -> P s a -> P s' a) -> (P empty i) -> (forall x a s', In x s -> ~In x s' -> P s' a -> P (add x s') (f x a)) -> P s (fold f s i). Proof. intros A P f i s Pmorphism Pempty Pstep. apply fold_rec; intros. apply Pmorphism with empty; auto with set. rewrite Add_Equal in H1; auto with set. apply Pmorphism with (add x s'); auto with set. Qed. Lemma fold_rec_nodep : forall (A:Type)(P : A -> Type)(f : elt -> A -> A)(i:A)(s:t), P i -> (forall x a, In x s -> P a -> P (f x a)) -> P (fold f s i). Proof. intros; apply fold_rec_bis with (P:=fun _ => P); auto. Qed. (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : the step hypothesis must here be applicable to any [x]. At the same time, it looks more like an induction principle, and hence can be easier to use. *) Lemma fold_rec_weak : forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A), (forall s s' a, s[=]s' -> P s a -> P s' a) -> P empty i -> (forall x a s, ~In x s -> P s a -> P (add x s) (f x a)) -> forall s, P s (fold f s i). Proof. intros; apply fold_rec_bis; auto. Qed. Lemma fold_rel : forall (A B:Type)(R : A -> B -> Type) (f : elt -> A -> A)(g : elt -> B -> B)(i : A)(j : B)(s : t), R i j -> (forall x a b, In x s -> R a b -> R (f x a) (g x b)) -> R (fold f s i) (fold g s j). Proof. intros A B R f g i j s Rempty Rstep. rewrite 2 fold_spec_right. set (l:=rev (elements s)). assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto with *). clearbody l; clear Rstep s. induction l; simpl; auto. Qed. (** From the induction principle on [fold], we can deduce some general induction principles on sets. *) Lemma set_induction : forall P : t -> Type, (forall s, Empty s -> P s) -> (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') -> forall s, P s. Proof. intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. Qed. Lemma set_induction_bis : forall P : t -> Type, (forall s s', s [=] s' -> P s -> P s') -> P empty -> (forall x s, ~In x s -> P s -> P (add x s)) -> forall s, P s. Proof. intros. apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. Qed. (** [fold] can be used to reconstruct the same initial set. *) Lemma fold_identity : forall s, fold add s empty [=] s. Proof. intros. apply fold_rec with (P:=fun s acc => acc[=]s); auto with set. intros. rewrite H2; rewrite Add_Equal in H1; auto with set. Qed. (** ** Alternative (weaker) specifications for [fold] *) (** When [FSets] was first designed, the order in which Ocaml's [Set.fold] takes the set elements was unspecified. This specification reflects this fact: *) Lemma fold_0 : forall s (A : Type) (i : A) (f : elt -> A -> A), exists l : list elt, NoDup l /\ (forall x : elt, In x s <-> InA x l) /\ fold f s i = fold_right f i l. Proof. intros; exists (rev (elements s)); split. apply NoDupA_rev; auto with *. split; intros. rewrite elements_iff; do 2 rewrite InA_alt. split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition. apply fold_spec_right. Qed. (** An alternate (and previous) specification for [fold] was based on the recursive structure of a set. It is now lemmas [fold_1] and [fold_2]. *) Lemma fold_1 : forall s (A : Type) (eqA : A -> A -> Prop) (st : Equivalence eqA) (i : A) (f : elt -> A -> A), Empty s -> eqA (fold f s i) i. Proof. unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))). rewrite H3; clear H3. generalize H H2; clear H H2; case l; simpl; intros. reflexivity. elim (H e). elim (H2 e); intuition. Qed. Lemma fold_2 : forall s s' x (A : Type) (eqA : A -> A -> Prop) (st : Equivalence eqA) (i : A) (f : elt -> A -> A), compat_op E.eq eqA f -> transpose eqA f -> ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). Proof. intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))). rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2. apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto with *. rewrite <- Hl1; auto. intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; rewrite (H2 a); intuition. Qed. (** In fact, [fold] on empty sets is more than equivalent to the initial element, it is Leibniz-equal to it. *) Lemma fold_1b : forall s (A : Type)(i : A) (f : elt -> A -> A), Empty s -> (fold f s i) = i. Proof. intros. rewrite M.fold_1. rewrite elements_Empty in H; rewrite H; simpl; auto. Qed. Section Fold_More. Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). Lemma fold_commutes : forall i s x, eqA (fold f s (f x i)) (f x (fold f s i)). Proof. intros. apply fold_rel with (R:=fun u v => eqA u (f x v)); intros. reflexivity. transitivity (f x0 (f x b)); auto. apply Comp; auto with *. Qed. (** ** Fold is a morphism *) Lemma fold_init : forall i i' s, eqA i i' -> eqA (fold f s i) (fold f s i'). Proof. intros. apply fold_rel with (R:=eqA); auto. intros; apply Comp; auto with *. Qed. Lemma fold_equal : forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). Proof. intros i s; pattern s; apply set_induction; clear s; intros. transitivity i. apply fold_1; auto. symmetry; apply fold_1; auto. rewrite <- H0; auto. transitivity (f x (fold f s i)). apply fold_2 with (eqA := eqA); auto. symmetry; apply fold_2 with (eqA := eqA); auto. unfold Add in *; intros. rewrite <- H2; auto. Qed. (** ** Fold and other set operators *) Lemma fold_empty : forall i, fold f empty i = i. Proof. intros i; apply fold_1b; auto with set. Qed. Lemma fold_add : forall i s x, ~In x s -> eqA (fold f (add x s) i) (f x (fold f s i)). Proof. intros; apply fold_2 with (eqA := eqA); auto with set. Qed. Lemma add_fold : forall i s x, In x s -> eqA (fold f (add x s) i) (fold f s i). Proof. intros; apply fold_equal; auto with set. Qed. Lemma remove_fold_1: forall i s x, In x s -> eqA (f x (fold f (remove x s) i)) (fold f s i). Proof. intros. symmetry. apply fold_2 with (eqA:=eqA); auto with set. Qed. Lemma remove_fold_2: forall i s x, ~In x s -> eqA (fold f (remove x s) i) (fold f s i). Proof. intros. apply fold_equal; auto with set. Qed. Lemma fold_union_inter : forall i s s', eqA (fold f (union s s') (fold f (inter s s') i)) (fold f s (fold f s' i)). Proof. intros; pattern s; apply set_induction; clear s; intros. transitivity (fold f s' (fold f (inter s s') i)). apply fold_equal; auto with set. transitivity (fold f s' i). apply fold_init; auto. apply fold_1; auto with set. symmetry; apply fold_1; auto. rename s'0 into s''. destruct (In_dec x s'). (* In x s' *) transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set. apply fold_init; auto. apply fold_2 with (eqA:=eqA); auto with set. rewrite inter_iff; intuition. transitivity (f x (fold f s (fold f s' i))). transitivity (fold f (union s s') (f x (fold f (inter s s') i))). apply fold_equal; auto. apply equal_sym; apply union_Equal with x; auto with set. transitivity (f x (fold f (union s s') (fold f (inter s s') i))). apply fold_commutes; auto. apply Comp; auto. symmetry; apply fold_2 with (eqA:=eqA); auto. (* ~(In x s') *) transitivity (f x (fold f (union s s') (fold f (inter s'' s') i))). apply fold_2 with (eqA:=eqA); auto with set. transitivity (f x (fold f (union s s') (fold f (inter s s') i))). apply Comp;auto. apply fold_init;auto. apply fold_equal;auto. apply equal_sym; apply inter_Add_2 with x; auto with set. transitivity (f x (fold f s (fold f s' i))). apply Comp; auto. symmetry; apply fold_2 with (eqA:=eqA); auto. Qed. Lemma fold_diff_inter : forall i s s', eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i). Proof. intros. transitivity (fold f (union (diff s s') (inter s s')) (fold f (inter (diff s s') (inter s s')) i)). symmetry; apply fold_union_inter; auto. transitivity (fold f s (fold f (inter (diff s s') (inter s s')) i)). apply fold_equal; auto with set. apply fold_init; auto. apply fold_1; auto with set. Qed. Lemma fold_union: forall i s s', (forall x, ~(In x s/\In x s')) -> eqA (fold f (union s s') i) (fold f s (fold f s' i)). Proof. intros. transitivity (fold f (union s s') (fold f (inter s s') i)). apply fold_init; auto. symmetry; apply fold_1; auto with set. unfold Empty; intro a; generalize (H a); set_iff; tauto. apply fold_union_inter; auto. Qed. End Fold_More. Lemma fold_plus : forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p. Proof. intros. apply fold_rel with (R:=fun u v => u = v + p); simpl; auto. Qed. End Fold. (** * Cardinal *) (** ** Characterization of cardinal in terms of fold *) Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0. Proof. intros; rewrite cardinal_1; rewrite M.fold_1. symmetry; apply fold_left_length; auto. Qed. (** ** Old specifications for [cardinal]. *) Lemma cardinal_0 : forall s, exists l : list elt, NoDupA E.eq l /\ (forall x : elt, In x s <-> InA E.eq x l) /\ cardinal s = length l. Proof. intros; exists (elements s); intuition; apply cardinal_1. Qed. Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0. Proof. intros; rewrite cardinal_fold; apply fold_1; auto. Qed. Lemma cardinal_2 : forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s). Proof. intros; do 2 rewrite cardinal_fold. change S with ((fun _ => S) x). apply fold_2; auto. Qed. (** ** Cardinal and (non-)emptiness *) Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0. Proof. intros. rewrite elements_Empty, M.cardinal_1. destruct (elements s); intuition; discriminate. Qed. Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. Proof. intros; rewrite cardinal_Empty; auto. Qed. Hint Resolve cardinal_inv_1. Lemma cardinal_inv_2 : forall s n, cardinal s = S n -> { x : elt | In x s }. Proof. intros; rewrite M.cardinal_1 in H. generalize (elements_2 (s:=s)). destruct (elements s); try discriminate. exists e; auto. Qed. Lemma cardinal_inv_2b : forall s, cardinal s <> 0 -> { x : elt | In x s }. Proof. intro; generalize (@cardinal_inv_2 s); destruct cardinal; [intuition|eauto]. Qed. (** ** Cardinal is a morphism *) Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. Proof. symmetry. remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. induction n; intros. apply cardinal_1; rewrite <- H; auto. destruct (cardinal_inv_2 Heqn) as (x,H2). revert Heqn. rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set. rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); eauto with set. Qed. Add Morphism cardinal : cardinal_m. Proof. exact Equal_cardinal. Qed. Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal. (** ** Cardinal and set operators *) Lemma empty_cardinal : cardinal empty = 0. Proof. rewrite cardinal_fold; apply fold_1; auto with set. Qed. Hint Immediate empty_cardinal cardinal_1 : set. Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1. Proof. intros. rewrite (singleton_equal_add x). replace 0 with (cardinal empty); auto with set. apply cardinal_2 with x; auto with set. Qed. Hint Resolve singleton_cardinal: set. Lemma diff_inter_cardinal : forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s . Proof. intros; do 3 rewrite cardinal_fold. rewrite <- fold_plus. apply fold_diff_inter with (eqA:=@Logic.eq nat); auto. Qed. Lemma union_cardinal: forall s s', (forall x, ~(In x s/\In x s')) -> cardinal (union s s')=cardinal s+cardinal s'. Proof. intros; do 3 rewrite cardinal_fold. rewrite <- fold_plus. apply fold_union; auto. Qed. Lemma subset_cardinal : forall s s', s[<=]s' -> cardinal s <= cardinal s' . Proof. intros. rewrite <- (diff_inter_cardinal s' s). rewrite (inter_sym s' s). rewrite (inter_subset_equal H); auto with arith. Qed. Lemma subset_cardinal_lt : forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'. Proof. intros. rewrite <- (diff_inter_cardinal s' s). rewrite (inter_sym s' s). rewrite (inter_subset_equal H). generalize (@cardinal_inv_1 (diff s' s)). destruct (cardinal (diff s' s)). intro H2; destruct (H2 Logic.eq_refl x). set_iff; auto. intros _. change (0 + cardinal s < S n + cardinal s). apply Plus.plus_lt_le_compat; auto with arith. Qed. Theorem union_inter_cardinal : forall s s', cardinal (union s s') + cardinal (inter s s') = cardinal s + cardinal s' . Proof. intros. do 4 rewrite cardinal_fold. do 2 rewrite <- fold_plus. apply fold_union_inter with (eqA:=@Logic.eq nat); auto. Qed. Lemma union_cardinal_inter : forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s'). Proof. intros. rewrite <- union_inter_cardinal. rewrite Plus.plus_comm. auto with arith. Qed. Lemma union_cardinal_le : forall s s', cardinal (union s s') <= cardinal s + cardinal s'. Proof. intros; generalize (union_inter_cardinal s s'). intros; rewrite <- H; auto with arith. Qed. Lemma add_cardinal_1 : forall s x, In x s -> cardinal (add x s) = cardinal s. Proof. auto with set. Qed. Lemma add_cardinal_2 : forall s x, ~In x s -> cardinal (add x s) = S (cardinal s). Proof. intros. do 2 rewrite cardinal_fold. change S with ((fun _ => S) x); apply fold_add with (eqA:=@Logic.eq nat); auto. Qed. Lemma remove_cardinal_1 : forall s x, In x s -> S (cardinal (remove x s)) = cardinal s. Proof. intros. do 2 rewrite cardinal_fold. change S with ((fun _ =>S) x). apply remove_fold_1 with (eqA:=@Logic.eq nat); auto. Qed. Lemma remove_cardinal_2 : forall s x, ~In x s -> cardinal (remove x s) = cardinal s. Proof. auto with set. Qed. Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2. End WProperties_fun. (** Now comes variants for self-contained weak sets and for full sets. For these variants, only one argument is necessary. Thanks to the subtyping [WS<=S], the [Properties] functor which is meant to be used on modules [(M:S)] can simply be an alias of [WProperties]. *) Module WProperties (M:WS) := WProperties_fun M.E M. Module Properties := WProperties. (** Now comes some properties specific to the element ordering, invalid for Weak Sets. *) Module OrdProperties (M:S). Module ME:=OrderedTypeFacts(M.E). Module Import P := Properties M. Import FM. Import M.E. Import M. (** First, a specialized version of SortA_equivlistA_eqlistA: *) Lemma sort_equivlistA_eqlistA : forall l l' : list elt, sort E.lt l -> sort E.lt l' -> equivlistA E.eq l l' -> eqlistA E.eq l l'. Proof. apply SortA_equivlistA_eqlistA; eauto with *. Qed. Definition gtb x y := match E.compare x y with GT _ => true | _ => false end. Definition leb x := fun y => negb (gtb x y). Definition elements_lt x s := List.filter (gtb x) (elements s). Definition elements_ge x s := List.filter (leb x) (elements s). Lemma gtb_1 : forall x y, gtb x y = true <-> E.lt y x. Proof. intros; unfold gtb; destruct (E.compare x y); intuition; try discriminate; ME.order. Qed. Lemma leb_1 : forall x y, leb x y = true <-> ~E.lt y x. Proof. intros; unfold leb, gtb; destruct (E.compare x y); intuition; try discriminate; ME.order. Qed. Lemma gtb_compat : forall x, Proper (E.eq==>Logic.eq) (gtb x). Proof. red; intros x a b H. generalize (gtb_1 x a)(gtb_1 x b); destruct (gtb x a); destruct (gtb x b); auto. intros. symmetry; rewrite H1. apply ME.eq_lt with a; auto. rewrite <- H0; auto. intros. rewrite H0. apply ME.eq_lt with b; auto. rewrite <- H1; auto. Qed. Lemma leb_compat : forall x, Proper (E.eq==>Logic.eq) (leb x). Proof. red; intros x a b H; unfold leb. f_equal; apply gtb_compat; auto. Qed. Hint Resolve gtb_compat leb_compat. Lemma elements_split : forall x s, elements s = elements_lt x s ++ elements_ge x s. Proof. unfold elements_lt, elements_ge, leb; intros. eapply (@filter_split _ E.eq _ E.lt); auto with *. intros. rewrite gtb_1 in H. assert (~E.lt y x). unfold gtb in *; destruct (E.compare x y); intuition; try discriminate; ME.order. ME.order. Qed. Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' -> eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s). Proof. intros; unfold elements_ge, elements_lt. apply sort_equivlistA_eqlistA; auto with set. apply (@SortA_app _ E.eq); auto with *. apply (@filter_sort _ E.eq); auto with *. constructor; auto. apply (@filter_sort _ E.eq); auto with *. rewrite ME.Inf_alt by (apply (@filter_sort _ E.eq); eauto with *). intros. rewrite filter_InA in H1; auto with *; destruct H1. rewrite leb_1 in H2. rewrite <- elements_iff in H1. assert (~E.eq x y). contradict H; rewrite H; auto. ME.order. intros. rewrite filter_InA in H1; auto with *; destruct H1. rewrite gtb_1 in H3. inversion_clear H2. ME.order. rewrite filter_InA in H4; auto with *; destruct H4. rewrite leb_1 in H4. ME.order. red; intros a. rewrite InA_app_iff, InA_cons, !filter_InA, <-elements_iff, leb_1, gtb_1, (H0 a) by auto with *. intuition. destruct (E.compare a x); intuition. right; right; split; auto with *. ME.order. Qed. Definition Above x s := forall y, In y s -> E.lt y x. Definition Below x s := forall y, In y s -> E.lt x y. Lemma elements_Add_Above : forall s s' x, Above x s -> Add x s s' -> eqlistA E.eq (elements s') (elements s ++ x::nil). Proof. intros. apply sort_equivlistA_eqlistA; auto with *. apply (@SortA_app _ E.eq); auto with *. intros. inversion_clear H2. rewrite <- elements_iff in H1. apply ME.lt_eq with x; auto. inversion H3. red; intros a. rewrite InA_app_iff, InA_cons, InA_nil by auto with *. do 2 rewrite <- elements_iff; rewrite (H0 a); intuition. Qed. Lemma elements_Add_Below : forall s s' x, Below x s -> Add x s s' -> eqlistA E.eq (elements s') (x::elements s). Proof. intros. apply sort_equivlistA_eqlistA; auto with *. change (sort E.lt ((x::nil) ++ elements s)). apply (@SortA_app _ E.eq); auto with *. intros. inversion_clear H1. rewrite <- elements_iff in H2. apply ME.eq_lt with x; auto. inversion H3. red; intros a. rewrite InA_cons. do 2 rewrite <- elements_iff; rewrite (H0 a); intuition. Qed. (** Two other induction principles on sets: we can be more restrictive on the element we add at each step. *) Lemma set_induction_max : forall P : t -> Type, (forall s : t, Empty s -> P s) -> (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') -> forall s : t, P s. Proof. intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. case_eq (max_elt s); intros. apply X0 with (remove e s) e; auto with set. apply IHn. assert (S n = S (cardinal (remove e s))). rewrite Heqn; apply cardinal_2 with e; auto with set. inversion H0; auto. red; intros. rewrite remove_iff in H0; destruct H0. generalize (@max_elt_2 s e y H H0); ME.order. assert (H0:=max_elt_3 H). rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn. Qed. Lemma set_induction_min : forall P : t -> Type, (forall s : t, Empty s -> P s) -> (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') -> forall s : t, P s. Proof. intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. case_eq (min_elt s); intros. apply X0 with (remove e s) e; auto with set. apply IHn. assert (S n = S (cardinal (remove e s))). rewrite Heqn; apply cardinal_2 with e; auto with set. inversion H0; auto. red; intros. rewrite remove_iff in H0; destruct H0. generalize (@min_elt_2 s e y H H0); ME.order. assert (H0:=min_elt_3 H). rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn. Qed. (** More properties of [fold] : behavior with respect to Above/Below *) Lemma fold_3 : forall s s' x (A : Type) (eqA : A -> A -> Prop) (st : Equivalence eqA) (i : A) (f : elt -> A -> A), compat_op E.eq eqA f -> Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). Proof. intros. rewrite 2 fold_spec_right. change (f x (fold_right f i (rev (elements s)))) with (fold_right f i (rev (x::nil)++rev (elements s))). apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. rewrite <- distr_rev. apply eqlistA_rev. apply elements_Add_Above; auto. Qed. Lemma fold_4 : forall s s' x (A : Type) (eqA : A -> A -> Prop) (st : Equivalence eqA) (i : A) (f : elt -> A -> A), compat_op E.eq eqA f -> Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)). Proof. intros. rewrite 2 M.fold_1. set (g:=fun (a : A) (e : elt) => f e a). change (eqA (fold_left g (elements s') i) (fold_left g (x::elements s) i)). unfold g. rewrite <- 2 fold_left_rev_right. apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. apply eqlistA_rev. apply elements_Add_Below; auto. Qed. (** The following results have already been proved earlier, but we can now prove them with one hypothesis less: no need for [(transpose eqA f)]. *) Section FoldOpt. Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f). Lemma fold_equal : forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). Proof. intros. rewrite 2 fold_spec_right. apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. apply eqlistA_rev. apply sort_equivlistA_eqlistA; auto with set. red; intro a; do 2 rewrite <- elements_iff; auto. Qed. Lemma add_fold : forall i s x, In x s -> eqA (fold f (add x s) i) (fold f s i). Proof. intros; apply fold_equal; auto with set. Qed. Lemma remove_fold_2: forall i s x, ~In x s -> eqA (fold f (remove x s) i) (fold f s i). Proof. intros. apply fold_equal; auto with set. Qed. End FoldOpt. (** An alternative version of [choose_3] *) Lemma choose_equal : forall s s', Equal s s' -> match choose s, choose s' with | Some x, Some x' => E.eq x x' | None, None => True | _, _ => False end. Proof. intros s s' H; generalize (@choose_1 s)(@choose_2 s) (@choose_1 s')(@choose_2 s')(@choose_3 s s'); destruct (choose s); destruct (choose s'); simpl; intuition. apply H5 with e; rewrite <-H; auto. apply H5 with e; rewrite H; auto. Qed. End OrdProperties. coq-8.4pl4/theories/FSets/FMapInterface.v0000644000175000017500000002725712326224777017351 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* elt->bool) e1 e2 := cmp e1 e2 = true. (** ** Weak signature for maps No requirements for an ordering on keys nor elements, only decidability of equality on keys. First, a functorial signature: *) Module Type WSfun (E : DecidableType). Definition key := E.t. Hint Transparent key. Parameter t : Type -> Type. (** the abstract type of maps *) Section Types. Variable elt:Type. Parameter empty : t elt. (** The empty map. *) Parameter is_empty : t elt -> bool. (** Test whether a map is empty or not. *) Parameter add : key -> elt -> t elt -> t elt. (** [add x y m] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already bound in [m], its previous binding disappears. *) Parameter find : key -> t elt -> option elt. (** [find x m] returns the current binding of [x] in [m], or [None] if no such binding exists. *) Parameter remove : key -> t elt -> t elt. (** [remove x m] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map. *) Parameter mem : key -> t elt -> bool. (** [mem x m] returns [true] if [m] contains a binding for [x], and [false] otherwise. *) Variable elt' elt'' : Type. Parameter map : (elt -> elt') -> t elt -> t elt'. (** [map f m] returns a map with same domain as [m], where the associated value a of all bindings of [m] has been replaced by the result of the application of [f] to [a]. Since Coq is purely functional, the order in which the bindings are passed to [f] is irrelevant. *) Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'. (** Same as [map], but the function receives as arguments both the key and the associated value for each binding of the map. *) Parameter map2 : (option elt -> option elt' -> option elt'') -> t elt -> t elt' -> t elt''. (** [map2 f m m'] creates a new map whose bindings belong to the ones of either [m] or [m']. The presence and value for a key [k] is determined by [f e e'] where [e] and [e'] are the (optional) bindings of [k] in [m] and [m']. *) Parameter elements : t elt -> list (key*elt). (** [elements m] returns an assoc list corresponding to the bindings of [m], in any order. *) Parameter cardinal : t elt -> nat. (** [cardinal m] returns the number of bindings in [m]. *) Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A. (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], where [k1] ... [kN] are the keys of all bindings in [m] (in any order), and [d1] ... [dN] are the associated data. *) Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool. (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, that is, contain equal keys and associate them with equal data. [cmp] is the equality predicate used to compare the data associated with the keys. *) Section Spec. Variable m m' m'' : t elt. Variable x y z : key. Variable e e' : elt. Parameter MapsTo : key -> elt -> t elt -> Prop. Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m. Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p'). Definition eq_key_elt (p p':key*elt) := E.eq (fst p) (fst p') /\ (snd p) = (snd p'). (** Specification of [MapsTo] *) Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m. (** Specification of [mem] *) Parameter mem_1 : In x m -> mem x m = true. Parameter mem_2 : mem x m = true -> In x m. (** Specification of [empty] *) Parameter empty_1 : Empty empty. (** Specification of [is_empty] *) Parameter is_empty_1 : Empty m -> is_empty m = true. Parameter is_empty_2 : is_empty m = true -> Empty m. (** Specification of [add] *) Parameter add_1 : E.eq x y -> MapsTo y e (add x e m). Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Parameter add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. (** Specification of [remove] *) Parameter remove_1 : E.eq x y -> ~ In y (remove x m). Parameter remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. (** Specification of [find] *) Parameter find_1 : MapsTo x e m -> find x m = Some e. Parameter find_2 : find x m = Some e -> MapsTo x e m. (** Specification of [elements] *) Parameter elements_1 : MapsTo x e m -> InA eq_key_elt (x,e) (elements m). Parameter elements_2 : InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. (** When compared with ordered maps, here comes the only property that is really weaker: *) Parameter elements_3w : NoDupA eq_key (elements m). (** Specification of [cardinal] *) Parameter cardinal_1 : cardinal m = length (elements m). (** Specification of [fold] *) Parameter fold_1 : forall (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. (** Equality of maps *) (** Caveat: there are at least three distinct equality predicates on maps. - The simpliest (and maybe most natural) way is to consider keys up to their equivalence [E.eq], but elements up to Leibniz equality, in the spirit of [eq_key_elt] above. This leads to predicate [Equal]. - Unfortunately, this [Equal] predicate can't be used to describe the [equal] function, since this function (for compatibility with ocaml) expects a boolean comparison [cmp] that may identify more elements than Leibniz. So logical specification of [equal] is done via another predicate [Equivb] - This predicate [Equivb] is quite ad-hoc with its boolean [cmp], it can be generalized in a [Equiv] expecting a more general (possibly non-decidable) equality predicate on elements *) Definition Equal m m' := forall y, find y m = find y m'. Definition Equiv (eq_elt:elt->elt->Prop) m m' := (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp). (** Specification of [equal] *) Variable cmp : elt -> elt -> bool. Parameter equal_1 : Equivb cmp m m' -> equal cmp m m' = true. Parameter equal_2 : equal cmp m m' = true -> Equivb cmp m m'. End Spec. End Types. (** Specification of [map] *) Parameter map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Parameter map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. (** Specification of [mapi] *) Parameter mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Parameter mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. (** Specification of [map2] *) Parameter map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x m \/ In x m' -> find x (map2 f m m') = f (find x m) (find x m'). Parameter map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Hint Immediate MapsTo_1 mem_2 is_empty_2 map_2 mapi_2 add_3 remove_3 find_2 : map. Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 remove_1 remove_2 find_1 fold_1 map_1 mapi_1 mapi_2 : map. End WSfun. (** ** Static signature for Weak Maps Similar to [WSfun] but expressed in a self-contained way. *) Module Type WS. Declare Module E : DecidableType. Include WSfun E. End WS. (** ** Maps on ordered keys, functorial signature *) Module Type Sfun (E : OrderedType). Include WSfun E. Section elt. Variable elt:Type. Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p'). (* Additional specification of [elements] *) Parameter elements_3 : forall m, sort lt_key (elements m). (** Remark: since [fold] is specified via [elements], this stronger specification of [elements] has an indirect impact on [fold], which can now be proved to receive elements in increasing order. *) End elt. End Sfun. (** ** Maps on ordered keys, self-contained signature *) Module Type S. Declare Module E : OrderedType. Include Sfun E. End S. (** ** Maps with ordering both on keys and datas *) Module Type Sord. Declare Module Data : OrderedType. Declare Module MapS : S. Import MapS. Definition t := MapS.t Data.t. Parameter eq : t -> t -> Prop. Parameter lt : t -> t -> Prop. Axiom eq_refl : forall m : t, eq m m. Axiom eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. Axiom eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. Axiom lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. Axiom lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end. Parameter eq_1 : forall m m', Equivb cmp m m' -> eq m m'. Parameter eq_2 : forall m m', eq m m' -> Equivb cmp m m'. Parameter compare : forall m1 m2, Compare lt eq m1 m2. (** Total ordering between maps. [Data.compare] is a total ordering used to compare data associated with equal keys in the two maps. *) End Sord. coq-8.4pl4/theories/FSets/FSets.v0000644000175000017500000000166612326224777015725 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t -> Prop. Definition Equal s s' := forall a : elt, In a s <-> In a s'. Definition Subset s s' := forall a : elt, In a s -> In a s'. Definition Empty s := forall a : elt, ~ In a s. Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. Notation "s [=] t" := (Equal s t) (at level 70, no associativity). Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). Parameter empty : t. (** The empty set. *) Parameter is_empty : t -> bool. (** Test whether a set is empty or not. *) Parameter mem : elt -> t -> bool. (** [mem x s] tests whether [x] belongs to the set [s]. *) Parameter add : elt -> t -> t. (** [add x s] returns a set containing all elements of [s], plus [x]. If [x] was already in [s], [s] is returned unchanged. *) Parameter singleton : elt -> t. (** [singleton x] returns the one-element set containing only [x]. *) Parameter remove : elt -> t -> t. (** [remove x s] returns a set containing all elements of [s], except [x]. If [x] was not in [s], [s] is returned unchanged. *) Parameter union : t -> t -> t. (** Set union. *) Parameter inter : t -> t -> t. (** Set intersection. *) Parameter diff : t -> t -> t. (** Set difference. *) Definition eq : t -> t -> Prop := Equal. Parameter eq_dec : forall s s', { eq s s' } + { ~ eq s s' }. Parameter equal : t -> t -> bool. (** [equal s1 s2] tests whether the sets [s1] and [s2] are equal, that is, contain equal elements. *) Parameter subset : t -> t -> bool. (** [subset s1 s2] tests whether the set [s1] is a subset of the set [s2]. *) Parameter fold : forall A : Type, (elt -> A -> A) -> t -> A -> A. (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], where [x1 ... xN] are the elements of [s]. The order in which elements of [s] are presented to [f] is unspecified. *) Parameter for_all : (elt -> bool) -> t -> bool. (** [for_all p s] checks if all elements of the set satisfy the predicate [p]. *) Parameter exists_ : (elt -> bool) -> t -> bool. (** [exists p s] checks if at least one element of the set satisfies the predicate [p]. *) Parameter filter : (elt -> bool) -> t -> t. (** [filter p s] returns the set of all elements in [s] that satisfy predicate [p]. *) Parameter partition : (elt -> bool) -> t -> t * t. (** [partition p s] returns a pair of sets [(s1, s2)], where [s1] is the set of all the elements of [s] that satisfy the predicate [p], and [s2] is the set of all the elements of [s] that do not satisfy [p]. *) Parameter cardinal : t -> nat. (** Return the number of elements of a set. *) Parameter elements : t -> list elt. (** Return the list of all elements of the given set, in any order. *) Parameter choose : t -> option elt. (** Return one element of the given set, or [None] if the set is empty. Which element is chosen is unspecified. Equal sets could return different elements. *) Section Spec. Variable s s' s'': t. Variable x y : elt. (** Specification of [In] *) Parameter In_1 : E.eq x y -> In x s -> In y s. (** Specification of [eq] *) Parameter eq_refl : eq s s. Parameter eq_sym : eq s s' -> eq s' s. Parameter eq_trans : eq s s' -> eq s' s'' -> eq s s''. (** Specification of [mem] *) Parameter mem_1 : In x s -> mem x s = true. Parameter mem_2 : mem x s = true -> In x s. (** Specification of [equal] *) Parameter equal_1 : Equal s s' -> equal s s' = true. Parameter equal_2 : equal s s' = true -> Equal s s'. (** Specification of [subset] *) Parameter subset_1 : Subset s s' -> subset s s' = true. Parameter subset_2 : subset s s' = true -> Subset s s'. (** Specification of [empty] *) Parameter empty_1 : Empty empty. (** Specification of [is_empty] *) Parameter is_empty_1 : Empty s -> is_empty s = true. Parameter is_empty_2 : is_empty s = true -> Empty s. (** Specification of [add] *) Parameter add_1 : E.eq x y -> In y (add x s). Parameter add_2 : In y s -> In y (add x s). Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s. (** Specification of [remove] *) Parameter remove_1 : E.eq x y -> ~ In y (remove x s). Parameter remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). Parameter remove_3 : In y (remove x s) -> In y s. (** Specification of [singleton] *) Parameter singleton_1 : In y (singleton x) -> E.eq x y. Parameter singleton_2 : E.eq x y -> In y (singleton x). (** Specification of [union] *) Parameter union_1 : In x (union s s') -> In x s \/ In x s'. Parameter union_2 : In x s -> In x (union s s'). Parameter union_3 : In x s' -> In x (union s s'). (** Specification of [inter] *) Parameter inter_1 : In x (inter s s') -> In x s. Parameter inter_2 : In x (inter s s') -> In x s'. Parameter inter_3 : In x s -> In x s' -> In x (inter s s'). (** Specification of [diff] *) Parameter diff_1 : In x (diff s s') -> In x s. Parameter diff_2 : In x (diff s s') -> ~ In x s'. Parameter diff_3 : In x s -> ~ In x s' -> In x (diff s s'). (** Specification of [fold] *) Parameter fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. (** Specification of [cardinal] *) Parameter cardinal_1 : cardinal s = length (elements s). Section Filter. Variable f : elt -> bool. (** Specification of [filter] *) Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. Parameter filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). (** Specification of [for_all] *) Parameter for_all_1 : compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true. Parameter for_all_2 : compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s. (** Specification of [exists] *) Parameter exists_1 : compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. Parameter exists_2 : compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. (** Specification of [partition] *) Parameter partition_1 : compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). Parameter partition_2 : compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). End Filter. (** Specification of [elements] *) Parameter elements_1 : In x s -> InA E.eq x (elements s). Parameter elements_2 : InA E.eq x (elements s) -> In x s. (** When compared with ordered sets, here comes the only property that is really weaker: *) Parameter elements_3w : NoDupA E.eq (elements s). (** Specification of [choose] *) Parameter choose_1 : choose s = Some x -> In x s. Parameter choose_2 : choose s = None -> Empty s. End Spec. Hint Transparent elt. Hint Resolve mem_1 equal_1 subset_1 empty_1 is_empty_1 choose_1 choose_2 add_1 add_2 remove_1 remove_2 singleton_2 union_1 union_2 union_3 inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1 partition_1 partition_2 elements_1 elements_3w : set. Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3 remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2 filter_1 filter_2 for_all_2 exists_2 elements_2 : set. End WSfun. (** ** Static signature for weak sets Similar to the functorial signature [SW], except that the module [E] of base elements is incorporated in the signature. *) Module Type WS. Declare Module E : DecidableType. Include WSfun E. End WS. (** ** Functorial signature for sets on ordered elements Based on [WSfun], plus ordering on sets and [min_elt] and [max_elt] and some stronger specifications for other functions. *) Module Type Sfun (E : OrderedType). Include WSfun E. Parameter lt : t -> t -> Prop. Parameter compare : forall s s' : t, Compare lt eq s s'. (** Total ordering between sets. Can be used as the ordering function for doing sets of sets. *) Parameter min_elt : t -> option elt. (** Return the smallest element of the given set (with respect to the [E.compare] ordering), or [None] if the set is empty. *) Parameter max_elt : t -> option elt. (** Same as [min_elt], but returns the largest element of the given set. *) Section Spec. Variable s s' s'' : t. Variable x y : elt. (** Specification of [lt] *) Parameter lt_trans : lt s s' -> lt s' s'' -> lt s s''. Parameter lt_not_eq : lt s s' -> ~ eq s s'. (** Additional specification of [elements] *) Parameter elements_3 : sort E.lt (elements s). (** Remark: since [fold] is specified via [elements], this stronger specification of [elements] has an indirect impact on [fold], which can now be proved to receive elements in increasing order. *) (** Specification of [min_elt] *) Parameter min_elt_1 : min_elt s = Some x -> In x s. Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. Parameter min_elt_3 : min_elt s = None -> Empty s. (** Specification of [max_elt] *) Parameter max_elt_1 : max_elt s = Some x -> In x s. Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. Parameter max_elt_3 : max_elt s = None -> Empty s. (** Additional specification of [choose] *) Parameter choose_3 : choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. End Spec. Hint Resolve elements_3 : set. Hint Immediate min_elt_1 min_elt_2 min_elt_3 max_elt_1 max_elt_2 max_elt_3 : set. End Sfun. (** ** Static signature for sets on ordered elements Similar to the functorial signature [Sfun], except that the module [E] of base elements is incorporated in the signature. *) Module Type S. Declare Module E : OrderedType. Include Sfun E. End S. (** ** Some subtyping tests << WSfun ---> WS | | | | V V Sfun ---> S Module S_WS (M : S) <: WS := M. Module Sfun_WSfun (E:OrderedType)(M : Sfun E) <: WSfun E := M. Module S_Sfun (M : S) <: Sfun M.E := M. Module WS_WSfun (M : WS) <: WSfun M.E := M. >> *) (** * Dependent signature Signature [Sdep] presents ordered sets using dependent types *) Module Type Sdep. Declare Module E : OrderedType. Definition elt := E.t. Parameter t : Type. Parameter In : elt -> t -> Prop. Definition Equal s s' := forall a : elt, In a s <-> In a s'. Definition Subset s s' := forall a : elt, In a s -> In a s'. Definition Add x s s' := forall y, In y s' <-> E.eq x y \/ In y s. Definition Empty s := forall a : elt, ~ In a s. Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. Notation "s [=] t" := (Equal s t) (at level 70, no associativity). Definition eq : t -> t -> Prop := Equal. Parameter lt : t -> t -> Prop. Parameter compare : forall s s' : t, Compare lt eq s s'. Parameter eq_refl : forall s : t, eq s s. Parameter eq_sym : forall s s' : t, eq s s' -> eq s' s. Parameter eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''. Parameter lt_trans : forall s s' s'' : t, lt s s' -> lt s' s'' -> lt s s''. Parameter lt_not_eq : forall s s' : t, lt s s' -> ~ eq s s'. Parameter eq_In : forall (s : t) (x y : elt), E.eq x y -> In x s -> In y s. Parameter empty : {s : t | Empty s}. Parameter is_empty : forall s : t, {Empty s} + {~ Empty s}. Parameter mem : forall (x : elt) (s : t), {In x s} + {~ In x s}. Parameter add : forall (x : elt) (s : t), {s' : t | Add x s s'}. Parameter singleton : forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}. Parameter remove : forall (x : elt) (s : t), {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}. Parameter union : forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}. Parameter inter : forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}. Parameter diff : forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}. Parameter equal : forall s s' : t, {s[=]s'} + {~ s[=]s'}. Parameter subset : forall s s' : t, {Subset s s'} + {~ Subset s s'}. Parameter filter : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}. Parameter for_all : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}. Parameter exists_ : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}. Parameter partition : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {partition : t * t | let (s1, s2) := partition in compat_P E.eq P -> For_all P s1 /\ For_all (fun x => ~ P x) s2 /\ (forall x : elt, In x s <-> In x s1 \/ In x s2)}. Parameter elements : forall s : t, {l : list elt | sort E.lt l /\ (forall x : elt, In x s <-> InA E.eq x l)}. Parameter fold : forall (A : Type) (f : elt -> A -> A) (s : t) (i : A), {r : A | let (l,_) := elements s in r = fold_left (fun a e => f e a) l i}. Parameter cardinal : forall s : t, {r : nat | let (l,_) := elements s in r = length l }. Parameter min_elt : forall s : t, {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}. Parameter max_elt : forall s : t, {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}. Parameter choose : forall s : t, {x : elt | In x s} + {Empty s}. (** The [choose_3] specification of [S] cannot be packed in the dependent version of [choose], so we leave it separate. *) Parameter choose_equal : forall s s', Equal s s' -> match choose s, choose s' with | inleft (exist x _), inleft (exist x' _) => E.eq x x' | inright _, inright _ => True | _, _ => False end. End Sdep. coq-8.4pl4/theories/FSets/FSetEqProperties.v0000644000175000017500000005435512326224777020110 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* mem x s=mem y s. Proof. intro H; rewrite H; auto. Qed. Lemma equal_mem_1: (forall a, mem a s=mem a s') -> equal s s'=true. Proof. intros; apply equal_1; unfold Equal; intros. do 2 rewrite mem_iff; rewrite H; tauto. Qed. Lemma equal_mem_2: equal s s'=true -> forall a, mem a s=mem a s'. Proof. intros; rewrite (equal_2 H); auto. Qed. Lemma subset_mem_1: (forall a, mem a s=true->mem a s'=true) -> subset s s'=true. Proof. intros; apply subset_1; unfold Subset; intros a. do 2 rewrite mem_iff; auto. Qed. Lemma subset_mem_2: subset s s'=true -> forall a, mem a s=true -> mem a s'=true. Proof. intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto. Qed. Lemma empty_mem: mem x empty=false. Proof. rewrite <- not_mem_iff; auto with set. Qed. Lemma is_empty_equal_empty: is_empty s = equal s empty. Proof. apply bool_1; split; intros. auto with set. rewrite <- is_empty_iff; auto with set. Qed. Lemma choose_mem_1: choose s=Some x -> mem x s=true. Proof. auto with set. Qed. Lemma choose_mem_2: choose s=None -> is_empty s=true. Proof. auto with set. Qed. Lemma add_mem_1: mem x (add x s)=true. Proof. auto with set. Qed. Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s. Proof. apply add_neq_b. Qed. Lemma remove_mem_1: mem x (remove x s)=false. Proof. rewrite <- not_mem_iff; auto with set. Qed. Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s. Proof. apply remove_neq_b. Qed. Lemma singleton_equal_add: equal (singleton x) (add x empty)=true. Proof. rewrite (singleton_equal_add x); auto with set. Qed. Lemma union_mem: mem x (union s s')=mem x s || mem x s'. Proof. apply union_b. Qed. Lemma inter_mem: mem x (inter s s')=mem x s && mem x s'. Proof. apply inter_b. Qed. Lemma diff_mem: mem x (diff s s')=mem x s && negb (mem x s'). Proof. apply diff_b. Qed. (** properties of [mem] *) Lemma mem_3 : ~In x s -> mem x s=false. Proof. intros; rewrite <- not_mem_iff; auto. Qed. Lemma mem_4 : mem x s=false -> ~In x s. Proof. intros; rewrite not_mem_iff; auto. Qed. (** Properties of [equal] *) Lemma equal_refl: equal s s=true. Proof. auto with set. Qed. Lemma equal_sym: equal s s'=equal s' s. Proof. intros; apply bool_1; do 2 rewrite <- equal_iff; intuition. Qed. Lemma equal_trans: equal s s'=true -> equal s' s''=true -> equal s s''=true. Proof. intros; rewrite (equal_2 H); auto. Qed. Lemma equal_equal: equal s s'=true -> equal s s''=equal s' s''. Proof. intros; rewrite (equal_2 H); auto. Qed. Lemma equal_cardinal: equal s s'=true -> cardinal s=cardinal s'. Proof. auto with set. Qed. (* Properties of [subset] *) Lemma subset_refl: subset s s=true. Proof. auto with set. Qed. Lemma subset_antisym: subset s s'=true -> subset s' s=true -> equal s s'=true. Proof. auto with set. Qed. Lemma subset_trans: subset s s'=true -> subset s' s''=true -> subset s s''=true. Proof. do 3 rewrite <- subset_iff; intros. apply subset_trans with s'; auto. Qed. Lemma subset_equal: equal s s'=true -> subset s s'=true. Proof. auto with set. Qed. (** Properties of [choose] *) Lemma choose_mem_3: is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}. Proof. intros. generalize (@choose_1 s) (@choose_2 s). destruct (choose s);intros. exists e;auto with set. generalize (H1 Logic.eq_refl); clear H1. intros; rewrite (is_empty_1 H1) in H; discriminate. Qed. Lemma choose_mem_4: choose empty=None. Proof. generalize (@choose_1 empty). case (@choose empty);intros;auto. elim (@empty_1 e); auto. Qed. (** Properties of [add] *) Lemma add_mem_3: mem y s=true -> mem y (add x s)=true. Proof. auto with set. Qed. Lemma add_equal: mem x s=true -> equal (add x s) s=true. Proof. auto with set. Qed. (** Properties of [remove] *) Lemma remove_mem_3: mem y (remove x s)=true -> mem y s=true. Proof. rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto. Qed. Lemma remove_equal: mem x s=false -> equal (remove x s) s=true. Proof. intros; apply equal_1; apply remove_equal. rewrite not_mem_iff; auto. Qed. Lemma add_remove: mem x s=true -> equal (add x (remove x s)) s=true. Proof. intros; apply equal_1; apply add_remove; auto with set. Qed. Lemma remove_add: mem x s=false -> equal (remove x (add x s)) s=true. Proof. intros; apply equal_1; apply remove_add; auto. rewrite not_mem_iff; auto. Qed. (** Properties of [is_empty] *) Lemma is_empty_cardinal: is_empty s = zerob (cardinal s). Proof. intros; apply bool_1; split; intros. rewrite MP.cardinal_1; simpl; auto with set. assert (cardinal s = 0) by (apply zerob_true_elim; auto). auto with set. Qed. (** Properties of [singleton] *) Lemma singleton_mem_1: mem x (singleton x)=true. Proof. auto with set. Qed. Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false. Proof. intros; rewrite singleton_b. unfold eqb; destruct (E.eq_dec x y); intuition. Qed. Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y. Proof. intros; apply singleton_1; auto with set. Qed. (** Properties of [union] *) Lemma union_sym: equal (union s s') (union s' s)=true. Proof. auto with set. Qed. Lemma union_subset_equal: subset s s'=true -> equal (union s s') s'=true. Proof. auto with set. Qed. Lemma union_equal_1: equal s s'=true-> equal (union s s'') (union s' s'')=true. Proof. auto with set. Qed. Lemma union_equal_2: equal s' s''=true-> equal (union s s') (union s s'')=true. Proof. auto with set. Qed. Lemma union_assoc: equal (union (union s s') s'') (union s (union s' s''))=true. Proof. auto with set. Qed. Lemma add_union_singleton: equal (add x s) (union (singleton x) s)=true. Proof. auto with set. Qed. Lemma union_add: equal (union (add x s) s') (add x (union s s'))=true. Proof. auto with set. Qed. (* caracterisation of [union] via [subset] *) Lemma union_subset_1: subset s (union s s')=true. Proof. auto with set. Qed. Lemma union_subset_2: subset s' (union s s')=true. Proof. auto with set. Qed. Lemma union_subset_3: subset s s''=true -> subset s' s''=true -> subset (union s s') s''=true. Proof. intros; apply subset_1; apply union_subset_3; auto with set. Qed. (** Properties of [inter] *) Lemma inter_sym: equal (inter s s') (inter s' s)=true. Proof. auto with set. Qed. Lemma inter_subset_equal: subset s s'=true -> equal (inter s s') s=true. Proof. auto with set. Qed. Lemma inter_equal_1: equal s s'=true -> equal (inter s s'') (inter s' s'')=true. Proof. auto with set. Qed. Lemma inter_equal_2: equal s' s''=true -> equal (inter s s') (inter s s'')=true. Proof. auto with set. Qed. Lemma inter_assoc: equal (inter (inter s s') s'') (inter s (inter s' s''))=true. Proof. auto with set. Qed. Lemma union_inter_1: equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true. Proof. auto with set. Qed. Lemma union_inter_2: equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true. Proof. auto with set. Qed. Lemma inter_add_1: mem x s'=true -> equal (inter (add x s) s') (add x (inter s s'))=true. Proof. auto with set. Qed. Lemma inter_add_2: mem x s'=false -> equal (inter (add x s) s') (inter s s')=true. Proof. intros; apply equal_1; apply inter_add_2. rewrite not_mem_iff; auto. Qed. (* caracterisation of [union] via [subset] *) Lemma inter_subset_1: subset (inter s s') s=true. Proof. auto with set. Qed. Lemma inter_subset_2: subset (inter s s') s'=true. Proof. auto with set. Qed. Lemma inter_subset_3: subset s'' s=true -> subset s'' s'=true -> subset s'' (inter s s')=true. Proof. intros; apply subset_1; apply inter_subset_3; auto with set. Qed. (** Properties of [diff] *) Lemma diff_subset: subset (diff s s') s=true. Proof. auto with set. Qed. Lemma diff_subset_equal: subset s s'=true -> equal (diff s s') empty=true. Proof. auto with set. Qed. Lemma remove_inter_singleton: equal (remove x s) (diff s (singleton x))=true. Proof. auto with set. Qed. Lemma diff_inter_empty: equal (inter (diff s s') (inter s s')) empty=true. Proof. auto with set. Qed. Lemma diff_inter_all: equal (union (diff s s') (inter s s')) s=true. Proof. auto with set. Qed. End BasicProperties. Hint Immediate empty_mem is_empty_equal_empty add_mem_1 remove_mem_1 singleton_equal_add union_mem inter_mem diff_mem equal_sym add_remove remove_add : set. Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal subset_refl subset_equal subset_antisym add_mem_3 add_equal remove_mem_3 remove_equal : set. (** General recursion principle *) Lemma set_rec: forall (P:t->Type), (forall s s', equal s s'=true -> P s -> P s') -> (forall s x, mem x s=false -> P s -> P (add x s)) -> P empty -> forall s, P s. Proof. intros. apply set_induction; auto; intros. apply X with empty; auto with set. apply X with (add x s0); auto with set. apply equal_1; intro a; rewrite add_iff; rewrite (H0 a); tauto. apply X0; auto with set; apply mem_3; auto. Qed. (** Properties of [fold] *) Lemma exclusive_set : forall s s' x, ~(In x s/\In x s') <-> mem x s && mem x s'=false. Proof. intros; do 2 rewrite mem_iff. destruct (mem x s); destruct (mem x s'); intuition. Qed. Section Fold. Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). Variables (i:A). Variables (s s':t)(x:elt). Lemma fold_empty: (fold f empty i) = i. Proof. apply fold_empty; auto. Qed. Lemma fold_equal: equal s s'=true -> eqA (fold f s i) (fold f s' i). Proof. intros; apply fold_equal with (eqA:=eqA); auto with set. Qed. Lemma fold_add: mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)). Proof. intros; apply fold_add with (eqA:=eqA); auto. rewrite not_mem_iff; auto. Qed. Lemma add_fold: mem x s=true -> eqA (fold f (add x s) i) (fold f s i). Proof. intros; apply add_fold with (eqA:=eqA); auto with set. Qed. Lemma remove_fold_1: mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i). Proof. intros; apply remove_fold_1 with (eqA:=eqA); auto with set. Qed. Lemma remove_fold_2: mem x s=false -> eqA (fold f (remove x s) i) (fold f s i). Proof. intros; apply remove_fold_2 with (eqA:=eqA); auto. rewrite not_mem_iff; auto. Qed. Lemma fold_union: (forall x, mem x s && mem x s'=false) -> eqA (fold f (union s s') i) (fold f s (fold f s' i)). Proof. intros; apply fold_union with (eqA:=eqA); auto. intros; rewrite exclusive_set; auto. Qed. End Fold. (** Properties of [cardinal] *) Lemma add_cardinal_1: forall s x, mem x s=true -> cardinal (add x s)=cardinal s. Proof. auto with set. Qed. Lemma add_cardinal_2: forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s). Proof. intros; apply add_cardinal_2; auto. rewrite not_mem_iff; auto. Qed. Lemma remove_cardinal_1: forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s. Proof. intros; apply remove_cardinal_1; auto with set. Qed. Lemma remove_cardinal_2: forall s x, mem x s=false -> cardinal (remove x s)=cardinal s. Proof. intros; apply Equal_cardinal; apply equal_2; auto with set. Qed. Lemma union_cardinal: forall s s', (forall x, mem x s && mem x s'=false) -> cardinal (union s s')=cardinal s+cardinal s'. Proof. intros; apply union_cardinal; auto; intros. rewrite exclusive_set; auto. Qed. Lemma subset_cardinal: forall s s', subset s s'=true -> cardinal s<=cardinal s'. Proof. intros; apply subset_cardinal; auto with set. Qed. Section Bool. (** Properties of [filter] *) Variable f:elt->bool. Variable Comp: Proper (E.eq==>Logic.eq) f. Let Comp' : Proper (E.eq==>Logic.eq) (fun x =>negb (f x)). Proof. repeat red; intros; f_equal; auto. Qed. Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x. Proof. intros; apply filter_b; auto. Qed. Lemma for_all_filter: forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s). Proof. intros; apply bool_1; split; intros. apply is_empty_1. unfold Empty; intros. rewrite filter_iff; auto. red; destruct 1. rewrite <- (@for_all_iff s f) in H; auto. rewrite (H a H0) in H1; discriminate. apply for_all_1; auto; red; intros. revert H; rewrite <- is_empty_iff. unfold Empty; intro H; generalize (H x); clear H. rewrite filter_iff; auto. destruct (f x); auto. Qed. Lemma exists_filter : forall s, exists_ f s=negb (is_empty (filter f s)). Proof. intros; apply bool_1; split; intros. destruct (exists_2 Comp H) as (a,(Ha1,Ha2)). apply bool_6. red; intros; apply (@is_empty_2 _ H0 a); auto with set. generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)). destruct (choose (filter f s)). intros H0 _; apply exists_1; auto. exists e; generalize (H0 e); rewrite filter_iff; auto. intros _ H0. rewrite (is_empty_1 (H0 Logic.eq_refl)) in H; auto; discriminate. Qed. Lemma partition_filter_1: forall s, equal (fst (partition f s)) (filter f s)=true. Proof. auto with set. Qed. Lemma partition_filter_2: forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true. Proof. auto with set. Qed. Lemma filter_add_1 : forall s x, f x = true -> filter f (add x s) [=] add x (filter f s). Proof. red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff. intuition. rewrite <- H; apply Comp; auto. Qed. Lemma filter_add_2 : forall s x, f x = false -> filter f (add x s) [=] filter f s. Proof. red; intros; do 2 (rewrite filter_iff; auto); set_iff. intuition. assert (f x = f a) by (apply Comp; auto). rewrite H in H1; rewrite H2 in H1; discriminate. Qed. Lemma add_filter_1 : forall s s' x, f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')). Proof. unfold Add, MP.Add; intros. repeat rewrite filter_iff; auto. rewrite H0; clear H0. assert (E.eq x y -> f y = true) by (intro H0; rewrite <- (Comp _ _ H0); auto). tauto. Qed. Lemma add_filter_2 : forall s s' x, f x=false -> (Add x s s') -> filter f s [=] filter f s'. Proof. unfold Add, MP.Add, Equal; intros. repeat rewrite filter_iff; auto. rewrite H0; clear H0. assert (f a = true -> ~E.eq x a). intros H0 H1. rewrite (Comp _ _ H1) in H. rewrite H in H0; discriminate. tauto. Qed. Lemma union_filter: forall f g, (compat_bool E.eq f) -> (compat_bool E.eq g) -> forall s, union (filter f s) (filter g s) [=] filter (fun x=>orb (f x) (g x)) s. Proof. clear Comp' Comp f. intros. assert (compat_bool E.eq (fun x => orb (f x) (g x))). unfold compat_bool, Proper, respectful; intros. rewrite (H x y H1); rewrite (H0 x y H1); auto. unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto. assert (f a || g a = true <-> f a = true \/ g a = true). split; auto with bool. intro H3; destruct (orb_prop _ _ H3); auto. tauto. Qed. Lemma filter_union: forall s s', filter f (union s s') [=] union (filter f s) (filter f s'). Proof. unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto; set_iff; tauto. Qed. (** Properties of [for_all] *) Lemma for_all_mem_1: forall s, (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true. Proof. intros. rewrite for_all_filter; auto. rewrite is_empty_equal_empty. apply equal_mem_1;intros. rewrite filter_b; auto. rewrite empty_mem. generalize (H a); case (mem a s);intros;auto. rewrite H0;auto. Qed. Lemma for_all_mem_2: forall s, (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. Proof. intros. rewrite for_all_filter in H; auto. rewrite is_empty_equal_empty in H. generalize (equal_mem_2 _ _ H x). rewrite filter_b; auto. rewrite empty_mem. rewrite H0; simpl;intros. rewrite <- negb_false_iff; auto. Qed. Lemma for_all_mem_3: forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false. Proof. intros. apply (bool_eq_ind (for_all f s));intros;auto. rewrite for_all_filter in H1; auto. rewrite is_empty_equal_empty in H1. generalize (equal_mem_2 _ _ H1 x). rewrite filter_b; auto. rewrite empty_mem. rewrite H. rewrite H0. simpl;auto. Qed. Lemma for_all_mem_4: forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}. Proof. intros. rewrite for_all_filter in H; auto. destruct (choose_mem_3 _ H) as (x,(H0,H1));intros. exists x. rewrite filter_b in H1; auto. elim (andb_prop _ _ H1). split;auto. rewrite <- negb_true_iff; auto. Qed. (** Properties of [exists] *) Lemma for_all_exists: forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s). Proof. intros. rewrite for_all_b; auto. rewrite exists_b; auto. induction (elements s); simpl; auto. destruct (f a); simpl; auto. Qed. End Bool. Section Bool'. Variable f:elt->bool. Variable Comp: compat_bool E.eq f. Let Comp' : compat_bool E.eq (fun x =>negb (f x)). Proof. unfold compat_bool, Proper, respectful in *; intros; f_equal; auto. Qed. Lemma exists_mem_1: forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false. Proof. intros. rewrite for_all_exists; auto. rewrite for_all_mem_1;auto with bool. intros;generalize (H x H0);intros. rewrite negb_true_iff; auto. Qed. Lemma exists_mem_2: forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. Proof. intros. rewrite for_all_exists in H; auto. rewrite negb_false_iff in H. rewrite <- negb_true_iff. apply for_all_mem_2 with (2:=H); auto. Qed. Lemma exists_mem_3: forall s x, mem x s=true -> f x=true -> exists_ f s=true. Proof. intros. rewrite for_all_exists; auto. rewrite negb_true_iff. apply for_all_mem_3 with x;auto. rewrite negb_false_iff; auto. Qed. Lemma exists_mem_4: forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}. Proof. intros. rewrite for_all_exists in H; auto. rewrite negb_true_iff in H. elim (for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros;auto. elim p;intros. exists x;split;auto. rewrite <-negb_false_iff; auto. Qed. End Bool'. Section Sum. (** Adding a valuation function on all elements of a set. *) Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. Notation compat_opL := (compat_op E.eq Logic.eq). Notation transposeL := (transpose Logic.eq). Lemma sum_plus : forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> forall s, sum (fun x =>f x+g x) s = sum f s + sum g s. Proof. unfold sum. intros f g Hf Hg. assert (fc : compat_opL (fun x:elt =>plus (f x))). red; auto. assert (ft : transposeL (fun x:elt =>plus (f x))). red; intros; omega. assert (gc : compat_opL (fun x:elt => plus (g x))). red; auto. assert (gt : transposeL (fun x:elt =>plus (g x))). red; intros; omega. assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). repeat red; auto. assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega. assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). intros s;pattern s; apply set_rec. intros. rewrite <- (fold_equal _ _ st _ fc ft 0 _ _ H). rewrite <- (fold_equal _ _ st _ gc gt 0 _ _ H). rewrite <- (fold_equal _ _ st _ fgc fgt 0 _ _ H); auto. intros; do 3 (rewrite (fold_add _ _ st);auto). rewrite H0;simpl;omega. do 3 rewrite fold_empty;auto. Qed. Lemma sum_filter : forall f, (compat_bool E.eq f) -> forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)). Proof. unfold sum; intros f Hf. assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))). repeat red; intros. rewrite (Hf _ _ H); auto. assert (ct : transposeL (fun x => plus (if f x then 1 else 0))). red; intros; omega. intros s;pattern s; apply set_rec. intros. change elt with E.t. rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H). rewrite <- (MP.Equal_cardinal (filter_equal Hf (equal_2 H))); auto. intros; rewrite (fold_add _ _ st _ cc ct); auto. generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0) x) . assert (~ In x (filter f s0)). intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H. case (f x); simpl; intros. rewrite (MP.cardinal_2 H1 (H2 Logic.eq_refl (MP.Add_add s0 x))); auto. rewrite <- (MP.Equal_cardinal (H3 Logic.eq_refl (MP.Add_add s0 x))); auto. intros; rewrite fold_empty;auto. rewrite MP.cardinal_1; auto. unfold Empty; intros. rewrite filter_iff; auto; set_iff; tauto. Qed. Lemma fold_compat : forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) (f g:elt->A->A), (compat_op E.eq eqA f) -> (transpose eqA f) -> (compat_op E.eq eqA g) -> (transpose eqA g) -> forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> (eqA (fold f s i) (fold g s i)). Proof. intros A eqA st f g fc ft gc gt i. intro s; pattern s; apply set_rec; intros. transitivity (fold f s0 i). apply fold_equal with (eqA:=eqA); auto. rewrite equal_sym; auto. transitivity (fold g s0 i). apply H0; intros; apply H1; auto with set. elim (equal_2 H x); auto with set; intros. apply fold_equal with (eqA:=eqA); auto with set. transitivity (f x (fold f s0 i)). apply fold_add with (eqA:=eqA); auto with set. transitivity (g x (fold f s0 i)); auto with set. transitivity (g x (fold g s0 i)); auto with set. apply gc; auto with *. symmetry; apply fold_add with (eqA:=eqA); auto. do 2 rewrite fold_empty; reflexivity. Qed. Lemma sum_compat : forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s. intros. unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto with *. intros x x' Hx y y' Hy. rewrite Hx, Hy; auto. intros x x' Hx y y' Hy. rewrite Hx, Hy; auto. Qed. End Sum. End WEqProperties_fun. (** Now comes variants for self-contained weak sets and for full sets. For these variants, only one argument is necessary. Thanks to the subtyping [WS<=S], the [EqProperties] functor which is meant to be used on modules [(M:S)] can simply be an alias of [WEqProperties]. *) Module WEqProperties (M:WS) := WEqProperties_fun M.E M. Module EqProperties := WEqProperties. coq-8.4pl4/theories/FSets/FMapPositive.v0000644000175000017500000010011512326224777017234 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* j | xI ii => xI (append ii j) | xO ii => xO (append ii j) end. Lemma append_assoc_0 : forall (i j : positive), append i (xO j) = append (append i (xO xH)) j. Proof. induction i; intros; destruct j; simpl; try rewrite (IHi (xI j)); try rewrite (IHi (xO j)); try rewrite <- (IHi xH); auto. Qed. Lemma append_assoc_1 : forall (i j : positive), append i (xI j) = append (append i (xI xH)) j. Proof. induction i; intros; destruct j; simpl; try rewrite (IHi (xI j)); try rewrite (IHi (xO j)); try rewrite <- (IHi xH); auto. Qed. Lemma append_neutral_r : forall (i : positive), append i xH = i. Proof. induction i; simpl; congruence. Qed. Lemma append_neutral_l : forall (i : positive), append xH i = i. Proof. simpl; auto. Qed. (** The module of maps over positive keys *) Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Module E:=PositiveOrderedTypeBits. Module ME:=KeyOrderedType E. Definition key := positive. Inductive tree (A : Type) := | Leaf : tree A | Node : tree A -> option A -> tree A -> tree A. Scheme tree_ind := Induction for tree Sort Prop. Definition t := tree. Section A. Variable A:Type. Arguments Leaf [A]. Definition empty : t A := Leaf. Fixpoint is_empty (m : t A) : bool := match m with | Leaf => true | Node l None r => (is_empty l) && (is_empty r) | _ => false end. Fixpoint find (i : positive) (m : t A) : option A := match m with | Leaf => None | Node l o r => match i with | xH => o | xO ii => find ii l | xI ii => find ii r end end. Fixpoint mem (i : positive) (m : t A) : bool := match m with | Leaf => false | Node l o r => match i with | xH => match o with None => false | _ => true end | xO ii => mem ii l | xI ii => mem ii r end end. Fixpoint add (i : positive) (v : A) (m : t A) : t A := match m with | Leaf => match i with | xH => Node Leaf (Some v) Leaf | xO ii => Node (add ii v Leaf) None Leaf | xI ii => Node Leaf None (add ii v Leaf) end | Node l o r => match i with | xH => Node l (Some v) r | xO ii => Node (add ii v l) o r | xI ii => Node l o (add ii v r) end end. Fixpoint remove (i : positive) (m : t A) : t A := match i with | xH => match m with | Leaf => Leaf | Node Leaf o Leaf => Leaf | Node l o r => Node l None r end | xO ii => match m with | Leaf => Leaf | Node l None Leaf => match remove ii l with | Leaf => Leaf | mm => Node mm None Leaf end | Node l o r => Node (remove ii l) o r end | xI ii => match m with | Leaf => Leaf | Node Leaf None r => match remove ii r with | Leaf => Leaf | mm => Node Leaf None mm end | Node l o r => Node l o (remove ii r) end end. (** [elements] *) Fixpoint xelements (m : t A) (i : positive) : list (positive * A) := match m with | Leaf => nil | Node l None r => (xelements l (append i (xO xH))) ++ (xelements r (append i (xI xH))) | Node l (Some x) r => (xelements l (append i (xO xH))) ++ ((i, x) :: xelements r (append i (xI xH))) end. (* Note: function [xelements] above is inefficient. We should apply deforestation to it, but that makes the proofs even harder. *) Definition elements (m : t A) := xelements m xH. (** [cardinal] *) Fixpoint cardinal (m : t A) : nat := match m with | Leaf => 0%nat | Node l None r => (cardinal l + cardinal r)%nat | Node l (Some _) r => S (cardinal l + cardinal r) end. Section CompcertSpec. Theorem gempty: forall (i: positive), find i empty = None. Proof. destruct i; simpl; auto. Qed. Theorem gss: forall (i: positive) (x: A) (m: t A), find i (add i x m) = Some x. Proof. induction i; destruct m; simpl; auto. Qed. Lemma gleaf : forall (i : positive), find i (Leaf : t A) = None. Proof. exact gempty. Qed. Theorem gso: forall (i j: positive) (x: A) (m: t A), i <> j -> find i (add j x m) = find i m. Proof. induction i; intros; destruct j; destruct m; simpl; try rewrite <- (gleaf i); auto; try apply IHi; congruence. Qed. Lemma rleaf : forall (i : positive), remove i (Leaf : t A) = Leaf. Proof. destruct i; simpl; auto. Qed. Theorem grs: forall (i: positive) (m: t A), find i (remove i m) = None. Proof. induction i; destruct m. simpl; auto. destruct m1; destruct o; destruct m2 as [ | ll oo rr]; simpl; auto. rewrite (rleaf i); auto. cut (find i (remove i (Node ll oo rr)) = None). destruct (remove i (Node ll oo rr)); auto; apply IHi. apply IHi. simpl; auto. destruct m1 as [ | ll oo rr]; destruct o; destruct m2; simpl; auto. rewrite (rleaf i); auto. cut (find i (remove i (Node ll oo rr)) = None). destruct (remove i (Node ll oo rr)); auto; apply IHi. apply IHi. simpl; auto. destruct m1; destruct m2; simpl; auto. Qed. Theorem gro: forall (i j: positive) (m: t A), i <> j -> find i (remove j m) = find i m. Proof. induction i; intros; destruct j; destruct m; try rewrite (rleaf (xI j)); try rewrite (rleaf (xO j)); try rewrite (rleaf 1); auto; destruct m1; destruct o; destruct m2; simpl; try apply IHi; try congruence; try rewrite (rleaf j); auto; try rewrite (gleaf i); auto. cut (find i (remove j (Node m2_1 o m2_2)) = find i (Node m2_1 o m2_2)); [ destruct (remove j (Node m2_1 o m2_2)); try rewrite (gleaf i); auto | apply IHi; congruence ]. destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i); auto. destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i); auto. cut (find i (remove j (Node m1_1 o0 m1_2)) = find i (Node m1_1 o0 m1_2)); [ destruct (remove j (Node m1_1 o0 m1_2)); try rewrite (gleaf i); auto | apply IHi; congruence ]. destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i); auto. destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i); auto. Qed. Lemma xelements_correct: forall (m: t A) (i j : positive) (v: A), find i m = Some v -> List.In (append j i, v) (xelements m j). Proof. induction m; intros. rewrite (gleaf i) in H; congruence. destruct o; destruct i; simpl; simpl in H. rewrite append_assoc_1; apply in_or_app; right; apply in_cons; apply IHm2; auto. rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto. rewrite append_neutral_r; apply in_or_app; injection H; intro EQ; rewrite EQ; right; apply in_eq. rewrite append_assoc_1; apply in_or_app; right; apply IHm2; auto. rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto. congruence. Qed. Theorem elements_correct: forall (m: t A) (i: positive) (v: A), find i m = Some v -> List.In (i, v) (elements m). Proof. intros m i v H. exact (xelements_correct m i xH H). Qed. Fixpoint xfind (i j : positive) (m : t A) : option A := match i, j with | _, xH => find i m | xO ii, xO jj => xfind ii jj m | xI ii, xI jj => xfind ii jj m | _, _ => None end. Lemma xfind_left : forall (j i : positive) (m1 m2 : t A) (o : option A) (v : A), xfind i (append j (xO xH)) m1 = Some v -> xfind i j (Node m1 o m2) = Some v. Proof. induction j; intros; destruct i; simpl; simpl in H; auto; try congruence. destruct i; simpl in *; auto. Qed. Lemma xelements_ii : forall (m: t A) (i j : positive) (v: A), List.In (xI i, v) (xelements m (xI j)) -> List.In (i, v) (xelements m j). Proof. induction m. simpl; auto. intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H); apply in_or_app. left; apply IHm1; auto. right; destruct (in_inv H0). injection H1; intros Eq1 Eq2; rewrite Eq1; rewrite Eq2; apply in_eq. apply in_cons; apply IHm2; auto. left; apply IHm1; auto. right; apply IHm2; auto. Qed. Lemma xelements_io : forall (m: t A) (i j : positive) (v: A), ~List.In (xI i, v) (xelements m (xO j)). Proof. induction m. simpl; auto. intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H). apply (IHm1 _ _ _ H0). destruct (in_inv H0). congruence. apply (IHm2 _ _ _ H1). apply (IHm1 _ _ _ H0). apply (IHm2 _ _ _ H0). Qed. Lemma xelements_oo : forall (m: t A) (i j : positive) (v: A), List.In (xO i, v) (xelements m (xO j)) -> List.In (i, v) (xelements m j). Proof. induction m. simpl; auto. intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H); apply in_or_app. left; apply IHm1; auto. right; destruct (in_inv H0). injection H1; intros Eq1 Eq2; rewrite Eq1; rewrite Eq2; apply in_eq. apply in_cons; apply IHm2; auto. left; apply IHm1; auto. right; apply IHm2; auto. Qed. Lemma xelements_oi : forall (m: t A) (i j : positive) (v: A), ~List.In (xO i, v) (xelements m (xI j)). Proof. induction m. simpl; auto. intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H). apply (IHm1 _ _ _ H0). destruct (in_inv H0). congruence. apply (IHm2 _ _ _ H1). apply (IHm1 _ _ _ H0). apply (IHm2 _ _ _ H0). Qed. Lemma xelements_ih : forall (m1 m2: t A) (o: option A) (i : positive) (v: A), List.In (xI i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m2 xH). Proof. destruct o; simpl; intros; destruct (in_app_or _ _ _ H). absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto. destruct (in_inv H0). congruence. apply xelements_ii; auto. absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto. apply xelements_ii; auto. Qed. Lemma xelements_oh : forall (m1 m2: t A) (o: option A) (i : positive) (v: A), List.In (xO i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m1 xH). Proof. destruct o; simpl; intros; destruct (in_app_or _ _ _ H). apply xelements_oo; auto. destruct (in_inv H0). congruence. absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto. apply xelements_oo; auto. absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto. Qed. Lemma xelements_hi : forall (m: t A) (i : positive) (v: A), ~List.In (xH, v) (xelements m (xI i)). Proof. induction m; intros. simpl; auto. destruct o; simpl; intro H; destruct (in_app_or _ _ _ H). generalize H0; apply IHm1; auto. destruct (in_inv H0). congruence. generalize H1; apply IHm2; auto. generalize H0; apply IHm1; auto. generalize H0; apply IHm2; auto. Qed. Lemma xelements_ho : forall (m: t A) (i : positive) (v: A), ~List.In (xH, v) (xelements m (xO i)). Proof. induction m; intros. simpl; auto. destruct o; simpl; intro H; destruct (in_app_or _ _ _ H). generalize H0; apply IHm1; auto. destruct (in_inv H0). congruence. generalize H1; apply IHm2; auto. generalize H0; apply IHm1; auto. generalize H0; apply IHm2; auto. Qed. Lemma find_xfind_h : forall (m: t A) (i: positive), find i m = xfind i xH m. Proof. destruct i; simpl; auto. Qed. Lemma xelements_complete: forall (i j : positive) (m: t A) (v: A), List.In (i, v) (xelements m j) -> xfind i j m = Some v. Proof. induction i; simpl; intros; destruct j; simpl. apply IHi; apply xelements_ii; auto. absurd (List.In (xI i, v) (xelements m (xO j))); auto; apply xelements_io. destruct m. simpl in H; tauto. rewrite find_xfind_h. apply IHi. apply (xelements_ih _ _ _ _ _ H). absurd (List.In (xO i, v) (xelements m (xI j))); auto; apply xelements_oi. apply IHi; apply xelements_oo; auto. destruct m. simpl in H; tauto. rewrite find_xfind_h. apply IHi. apply (xelements_oh _ _ _ _ _ H). absurd (List.In (xH, v) (xelements m (xI j))); auto; apply xelements_hi. absurd (List.In (xH, v) (xelements m (xO j))); auto; apply xelements_ho. destruct m. simpl in H; tauto. destruct o; simpl in H; destruct (in_app_or _ _ _ H). absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho. destruct (in_inv H0). congruence. absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi. absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho. absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi. Qed. Theorem elements_complete: forall (m: t A) (i: positive) (v: A), List.In (i, v) (elements m) -> find i m = Some v. Proof. intros m i v H. unfold elements in H. rewrite find_xfind_h. exact (xelements_complete i xH m v H). Qed. Lemma cardinal_1 : forall (m: t A), cardinal m = length (elements m). Proof. unfold elements. intros m; set (p:=1); clearbody p; revert m p. induction m; simpl; auto; intros. rewrite (IHm1 (append p 2)), (IHm2 (append p 3)); auto. destruct o; rewrite app_length; simpl; omega. Qed. End CompcertSpec. Definition MapsTo (i:positive)(v:A)(m:t A) := find i m = Some v. Definition In (i:positive)(m:t A) := exists e:A, MapsTo i e m. Definition Empty m := forall (a : positive)(e:A) , ~ MapsTo a e m. Definition eq_key (p p':positive*A) := E.eq (fst p) (fst p'). Definition eq_key_elt (p p':positive*A) := E.eq (fst p) (fst p') /\ (snd p) = (snd p'). Definition lt_key (p p':positive*A) := E.lt (fst p) (fst p'). Global Program Instance eqk_equiv : Equivalence eq_key. Global Program Instance eqke_equiv : Equivalence eq_key_elt. Global Program Instance ltk_strorder : StrictOrder lt_key. Lemma mem_find : forall m x, mem x m = match find x m with None => false | _ => true end. Proof. induction m; destruct x; simpl; auto. Qed. Lemma Empty_alt : forall m, Empty m <-> forall a, find a m = None. Proof. unfold Empty, MapsTo. intuition. generalize (H a). destruct (find a m); intuition. elim (H0 a0); auto. rewrite H in H0; discriminate. Qed. Lemma Empty_Node : forall l o r, Empty (Node l o r) <-> o=None /\ Empty l /\ Empty r. Proof. intros l o r. split. rewrite Empty_alt. split. destruct o; auto. generalize (H 1); simpl; auto. split; rewrite Empty_alt; intros. generalize (H (xO a)); auto. generalize (H (xI a)); auto. intros (H,(H0,H1)). subst. rewrite Empty_alt; intros. destruct a; auto. simpl; generalize H1; rewrite Empty_alt; auto. simpl; generalize H0; rewrite Empty_alt; auto. Qed. Section FMapSpec. Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. unfold In, MapsTo; intros m x; rewrite mem_find. destruct 1 as (e0,H0); rewrite H0; auto. Qed. Lemma mem_2 : forall m x, mem x m = true -> In x m. Proof. unfold In, MapsTo; intros m x; rewrite mem_find. destruct (find x m). exists a; auto. intros; discriminate. Qed. Variable m m' m'' : t A. Variable x y z : key. Variable e e' : A. Lemma MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m. Proof. intros; rewrite <- H; auto. Qed. Lemma find_1 : MapsTo x e m -> find x m = Some e. Proof. unfold MapsTo; auto. Qed. Lemma find_2 : find x m = Some e -> MapsTo x e m. Proof. red; auto. Qed. Lemma empty_1 : Empty empty. Proof. rewrite Empty_alt; apply gempty. Qed. Lemma is_empty_1 : Empty m -> is_empty m = true. Proof. induction m; simpl; auto. rewrite Empty_Node. intros (H,(H0,H1)). subst; simpl. rewrite IHt0_1; simpl; auto. Qed. Lemma is_empty_2 : is_empty m = true -> Empty m. Proof. induction m; simpl; auto. rewrite Empty_alt. intros _; exact gempty. rewrite Empty_Node. destruct o. intros; discriminate. intro H; destruct (andb_prop _ _ H); intuition. Qed. Lemma add_1 : E.eq x y -> MapsTo y e (add x e m). Proof. unfold MapsTo. intro H; rewrite H; clear H. apply gss. Qed. Lemma add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. unfold MapsTo. intros; rewrite gso; auto. Qed. Lemma add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. Proof. unfold MapsTo. intro H; rewrite gso; auto. Qed. Lemma remove_1 : E.eq x y -> ~ In y (remove x m). Proof. intros; intro. generalize (mem_1 H0). rewrite mem_find. red in H. rewrite H. rewrite grs. intros; discriminate. Qed. Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. unfold MapsTo. intro H; rewrite gro; auto. Qed. Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. Proof. unfold MapsTo. destruct (E.eq_dec x y). subst. rewrite grs; intros; discriminate. rewrite gro; auto. Qed. Lemma elements_1 : MapsTo x e m -> InA eq_key_elt (x,e) (elements m). Proof. unfold MapsTo. rewrite InA_alt. intro H. exists (x,e). split. red; simpl; unfold E.eq; auto. apply elements_correct; auto. Qed. Lemma elements_2 : InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. unfold MapsTo. rewrite InA_alt. intros ((e0,a),(H,H0)). red in H; simpl in H; unfold E.eq in H; destruct H; subst. apply elements_complete; auto. Qed. Lemma xelements_bits_lt_1 : forall p p0 q m v, List.In (p0,v) (xelements m (append p (xO q))) -> E.bits_lt p0 p. Proof. intros. generalize (xelements_complete _ _ _ _ H); clear H; intros. revert p0 q m v H. induction p; destruct p0; simpl; intros; eauto; try discriminate. Qed. Lemma xelements_bits_lt_2 : forall p p0 q m v, List.In (p0,v) (xelements m (append p (xI q))) -> E.bits_lt p p0. Proof. intros. generalize (xelements_complete _ _ _ _ H); clear H; intros. revert p0 q m v H. induction p; destruct p0; simpl; intros; eauto; try discriminate. Qed. Lemma xelements_sort : forall p, sort lt_key (xelements m p). Proof. induction m. simpl; auto. destruct o; simpl; intros. (* Some *) apply (SortA_app (eqA:=eq_key_elt)); auto with *. constructor; auto. apply In_InfA; intros. destruct y0. red; red; simpl. eapply xelements_bits_lt_2; eauto. intros x0 y0. do 2 rewrite InA_alt. intros (y1,(Hy1,H)) (y2,(Hy2,H0)). destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst. destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst. red; red; simpl. destruct H0. injection H0; clear H0; intros _ H0; subst. eapply xelements_bits_lt_1; eauto. apply E.bits_lt_trans with p. eapply xelements_bits_lt_1; eauto. eapply xelements_bits_lt_2; eauto. (* None *) apply (SortA_app (eqA:=eq_key_elt)); auto with *. intros x0 y0. do 2 rewrite InA_alt. intros (y1,(Hy1,H)) (y2,(Hy2,H0)). destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst. destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst. red; red; simpl. apply E.bits_lt_trans with p. eapply xelements_bits_lt_1; eauto. eapply xelements_bits_lt_2; eauto. Qed. Lemma elements_3 : sort lt_key (elements m). Proof. unfold elements. apply xelements_sort; auto. Qed. Lemma elements_3w : NoDupA eq_key (elements m). Proof. change eq_key with (@ME.eqk A). apply ME.Sort_NoDupA; apply elements_3; auto. Qed. End FMapSpec. (** [map] and [mapi] *) Variable B : Type. Section Mapi. Variable f : positive -> A -> B. Fixpoint xmapi (m : t A) (i : positive) : t B := match m with | Leaf => @Leaf B | Node l o r => Node (xmapi l (append i (xO xH))) (option_map (f i) o) (xmapi r (append i (xI xH))) end. Definition mapi m := xmapi m xH. End Mapi. Definition map (f : A -> B) m := mapi (fun _ => f) m. End A. Lemma xgmapi: forall (A B: Type) (f: positive -> A -> B) (i j : positive) (m: t A), find i (xmapi f m j) = option_map (f (append j i)) (find i m). Proof. induction i; intros; destruct m; simpl; auto. rewrite (append_assoc_1 j i); apply IHi. rewrite (append_assoc_0 j i); apply IHi. rewrite (append_neutral_r j); auto. Qed. Theorem gmapi: forall (A B: Type) (f: positive -> A -> B) (i: positive) (m: t A), find i (mapi f m) = option_map (f i) (find i m). Proof. intros. unfold mapi. replace (f i) with (f (append xH i)). apply xgmapi. rewrite append_neutral_l; auto. Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros. exists x. split; [red; auto|]. apply find_2. generalize (find_1 H); clear H; intros. rewrite gmapi. rewrite H. simpl; auto. Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. intros. apply mem_2. rewrite mem_find. destruct H as (v,H). generalize (find_1 H); clear H; intros. rewrite gmapi in H. destruct (find x m); auto. simpl in *; discriminate. Qed. Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros; unfold map. destruct (mapi_1 (fun _ => f) H); intuition. Qed. Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. intros; unfold map in *; eapply mapi_2; eauto. Qed. Section map2. Variable A B C : Type. Variable f : option A -> option B -> option C. Arguments Leaf [A]. Fixpoint xmap2_l (m : t A) : t C := match m with | Leaf => Leaf | Node l o r => Node (xmap2_l l) (f o None) (xmap2_l r) end. Lemma xgmap2_l : forall (i : positive) (m : t A), f None None = None -> find i (xmap2_l m) = f (find i m) None. Proof. induction i; intros; destruct m; simpl; auto. Qed. Fixpoint xmap2_r (m : t B) : t C := match m with | Leaf => Leaf | Node l o r => Node (xmap2_r l) (f None o) (xmap2_r r) end. Lemma xgmap2_r : forall (i : positive) (m : t B), f None None = None -> find i (xmap2_r m) = f None (find i m). Proof. induction i; intros; destruct m; simpl; auto. Qed. Fixpoint _map2 (m1 : t A)(m2 : t B) : t C := match m1 with | Leaf => xmap2_r m2 | Node l1 o1 r1 => match m2 with | Leaf => xmap2_l m1 | Node l2 o2 r2 => Node (_map2 l1 l2) (f o1 o2) (_map2 r1 r2) end end. Lemma gmap2: forall (i: positive)(m1:t A)(m2: t B), f None None = None -> find i (_map2 m1 m2) = f (find i m1) (find i m2). Proof. induction i; intros; destruct m1; destruct m2; simpl; auto; try apply xgmap2_r; try apply xgmap2_l; auto. Qed. End map2. Definition map2 (elt elt' elt'':Type)(f:option elt->option elt'->option elt'') := _map2 (fun o1 o2 => match o1,o2 with None,None => None | _, _ => f o1 o2 end). Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x m \/ In x m' -> find x (map2 f m m') = f (find x m) (find x m'). Proof. intros. unfold map2. rewrite gmap2; auto. generalize (@mem_1 _ m x) (@mem_1 _ m' x). do 2 rewrite mem_find. destruct (find x m); simpl; auto. destruct (find x m'); simpl; auto. intros. destruct H; intuition; try discriminate. Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Proof. intros. generalize (mem_1 H); clear H; intros. rewrite mem_find in H. unfold map2 in H. rewrite gmap2 in H; auto. generalize (@mem_2 _ m x) (@mem_2 _ m' x). do 2 rewrite mem_find. destruct (find x m); simpl in *; auto. destruct (find x m'); simpl in *; auto. Qed. Section Fold. Variables A B : Type. Variable f : positive -> A -> B -> B. Fixpoint xfoldi (m : t A) (v : B) (i : positive) := match m with | Leaf => v | Node l (Some x) r => xfoldi r (f i x (xfoldi l v (append i 2))) (append i 3) | Node l None r => xfoldi r (xfoldi l v (append i 2)) (append i 3) end. Lemma xfoldi_1 : forall m v i, xfoldi m v i = fold_left (fun a p => f (fst p) (snd p) a) (xelements m i) v. Proof. set (F := fun a p => f (fst p) (snd p) a). induction m; intros; simpl; auto. destruct o. rewrite fold_left_app; simpl. rewrite <- IHm1. rewrite <- IHm2. unfold F; simpl; reflexivity. rewrite fold_left_app; simpl. rewrite <- IHm1. rewrite <- IHm2. reflexivity. Qed. Definition fold m i := xfoldi m i 1. End Fold. Lemma fold_1 : forall (A:Type)(m:t A)(B:Type)(i : B) (f : key -> A -> B -> B), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros; unfold fold, elements. rewrite xfoldi_1; reflexivity. Qed. Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) : bool := match m1, m2 with | Leaf, _ => is_empty m2 | _, Leaf => is_empty m1 | Node l1 o1 r1, Node l2 o2 r2 => (match o1, o2 with | None, None => true | Some v1, Some v2 => cmp v1 v2 | _, _ => false end) && equal cmp l1 l2 && equal cmp r1 r2 end. Definition Equal (A:Type)(m m':t A) := forall y, find y m = find y m'. Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' := (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb (A:Type)(cmp: A->A->bool) := Equiv (Cmp cmp). Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool), Equivb cmp m m' -> equal cmp m m' = true. Proof. induction m. (* m = Leaf *) destruct 1. simpl. apply is_empty_1. red; red; intros. assert (In a (Leaf A)). rewrite H. exists e; auto. destruct H2; red in H2. destruct a; simpl in *; discriminate. (* m = Node *) destruct m'. (* m' = Leaf *) destruct 1. simpl. destruct o. assert (In xH (Leaf A)). rewrite <- H. exists a; red; auto. destruct H1; red in H1; simpl in H1; discriminate. apply andb_true_intro; split; apply is_empty_1; red; red; intros. assert (In (xO a) (Leaf A)). rewrite <- H. exists e; auto. destruct H2; red in H2; simpl in H2; discriminate. assert (In (xI a) (Leaf A)). rewrite <- H. exists e; auto. destruct H2; red in H2; simpl in H2; discriminate. (* m' = Node *) destruct 1. assert (Equivb cmp m1 m'1). split. intros k; generalize (H (xO k)); unfold In, MapsTo; simpl; auto. intros k e e'; generalize (H0 (xO k) e e'); unfold In, MapsTo; simpl; auto. assert (Equivb cmp m2 m'2). split. intros k; generalize (H (xI k)); unfold In, MapsTo; simpl; auto. intros k e e'; generalize (H0 (xI k) e e'); unfold In, MapsTo; simpl; auto. simpl. destruct o; destruct o0; simpl. repeat (apply andb_true_intro; split); auto. apply (H0 xH); red; auto. generalize (H xH); unfold In, MapsTo; simpl; intuition. destruct H4; try discriminate; eauto. generalize (H xH); unfold In, MapsTo; simpl; intuition. destruct H5; try discriminate; eauto. apply andb_true_intro; split; auto. Qed. Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool), equal cmp m m' = true -> Equivb cmp m m'. Proof. induction m. (* m = Leaf *) simpl. split; intros. split. destruct 1; red in H0; destruct k; discriminate. destruct 1; elim (is_empty_2 H H0). red in H0; destruct k; discriminate. (* m = Node *) destruct m'. (* m' = Leaf *) simpl. destruct o; intros; try discriminate. destruct (andb_prop _ _ H); clear H. split; intros. split; unfold In, MapsTo; destruct 1. destruct k; simpl in *; try discriminate. destruct (is_empty_2 H1 (find_2 _ _ H)). destruct (is_empty_2 H0 (find_2 _ _ H)). destruct k; simpl in *; discriminate. unfold In, MapsTo; destruct k; simpl in *; discriminate. (* m' = Node *) destruct o; destruct o0; simpl; intros; try discriminate. destruct (andb_prop _ _ H); clear H. destruct (andb_prop _ _ H0); clear H0. destruct (IHm1 _ _ H2); clear H2 IHm1. destruct (IHm2 _ _ H1); clear H1 IHm2. split; intros. destruct k; unfold In, MapsTo in *; simpl; auto. split; eauto. destruct k; unfold In, MapsTo in *; simpl in *. eapply H4; eauto. eapply H3; eauto. congruence. destruct (andb_prop _ _ H); clear H. destruct (IHm1 _ _ H0); clear H0 IHm1. destruct (IHm2 _ _ H1); clear H1 IHm2. split; intros. destruct k; unfold In, MapsTo in *; simpl; auto. split; eauto. destruct k; unfold In, MapsTo in *; simpl in *. eapply H3; eauto. eapply H2; eauto. try discriminate. Qed. End PositiveMap. (** Here come some additionnal facts about this implementation. Most are facts that cannot be derivable from the general interface. *) Module PositiveMapAdditionalFacts. Import PositiveMap. (* Derivable from the Map interface *) Theorem gsspec: forall (A:Type)(i j: positive) (x: A) (m: t A), find i (add j x m) = if E.eq_dec i j then Some x else find i m. Proof. intros. destruct (E.eq_dec i j); [ rewrite e; apply gss | apply gso; auto ]. Qed. (* Not derivable from the Map interface *) Theorem gsident: forall (A:Type)(i: positive) (m: t A) (v: A), find i m = Some v -> add i v m = m. Proof. induction i; intros; destruct m; simpl; simpl in H; try congruence. rewrite (IHi m2 v H); congruence. rewrite (IHi m1 v H); congruence. Qed. Lemma xmap2_lr : forall (A B : Type)(f g: option A -> option A -> option B)(m : t A), (forall (i j : option A), f i j = g j i) -> xmap2_l f m = xmap2_r g m. Proof. induction m; intros; simpl; auto. rewrite IHm1; auto. rewrite IHm2; auto. rewrite H; auto. Qed. Theorem map2_commut: forall (A B: Type) (f g: option A -> option A -> option B), (forall (i j: option A), f i j = g j i) -> forall (m1 m2: t A), _map2 f m1 m2 = _map2 g m2 m1. Proof. intros A B f g Eq1. assert (Eq2: forall (i j: option A), g i j = f j i). intros; auto. induction m1; intros; destruct m2; simpl; try rewrite Eq1; repeat rewrite (xmap2_lr f g); repeat rewrite (xmap2_lr g f); auto. rewrite IHm1_1. rewrite IHm1_2. auto. Qed. End PositiveMapAdditionalFacts. coq-8.4pl4/theories/FSets/FSetWeakList.v0000644000175000017500000000211612326224777017175 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* E.eq x y \/ In y s. Definition add : forall (x : elt) (s : t), {s' : t | Add x s s'}. Proof. intros; exists (add x s); auto. unfold Add; intuition. elim (E.eq_dec x y); auto. intros; right. eapply add_3; eauto. Qed. Definition singleton : forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}. Proof. intros; exists (singleton x); intuition. Qed. Definition remove : forall (x : elt) (s : t), {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}. Proof. intros; exists (remove x s); intuition. absurd (In x (remove x s)); auto with set. apply In_1 with y; auto. elim (E.eq_dec x y); intros; auto. absurd (In x (remove x s)); auto with set. apply In_1 with y; auto. eauto with set. Qed. Definition union : forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}. Proof. intros; exists (union s s'); intuition. Qed. Definition inter : forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}. Proof. intros; exists (inter s s'); intuition; eauto with set. Qed. Definition diff : forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}. Proof. intros; exists (diff s s'); intuition; eauto with set. absurd (In x s'); eauto with set. Qed. Definition equal : forall s s' : t, {Equal s s'} + {~ Equal s s'}. Proof. intros. generalize (equal_1 (s:=s) (s':=s')) (equal_2 (s:=s) (s':=s')). case (equal s s'); intuition. Qed. Definition subset : forall s s' : t, {Subset s s'} + {~Subset s s'}. Proof. intros. generalize (subset_1 (s:=s) (s':=s')) (subset_2 (s:=s) (s':=s')). case (subset s s'); intuition. Qed. Definition elements : forall s : t, {l : list elt | sort E.lt l /\ (forall x : elt, In x s <-> InA E.eq x l)}. Proof. intros; exists (elements s); intuition. Defined. Definition fold : forall (A : Type) (f : elt -> A -> A) (s : t) (i : A), {r : A | let (l,_) := elements s in r = fold_left (fun a e => f e a) l i}. Proof. intros; exists (fold (A:=A) f s i); exact (fold_1 s i f). Qed. Definition cardinal : forall s : t, {r : nat | let (l,_) := elements s in r = length l }. Proof. intros; exists (cardinal s); exact (cardinal_1 s). Qed. Definition fdec (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (x : elt) := if Pdec x then true else false. Lemma compat_P_aux : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}), compat_P E.eq P -> compat_bool E.eq (fdec Pdec). Proof. unfold compat_P, compat_bool, Proper, respectful, fdec; intros. generalize (E.eq_sym H0); case (Pdec x); case (Pdec y); firstorder. Qed. Hint Resolve compat_P_aux. Definition filter : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}. Proof. intros. exists (filter (fdec Pdec) s). intro H; assert (compat_bool E.eq (fdec Pdec)); auto. intuition. eauto with set. generalize (filter_2 H0 H1). unfold fdec. case (Pdec x); intuition. inversion H2. apply filter_3; auto. unfold fdec; simpl. case (Pdec x); intuition. Qed. Definition for_all : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}. Proof. intros. generalize (for_all_1 (s:=s) (f:=fdec Pdec)) (for_all_2 (s:=s) (f:=fdec Pdec)). case (for_all (fdec Pdec) s); unfold For_all; [ left | right ]; intros. assert (compat_bool E.eq (fdec Pdec)); auto. generalize (H0 H3 Logic.eq_refl _ H2). unfold fdec. case (Pdec x); intuition. inversion H4. intuition. absurd (false = true); [ auto with bool | apply H; auto ]. intro. unfold fdec. case (Pdec x); intuition. Qed. Definition exists_ : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}. Proof. intros. generalize (exists_1 (s:=s) (f:=fdec Pdec)) (exists_2 (s:=s) (f:=fdec Pdec)). case (exists_ (fdec Pdec) s); unfold Exists; [ left | right ]; intros. elim H0; auto; intros. exists x; intuition. generalize H4. unfold fdec. case (Pdec x); intuition. inversion H2. intuition. elim H2; intros. absurd (false = true); [ auto with bool | apply H; auto ]. exists x; intuition. unfold fdec. case (Pdec x); intuition. Qed. Definition partition : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {partition : t * t | let (s1, s2) := partition in compat_P E.eq P -> For_all P s1 /\ For_all (fun x => ~ P x) s2 /\ (forall x : elt, In x s <-> In x s1 \/ In x s2)}. Proof. intros. exists (partition (fdec Pdec) s). generalize (partition_1 s (f:=fdec Pdec)) (partition_2 s (f:=fdec Pdec)). case (partition (fdec Pdec) s). intros s1 s2; simpl. intros; assert (compat_bool E.eq (fdec Pdec)); auto. intros; assert (compat_bool E.eq (fun x => negb (fdec Pdec x))). generalize H2; unfold compat_bool, Proper, respectful; intuition; apply (f_equal negb); auto. intuition. generalize H4; unfold For_all, Equal; intuition. elim (H0 x); intros. assert (fdec Pdec x = true). eapply filter_2; eauto with set. generalize H8; unfold fdec; case (Pdec x); intuition. inversion H9. generalize H; unfold For_all, Equal; intuition. elim (H0 x); intros. cut ((fun x => negb (fdec Pdec x)) x = true). unfold fdec; case (Pdec x); intuition. change ((fun x => negb (fdec Pdec x)) x = true). apply (filter_2 (s:=s) (x:=x)); auto. set (b := fdec Pdec x) in *; generalize (Logic.eq_refl b); pattern b at -1; case b; unfold b; [ left | right ]. elim (H4 x); intros _ B; apply B; auto with set. elim (H x); intros _ B; apply B; auto with set. apply filter_3; auto. rewrite H5; auto. eapply (filter_1 (s:=s) (x:=x) H2); elim (H4 x); intros B _; apply B; auto. eapply (filter_1 (s:=s) (x:=x) H3); elim (H x); intros B _; apply B; auto. Qed. Definition choose_aux: forall s : t, { x : elt | M.choose s = Some x } + { M.choose s = None }. Proof. intros. destruct (M.choose s); [left | right]; auto. exists e; auto. Qed. Definition choose : forall s : t, {x : elt | In x s} + {Empty s}. Proof. intros; destruct (choose_aux s) as [(x,Hx)|H]. left; exists x; apply choose_1; auto. right; apply choose_2; auto. Defined. Lemma choose_ok1 : forall s x, M.choose s = Some x <-> exists H:In x s, choose s = inleft _ (exist (fun x => In x s) x H). Proof. intros s x. unfold choose; split; intros. destruct (choose_aux s) as [(y,Hy)|H']; try congruence. replace x with y in * by congruence. exists (choose_1 Hy); auto. destruct H. destruct (choose_aux s) as [(y,Hy)|H']; congruence. Qed. Lemma choose_ok2 : forall s, M.choose s = None <-> exists H:Empty s, choose s = inright _ H. Proof. intros s. unfold choose; split; intros. destruct (choose_aux s) as [(y,Hy)|H']; try congruence. exists (choose_2 H'); auto. destruct H. destruct (choose_aux s) as [(y,Hy)|H']; congruence. Qed. Lemma choose_equal : forall s s', Equal s s' -> match choose s, choose s' with | inleft (exist x _), inleft (exist x' _) => E.eq x x' | inright _, inright _ => True | _, _ => False end. Proof. intros. generalize (@M.choose_1 s)(@M.choose_2 s) (@M.choose_1 s')(@M.choose_2 s')(@M.choose_3 s s') (choose_ok1 s)(choose_ok2 s)(choose_ok1 s')(choose_ok2 s'). destruct (choose s) as [(x,Hx)|Hx]; destruct (choose s') as [(x',Hx')|Hx']; auto; intros. apply H4; auto. rewrite H5; exists Hx; auto. rewrite H7; exists Hx'; auto. apply Hx' with x; unfold Equal in H; rewrite <-H; auto. apply Hx with x'; unfold Equal in H; rewrite H; auto. Qed. Definition min_elt : forall s : t, {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}. Proof. intros; generalize (min_elt_1 (s:=s)) (min_elt_2 (s:=s)) (min_elt_3 (s:=s)). case (min_elt s); [ left | right ]; auto. exists e; unfold For_all; eauto. Qed. Definition max_elt : forall s : t, {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}. Proof. intros; generalize (max_elt_1 (s:=s)) (max_elt_2 (s:=s)) (max_elt_3 (s:=s)). case (max_elt s); [ left | right ]; auto. exists e; unfold For_all; eauto. Qed. Definition elt := elt. Definition t := t. Definition In := In. Definition Equal s s' := forall a : elt, In a s <-> In a s'. Definition Subset s s' := forall a : elt, In a s -> In a s'. Definition Empty s := forall a : elt, ~ In a s. Definition For_all (P : elt -> Prop) (s : t) := forall x : elt, In x s -> P x. Definition Exists (P : elt -> Prop) (s : t) := exists x : elt, In x s /\ P x. Definition eq_In := In_1. Definition eq := Equal. Definition lt := lt. Definition eq_refl := eq_refl. Definition eq_sym := eq_sym. Definition eq_trans := eq_trans. Definition lt_trans := lt_trans. Definition lt_not_eq := lt_not_eq. Definition compare := compare. Module E := E. End DepOfNodep. (** * From dependent signature [Sdep] to non-dependent signature [S]. *) Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Import M. Module ME := OrderedTypeFacts E. Definition empty : t := let (s, _) := empty in s. Lemma empty_1 : Empty empty. Proof. unfold empty; case M.empty; auto. Qed. Definition is_empty (s : t) : bool := if is_empty s then true else false. Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true. Proof. intros; unfold is_empty; case (M.is_empty s); auto. Qed. Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. Proof. intro s; unfold is_empty; case (M.is_empty s); auto. intros; discriminate H. Qed. Definition mem (x : elt) (s : t) : bool := if mem x s then true else false. Lemma mem_1 : forall (s : t) (x : elt), In x s -> mem x s = true. Proof. intros; unfold mem; case (M.mem x s); auto. Qed. Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s. Proof. intros s x; unfold mem; case (M.mem x s); auto. intros; discriminate H. Qed. Definition eq_dec := equal. Definition equal (s s' : t) : bool := if equal s s' then true else false. Lemma equal_1 : forall s s' : t, Equal s s' -> equal s s' = true. Proof. intros; unfold equal; case M.equal; intuition. Qed. Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'. Proof. intros s s'; unfold equal; case (M.equal s s'); intuition; inversion H. Qed. Definition subset (s s' : t) : bool := if subset s s' then true else false. Lemma subset_1 : forall s s' : t, Subset s s' -> subset s s' = true. Proof. intros; unfold subset; case M.subset; intuition. Qed. Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'. Proof. intros s s'; unfold subset; case (M.subset s s'); intuition; inversion H. Qed. Definition choose (s : t) : option elt := match choose s with | inleft (exist x _) => Some x | inright _ => None end. Lemma choose_1 : forall (s : t) (x : elt), choose s = Some x -> In x s. Proof. intros s x; unfold choose; case (M.choose s). simple destruct s0; intros; injection H; intros; subst; auto. intros; discriminate H. Qed. Lemma choose_2 : forall s : t, choose s = None -> Empty s. Proof. intro s; unfold choose; case (M.choose s); auto. simple destruct s0; intros; discriminate H. Qed. Lemma choose_3 : forall s s' x x', choose s = Some x -> choose s' = Some x' -> Equal s s' -> E.eq x x'. Proof. unfold choose; intros. generalize (M.choose_equal H1); clear H1. destruct (M.choose s) as [(?,?)|?]; destruct (M.choose s') as [(?,?)|?]; simpl; auto; congruence. Qed. Definition elements (s : t) : list elt := let (l, _) := elements s in l. Lemma elements_1 : forall (s : t) (x : elt), In x s -> InA E.eq x (elements s). Proof. intros; unfold elements; case (M.elements s); firstorder. Qed. Lemma elements_2 : forall (s : t) (x : elt), InA E.eq x (elements s) -> In x s. Proof. intros s x; unfold elements; case (M.elements s); firstorder. Qed. Lemma elements_3 : forall s : t, sort E.lt (elements s). Proof. intros; unfold elements; case (M.elements s); firstorder. Qed. Hint Resolve elements_3. Lemma elements_3w : forall s : t, NoDupA E.eq (elements s). Proof. auto. Qed. Definition min_elt (s : t) : option elt := match min_elt s with | inleft (exist x _) => Some x | inright _ => None end. Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. Proof. intros s x; unfold min_elt; case (M.min_elt s). simple destruct s0; intros; injection H; intros; subst; intuition. intros; discriminate H. Qed. Lemma min_elt_2 : forall (s : t) (x y : elt), min_elt s = Some x -> In y s -> ~ E.lt y x. Proof. intros s x y; unfold min_elt; case (M.min_elt s). unfold For_all; simple destruct s0; intros; injection H; intros; subst; firstorder. intros; discriminate H. Qed. Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s. Proof. intros s; unfold min_elt; case (M.min_elt s); auto. simple destruct s0; intros; discriminate H. Qed. Definition max_elt (s : t) : option elt := match max_elt s with | inleft (exist x _) => Some x | inright _ => None end. Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. Proof. intros s x; unfold max_elt; case (M.max_elt s). simple destruct s0; intros; injection H; intros; subst; intuition. intros; discriminate H. Qed. Lemma max_elt_2 : forall (s : t) (x y : elt), max_elt s = Some x -> In y s -> ~ E.lt x y. Proof. intros s x y; unfold max_elt; case (M.max_elt s). unfold For_all; simple destruct s0; intros; injection H; intros; subst; firstorder. intros; discriminate H. Qed. Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s. Proof. intros s; unfold max_elt; case (M.max_elt s); auto. simple destruct s0; intros; discriminate H. Qed. Definition add (x : elt) (s : t) : t := let (s', _) := add x s in s'. Lemma add_1 : forall (s : t) (x y : elt), E.eq x y -> In y (add x s). Proof. intros; unfold add; case (M.add x s); unfold Add; firstorder. Qed. Lemma add_2 : forall (s : t) (x y : elt), In y s -> In y (add x s). Proof. intros; unfold add; case (M.add x s); unfold Add; firstorder. Qed. Lemma add_3 : forall (s : t) (x y : elt), ~ E.eq x y -> In y (add x s) -> In y s. Proof. intros s x y; unfold add; case (M.add x s); unfold Add; firstorder. Qed. Definition remove (x : elt) (s : t) : t := let (s', _) := remove x s in s'. Lemma remove_1 : forall (s : t) (x y : elt), E.eq x y -> ~ In y (remove x s). Proof. intros; unfold remove; case (M.remove x s); firstorder. Qed. Lemma remove_2 : forall (s : t) (x y : elt), ~ E.eq x y -> In y s -> In y (remove x s). Proof. intros; unfold remove; case (M.remove x s); firstorder. Qed. Lemma remove_3 : forall (s : t) (x y : elt), In y (remove x s) -> In y s. Proof. intros s x y; unfold remove; case (M.remove x s); firstorder. Qed. Definition singleton (x : elt) : t := let (s, _) := singleton x in s. Lemma singleton_1 : forall x y : elt, In y (singleton x) -> E.eq x y. Proof. intros x y; unfold singleton; case (M.singleton x); firstorder. Qed. Lemma singleton_2 : forall x y : elt, E.eq x y -> In y (singleton x). Proof. intros x y; unfold singleton; case (M.singleton x); firstorder. Qed. Definition union (s s' : t) : t := let (s'', _) := union s s' in s''. Lemma union_1 : forall (s s' : t) (x : elt), In x (union s s') -> In x s \/ In x s'. Proof. intros s s' x; unfold union; case (M.union s s'); firstorder. Qed. Lemma union_2 : forall (s s' : t) (x : elt), In x s -> In x (union s s'). Proof. intros s s' x; unfold union; case (M.union s s'); firstorder. Qed. Lemma union_3 : forall (s s' : t) (x : elt), In x s' -> In x (union s s'). Proof. intros s s' x; unfold union; case (M.union s s'); firstorder. Qed. Definition inter (s s' : t) : t := let (s'', _) := inter s s' in s''. Lemma inter_1 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s. Proof. intros s s' x; unfold inter; case (M.inter s s'); firstorder. Qed. Lemma inter_2 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s'. Proof. intros s s' x; unfold inter; case (M.inter s s'); firstorder. Qed. Lemma inter_3 : forall (s s' : t) (x : elt), In x s -> In x s' -> In x (inter s s'). Proof. intros s s' x; unfold inter; case (M.inter s s'); firstorder. Qed. Definition diff (s s' : t) : t := let (s'', _) := diff s s' in s''. Lemma diff_1 : forall (s s' : t) (x : elt), In x (diff s s') -> In x s. Proof. intros s s' x; unfold diff; case (M.diff s s'); firstorder. Qed. Lemma diff_2 : forall (s s' : t) (x : elt), In x (diff s s') -> ~ In x s'. Proof. intros s s' x; unfold diff; case (M.diff s s'); firstorder. Qed. Lemma diff_3 : forall (s s' : t) (x : elt), In x s -> ~ In x s' -> In x (diff s s'). Proof. intros s s' x; unfold diff; case (M.diff s s'); firstorder. Qed. Definition cardinal (s : t) : nat := let (f, _) := cardinal s in f. Lemma cardinal_1 : forall s, cardinal s = length (elements s). Proof. intros; unfold cardinal; case (M.cardinal s); unfold elements in *; destruct (M.elements s); auto. Qed. Definition fold (B : Type) (f : elt -> B -> B) (i : t) (s : B) : B := let (fold, _) := fold f i s in fold. Lemma fold_1 : forall (s : t) (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. Proof. intros; unfold fold; case (M.fold f s i); unfold elements in *; destruct (M.elements s); auto. Qed. Definition f_dec : forall (f : elt -> bool) (x : elt), {f x = true} + {f x <> true}. Proof. intros; case (f x); auto with bool. Defined. Lemma compat_P_aux : forall f : elt -> bool, compat_bool E.eq f -> compat_P E.eq (fun x => f x = true). Proof. unfold compat_bool, compat_P, Proper, respectful, impl; intros; rewrite <- H1; firstorder. Qed. Hint Resolve compat_P_aux. Definition filter (f : elt -> bool) (s : t) : t := let (s', _) := filter (P:=fun x => f x = true) (f_dec f) s in s'. Lemma filter_1 : forall (s : t) (x : elt) (f : elt -> bool), compat_bool E.eq f -> In x (filter f s) -> In x s. Proof. intros s x f; unfold filter; case M.filter; intuition. generalize (i (compat_P_aux H)); firstorder. Qed. Lemma filter_2 : forall (s : t) (x : elt) (f : elt -> bool), compat_bool E.eq f -> In x (filter f s) -> f x = true. Proof. intros s x f; unfold filter; case M.filter; intuition. generalize (i (compat_P_aux H)); firstorder. Qed. Lemma filter_3 : forall (s : t) (x : elt) (f : elt -> bool), compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). Proof. intros s x f; unfold filter; case M.filter; intuition. generalize (i (compat_P_aux H)); firstorder. Qed. Definition for_all (f : elt -> bool) (s : t) : bool := if for_all (P:=fun x => f x = true) (f_dec f) s then true else false. Lemma for_all_1 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true. Proof. intros s f; unfold for_all; case M.for_all; intuition; elim n; auto. Qed. Lemma for_all_2 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s. Proof. intros s f; unfold for_all; case M.for_all; intuition; inversion H0. Qed. Definition exists_ (f : elt -> bool) (s : t) : bool := if exists_ (P:=fun x => f x = true) (f_dec f) s then true else false. Lemma exists_1 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. Proof. intros s f; unfold exists_; case M.exists_; intuition; elim n; auto. Qed. Lemma exists_2 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. Proof. intros s f; unfold exists_; case M.exists_; intuition; inversion H0. Qed. Definition partition (f : elt -> bool) (s : t) : t * t := let (p, _) := partition (P:=fun x => f x = true) (f_dec f) s in p. Lemma partition_1 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). Proof. intros s f; unfold partition; case M.partition. intro p; case p; clear p; intros s1 s2 H C. generalize (H (compat_P_aux C)); clear H; intro H. simpl; unfold Equal; intuition. apply filter_3; firstorder. elim (H2 a); intros. assert (In a s). eapply filter_1; eauto. elim H3; intros; auto. absurd (f a = true). exact (H a H6). eapply filter_2; eauto. Qed. Lemma partition_2 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). Proof. intros s f; unfold partition; case M.partition. intro p; case p; clear p; intros s1 s2 H C. generalize (H (compat_P_aux C)); clear H; intro H. assert (D : compat_bool E.eq (fun x => negb (f x))). generalize C; unfold compat_bool, Proper, respectful; intros; apply (f_equal negb); auto. simpl; unfold Equal; intuition. apply filter_3; firstorder. elim (H2 a); intros. assert (In a s). eapply filter_1; eauto. elim H3; intros; auto. absurd (f a = true). intro. generalize (filter_2 D H1). rewrite H7; intros H8; inversion H8. exact (H0 a H6). Qed. Definition elt := elt. Definition t := t. Definition In := In. Definition Equal s s' := forall a : elt, In a s <-> In a s'. Definition Subset s s' := forall a : elt, In a s -> In a s'. Definition Add (x : elt) (s s' : t) := forall y : elt, In y s' <-> E.eq y x \/ In y s. Definition Empty s := forall a : elt, ~ In a s. Definition For_all (P : elt -> Prop) (s : t) := forall x : elt, In x s -> P x. Definition Exists (P : elt -> Prop) (s : t) := exists x : elt, In x s /\ P x. Definition In_1 := eq_In. Definition eq := Equal. Definition lt := lt. Definition eq_refl := eq_refl. Definition eq_sym := eq_sym. Definition eq_trans := eq_trans. Definition lt_trans := lt_trans. Definition lt_not_eq := lt_not_eq. Definition compare := compare. Module E := E. End NodepOfDep. coq-8.4pl4/theories/FSets/FMapList.v0000644000175000017500000011160712326224777016355 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* is_empty m = true. Proof. unfold Empty, PX.MapsTo. intros m. case m;auto. intros (k,e) l inlist. absurd (InA eqke (k, e) ((k, e) :: l));auto. Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. Proof. intros m. case m;auto. intros p l abs. inversion abs. Qed. (** * [mem] *) Function mem (k : key) (s : t elt) {struct s} : bool := match s with | nil => false | (k',_) :: l => match X.compare k k' with | LT _ => false | EQ _ => true | GT _ => mem k l end end. Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true. Proof. intros m Hm x; generalize Hm; clear Hm. functional induction (mem x m);intros sorted belong1;trivial. inversion belong1. inversion H. absurd (In x ((k', _x) :: l));try assumption. apply Sort_Inf_NotIn with _x;auto. apply IHb. elim (sort_inv sorted);auto. elim (In_inv belong1);auto. intro abs. absurd (X.eq x k');auto. Qed. Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. Proof. intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo. functional induction (mem x m); intros sorted hyp;try ((inversion hyp);fail). exists _x; auto. induction IHb; auto. exists x0; auto. inversion_clear sorted; auto. Qed. (** * [find] *) Function find (k:key) (s: t elt) {struct s} : option elt := match s with | nil => None | (k',x)::s' => match X.compare k k' with | LT _ => None | EQ _ => Some x | GT _ => find k s' end end. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m x. unfold PX.MapsTo. functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto. Qed. Lemma find_1 : forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. Proof. intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo. functional induction (find x m);simpl; subst; try clear H_eq_1. inversion 2. inversion_clear 2. clear e1;compute in H0; destruct H0;order. clear e1;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order. clear e1;inversion_clear 2. compute in H0; destruct H0; intuition congruence. generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order. clear e1; do 2 inversion_clear 1; auto. compute in H2; destruct H2; order. Qed. (** * [add] *) Function add (k : key) (x : elt) (s : t elt) {struct s} : t elt := match s with | nil => (k,x) :: nil | (k',y) :: l => match X.compare k k' with | LT _ => (k,x)::s | EQ _ => (k,x)::l | GT _ => (k',y) :: add k x l end end. Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). Proof. intros m x y e; generalize y; clear y. unfold PX.MapsTo. functional induction (add x e m);simpl;auto. Qed. Lemma add_2 : forall m x y e e', ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo. functional induction (add x e' m) ;simpl;auto; clear e0. subst;auto. intros y' e'' eqky'; inversion_clear 1; destruct H0; simpl in *. order. auto. auto. intros y' e'' eqky'; inversion_clear 1; intuition. Qed. Lemma add_3 : forall m x y e e', ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. Proof. intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo. functional induction (add x e' m);simpl; intros. apply (In_inv_3 H0); compute; auto. apply (In_inv_3 H0); compute; auto. constructor 2; apply (In_inv_3 H0); compute; auto. inversion_clear H0; auto. Qed. Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m). Proof. induction m. simpl; intuition. intros. destruct a as (x'',e''). inversion_clear H. compute in H0,H1. simpl; case (X.compare x x''); intuition. Qed. Hint Resolve add_Inf. Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m). Proof. induction m. simpl; intuition. intros. destruct a as (x',e'). simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. constructor; auto. apply Inf_eq with (x',e'); auto. Qed. (** * [remove] *) Function remove (k : key) (s : t elt) {struct s} : t elt := match s with | nil => nil | (k',x) :: l => match X.compare k k' with | LT _ => s | EQ _ => l | GT _ => (k',x) :: remove k l end end. Lemma remove_1 : forall m (Hm:Sort m) x y, X.eq x y -> ~ In y (remove x m). Proof. intros m Hm x y; generalize Hm; clear Hm. functional induction (remove x m);simpl;intros;subst. red; inversion 1; inversion H1. apply Sort_Inf_NotIn with x0; auto. clear e0;constructor; compute; order. clear e0;inversion_clear Hm. apply Sort_Inf_NotIn with x0; auto. apply Inf_eq with (k',x0);auto; compute; apply X.eq_trans with x; auto. clear e0;inversion_clear Hm. assert (notin:~ In y (remove x l)) by auto. intros (x1,abs). inversion_clear abs. compute in H2; destruct H2; order. apply notin; exists x1; auto. Qed. Lemma remove_2 : forall m (Hm:Sort m) x y e, ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. functional induction (remove x m);subst;auto; match goal with | [H: X.compare _ _ = _ |- _ ] => clear H | _ => idtac end. inversion_clear 3; auto. compute in H1; destruct H1; order. inversion_clear 1; inversion_clear 2; auto. Qed. Lemma remove_3 : forall m (Hm:Sort m) x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. functional induction (remove x m);subst;auto. inversion_clear 1; inversion_clear 1; auto. Qed. Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), Inf (x',e') m -> Inf (x',e') (remove x m). Proof. induction m. simpl; intuition. intros. destruct a as (x'',e''). inversion_clear H. compute in H0. simpl; case (X.compare x x''); intuition. inversion_clear Hm. apply Inf_lt with (x'',e''); auto. Qed. Hint Resolve remove_Inf. Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m). Proof. induction m. simpl; intuition. intros. destruct a as (x',e'). simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. Qed. (** * [elements] *) Definition elements (m: t elt) := m. Lemma elements_1 : forall m x e, MapsTo x e m -> InA eqke (x,e) (elements m). Proof. auto. Qed. Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m. Proof. auto. Qed. Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m). Proof. auto. Qed. Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m). Proof. intros. apply Sort_NoDupA. apply elements_3; auto. Qed. (** * [fold] *) Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) {struct m} : A := match m with | nil => acc | (k,e)::m' => fold f m' (f k e acc) end. Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros; functional induction (fold f m i); auto. Qed. (** * [equal] *) Function equal (cmp:elt->elt->bool)(m m' : t elt) {struct m} : bool := match m, m' with | nil, nil => true | (x,e)::l, (x',e')::l' => match X.compare x x' with | EQ _ => cmp e e' && equal cmp l l' | _ => false end | _, _ => false end. Definition Equivb cmp m m' := (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, Equivb cmp m m' -> equal cmp m m' = true. Proof. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; intuition; subst. match goal with H: X.compare _ _ = _ |- _ => clear H end. assert (cmp_e_e':cmp e e' = true). apply H1 with x; auto. rewrite cmp_e_e'; simpl. apply IHb; auto. inversion_clear Hm; auto. inversion_clear Hm'; auto. unfold Equivb; intuition. destruct (H0 k). assert (In k ((x,e) ::l)). destruct H as (e'', hyp); exists e''; auto. destruct (In_inv (H2 H4)); auto. inversion_clear Hm. elim (Sort_Inf_NotIn H6 H7). destruct H as (e'', hyp); exists e''; auto. apply MapsTo_eq with k; auto; order. destruct (H0 k). assert (In k ((x',e') ::l')). destruct H as (e'', hyp); exists e''; auto. destruct (In_inv (H3 H4)); auto. inversion_clear Hm'. elim (Sort_Inf_NotIn H6 H7). destruct H as (e'', hyp); exists e''; auto. apply MapsTo_eq with k; auto; order. apply H1 with k; destruct (X.eq_dec x k); auto. destruct (X.compare x x'); try contradiction; clear y. destruct (H0 x). assert (In x ((x',e')::l')). apply H; auto. exists e; auto. destruct (In_inv H3). order. inversion_clear Hm'. assert (Inf (x,e) l'). apply Inf_lt with (x',e'); auto. elim (Sort_Inf_NotIn H5 H7 H4). destruct (H0 x'). assert (In x' ((x,e)::l)). apply H2; auto. exists e'; auto. destruct (In_inv H3). order. inversion_clear Hm. assert (Inf (x',e') l). apply Inf_lt with (x,e); auto. elim (Sort_Inf_NotIn H5 H7 H4). destruct m; destruct m';try contradiction. clear H1;destruct p as (k,e). destruct (H0 k). destruct H1. exists e; auto. inversion H1. destruct p as (x,e). destruct (H0 x). destruct H. exists e; auto. inversion H. destruct p;destruct p0;contradiction. Qed. Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; intuition; try discriminate; subst; try match goal with H: X.compare _ _ = _ |- _ => clear H end. inversion H0. inversion_clear Hm;inversion_clear Hm'. destruct (andb_prop _ _ H); clear H. destruct (IHb H1 H3 H6). destruct (In_inv H0). exists e'; constructor; split; trivial; apply X.eq_trans with x; auto. destruct (H k). destruct (H9 H8) as (e'',hyp). exists e''; auto. inversion_clear Hm;inversion_clear Hm'. destruct (andb_prop _ _ H); clear H. destruct (IHb H1 H3 H6). destruct (In_inv H0). exists e; constructor; split; trivial; apply X.eq_trans with x'; auto. destruct (H k). destruct (H10 H8) as (e'',hyp). exists e''; auto. inversion_clear Hm;inversion_clear Hm'. destruct (andb_prop _ _ H); clear H. destruct (IHb H2 H4 H7). inversion_clear H0. destruct H9; simpl in *; subst. inversion_clear H1. destruct H9; simpl in *; subst; auto. elim (Sort_Inf_NotIn H4 H5). exists e'0; apply MapsTo_eq with k; auto; order. inversion_clear H1. destruct H0; simpl in *; subst; auto. elim (Sort_Inf_NotIn H2 H3). exists e0; apply MapsTo_eq with k; auto; order. apply H8 with k; auto. Qed. (** This lemma isn't part of the spec of [Equivb], but is used in [FMapAVL] *) Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) -> eqk x y -> cmp (snd x) (snd y) = true -> (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)). Proof. intros. inversion H; subst. inversion H0; subst. destruct x; destruct y; compute in H1, H2. split; intros. apply equal_2; auto. simpl. elim_comp. rewrite H2; simpl. apply equal_1; auto. apply equal_2; auto. generalize (equal_1 H H0 H3). simpl. elim_comp. rewrite H2; simpl; auto. Qed. Variable elt':Type. (** * [map] and [mapi] *) Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := match m with | nil => nil | (k,e)::m' => (k,f e) :: map f m' end. Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := match m with | nil => nil | (k,e)::m' => (k,f k e) :: mapi f m' end. End Elt. Section Elt2. (* A new section is necessary for previous definitions to work with different [elt], especially [MapsTo]... *) Variable elt elt' : Type. (** Specification of [map] *) Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros m x e f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m. inversion 1. destruct a as (x',e'). simpl. inversion_clear 1. constructor 1. unfold eqke in *; simpl in *; intuition congruence. constructor 2. unfold MapsTo in *; auto. Qed. Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. intros m x f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m; simpl. intros (e,abs). inversion abs. destruct a as (x',e). intros hyp. inversion hyp. clear hyp. inversion H; subst; rename x0 into e'. exists e; constructor. unfold eqke in *; simpl in *; intuition. destruct IHm as (e'',hyp). exists e'; auto. exists e''. constructor 2; auto. Qed. Lemma map_lelistA : forall (m: t elt)(x:key)(e:elt)(e':elt')(f:elt->elt'), lelistA (@ltk elt) (x,e) m -> lelistA (@ltk elt') (x,e') (map f m). Proof. induction m; simpl; auto. intros. destruct a as (x0,e0). inversion_clear H; auto. Qed. Hint Resolve map_lelistA. Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), sort (@ltk elt') (map f m). Proof. induction m; simpl; auto. intros. destruct a as (x',e'). inversion_clear Hm. constructor; auto. exact (map_lelistA _ _ H0). Qed. (** Specification of [mapi] *) Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros m x e f. (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) induction m. inversion 1. destruct a as (x',e'). simpl. inversion_clear 1. exists x'. destruct H0; simpl in *. split; auto. constructor 1. unfold eqke in *; simpl in *; intuition congruence. destruct IHm as (y, hyp); auto. exists y; intuition. Qed. Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. intros m x f. (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) induction m; simpl. intros (e,abs). inversion abs. destruct a as (x',e). intros hyp. inversion hyp. clear hyp. inversion H; subst; rename x0 into e'. exists e; constructor. unfold eqke in *; simpl in *; intuition. destruct IHm as (e'',hyp). exists e'; auto. exists e''. constructor 2; auto. Qed. Lemma mapi_lelistA : forall (m: t elt)(x:key)(e:elt)(f:key->elt->elt'), lelistA (@ltk elt) (x,e) m -> lelistA (@ltk elt') (x,f x e) (mapi f m). Proof. induction m; simpl; auto. intros. destruct a as (x',e'). inversion_clear H; auto. Qed. Hint Resolve mapi_lelistA. Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), sort (@ltk elt') (mapi f m). Proof. induction m; simpl; auto. intros. destruct a as (x',e'). inversion_clear Hm; auto. Qed. End Elt2. Section Elt3. (** * [map2] *) Variable elt elt' elt'' : Type. Variable f : option elt -> option elt' -> option elt''. Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := match o with | Some e => (k,e)::l | None => l end. Fixpoint map2_l (m : t elt) : t elt'' := match m with | nil => nil | (k,e)::l => option_cons k (f (Some e) None) (map2_l l) end. Fixpoint map2_r (m' : t elt') : t elt'' := match m' with | nil => nil | (k,e')::l' => option_cons k (f None (Some e')) (map2_r l') end. Fixpoint map2 (m : t elt) : t elt' -> t elt'' := match m with | nil => map2_r | (k,e) :: l => fix map2_aux (m' : t elt') : t elt'' := match m' with | nil => map2_l m | (k',e') :: l' => match X.compare k k' with | LT _ => option_cons k (f (Some e) None) (map2 l m') | EQ _ => option_cons k (f (Some e) (Some e')) (map2 l l') | GT _ => option_cons k' (f None (Some e')) (map2_aux l') end end end. Notation oee' := (option elt * option elt')%type. Fixpoint combine (m : t elt) : t elt' -> t oee' := match m with | nil => map (fun e' => (None,Some e')) | (k,e) :: l => fix combine_aux (m':t elt') : list (key * oee') := match m' with | nil => map (fun e => (Some e,None)) m | (k',e') :: l' => match X.compare k k' with | LT _ => (k,(Some e, None))::combine l m' | EQ _ => (k,(Some e, Some e'))::combine l l' | GT _ => (k',(None,Some e'))::combine_aux l' end end end. Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) := List.fold_right (fun p => f (fst p) (snd p)) i l. Definition map2_alt m m' := let m0 : t oee' := combine m m' in let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in fold_right_pair (option_cons (A:=elt'')) m1 nil. Lemma map2_alt_equiv : forall m m', map2_alt m m' = map2 m m'. Proof. unfold map2_alt. induction m. simpl; auto; intros. (* map2_r *) induction m'; try destruct a; simpl; auto. rewrite IHm'; auto. (* fin map2_r *) induction m'; destruct a. simpl; f_equal. (* map2_l *) clear IHm. induction m; try destruct a; simpl; auto. rewrite IHm; auto. (* fin map2_l *) destruct a0. simpl. destruct (X.compare t0 t1); simpl; f_equal. apply IHm. apply IHm. apply IHm'. Qed. Lemma combine_lelistA : forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), lelistA (@ltk elt) (x,e) m -> lelistA (@ltk elt') (x,e') m' -> lelistA (@ltk oee') (x,e'') (combine m m'). Proof. induction m. intros. simpl. exact (map_lelistA _ _ H0). induction m'. intros. destruct a. replace (combine ((t0, e0) :: m) nil) with (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto. exact (map_lelistA _ _ H). intros. simpl. destruct a as (k,e0); destruct a0 as (k',e0'). destruct (X.compare k k'). inversion_clear H; auto. inversion_clear H; auto. inversion_clear H0; auto. Qed. Hint Resolve combine_lelistA. Lemma combine_sorted : forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), sort (@ltk oee') (combine m m'). Proof. induction m. intros; clear Hm. simpl. apply map_sorted; auto. induction m'. intros; clear Hm'. destruct a. replace (combine ((t0, e) :: m) nil) with (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto. apply map_sorted; auto. intros. simpl. destruct a as (k,e); destruct a0 as (k',e'). destruct (X.compare k k'). inversion_clear Hm. constructor; auto. assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto. exact (combine_lelistA _ H0 H1). inversion_clear Hm; inversion_clear Hm'. constructor; auto. assert (lelistA (ltk (elt:=elt')) (k, e') m') by (apply Inf_eq with (k',e'); auto). exact (combine_lelistA _ H0 H3). inversion_clear Hm; inversion_clear Hm'. constructor; auto. change (lelistA (ltk (elt:=oee')) (k', (None, Some e')) (combine ((k,e)::m) m')). assert (lelistA (ltk (elt:=elt)) (k', e) ((k,e)::m)) by auto. exact (combine_lelistA _ H3 H2). Qed. Lemma map2_sorted : forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), sort (@ltk elt'') (map2 m m'). Proof. intros. rewrite <- map2_alt_equiv. unfold map2_alt. assert (H0:=combine_sorted Hm Hm'). set (l0:=combine m m') in *; clearbody l0. set (f':= fun p : oee' => f (fst p) (snd p)). assert (H1:=map_sorted (elt' := option elt'') H0 f'). set (l1:=map f' l0) in *; clearbody l1. clear f' f H0 l0 Hm Hm' m m'. induction l1. simpl; auto. inversion_clear H1. destruct a; destruct o; auto. simpl. constructor; auto. clear IHl1. induction l1. simpl; auto. destruct a; destruct o; simpl; auto. inversion_clear H0; auto. inversion_clear H0. red in H1; simpl in H1. inversion_clear H. apply IHl1; auto. apply Inf_lt with (t1, None (A:=elt'')); auto. Qed. Definition at_least_one (o:option elt)(o':option elt') := match o, o' with | None, None => None | _, _ => Some (o,o') end. Lemma combine_1 : forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), find x (combine m m') = at_least_one (find x m) (find x m'). Proof. induction m. intros. simpl. induction m'. intros; simpl; auto. simpl; destruct a. simpl; destruct (X.compare x t0); simpl; auto. inversion_clear Hm'; auto. induction m'. (* m' = nil *) intros; destruct a; simpl. destruct (X.compare x t0); simpl; auto. inversion_clear Hm; clear H0 l Hm' IHm t0. induction m; simpl; auto. inversion_clear H. destruct a. simpl; destruct (X.compare x t0); simpl; auto. (* m' <> nil *) intros. destruct a as (k,e); destruct a0 as (k',e'); simpl. inversion Hm; inversion Hm'; subst. destruct (X.compare k k'); simpl; destruct (X.compare x k); elim_comp || destruct (X.compare x k'); simpl; auto. rewrite IHm; auto; simpl; elim_comp; auto. rewrite IHm; auto; simpl; elim_comp; auto. rewrite IHm; auto; simpl; elim_comp; auto. change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')). rewrite IHm'; auto. simpl find; elim_comp; auto. change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')). rewrite IHm'; auto. simpl find; elim_comp; auto. change (find x (combine ((k, e) :: m) m') = at_least_one (find x m) (find x m')). rewrite IHm'; auto. simpl find; elim_comp; auto. Qed. Definition at_least_one_then_f (o:option elt)(o':option elt') := match o, o' with | None, None => None | _, _ => f o o' end. Lemma map2_0 : forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). Proof. intros. rewrite <- map2_alt_equiv. unfold map2_alt. assert (H:=combine_1 Hm Hm' x). assert (H2:=combine_sorted Hm Hm'). set (f':= fun p : oee' => f (fst p) (snd p)). set (m0 := combine m m') in *; clearbody m0. set (o:=find x m) in *; clearbody o. set (o':=find x m') in *; clearbody o'. clear Hm Hm' m m'. generalize H; clear H. match goal with |- ?m=?n -> ?p=?q => assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end. induction m0; simpl in *; intuition. destruct o; destruct o'; simpl in *; try discriminate; auto. destruct a as (k,(oo,oo')); simpl in *. inversion_clear H2. destruct (X.compare x k); simpl in *. (* x < k *) destruct (f' (oo,oo')); simpl. elim_comp. destruct o; destruct o'; simpl in *; try discriminate; auto. destruct (IHm0 H0) as (H2,_); apply H2; auto. rewrite <- H. case_eq (find x m0); intros; auto. assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). red; auto. destruct (Sort_Inf_NotIn H0 (Inf_lt H4 H1)). exists p; apply find_2; auto. (* x = k *) assert (at_least_one_then_f o o' = f oo oo'). destruct o; destruct o'; simpl in *; inversion_clear H; auto. rewrite H2. unfold f'; simpl. destruct (f oo oo'); simpl. elim_comp; auto. destruct (IHm0 H0) as (_,H4); apply H4; auto. case_eq (find x m0); intros; auto. assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))). red; auto. destruct (Sort_Inf_NotIn H0 (Inf_eq (eqk_sym H5) H1)). exists p; apply find_2; auto. (* k < x *) unfold f'; simpl. destruct (f oo oo'); simpl. elim_comp; auto. destruct (IHm0 H0) as (H3,_); apply H3; auto. destruct (IHm0 H0) as (H3,_); apply H3; auto. (* None -> None *) destruct a as (k,(oo,oo')). simpl. inversion_clear H2. destruct (X.compare x k). (* x < k *) unfold f'; simpl. destruct (f oo oo'); simpl. elim_comp; auto. destruct (IHm0 H0) as (_,H4); apply H4; auto. case_eq (find x m0); intros; auto. assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). red; auto. destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)). exists p; apply find_2; auto. (* x = k *) discriminate. (* k < x *) unfold f'; simpl. destruct (f oo oo'); simpl. elim_comp; auto. destruct (IHm0 H0) as (_,H4); apply H4; auto. destruct (IHm0 H0) as (_,H4); apply H4; auto. Qed. (** Specification of [map2] *) Lemma map2_1 : forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), In x m \/ In x m' -> find x (map2 m m') = f (find x m) (find x m'). Proof. intros. rewrite map2_0; auto. destruct H as [(e,H)|(e,H)]. rewrite (find_1 Hm H). destruct (find x m'); simpl; auto. rewrite (find_1 Hm' H). destruct (find x m); simpl; auto. Qed. Lemma map2_2 : forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), In x (map2 m m') -> In x m \/ In x m'. Proof. intros. destruct H as (e,H). generalize (map2_0 Hm Hm' x). rewrite (find_1 (map2_sorted Hm Hm') H). generalize (@find_2 _ m x). generalize (@find_2 _ m' x). destruct (find x m); destruct (find x m'); simpl; intros. left; exists e0; auto. left; exists e0; auto. right; exists e0; auto. discriminate. Qed. End Elt3. End Raw. Module Make (X: OrderedType) <: S with Module E := X. Module Raw := Raw X. Module E := X. Definition key := E.t. Record slist (elt:Type) := {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}. Definition t (elt:Type) : Type := slist elt. Section Elt. Variable elt elt' elt'':Type. Implicit Types m : t elt. Implicit Types x y : key. Implicit Types e : elt. Definition empty : t elt := Build_slist (Raw.empty_sorted elt). Definition is_empty m : bool := Raw.is_empty m.(this). Definition add x e m : t elt := Build_slist (Raw.add_sorted m.(sorted) x e). Definition find x m : option elt := Raw.find x m.(this). Definition remove x m : t elt := Build_slist (Raw.remove_sorted m.(sorted) x). Definition mem x m : bool := Raw.mem x m.(this). Definition map f m : t elt' := Build_slist (Raw.map_sorted m.(sorted) f). Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted m.(sorted) f). Definition map2 f m (m':t elt') : t elt'' := Build_slist (Raw.map2_sorted f m.(sorted) m'.(sorted)). Definition elements m : list (key*elt) := @Raw.elements elt m.(this). Definition cardinal m := length m.(this). Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f m.(this) i. Definition equal cmp m m' : bool := @Raw.equal elt cmp m.(this) m'.(this). Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this). Definition In x m : Prop := Raw.PX.In x m.(this). Definition Empty m : Prop := Raw.Empty m.(this). Definition Equal m m' := forall y, find y m = find y m'. Definition Equiv (eq_elt:elt->elt->Prop) m m' := (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt. Definition lt_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.ltk elt. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. Proof. intros m; exact (@Raw.PX.MapsTo_eq elt m.(this)). Qed. Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. intros m; exact (@Raw.mem_1 elt m.(this) m.(sorted)). Qed. Lemma mem_2 : forall m x, mem x m = true -> In x m. Proof. intros m; exact (@Raw.mem_2 elt m.(this) m.(sorted)). Qed. Lemma empty_1 : Empty empty. Proof. exact (@Raw.empty_1 elt). Qed. Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. Proof. intros m; exact (@Raw.is_empty_1 elt m.(this)). Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. Proof. intros m; exact (@Raw.is_empty_2 elt m.(this)). Qed. Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). Proof. intros m; exact (@Raw.add_1 elt m.(this)). Qed. Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. intros m; exact (@Raw.add_2 elt m.(this)). Qed. Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. Proof. intros m; exact (@Raw.add_3 elt m.(this)). Qed. Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). Proof. intros m; exact (@Raw.remove_1 elt m.(this) m.(sorted)). Qed. Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m; exact (@Raw.remove_2 elt m.(this) m.(sorted)). Qed. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(sorted)). Qed. Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(sorted)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed. Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed. Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed. Lemma elements_3 : forall m, sort lt_key (elements m). Proof. intros m; exact (@Raw.elements_3 elt m.(this) m.(sorted)). Qed. Lemma elements_3w : forall m, NoDupA eq_key (elements m). Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(sorted)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). Proof. intros; reflexivity. Qed. Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed. Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed. Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed. End Elt. Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed. Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x m \/ In x m' -> find x (map2 f m m') = f (find x m) (find x m'). Proof. intros elt elt' elt'' m m' x f; exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Proof. intros elt elt' elt'' m m' x f; exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x). Qed. End Make. Module Make_ord (X: OrderedType)(D : OrderedType) <: Sord with Module Data := D with Module MapS.E := X. Module Data := D. Module MapS := Make(X). Import MapS. Module MD := OrderedTypeFacts(D). Import MD. Definition t := MapS.t D.t. Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. Fixpoint eq_list (m m' : list (X.t * D.t)) : Prop := match m, m' with | nil, nil => True | (x,e)::l, (x',e')::l' => match X.compare x x' with | EQ _ => D.eq e e' /\ eq_list l l' | _ => False end | _, _ => False end. Definition eq m m' := eq_list m.(this) m'.(this). Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop := match m, m' with | nil, nil => False | nil, _ => True | _, nil => False | (x,e)::l, (x',e')::l' => match X.compare x x' with | LT _ => True | GT _ => False | EQ _ => D.lt e e' \/ (D.eq e e' /\ lt_list l l') end end. Definition lt m m' := lt_list m.(this) m'.(this). Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true. Proof. intros (l,Hl); induction l. intros (l',Hl'); unfold eq; simpl. destruct l'; unfold equal; simpl; intuition. intros (l',Hl'); unfold eq. destruct l'. destruct a; unfold equal; simpl; intuition. destruct a as (x,e). destruct p as (x',e'). unfold equal; simpl. destruct (X.compare x x'); simpl; intuition. unfold cmp at 1. MD.elim_comp; clear H; simpl. inversion_clear Hl. inversion_clear Hl'. destruct (IHl H (Build_slist H3)). unfold equal, eq in H5; simpl in H5; auto. destruct (andb_prop _ _ H); clear H. generalize H0; unfold cmp. MD.elim_comp; auto; intro; discriminate. destruct (andb_prop _ _ H); clear H. inversion_clear Hl. inversion_clear Hl'. destruct (IHl H (Build_slist H3)). unfold equal, eq in H6; simpl in H6; auto. Qed. Lemma eq_1 : forall m m', Equivb cmp m m' -> eq m m'. Proof. intros. generalize (@equal_1 D.t m m' cmp). generalize (@eq_equal m m'). intuition. Qed. Lemma eq_2 : forall m m', eq m m' -> Equivb cmp m m'. Proof. intros. generalize (@equal_2 D.t m m' cmp). generalize (@eq_equal m m'). intuition. Qed. Lemma eq_refl : forall m : t, eq m m. Proof. intros (m,Hm); induction m; unfold eq; simpl; auto. destruct a. destruct (X.compare t0 t0); auto. apply (MapS.Raw.MX.lt_antirefl l); auto. split. apply D.eq_refl. inversion_clear Hm. apply (IHm H). apply (MapS.Raw.MX.lt_antirefl l); auto. Qed. Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. Proof. intros (m,Hm); induction m; intros (m', Hm'); destruct m'; unfold eq; simpl; try destruct a as (x,e); try destruct p as (x',e'); auto. destruct (X.compare x x'); MapS.Raw.MX.elim_comp; intuition. inversion_clear Hm; inversion_clear Hm'. apply (IHm H0 (Build_slist H4)); auto. Qed. Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. Proof. intros (m1,Hm1); induction m1; intros (m2, Hm2); destruct m2; intros (m3, Hm3); destruct m3; unfold eq; simpl; try destruct a as (x,e); try destruct p as (x',e'); try destruct p0 as (x'',e''); try contradiction; auto. destruct (X.compare x x'); destruct (X.compare x' x''); MapS.Raw.MX.elim_comp; intuition. apply D.eq_trans with e'; auto. inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. apply (IHm1 H1 (Build_slist H6) (Build_slist H8)); intuition. Qed. Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. Proof. intros (m1,Hm1); induction m1; intros (m2, Hm2); destruct m2; intros (m3, Hm3); destruct m3; unfold lt; simpl; try destruct a as (x,e); try destruct p as (x',e'); try destruct p0 as (x'',e''); try contradiction; auto. destruct (X.compare x x'); destruct (X.compare x' x''); MapS.Raw.MX.elim_comp; intuition. left; apply D.lt_trans with e'; auto. left; apply lt_eq with e'; auto. left; apply eq_lt with e'; auto. right. split. apply D.eq_trans with e'; auto. inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. apply (IHm1 H2 (Build_slist H6) (Build_slist H8)); intuition. Qed. Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. Proof. intros (m1,Hm1); induction m1; intros (m2, Hm2); destruct m2; unfold eq, lt; simpl; try destruct a as (x,e); try destruct p as (x',e'); try contradiction; auto. destruct (X.compare x x'); auto. intuition. exact (D.lt_not_eq H0 H1). inversion_clear Hm1; inversion_clear Hm2. apply (IHm1 H0 (Build_slist H5)); intuition. Qed. Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto. Definition compare : forall m1 m2, Compare lt eq m1 m2. Proof. intros (m1,Hm1); induction m1; intros (m2, Hm2); destruct m2; [ apply EQ | apply LT | apply GT | ]; cmp_solve. destruct a as (x,e); destruct p as (x',e'). destruct (X.compare x x'); [ apply LT | | apply GT ]; cmp_solve. destruct (D.compare e e'); [ apply LT | | apply GT ]; cmp_solve. assert (Hm11 : sort (Raw.PX.ltk (elt:=D.t)) m1). inversion_clear Hm1; auto. assert (Hm22 : sort (Raw.PX.ltk (elt:=D.t)) m2). inversion_clear Hm2; auto. destruct (IHm1 Hm11 (Build_slist Hm22)); [ apply LT | apply EQ | apply GT ]; cmp_solve. Qed. End Make_ord. coq-8.4pl4/theories/FSets/FSetList.v0000644000175000017500000000205712326224777016371 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Ensemble M.elt := fun s x => M.In x s. Notation " !! " := mkEns. Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x. Proof. unfold In; compute; auto with extcore. Qed. Lemma Subset_Included : forall s s', s[<=]s' <-> Included _ (!!s) (!!s'). Proof. unfold Subset, Included, In, mkEns; intuition. Qed. Notation " a === b " := (Same_set M.elt a b) (at level 70, no associativity). Lemma Equal_Same_set : forall s s', s[=]s' <-> !!s === !!s'. Proof. intros. rewrite double_inclusion. unfold Subset, Included, Same_set, In, mkEns; intuition. Qed. Lemma empty_Empty_Set : !!M.empty === Empty_set _. Proof. unfold Same_set, Included, mkEns, In. split; intro; set_iff; inversion 1. Qed. Lemma Empty_Empty_set : forall s, Empty s -> !!s === Empty_set _. Proof. unfold Same_set, Included, mkEns, In. split; intros. destruct(H x H0). inversion H0. Qed. Lemma singleton_Singleton : forall x, !!(M.singleton x) === Singleton _ x . Proof. unfold Same_set, Included, mkEns, In. split; intro; set_iff; inversion 1; try constructor; auto. Qed. Lemma union_Union : forall s s', !!(union s s') === Union _ (!!s) (!!s'). Proof. unfold Same_set, Included, mkEns, In. split; intro; set_iff; inversion 1; [ constructor 1 | constructor 2 | | ]; auto. Qed. Lemma inter_Intersection : forall s s', !!(inter s s') === Intersection _ (!!s) (!!s'). Proof. unfold Same_set, Included, mkEns, In. split; intro; set_iff; inversion 1; try constructor; auto. Qed. Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x. Proof. unfold Same_set, Included, mkEns, In. split; intro; set_iff; inversion 1; auto with sets. inversion H0. constructor 2; constructor. constructor 1; auto. Qed. Lemma Add_Add : forall x s s', MP.Add x s s' -> !!s' === Add _ (!!s) x. Proof. unfold Same_set, Included, mkEns, In. split; intros. red in H; rewrite H in H0. destruct H0. inversion H0. constructor 2; constructor. constructor 1; auto. red in H; rewrite H. inversion H0; auto. inversion H1; auto. Qed. Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x. Proof. unfold Same_set, Included, mkEns, In. split; intro; set_iff; inversion 1; auto with sets. split; auto. contradict H1. inversion H1; auto. Qed. Lemma mkEns_Finite : forall s, Finite _ (!!s). Proof. intro s; pattern s; apply set_induction; clear s; intros. intros; replace (!!s) with (Empty_set elt); auto with sets. symmetry; apply Extensionality_Ensembles. apply Empty_Empty_set; auto. replace (!!s') with (Add _ (!!s) x). constructor 2; auto. symmetry; apply Extensionality_Ensembles. apply Add_Add; auto. Qed. Lemma mkEns_cardinal : forall s, cardinal _ (!!s) (M.cardinal s). Proof. intro s; pattern s; apply set_induction; clear s; intros. intros; replace (!!s) with (Empty_set elt); auto with sets. rewrite cardinal_1; auto with sets. symmetry; apply Extensionality_Ensembles. apply Empty_Empty_set; auto. replace (!!s') with (Add _ (!!s) x). rewrite (cardinal_2 H0 H1); auto with sets. symmetry; apply Extensionality_Ensembles. apply Add_Add; auto. Qed. (** we can even build a function from Finite Ensemble to FSet ... at least in Prop. *) Lemma Ens_to_FSet : forall e : Ensemble M.elt, Finite _ e -> exists s:M.t, !!s === e. Proof. induction 1. exists M.empty. apply empty_Empty_Set. destruct IHFinite as (s,Hs). exists (M.add x s). apply Extensionality_Ensembles in Hs. rewrite <- Hs. apply add_Add. Qed. End WS_to_Finite_set. Module S_to_Finite_set (U:UsualOrderedType)(M: Sfun U) := WS_to_Finite_set U M. coq-8.4pl4/theories/Unicode/0000755000175000017500000000000012365131022015022 5ustar stephstephcoq-8.4pl4/theories/Unicode/Utf8.v0000644000175000017500000000165412326224777016066 0ustar stephsteph(* -*- coding:utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (∃ y v, x + v â‰Ĩ y + z) âˆĻ x â‰Ī 0. *) (* Integer Arithmetic *) (* TODO: this should come after ZArith Notation "x â‰Ī y" := (Z.le x y) (at level 70, no associativity). *) coq-8.4pl4/theories/Unicode/vo.itarget0000644000175000017500000000002512326224777017045 0ustar stephstephUtf8.vo Utf8_core.vo coq-8.4pl4/theories/Unicode/Utf8_core.v0000644000175000017500000000264212326224777017074 0ustar stephsteph(* -*- coding:utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* y) (at level 90, y at level 200, right associativity): type_scope. Notation "x ↔ y" := (x <-> y) (at level 95, no associativity): type_scope. Notation "ÂŽ x" := (~x) (at level 75, right associativity) : type_scope. Notation "x ≠ y" := (x <> y) (at level 70) : type_scope. (* Abstraction *) Notation "'Îŧ' x .. y , t" := (fun x => .. (fun y => t) ..) (at level 200, x binder, y binder, right associativity). coq-8.4pl4/theories/Program/0000755000175000017500000000000012365131022015043 5ustar stephstephcoq-8.4pl4/theories/Program/Basics.v0000644000175000017500000000336512326224777016466 0ustar stephsteph(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* C) (f : A -> B) := fun x : A => g (f x). Hint Unfold compose. Notation " g ∘ f " := (compose g f) (at level 40, left associativity) : program_scope. Local Open Scope program_scope. (** The non-dependent function space between [A] and [B]. *) Definition arrow (A B : Type) := A -> B. (** Logical implication. *) Definition impl (A B : Prop) : Prop := A -> B. (** The constant function [const a] always returns [a]. *) Definition const {A B} (a : A) := fun _ : B => a. (** The [flip] combinator reverses the first two arguments of a function. *) Definition flip {A B C} (f : A -> B -> C) x y := f y x. (** Application as a combinator. *) Definition apply {A B} (f : A -> B) (x : A) := f x. (** Curryfication of [prod] is defined in [Logic.Datatypes]. *) Arguments prod_curry {A B C} f p. Arguments prod_uncurry {A B C} f x y. coq-8.4pl4/theories/Program/Tactics.v0000644000175000017500000002310712326224777016650 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* idtac T end. Ltac show_hyp id := match goal with | [ H := ?b : ?T |- _ ] => match H with | id => idtac id ":=" b ":" T end | [ H : ?T |- _ ] => match H with | id => idtac id ":" T end end. Ltac show_hyps := try match reverse goal with | [ H : ?T |- _ ] => show_hyp H ; fail end. (** The [do] tactic but using a Coq-side nat. *) Ltac do_nat n tac := match n with | 0 => idtac | S ?n' => tac ; do_nat n' tac end. (** Do something on the last hypothesis, or fail *) Ltac on_last_hyp tac := match goal with [ H : _ |- _ ] => first [ tac H | fail 1 ] end. (** Destructs one pair, without care regarding naming. *) Ltac destruct_one_pair := match goal with | [H : (_ /\ _) |- _] => destruct H | [H : prod _ _ |- _] => destruct H end. (** Repeateadly destruct pairs. *) Ltac destruct_pairs := repeat (destruct_one_pair). (** Destruct one existential package, keeping the name of the hypothesis for the first component. *) Ltac destruct_one_ex := let tac H := let ph := fresh "H" in (destruct H as [H ph]) in let tac2 H := let ph := fresh "H" in let ph' := fresh "H" in (destruct H as [H ph ph']) in let tacT H := let ph := fresh "X" in (destruct H as [H ph]) in let tacT2 H := let ph := fresh "X" in let ph' := fresh "X" in (destruct H as [H ph ph']) in match goal with | [H : (ex _) |- _] => tac H | [H : (sig ?P) |- _ ] => tac H | [H : (sigT ?P) |- _ ] => tacT H | [H : (ex2 _ _) |- _] => tac2 H | [H : (sig2 ?P _) |- _ ] => tac2 H | [H : (sigT2 ?P _) |- _ ] => tacT2 H end. (** Repeateadly destruct existentials. *) Ltac destruct_exists := repeat (destruct_one_ex). (** Repeateadly destruct conjunctions and existentials. *) Ltac destruct_conjs := repeat (destruct_one_pair || destruct_one_ex). (** Destruct an existential hypothesis [t] keeping its name for the first component and using [Ht] for the second *) Tactic Notation "destruct" "exist" ident(t) ident(Ht) := destruct t as [t Ht]. (** Destruct a disjunction keeping its name in both subgoals. *) Tactic Notation "destruct" "or" ident(H) := destruct H as [H|H]. (** Discriminate that also work on a [x <> x] hypothesis. *) Ltac discriminates := match goal with | [ H : ?x <> ?x |- _ ] => elim H ; reflexivity | _ => discriminate end. (** Revert the last hypothesis. *) Ltac revert_last := match goal with [ H : _ |- _ ] => revert H end. (** Repeatedly reverse the last hypothesis, putting everything in the goal. *) Ltac reverse := repeat revert_last. (** Reverse everything up to hypothesis id (not included). *) Ltac revert_until id := on_last_hyp ltac:(fun id' => match id' with | id => idtac | _ => revert id' ; revert_until id end). (** Clear duplicated hypotheses *) Ltac clear_dup := match goal with | [ H : ?X |- _ ] => match goal with | [ H' : ?Y |- _ ] => match H with | H' => fail 2 | _ => unify X Y ; (clear H' || clear H) end end end. Ltac clear_dups := repeat clear_dup. (** Try to clear everything except some hyp *) Ltac clear_except hyp := repeat match goal with [ H : _ |- _ ] => match H with | hyp => fail 1 | _ => clear H end end. (** A non-failing subst that substitutes as much as possible. *) Ltac subst_no_fail := repeat (match goal with [ H : ?X = ?Y |- _ ] => subst X || subst Y end). Tactic Notation "subst" "*" := subst_no_fail. Ltac on_application f tac T := match T with | context [f ?x ?y ?z ?w ?v ?u ?a ?b ?c] => tac (f x y z w v u a b c) | context [f ?x ?y ?z ?w ?v ?u ?a ?b] => tac (f x y z w v u a b) | context [f ?x ?y ?z ?w ?v ?u ?a] => tac (f x y z w v u a) | context [f ?x ?y ?z ?w ?v ?u] => tac (f x y z w v u) | context [f ?x ?y ?z ?w ?v] => tac (f x y z w v) | context [f ?x ?y ?z ?w] => tac (f x y z w) | context [f ?x ?y ?z] => tac (f x y z) | context [f ?x ?y] => tac (f x y) | context [f ?x] => tac (f x) end. (** A variant of [apply] using [refine], doing as much conversion as necessary. *) Ltac rapply p := refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _) || refine (p _ _ _ _ _ _ _ _ _ _ _ _ _) || refine (p _ _ _ _ _ _ _ _ _ _ _ _) || refine (p _ _ _ _ _ _ _ _ _ _ _) || refine (p _ _ _ _ _ _ _ _ _ _) || refine (p _ _ _ _ _ _ _ _ _) || refine (p _ _ _ _ _ _ _ _) || refine (p _ _ _ _ _ _ _) || refine (p _ _ _ _ _ _) || refine (p _ _ _ _ _) || refine (p _ _ _ _) || refine (p _ _ _) || refine (p _ _) || refine (p _) || refine p. (** Tactical [on_call f tac] applies [tac] on any application of [f] in the hypothesis or goal. *) Ltac on_call f tac := match goal with | |- ?T => on_application f tac T | H : ?T |- _ => on_application f tac T end. (* Destructs calls to f in hypothesis or conclusion, useful if f creates a subset object. *) Ltac destruct_call f := let tac t := (destruct t) in on_call f tac. Ltac destruct_calls f := repeat destruct_call f. Ltac destruct_call_in f H := let tac t := (destruct t) in let T := type of H in on_application f tac T. Ltac destruct_call_as f l := let tac t := (destruct t as l) in on_call f tac. Ltac destruct_call_as_in f l H := let tac t := (destruct t as l) in let T := type of H in on_application f tac T. Tactic Notation "destruct_call" constr(f) := destruct_call f. (** Permit to name the results of destructing the call to [f]. *) Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) := destruct_call_as f l. (** Specify the hypothesis in which the call occurs as well. *) Tactic Notation "destruct_call" constr(f) "in" hyp(id) := destruct_call_in f id. Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) "in" hyp(id) := destruct_call_as_in f l id. (** A marker for prototypes to destruct. *) Definition fix_proto {A : Type} (a : A) := a. Ltac destruct_rec_calls := match goal with | [ H : fix_proto _ |- _ ] => destruct_calls H ; clear H end. Ltac destruct_all_rec_calls := repeat destruct_rec_calls ; unfold fix_proto in *. (** Try to inject any potential constructor equality hypothesis. *) Ltac autoinjection tac := match goal with | [ H : ?f ?a = ?f' ?a' |- _ ] => tac H end. Ltac inject H := progress (inversion H ; subst*; clear_dups) ; clear H. Ltac autoinjections := repeat (clear_dups ; autoinjection ltac:inject). (** Destruct an hypothesis by first copying it to avoid dependencies. *) Ltac destruct_nondep H := let H0 := fresh "H" in assert(H0 := H); destruct H0. (** If bang appears in the goal, it means that we have a proof of False and the goal is solved. *) Ltac bang := match goal with | |- ?x => match x with | appcontext [False_rect _ ?p] => elim p end end. (** A tactic to show contradiction by first asserting an automatically provable hypothesis. *) Tactic Notation "contradiction" "by" constr(t) := let H := fresh in assert t as H by auto with * ; contradiction. (** A tactic that adds [H:=p:typeof(p)] to the context if no hypothesis of the same type appears in the goal. Useful to do saturation using tactics. *) Ltac add_hypothesis H' p := match type of p with ?X => match goal with | [ H : X |- _ ] => fail 1 | _ => set (H':=p) ; try (change p with H') ; clearbody H' end end. (** A tactic to replace an hypothesis by another term. *) Ltac replace_hyp H c := let H' := fresh "H" in assert(H' := c) ; clear H ; rename H' into H. (** A tactic to refine an hypothesis by supplying some of its arguments. *) Ltac refine_hyp c := let tac H := replace_hyp H c in match c with | ?H _ => tac H | ?H _ _ => tac H | ?H _ _ _ => tac H | ?H _ _ _ _ => tac H | ?H _ _ _ _ _ => tac H | ?H _ _ _ _ _ _ => tac H | ?H _ _ _ _ _ _ _ => tac H | ?H _ _ _ _ _ _ _ _ => tac H end. (** The default simplification tactic used by Program is defined by [program_simpl], sometimes [auto] is not enough, better rebind using [Obligation Tactic := tac] in this case, possibly using [program_simplify] to use standard goal-cleaning tactics. *) Ltac program_simplify := simpl; intros ; destruct_all_rec_calls ; repeat (destruct_conjs; simpl proj1_sig in * ); subst*; autoinjections ; try discriminates ; try (solve [ red ; intros ; destruct_conjs ; autoinjections ; discriminates ]). (** Restrict automation to propositional obligations. *) Ltac program_solve_wf := match goal with | |- well_founded _ => auto with * | |- ?T => match type of T with Prop => auto end end. Create HintDb program discriminated. Ltac program_simpl := program_simplify ; try typeclasses eauto with program ; try program_solve_wf. Obligation Tactic := program_simpl. Definition obligation (A : Type) {a : A} := a.coq-8.4pl4/theories/Program/Program.v0000644000175000017500000000140412326224777016661 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let (x,y) := anonymous in P)) (x ident, y ident, at level 10) : type_scope. (** Generates an obligation to prove False. *) Notation " ! " := (False_rect _ _) : program_scope. Delimit Scope program_scope with prg. (** Abbreviation for first projection and hiding of proofs of subset objects. *) Notation " ` t " := (proj1_sig t) (at level 10, t at next level) : program_scope. (** Coerces objects to their support before comparing them. *) Notation " x '`=' y " := ((x :>) = (y :>)) (at level 70) : program_scope. Require Import Coq.Bool.Sumbool. (** Construct a dependent disjunction from a boolean. *) Notation dec := sumbool_of_bool. (** The notations [in_right] and [in_left] construct objects of a dependent disjunction. *) (** Hide proofs and generates obligations when put in a term. *) Notation in_left := (@left _ _ _). Notation in_right := (@right _ _ _). (** Extraction directives *) (* Extraction Inline proj1_sig. Extract Inductive unit => "unit" [ "()" ]. Extract Inductive bool => "bool" [ "true" "false" ]. Extract Inductive sumbool => "bool" [ "true" "false" ]. (* Extract Inductive prod "'a" "'b" => " 'a * 'b " [ "(,)" ]. *) (* Extract Inductive sigT => "prod" [ "" ]. *) *) coq-8.4pl4/theories/Program/Syntax.v0000644000175000017500000000266712326224777016554 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* is_ground T end. (** Try to find a contradiction. *) Hint Extern 10 => is_ground_goal ; progress exfalso : exfalso. (** We will use the [block] definition to separate the goal from the equalities generated by the tactic. *) Definition block {A : Type} (a : A) := a. Ltac block_goal := match goal with [ |- ?T ] => change (block T) end. Ltac unblock_goal := unfold block in *. (** Notation for heterogenous equality. *) Notation " x ~= y " := (@JMeq _ x _ y) (at level 70, no associativity). (** Do something on an heterogeneous equality appearing in the context. *) Ltac on_JMeq tac := match goal with | [ H : @JMeq ?x ?X ?y ?Y |- _ ] => tac H end. (** Try to apply [JMeq_eq] to get back a regular equality when the two types are equal. *) Ltac simpl_one_JMeq := on_JMeq ltac:(fun H => apply JMeq_eq in H). (** Repeat it for every possible hypothesis. *) Ltac simpl_JMeq := repeat simpl_one_JMeq. (** Just simplify an h.eq. without clearing it. *) Ltac simpl_one_dep_JMeq := on_JMeq ltac:(fun H => let H' := fresh "H" in assert (H' := JMeq_eq H)). Require Import Eqdep. (** Simplify dependent equality using sigmas to equality of the second projections if possible. Uses UIP. *) Ltac simpl_existT := match goal with [ H : existT _ ?x _ = existT _ ?x _ |- _ ] => let Hi := fresh H in assert(Hi:=inj_pairT2 _ _ _ _ _ H) ; clear H end. Ltac simpl_existTs := repeat simpl_existT. (** Tries to eliminate a call to [eq_rect] (the substitution principle) by any means available. *) Ltac elim_eq_rect := match goal with | [ |- ?t ] => match t with | context [ @eq_rect _ _ _ _ _ ?p ] => let P := fresh "P" in set (P := p); simpl in P ; ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) | context [ @eq_rect _ _ _ _ _ ?p _ ] => let P := fresh "P" in set (P := p); simpl in P ; ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) end end. (** Rewrite using uniqueness of indentity proofs [H = eq_refl]. *) Ltac simpl_uip := match goal with [ H : ?X = ?X |- _ ] => rewrite (UIP_refl _ _ H) in *; clear H end. (** Simplify equalities appearing in the context and goal. *) Ltac simpl_eq := simpl ; unfold eq_rec_r, eq_rec ; repeat (elim_eq_rect ; simpl) ; repeat (simpl_uip ; simpl). (** Try to abstract a proof of equality, if no proof of the same equality is present in the context. *) Ltac abstract_eq_hyp H' p := let ty := type of p in let tyred := eval simpl in ty in match tyred with ?X = ?Y => match goal with | [ H : X = Y |- _ ] => fail 1 | _ => set (H':=p) ; try (change p with H') ; clearbody H' ; simpl in H' end end. (** Apply the tactic tac to proofs of equality appearing as coercion arguments. Just redefine this tactic (using [Ltac on_coerce_proof tac ::=]) to handle custom coercion operators. *) Ltac on_coerce_proof tac T := match T with | context [ eq_rect _ _ _ _ ?p ] => tac p end. Ltac on_coerce_proof_gl tac := match goal with [ |- ?T ] => on_coerce_proof tac T end. (** Abstract proofs of equalities of coercions. *) Ltac abstract_eq_proof := on_coerce_proof_gl ltac:(fun p => let H := fresh "eqH" in abstract_eq_hyp H p). Ltac abstract_eq_proofs := repeat abstract_eq_proof. (** Factorize proofs, by using proof irrelevance so that two proofs of the same equality in the goal become convertible. *) Ltac pi_eq_proof_hyp p := let ty := type of p in let tyred := eval simpl in ty in match tyred with ?X = ?Y => match goal with | [ H : X = Y |- _ ] => match p with | H => fail 2 | _ => rewrite (proof_irrelevance (X = Y) p H) end | _ => fail " No hypothesis with same type " end end. (** Factorize proofs of equality appearing as coercion arguments. *) Ltac pi_eq_proof := on_coerce_proof_gl pi_eq_proof_hyp. Ltac pi_eq_proofs := repeat pi_eq_proof. (** The two preceding tactics in sequence. *) Ltac clear_eq_proofs := abstract_eq_proofs ; pi_eq_proofs. Hint Rewrite <- eq_rect_eq : refl_id. (** The [refl_id] database should be populated with lemmas of the form [coerce_* t eq_refl = t]. *) Lemma JMeq_eq_refl {A} (x : A) : JMeq_eq (@JMeq_refl _ x) = eq_refl. Proof. apply proof_irrelevance. Qed. Lemma UIP_refl_refl A (x : A) : Eqdep.EqdepTheory.UIP_refl A x eq_refl = eq_refl. Proof. apply UIP_refl. Qed. Lemma inj_pairT2_refl A (x : A) (P : A -> Type) (p : P x) : Eqdep.EqdepTheory.inj_pairT2 A P x p p eq_refl = eq_refl. Proof. apply UIP_refl. Qed. Hint Rewrite @JMeq_eq_refl @UIP_refl_refl @inj_pairT2_refl : refl_id. Ltac rewrite_refl_id := autorewrite with refl_id. (** Clear the context and goal of equality proofs. *) Ltac clear_eq_ctx := rewrite_refl_id ; clear_eq_proofs. (** Reapeated elimination of [eq_rect] applications. Abstracting equalities makes it run much faster than an naive implementation. *) Ltac simpl_eqs := repeat (elim_eq_rect ; simpl ; clear_eq_ctx). (** Clear unused reflexivity proofs. *) Ltac clear_refl_eq := match goal with [ H : ?X = ?X |- _ ] => clear H end. Ltac clear_refl_eqs := repeat clear_refl_eq. (** Clear unused equality proofs. *) Ltac clear_eq := match goal with [ H : _ = _ |- _ ] => clear H end. Ltac clear_eqs := repeat clear_eq. (** Combine all the tactics to simplify goals containing coercions. *) Ltac simplify_eqs := simpl ; simpl_eqs ; clear_eq_ctx ; clear_refl_eqs ; try subst ; simpl ; repeat simpl_uip ; rewrite_refl_id. (** A tactic that tries to remove trivial equality guards in induction hypotheses coming from [dependent induction]/[generalize_eqs] invocations. *) Ltac simplify_IH_hyps := repeat match goal with | [ hyp : context [ block _ ] |- _ ] => specialize_eqs hyp end. (** We split substitution tactics in the two directions depending on which names we want to keep corresponding to the generalization performed by the [generalize_eqs] tactic. *) Ltac subst_left_no_fail := repeat (match goal with [ H : ?X = ?Y |- _ ] => subst X end). Ltac subst_right_no_fail := repeat (match goal with [ H : ?X = ?Y |- _ ] => subst Y end). Ltac inject_left H := progress (inversion H ; subst_left_no_fail ; clear_dups) ; clear H. Ltac inject_right H := progress (inversion H ; subst_right_no_fail ; clear_dups) ; clear H. Ltac autoinjections_left := repeat autoinjection ltac:inject_left. Ltac autoinjections_right := repeat autoinjection ltac:inject_right. Ltac simpl_depind := subst_no_fail ; autoinjections ; try discriminates ; simpl_JMeq ; simpl_existTs ; simplify_IH_hyps. Ltac simpl_depind_l := subst_left_no_fail ; autoinjections_left ; try discriminates ; simpl_JMeq ; simpl_existTs ; simplify_IH_hyps. Ltac simpl_depind_r := subst_right_no_fail ; autoinjections_right ; try discriminates ; simpl_JMeq ; simpl_existTs ; simplify_IH_hyps. Ltac blocked t := block_goal ; t ; unblock_goal. (** The [DependentEliminationPackage] provides the default dependent elimination principle to be used by the [equations] resolver. It is especially useful to register the dependent elimination principles for things in [Prop] which are not automatically generated. *) Class DependentEliminationPackage (A : Type) := { elim_type : Type ; elim : elim_type }. (** A higher-order tactic to apply a registered eliminator. *) Ltac elim_tac tac p := let ty := type of p in let eliminator := eval simpl in (elim (A:=ty)) in tac p eliminator. (** Specialization to do case analysis or induction. Note: the [equations] tactic tries [case] before [elim_case]: there is no need to register generated induction principles. *) Ltac elim_case p := elim_tac ltac:(fun p el => destruct p using el) p. Ltac elim_ind p := elim_tac ltac:(fun p el => induction p using el) p. (** Lemmas used by the simplifier, mainly rephrasings of [eq_rect], [eq_ind]. *) Lemma solution_left A (B : A -> Type) (t : A) : B t -> (forall x, x = t -> B x). Proof. intros; subst; assumption. Defined. Lemma solution_right A (B : A -> Type) (t : A) : B t -> (forall x, t = x -> B x). Proof. intros; subst; assumption. Defined. Lemma deletion A B (t : A) : B -> (t = t -> B). Proof. intros; assumption. Defined. Lemma simplification_heq A B (x y : A) : (x = y -> B) -> (JMeq x y -> B). Proof. intros H J; apply H; apply (JMeq_eq J). Defined. Definition conditional_eq {A} (x y : A) := eq x y. Lemma simplification_existT2 A (P : A -> Type) B (p : A) (x y : P p) : (x = y -> B) -> (conditional_eq (existT P p x) (existT P p y) -> B). Proof. intros H E. apply H. apply inj_pair2. assumption. Defined. Lemma simplification_existT1 A (P : A -> Type) B (p q : A) (x : P p) (y : P q) : (p = q -> conditional_eq (existT P p x) (existT P q y) -> B) -> (existT P p x = existT P q y -> B). Proof. injection 2. auto. Defined. Lemma simplification_K A (x : A) (B : x = x -> Type) : B eq_refl -> (forall p : x = x, B p). Proof. intros. rewrite (UIP_refl A). assumption. Defined. (** This hint database and the following tactic can be used with [autounfold] to unfold everything to [eq_rect]s. *) Hint Unfold solution_left solution_right deletion simplification_heq simplification_existT1 simplification_existT2 simplification_K eq_rect_r eq_rec eq_ind : dep_elim. (** Using these we can make a simplifier that will perform the unification steps needed to put the goal in normalised form (provided there are only constructor forms). Compare with the lemma 16 of the paper. We don't have a [noCycle] procedure yet. *) Ltac simplify_one_dep_elim_term c := match c with | @JMeq _ _ _ _ -> _ => refine (simplification_heq _ _ _ _ _) | ?t = ?t -> _ => intros _ || refine (simplification_K _ t _ _) | eq (existT _ _ _) (existT _ _ _) -> _ => refine (simplification_existT1 _ _ _ _ _ _ _ _) | conditional_eq (existT _ _ _) (existT _ _ _) -> _ => refine (simplification_existT2 _ _ _ _ _ _ _) || (unfold conditional_eq; intro) | ?x = ?y -> _ => (* variables case *) (unfold x) || (unfold y) || (let hyp := fresh in intros hyp ; move hyp before x ; revert_until hyp ; generalize dependent x ; refine (solution_left _ _ _ _)(* ; intros until 0 *)) || (let hyp := fresh in intros hyp ; move hyp before y ; revert_until hyp ; generalize dependent y ; refine (solution_right _ _ _ _)(* ; intros until 0 *)) | ?f ?x = ?g ?y -> _ => let H := fresh in progress (intros H ; injection H ; clear H) | ?t = ?u -> _ => let hyp := fresh in intros hyp ; exfalso ; discriminate | ?x = ?y -> _ => let hyp := fresh in intros hyp ; (try (clear hyp ; (* If non dependent, don't clear it! *) fail 1)) ; case hyp ; clear hyp | block ?T => fail 1 (* Do not put any part of the rhs in the hyps *) | forall x, _ => intro x || (let H := fresh x in rename x into H ; intro x) (* Try to keep original names *) | _ => intro end. Ltac simplify_one_dep_elim := match goal with | [ |- ?gl ] => simplify_one_dep_elim_term gl end. (** Repeat until no progress is possible. By construction, it should leave the goal with no remaining equalities generated by the [generalize_eqs] tactic. *) Ltac simplify_dep_elim := repeat simplify_one_dep_elim. (** Do dependent elimination of the last hypothesis, but not simplifying yet (used internally). *) Ltac destruct_last := on_last_hyp ltac:(fun id => simpl in id ; generalize_eqs id ; destruct id). Ltac introduce p := first [ match p with _ => (* Already there, generalize dependent hyps *) generalize dependent p ; intros p end | intros until p | intros until 1 | intros ]. Ltac do_case p := introduce p ; (destruct p || elim_case p || (case p ; clear p)). Ltac do_ind p := introduce p ; (induction p || elim_ind p). (** The following tactics allow to do induction on an already instantiated inductive predicate by first generalizing it and adding the proper equalities to the context, in a maner similar to the BasicElim tactic of "Elimination with a motive" by Conor McBride. *) (** The [do_depelim] higher-order tactic takes an elimination tactic as argument and an hypothesis and starts a dependent elimination using this tactic. *) Ltac is_introduced H := match goal with | [ H' : _ |- _ ] => match H' with H => idtac end end. Tactic Notation "intro_block" hyp(H) := (is_introduced H ; block_goal ; revert_until H ; block_goal) || (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal). Tactic Notation "intro_block_id" ident(H) := (is_introduced H ; block_goal ; revert_until H; block_goal) || (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal). Ltac unblock_dep_elim := match goal with | |- block ?T => match T with context [ block _ ] => change T ; intros ; unblock_goal end | _ => unblock_goal end. Ltac simpl_dep_elim := simplify_dep_elim ; simplify_IH_hyps ; unblock_dep_elim. Ltac do_intros H := (try intros until H) ; (intro_block_id H || intro_block H). Ltac do_depelim_nosimpl tac H := do_intros H ; generalize_eqs H ; tac H. Ltac do_depelim tac H := do_depelim_nosimpl tac H ; simpl_dep_elim. Ltac do_depind tac H := (try intros until H) ; intro_block H ; generalize_eqs_vars H ; tac H ; simpl_dep_elim. (** To dependent elimination on some hyp. *) Ltac depelim id := do_depelim ltac:(fun hyp => do_case hyp) id. (** Used internally. *) Ltac depelim_nosimpl id := do_depelim_nosimpl ltac:(fun hyp => do_case hyp) id. (** To dependent induction on some hyp. *) Ltac depind id := do_depind ltac:(fun hyp => do_ind hyp) id. (** A variant where generalized variables should be given by the user. *) Ltac do_depelim' rev tac H := (try intros until H) ; block_goal ; rev H ; (try revert_until H ; block_goal) ; generalize_eqs H ; tac H ; simpl_dep_elim. (** Calls [destruct] on the generalized hypothesis, results should be similar to inversion. By default, we don't try to generalize the hyp by its variable indices. *) Tactic Notation "dependent" "destruction" ident(H) := do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => do_case hyp) H. Tactic Notation "dependent" "destruction" ident(H) "using" constr(c) := do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => destruct hyp using c) H. (** This tactic also generalizes the goal by the given variables before the elimination. *) Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) := do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => do_case hyp) H. Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => destruct hyp using c) H. (** Then we have wrappers for usual calls to induction. One can customize the induction tactic by writting another wrapper calling do_depelim. We suppose the hyp has to be generalized before calling [induction]. *) Tactic Notation "dependent" "induction" ident(H) := do_depind ltac:(fun hyp => do_ind hyp) H. Tactic Notation "dependent" "induction" ident(H) "using" constr(c) := do_depind ltac:(fun hyp => induction hyp using c) H. (** This tactic also generalizes the goal by the given variables before the induction. *) Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) := do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => do_ind hyp) H. Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => induction hyp using c) H. coq-8.4pl4/theories/Program/Combinators.v0000644000175000017500000000415612326224777017541 0ustar stephsteph(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* B), id ∘ f = f. Proof. intros. unfold id, compose. symmetry. apply eta_expansion. Qed. Lemma compose_id_right : forall A B (f : A -> B), f ∘ id = f. Proof. intros. unfold id, compose. symmetry ; apply eta_expansion. Qed. Lemma compose_assoc : forall A B C D (f : A -> B) (g : B -> C) (h : C -> D), h ∘ g ∘ f = h ∘ (g ∘ f). Proof. intros. reflexivity. Qed. Hint Rewrite @compose_id_left @compose_id_right : core. Hint Rewrite <- @compose_assoc : core. (** [flip] is involutive. *) Lemma flip_flip : forall A B C, @flip A B C ∘ flip = id. Proof. unfold flip, compose. intros. extensionality x ; extensionality y ; extensionality z. reflexivity. Qed. (** [prod_curry] and [prod_uncurry] are each others inverses. *) Lemma prod_uncurry_curry : forall A B C, @prod_uncurry A B C ∘ prod_curry = id. Proof. simpl ; intros. unfold prod_uncurry, prod_curry, compose. extensionality x ; extensionality y ; extensionality z. reflexivity. Qed. Lemma prod_curry_uncurry : forall A B C, @prod_curry A B C ∘ prod_uncurry = id. Proof. simpl ; intros. unfold prod_uncurry, prod_curry, compose. extensionality x ; extensionality p. destruct p ; simpl ; reflexivity. Qed. coq-8.4pl4/theories/Program/Wf.v0000644000175000017500000001700512326224777015632 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* A -> Prop. Hypothesis Rwf : well_founded R. Variable P : A -> Type. Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x. Fixpoint Fix_F_sub (x : A) (r : Acc R x) : P x := F_sub x (fun y: { y : A | R y x} => Fix_F_sub (proj1_sig y) (Acc_inv r (proj2_sig y))). Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x). (* Notation Fix_F := (Fix_F_sub P F_sub) (only parsing). (* alias *) *) (* Definition Fix (x:A) := Fix_F_sub P F_sub x (Rwf x). *) Hypothesis F_ext : forall (x:A) (f g:forall y:{y:A | R y x}, P (`y)), (forall (y : A | R y x), f y = g y) -> F_sub x f = F_sub x g. Lemma Fix_F_eq : forall (x:A) (r:Acc R x), F_sub x (fun (y:A|R y x) => Fix_F_sub (`y) (Acc_inv r (proj2_sig y))) = Fix_F_sub x r. Proof. destruct r using Acc_inv_dep; auto. Qed. Lemma Fix_F_inv : forall (x:A) (r s:Acc R x), Fix_F_sub x r = Fix_F_sub x s. Proof. intro x; induction (Rwf x); intros. rewrite (proof_irrelevance (Acc R x) r s) ; auto. Qed. Lemma Fix_eq : forall x:A, Fix_sub x = F_sub x (fun (y:A|R y x) => Fix_sub (proj1_sig y)). Proof. intro x; unfold Fix_sub. rewrite <- (Fix_F_eq ). apply F_ext; intros. apply Fix_F_inv. Qed. Lemma fix_sub_eq : forall x : A, Fix_sub x = let f_sub := F_sub in f_sub x (fun (y : A | R y x) => Fix_sub (`y)). exact Fix_eq. Qed. End Well_founded. Extraction Inline Fix_F_sub Fix_sub. Set Implicit Arguments. (** Reasoning about well-founded fixpoints on measures. *) Section Measure_well_founded. (* Measure relations are well-founded if the underlying relation is well-founded. *) Variables T M: Type. Variable R: M -> M -> Prop. Hypothesis wf: well_founded R. Variable m: T -> M. Definition MR (x y: T): Prop := R (m x) (m y). Lemma measure_wf: well_founded MR. Proof with auto. unfold well_founded. cut (forall a: M, (fun mm: M => forall a0: T, m a0 = mm -> Acc MR a0) a). intros. apply (H (m a))... apply (@well_founded_ind M R wf (fun mm => forall a, m a = mm -> Acc MR a)). intros. apply Acc_intro. intros. unfold MR in H1. rewrite H0 in H1. apply (H (m y))... Defined. End Measure_well_founded. Hint Resolve measure_wf. Section Fix_rects. Variable A: Type. Variable P: A -> Type. Variable R : A -> A -> Prop. Variable Rwf : well_founded R. Variable f: forall (x : A), (forall y: { y: A | R y x }, P (proj1_sig y)) -> P x. Lemma F_unfold x r: Fix_F_sub A R P f x r = f (fun y => Fix_F_sub A R P f (proj1_sig y) (Acc_inv r (proj2_sig y))). Proof. intros. case r; auto. Qed. (* Fix_F_sub_rect lets one prove a property of functions defined using Fix_F_sub by showing that property to be invariant over single application of the function body (f in our case). *) Lemma Fix_F_sub_rect (Q: forall x, P x -> Type) (inv: forall x: A, (forall (y: A) (H: R y x) (a: Acc R y), Q y (Fix_F_sub A R P f y a)) -> forall (a: Acc R x), Q x (f (fun y: {y: A | R y x} => Fix_F_sub A R P f (proj1_sig y) (Acc_inv a (proj2_sig y))))) : forall x a, Q _ (Fix_F_sub A R P f x a). Proof with auto. set (R' := fun (x: A) => forall a, Q _ (Fix_F_sub A R P f x a)). cut (forall x, R' x)... apply (well_founded_induction_type Rwf). subst R'. simpl. intros. rewrite F_unfold... Qed. (* Let's call f's second parameter its "lowers" function, since it provides it access to results for inputs with a lower measure. In preparation of lemma similar to Fix_F_sub_rect, but for Fix_sub, we first need an extra hypothesis stating that the function body has the same result for different "lowers" functions (g and h below) as long as those produce the same results for lower inputs, regardless of the lt proofs. *) Hypothesis equiv_lowers: forall x0 (g h: forall x: {y: A | R y x0}, P (proj1_sig x)), (forall x p p', g (exist (fun y: A => R y x0) x p) = h (exist _ x p')) -> f g = f h. (* From equiv_lowers, it follows that [Fix_F_sub A R P f x] applications do not not depend on the Acc proofs. *) Lemma eq_Fix_F_sub x (a a': Acc R x): Fix_F_sub A R P f x a = Fix_F_sub A R P f x a'. Proof. revert a'. pattern x, (Fix_F_sub A R P f x a). apply Fix_F_sub_rect. intros. rewrite F_unfold. apply equiv_lowers. intros. apply H. assumption. Qed. (* Finally, Fix_F_rect lets one prove a property of functions defined using Fix_F_sub by showing that property to be invariant over single application of the function body (f). *) Lemma Fix_sub_rect (Q: forall x, P x -> Type) (inv: forall (x: A) (H: forall (y: A), R y x -> Q y (Fix_sub A R Rwf P f y)) (a: Acc R x), Q x (f (fun y: {y: A | R y x} => Fix_sub A R Rwf P f (proj1_sig y)))) : forall x, Q _ (Fix_sub A R Rwf P f x). Proof with auto. unfold Fix_sub. intros. apply Fix_F_sub_rect. intros. assert (forall y: A, R y x0 -> Q y (Fix_F_sub A R P f y (Rwf y)))... set (inv x0 X0 a). clearbody q. rewrite <- (equiv_lowers (fun y: {y: A | R y x0} => Fix_F_sub A R P f (proj1_sig y) (Rwf (proj1_sig y))) (fun y: {y: A | R y x0} => Fix_F_sub A R P f (proj1_sig y) (Acc_inv a (proj2_sig y))))... intros. apply eq_Fix_F_sub. Qed. End Fix_rects. (** Tactic to fold a definition based on [Fix_measure_sub]. *) Ltac fold_sub f := match goal with | [ |- ?T ] => match T with appcontext C [ @Fix_sub _ _ _ _ _ ?arg ] => let app := context C [ f arg ] in change app end end. (** This module provides the fixpoint equation provided one assumes functional extensionality. *) Module WfExtensionality. Require Import FunctionalExtensionality. (** The two following lemmas allow to unfold a well-founded fixpoint definition without restriction using the functional extensionality axiom. *) (** For a function defined with Program using a well-founded order. *) Program Lemma fix_sub_eq_ext : forall (A : Type) (R : A -> A -> Prop) (Rwf : well_founded R) (P : A -> Type) (F_sub : forall x : A, (forall (y : A | R y x), P y) -> P x), forall x : A, Fix_sub A R Rwf P F_sub x = F_sub x (fun (y : A | R y x) => Fix_sub A R Rwf P F_sub y). Proof. intros ; apply Fix_eq ; auto. intros. assert(f = g). extensionality y ; apply H. rewrite H0 ; auto. Qed. (** Tactic to unfold once a definition based on [Fix_sub]. *) Ltac unfold_sub f fargs := set (call:=fargs) ; unfold f in call ; unfold call ; clear call ; rewrite fix_sub_eq_ext ; repeat fold_sub f ; simpl proj1_sig. End WfExtensionality. coq-8.4pl4/theories/Program/Subset.v0000644000175000017500000000671412326224777016530 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* try on_subset_proof_aux tac P ; tac p end. Ltac on_subset_proof tac := match goal with [ |- ?T ] => on_subset_proof_aux tac T end. Ltac abstract_any_hyp H' p := match type of p with ?X => match goal with | [ H : X |- _ ] => fail 1 | _ => set (H':=p) ; try (change p with H') ; clearbody H' end end. Ltac abstract_subset_proof := on_subset_proof ltac:(fun p => let H := fresh "eqH" in abstract_any_hyp H p ; simpl in H). Ltac abstract_subset_proofs := repeat abstract_subset_proof. Ltac pi_subset_proof_hyp p := match type of p with ?X => match goal with | [ H : X |- _ ] => match p with | H => fail 2 | _ => rewrite (proof_irrelevance X p H) end | _ => fail " No hypothesis with same type " end end. Ltac pi_subset_proof := on_subset_proof pi_subset_proof_hyp. Ltac pi_subset_proofs := repeat pi_subset_proof. (** The two preceding tactics in sequence. *) Ltac clear_subset_proofs := abstract_subset_proofs ; simpl in * |- ; pi_subset_proofs ; clear_dups. Ltac pi := repeat progress f_equal ; apply proof_irrelevance. Lemma subset_eq : forall A (P : A -> Prop) (n m : sig P), n = m <-> `n = `m. Proof. induction n. induction m. simpl. split ; intros ; subst. inversion H. reflexivity. pi. Qed. (* Somewhat trivial definition, but not unfolded automatically hence we can match on [match_eq ?A ?B ?x ?f] in tactics. *) Definition match_eq (A B : Type) (x : A) (fn : forall (y : A | y = x), B) : B := fn (exist _ x eq_refl). (* This is what we want to be able to do: replace the originaly matched object by a new, propositionally equal one. If [fn] works on [x] it should work on any [y | y = x]. *) Lemma match_eq_rewrite : forall (A B : Type) (x : A) (fn : forall (y : A | y = x), B) (y : A | y = x), match_eq A B x fn = fn y. Proof. intros. unfold match_eq. f_equal. destruct y. (* uses proof-irrelevance *) apply <- subset_eq. symmetry. assumption. Qed. (** Now we make a tactic to be able to rewrite a term [t] which is applied to a [match_eq] using an arbitrary equality [t = u], and [u] is now the subject of the [match]. *) Ltac rewrite_match_eq H := match goal with [ |- ?T ] => match T with context [ match_eq ?A ?B ?t ?f ] => rewrite (match_eq_rewrite A B t f (exist _ _ (eq_sym H))) end end. (** Otherwise we can simply unfold [match_eq] and the term trivially reduces to the original definition. *) Ltac simpl_match_eq := unfold match_eq ; simpl. coq-8.4pl4/theories/theories.itarget0000644000175000017500000000067012326224777016663 0ustar stephstephArith/vo.otarget Bool/vo.otarget Classes/vo.otarget FSets/vo.otarget MSets/vo.otarget Structures/vo.otarget Init/vo.otarget Lists/vo.otarget Vectors/vo.otarget Logic/vo.otarget PArith/vo.otarget NArith/vo.otarget Numbers/vo.otarget Program/vo.otarget QArith/vo.otarget Reals/vo.otarget Relations/vo.otarget Setoids/vo.otarget Sets/vo.otarget Sorting/vo.otarget Strings/vo.otarget Unicode/vo.otarget Wellfounded/vo.otarget ZArith/vo.otarget coq-8.4pl4/theories/Structures/0000755000175000017500000000000012365131022015617 5ustar stephstephcoq-8.4pl4/theories/Structures/OrderedType.v0000644000175000017500000003404512326224777020263 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* X -> Prop) (x y : X) : Type := | LT : lt x y -> Compare lt eq x y | EQ : eq x y -> Compare lt eq x y | GT : lt y x -> Compare lt eq x y. Arguments LT [X lt eq x y] _. Arguments EQ [X lt eq x y] _. Arguments GT [X lt eq x y] _. Module Type MiniOrderedType. Parameter Inline t : Type. Parameter Inline eq : t -> t -> Prop. Parameter Inline lt : t -> t -> Prop. Axiom eq_refl : forall x : t, eq x x. Axiom eq_sym : forall x y : t, eq x y -> eq y x. Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y. Parameter compare : forall x y : t, Compare lt eq x y. Hint Immediate eq_sym. Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. End MiniOrderedType. Module Type OrderedType. Include MiniOrderedType. (** A [eq_dec] can be deduced from [compare] below. But adding this redundant field allows to see an OrderedType as a DecidableType. *) Parameter eq_dec : forall x y, { eq x y } + { ~ eq x y }. End OrderedType. Module MOT_to_OT (Import O : MiniOrderedType) <: OrderedType. Include O. Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. Proof. intros; elim (compare x y); intro H; [ right | left | right ]; auto. assert (~ eq y x); auto. Defined. End MOT_to_OT. (** * Ordered types properties *) (** Additional properties that can be derived from signature [OrderedType]. *) Module OrderedTypeFacts (Import O: OrderedType). Instance eq_equiv : Equivalence eq. Proof. split; [ exact eq_refl | exact eq_sym | exact eq_trans ]. Qed. Lemma lt_antirefl : forall x, ~ lt x x. Proof. intros; intro; absurd (eq x x); auto. Qed. Instance lt_strorder : StrictOrder lt. Proof. split; [ exact lt_antirefl | exact lt_trans]. Qed. Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. Proof. intros; destruct (compare x z); auto. elim (lt_not_eq H); apply eq_trans with z; auto. elim (lt_not_eq (lt_trans l H)); auto. Qed. Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. Proof. intros; destruct (compare x z); auto. elim (lt_not_eq H0); apply eq_trans with x; auto. elim (lt_not_eq (lt_trans H0 l)); auto. Qed. Instance lt_compat : Proper (eq==>eq==>iff) lt. Proof. apply proper_sym_impl_iff_2; auto with *. intros x x' Hx y y' Hy H. apply eq_lt with x; auto. apply lt_eq with y; auto. Qed. Lemma lt_total : forall x y, lt x y \/ eq x y \/ lt y x. Proof. intros; destruct (compare x y); auto. Qed. Module TO. Definition t := t. Definition eq := eq. Definition lt := lt. Definition le x y := lt x y \/ eq x y. End TO. Module IsTO. Definition eq_equiv := eq_equiv. Definition lt_strorder := lt_strorder. Definition lt_compat := lt_compat. Definition lt_total := lt_total. Lemma le_lteq x y : TO.le x y <-> lt x y \/ eq x y. Proof. reflexivity. Qed. End IsTO. Module OrderTac := !MakeOrderTac TO IsTO. Ltac order := OrderTac.order. Lemma le_eq x y z : ~lt x y -> eq y z -> ~lt x z. Proof. order. Qed. Lemma eq_le x y z : eq x y -> ~lt y z -> ~lt x z. Proof. order. Qed. Lemma neq_eq x y z : ~eq x y -> eq y z -> ~eq x z. Proof. order. Qed. Lemma eq_neq x y z : eq x y -> ~eq y z -> ~eq x z. Proof. order. Qed. Lemma le_lt_trans x y z : ~lt y x -> lt y z -> lt x z. Proof. order. Qed. Lemma lt_le_trans x y z : lt x y -> ~lt z y -> lt x z. Proof. order. Qed. Lemma le_neq x y : ~lt x y -> ~eq x y -> lt y x. Proof. order. Qed. Lemma le_trans x y z : ~lt y x -> ~lt z y -> ~lt z x. Proof. order. Qed. Lemma le_antisym x y : ~lt y x -> ~lt x y -> eq x y. Proof. order. Qed. Lemma neq_sym x y : ~eq x y -> ~eq y x. Proof. order. Qed. Lemma lt_le x y : lt x y -> ~lt y x. Proof. order. Qed. Lemma gt_not_eq x y : lt y x -> ~ eq x y. Proof. order. Qed. Lemma eq_not_lt x y : eq x y -> ~ lt x y. Proof. order. Qed. Lemma eq_not_gt x y : eq x y -> ~ lt y x. Proof. order. Qed. Lemma lt_not_gt x y : lt x y -> ~ lt y x. Proof. order. Qed. Hint Resolve gt_not_eq eq_not_lt. Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq. Hint Resolve eq_not_gt lt_antirefl lt_not_gt. Lemma elim_compare_eq : forall x y : t, eq x y -> exists H : eq x y, compare x y = EQ H. Proof. intros; case (compare x y); intros H'; try (exfalso; order). exists H'; auto. Qed. Lemma elim_compare_lt : forall x y : t, lt x y -> exists H : lt x y, compare x y = LT H. Proof. intros; case (compare x y); intros H'; try (exfalso; order). exists H'; auto. Qed. Lemma elim_compare_gt : forall x y : t, lt y x -> exists H : lt y x, compare x y = GT H. Proof. intros; case (compare x y); intros H'; try (exfalso; order). exists H'; auto. Qed. Ltac elim_comp := match goal with | |- ?e => match e with | context ctx [ compare ?a ?b ] => let H := fresh in (destruct (compare a b) as [H|H|H]; try order) end end. Ltac elim_comp_eq x y := elim (elim_compare_eq (x:=x) (y:=y)); [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. Ltac elim_comp_lt x y := elim (elim_compare_lt (x:=x) (y:=y)); [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. Ltac elim_comp_gt x y := elim (elim_compare_gt (x:=x) (y:=y)); [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. (** For compatibility reasons *) Definition eq_dec := eq_dec. Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. Proof. intros; elim (compare x y); [ left | right | right ]; auto. Defined. Definition eqb x y : bool := if eq_dec x y then true else false. Lemma eqb_alt : forall x y, eqb x y = match compare x y with EQ _ => true | _ => false end. Proof. unfold eqb; intros; destruct (eq_dec x y); elim_comp; auto. Qed. (* Specialization of resuts about lists modulo. *) Section ForNotations. Notation In:=(InA eq). Notation Inf:=(lelistA lt). Notation Sort:=(sort lt). Notation NoDup:=(NoDupA eq). Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. Proof. exact (InA_eqA eq_equiv). Qed. Lemma ListIn_In : forall l x, List.In x l -> In x l. Proof. exact (In_InA eq_equiv). Qed. Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l. Proof. exact (InfA_ltA lt_strorder). Qed. Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l. Proof. exact (InfA_eqA eq_equiv lt_strorder lt_compat). Qed. Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x. Proof. exact (SortA_InfA_InA eq_equiv lt_strorder lt_compat). Qed. Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l. Proof. exact (@In_InfA t lt). Qed. Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l. Proof. exact (InA_InfA eq_equiv (ltA:=lt)). Qed. Lemma Inf_alt : forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)). Proof. exact (InfA_alt eq_equiv lt_strorder lt_compat). Qed. Lemma Sort_NoDup : forall l, Sort l -> NoDup l. Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat). Qed. End ForNotations. Hint Resolve ListIn_In Sort_NoDup Inf_lt. Hint Immediate In_eq Inf_lt. End OrderedTypeFacts. Module KeyOrderedType(O:OrderedType). Import O. Module MO:=OrderedTypeFacts(O). Import MO. Section Elt. Variable elt : Type. Notation key:=t. Definition eqk (p p':key*elt) := eq (fst p) (fst p'). Definition eqke (p p':key*elt) := eq (fst p) (fst p') /\ (snd p) = (snd p'). Definition ltk (p p':key*elt) := lt (fst p) (fst p'). Hint Unfold eqk eqke ltk. Hint Extern 2 (eqke ?a ?b) => split. (* eqke is stricter than eqk *) Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. Proof. unfold eqk, eqke; intuition. Qed. (* ltk ignore the second components *) Lemma ltk_right_r : forall x k e e', ltk x (k,e) -> ltk x (k,e'). Proof. auto. Qed. Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x. Proof. auto. Qed. Hint Immediate ltk_right_r ltk_right_l. (* eqk, eqke are equalities, ltk is a strict order *) Lemma eqk_refl : forall e, eqk e e. Proof. auto. Qed. Lemma eqke_refl : forall e, eqke e e. Proof. auto. Qed. Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. Proof. auto. Qed. Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. Proof. unfold eqke; intuition. Qed. Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. Proof. eauto. Qed. Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. Proof. unfold eqke; intuition; [ eauto | congruence ]. Qed. Lemma ltk_trans : forall e e' e'', ltk e e' -> ltk e' e'' -> ltk e e''. Proof. eauto. Qed. Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'. Proof. unfold eqk, ltk; auto. Qed. Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. Proof. unfold eqke, ltk; intuition; simpl in *; subst. exact (lt_not_eq H H1). Qed. Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke. Hint Immediate eqk_sym eqke_sym. Global Instance eqk_equiv : Equivalence eqk. Proof. constructor; eauto. Qed. Global Instance eqke_equiv : Equivalence eqke. Proof. split; eauto. Qed. Global Instance ltk_strorder : StrictOrder ltk. Proof. constructor; eauto. intros x; apply (irreflexivity (x:=fst x)). Qed. Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk. Proof. intros (x,e) (x',e') Hxx' (y,f) (y',f') Hyy'; compute. compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto. Qed. Global Instance ltk_compat' : Proper (eqke==>eqke==>iff) ltk. Proof. intros (x,e) (x',e') (Hxx',_) (y,f) (y',f') (Hyy',_); compute. compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto. Qed. (* Additionnal facts *) Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'. Proof. unfold eqk, ltk; simpl; auto. Qed. Lemma ltk_eqk : forall e e' e'', ltk e e' -> eqk e' e'' -> ltk e e''. Proof. eauto. Qed. Lemma eqk_ltk : forall e e' e'', eqk e e' -> ltk e' e'' -> ltk e e''. Proof. intros (k,e) (k',e') (k'',e''). unfold ltk, eqk; simpl; eauto. Qed. Hint Resolve eqk_not_ltk. Hint Immediate ltk_eqk eqk_ltk. Lemma InA_eqke_eqk : forall x m, InA eqke x m -> InA eqk x m. Proof. unfold eqke; induction 1; intuition. Qed. Hint Resolve InA_eqke_eqk. Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). Definition In k m := exists e:elt, MapsTo k e m. Notation Sort := (sort ltk). Notation Inf := (lelistA ltk). Hint Unfold MapsTo In. (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. Proof. firstorder. exists x; auto. induction H. destruct y. exists e; auto. destruct IHInA as [e H0]. exists e; auto. Qed. Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. Proof. intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto with *. Qed. Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. Proof. destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. Qed. Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l. Proof. exact (InfA_eqA eqk_equiv ltk_strorder ltk_compat). Qed. Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. Proof. exact (InfA_ltA ltk_strorder). Qed. Hint Immediate Inf_eq. Hint Resolve Inf_lt. Lemma Sort_Inf_In : forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. Proof. exact (SortA_InfA_InA eqk_equiv ltk_strorder ltk_compat). Qed. Lemma Sort_Inf_NotIn : forall l k e, Sort l -> Inf (k,e) l -> ~In k l. Proof. intros; red; intros. destruct H1 as [e' H2]. elim (@ltk_not_eqk (k,e) (k,e')). eapply Sort_Inf_In; eauto. red; simpl; auto. Qed. Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l. Proof. exact (SortA_NoDupA eqk_equiv ltk_strorder ltk_compat). Qed. Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'. Proof. inversion 1; intros; eapply Sort_Inf_In; eauto. Qed. Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) -> ltk e e' \/ eqk e e'. Proof. inversion_clear 2; auto. left; apply Sort_In_cons_1 with l; auto. Qed. Lemma Sort_In_cons_3 : forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k. Proof. inversion_clear 1; red; intros. destruct (Sort_Inf_NotIn H0 H1 (In_eq H2 H)). Qed. Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. Proof. inversion 1. inversion_clear H0; eauto. destruct H1; simpl in *; intuition. Qed. Lemma In_inv_2 : forall k k' e e' l, InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. Proof. inversion_clear 1; compute in H0; intuition. Qed. Lemma In_inv_3 : forall x x' l, InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. Proof. inversion_clear 1; compute in H0; intuition. Qed. End Elt. Hint Unfold eqk eqke ltk. Hint Extern 2 (eqke ?a ?b) => split. Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke. Hint Immediate eqk_sym eqke_sym. Hint Resolve eqk_not_ltk. Hint Immediate ltk_eqk eqk_ltk. Hint Resolve InA_eqke_eqk. Hint Unfold MapsTo In. Hint Immediate Inf_eq. Hint Resolve Inf_lt. Hint Resolve Sort_Inf_NotIn. Hint Resolve In_inv_2 In_inv_3. End KeyOrderedType. coq-8.4pl4/theories/Structures/GenericMinMax.v0000644000175000017500000004456312326224777020531 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t -> t. Parameter max_l : forall x y, y<=x -> max x y == x. Parameter max_r : forall x y, x<=y -> max x y == y. End HasMax. Module Type HasMin (Import E:EqLe'). Parameter Inline min : t -> t -> t. Parameter min_l : forall x y, x<=y -> min x y == x. Parameter min_r : forall x y, y<=x -> min x y == y. End HasMin. Module Type HasMinMax (E:EqLe) := HasMax E <+ HasMin E. (** ** Any [OrderedTypeFull] can be equipped by [max] and [min] based on the compare function. *) Definition gmax {A} (cmp : A->A->comparison) x y := match cmp x y with Lt => y | _ => x end. Definition gmin {A} (cmp : A->A->comparison) x y := match cmp x y with Gt => y | _ => x end. Module GenericMinMax (Import O:OrderedTypeFull') <: HasMinMax O. Definition max := gmax O.compare. Definition min := gmin O.compare. Lemma ge_not_lt x y : y<=x -> x False. Proof. intros H H'. apply (StrictOrder_Irreflexive x). rewrite le_lteq in *; destruct H as [H|H]. transitivity y; auto. rewrite H in H'; auto. Qed. Lemma max_l x y : y<=x -> max x y == x. Proof. intros. unfold max, gmax. case compare_spec; auto with relations. intros; elim (ge_not_lt x y); auto. Qed. Lemma max_r x y : x<=y -> max x y == y. Proof. intros. unfold max, gmax. case compare_spec; auto with relations. intros; elim (ge_not_lt y x); auto. Qed. Lemma min_l x y : x<=y -> min x y == x. Proof. intros. unfold min, gmin. case compare_spec; auto with relations. intros; elim (ge_not_lt y x); auto. Qed. Lemma min_r x y : y<=x -> min x y == y. Proof. intros. unfold min, gmin. case compare_spec; auto with relations. intros; elim (ge_not_lt x y); auto. Qed. End GenericMinMax. (** ** Consequences of the minimalist interface: facts about [max] and [min]. *) Module MinMaxLogicalProperties (Import O:TotalOrder')(Import M:HasMinMax O). Module Import Private_Tac := !MakeOrderTac O O. (** An alternative caracterisation of [max], equivalent to [max_l /\ max_r] *) Lemma max_spec n m : (n < m /\ max n m == m) \/ (m <= n /\ max n m == n). Proof. destruct (lt_total n m); [left|right]. - split; auto. apply max_r. rewrite le_lteq; auto. - assert (m <= n) by (rewrite le_lteq; intuition). split; auto. now apply max_l. Qed. (** A more symmetric version of [max_spec], based only on [le]. Beware that left and right alternatives overlap. *) Lemma max_spec_le n m : (n <= m /\ max n m == m) \/ (m <= n /\ max n m == n). Proof. destruct (max_spec n m); [left|right]; intuition; order. Qed. Instance : Proper (eq==>eq==>iff) le. Proof. repeat red. intuition order. Qed. Instance max_compat : Proper (eq==>eq==>eq) max. Proof. intros x x' Hx y y' Hy. assert (H1 := max_spec x y). assert (H2 := max_spec x' y'). set (m := max x y) in *; set (m' := max x' y') in *; clearbody m m'. rewrite <- Hx, <- Hy in *. destruct (lt_total x y); intuition order. Qed. (** A function satisfying the same specification is equal to [max]. *) Lemma max_unicity n m p : ((n < m /\ p == m) \/ (m <= n /\ p == n)) -> p == max n m. Proof. assert (Hm := max_spec n m). destruct (lt_total n m); intuition; order. Qed. Lemma max_unicity_ext f : (forall n m, (n < m /\ f n m == m) \/ (m <= n /\ f n m == n)) -> (forall n m, f n m == max n m). Proof. intros. apply max_unicity; auto. Qed. (** [max] commutes with monotone functions. *) Lemma max_mono f : (Proper (eq ==> eq) f) -> (Proper (le ==> le) f) -> forall x y, max (f x) (f y) == f (max x y). Proof. intros Eqf Lef x y. destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. assert (f x <= f y) by (apply Lef; order). order. assert (f y <= f x) by (apply Lef; order). order. Qed. (** *** Semi-lattice algebraic properties of [max] *) Lemma max_id n : max n n == n. Proof. apply max_l; order. Qed. Notation max_idempotent := max_id (only parsing). Lemma max_assoc m n p : max m (max n p) == max (max m n) p. Proof. destruct (max_spec n p) as [(H,E)|(H,E)]; rewrite E; destruct (max_spec m n) as [(H',E')|(H',E')]; rewrite E', ?E; try easy. - apply max_r; order. - symmetry. apply max_l; order. Qed. Lemma max_comm n m : max n m == max m n. Proof. destruct (max_spec m n) as [(H,E)|(H,E)]; rewrite E; (apply max_r || apply max_l); order. Qed. Ltac solve_max := match goal with |- context [max ?n ?m] => destruct (max_spec n m); intuition; order end. (** *** Least-upper bound properties of [max] *) Lemma le_max_l n m : n <= max n m. Proof. solve_max. Qed. Lemma le_max_r n m : m <= max n m. Proof. solve_max. Qed. Lemma max_l_iff n m : max n m == n <-> m <= n. Proof. solve_max. Qed. Lemma max_r_iff n m : max n m == m <-> n <= m. Proof. solve_max. Qed. Lemma max_le n m p : p <= max n m -> p <= n \/ p <= m. Proof. destruct (max_spec n m); [right|left]; intuition; order. Qed. Lemma max_le_iff n m p : p <= max n m <-> p <= n \/ p <= m. Proof. split. apply max_le. solve_max. Qed. Lemma max_lt_iff n m p : p < max n m <-> p < n \/ p < m. Proof. destruct (max_spec n m); intuition; order || (right; order) || (left; order). Qed. Lemma max_lub_l n m p : max n m <= p -> n <= p. Proof. solve_max. Qed. Lemma max_lub_r n m p : max n m <= p -> m <= p. Proof. solve_max. Qed. Lemma max_lub n m p : n <= p -> m <= p -> max n m <= p. Proof. solve_max. Qed. Lemma max_lub_iff n m p : max n m <= p <-> n <= p /\ m <= p. Proof. solve_max. Qed. Lemma max_lub_lt n m p : n < p -> m < p -> max n m < p. Proof. solve_max. Qed. Lemma max_lub_lt_iff n m p : max n m < p <-> n < p /\ m < p. Proof. solve_max. Qed. Lemma max_le_compat_l n m p : n <= m -> max p n <= max p m. Proof. intros. apply max_lub_iff. solve_max. Qed. Lemma max_le_compat_r n m p : n <= m -> max n p <= max m p. Proof. intros. apply max_lub_iff. solve_max. Qed. Lemma max_le_compat n m p q : n <= m -> p <= q -> max n p <= max m q. Proof. intros Hnm Hpq. assert (LE := max_le_compat_l _ _ m Hpq). assert (LE' := max_le_compat_r _ _ p Hnm). order. Qed. (** Properties of [min] *) Lemma min_spec n m : (n < m /\ min n m == n) \/ (m <= n /\ min n m == m). Proof. destruct (lt_total n m); [left|right]. - split; auto. apply min_l. rewrite le_lteq; auto. - assert (m <= n) by (rewrite le_lteq; intuition). split; auto. now apply min_r. Qed. Lemma min_spec_le n m : (n <= m /\ min n m == n) \/ (m <= n /\ min n m == m). Proof. destruct (min_spec n m); [left|right]; intuition; order. Qed. Instance min_compat : Proper (eq==>eq==>eq) min. Proof. intros x x' Hx y y' Hy. assert (H1 := min_spec x y). assert (H2 := min_spec x' y'). set (m := min x y) in *; set (m' := min x' y') in *; clearbody m m'. rewrite <- Hx, <- Hy in *. destruct (lt_total x y); intuition order. Qed. Lemma min_unicity n m p : ((n < m /\ p == n) \/ (m <= n /\ p == m)) -> p == min n m. Proof. assert (Hm := min_spec n m). destruct (lt_total n m); intuition; order. Qed. Lemma min_unicity_ext f : (forall n m, (n < m /\ f n m == n) \/ (m <= n /\ f n m == m)) -> (forall n m, f n m == min n m). Proof. intros. apply min_unicity; auto. Qed. Lemma min_mono f : (Proper (eq ==> eq) f) -> (Proper (le ==> le) f) -> forall x y, min (f x) (f y) == f (min x y). Proof. intros Eqf Lef x y. destruct (min_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (min_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. assert (f x <= f y) by (apply Lef; order). order. assert (f y <= f x) by (apply Lef; order). order. Qed. Lemma min_id n : min n n == n. Proof. apply min_l; order. Qed. Notation min_idempotent := min_id (only parsing). Lemma min_assoc m n p : min m (min n p) == min (min m n) p. Proof. destruct (min_spec n p) as [(H,E)|(H,E)]; rewrite E; destruct (min_spec m n) as [(H',E')|(H',E')]; rewrite E', ?E; try easy. - symmetry. apply min_l; order. - apply min_r; order. Qed. Lemma min_comm n m : min n m == min m n. Proof. destruct (min_spec m n) as [(H,E)|(H,E)]; rewrite E; (apply min_r || apply min_l); order. Qed. Ltac solve_min := match goal with |- context [min ?n ?m] => destruct (min_spec n m); intuition; order end. Lemma le_min_r n m : min n m <= m. Proof. solve_min. Qed. Lemma le_min_l n m : min n m <= n. Proof. solve_min. Qed. Lemma min_l_iff n m : min n m == n <-> n <= m. Proof. solve_min. Qed. Lemma min_r_iff n m : min n m == m <-> m <= n. Proof. solve_min. Qed. Lemma min_le n m p : min n m <= p -> n <= p \/ m <= p. Proof. destruct (min_spec n m); [left|right]; intuition; order. Qed. Lemma min_le_iff n m p : min n m <= p <-> n <= p \/ m <= p. Proof. split. apply min_le. solve_min. Qed. Lemma min_lt_iff n m p : min n m < p <-> n < p \/ m < p. Proof. destruct (min_spec n m); intuition; order || (right; order) || (left; order). Qed. Lemma min_glb_l n m p : p <= min n m -> p <= n. Proof. solve_min. Qed. Lemma min_glb_r n m p : p <= min n m -> p <= m. Proof. solve_min. Qed. Lemma min_glb n m p : p <= n -> p <= m -> p <= min n m. Proof. solve_min. Qed. Lemma min_glb_iff n m p : p <= min n m <-> p <= n /\ p <= m. Proof. solve_min. Qed. Lemma min_glb_lt n m p : p < n -> p < m -> p < min n m. Proof. solve_min. Qed. Lemma min_glb_lt_iff n m p : p < min n m <-> p < n /\ p < m. Proof. solve_min. Qed. Lemma min_le_compat_l n m p : n <= m -> min p n <= min p m. Proof. intros. apply min_glb_iff. solve_min. Qed. Lemma min_le_compat_r n m p : n <= m -> min n p <= min m p. Proof. intros. apply min_glb_iff. solve_min. Qed. Lemma min_le_compat n m p q : n <= m -> p <= q -> min n p <= min m q. Proof. intros Hnm Hpq. assert (LE := min_le_compat_l _ _ m Hpq). assert (LE' := min_le_compat_r _ _ p Hnm). order. Qed. (** *** Combined properties of min and max *) Lemma min_max_absorption n m : max n (min n m) == n. Proof. intros. destruct (min_spec n m) as [(C,E)|(C,E)]; rewrite E. apply max_l. order. destruct (max_spec n m); intuition; order. Qed. Lemma max_min_absorption n m : min n (max n m) == n. Proof. intros. destruct (max_spec n m) as [(C,E)|(C,E)]; rewrite E. destruct (min_spec n m) as [(C',E')|(C',E')]; auto. order. apply min_l; auto. order. Qed. (** Distributivity *) Lemma max_min_distr n m p : max n (min m p) == min (max n m) (max n p). Proof. symmetry. apply min_mono. eauto with *. repeat red; intros. apply max_le_compat_l; auto. Qed. Lemma min_max_distr n m p : min n (max m p) == max (min n m) (min n p). Proof. symmetry. apply max_mono. eauto with *. repeat red; intros. apply min_le_compat_l; auto. Qed. (** Modularity *) Lemma max_min_modular n m p : max n (min m (max n p)) == min (max n m) (max n p). Proof. rewrite <- max_min_distr. destruct (max_spec n p) as [(C,E)|(C,E)]; rewrite E; auto with *. destruct (min_spec m n) as [(C',E')|(C',E')]; rewrite E'. rewrite 2 max_l; try order. rewrite min_le_iff; auto. rewrite 2 max_l; try order. rewrite min_le_iff; auto. Qed. Lemma min_max_modular n m p : min n (max m (min n p)) == max (min n m) (min n p). Proof. intros. rewrite <- min_max_distr. destruct (min_spec n p) as [(C,E)|(C,E)]; rewrite E; auto with *. destruct (max_spec m n) as [(C',E')|(C',E')]; rewrite E'. rewrite 2 min_l; try order. rewrite max_le_iff; right; order. rewrite 2 min_l; try order. rewrite max_le_iff; auto. Qed. (** Disassociativity *) Lemma max_min_disassoc n m p : min n (max m p) <= max (min n m) p. Proof. intros. rewrite min_max_distr. auto using max_le_compat_l, le_min_r. Qed. (** Anti-monotonicity swaps the role of [min] and [max] *) Lemma max_min_antimono f : Proper (eq==>eq) f -> Proper (le==>inverse le) f -> forall x y, max (f x) (f y) == f (min x y). Proof. intros Eqf Lef x y. destruct (min_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. assert (f y <= f x) by (apply Lef; order). order. assert (f x <= f y) by (apply Lef; order). order. Qed. Lemma min_max_antimono f : Proper (eq==>eq) f -> Proper (le==>inverse le) f -> forall x y, min (f x) (f y) == f (max x y). Proof. intros Eqf Lef x y. destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (min_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. assert (f y <= f x) by (apply Lef; order). order. assert (f x <= f y) by (apply Lef; order). order. Qed. End MinMaxLogicalProperties. (** ** Properties requiring a decidable order *) Module MinMaxDecProperties (Import O:OrderedTypeFull')(Import M:HasMinMax O). (** Induction principles for [max]. *) Lemma max_case_strong n m (P:t -> Type) : (forall x y, x==y -> P x -> P y) -> (m<=n -> P n) -> (n<=m -> P m) -> P (max n m). Proof. intros Compat Hl Hr. destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT]. assert (n<=m) by (rewrite le_lteq; auto). apply (Compat m), Hr; auto. symmetry; apply max_r; auto. assert (n<=m) by (rewrite le_lteq; auto). apply (Compat m), Hr; auto. symmetry; apply max_r; auto. assert (m<=n) by (rewrite le_lteq; auto). apply (Compat n), Hl; auto. symmetry; apply max_l; auto. Defined. Lemma max_case n m (P:t -> Type) : (forall x y, x == y -> P x -> P y) -> P n -> P m -> P (max n m). Proof. intros. apply max_case_strong; auto. Defined. (** [max] returns one of its arguments. *) Lemma max_dec n m : {max n m == n} + {max n m == m}. Proof. apply max_case; auto with relations. intros x y H [E|E]; [left|right]; rewrite <-H; auto. Defined. (** Idem for [min] *) Lemma min_case_strong n m (P:O.t -> Type) : (forall x y, x == y -> P x -> P y) -> (n<=m -> P n) -> (m<=n -> P m) -> P (min n m). Proof. intros Compat Hl Hr. destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT]. assert (n<=m) by (rewrite le_lteq; auto). apply (Compat n), Hl; auto. symmetry; apply min_l; auto. assert (n<=m) by (rewrite le_lteq; auto). apply (Compat n), Hl; auto. symmetry; apply min_l; auto. assert (m<=n) by (rewrite le_lteq; auto). apply (Compat m), Hr; auto. symmetry; apply min_r; auto. Defined. Lemma min_case n m (P:O.t -> Type) : (forall x y, x == y -> P x -> P y) -> P n -> P m -> P (min n m). Proof. intros. apply min_case_strong; auto. Defined. Lemma min_dec n m : {min n m == n} + {min n m == m}. Proof. intros. apply min_case; auto with relations. intros x y H [E|E]; [left|right]; rewrite <- E; auto with relations. Defined. End MinMaxDecProperties. Module MinMaxProperties (Import O:OrderedTypeFull')(Import M:HasMinMax O). Module OT := OTF_to_TotalOrder O. Include MinMaxLogicalProperties OT M. Include MinMaxDecProperties O M. Definition max_l := max_l. Definition max_r := max_r. Definition min_l := min_l. Definition min_r := min_r. Notation max_monotone := max_mono. Notation min_monotone := min_mono. Notation max_min_antimonotone := max_min_antimono. Notation min_max_antimonotone := min_max_antimono. End MinMaxProperties. (** ** When the equality is Leibniz, we can skip a few [Proper] precondition. *) Module UsualMinMaxLogicalProperties (Import O:UsualTotalOrder')(Import M:HasMinMax O). Include MinMaxLogicalProperties O M. Lemma max_monotone f : Proper (le ==> le) f -> forall x y, max (f x) (f y) = f (max x y). Proof. intros; apply max_mono; auto. congruence. Qed. Lemma min_monotone f : Proper (le ==> le) f -> forall x y, min (f x) (f y) = f (min x y). Proof. intros; apply min_mono; auto. congruence. Qed. Lemma min_max_antimonotone f : Proper (le ==> inverse le) f -> forall x y, min (f x) (f y) = f (max x y). Proof. intros; apply min_max_antimono; auto. congruence. Qed. Lemma max_min_antimonotone f : Proper (le ==> inverse le) f -> forall x y, max (f x) (f y) = f (min x y). Proof. intros; apply max_min_antimono; auto. congruence. Qed. End UsualMinMaxLogicalProperties. Module UsualMinMaxDecProperties (Import O:UsualOrderedTypeFull')(Import M:HasMinMax O). Module Import Private_Dec := MinMaxDecProperties O M. Lemma max_case_strong : forall n m (P:t -> Type), (m<=n -> P n) -> (n<=m -> P m) -> P (max n m). Proof. intros; apply max_case_strong; auto. congruence. Defined. Lemma max_case : forall n m (P:t -> Type), P n -> P m -> P (max n m). Proof. intros; apply max_case_strong; auto. Defined. Lemma max_dec : forall n m, {max n m = n} + {max n m = m}. Proof. exact max_dec. Defined. Lemma min_case_strong : forall n m (P:O.t -> Type), (n<=m -> P n) -> (m<=n -> P m) -> P (min n m). Proof. intros; apply min_case_strong; auto. congruence. Defined. Lemma min_case : forall n m (P:O.t -> Type), P n -> P m -> P (min n m). Proof. intros. apply min_case_strong; auto. Defined. Lemma min_dec : forall n m, {min n m = n} + {min n m = m}. Proof. exact min_dec. Defined. End UsualMinMaxDecProperties. Module UsualMinMaxProperties (Import O:UsualOrderedTypeFull')(Import M:HasMinMax O). Module OT := OTF_to_TotalOrder O. Include UsualMinMaxLogicalProperties OT M. Include UsualMinMaxDecProperties O M. Definition max_l := max_l. Definition max_r := max_r. Definition min_l := min_l. Definition min_r := min_r. End UsualMinMaxProperties. (** From [TotalOrder] and [HasMax] and [HasEqDec], we can prove that the order is decidable and build an [OrderedTypeFull]. *) Module TOMaxEqDec_to_Compare (Import O:TotalOrder')(Import M:HasMax O)(Import E:HasEqDec O) <: HasCompare O. Definition compare x y := if eq_dec x y then Eq else if eq_dec (M.max x y) y then Lt else Gt. Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). Proof. intros; unfold compare; repeat destruct eq_dec; auto; constructor. destruct (lt_total x y); auto. absurd (x==y); auto. transitivity (max x y); auto. symmetry. apply max_l. rewrite le_lteq; intuition. destruct (lt_total y x); auto. absurd (max x y == y); auto. apply max_r; rewrite le_lteq; intuition. Qed. End TOMaxEqDec_to_Compare. Module TOMaxEqDec_to_OTF (O:TotalOrder)(M:HasMax O)(E:HasEqDec O) <: OrderedTypeFull := O <+ E <+ TOMaxEqDec_to_Compare O M E. (** TODO: Some Remaining questions... --> Compare with a type-classes version ? --> Is max_unicity and max_unicity_ext really convenient to express that any possible definition of max will in fact be equivalent ? --> Is it possible to avoid copy-paste about min even more ? *) coq-8.4pl4/theories/Structures/vo.itarget0000644000175000017500000000032612326224777017646 0ustar stephstephEqualities.vo EqualitiesFacts.vo Orders.vo OrdersEx.vo OrdersFacts.vo OrdersLists.vo OrdersTac.vo OrdersAlt.vo GenericMinMax.vo DecidableType.vo DecidableTypeEx.vo OrderedTypeAlt.vo OrderedTypeEx.vo OrderedType.vo coq-8.4pl4/theories/Structures/EqualitiesFacts.v0000644000175000017500000001122512326224777021116 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* InA eqk x m. Proof. unfold eqke, RelProd; induction 1; firstorder. Qed. Hint Resolve InA_eqke_eqk. Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. Proof. intros. rewrite <- H; auto. Qed. Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). Definition In k m := exists e:elt, MapsTo k e m. Hint Unfold MapsTo In. (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. Proof. firstorder. exists x; auto. induction H. destruct y; compute in H. exists e; left; auto. destruct IHInA as [e H0]. exists e; auto. Qed. Lemma In_alt2 : forall k l, In k l <-> Exists (fun p => eq k (fst p)) l. Proof. unfold In, MapsTo. setoid_rewrite Exists_exists; setoid_rewrite InA_alt. firstorder. exists (snd x), x; auto. Qed. Lemma In_nil : forall k, In k nil <-> False. Proof. intros; rewrite In_alt2; apply Exists_nil. Qed. Lemma In_cons : forall k p l, In k (p::l) <-> eq k (fst p) \/ In k l. Proof. intros; rewrite !In_alt2, Exists_cons; intuition. Qed. Global Instance MapsTo_compat : Proper (eq==>Logic.eq==>equivlistA eqke==>iff) MapsTo. Proof. intros x x' Hx e e' He l l' Hl. unfold MapsTo. rewrite Hx, He, Hl; intuition. Qed. Global Instance In_compat : Proper (eq==>equivlistA eqk==>iff) In. Proof. intros x x' Hx l l' Hl. rewrite !In_alt. setoid_rewrite Hl. setoid_rewrite Hx. intuition. Qed. Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. Proof. intros l x y e EQ. rewrite <- EQ; auto. Qed. Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. Proof. intros l x y EQ. rewrite <- EQ; auto. Qed. Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. Proof. intros; invlist In; invlist MapsTo. compute in * |- ; intuition. right; exists x; auto. Qed. Lemma In_inv_2 : forall k k' e e' l, InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. Proof. intros; invlist InA; intuition. Qed. Lemma In_inv_3 : forall x x' l, InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. Proof. intros; invlist InA; compute in * |- ; intuition. Qed. End Elt. Hint Unfold eqk eqke. Hint Extern 2 (eqke ?a ?b) => split. Hint Resolve InA_eqke_eqk. Hint Unfold MapsTo In. Hint Resolve In_inv_2 In_inv_3. End KeyDecidableType. (** * PairDecidableType From two decidable types, we can build a new DecidableType over their cartesian product. *) Module PairDecidableType(D1 D2:DecidableType) <: DecidableType. Definition t := (D1.t * D2.t)%type. Definition eq := (D1.eq * D2.eq)%signature. Instance eq_equiv : Equivalence eq := _. Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. Proof. intros (x1,x2) (y1,y2); unfold eq; simpl. destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); compute; intuition. Defined. End PairDecidableType. (** Similarly for pairs of UsualDecidableType *) Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType. Definition t := (D1.t * D2.t)%type. Definition eq := @eq t. Instance eq_equiv : Equivalence eq := _. Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. Proof. intros (x1,x2) (y1,y2); destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); unfold eq, D1.eq, D2.eq in *; simpl; (left; f_equal; auto; fail) || (right; intro H; injection H; auto). Defined. End PairUsualDecidableType. coq-8.4pl4/theories/Structures/OrdersEx.v0000644000175000017500000000541612326224777017570 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* eq==>iff) lt. Proof. compute. intros (x1,x2) (x1',x2') (X1,X2) (y1,y2) (y1',y2') (Y1,Y2). rewrite X1,X2,Y1,Y2; intuition. Qed. Definition compare x y := match O1.compare (fst x) (fst y) with | Eq => O2.compare (snd x) (snd y) | Lt => Lt | Gt => Gt end. Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). Proof. intros (x1,x2) (y1,y2); unfold compare; simpl. destruct (O1.compare_spec x1 y1); try (constructor; compute; auto). destruct (O2.compare_spec x2 y2); constructor; compute; auto with relations. Qed. End PairOrderedType. coq-8.4pl4/theories/Structures/Equalities.v0000644000175000017500000001774712326224777020154 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t -> Prop. End HasEq. Module Type Eq := Typ <+ HasEq. Module Type EqNotation (Import E:Eq). Infix "==" := eq (at level 70, no associativity). Notation "x ~= y" := (~eq x y) (at level 70, no associativity). End EqNotation. Module Type Eq' := Eq <+ EqNotation. (** * Specification of the equality via the [Equivalence] type class *) Module Type IsEq (Import E:Eq). Declare Instance eq_equiv : Equivalence eq. End IsEq. (** * Earlier specification of equality by three separate lemmas. *) Module Type IsEqOrig (Import E:Eq'). Axiom eq_refl : forall x : t, x==x. Axiom eq_sym : forall x y : t, x==y -> y==x. Axiom eq_trans : forall x y z : t, x==y -> y==z -> x==z. Hint Immediate eq_sym. Hint Resolve eq_refl eq_trans. End IsEqOrig. (** * Types with decidable equality *) Module Type HasEqDec (Import E:Eq'). Parameter eq_dec : forall x y : t, { x==y } + { ~ x==y }. End HasEqDec. (** * Boolean Equality *) (** Having [eq_dec] is the same as having a boolean equality plus a correctness proof. *) Module Type HasEqb (Import T:Typ). Parameter Inline eqb : t -> t -> bool. End HasEqb. Module Type EqbSpec (T:Typ)(X:HasEq T)(Y:HasEqb T). Parameter eqb_eq : forall x y, Y.eqb x y = true <-> X.eq x y. End EqbSpec. Module Type EqbNotation (T:Typ)(E:HasEqb T). Infix "=?" := E.eqb (at level 70, no associativity). End EqbNotation. Module Type HasEqBool (E:Eq) := HasEqb E <+ EqbSpec E E. (** From these basic blocks, we can build many combinations of static standalone module types. *) Module Type EqualityType := Eq <+ IsEq. Module Type EqualityTypeOrig := Eq <+ IsEqOrig. Module Type EqualityTypeBoth <: EqualityType <: EqualityTypeOrig := Eq <+ IsEq <+ IsEqOrig. Module Type DecidableType <: EqualityType := Eq <+ IsEq <+ HasEqDec. Module Type DecidableTypeOrig <: EqualityTypeOrig := Eq <+ IsEqOrig <+ HasEqDec. Module Type DecidableTypeBoth <: DecidableType <: DecidableTypeOrig := EqualityTypeBoth <+ HasEqDec. Module Type BooleanEqualityType <: EqualityType := Eq <+ IsEq <+ HasEqBool. Module Type BooleanDecidableType <: DecidableType <: BooleanEqualityType := Eq <+ IsEq <+ HasEqDec <+ HasEqBool. Module Type DecidableTypeFull <: DecidableTypeBoth <: BooleanDecidableType := Eq <+ IsEq <+ IsEqOrig <+ HasEqDec <+ HasEqBool. (** Same, with notation for [eq] *) Module Type EqualityType' := EqualityType <+ EqNotation. Module Type EqualityTypeOrig' := EqualityTypeOrig <+ EqNotation. Module Type EqualityTypeBoth' := EqualityTypeBoth <+ EqNotation. Module Type DecidableType' := DecidableType <+ EqNotation. Module Type DecidableTypeOrig' := DecidableTypeOrig <+ EqNotation. Module Type DecidableTypeBoth' := DecidableTypeBoth <+ EqNotation. Module Type BooleanEqualityType' := BooleanEqualityType <+ EqNotation <+ EqbNotation. Module Type BooleanDecidableType' := BooleanDecidableType <+ EqNotation <+ EqbNotation. Module Type DecidableTypeFull' := DecidableTypeFull <+ EqNotation. (** * Compatibility wrapper from/to the old version of [EqualityType] and [DecidableType] *) Module BackportEq (E:Eq)(F:IsEq E) <: IsEqOrig E. Definition eq_refl := @Equivalence_Reflexive _ _ F.eq_equiv. Definition eq_sym := @Equivalence_Symmetric _ _ F.eq_equiv. Definition eq_trans := @Equivalence_Transitive _ _ F.eq_equiv. End BackportEq. Module UpdateEq (E:Eq)(F:IsEqOrig E) <: IsEq E. Instance eq_equiv : Equivalence E.eq. Proof. exact (Build_Equivalence _ _ F.eq_refl F.eq_sym F.eq_trans). Qed. End UpdateEq. Module Backport_ET (E:EqualityType) <: EqualityTypeBoth := E <+ BackportEq. Module Update_ET (E:EqualityTypeOrig) <: EqualityTypeBoth := E <+ UpdateEq. Module Backport_DT (E:DecidableType) <: DecidableTypeBoth := E <+ BackportEq. Module Update_DT (E:DecidableTypeOrig) <: DecidableTypeBoth := E <+ UpdateEq. (** * Having [eq_dec] is equivalent to having [eqb] and its spec. *) Module HasEqDec2Bool (E:Eq)(F:HasEqDec E) <: HasEqBool E. Definition eqb x y := if F.eq_dec x y then true else false. Lemma eqb_eq : forall x y, eqb x y = true <-> E.eq x y. Proof. intros x y. unfold eqb. destruct F.eq_dec as [EQ|NEQ]. auto with *. split. discriminate. intro EQ; elim NEQ; auto. Qed. End HasEqDec2Bool. Module HasEqBool2Dec (E:Eq)(F:HasEqBool E) <: HasEqDec E. Lemma eq_dec : forall x y, {E.eq x y}+{~E.eq x y}. Proof. intros x y. assert (H:=F.eqb_eq x y). destruct (F.eqb x y); [left|right]. apply -> H; auto. intro EQ. apply H in EQ. discriminate. Defined. End HasEqBool2Dec. Module Dec2Bool (E:DecidableType) <: BooleanDecidableType := E <+ HasEqDec2Bool. Module Bool2Dec (E:BooleanEqualityType) <: BooleanDecidableType := E <+ HasEqBool2Dec. (** Some properties of boolean equality *) Module BoolEqualityFacts (Import E : BooleanEqualityType'). (** [eqb] is compatible with [eq] *) Instance eqb_compat : Proper (E.eq ==> E.eq ==> Logic.eq) eqb. Proof. intros x x' Exx' y y' Eyy'. apply eq_true_iff_eq. now rewrite 2 eqb_eq, Exx', Eyy'. Qed. (** Alternative specification of [eqb] based on [reflect]. *) Lemma eqb_spec x y : reflect (x==y) (x =? y). Proof. apply iff_reflect. symmetry. apply eqb_eq. Defined. (** Negated form of [eqb_eq] *) Lemma eqb_neq x y : (x =? y) = false <-> x ~= y. Proof. now rewrite <- not_true_iff_false, eqb_eq. Qed. (** Basic equality laws for [eqb] *) Lemma eqb_refl x : (x =? x) = true. Proof. now apply eqb_eq. Qed. Lemma eqb_sym x y : (x =? y) = (y =? x). Proof. apply eq_true_iff_eq. now rewrite 2 eqb_eq. Qed. (** Transitivity is a particular case of [eqb_compat] *) End BoolEqualityFacts. (** * UsualDecidableType A particular case of [DecidableType] where the equality is the usual one of Coq. *) Module Type HasUsualEq (Import T:Typ) <: HasEq T. Definition eq := @Logic.eq t. End HasUsualEq. Module Type UsualEq <: Eq := Typ <+ HasUsualEq. Module Type UsualIsEq (E:UsualEq) <: IsEq E. (* No Instance syntax to avoid saturating the Equivalence tables *) Definition eq_equiv : Equivalence E.eq := eq_equivalence. End UsualIsEq. Module Type UsualIsEqOrig (E:UsualEq) <: IsEqOrig E. Definition eq_refl := @Logic.eq_refl E.t. Definition eq_sym := @Logic.eq_sym E.t. Definition eq_trans := @Logic.eq_trans E.t. End UsualIsEqOrig. Module Type UsualEqualityType <: EqualityType := UsualEq <+ UsualIsEq. Module Type UsualDecidableType <: DecidableType := UsualEq <+ UsualIsEq <+ HasEqDec. Module Type UsualDecidableTypeOrig <: DecidableTypeOrig := UsualEq <+ UsualIsEqOrig <+ HasEqDec. Module Type UsualDecidableTypeBoth <: DecidableTypeBoth := UsualEq <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqDec. Module Type UsualBoolEq := UsualEq <+ HasEqBool. Module Type UsualDecidableTypeFull <: DecidableTypeFull := UsualEq <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqDec <+ HasEqBool. (** Some shortcuts for easily building a [UsualDecidableType] *) Module Type MiniDecidableType. Include Typ. Parameter eq_dec : forall x y : t, {x=y}+{~x=y}. End MiniDecidableType. Module Make_UDT (M:MiniDecidableType) <: UsualDecidableTypeBoth := M <+ HasUsualEq <+ UsualIsEq <+ UsualIsEqOrig. Module Make_UDTF (M:UsualBoolEq) <: UsualDecidableTypeFull := M <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqBool2Dec. coq-8.4pl4/theories/Structures/OrderedTypeAlt.v0000644000175000017500000000561112326224777020721 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t -> comparison. Infix "?=" := compare (at level 70, no associativity). Parameter compare_sym : forall x y, (y?=x) = CompOpp (x?=y). Parameter compare_trans : forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. End OrderedTypeAlt. (** From this new presentation to the original one. *) Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType. Import O. Definition t := t. Definition eq x y := (x?=y) = Eq. Definition lt x y := (x?=y) = Lt. Lemma eq_refl : forall x, eq x x. Proof. intro x. unfold eq. assert (H:=compare_sym x x). destruct (x ?= x); simpl in *; try discriminate; auto. Qed. Lemma eq_sym : forall x y, eq x y -> eq y x. Proof. unfold eq; intros. rewrite compare_sym. rewrite H; simpl; auto. Qed. Definition eq_trans := (compare_trans Eq). Definition lt_trans := (compare_trans Lt). Lemma lt_not_eq : forall x y, lt x y -> ~eq x y. Proof. unfold eq, lt; intros. rewrite H; discriminate. Qed. Definition compare : forall x y, Compare lt eq x y. Proof. intros. case_eq (x ?= y); intros. apply EQ; auto. apply LT; auto. apply GT; red. rewrite compare_sym; rewrite H; auto. Defined. Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. Proof. intros; unfold eq. case (x ?= y); [ left | right | right ]; auto; discriminate. Defined. End OrderedType_from_Alt. (** From the original presentation to this alternative one. *) Module OrderedType_to_Alt (O:OrderedType) <: OrderedTypeAlt. Import O. Module MO:=OrderedTypeFacts(O). Import MO. Definition t := t. Definition compare x y := match compare x y with | LT _ => Lt | EQ _ => Eq | GT _ => Gt end. Infix "?=" := compare (at level 70, no associativity). Lemma compare_sym : forall x y, (y?=x) = CompOpp (x?=y). Proof. intros x y; unfold compare. destruct O.compare; elim_comp; simpl; auto. Qed. Lemma compare_trans : forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. Proof. intros c x y z. destruct c; unfold compare; do 2 (destruct O.compare; intros; try discriminate); elim_comp; auto. Qed. End OrderedType_to_Alt. coq-8.4pl4/theories/Structures/DecidableType.v0000644000175000017500000001006612326224777020530 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* split. (* eqke is stricter than eqk *) Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. Proof. unfold eqk, eqke; intuition. Qed. (* eqk, eqke are equalities *) Lemma eqk_refl : forall e, eqk e e. Proof. auto. Qed. Lemma eqke_refl : forall e, eqke e e. Proof. auto. Qed. Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. Proof. auto. Qed. Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. Proof. unfold eqke; intuition. Qed. Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. Proof. eauto. Qed. Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. Proof. unfold eqke; intuition; [ eauto | congruence ]. Qed. Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. Hint Immediate eqk_sym eqke_sym. Global Instance eqk_equiv : Equivalence eqk. Proof. split; eauto. Qed. Global Instance eqke_equiv : Equivalence eqke. Proof. split; eauto. Qed. Lemma InA_eqke_eqk : forall x m, InA eqke x m -> InA eqk x m. Proof. unfold eqke; induction 1; intuition. Qed. Hint Resolve InA_eqke_eqk. Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. Proof. intros; apply InA_eqA with p; auto with *. Qed. Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). Definition In k m := exists e:elt, MapsTo k e m. Hint Unfold MapsTo In. (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. Proof. firstorder. exists x; auto. induction H. destruct y. exists e; auto. destruct IHInA as [e H0]. exists e; auto. Qed. Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. Proof. intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto with *. Qed. Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. Proof. destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. Qed. Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. Proof. inversion 1. inversion_clear H0; eauto. destruct H1; simpl in *; intuition. Qed. Lemma In_inv_2 : forall k k' e e' l, InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. Proof. inversion_clear 1; compute in H0; intuition. Qed. Lemma In_inv_3 : forall x x' l, InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. Proof. inversion_clear 1; compute in H0; intuition. Qed. End Elt. Hint Unfold eqk eqke. Hint Extern 2 (eqke ?a ?b) => split. Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. Hint Immediate eqk_sym eqke_sym. Hint Resolve InA_eqke_eqk. Hint Unfold MapsTo In. Hint Resolve In_inv_2 In_inv_3. End KeyDecidableType. coq-8.4pl4/theories/Structures/OrdersTac.v0000644000175000017500000002207312326224777017721 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* le y z -> le x z]. *) Inductive ord := OEQ | OLT | OLE. Definition trans_ord o o' := match o, o' with | OEQ, _ => o' | _, OEQ => o | OLE, OLE => OLE | _, _ => OLT end. Local Infix "+" := trans_ord. (** ** The tactic requirements : a total order We need : - an equivalence [eq], - a strict order [lt] total and compatible with [eq], - a larger order [le] synonym for [lt\/eq]. This used to be provided here via a [TotalOrder], but for technical reasons related to extraction, we now ask for two sperate parts: relations in a [EqLtLe] + properties in [IsTotalOrder]. Note that [TotalOrder = EqLtLe <+ IsTotalOrder] *) Module Type IsTotalOrder (O:EqLtLe) := IsEq O <+ IsStrOrder O <+ LeIsLtEq O <+ LtIsTotal O. (** ** Properties that will be used by the [order] tactic *) Module OrderFacts (Import O:EqLtLe)(P:IsTotalOrder O). Include EqLtLeNotation O. (** Reflexivity rules *) Lemma eq_refl : forall x, x==x. Proof. reflexivity. Qed. Lemma le_refl : forall x, x<=x. Proof. intros; rewrite P.le_lteq; right; reflexivity. Qed. Lemma lt_irrefl : forall x, ~ x y==x. Proof. auto with *. Qed. Lemma le_antisym : forall x y, x<=y -> y<=x -> x==y. Proof. intros x y; rewrite 2 P.le_lteq. intuition. elim (StrictOrder_Irreflexive x); transitivity y; auto. Qed. Lemma neq_sym : forall x y, ~x==y -> ~y==x. Proof. auto using eq_sym. Qed. (** Transitivity rules : first, a generic formulation, then instances*) Ltac subst_eqns := match goal with | H : _==_ |- _ => (rewrite H || rewrite <- H); clear H; subst_eqns | _ => idtac end. Definition interp_ord o := match o with OEQ => O.eq | OLT => O.lt | OLE => O.le end. Local Notation "#" := interp_ord. Lemma trans : forall o o' x y z, #o x y -> #o' y z -> #(o+o') x z. Proof. destruct o, o'; simpl; intros x y z; rewrite ?P.le_lteq; intuition; subst_eqns; eauto using (StrictOrder_Transitive x y z) with *. Qed. Definition eq_trans x y z : x==y -> y==z -> x==z := @trans OEQ OEQ x y z. Definition le_trans x y z : x<=y -> y<=z -> x<=z := @trans OLE OLE x y z. Definition lt_trans x y z : x y x y x y<=z -> x y x y==z -> x y<=z -> x<=z := @trans OEQ OLE x y z. Definition le_eq x y z : x<=y -> y==z -> x<=z := @trans OLE OEQ x y z. Lemma eq_neq : forall x y z, x==y -> ~y==z -> ~x==z. Proof. eauto using eq_trans, eq_sym. Qed. Lemma neq_eq : forall x y z, ~x==y -> y==z -> ~x==z. Proof. eauto using eq_trans, eq_sym. Qed. (** (double) negation rules *) Lemma not_neq_eq : forall x y, ~~x==y -> x==y. Proof. intros x y H. destruct (P.lt_total x y) as [H'|[H'|H']]; auto; destruct H; intro H; rewrite H in H'; eapply lt_irrefl; eauto. Qed. Lemma not_ge_lt : forall x y, ~y<=x -> x x<=y. Proof. intros x y H. rewrite P.le_lteq. generalize (P.lt_total x y); intuition. Qed. Lemma le_neq_lt : forall x y, x<=y -> ~x==y -> x

    ~ (n|p)). Lemma Z_0_1_more x : 0<=x -> x=0 \/ x=1 \/ 1 prime p. Proof. split; intros (Hp,H). - (* prime -> prime' *) constructor; trivial; intros n Hn. constructor; auto with zarith; intros x Hxn Hxp. rewrite <- Z.divide_abs_l in Hxn, Hxp |- *. assert (Hx := Z.abs_nonneg x). set (y:=Z.abs x) in *; clearbody y; clear x; rename y into x. destruct (Z_0_1_more x Hx) as [->|[->|Hx']]. + exfalso. apply Z.divide_0_l in Hxn. omega. + now exists 1. + elim (H x); auto. split; trivial. apply Z.le_lt_trans with n; auto with zarith. apply Z.divide_pos_le; auto with zarith. - (* prime' -> prime *) constructor; trivial. intros n Hn Hnp. case (Zis_gcd_unique n p n 1); auto with zarith. constructor; auto with zarith. apply H; auto with zarith. Qed. Theorem square_not_prime: forall a, ~ prime (a * a). Proof. intros a Ha. rewrite <- (Z.abs_square a) in Ha. assert (H:=Z.abs_nonneg a). set (b:=Z.abs a) in *; clearbody b; clear a; rename b into a. rewrite <- prime_alt in Ha; destruct Ha as (Ha,Ha'). assert (H' : 1 < a) by now apply (Z.square_lt_simpl_nonneg 1). apply (Ha' a). + split; trivial. rewrite <- (Z.mul_1_l a) at 1. apply Z.mul_lt_mono_pos_r; omega. + exists a; auto. Qed. Theorem prime_div_prime: forall p q, prime p -> prime q -> (p | q) -> p = q. Proof. intros p q H H1 H2; assert (Hp: 0 < p); try apply Z.lt_le_trans with 2; try apply prime_ge_2; auto with zarith. assert (Hq: 0 < q); try apply Z.lt_le_trans with 2; try apply prime_ge_2; auto with zarith. case prime_divisors with (2 := H2); auto. intros H4; contradict Hp; subst; auto with zarith. intros [H4| [H4 | H4]]; subst; auto. contradict H; auto; apply not_prime_1. contradict Hp; auto with zarith. Qed. (** we now prove that [Z.gcd] is indeed a gcd in the sense of [Zis_gcd]. *) Notation Zgcd_is_pos := Z.gcd_nonneg (compat "8.3"). Lemma Zgcd_is_gcd : forall a b, Zis_gcd a b (Z.gcd a b). Proof. constructor. apply Z.gcd_divide_l. apply Z.gcd_divide_r. apply Z.gcd_greatest. Qed. Theorem Zgcd_spec : forall x y : Z, {z : Z | Zis_gcd x y z /\ 0 <= z}. Proof. intros x y; exists (Z.gcd x y). split; [apply Zgcd_is_gcd | apply Z.gcd_nonneg]. Qed. Theorem Zdivide_Zgcd: forall p q r : Z, (p | q) -> (p | r) -> (p | Z.gcd q r). Proof. intros. now apply Z.gcd_greatest. Qed. Theorem Zis_gcd_gcd: forall a b c : Z, 0 <= c -> Zis_gcd a b c -> Z.gcd a b = c. Proof. intros a b c H1 H2. case (Zis_gcd_uniqueness_apart_sign a b c (Z.gcd a b)); auto. apply Zgcd_is_gcd; auto. Z.le_elim H1. - generalize (Z.gcd_nonneg a b); auto with zarith. - subst. now case (Z.gcd a b). Qed. Notation Zgcd_inv_0_l := Z.gcd_eq_0_l (compat "8.3"). Notation Zgcd_inv_0_r := Z.gcd_eq_0_r (compat "8.3"). Theorem Zgcd_div_swap0 : forall a b : Z, 0 < Z.gcd a b -> 0 < b -> (a / Z.gcd a b) * b = a * (b/Z.gcd a b). Proof. intros a b Hg Hb. assert (F := Zgcd_is_gcd a b); inversion F as [F1 F2 F3]. pattern b at 2; rewrite (Zdivide_Zdiv_eq (Z.gcd a b) b); auto. repeat rewrite Z.mul_assoc; f_equal. rewrite Z.mul_comm. rewrite <- Zdivide_Zdiv_eq; auto. Qed. Theorem Zgcd_div_swap : forall a b c : Z, 0 < Z.gcd a b -> 0 < b -> (c * a) / Z.gcd a b * b = c * a * (b/Z.gcd a b). Proof. intros a b c Hg Hb. assert (F := Zgcd_is_gcd a b); inversion F as [F1 F2 F3]. pattern b at 2; rewrite (Zdivide_Zdiv_eq (Z.gcd a b) b); auto. repeat rewrite Z.mul_assoc; f_equal. rewrite Zdivide_Zdiv_eq_2; auto. repeat rewrite <- Z.mul_assoc; f_equal. rewrite Z.mul_comm. rewrite <- Zdivide_Zdiv_eq; auto. Qed. Notation Zgcd_comm := Z.gcd_comm (compat "8.3"). Lemma Zgcd_ass a b c : Z.gcd (Z.gcd a b) c = Z.gcd a (Z.gcd b c). Proof. symmetry. apply Z.gcd_assoc. Qed. Notation Zgcd_Zabs := Z.gcd_abs_l (compat "8.3"). Notation Zgcd_0 := Z.gcd_0_r (compat "8.3"). Notation Zgcd_1 := Z.gcd_1_r (compat "8.3"). Hint Resolve Z.gcd_0_r Z.gcd_1_r : zarith. Theorem Zgcd_1_rel_prime : forall a b, Z.gcd a b = 1 <-> rel_prime a b. Proof. unfold rel_prime; split; intro H. rewrite <- H; apply Zgcd_is_gcd. case (Zis_gcd_unique a b (Z.gcd a b) 1); auto. apply Zgcd_is_gcd. intros H2; absurd (0 <= Z.gcd a b); auto with zarith. generalize (Z.gcd_nonneg a b); auto with zarith. Qed. Definition rel_prime_dec: forall a b, { rel_prime a b }+{ ~ rel_prime a b }. Proof. intros a b; case (Z.eq_dec (Z.gcd a b) 1); intros H1. left; apply -> Zgcd_1_rel_prime; auto. right; contradict H1; apply <- Zgcd_1_rel_prime; auto. Defined. Definition prime_dec_aux: forall p m, { forall n, 1 < n < m -> rel_prime n p } + { exists n, 1 < n < m /\ ~ rel_prime n p }. Proof. intros p m. case (Z_lt_dec 1 m); intros H1; [ | left; intros; exfalso; omega ]. pattern m; apply natlike_rec; auto with zarith. left; intros; exfalso; omega. intros x Hx IH; destruct IH as [F|E]. destruct (rel_prime_dec x p) as [Y|N]. left; intros n [HH1 HH2]. rewrite Z.lt_succ_r in HH2. Z.le_elim HH2; subst; auto with zarith. - case (Z_lt_dec 1 x); intros HH1. * right; exists x; split; auto with zarith. * left; intros n [HHH1 HHH2]; contradict HHH1; auto with zarith. - right; destruct E as (n,((H0,H2),H3)); exists n; auto with zarith. Defined. Definition prime_dec: forall p, { prime p }+{ ~ prime p }. Proof. intros p; case (Z_lt_dec 1 p); intros H1. + case (prime_dec_aux p p); intros H2. * left; apply prime_intro; auto. intros n (Hn1,Hn2). Z.le_elim Hn1; auto; subst n. constructor; auto with zarith. * right; intros H3; inversion_clear H3 as [Hp1 Hp2]. case H2; intros n [Hn1 Hn2]; case Hn2; auto with zarith. + right; intros H3; inversion_clear H3 as [Hp1 Hp2]; case H1; auto. Defined. Theorem not_prime_divide: forall p, 1 < p -> ~ prime p -> exists n, 1 < n < p /\ (n | p). Proof. intros p Hp Hp1. case (prime_dec_aux p p); intros H1. - elim Hp1; constructor; auto. intros n (Hn1,Hn2). Z.le_elim Hn1; auto with zarith. subst n; constructor; auto with zarith. - case H1; intros n (Hn1,Hn2). destruct (Z_0_1_more _ (Z.gcd_nonneg n p)) as [H|[H|H]]. + exfalso. apply Z.gcd_eq_0_l in H. omega. + elim Hn2. red. rewrite <- H. apply Zgcd_is_gcd. + exists (Z.gcd n p); split; [ split; auto | apply Z.gcd_divide_r ]. apply Z.le_lt_trans with n; auto with zarith. apply Z.divide_pos_le; auto with zarith. apply Z.gcd_divide_l. Qed. coq-8.4pl4/theories/ZArith/Zmax.v0000644000175000017500000000462012326224777015766 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* = y /\ Z.max x y = x \/ x < y /\ Z.max x y = y. Proof. Z.swap_greater. destruct (Z.max_spec x y); auto. Qed. Lemma Zmax_left n m : n>=m -> Z.max n m = n. Proof. Z.swap_greater. apply Z.max_l. Qed. Lemma Zpos_max_1 p : Z.max 1 (Z.pos p) = Z.pos p. Proof. now destruct p. Qed. coq-8.4pl4/theories/ZArith/Zsqrt_compat.v0000644000175000017500000001700612326224777017537 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* match constr:X1 with | context [1%positive] => fail 1 | _ => rewrite (Pos2Z.inj_xI X1) end | |- context [(Zpos (xO ?X1))] => match constr:X1 with | context [1%positive] => fail 1 | _ => rewrite (Pos2Z.inj_xO X1) end end. Inductive sqrt_data (n:Z) : Set := c_sqrt : forall s r:Z, n = s * s + r -> 0 <= r <= 2 * s -> sqrt_data n. Definition sqrtrempos : forall p:positive, sqrt_data (Zpos p). refine (fix sqrtrempos (p:positive) : sqrt_data (Zpos p) := match p return sqrt_data (Zpos p) with | xH => c_sqrt 1 1 0 _ _ | xO xH => c_sqrt 2 1 1 _ _ | xI xH => c_sqrt 3 1 2 _ _ | xO (xO p') => match sqrtrempos p' with | c_sqrt s' r' Heq Hint => match Z_le_gt_dec (4 * s' + 1) (4 * r') with | left Hle => c_sqrt (Zpos (xO (xO p'))) (2 * s' + 1) (4 * r' - (4 * s' + 1)) _ _ | right Hgt => c_sqrt (Zpos (xO (xO p'))) (2 * s') (4 * r') _ _ end end | xO (xI p') => match sqrtrempos p' with | c_sqrt s' r' Heq Hint => match Z_le_gt_dec (4 * s' + 1) (4 * r' + 2) with | left Hle => c_sqrt (Zpos (xO (xI p'))) (2 * s' + 1) (4 * r' + 2 - (4 * s' + 1)) _ _ | right Hgt => c_sqrt (Zpos (xO (xI p'))) (2 * s') (4 * r' + 2) _ _ end end | xI (xO p') => match sqrtrempos p' with | c_sqrt s' r' Heq Hint => match Z_le_gt_dec (4 * s' + 1) (4 * r' + 1) with | left Hle => c_sqrt (Zpos (xI (xO p'))) (2 * s' + 1) (4 * r' + 1 - (4 * s' + 1)) _ _ | right Hgt => c_sqrt (Zpos (xI (xO p'))) (2 * s') (4 * r' + 1) _ _ end end | xI (xI p') => match sqrtrempos p' with | c_sqrt s' r' Heq Hint => match Z_le_gt_dec (4 * s' + 1) (4 * r' + 3) with | left Hle => c_sqrt (Zpos (xI (xI p'))) (2 * s' + 1) (4 * r' + 3 - (4 * s' + 1)) _ _ | right Hgt => c_sqrt (Zpos (xI (xI p'))) (2 * s') (4 * r' + 3) _ _ end end end); clear sqrtrempos; repeat compute_POS; try (try rewrite Heq; ring); try omega. Defined. (** Define with integer input, but with a strong (readable) specification. *) Definition Zsqrt : forall x:Z, 0 <= x -> {s : Z & {r : Z | x = s * s + r /\ s * s <= x < (s + 1) * (s + 1)}}. refine (fun x => match x return 0 <= x -> {s : Z & {r : Z | x = s * s + r /\ s * s <= x < (s + 1) * (s + 1)}} with | Zpos p => fun h => match sqrtrempos p with | c_sqrt s r Heq Hint => existT (fun s:Z => {r : Z | Zpos p = s * s + r /\ s * s <= Zpos p < (s + 1) * (s + 1)}) s (exist (fun r:Z => Zpos p = s * s + r /\ s * s <= Zpos p < (s + 1) * (s + 1)) r _) end | Zneg p => fun h => False_rec {s : Z & {r : Z | Zneg p = s * s + r /\ s * s <= Zneg p < (s + 1) * (s + 1)}} (h (eq_refl Datatypes.Gt)) | Z0 => fun h => existT (fun s:Z => {r : Z | 0 = s * s + r /\ s * s <= 0 < (s + 1) * (s + 1)}) 0 (exist (fun r:Z => 0 = 0 * 0 + r /\ 0 * 0 <= 0 < (0 + 1) * (0 + 1)) 0 _) end); try omega. split; [ omega | rewrite Heq; ring_simplify (s*s) ((s + 1) * (s + 1)); omega ]. Defined. (** Define a function of type Z->Z that computes the integer square root, but only for positive numbers, and 0 for others. *) Definition Zsqrt_plain (x:Z) : Z := match x with | Zpos p => match Zsqrt (Zpos p) (Pos2Z.is_nonneg p) with | existT s _ => s end | Zneg p => 0 | Z0 => 0 end. (** A basic theorem about Zsqrt_plain *) Theorem Zsqrt_interval : forall n:Z, 0 <= n -> Zsqrt_plain n * Zsqrt_plain n <= n < (Zsqrt_plain n + 1) * (Zsqrt_plain n + 1). Proof. intros [|p|p] Hp. - now compute. - unfold Zsqrt_plain. now destruct Zsqrt as (s & r & Heq & Hint). - now elim Hp. Qed. (** Positivity *) Theorem Zsqrt_plain_is_pos: forall n, 0 <= n -> 0 <= Zsqrt_plain n. Proof. intros n m; case (Zsqrt_interval n); auto with zarith. intros H1 H2; case (Z.le_gt_cases 0 (Zsqrt_plain n)); auto. intros H3; contradict H2; auto; apply Z.le_ngt. apply Z.le_trans with ( 2 := H1 ). replace ((Zsqrt_plain n + 1) * (Zsqrt_plain n + 1)) with (Zsqrt_plain n * Zsqrt_plain n + (2 * Zsqrt_plain n + 1)); auto with zarith. ring. Qed. (** Direct correctness on squares. *) Theorem Zsqrt_square_id: forall a, 0 <= a -> Zsqrt_plain (a * a) = a. Proof. intros a H. generalize (Zsqrt_plain_is_pos (a * a)); auto with zarith; intros Haa. case (Zsqrt_interval (a * a)); auto with zarith. intros H1 H2. case (Z.le_gt_cases a (Zsqrt_plain (a * a))); intros H3. - Z.le_elim H3; auto. contradict H1; auto; apply Z.lt_nge; auto with zarith. apply Z.le_lt_trans with (a * Zsqrt_plain (a * a)); auto with zarith. apply Z.mul_lt_mono_pos_r; auto with zarith. - contradict H2; auto; apply Z.le_ngt; auto with zarith. apply Z.mul_le_mono_nonneg; auto with zarith. Qed. (** [Zsqrt_plain] is increasing *) Theorem Zsqrt_le: forall p q, 0 <= p <= q -> Zsqrt_plain p <= Zsqrt_plain q. Proof. intros p q [H1 H2]. Z.le_elim H2; [ | subst q; auto with zarith]. case (Z.le_gt_cases (Zsqrt_plain p) (Zsqrt_plain q)); auto; intros H3. assert (Hp: (0 <= Zsqrt_plain q)). { apply Zsqrt_plain_is_pos; auto with zarith. } absurd (q <= p); auto with zarith. apply Z.le_trans with ((Zsqrt_plain q + 1) * (Zsqrt_plain q + 1)). case (Zsqrt_interval q); auto with zarith. apply Z.le_trans with (Zsqrt_plain p * Zsqrt_plain p); auto with zarith. apply Z.mul_le_mono_nonneg; auto with zarith. case (Zsqrt_interval p); auto with zarith. Qed. (** Equivalence between Zsqrt_plain and [Z.sqrt] *) Lemma Zsqrt_equiv : forall n, Zsqrt_plain n = Z.sqrt n. Proof. intros. destruct (Z_le_gt_dec 0 n). symmetry. apply Z.sqrt_unique; trivial. now apply Zsqrt_interval. now destruct n. Qed.coq-8.4pl4/theories/ZArith/Zdiv.v0000644000175000017500000005152412326224777015770 0ustar stephsteph(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 -> forall a:positive, let (q, r) := Z.pos_div_eucl a b in Zpos a = b * q + r /\ 0 <= r < b. Proof. intros b Hb a. Z.swap_greater. generalize (Z.pos_div_eucl_eq a b Hb) (Z.pos_div_eucl_bound a b Hb). destruct Z.pos_div_eucl. rewrite Z.mul_comm. auto. Qed. Theorem Z_div_mod a b : b > 0 -> let (q, r) := Z.div_eucl a b in a = b * q + r /\ 0 <= r < b. Proof. Z.swap_greater. intros Hb. assert (Hb' : b<>0) by (now destruct b). generalize (Z.div_eucl_eq a b Hb') (Z.mod_pos_bound a b Hb). unfold Z.modulo. destruct Z.div_eucl. auto. Qed. (** For stating the fully general result, let's give a short name to the condition on the remainder. *) Definition Remainder r b := 0 <= r < b \/ b < r <= 0. (** Another equivalent formulation: *) Definition Remainder_alt r b := Z.abs r < Z.abs b /\ Z.sgn r <> - Z.sgn b. (* In the last formulation, [ Z.sgn r <> - Z.sgn b ] is less nice than saying [ Z.sgn r = Z.sgn b ], but at least it works even when [r] is null. *) Lemma Remainder_equiv : forall r b, Remainder r b <-> Remainder_alt r b. Proof. intros; unfold Remainder, Remainder_alt; omega with *. Qed. Hint Unfold Remainder. (** Now comes the fully general result about Euclidean division. *) Theorem Z_div_mod_full a b : b <> 0 -> let (q, r) := Z.div_eucl a b in a = b * q + r /\ Remainder r b. Proof. intros Hb. generalize (Z.div_eucl_eq a b Hb) (Z.mod_pos_bound a b) (Z.mod_neg_bound a b). unfold Z.modulo. destruct Z.div_eucl as (q,r). intros EQ POS NEG. split; auto. red; destruct b. now destruct Hb. left; now apply POS. right; now apply NEG. Qed. (** The same results as before, stated separately in terms of Z.div and Z.modulo *) Lemma Z_mod_remainder a b : b<>0 -> Remainder (a mod b) b. Proof. unfold Z.modulo; intros Hb; generalize (Z_div_mod_full a b Hb); auto. destruct Z.div_eucl; tauto. Qed. Lemma Z_mod_lt a b : b > 0 -> 0 <= a mod b < b. Proof (fun Hb => Z.mod_pos_bound a b (Z.gt_lt _ _ Hb)). Lemma Z_mod_neg a b : b < 0 -> b < a mod b <= 0. Proof (Z.mod_neg_bound a b). Lemma Z_div_mod_eq a b : b > 0 -> a = b*(a/b) + (a mod b). Proof. intros Hb; apply Z.div_mod; auto with zarith. Qed. Lemma Zmod_eq_full a b : b<>0 -> a mod b = a - (a/b)*b. Proof. intros. rewrite Z.mul_comm. now apply Z.mod_eq. Qed. Lemma Zmod_eq a b : b>0 -> a mod b = a - (a/b)*b. Proof. intros. apply Zmod_eq_full. now destruct b. Qed. (** Existence theorem *) Theorem Zdiv_eucl_exist : forall (b:Z)(Hb:b>0)(a:Z), {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < b}. Proof. intros b Hb a. exists (Z.div_eucl a b). exact (Z_div_mod a b Hb). Qed. Arguments Zdiv_eucl_exist : default implicits. (** Uniqueness theorems *) Theorem Zdiv_mod_unique b q1 q2 r1 r2 : 0 <= r1 < Z.abs b -> 0 <= r2 < Z.abs b -> b*q1+r1 = b*q2+r2 -> q1=q2 /\ r1=r2. Proof. intros Hr1 Hr2 H. rewrite <- (Z.abs_sgn b), <- !Z.mul_assoc in H. destruct (Z.div_mod_unique (Z.abs b) (Z.sgn b * q1) (Z.sgn b * q2) r1 r2); auto. split; trivial. apply Z.mul_cancel_l with (Z.sgn b); trivial. rewrite Z.sgn_null_iff, <- Z.abs_0_iff. destruct Hr1; Z.order. Qed. Theorem Zdiv_mod_unique_2 : forall b q1 q2 r1 r2:Z, Remainder r1 b -> Remainder r2 b -> b*q1+r1 = b*q2+r2 -> q1=q2 /\ r1=r2. Proof Z.div_mod_unique. Theorem Zdiv_unique_full: forall a b q r, Remainder r b -> a = b*q + r -> q = a/b. Proof Z.div_unique. Theorem Zdiv_unique: forall a b q r, 0 <= r < b -> a = b*q + r -> q = a/b. Proof. intros; eapply Zdiv_unique_full; eauto. Qed. Theorem Zmod_unique_full: forall a b q r, Remainder r b -> a = b*q + r -> r = a mod b. Proof Z.mod_unique. Theorem Zmod_unique: forall a b q r, 0 <= r < b -> a = b*q + r -> r = a mod b. Proof. intros; eapply Zmod_unique_full; eauto. Qed. (** * Basic values of divisions and modulo. *) Lemma Zmod_0_l: forall a, 0 mod a = 0. Proof. destruct a; simpl; auto. Qed. Lemma Zmod_0_r: forall a, a mod 0 = 0. Proof. destruct a; simpl; auto. Qed. Lemma Zdiv_0_l: forall a, 0/a = 0. Proof. destruct a; simpl; auto. Qed. Lemma Zdiv_0_r: forall a, a/0 = 0. Proof. destruct a; simpl; auto. Qed. Ltac zero_or_not a := destruct (Z.eq_dec a 0); [subst; rewrite ?Zmod_0_l, ?Zdiv_0_l, ?Zmod_0_r, ?Zdiv_0_r; auto with zarith|]. Lemma Zmod_1_r: forall a, a mod 1 = 0. Proof. intros. zero_or_not a. apply Z.mod_1_r. Qed. Lemma Zdiv_1_r: forall a, a/1 = a. Proof. intros. zero_or_not a. apply Z.div_1_r. Qed. Hint Resolve Zmod_0_l Zmod_0_r Zdiv_0_l Zdiv_0_r Zdiv_1_r Zmod_1_r : zarith. Lemma Zdiv_1_l: forall a, 1 < a -> 1/a = 0. Proof Z.div_1_l. Lemma Zmod_1_l: forall a, 1 < a -> 1 mod a = 1. Proof Z.mod_1_l. Lemma Z_div_same_full : forall a:Z, a<>0 -> a/a = 1. Proof Z.div_same. Lemma Z_mod_same_full : forall a, a mod a = 0. Proof. intros. zero_or_not a. apply Z.mod_same; auto. Qed. Lemma Z_mod_mult : forall a b, (a*b) mod b = 0. Proof. intros. zero_or_not b. apply Z.mod_mul. auto. Qed. Lemma Z_div_mult_full : forall a b:Z, b <> 0 -> (a*b)/b = a. Proof Z.div_mul. (** * Order results about Z.modulo and Z.div *) (* Division of positive numbers is positive. *) Lemma Z_div_pos: forall a b, b > 0 -> 0 <= a -> 0 <= a/b. Proof. intros. apply Z.div_pos; auto with zarith. Qed. Lemma Z_div_ge0: forall a b, b > 0 -> a >= 0 -> a/b >=0. Proof. intros; generalize (Z_div_pos a b H); auto with zarith. Qed. (** As soon as the divisor is greater or equal than 2, the division is strictly decreasing. *) Lemma Z_div_lt : forall a b:Z, b >= 2 -> a > 0 -> a/b < a. Proof. intros. apply Z.div_lt; auto with zarith. Qed. (** A division of a small number by a bigger one yields zero. *) Theorem Zdiv_small: forall a b, 0 <= a < b -> a/b = 0. Proof Z.div_small. (** Same situation, in term of modulo: *) Theorem Zmod_small: forall a n, 0 <= a < n -> a mod n = a. Proof Z.mod_small. (** [Z.ge] is compatible with a positive division. *) Lemma Z_div_ge : forall a b c:Z, c > 0 -> a >= b -> a/c >= b/c. Proof. intros. apply Z.le_ge. apply Z.div_le_mono; auto with zarith. Qed. (** Same, with [Z.le]. *) Lemma Z_div_le : forall a b c:Z, c > 0 -> a <= b -> a/c <= b/c. Proof. intros. apply Z.div_le_mono; auto with zarith. Qed. (** With our choice of division, rounding of (a/b) is always done toward bottom: *) Lemma Z_mult_div_ge : forall a b:Z, b > 0 -> b*(a/b) <= a. Proof. intros. apply Z.mul_div_le; auto with zarith. Qed. Lemma Z_mult_div_ge_neg : forall a b:Z, b < 0 -> b*(a/b) >= a. Proof. intros. apply Z.le_ge. apply Z.mul_div_ge; auto with zarith. Qed. (** The previous inequalities are exact iff the modulo is zero. *) Lemma Z_div_exact_full_1 : forall a b:Z, a = b*(a/b) -> a mod b = 0. Proof. intros a b. zero_or_not b. rewrite Z.div_exact; auto. Qed. Lemma Z_div_exact_full_2 : forall a b:Z, b <> 0 -> a mod b = 0 -> a = b*(a/b). Proof. intros; rewrite Z.div_exact; auto. Qed. (** A modulo cannot grow beyond its starting point. *) Theorem Zmod_le: forall a b, 0 < b -> 0 <= a -> a mod b <= a. Proof. intros. apply Z.mod_le; auto. Qed. (** Some additionnal inequalities about Z.div. *) Theorem Zdiv_lt_upper_bound: forall a b q, 0 < b -> a < q*b -> a/b < q. Proof. intros a b q; rewrite Z.mul_comm; apply Z.div_lt_upper_bound. Qed. Theorem Zdiv_le_upper_bound: forall a b q, 0 < b -> a <= q*b -> a/b <= q. Proof. intros a b q; rewrite Z.mul_comm; apply Z.div_le_upper_bound. Qed. Theorem Zdiv_le_lower_bound: forall a b q, 0 < b -> q*b <= a -> q <= a/b. Proof. intros a b q; rewrite Z.mul_comm; apply Z.div_le_lower_bound. Qed. (** A division of respect opposite monotonicity for the divisor *) Lemma Zdiv_le_compat_l: forall p q r, 0 <= p -> 0 < q < r -> p / r <= p / q. Proof. intros; apply Z.div_le_compat_l; auto with zarith. Qed. Theorem Zdiv_sgn: forall a b, 0 <= Z.sgn (a/b) * Z.sgn a * Z.sgn b. Proof. destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; generalize (Z.div_pos (Zpos a) (Zpos b)); unfold Z.div, Z.div_eucl; destruct Z.pos_div_eucl as (q,r); destruct r; omega with *. Qed. (** * Relations between usual operations and Z.modulo and Z.div *) Lemma Z_mod_plus_full : forall a b c:Z, (a + b * c) mod c = a mod c. Proof. intros. zero_or_not c. apply Z.mod_add; auto. Qed. Lemma Z_div_plus_full : forall a b c:Z, c <> 0 -> (a + b * c) / c = a / c + b. Proof Z.div_add. Theorem Z_div_plus_full_l: forall a b c : Z, b <> 0 -> (a * b + c) / b = a + c / b. Proof Z.div_add_l. (** [Z.opp] and [Z.div], [Z.modulo]. Due to the choice of convention for our Euclidean division, some of the relations about [Z.opp] and divisions are rather complex. *) Lemma Zdiv_opp_opp : forall a b:Z, (-a)/(-b) = a/b. Proof. intros. zero_or_not b. apply Z.div_opp_opp; auto. Qed. Lemma Zmod_opp_opp : forall a b:Z, (-a) mod (-b) = - (a mod b). Proof. intros. zero_or_not b. apply Z.mod_opp_opp; auto. Qed. Lemma Z_mod_zero_opp_full : forall a b:Z, a mod b = 0 -> (-a) mod b = 0. Proof. intros. zero_or_not b. apply Z.mod_opp_l_z; auto. Qed. Lemma Z_mod_nz_opp_full : forall a b:Z, a mod b <> 0 -> (-a) mod b = b - (a mod b). Proof. intros. zero_or_not b. apply Z.mod_opp_l_nz; auto. Qed. Lemma Z_mod_zero_opp_r : forall a b:Z, a mod b = 0 -> a mod (-b) = 0. Proof. intros. zero_or_not b. apply Z.mod_opp_r_z; auto. Qed. Lemma Z_mod_nz_opp_r : forall a b:Z, a mod b <> 0 -> a mod (-b) = (a mod b) - b. Proof. intros. zero_or_not b. apply Z.mod_opp_r_nz; auto. Qed. Lemma Z_div_zero_opp_full : forall a b:Z, a mod b = 0 -> (-a)/b = -(a/b). Proof. intros. zero_or_not b. apply Z.div_opp_l_z; auto. Qed. Lemma Z_div_nz_opp_full : forall a b:Z, a mod b <> 0 -> (-a)/b = -(a/b)-1. Proof. intros a b. zero_or_not b. intros; rewrite Z.div_opp_l_nz; auto. Qed. Lemma Z_div_zero_opp_r : forall a b:Z, a mod b = 0 -> a/(-b) = -(a/b). Proof. intros. zero_or_not b. apply Z.div_opp_r_z; auto. Qed. Lemma Z_div_nz_opp_r : forall a b:Z, a mod b <> 0 -> a/(-b) = -(a/b)-1. Proof. intros a b. zero_or_not b. intros; rewrite Z.div_opp_r_nz; auto. Qed. (** Cancellations. *) Lemma Zdiv_mult_cancel_r : forall a b c:Z, c <> 0 -> (a*c)/(b*c) = a/b. Proof. intros. zero_or_not b. apply Z.div_mul_cancel_r; auto. Qed. Lemma Zdiv_mult_cancel_l : forall a b c:Z, c<>0 -> (c*a)/(c*b) = a/b. Proof. intros. rewrite (Z.mul_comm c b); zero_or_not b. rewrite (Z.mul_comm b c). apply Z.div_mul_cancel_l; auto. Qed. Lemma Zmult_mod_distr_l: forall a b c, (c*a) mod (c*b) = c * (a mod b). Proof. intros. zero_or_not c. rewrite (Z.mul_comm c b); zero_or_not b. rewrite (Z.mul_comm b c). apply Z.mul_mod_distr_l; auto. Qed. Lemma Zmult_mod_distr_r: forall a b c, (a*c) mod (b*c) = (a mod b) * c. Proof. intros. zero_or_not b. rewrite (Z.mul_comm b c); zero_or_not c. rewrite (Z.mul_comm c b). apply Z.mul_mod_distr_r; auto. Qed. (** Operations modulo. *) Theorem Zmod_mod: forall a n, (a mod n) mod n = a mod n. Proof. intros. zero_or_not n. apply Z.mod_mod; auto. Qed. Theorem Zmult_mod: forall a b n, (a * b) mod n = ((a mod n) * (b mod n)) mod n. Proof. intros. zero_or_not n. apply Z.mul_mod; auto. Qed. Theorem Zplus_mod: forall a b n, (a + b) mod n = (a mod n + b mod n) mod n. Proof. intros. zero_or_not n. apply Z.add_mod; auto. Qed. Theorem Zminus_mod: forall a b n, (a - b) mod n = (a mod n - b mod n) mod n. Proof. intros. replace (a - b) with (a + (-1) * b); auto with zarith. replace (a mod n - b mod n) with (a mod n + (-1) * (b mod n)); auto with zarith. rewrite Zplus_mod. rewrite Zmult_mod. rewrite Zplus_mod with (b:=(-1) * (b mod n)). rewrite Zmult_mod. rewrite Zmult_mod with (b:= b mod n). repeat rewrite Zmod_mod; auto. Qed. Lemma Zplus_mod_idemp_l: forall a b n, (a mod n + b) mod n = (a + b) mod n. Proof. intros; rewrite Zplus_mod, Zmod_mod, <- Zplus_mod; auto. Qed. Lemma Zplus_mod_idemp_r: forall a b n, (b + a mod n) mod n = (b + a) mod n. Proof. intros; rewrite Zplus_mod, Zmod_mod, <- Zplus_mod; auto. Qed. Lemma Zminus_mod_idemp_l: forall a b n, (a mod n - b) mod n = (a - b) mod n. Proof. intros; rewrite Zminus_mod, Zmod_mod, <- Zminus_mod; auto. Qed. Lemma Zminus_mod_idemp_r: forall a b n, (a - b mod n) mod n = (a - b) mod n. Proof. intros; rewrite Zminus_mod, Zmod_mod, <- Zminus_mod; auto. Qed. Lemma Zmult_mod_idemp_l: forall a b n, (a mod n * b) mod n = (a * b) mod n. Proof. intros; rewrite Zmult_mod, Zmod_mod, <- Zmult_mod; auto. Qed. Lemma Zmult_mod_idemp_r: forall a b n, (b * (a mod n)) mod n = (b * a) mod n. Proof. intros; rewrite Zmult_mod, Zmod_mod, <- Zmult_mod; auto. Qed. (** For a specific number N, equality modulo N is hence a nice setoid equivalence, compatible with [+], [-] and [*]. *) Section EqualityModulo. Variable N:Z. Definition eqm a b := (a mod N = b mod N). Infix "==" := eqm (at level 70). Lemma eqm_refl : forall a, a == a. Proof. unfold eqm; auto. Qed. Lemma eqm_sym : forall a b, a == b -> b == a. Proof. unfold eqm; auto. Qed. Lemma eqm_trans : forall a b c, a == b -> b == c -> a == c. Proof. unfold eqm; eauto with *. Qed. Instance eqm_setoid : Equivalence eqm. Proof. constructor; [exact eqm_refl | exact eqm_sym | exact eqm_trans]. Qed. Instance Zplus_eqm : Proper (eqm ==> eqm ==> eqm) Z.add. Proof. unfold eqm; repeat red; intros. rewrite Zplus_mod, H, H0, <- Zplus_mod; auto. Qed. Instance Zminus_eqm : Proper (eqm ==> eqm ==> eqm) Z.sub. Proof. unfold eqm; repeat red; intros. rewrite Zminus_mod, H, H0, <- Zminus_mod; auto. Qed. Instance Zmult_eqm : Proper (eqm ==> eqm ==> eqm) Z.mul. Proof. unfold eqm; repeat red; intros. rewrite Zmult_mod, H, H0, <- Zmult_mod; auto. Qed. Instance Zopp_eqm : Proper (eqm ==> eqm) Z.opp. Proof. intros x y H. change ((-x)==(-y)) with ((0-x)==(0-y)). now rewrite H. Qed. Lemma Zmod_eqm : forall a, (a mod N) == a. Proof. intros; exact (Zmod_mod a N). Qed. (* NB: Z.modulo and Z.div are not morphisms with respect to eqm. For instance, let (==) be (eqm 2). Then we have (3 == 1) but: ~ (3 mod 3 == 1 mod 3) ~ (1 mod 3 == 1 mod 1) ~ (3/3 == 1/3) ~ (1/3 == 1/1) *) End EqualityModulo. Lemma Zdiv_Zdiv : forall a b c, 0<=b -> 0<=c -> (a/b)/c = a/(b*c). Proof. intros. zero_or_not b. rewrite Z.mul_comm. zero_or_not c. rewrite Z.mul_comm. apply Z.div_div; auto with zarith. Qed. (** Unfortunately, the previous result isn't always true on negative numbers. For instance: 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) *) (** A last inequality: *) Theorem Zdiv_mult_le: forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a/b) <= (c*a)/b. Proof. intros. zero_or_not b. apply Z.div_mul_le; auto with zarith. Qed. (** Z.modulo is related to divisibility (see more in Znumtheory) *) Lemma Zmod_divides : forall a b, b<>0 -> (a mod b = 0 <-> exists c, a = b*c). Proof. intros. rewrite Z.mod_divide; trivial. split; intros (c,Hc); exists c; subst; auto with zarith. Qed. (** Particular case : dividing by 2 is related with parity *) Lemma Zdiv2_div : forall a, Z.div2 a = a/2. Proof Z.div2_div. Lemma Zmod_odd : forall a, a mod 2 = if Z.odd a then 1 else 0. Proof. intros a. now rewrite <- Z.bit0_odd, <- Z.bit0_mod. Qed. Lemma Zmod_even : forall a, a mod 2 = if Z.even a then 0 else 1. Proof. intros a. rewrite Zmod_odd, Zodd_even_bool. now destruct Z.even. Qed. Lemma Zodd_mod : forall a, Z.odd a = Zeq_bool (a mod 2) 1. Proof. intros a. rewrite Zmod_odd. now destruct Z.odd. Qed. Lemma Zeven_mod : forall a, Z.even a = Zeq_bool (a mod 2) 0. Proof. intros a. rewrite Zmod_even. now destruct Z.even. Qed. (** * Compatibility *) (** Weaker results kept only for compatibility *) Lemma Z_mod_same : forall a, a > 0 -> a mod a = 0. Proof. intros; apply Z_mod_same_full. Qed. Lemma Z_div_same : forall a, a > 0 -> a/a = 1. Proof. intros; apply Z_div_same_full; auto with zarith. Qed. Lemma Z_div_plus : forall a b c:Z, c > 0 -> (a + b * c) / c = a / c + b. Proof. intros; apply Z_div_plus_full; auto with zarith. Qed. Lemma Z_div_mult : forall a b:Z, b > 0 -> (a*b)/b = a. Proof. intros; apply Z_div_mult_full; auto with zarith. Qed. Lemma Z_mod_plus : forall a b c:Z, c > 0 -> (a + b * c) mod c = a mod c. Proof. intros; apply Z_mod_plus_full; auto with zarith. Qed. Lemma Z_div_exact_1 : forall a b:Z, b > 0 -> a = b*(a/b) -> a mod b = 0. Proof. intros; apply Z_div_exact_full_1; auto with zarith. Qed. Lemma Z_div_exact_2 : forall a b:Z, b > 0 -> a mod b = 0 -> a = b*(a/b). Proof. intros; apply Z_div_exact_full_2; auto with zarith. Qed. Lemma Z_mod_zero_opp : forall a b:Z, b > 0 -> a mod b = 0 -> (-a) mod b = 0. Proof. intros; apply Z_mod_zero_opp_full; auto with zarith. Qed. (** * A direct way to compute Z.modulo *) Fixpoint Zmod_POS (a : positive) (b : Z) : Z := match a with | xI a' => let r := Zmod_POS a' b in let r' := (2 * r + 1) in if r' let r := Zmod_POS a' b in let r' := (2 * r) in if r' if 2 <=? b then 1 else 0 end. Definition Zmod' a b := match a with | Z0 => 0 | Zpos a' => match b with | Z0 => 0 | Zpos _ => Zmod_POS a' b | Zneg b' => let r := Zmod_POS a' (Zpos b') in match r with Z0 => 0 | _ => b + r end end | Zneg a' => match b with | Z0 => 0 | Zpos _ => let r := Zmod_POS a' b in match r with Z0 => 0 | _ => b - r end | Zneg b' => - (Zmod_POS a' (Zpos b')) end end. Theorem Zmod_POS_correct a b : Zmod_POS a b = snd (Z.pos_div_eucl a b). Proof. induction a as [a IH|a IH| ]; simpl; rewrite ?IH. destruct (Z.pos_div_eucl a b) as (p,q); simpl; case Z.ltb_spec; reflexivity. destruct (Z.pos_div_eucl a b) as (p,q); simpl; case Z.ltb_spec; reflexivity. case Z.leb_spec; trivial. Qed. Theorem Zmod'_correct: forall a b, Zmod' a b = a mod b. Proof. intros a b; unfold Z.modulo; case a; simpl; auto. intros p; case b; simpl; auto. intros p1; refine (Zmod_POS_correct _ _); auto. intros p1; rewrite Zmod_POS_correct; auto. case (Z.pos_div_eucl p (Zpos p1)); simpl; intros z1 z2; case z2; auto. intros p; case b; simpl; auto. intros p1; rewrite Zmod_POS_correct; auto. case (Z.pos_div_eucl p (Zpos p1)); simpl; intros z1 z2; case z2; auto. intros p1; rewrite Zmod_POS_correct; simpl; auto. case (Z.pos_div_eucl p (Zpos p1)); auto. Qed. (** Another convention is possible for division by negative numbers: * quotient is always the biggest integer smaller than or equal to a/b * remainder is hence always positive or null. *) Theorem Zdiv_eucl_extended : forall b:Z, b <> 0 -> forall a:Z, {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < Z.abs b}. Proof. intros b Hb a. elim (Z_le_gt_dec 0 b); intro Hb'. cut (b > 0); [ intro Hb'' | omega ]. rewrite Z.abs_eq; [ apply Zdiv_eucl_exist; assumption | assumption ]. cut (- b > 0); [ intro Hb'' | omega ]. elim (Zdiv_eucl_exist Hb'' a); intros qr. elim qr; intros q r Hqr. exists (- q, r). elim Hqr; intros. split. rewrite <- Z.mul_opp_comm; assumption. rewrite Z.abs_neq; [ assumption | omega ]. Qed. Arguments Zdiv_eucl_extended : default implicits. (** * Division and modulo in Z agree with same in nat: *) Require Import NPeano. Lemma div_Zdiv (n m: nat): m <> O -> Z.of_nat (n / m) = Z.of_nat n / Z.of_nat m. Proof. intros. apply (Zdiv_unique _ _ _ (Z.of_nat (n mod m))). split. auto with zarith. now apply inj_lt, Nat.mod_upper_bound. rewrite <- Nat2Z.inj_mul, <- Nat2Z.inj_add. now apply inj_eq, Nat.div_mod. Qed. Lemma mod_Zmod (n m: nat): m <> O -> Z.of_nat (n mod m) = (Z.of_nat n) mod (Z.of_nat m). Proof. intros. apply (Zmod_unique _ _ (Z.of_nat n / Z.of_nat m)). split. auto with zarith. now apply inj_lt, Nat.mod_upper_bound. rewrite <- div_Zdiv, <- Nat2Z.inj_mul, <- Nat2Z.inj_add by trivial. now apply inj_eq, Nat.div_mod. Qed. coq-8.4pl4/theories/ZArith/Zquot.v0000644000175000017500000003403012326224777016167 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0] condition whenever possible. *) Lemma Zrem_0_l a : Z.rem 0 a = 0. Proof. now destruct a. Qed. Lemma Zquot_0_l a : 0÷a = 0. Proof. now destruct a. Qed. Hint Resolve Zrem_0_l Zrem_0_r Zquot_0_l Zquot_0_r Z.quot_1_r Z.rem_1_r : zarith. Ltac zero_or_not a := destruct (Z.eq_decidable a 0) as [->|?]; [rewrite ?Zquot_0_l, ?Zrem_0_l, ?Zquot_0_r, ?Zrem_0_r; auto with zarith|]. Lemma Z_rem_same a : Z.rem a a = 0. Proof. zero_or_not a. now apply Z.rem_same. Qed. Lemma Z_rem_mult a b : Z.rem (a*b) b = 0. Proof. zero_or_not b. now apply Z.rem_mul. Qed. (** * Division and Opposite *) (* The precise equalities that are invalid with "historic" Zdiv. *) Theorem Zquot_opp_l a b : (-a)÷b = -(a÷b). Proof. zero_or_not b. now apply Z.quot_opp_l. Qed. Theorem Zquot_opp_r a b : a÷(-b) = -(a÷b). Proof. zero_or_not b. now apply Z.quot_opp_r. Qed. Theorem Zrem_opp_l a b : Z.rem (-a) b = -(Z.rem a b). Proof. zero_or_not b. now apply Z.rem_opp_l. Qed. Theorem Zrem_opp_r a b : Z.rem a (-b) = Z.rem a b. Proof. zero_or_not b. now apply Z.rem_opp_r. Qed. Theorem Zquot_opp_opp a b : (-a)÷(-b) = a÷b. Proof. zero_or_not b. now apply Z.quot_opp_opp. Qed. Theorem Zrem_opp_opp a b : Z.rem (-a) (-b) = -(Z.rem a b). Proof. zero_or_not b. now apply Z.rem_opp_opp. Qed. (** The sign of the remainder is the one of [a]. Due to the possible nullity of [a], a general result is to be stated in the following form: *) Theorem Zrem_sgn a b : 0 <= Z.sgn (Z.rem a b) * Z.sgn a. Proof. zero_or_not b. - apply Z.square_nonneg. - zero_or_not (Z.rem a b). rewrite Z.rem_sign_nz; trivial. apply Z.square_nonneg. Qed. (** This can also be said in a simplier way: *) Theorem Zrem_sgn2 a b : 0 <= (Z.rem a b) * a. Proof. zero_or_not b. - apply Z.square_nonneg. - now apply Z.rem_sign_mul. Qed. (** Reformulation of [Z.rem_bound_abs] in 2 then 4 particular cases. *) Theorem Zrem_lt_pos a b : 0<=a -> b<>0 -> 0 <= Z.rem a b < Z.abs b. Proof. intros; generalize (Z.rem_nonneg a b) (Z.rem_bound_abs a b); romega with *. Qed. Theorem Zrem_lt_neg a b : a<=0 -> b<>0 -> -Z.abs b < Z.rem a b <= 0. Proof. intros; generalize (Z.rem_nonpos a b) (Z.rem_bound_abs a b); romega with *. Qed. Theorem Zrem_lt_pos_pos a b : 0<=a -> 0 0 <= Z.rem a b < b. Proof. intros; generalize (Zrem_lt_pos a b); romega with *. Qed. Theorem Zrem_lt_pos_neg a b : 0<=a -> b<0 -> 0 <= Z.rem a b < -b. Proof. intros; generalize (Zrem_lt_pos a b); romega with *. Qed. Theorem Zrem_lt_neg_pos a b : a<=0 -> 0 -b < Z.rem a b <= 0. Proof. intros; generalize (Zrem_lt_neg a b); romega with *. Qed. Theorem Zrem_lt_neg_neg a b : a<=0 -> b<0 -> b < Z.rem a b <= 0. Proof. intros; generalize (Zrem_lt_neg a b); romega with *. Qed. (** * Unicity results *) Definition Remainder a b r := (0 <= a /\ 0 <= r < Z.abs b) \/ (a <= 0 /\ -Z.abs b < r <= 0). Definition Remainder_alt a b r := Z.abs r < Z.abs b /\ 0 <= r * a. Lemma Remainder_equiv : forall a b r, Remainder a b r <-> Remainder_alt a b r. Proof. unfold Remainder, Remainder_alt; intuition. - romega with *. - romega with *. - rewrite <-(Z.mul_opp_opp). apply Z.mul_nonneg_nonneg; romega. - assert (0 <= Z.sgn r * Z.sgn a). { rewrite <-Z.sgn_mul, Z.sgn_nonneg; auto. } destruct r; simpl Z.sgn in *; romega with *. Qed. Theorem Zquot_mod_unique_full a b q r : Remainder a b r -> a = b*q + r -> q = a÷b /\ r = Z.rem a b. Proof. destruct 1 as [(H,H0)|(H,H0)]; intros. apply Zdiv_mod_unique with b; auto. apply Zrem_lt_pos; auto. romega with *. rewrite <- H1; apply Z.quot_rem'. rewrite <- (Z.opp_involutive a). rewrite Zquot_opp_l, Zrem_opp_l. generalize (Zdiv_mod_unique b (-q) (-a÷b) (-r) (Z.rem (-a) b)). generalize (Zrem_lt_pos (-a) b). rewrite <-Z.quot_rem', Z.mul_opp_r, <-Z.opp_add_distr, <-H1. romega with *. Qed. Theorem Zquot_unique_full a b q r : Remainder a b r -> a = b*q + r -> q = a÷b. Proof. intros; destruct (Zquot_mod_unique_full a b q r); auto. Qed. Theorem Zrem_unique_full a b q r : Remainder a b r -> a = b*q + r -> r = Z.rem a b. Proof. intros; destruct (Zquot_mod_unique_full a b q r); auto. Qed. (** * Order results about Zrem and Zquot *) (* Division of positive numbers is positive. *) Lemma Z_quot_pos a b : 0 <= a -> 0 <= b -> 0 <= a÷b. Proof. intros. zero_or_not b. apply Z.quot_pos; auto with zarith. Qed. (** As soon as the divisor is greater or equal than 2, the division is strictly decreasing. *) Lemma Z_quot_lt a b : 0 < a -> 2 <= b -> a÷b < a. Proof. intros. apply Z.quot_lt; auto with zarith. Qed. (** [<=] is compatible with a positive division. *) Lemma Z_quot_monotone a b c : 0<=c -> a<=b -> a÷c <= b÷c. Proof. intros. zero_or_not c. apply Z.quot_le_mono; auto with zarith. Qed. (** With our choice of division, rounding of (a÷b) is always done toward 0: *) Lemma Z_mult_quot_le a b : 0 <= a -> 0 <= b*(a÷b) <= a. Proof. intros. zero_or_not b. apply Z.mul_quot_le; auto with zarith. Qed. Lemma Z_mult_quot_ge a b : a <= 0 -> a <= b*(a÷b) <= 0. Proof. intros. zero_or_not b. apply Z.mul_quot_ge; auto with zarith. Qed. (** The previous inequalities between [b*(a÷b)] and [a] are exact iff the modulo is zero. *) Lemma Z_quot_exact_full a b : a = b*(a÷b) <-> Z.rem a b = 0. Proof. intros. zero_or_not b. intuition. apply Z.quot_exact; auto. Qed. (** A modulo cannot grow beyond its starting point. *) Theorem Zrem_le a b : 0 <= a -> 0 <= b -> Z.rem a b <= a. Proof. intros. zero_or_not b. apply Z.rem_le; auto with zarith. Qed. (** Some additionnal inequalities about Zdiv. *) Theorem Zquot_le_upper_bound: forall a b q, 0 < b -> a <= q*b -> a÷b <= q. Proof. intros a b q; rewrite Z.mul_comm; apply Z.quot_le_upper_bound. Qed. Theorem Zquot_lt_upper_bound: forall a b q, 0 <= a -> 0 < b -> a < q*b -> a÷b < q. Proof. intros a b q; rewrite Z.mul_comm; apply Z.quot_lt_upper_bound. Qed. Theorem Zquot_le_lower_bound: forall a b q, 0 < b -> q*b <= a -> q <= a÷b. Proof. intros a b q; rewrite Z.mul_comm; apply Z.quot_le_lower_bound. Qed. Theorem Zquot_sgn: forall a b, 0 <= Z.sgn (a÷b) * Z.sgn a * Z.sgn b. Proof. destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; unfold Z.quot; simpl; destruct N.pos_div_eucl; simpl; destruct n; simpl; auto with zarith. Qed. (** * Relations between usual operations and Zmod and Zdiv *) (** First, a result that used to be always valid with Zdiv, but must be restricted here. For instance, now (9+(-5)*2) rem 2 = -1 <> 1 = 9 rem 2 *) Lemma Z_rem_plus : forall a b c:Z, 0 <= (a+b*c) * a -> Z.rem (a + b * c) c = Z.rem a c. Proof. intros. zero_or_not c. apply Z.rem_add; auto with zarith. Qed. Lemma Z_quot_plus : forall a b c:Z, 0 <= (a+b*c) * a -> c<>0 -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros. apply Z.quot_add; auto with zarith. Qed. Theorem Z_quot_plus_l: forall a b c : Z, 0 <= (a*b+c)*c -> b<>0 -> b<>0 -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros. apply Z.quot_add_l; auto with zarith. Qed. (** Cancellations. *) Lemma Zquot_mult_cancel_r : forall a b c:Z, c<>0 -> (a*c)÷(b*c) = a÷b. Proof. intros. zero_or_not b. apply Z.quot_mul_cancel_r; auto. Qed. Lemma Zquot_mult_cancel_l : forall a b c:Z, c<>0 -> (c*a)÷(c*b) = a÷b. Proof. intros. rewrite (Z.mul_comm c b). zero_or_not b. rewrite (Z.mul_comm b c). apply Z.quot_mul_cancel_l; auto. Qed. Lemma Zmult_rem_distr_l: forall a b c, Z.rem (c*a) (c*b) = c * (Z.rem a b). Proof. intros. zero_or_not c. rewrite (Z.mul_comm c b). zero_or_not b. rewrite (Z.mul_comm b c). apply Z.mul_rem_distr_l; auto. Qed. Lemma Zmult_rem_distr_r: forall a b c, Z.rem (a*c) (b*c) = (Z.rem a b) * c. Proof. intros. zero_or_not b. rewrite (Z.mul_comm b c). zero_or_not c. rewrite (Z.mul_comm c b). apply Z.mul_rem_distr_r; auto. Qed. (** Operations modulo. *) Theorem Zrem_rem: forall a n, Z.rem (Z.rem a n) n = Z.rem a n. Proof. intros. zero_or_not n. apply Z.rem_rem; auto. Qed. Theorem Zmult_rem: forall a b n, Z.rem (a * b) n = Z.rem (Z.rem a n * Z.rem b n) n. Proof. intros. zero_or_not n. apply Z.mul_rem; auto. Qed. (** addition and modulo Generally speaking, unlike with Zdiv, we don't have (a+b) rem n = (a rem n + b rem n) rem n for any a and b. For instance, take (8 + (-10)) rem 3 = -2 whereas (8 rem 3 + (-10 rem 3)) rem 3 = 1. *) Theorem Zplus_rem: forall a b n, 0 <= a * b -> Z.rem (a + b) n = Z.rem (Z.rem a n + Z.rem b n) n. Proof. intros. zero_or_not n. apply Z.add_rem; auto. Qed. Lemma Zplus_rem_idemp_l: forall a b n, 0 <= a * b -> Z.rem (Z.rem a n + b) n = Z.rem (a + b) n. Proof. intros. zero_or_not n. apply Z.add_rem_idemp_l; auto. Qed. Lemma Zplus_rem_idemp_r: forall a b n, 0 <= a*b -> Z.rem (b + Z.rem a n) n = Z.rem (b + a) n. Proof. intros. zero_or_not n. apply Z.add_rem_idemp_r; auto. rewrite Z.mul_comm; auto. Qed. Lemma Zmult_rem_idemp_l: forall a b n, Z.rem (Z.rem a n * b) n = Z.rem (a * b) n. Proof. intros. zero_or_not n. apply Z.mul_rem_idemp_l; auto. Qed. Lemma Zmult_rem_idemp_r: forall a b n, Z.rem (b * Z.rem a n) n = Z.rem (b * a) n. Proof. intros. zero_or_not n. apply Z.mul_rem_idemp_r; auto. Qed. (** Unlike with Zdiv, the following result is true without restrictions. *) Lemma Zquot_Zquot : forall a b c, (a÷b)÷c = a÷(b*c). Proof. intros. zero_or_not b. rewrite Z.mul_comm. zero_or_not c. rewrite Z.mul_comm. apply Z.quot_quot; auto. Qed. (** A last inequality: *) Theorem Zquot_mult_le: forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a÷b) <= (c*a)÷b. Proof. intros. zero_or_not b. apply Z.quot_mul_le; auto with zarith. Qed. (** Z.rem is related to divisibility (see more in Znumtheory) *) Lemma Zrem_divides : forall a b, Z.rem a b = 0 <-> exists c, a = b*c. Proof. intros. zero_or_not b. firstorder. rewrite Z.rem_divide; trivial. split; intros (c,Hc); exists c; subst; auto with zarith. Qed. (** Particular case : dividing by 2 is related with parity *) Lemma Zquot2_odd_remainder : forall a, Remainder a 2 (if Z.odd a then Z.sgn a else 0). Proof. intros [ |p|p]. simpl. left. simpl. auto with zarith. left. destruct p; simpl; auto with zarith. right. destruct p; simpl; split; now auto with zarith. Qed. Lemma Zrem_odd : forall a, Z.rem a 2 = if Z.odd a then Z.sgn a else 0. Proof. intros. symmetry. apply Zrem_unique_full with (Z.quot2 a). apply Zquot2_odd_remainder. apply Zquot2_odd_eqn. Qed. Lemma Zrem_even : forall a, Z.rem a 2 = if Z.even a then 0 else Z.sgn a. Proof. intros a. rewrite Zrem_odd, Zodd_even_bool. now destruct Z.even. Qed. Lemma Zeven_rem : forall a, Z.even a = Z.eqb (Z.rem a 2) 0. Proof. intros a. rewrite Zrem_even. destruct a as [ |p|p]; trivial; now destruct p. Qed. Lemma Zodd_rem : forall a, Z.odd a = negb (Z.eqb (Z.rem a 2) 0). Proof. intros a. rewrite Zrem_odd. destruct a as [ |p|p]; trivial; now destruct p. Qed. (** * Interaction with "historic" Zdiv *) (** They agree at least on positive numbers: *) Theorem Zquotrem_Zdiv_eucl_pos : forall a b:Z, 0 <= a -> 0 < b -> a÷b = a/b /\ Z.rem a b = a mod b. Proof. intros. apply Zdiv_mod_unique with b. apply Zrem_lt_pos; auto with zarith. rewrite Z.abs_eq; auto with *; apply Z_mod_lt; auto with *. rewrite <- Z_div_mod_eq; auto with *. symmetry; apply Z.quot_rem; auto with *. Qed. Theorem Zquot_Zdiv_pos : forall a b, 0 <= a -> 0 <= b -> a÷b = a/b. Proof. intros a b Ha Hb. Z.le_elim Hb. - generalize (Zquotrem_Zdiv_eucl_pos a b Ha Hb); intuition. - subst; now rewrite Zquot_0_r, Zdiv_0_r. Qed. Theorem Zrem_Zmod_pos : forall a b, 0 <= a -> 0 < b -> Z.rem a b = a mod b. Proof. intros a b Ha Hb; generalize (Zquotrem_Zdiv_eucl_pos a b Ha Hb); intuition. Qed. (** Modulos are null at the same places *) Theorem Zrem_Zmod_zero : forall a b, b<>0 -> (Z.rem a b = 0 <-> a mod b = 0). Proof. intros. rewrite Zrem_divides, Zmod_divides; intuition. Qed. coq-8.4pl4/theories/ZArith/Zbool.v0000644000175000017500000001141412326224777016133 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | _ => false end. Definition Zneq_bool (x y:Z) := match x ?= y with | Eq => false | _ => true end. (** Properties in term of [if ... then ... else ...] *) Lemma Zle_cases n m : if n <=? m then n <= m else n > m. Proof. case Z.leb_spec; now Z.swap_greater. Qed. Lemma Zlt_cases n m : if n = m. Proof. case Z.ltb_spec; now Z.swap_greater. Qed. Lemma Zge_cases n m : if n >=? m then n >= m else n < m. Proof. rewrite Z.geb_leb. case Z.leb_spec; now Z.swap_greater. Qed. Lemma Zgt_cases n m : if n >? m then n > m else n <= m. Proof. rewrite Z.gtb_ltb. case Z.ltb_spec; now Z.swap_greater. Qed. (** Lemmas on [Z.leb] used in contrib/graphs *) Lemma Zle_bool_imp_le n m : (n <=? m) = true -> (n <= m). Proof. apply Z.leb_le. Qed. Lemma Zle_imp_le_bool n m : (n <= m) -> (n <=? m) = true. Proof. apply Z.leb_le. Qed. Notation Zle_bool_refl := Z.leb_refl (compat "8.3"). Lemma Zle_bool_antisym n m : (n <=? m) = true -> (m <=? n) = true -> n = m. Proof. rewrite !Z.leb_le. apply Z.le_antisymm. Qed. Lemma Zle_bool_trans n m p : (n <=? m) = true -> (m <=? p) = true -> (n <=? p) = true. Proof. rewrite !Z.leb_le. apply Z.le_trans. Qed. Definition Zle_bool_total x y : { x <=? y = true } + { y <=? x = true }. Proof. case_eq (x <=? y); intros H. - left; trivial. - right. apply Z.leb_gt in H. now apply Z.leb_le, Z.lt_le_incl. Defined. Lemma Zle_bool_plus_mono n m p q : (n <=? m) = true -> (p <=? q) = true -> (n + p <=? m + q) = true. Proof. rewrite !Z.leb_le. apply Z.add_le_mono. Qed. Lemma Zone_pos : 1 <=? 0 = false. Proof. reflexivity. Qed. Lemma Zone_min_pos n : (n <=? 0) = false -> (1 <=? n) = true. Proof. rewrite Z.leb_le, Z.leb_gt. apply Z.le_succ_l. Qed. (** Properties in term of [iff] *) Lemma Zle_is_le_bool n m : (n <= m) <-> (n <=? m) = true. Proof. symmetry. apply Z.leb_le. Qed. Lemma Zge_is_le_bool n m : (n >= m) <-> (m <=? n) = true. Proof. Z.swap_greater. symmetry. apply Z.leb_le. Qed. Lemma Zlt_is_lt_bool n m : (n < m) <-> (n m) <-> (n >? m) = true. Proof. Z.swap_greater. rewrite Z.gtb_ltb. symmetry. apply Z.ltb_lt. Qed. Lemma Zlt_is_le_bool n m : (n < m) <-> (n <=? m - 1) = true. Proof. rewrite Z.leb_le. apply Z.lt_le_pred. Qed. Lemma Zgt_is_le_bool n m : (n > m) <-> (m <=? n - 1) = true. Proof. Z.swap_greater. rewrite Z.leb_le. apply Z.lt_le_pred. Qed. (** Properties of the deprecated [Zeq_bool] *) Lemma Zeq_is_eq_bool x y : x = y <-> Zeq_bool x y = true. Proof. unfold Zeq_bool. rewrite <- Z.compare_eq_iff. destruct Z.compare; now split. Qed. Lemma Zeq_bool_eq x y : Zeq_bool x y = true -> x = y. Proof. apply Zeq_is_eq_bool. Qed. Lemma Zeq_bool_neq x y : Zeq_bool x y = false -> x <> y. Proof. rewrite Zeq_is_eq_bool; now destruct Zeq_bool. Qed. Lemma Zeq_bool_if x y : if Zeq_bool x y then x=y else x<>y. Proof. generalize (Zeq_bool_eq x y) (Zeq_bool_neq x y). destruct Zeq_bool; auto. Qed. coq-8.4pl4/theories/ZArith/auxiliary.v0000644000175000017500000000453512326224777017063 0ustar stephsteph(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Zne (n + - m) 0. Proof. unfold Zne. now rewrite <- Z.sub_move_0_r. Qed. Theorem Zegal_left n m : n = m -> n + - m = 0. Proof. apply Z.sub_move_0_r. Qed. Theorem Zle_left n m : n <= m -> 0 <= m + - n. Proof. apply Z.le_0_sub. Qed. Theorem Zle_left_rev n m : 0 <= m + - n -> n <= m. Proof. apply Z.le_0_sub. Qed. Theorem Zlt_left_rev n m : 0 < m + - n -> n < m. Proof. apply Z.lt_0_sub. Qed. Theorem Zlt_left_lt n m : n < m -> 0 < m + - n. Proof. apply Z.lt_0_sub. Qed. Theorem Zlt_left n m : n < m -> 0 <= m + -1 + - n. Proof. intros. rewrite Z.add_shuffle0. change (-1) with (- Z.succ 0). now apply Z.le_0_sub, Z.le_succ_l, Z.lt_0_sub. Qed. Theorem Zge_left n m : n >= m -> 0 <= n + - m. Proof. Z.swap_greater. apply Z.le_0_sub. Qed. Theorem Zgt_left n m : n > m -> 0 <= n + -1 + - m. Proof. Z.swap_greater. apply Zlt_left. Qed. Theorem Zgt_left_gt n m : n > m -> n + - m > 0. Proof. Z.swap_greater. apply Z.lt_0_sub. Qed. Theorem Zgt_left_rev n m : n + - m > 0 -> n > m. Proof. Z.swap_greater. apply Z.lt_0_sub. Qed. Theorem Zle_mult_approx n m p : n > 0 -> p > 0 -> 0 <= m -> 0 <= m * n + p. Proof. Z.swap_greater. intros. Z.order_pos. Qed. Theorem Zmult_le_approx n m p : n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m. Proof. Z.swap_greater. intros. apply Z.lt_succ_r. apply Z.mul_pos_cancel_r with n; trivial. Z.nzsimpl. apply Z.le_lt_trans with (m*n+p); trivial. now apply Z.add_lt_mono_l. Qed. coq-8.4pl4/theories/ZArith/Zpower.v0000644000175000017500000002252312326224777016337 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* nat->nat] and [Z.mul : Z->Z->Z] *) Lemma Zpower_nat_is_exp : forall (n m:nat) (z:Z), Zpower_nat z (n + m) = Zpower_nat z n * Zpower_nat z m. Proof. induction n. - intros. now rewrite Zpower_nat_0_r, Z.mul_1_l. - intros. simpl. now rewrite 2 Zpower_nat_succ_r, IHn, Z.mul_assoc. Qed. (** Conversions between powers of unary and binary integers *) Lemma Zpower_pos_nat (z : Z) (p : positive) : Z.pow_pos z p = Zpower_nat z (Pos.to_nat p). Proof. apply Pos2Nat.inj_iter. Qed. Lemma Zpower_nat_Z (z : Z) (n : nat) : Zpower_nat z n = z ^ (Z.of_nat n). Proof. induction n. trivial. rewrite Zpower_nat_succ_r, Nat2Z.inj_succ, Z.pow_succ_r. now f_equal. apply Nat2Z.is_nonneg. Qed. Theorem Zpower_nat_Zpower z n : 0 <= n -> z^n = Zpower_nat z (Z.abs_nat n). Proof. intros. now rewrite Zpower_nat_Z, Zabs2Nat.id_abs, Z.abs_eq. Qed. (** The function [(Z.pow_pos z)] is a morphism for [Pos.add : positive->positive->positive] and [Z.mul : Z->Z->Z] *) Lemma Zpower_pos_is_exp (n m : positive)(z:Z) : Z.pow_pos z (n + m) = Z.pow_pos z n * Z.pow_pos z m. Proof. now apply (Z.pow_add_r z (Zpos n) (Zpos m)). Qed. Hint Immediate Zpower_nat_is_exp Zpower_pos_is_exp : zarith. Hint Unfold Z.pow_pos Zpower_nat: zarith. Theorem Zpower_exp x n m : n >= 0 -> m >= 0 -> x ^ (n + m) = x ^ n * x ^ m. Proof. Z.swap_greater. apply Z.pow_add_r. Qed. Section Powers_of_2. (** * Powers of 2 *) (** For the powers of two, that will be widely used, a more direct calculus is possible. [shift n m] computes [2^n * m], i.e. [m] shifted by [n] positions *) Definition shift_nat (n:nat) (z:positive) := nat_iter n xO z. Definition shift_pos (n z:positive) := Pos.iter n xO z. Definition shift (n:Z) (z:positive) := match n with | Z0 => z | Zpos p => Pos.iter p xO z | Zneg p => z end. Definition two_power_nat (n:nat) := Zpos (shift_nat n 1). Definition two_power_pos (x:positive) := Zpos (shift_pos x 1). Definition two_p (x:Z) := match x with | Z0 => 1 | Zpos y => two_power_pos y | Zneg y => 0 end. (** Equivalence with notions defined in BinInt *) Lemma shift_nat_equiv n p : shift_nat n p = Pos.shiftl_nat p n. Proof. reflexivity. Qed. Lemma shift_pos_equiv n p : shift_pos n p = Pos.shiftl p (Npos n). Proof. reflexivity. Qed. Lemma shift_equiv n p : 0<=n -> Zpos (shift n p) = Z.shiftl (Zpos p) n. Proof. destruct n. - trivial. - simpl; intros. now apply Pos.iter_swap_gen. - now destruct 1. Qed. Lemma two_power_nat_equiv n : two_power_nat n = 2 ^ (Z.of_nat n). Proof. induction n. - trivial. - now rewrite Nat2Z.inj_succ, Z.pow_succ_r, <- IHn by apply Nat2Z.is_nonneg. Qed. Lemma two_power_pos_equiv p : two_power_pos p = 2 ^ Zpos p. Proof. now apply Pos.iter_swap_gen. Qed. Lemma two_p_equiv x : two_p x = 2 ^ x. Proof. destruct x; trivial. apply two_power_pos_equiv. Qed. (** Properties of these old versions of powers of two *) Lemma two_power_nat_S n : two_power_nat (S n) = 2 * two_power_nat n. Proof. reflexivity. Qed. Lemma shift_nat_plus n m x : shift_nat (n + m) x = shift_nat n (shift_nat m x). Proof. apply iter_nat_plus. Qed. Theorem shift_nat_correct n x : Zpos (shift_nat n x) = Zpower_nat 2 n * Zpos x. Proof. induction n. - trivial. - now rewrite Zpower_nat_succ_r, <- Z.mul_assoc, <- IHn. Qed. Theorem two_power_nat_correct n : two_power_nat n = Zpower_nat 2 n. Proof. now rewrite two_power_nat_equiv, Zpower_nat_Z. Qed. Lemma shift_pos_nat p x : shift_pos p x = shift_nat (Pos.to_nat p) x. Proof. apply Pos2Nat.inj_iter. Qed. Lemma two_power_pos_nat p : two_power_pos p = two_power_nat (Pos.to_nat p). Proof. unfold two_power_pos. now rewrite shift_pos_nat. Qed. Theorem shift_pos_correct p x : Zpos (shift_pos p x) = Z.pow_pos 2 p * Zpos x. Proof. now rewrite shift_pos_nat, Zpower_pos_nat, shift_nat_correct. Qed. Theorem two_power_pos_correct x : two_power_pos x = Z.pow_pos 2 x. Proof. apply two_power_pos_equiv. Qed. Theorem two_power_pos_is_exp x y : two_power_pos (x + y) = two_power_pos x * two_power_pos y. Proof. rewrite 3 two_power_pos_equiv. now apply (Z.pow_add_r 2 (Zpos x) (Zpos y)). Qed. Lemma two_p_correct x : two_p x = 2^x. Proof (two_p_equiv x). Theorem two_p_is_exp x y : 0 <= x -> 0 <= y -> two_p (x + y) = two_p x * two_p y. Proof. rewrite !two_p_equiv. apply Z.pow_add_r. Qed. Lemma two_p_gt_ZERO x : 0 <= x -> two_p x > 0. Proof. Z.swap_greater. rewrite two_p_equiv. now apply Z.pow_pos_nonneg. Qed. Lemma two_p_S x : 0 <= x -> two_p (Z.succ x) = 2 * two_p x. Proof. rewrite !two_p_equiv. now apply Z.pow_succ_r. Qed. Lemma two_p_pred x : 0 <= x -> two_p (Z.pred x) < two_p x. Proof. rewrite !two_p_equiv. intros. apply Z.pow_lt_mono_r; auto with zarith. Qed. End Powers_of_2. Hint Resolve two_p_gt_ZERO: zarith. Hint Immediate two_p_pred two_p_S: zarith. Section power_div_with_rest. (** * Division by a power of two. *) (** To [x:Z] and [p:positive], [q],[r] are associated such that [x = 2^p.q + r] and [0 <= r < 2^p] *) (** Invariant: [d*q + r = d'*q + r /\ d' = 2*d /\ 0<=r (0, r) | Zpos xH => (0, d + r) | Zpos (xI n) => (Zpos n, d + r) | Zpos (xO n) => (Zpos n, r) | Zneg xH => (-1, d + r) | Zneg (xI n) => (Zneg n - 1, d + r) | Zneg (xO n) => (Zneg n, r) end, 2 * d). Definition Zdiv_rest (x:Z) (p:positive) := let (qr, d) := Pos.iter p Zdiv_rest_aux (x, 0, 1) in qr. Lemma Zdiv_rest_correct1 (x:Z) (p:positive) : let (_, d) := Pos.iter p Zdiv_rest_aux (x, 0, 1) in d = two_power_pos p. Proof. rewrite Pos2Nat.inj_iter, two_power_pos_nat. induction (Pos.to_nat p); simpl; trivial. destruct (nat_iter n Zdiv_rest_aux (x,0,1)) as ((q,r),d). unfold Zdiv_rest_aux. rewrite two_power_nat_S; now f_equal. Qed. Lemma Zdiv_rest_correct2 (x:Z) (p:positive) : let '(q,r,d) := Pos.iter p Zdiv_rest_aux (x, 0, 1) in x = q * d + r /\ 0 <= r < d. Proof. apply Pos.iter_invariant; [|omega]. intros ((q,r),d) (H,H'). unfold Zdiv_rest_aux. destruct q as [ |[q|q| ]|[q|q| ]]; try omega. - rewrite Pos2Z.inj_xI, Z.mul_add_distr_r in H. rewrite Z.mul_shuffle3, Z.mul_assoc. omega. - rewrite Pos2Z.inj_xO in H. rewrite Z.mul_shuffle3, Z.mul_assoc. omega. - rewrite Pos2Z.neg_xI, Z.mul_sub_distr_r in H. rewrite Z.mul_sub_distr_r, Z.mul_shuffle3, Z.mul_assoc. omega. - rewrite Pos2Z.neg_xO in H. rewrite Z.mul_shuffle3, Z.mul_assoc. omega. Qed. (** Old-style rich specification by proof of existence *) Inductive Zdiv_rest_proofs (x:Z) (p:positive) : Set := Zdiv_rest_proof : forall q r:Z, x = q * two_power_pos p + r -> 0 <= r -> r < two_power_pos p -> Zdiv_rest_proofs x p. Lemma Zdiv_rest_correct (x:Z) (p:positive) : Zdiv_rest_proofs x p. Proof. generalize (Zdiv_rest_correct1 x p); generalize (Zdiv_rest_correct2 x p). destruct (Pos.iter p Zdiv_rest_aux (x, 0, 1)) as ((q,r),d). intros (H1,(H2,H3)) ->. now exists q r. Qed. (** Direct correctness of [Zdiv_rest] *) Lemma Zdiv_rest_ok x p : let (q,r) := Zdiv_rest x p in x = q * 2^(Zpos p) + r /\ 0 <= r < 2^(Zpos p). Proof. unfold Zdiv_rest. generalize (Zdiv_rest_correct1 x p); generalize (Zdiv_rest_correct2 x p). destruct (Pos.iter p Zdiv_rest_aux (x, 0, 1)) as ((q,r),d). intros H ->. now rewrite two_power_pos_equiv in H. Qed. (** Equivalence with [Z.shiftr] *) Lemma Zdiv_rest_shiftr x p : fst (Zdiv_rest x p) = Z.shiftr x (Zpos p). Proof. generalize (Zdiv_rest_ok x p). destruct (Zdiv_rest x p) as (q,r). intros (H,H'). simpl. rewrite Z.shiftr_div_pow2 by easy. apply Z.div_unique_pos with r; trivial. now rewrite Z.mul_comm. Qed. End power_div_with_rest. coq-8.4pl4/theories/ZArith/Znat.v0000644000175000017500000006567012326224777015777 0ustar stephsteph(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Nat ---- | ^ | | | v Pos ---------> Z | | ^ | v | ----> N ----- >> *) Lemma nat_N_Z n : Z.of_N (N.of_nat n) = Z.of_nat n. Proof. now destruct n. Qed. Lemma N_nat_Z n : Z.of_nat (N.to_nat n) = Z.of_N n. Proof. destruct n; trivial. simpl. destruct (Pos2Nat.is_succ p) as (m,H). rewrite H. simpl. f_equal. now apply SuccNat2Pos.inv. Qed. Lemma positive_nat_Z p : Z.of_nat (Pos.to_nat p) = Zpos p. Proof. destruct (Pos2Nat.is_succ p) as (n,H). rewrite H. simpl. f_equal. now apply SuccNat2Pos.inv. Qed. Lemma positive_N_Z p : Z.of_N (Npos p) = Zpos p. Proof. reflexivity. Qed. Lemma positive_N_nat p : N.to_nat (Npos p) = Pos.to_nat p. Proof. reflexivity. Qed. Lemma positive_nat_N p : N.of_nat (Pos.to_nat p) = Npos p. Proof. destruct (Pos2Nat.is_succ p) as (n,H). rewrite H. simpl. f_equal. now apply SuccNat2Pos.inv. Qed. Lemma Z_N_nat n : N.to_nat (Z.to_N n) = Z.to_nat n. Proof. now destruct n. Qed. Lemma Z_nat_N n : N.of_nat (Z.to_nat n) = Z.to_N n. Proof. destruct n; simpl; trivial. apply positive_nat_N. Qed. Lemma Zabs_N_nat n : N.to_nat (Z.abs_N n) = Z.abs_nat n. Proof. now destruct n. Qed. Lemma Zabs_nat_N n : N.of_nat (Z.abs_nat n) = Z.abs_N n. Proof. destruct n; simpl; trivial; apply positive_nat_N. Qed. (** * Conversions between [Z] and [N] *) Module N2Z. (** [Z.of_N] is a bijection between [N] and non-negative [Z], with [Z.to_N] (or [Z.abs_N]) as reciprocal. See [Z2N.id] below for the dual equation. *) Lemma id n : Z.to_N (Z.of_N n) = n. Proof. now destruct n. Qed. (** [Z.of_N] is hence injective *) Lemma inj n m : Z.of_N n = Z.of_N m -> n = m. Proof. destruct n, m; simpl; congruence. Qed. Lemma inj_iff n m : Z.of_N n = Z.of_N m <-> n = m. Proof. split. apply inj. intros; now f_equal. Qed. (** [Z.of_N] produce non-negative integers *) Lemma is_nonneg n : 0 <= Z.of_N n. Proof. now destruct n. Qed. (** [Z.of_N], basic equations *) Lemma inj_0 : Z.of_N 0 = 0. Proof. reflexivity. Qed. Lemma inj_pos p : Z.of_N (Npos p) = Zpos p. Proof. reflexivity. Qed. (** [Z.of_N] and usual operations. *) Lemma inj_compare n m : (Z.of_N n ?= Z.of_N m) = (n ?= m)%N. Proof. now destruct n, m. Qed. Lemma inj_le n m : (n<=m)%N <-> Z.of_N n <= Z.of_N m. Proof. unfold Z.le. now rewrite inj_compare. Qed. Lemma inj_lt n m : (n Z.of_N n < Z.of_N m. Proof. unfold Z.lt. now rewrite inj_compare. Qed. Lemma inj_ge n m : (n>=m)%N <-> Z.of_N n >= Z.of_N m. Proof. unfold Z.ge. now rewrite inj_compare. Qed. Lemma inj_gt n m : (n>m)%N <-> Z.of_N n > Z.of_N m. Proof. unfold Z.gt. now rewrite inj_compare. Qed. Lemma inj_abs_N z : Z.of_N (Z.abs_N z) = Z.abs z. Proof. now destruct z. Qed. Lemma inj_add n m : Z.of_N (n+m) = Z.of_N n + Z.of_N m. Proof. now destruct n, m. Qed. Lemma inj_mul n m : Z.of_N (n*m) = Z.of_N n * Z.of_N m. Proof. now destruct n, m. Qed. Lemma inj_sub_max n m : Z.of_N (n-m) = Z.max 0 (Z.of_N n - Z.of_N m). Proof. destruct n as [|n], m as [|m]; simpl; trivial. rewrite Z.pos_sub_spec, Pos.compare_sub_mask. unfold Pos.sub. now destruct (Pos.sub_mask n m). Qed. Lemma inj_sub n m : (m<=n)%N -> Z.of_N (n-m) = Z.of_N n - Z.of_N m. Proof. intros H. rewrite inj_sub_max. unfold N.le in H. rewrite N.compare_antisym, <- inj_compare, Z.compare_sub in H. destruct (Z.of_N n - Z.of_N m); trivial; now destruct H. Qed. Lemma inj_succ n : Z.of_N (N.succ n) = Z.succ (Z.of_N n). Proof. destruct n. trivial. simpl. now rewrite Pos.add_1_r. Qed. Lemma inj_pred_max n : Z.of_N (N.pred n) = Z.max 0 (Z.pred (Z.of_N n)). Proof. unfold Z.pred. now rewrite N.pred_sub, inj_sub_max. Qed. Lemma inj_pred n : (0 Z.of_N (N.pred n) = Z.pred (Z.of_N n). Proof. intros H. unfold Z.pred. rewrite N.pred_sub, inj_sub; trivial. now apply N.le_succ_l in H. Qed. Lemma inj_min n m : Z.of_N (N.min n m) = Z.min (Z.of_N n) (Z.of_N m). Proof. unfold Z.min, N.min. rewrite inj_compare. now case N.compare. Qed. Lemma inj_max n m : Z.of_N (N.max n m) = Z.max (Z.of_N n) (Z.of_N m). Proof. unfold Z.max, N.max. rewrite inj_compare. case N.compare_spec; intros; subst; trivial. Qed. Lemma inj_div n m : Z.of_N (n/m) = Z.of_N n / Z.of_N m. Proof. destruct m as [|m]. now destruct n. apply Z.div_unique_pos with (Z.of_N (n mod (Npos m))). split. apply is_nonneg. apply inj_lt. now apply N.mod_lt. rewrite <- inj_mul, <- inj_add. f_equal. now apply N.div_mod. Qed. Lemma inj_mod n m : (m<>0)%N -> Z.of_N (n mod m) = (Z.of_N n) mod (Z.of_N m). Proof. intros Hm. apply Z.mod_unique_pos with (Z.of_N (n / m)). split. apply is_nonneg. apply inj_lt. now apply N.mod_lt. rewrite <- inj_mul, <- inj_add. f_equal. now apply N.div_mod. Qed. Lemma inj_quot n m : Z.of_N (n/m) = Z.of_N n ÷ Z.of_N m. Proof. destruct m. - now destruct n. - rewrite Z.quot_div_nonneg, inj_div; trivial. apply is_nonneg. easy. Qed. Lemma inj_rem n m : Z.of_N (n mod m) = Z.rem (Z.of_N n) (Z.of_N m). Proof. destruct m. - now destruct n. - rewrite Z.rem_mod_nonneg, inj_mod; trivial. easy. apply is_nonneg. easy. Qed. Lemma inj_div2 n : Z.of_N (N.div2 n) = Z.div2 (Z.of_N n). Proof. destruct n as [|p]; trivial. now destruct p. Qed. Lemma inj_quot2 n : Z.of_N (N.div2 n) = Z.quot2 (Z.of_N n). Proof. destruct n as [|p]; trivial. now destruct p. Qed. Lemma inj_pow n m : Z.of_N (n^m) = (Z.of_N n)^(Z.of_N m). Proof. destruct n, m; trivial. now rewrite Z.pow_0_l. apply Pos2Z.inj_pow. Qed. Lemma inj_testbit a n : Z.testbit (Z.of_N a) (Z.of_N n) = N.testbit a n. Proof. apply Z.Private_BootStrap.testbit_of_N. Qed. End N2Z. Module Z2N. (** [Z.to_N] is a bijection between non-negative [Z] and [N], with [Pos.of_N] as reciprocal. See [N2Z.id] above for the dual equation. *) Lemma id n : 0<=n -> Z.of_N (Z.to_N n) = n. Proof. destruct n; (now destruct 1) || trivial. Qed. (** [Z.to_N] is hence injective for non-negative integers. *) Lemma inj n m : 0<=n -> 0<=m -> Z.to_N n = Z.to_N m -> n = m. Proof. intros. rewrite <- (id n), <- (id m) by trivial. now f_equal. Qed. Lemma inj_iff n m : 0<=n -> 0<=m -> (Z.to_N n = Z.to_N m <-> n = m). Proof. intros. split. now apply inj. intros; now subst. Qed. (** [Z.to_N], basic equations *) Lemma inj_0 : Z.to_N 0 = 0%N. Proof. reflexivity. Qed. Lemma inj_pos n : Z.to_N (Zpos n) = Npos n. Proof. reflexivity. Qed. Lemma inj_neg n : Z.to_N (Zneg n) = 0%N. Proof. reflexivity. Qed. (** [Z.to_N] and operations *) Lemma inj_add n m : 0<=n -> 0<=m -> Z.to_N (n+m) = (Z.to_N n + Z.to_N m)%N. Proof. destruct n, m; trivial; (now destruct 1) || (now destruct 2). Qed. Lemma inj_mul n m : 0<=n -> 0<=m -> Z.to_N (n*m) = (Z.to_N n * Z.to_N m)%N. Proof. destruct n, m; trivial; (now destruct 1) || (now destruct 2). Qed. Lemma inj_succ n : 0<=n -> Z.to_N (Z.succ n) = N.succ (Z.to_N n). Proof. unfold Z.succ. intros. rewrite inj_add by easy. apply N.add_1_r. Qed. Lemma inj_sub n m : 0<=m -> Z.to_N (n - m) = (Z.to_N n - Z.to_N m)%N. Proof. destruct n as [|n|n], m as [|m|m]; trivial; try (now destruct 1). intros _. simpl. rewrite Z.pos_sub_spec, Pos.compare_sub_mask. unfold Pos.sub. now destruct (Pos.sub_mask n m). Qed. Lemma inj_pred n : Z.to_N (Z.pred n) = N.pred (Z.to_N n). Proof. unfold Z.pred. rewrite <- N.sub_1_r. now apply (inj_sub n 1). Qed. Lemma inj_compare n m : 0<=n -> 0<=m -> (Z.to_N n ?= Z.to_N m)%N = (n ?= m). Proof. intros Hn Hm. now rewrite <- N2Z.inj_compare, !id. Qed. Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.to_N n <= Z.to_N m)%N). Proof. intros Hn Hm. unfold Z.le, N.le. now rewrite inj_compare. Qed. Lemma inj_lt n m : 0<=n -> 0<=m -> (n (Z.to_N n < Z.to_N m)%N). Proof. intros Hn Hm. unfold Z.lt, N.lt. now rewrite inj_compare. Qed. Lemma inj_min n m : Z.to_N (Z.min n m) = N.min (Z.to_N n) (Z.to_N m). Proof. destruct n, m; simpl; trivial; unfold Z.min, N.min; simpl; now case Pos.compare. Qed. Lemma inj_max n m : Z.to_N (Z.max n m) = N.max (Z.to_N n) (Z.to_N m). Proof. destruct n, m; simpl; trivial; unfold Z.max, N.max; simpl. case Pos.compare_spec; intros; subst; trivial. now case Pos.compare. Qed. Lemma inj_div n m : 0<=n -> 0<=m -> Z.to_N (n/m) = (Z.to_N n / Z.to_N m)%N. Proof. destruct n, m; trivial; intros Hn Hm; (now destruct Hn) || (now destruct Hm) || clear. simpl. rewrite <- (N2Z.id (_ / _)). f_equal. now rewrite N2Z.inj_div. Qed. Lemma inj_mod n m : 0<=n -> 0 Z.to_N (n mod m) = ((Z.to_N n) mod (Z.to_N m))%N. Proof. destruct n, m; trivial; intros Hn Hm; (now destruct Hn) || (now destruct Hm) || clear. simpl. rewrite <- (N2Z.id (_ mod _)). f_equal. now rewrite N2Z.inj_mod. Qed. Lemma inj_quot n m : 0<=n -> 0<=m -> Z.to_N (n÷m) = (Z.to_N n / Z.to_N m)%N. Proof. destruct m. - now destruct n. - intros. now rewrite Z.quot_div_nonneg, inj_div. - now destruct 2. Qed. Lemma inj_rem n m :0<=n -> 0<=m -> Z.to_N (Z.rem n m) = ((Z.to_N n) mod (Z.to_N m))%N. Proof. destruct m. - now destruct n. - intros. now rewrite Z.rem_mod_nonneg, inj_mod. - now destruct 2. Qed. Lemma inj_div2 n : Z.to_N (Z.div2 n) = N.div2 (Z.to_N n). Proof. destruct n as [|p|p]; trivial. now destruct p. Qed. Lemma inj_quot2 n : Z.to_N (Z.quot2 n) = N.div2 (Z.to_N n). Proof. destruct n as [|p|p]; trivial; now destruct p. Qed. Lemma inj_pow n m : 0<=n -> 0<=m -> Z.to_N (n^m) = ((Z.to_N n)^(Z.to_N m))%N. Proof. destruct m. - trivial. - intros. now rewrite <- (N2Z.id (_ ^ _)), N2Z.inj_pow, id. - now destruct 2. Qed. Lemma inj_testbit a n : 0<=n -> Z.testbit (Z.of_N a) n = N.testbit a (Z.to_N n). Proof. apply Z.Private_BootStrap.testbit_of_N'. Qed. End Z2N. Module Zabs2N. (** Results about [Z.abs_N], converting absolute values of [Z] integers to [N]. *) Lemma abs_N_spec n : Z.abs_N n = Z.to_N (Z.abs n). Proof. now destruct n. Qed. Lemma abs_N_nonneg n : 0<=n -> Z.abs_N n = Z.to_N n. Proof. destruct n; trivial; now destruct 1. Qed. Lemma id_abs n : Z.of_N (Z.abs_N n) = Z.abs n. Proof. now destruct n. Qed. Lemma id n : Z.abs_N (Z.of_N n) = n. Proof. now destruct n. Qed. (** [Z.abs_N], basic equations *) Lemma inj_0 : Z.abs_N 0 = 0%N. Proof. reflexivity. Qed. Lemma inj_pos p : Z.abs_N (Zpos p) = Npos p. Proof. reflexivity. Qed. Lemma inj_neg p : Z.abs_N (Zneg p) = Npos p. Proof. reflexivity. Qed. (** [Z.abs_N] and usual operations, with non-negative integers *) Lemma inj_opp n : Z.abs_N (-n) = Z.abs_N n. Proof. now destruct n. Qed. Lemma inj_succ n : 0<=n -> Z.abs_N (Z.succ n) = N.succ (Z.abs_N n). Proof. intros. rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_succ. now apply Z.le_le_succ_r. Qed. Lemma inj_add n m : 0<=n -> 0<=m -> Z.abs_N (n+m) = (Z.abs_N n + Z.abs_N m)%N. Proof. intros. rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_add. now apply Z.add_nonneg_nonneg. Qed. Lemma inj_mul n m : Z.abs_N (n*m) = (Z.abs_N n * Z.abs_N m)%N. Proof. now destruct n, m. Qed. Lemma inj_sub n m : 0<=m<=n -> Z.abs_N (n-m) = (Z.abs_N n - Z.abs_N m)%N. Proof. intros (Hn,H). rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_sub. Z.order. now apply Z.le_0_sub. Qed. Lemma inj_pred n : 0 Z.abs_N (Z.pred n) = N.pred (Z.abs_N n). Proof. intros. rewrite !abs_N_nonneg. now apply Z2N.inj_pred. Z.order. apply Z.lt_succ_r. now rewrite Z.succ_pred. Qed. Lemma inj_compare n m : 0<=n -> 0<=m -> (Z.abs_N n ?= Z.abs_N m)%N = (n ?= m). Proof. intros. rewrite !abs_N_nonneg by trivial. now apply Z2N.inj_compare. Qed. Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.abs_N n <= Z.abs_N m)%N). Proof. intros Hn Hm. unfold Z.le, N.le. now rewrite inj_compare. Qed. Lemma inj_lt n m : 0<=n -> 0<=m -> (n (Z.abs_N n < Z.abs_N m)%N). Proof. intros Hn Hm. unfold Z.lt, N.lt. now rewrite inj_compare. Qed. Lemma inj_min n m : 0<=n -> 0<=m -> Z.abs_N (Z.min n m) = N.min (Z.abs_N n) (Z.abs_N m). Proof. intros. rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_min. now apply Z.min_glb. Qed. Lemma inj_max n m : 0<=n -> 0<=m -> Z.abs_N (Z.max n m) = N.max (Z.abs_N n) (Z.abs_N m). Proof. intros. rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_max. transitivity n; trivial. apply Z.le_max_l. Qed. Lemma inj_quot n m : Z.abs_N (n÷m) = ((Z.abs_N n) / (Z.abs_N m))%N. Proof. assert (forall p q, Z.abs_N (Zpos p ÷ Zpos q) = (Npos p / Npos q)%N). intros. rewrite abs_N_nonneg. now apply Z2N.inj_quot. now apply Z.quot_pos. destruct n, m; trivial; simpl. - trivial. - now rewrite <- Pos2Z.opp_pos, Z.quot_opp_r, inj_opp. - now rewrite <- Pos2Z.opp_pos, Z.quot_opp_l, inj_opp. - now rewrite <- 2 Pos2Z.opp_pos, Z.quot_opp_opp. Qed. Lemma inj_rem n m : Z.abs_N (Z.rem n m) = ((Z.abs_N n) mod (Z.abs_N m))%N. Proof. assert (forall p q, Z.abs_N (Z.rem (Zpos p) (Zpos q)) = ((Npos p) mod (Npos q))%N). intros. rewrite abs_N_nonneg. now apply Z2N.inj_rem. now apply Z.rem_nonneg. destruct n, m; trivial; simpl. - trivial. - now rewrite <- Pos2Z.opp_pos, Z.rem_opp_r. - now rewrite <- Pos2Z.opp_pos, Z.rem_opp_l, inj_opp. - now rewrite <- 2 Pos2Z.opp_pos, Z.rem_opp_opp, inj_opp. Qed. Lemma inj_pow n m : 0<=m -> Z.abs_N (n^m) = ((Z.abs_N n)^(Z.abs_N m))%N. Proof. intros Hm. rewrite abs_N_spec, Z.abs_pow, Z2N.inj_pow, <- abs_N_spec; trivial. f_equal. symmetry; now apply abs_N_nonneg. apply Z.abs_nonneg. Qed. (** [Z.abs_N] and usual operations, statements with [Z.abs] *) Lemma inj_succ_abs n : Z.abs_N (Z.succ (Z.abs n)) = N.succ (Z.abs_N n). Proof. destruct n; simpl; trivial; now rewrite Pos.add_1_r. Qed. Lemma inj_add_abs n m : Z.abs_N (Z.abs n + Z.abs m) = (Z.abs_N n + Z.abs_N m)%N. Proof. now destruct n, m. Qed. Lemma inj_mul_abs n m : Z.abs_N (Z.abs n * Z.abs m) = (Z.abs_N n * Z.abs_N m)%N. Proof. now destruct n, m. Qed. End Zabs2N. (** * Conversions between [Z] and [nat] *) Module Nat2Z. (** [Z.of_nat], basic equations *) Lemma inj_0 : Z.of_nat 0 = 0. Proof. reflexivity. Qed. Lemma inj_succ n : Z.of_nat (S n) = Z.succ (Z.of_nat n). Proof. destruct n. trivial. simpl. apply Pos2Z.inj_succ. Qed. (** [Z.of_N] produce non-negative integers *) Lemma is_nonneg n : 0 <= Z.of_nat n. Proof. now induction n. Qed. (** [Z.of_nat] is a bijection between [nat] and non-negative [Z], with [Z.to_nat] (or [Z.abs_nat]) as reciprocal. See [Z2Nat.id] below for the dual equation. *) Lemma id n : Z.to_nat (Z.of_nat n) = n. Proof. now rewrite <- nat_N_Z, <- Z_N_nat, N2Z.id, Nat2N.id. Qed. (** [Z.of_nat] is hence injective *) Lemma inj n m : Z.of_nat n = Z.of_nat m -> n = m. Proof. intros H. now rewrite <- (id n), <- (id m), H. Qed. Lemma inj_iff n m : Z.of_nat n = Z.of_nat m <-> n = m. Proof. split. apply inj. intros; now f_equal. Qed. (** [Z.of_nat] and usual operations *) Lemma inj_compare n m : (Z.of_nat n ?= Z.of_nat m) = nat_compare n m. Proof. now rewrite <-!nat_N_Z, N2Z.inj_compare, <- Nat2N.inj_compare. Qed. Lemma inj_le n m : (n<=m)%nat <-> Z.of_nat n <= Z.of_nat m. Proof. unfold Z.le. now rewrite inj_compare, nat_compare_le. Qed. Lemma inj_lt n m : (n Z.of_nat n < Z.of_nat m. Proof. unfold Z.lt. now rewrite inj_compare, nat_compare_lt. Qed. Lemma inj_ge n m : (n>=m)%nat <-> Z.of_nat n >= Z.of_nat m. Proof. unfold Z.ge. now rewrite inj_compare, nat_compare_ge. Qed. Lemma inj_gt n m : (n>m)%nat <-> Z.of_nat n > Z.of_nat m. Proof. unfold Z.gt. now rewrite inj_compare, nat_compare_gt. Qed. Lemma inj_abs_nat z : Z.of_nat (Z.abs_nat z) = Z.abs z. Proof. destruct z; simpl; trivial; destruct (Pos2Nat.is_succ p) as (n,H); rewrite H; simpl; f_equal; now apply SuccNat2Pos.inv. Qed. Lemma inj_add n m : Z.of_nat (n+m) = Z.of_nat n + Z.of_nat m. Proof. now rewrite <- !nat_N_Z, Nat2N.inj_add, N2Z.inj_add. Qed. Lemma inj_mul n m : Z.of_nat (n*m) = Z.of_nat n * Z.of_nat m. Proof. now rewrite <- !nat_N_Z, Nat2N.inj_mul, N2Z.inj_mul. Qed. Lemma inj_sub_max n m : Z.of_nat (n-m) = Z.max 0 (Z.of_nat n - Z.of_nat m). Proof. now rewrite <- !nat_N_Z, Nat2N.inj_sub, N2Z.inj_sub_max. Qed. Lemma inj_sub n m : (m<=n)%nat -> Z.of_nat (n-m) = Z.of_nat n - Z.of_nat m. Proof. rewrite nat_compare_le, Nat2N.inj_compare. intros. now rewrite <- !nat_N_Z, Nat2N.inj_sub, N2Z.inj_sub. Qed. Lemma inj_pred_max n : Z.of_nat (pred n) = Z.max 0 (Z.pred (Z.of_nat n)). Proof. now rewrite <- !nat_N_Z, Nat2N.inj_pred, N2Z.inj_pred_max. Qed. Lemma inj_pred n : (0 Z.of_nat (pred n) = Z.pred (Z.of_nat n). Proof. rewrite nat_compare_lt, Nat2N.inj_compare. intros. now rewrite <- !nat_N_Z, Nat2N.inj_pred, N2Z.inj_pred. Qed. Lemma inj_min n m : Z.of_nat (min n m) = Z.min (Z.of_nat n) (Z.of_nat m). Proof. now rewrite <- !nat_N_Z, Nat2N.inj_min, N2Z.inj_min. Qed. Lemma inj_max n m : Z.of_nat (max n m) = Z.max (Z.of_nat n) (Z.of_nat m). Proof. now rewrite <- !nat_N_Z, Nat2N.inj_max, N2Z.inj_max. Qed. End Nat2Z. Module Z2Nat. (** [Z.to_nat] is a bijection between non-negative [Z] and [nat], with [Pos.of_nat] as reciprocal. See [nat2Z.id] above for the dual equation. *) Lemma id n : 0<=n -> Z.of_nat (Z.to_nat n) = n. Proof. intros. now rewrite <- Z_N_nat, <- nat_N_Z, N2Nat.id, Z2N.id. Qed. (** [Z.to_nat] is hence injective for non-negative integers. *) Lemma inj n m : 0<=n -> 0<=m -> Z.to_nat n = Z.to_nat m -> n = m. Proof. intros. rewrite <- (id n), <- (id m) by trivial. now f_equal. Qed. Lemma inj_iff n m : 0<=n -> 0<=m -> (Z.to_nat n = Z.to_nat m <-> n = m). Proof. intros. split. now apply inj. intros; now subst. Qed. (** [Z.to_nat], basic equations *) Lemma inj_0 : Z.to_nat 0 = O. Proof. reflexivity. Qed. Lemma inj_pos n : Z.to_nat (Zpos n) = Pos.to_nat n. Proof. reflexivity. Qed. Lemma inj_neg n : Z.to_nat (Zneg n) = O. Proof. reflexivity. Qed. (** [Z.to_nat] and operations *) Lemma inj_add n m : 0<=n -> 0<=m -> Z.to_nat (n+m) = (Z.to_nat n + Z.to_nat m)%nat. Proof. intros. now rewrite <- !Z_N_nat, Z2N.inj_add, N2Nat.inj_add. Qed. Lemma inj_mul n m : 0<=n -> 0<=m -> Z.to_nat (n*m) = (Z.to_nat n * Z.to_nat m)%nat. Proof. intros. now rewrite <- !Z_N_nat, Z2N.inj_mul, N2Nat.inj_mul. Qed. Lemma inj_succ n : 0<=n -> Z.to_nat (Z.succ n) = S (Z.to_nat n). Proof. intros. now rewrite <- !Z_N_nat, Z2N.inj_succ, N2Nat.inj_succ. Qed. Lemma inj_sub n m : 0<=m -> Z.to_nat (n - m) = (Z.to_nat n - Z.to_nat m)%nat. Proof. intros. now rewrite <- !Z_N_nat, Z2N.inj_sub, N2Nat.inj_sub. Qed. Lemma inj_pred n : Z.to_nat (Z.pred n) = pred (Z.to_nat n). Proof. now rewrite <- !Z_N_nat, Z2N.inj_pred, N2Nat.inj_pred. Qed. Lemma inj_compare n m : 0<=n -> 0<=m -> nat_compare (Z.to_nat n) (Z.to_nat m) = (n ?= m). Proof. intros Hn Hm. now rewrite <- Nat2Z.inj_compare, !id. Qed. Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.to_nat n <= Z.to_nat m)%nat). Proof. intros Hn Hm. unfold Z.le. now rewrite nat_compare_le, inj_compare. Qed. Lemma inj_lt n m : 0<=n -> 0<=m -> (n (Z.to_nat n < Z.to_nat m)%nat). Proof. intros Hn Hm. unfold Z.lt. now rewrite nat_compare_lt, inj_compare. Qed. Lemma inj_min n m : Z.to_nat (Z.min n m) = min (Z.to_nat n) (Z.to_nat m). Proof. now rewrite <- !Z_N_nat, Z2N.inj_min, N2Nat.inj_min. Qed. Lemma inj_max n m : Z.to_nat (Z.max n m) = max (Z.to_nat n) (Z.to_nat m). Proof. now rewrite <- !Z_N_nat, Z2N.inj_max, N2Nat.inj_max. Qed. End Z2Nat. Module Zabs2Nat. (** Results about [Z.abs_nat], converting absolute values of [Z] integers to [nat]. *) Lemma abs_nat_spec n : Z.abs_nat n = Z.to_nat (Z.abs n). Proof. now destruct n. Qed. Lemma abs_nat_nonneg n : 0<=n -> Z.abs_nat n = Z.to_nat n. Proof. destruct n; trivial; now destruct 1. Qed. Lemma id_abs n : Z.of_nat (Z.abs_nat n) = Z.abs n. Proof. rewrite <-Zabs_N_nat, N_nat_Z. apply Zabs2N.id_abs. Qed. Lemma id n : Z.abs_nat (Z.of_nat n) = n. Proof. now rewrite <-Zabs_N_nat, <-nat_N_Z, Zabs2N.id, Nat2N.id. Qed. (** [Z.abs_nat], basic equations *) Lemma inj_0 : Z.abs_nat 0 = 0%nat. Proof. reflexivity. Qed. Lemma inj_pos p : Z.abs_nat (Zpos p) = Pos.to_nat p. Proof. reflexivity. Qed. Lemma inj_neg p : Z.abs_nat (Zneg p) = Pos.to_nat p. Proof. reflexivity. Qed. (** [Z.abs_nat] and usual operations, with non-negative integers *) Lemma inj_succ n : 0<=n -> Z.abs_nat (Z.succ n) = S (Z.abs_nat n). Proof. intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_succ, N2Nat.inj_succ. Qed. Lemma inj_add n m : 0<=n -> 0<=m -> Z.abs_nat (n+m) = (Z.abs_nat n + Z.abs_nat m)%nat. Proof. intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_add, N2Nat.inj_add. Qed. Lemma inj_mul n m : Z.abs_nat (n*m) = (Z.abs_nat n * Z.abs_nat m)%nat. Proof. destruct n, m; simpl; trivial using Pos2Nat.inj_mul. Qed. Lemma inj_sub n m : 0<=m<=n -> Z.abs_nat (n-m) = (Z.abs_nat n - Z.abs_nat m)%nat. Proof. intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_sub, N2Nat.inj_sub. Qed. Lemma inj_pred n : 0 Z.abs_nat (Z.pred n) = pred (Z.abs_nat n). Proof. intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_pred, N2Nat.inj_pred. Qed. Lemma inj_compare n m : 0<=n -> 0<=m -> nat_compare (Z.abs_nat n) (Z.abs_nat m) = (n ?= m). Proof. intros. now rewrite <- !Zabs_N_nat, <- N2Nat.inj_compare, Zabs2N.inj_compare. Qed. Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.abs_nat n <= Z.abs_nat m)%nat). Proof. intros Hn Hm. unfold Z.le. now rewrite nat_compare_le, inj_compare. Qed. Lemma inj_lt n m : 0<=n -> 0<=m -> (n (Z.abs_nat n < Z.abs_nat m)%nat). Proof. intros Hn Hm. unfold Z.lt. now rewrite nat_compare_lt, inj_compare. Qed. Lemma inj_min n m : 0<=n -> 0<=m -> Z.abs_nat (Z.min n m) = min (Z.abs_nat n) (Z.abs_nat m). Proof. intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_min, N2Nat.inj_min. Qed. Lemma inj_max n m : 0<=n -> 0<=m -> Z.abs_nat (Z.max n m) = max (Z.abs_nat n) (Z.abs_nat m). Proof. intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_max, N2Nat.inj_max. Qed. (** [Z.abs_nat] and usual operations, statements with [Z.abs] *) Lemma inj_succ_abs n : Z.abs_nat (Z.succ (Z.abs n)) = S (Z.abs_nat n). Proof. now rewrite <- !Zabs_N_nat, Zabs2N.inj_succ_abs, N2Nat.inj_succ. Qed. Lemma inj_add_abs n m : Z.abs_nat (Z.abs n + Z.abs m) = (Z.abs_nat n + Z.abs_nat m)%nat. Proof. now rewrite <- !Zabs_N_nat, Zabs2N.inj_add_abs, N2Nat.inj_add. Qed. Lemma inj_mul_abs n m : Z.abs_nat (Z.abs n * Z.abs m) = (Z.abs_nat n * Z.abs_nat m)%nat. Proof. now rewrite <- !Zabs_N_nat, Zabs2N.inj_mul_abs, N2Nat.inj_mul. Qed. End Zabs2Nat. (** Compatibility *) Definition neq (x y:nat) := x <> y. Lemma inj_neq n m : neq n m -> Zne (Z.of_nat n) (Z.of_nat m). Proof. intros H H'. now apply H, Nat2Z.inj. Qed. Lemma Zpos_P_of_succ_nat n : Zpos (Pos.of_succ_nat n) = Z.succ (Z.of_nat n). Proof (Nat2Z.inj_succ n). (** For these one, used in omega, a Definition is necessary *) Definition inj_eq := (f_equal Z.of_nat). Definition inj_le n m := proj1 (Nat2Z.inj_le n m). Definition inj_lt n m := proj1 (Nat2Z.inj_lt n m). Definition inj_ge n m := proj1 (Nat2Z.inj_ge n m). Definition inj_gt n m := proj1 (Nat2Z.inj_gt n m). (** For the others, a Notation is fine *) Notation inj_0 := Nat2Z.inj_0 (compat "8.3"). Notation inj_S := Nat2Z.inj_succ (compat "8.3"). Notation inj_compare := Nat2Z.inj_compare (compat "8.3"). Notation inj_eq_rev := Nat2Z.inj (compat "8.3"). Notation inj_eq_iff := (fun n m => iff_sym (Nat2Z.inj_iff n m)) (compat "8.3"). Notation inj_le_iff := Nat2Z.inj_le (compat "8.3"). Notation inj_lt_iff := Nat2Z.inj_lt (compat "8.3"). Notation inj_ge_iff := Nat2Z.inj_ge (compat "8.3"). Notation inj_gt_iff := Nat2Z.inj_gt (compat "8.3"). Notation inj_le_rev := (fun n m => proj2 (Nat2Z.inj_le n m)) (compat "8.3"). Notation inj_lt_rev := (fun n m => proj2 (Nat2Z.inj_lt n m)) (compat "8.3"). Notation inj_ge_rev := (fun n m => proj2 (Nat2Z.inj_ge n m)) (compat "8.3"). Notation inj_gt_rev := (fun n m => proj2 (Nat2Z.inj_gt n m)) (compat "8.3"). Notation inj_plus := Nat2Z.inj_add (compat "8.3"). Notation inj_mult := Nat2Z.inj_mul (compat "8.3"). Notation inj_minus1 := Nat2Z.inj_sub (compat "8.3"). Notation inj_minus := Nat2Z.inj_sub_max (compat "8.3"). Notation inj_min := Nat2Z.inj_min (compat "8.3"). Notation inj_max := Nat2Z.inj_max (compat "8.3"). Notation Z_of_nat_of_P := positive_nat_Z (compat "8.3"). Notation Zpos_eq_Z_of_nat_o_nat_of_P := (fun p => eq_sym (positive_nat_Z p)) (compat "8.3"). Notation Z_of_nat_of_N := N_nat_Z (compat "8.3"). Notation Z_of_N_of_nat := nat_N_Z (compat "8.3"). Notation Z_of_N_eq := (f_equal Z.of_N) (compat "8.3"). Notation Z_of_N_eq_rev := N2Z.inj (compat "8.3"). Notation Z_of_N_eq_iff := (fun n m => iff_sym (N2Z.inj_iff n m)) (compat "8.3"). Notation Z_of_N_compare := N2Z.inj_compare (compat "8.3"). Notation Z_of_N_le_iff := N2Z.inj_le (compat "8.3"). Notation Z_of_N_lt_iff := N2Z.inj_lt (compat "8.3"). Notation Z_of_N_ge_iff := N2Z.inj_ge (compat "8.3"). Notation Z_of_N_gt_iff := N2Z.inj_gt (compat "8.3"). Notation Z_of_N_le := (fun n m => proj1 (N2Z.inj_le n m)) (compat "8.3"). Notation Z_of_N_lt := (fun n m => proj1 (N2Z.inj_lt n m)) (compat "8.3"). Notation Z_of_N_ge := (fun n m => proj1 (N2Z.inj_ge n m)) (compat "8.3"). Notation Z_of_N_gt := (fun n m => proj1 (N2Z.inj_gt n m)) (compat "8.3"). Notation Z_of_N_le_rev := (fun n m => proj2 (N2Z.inj_le n m)) (compat "8.3"). Notation Z_of_N_lt_rev := (fun n m => proj2 (N2Z.inj_lt n m)) (compat "8.3"). Notation Z_of_N_ge_rev := (fun n m => proj2 (N2Z.inj_ge n m)) (compat "8.3"). Notation Z_of_N_gt_rev := (fun n m => proj2 (N2Z.inj_gt n m)) (compat "8.3"). Notation Z_of_N_pos := N2Z.inj_pos (compat "8.3"). Notation Z_of_N_abs := N2Z.inj_abs_N (compat "8.3"). Notation Z_of_N_le_0 := N2Z.is_nonneg (compat "8.3"). Notation Z_of_N_plus := N2Z.inj_add (compat "8.3"). Notation Z_of_N_mult := N2Z.inj_mul (compat "8.3"). Notation Z_of_N_minus := N2Z.inj_sub_max (compat "8.3"). Notation Z_of_N_succ := N2Z.inj_succ (compat "8.3"). Notation Z_of_N_min := N2Z.inj_min (compat "8.3"). Notation Z_of_N_max := N2Z.inj_max (compat "8.3"). Notation Zabs_of_N := Zabs2N.id (compat "8.3"). Notation Zabs_N_succ_abs := Zabs2N.inj_succ_abs (compat "8.3"). Notation Zabs_N_succ := Zabs2N.inj_succ (compat "8.3"). Notation Zabs_N_plus_abs := Zabs2N.inj_add_abs (compat "8.3"). Notation Zabs_N_plus := Zabs2N.inj_add (compat "8.3"). Notation Zabs_N_mult_abs := Zabs2N.inj_mul_abs (compat "8.3"). Notation Zabs_N_mult := Zabs2N.inj_mul (compat "8.3"). Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z.of_nat (n - m) = 0. Proof. intros. rewrite not_le_minus_0; auto with arith. Qed. coq-8.4pl4/theories/ZArith/Zcompare.v0000644000175000017500000001261712326224777016634 0ustar stephsteph(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (m ?= n) = Lt. Proof Z.gt_lt_iff. Lemma Zcompare_antisym n m : CompOpp (n ?= m) = (m ?= n). Proof eq_sym (Z.compare_antisym n m). (** * Transitivity of comparison *) Lemma Zcompare_Lt_trans : forall n m p:Z, (n ?= m) = Lt -> (m ?= p) = Lt -> (n ?= p) = Lt. Proof Z.lt_trans. Lemma Zcompare_Gt_trans : forall n m p:Z, (n ?= m) = Gt -> (m ?= p) = Gt -> (n ?= p) = Gt. Proof. intros n m p. change (n > m -> m > p -> n > p). Z.swap_greater. intros. now transitivity m. Qed. (** * Comparison and opposite *) Lemma Zcompare_opp n m : (n ?= m) = (- m ?= - n). Proof. symmetry. apply Z.compare_opp. Qed. (** * Comparison first-order specification *) Lemma Zcompare_Gt_spec n m : (n ?= m) = Gt -> exists h, n + - m = Zpos h. Proof. rewrite Z.compare_sub. unfold Z.sub. destruct (n+-m) as [|p|p]; try discriminate. now exists p. Qed. (** * Comparison and addition *) Lemma Zcompare_plus_compat n m p : (p + n ?= p + m) = (n ?= m). Proof. apply Z.add_compare_mono_l. Qed. Lemma Zplus_compare_compat (r:comparison) (n m p q:Z) : (n ?= m) = r -> (p ?= q) = r -> (n + p ?= m + q) = r. Proof. rewrite (Z.compare_sub n), (Z.compare_sub p), (Z.compare_sub (n+p)). unfold Z.sub. rewrite Z.opp_add_distr. rewrite Z.add_shuffle1. destruct (n+-m), (p+-q); simpl; intros; now subst. Qed. Lemma Zcompare_succ_Gt n : (Z.succ n ?= n) = Gt. Proof. apply Z.lt_gt. apply Z.lt_succ_diag_r. Qed. Lemma Zcompare_Gt_not_Lt n m : (n ?= m) = Gt <-> (n ?= m+1) <> Lt. Proof. change (n > m <-> n >= m+1). Z.swap_greater. symmetry. apply Z.le_succ_l. Qed. (** * Successor and comparison *) Lemma Zcompare_succ_compat n m : (Z.succ n ?= Z.succ m) = (n ?= m). Proof. rewrite <- 2 Z.add_1_l. apply Z.add_compare_mono_l. Qed. (** * Multiplication and comparison *) Lemma Zcompare_mult_compat : forall (p:positive) (n m:Z), (Zpos p * n ?= Zpos p * m) = (n ?= m). Proof. intros p [|n|n] [|m|m]; simpl; trivial; now rewrite Pos.mul_compare_mono_l. Qed. Lemma Zmult_compare_compat_l n m p: p > 0 -> (n ?= m) = (p * n ?= p * m). Proof. intros; destruct p; try discriminate. symmetry. apply Zcompare_mult_compat. Qed. Lemma Zmult_compare_compat_r n m p : p > 0 -> (n ?= m) = (n * p ?= m * p). Proof. intros; rewrite 2 (Z.mul_comm _ p); now apply Zmult_compare_compat_l. Qed. (** * Relating [x ?= y] to [=], [<=], [<], [>=] or [>] *) Lemma Zcompare_elim : forall (c1 c2 c3:Prop) (n m:Z), (n = m -> c1) -> (n < m -> c2) -> (n > m -> c3) -> match n ?= m with | Eq => c1 | Lt => c2 | Gt => c3 end. Proof. intros. case Z.compare_spec; trivial. now Z.swap_greater. Qed. Lemma Zcompare_eq_case : forall (c1 c2 c3:Prop) (n m:Z), c1 -> n = m -> match n ?= m with | Eq => c1 | Lt => c2 | Gt => c3 end. Proof. intros. subst. now rewrite Z.compare_refl. Qed. Lemma Zle_compare : forall n m:Z, n <= m -> match n ?= m with | Eq => True | Lt => True | Gt => False end. Proof. intros. case Z.compare_spec; trivial; Z.order. Qed. Lemma Zlt_compare : forall n m:Z, n < m -> match n ?= m with | Eq => False | Lt => True | Gt => False end. Proof. intros x y H; now rewrite H. Qed. Lemma Zge_compare : forall n m:Z, n >= m -> match n ?= m with | Eq => True | Lt => False | Gt => True end. Proof. intros. now case Z.compare_spec. Qed. Lemma Zgt_compare : forall n m:Z, n > m -> match n ?= m with | Eq => False | Lt => False | Gt => True end. Proof. intros x y H; now rewrite H. Qed. (** Compatibility notations *) Notation Zcompare_refl := Z.compare_refl (compat "8.3"). Notation Zcompare_Eq_eq := Z.compare_eq (compat "8.3"). Notation Zcompare_Eq_iff_eq := Z.compare_eq_iff (compat "8.3"). Notation Zcompare_spec := Z.compare_spec (compat "8.3"). Notation Zmin_l := Z.min_l (compat "8.3"). Notation Zmin_r := Z.min_r (compat "8.3"). Notation Zmax_l := Z.max_l (compat "8.3"). Notation Zmax_r := Z.max_r (compat "8.3"). Notation Zabs_eq := Z.abs_eq (compat "8.3"). Notation Zabs_non_eq := Z.abs_neq (compat "8.3"). Notation Zsgn_0 := Z.sgn_null (compat "8.3"). Notation Zsgn_1 := Z.sgn_pos (compat "8.3"). Notation Zsgn_m1 := Z.sgn_neg (compat "8.3"). (** Not kept: Zcompare_egal_dec *) coq-8.4pl4/theories/ZArith/Zhints.v0000644000175000017500000000751412326224777016333 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Z.succ n = Z.succ m *) (** Lemmas ending by Z.gt *) Zsucc_gt_compat (* m > n -> Z.succ m > Z.succ n *) Zgt_succ (* Z.succ n > n *) Zorder.Zgt_pos_0 (* Z.pos p > 0 *) Zplus_gt_compat_l (* n > m -> p+n > p+m *) Zplus_gt_compat_r (* n > m -> n+p > m+p *) (** Lemmas ending by Z.lt *) Pos2Z.is_pos (* 0 < Z.pos p *) Z.lt_succ_diag_r (* n < Z.succ n *) Zsucc_lt_compat (* n < m -> Z.succ n < Z.succ m *) Z.lt_pred_l (* Z.pred n < n *) Zplus_lt_compat_l (* n < m -> p+n < p+m *) Zplus_lt_compat_r (* n < m -> n+p < m+p *) (** Lemmas ending by Z.le *) Nat2Z.is_nonneg (* 0 <= Z.of_nat n *) Pos2Z.is_nonneg (* 0 <= Z.pos p *) Z.le_refl (* n <= n *) Z.le_succ_diag_r (* n <= Z.succ n *) Zsucc_le_compat (* m <= n -> Z.succ m <= Z.succ n *) Z.le_pred_l (* Z.pred n <= n *) Z.le_min_l (* Z.min n m <= n *) Z.le_min_r (* Z.min n m <= m *) Zplus_le_compat_l (* n <= m -> p+n <= p+m *) Zplus_le_compat_r (* a <= b -> a+c <= b+c *) Z.abs_nonneg (* 0 <= |x| *) (** ** Irreversible simplification lemmas *) (** Probably to be declared as hints, when no other simplification is possible *) (** Lemmas ending by eq *) Z_eq_mult (* y = 0 -> y*x = 0 *) Zplus_eq_compat (* n = m -> p = q -> n+p = m+q *) (** Lemmas ending by Z.ge *) Zorder.Zmult_ge_compat_r (* a >= b -> c >= 0 -> a*c >= b*c *) Zorder.Zmult_ge_compat_l (* a >= b -> c >= 0 -> c*a >= c*b *) Zorder.Zmult_ge_compat (* : a >= c -> b >= d -> c >= 0 -> d >= 0 -> a*b >= c*d *) (** Lemmas ending by Z.lt *) Zorder.Zmult_gt_0_compat (* a > 0 -> b > 0 -> a*b > 0 *) Z.lt_lt_succ_r (* n < m -> n < Z.succ m *) (** Lemmas ending by Z.le *) Z.mul_nonneg_nonneg (* 0 <= x -> 0 <= y -> 0 <= x*y *) Zorder.Zmult_le_compat_r (* a <= b -> 0 <= c -> a*c <= b*c *) Zorder.Zmult_le_compat_l (* a <= b -> 0 <= c -> c*a <= c*b *) Z.add_nonneg_nonneg (* 0 <= x -> 0 <= y -> 0 <= x+y *) Z.le_le_succ_r (* x <= y -> x <= Z.succ y *) Z.add_le_mono (* n <= m -> p <= q -> n+p <= m+q *) : zarith. coq-8.4pl4/theories/ZArith/Zminmax.v0000644000175000017500000000217712326224777016477 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 1 | Zpos p => Pos.iter_op Z.mul p n | Zneg p => 0 end. Infix "^^" := Zpower_alt (at level 30, right associativity) : Z_scope. Lemma Piter_mul_acc : forall f, (forall x y:Z, (f x)*y = f (x*y)) -> forall p k, Pos.iter p f k = (Pos.iter p f 1)*k. Proof. intros f Hf. induction p; simpl; intros. - set (g := Pos.iter p f 1) in *. now rewrite !IHp, Hf, Z.mul_assoc. - set (g := Pos.iter p f 1) in *. now rewrite !IHp, Z.mul_assoc. - now rewrite Hf, Z.mul_1_l. Qed. Lemma Piter_op_square : forall p a, Pos.iter_op Z.mul p (a*a) = (Pos.iter_op Z.mul p a)*(Pos.iter_op Z.mul p a). Proof. induction p; simpl; intros; trivial. now rewrite IHp, Z.mul_shuffle1. Qed. Lemma Zpower_equiv a b : a^^b = a^b. Proof. destruct b as [|p|p]; trivial. unfold Zpower_alt, Z.pow, Z.pow_pos. revert a. induction p; simpl; intros. - f_equal. rewrite Piter_mul_acc. now rewrite Piter_op_square, IHp. intros. symmetry; apply Z.mul_assoc. - rewrite Piter_mul_acc. now rewrite Piter_op_square, IHp. intros. symmetry; apply Z.mul_assoc. - now Z.nzsimpl. Qed. Lemma Zpower_alt_0_r n : n^^0 = 1. Proof. reflexivity. Qed. Lemma Zpower_alt_succ_r a b : 0<=b -> a^^(Z.succ b) = a * a^^b. Proof. destruct b as [|b|b]; intros Hb; simpl. - now Z.nzsimpl. - now rewrite Pos.add_1_r, Pos.iter_op_succ by apply Z.mul_assoc. - now elim Hb. Qed. Lemma Zpower_alt_neg_r a b : b<0 -> a^^b = 0. Proof. now destruct b. Qed. Lemma Zpower_alt_Ppow p q : (Zpos p)^^(Zpos q) = Zpos (p^q). Proof. now rewrite Zpower_equiv, Pos2Z.inj_pow. Qed. coq-8.4pl4/theories/ZArith/Zmin.v0000644000175000017500000000425212326224777015765 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* y /\ Z.min x y = y. Proof. Z.swap_greater. rewrite Z.min_comm. destruct (Z.min_spec y x); auto. Qed. Lemma Zmin_irreducible n m : Z.min n m = n \/ Z.min n m = m. Proof. destruct (Z.min_dec n m); auto. Qed. Notation Zmin_or := Zmin_irreducible (compat "8.3"). Lemma Zmin_le_prime_inf n m p : Z.min n m <= p -> {n <= p} + {m <= p}. Proof. apply Z.min_case; auto. Qed. Lemma Zpos_min_1 p : Z.min 1 (Zpos p) = 1. Proof. now destruct p. Qed. coq-8.4pl4/theories/ZArith/ZOdiv.v0000644000175000017500000001072712326224777016107 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* P) -> ((n ?= m) = Lt -> P) -> ((n ?= m) = Gt -> P) -> P. Proof. intros H1 H2 H3. destruct (n ?= m); auto. Defined. Lemma Zcompare_rec (P:Set) (n m:Z) : ((n ?= m) = Eq -> P) -> ((n ?= m) = Lt -> P) -> ((n ?= m) = Gt -> P) -> P. Proof. apply Zcompare_rect. Defined. Notation Z_eq_dec := Z.eq_dec (compat "8.3"). Section decidability. Variables x y : Z. (** * Decidability of order on binary integers *) Definition Z_lt_dec : {x < y} + {~ x < y}. Proof. unfold Z.lt; case Z.compare; (now left) || (now right). Defined. Definition Z_le_dec : {x <= y} + {~ x <= y}. Proof. unfold Z.le; case Z.compare; (now left) || (right; tauto). Defined. Definition Z_gt_dec : {x > y} + {~ x > y}. Proof. unfold Z.gt; case Z.compare; (now left) || (now right). Defined. Definition Z_ge_dec : {x >= y} + {~ x >= y}. Proof. unfold Z.ge; case Z.compare; (now left) || (right; tauto). Defined. Definition Z_lt_ge_dec : {x < y} + {x >= y}. Proof. exact Z_lt_dec. Defined. Lemma Z_lt_le_dec : {x < y} + {y <= x}. Proof. elim Z_lt_ge_dec. * now left. * right; now apply Z.ge_le. Defined. Definition Z_le_gt_dec : {x <= y} + {x > y}. Proof. elim Z_le_dec; auto with arith. intro. right. Z.swap_greater. now apply Z.nle_gt. Defined. Definition Z_gt_le_dec : {x > y} + {x <= y}. Proof. exact Z_gt_dec. Defined. Definition Z_ge_lt_dec : {x >= y} + {x < y}. Proof. elim Z_ge_dec; auto with arith. intro. right. Z.swap_greater. now apply Z.lt_nge. Defined. Definition Z_le_lt_eq_dec : x <= y -> {x < y} + {x = y}. Proof. intro H. apply Zcompare_rec with (n := x) (m := y). intro. right. elim (Z.compare_eq_iff x y); auto with arith. intro. left. elim (Z.compare_eq_iff x y); auto with arith. intro H1. absurd (x > y); auto with arith. Defined. End decidability. (** * Cotransitivity of order on binary integers *) Lemma Zlt_cotrans : forall n m:Z, n < m -> forall p:Z, {n < p} + {p < m}. Proof. intros x y H z. case (Z_lt_ge_dec x z). intro. left. assumption. intro. right. apply Z.le_lt_trans with (m := x). apply Z.ge_le. assumption. assumption. Defined. Lemma Zlt_cotrans_pos : forall n m:Z, 0 < n + m -> {0 < n} + {0 < m}. Proof. intros x y H. case (Zlt_cotrans 0 (x + y) H x). - now left. - right. apply Z.add_lt_mono_l with (p := x). now rewrite Z.add_0_r. Defined. Lemma Zlt_cotrans_neg : forall n m:Z, n + m < 0 -> {n < 0} + {m < 0}. Proof. intros x y H; case (Zlt_cotrans (x + y) 0 H x); intro Hxy; [ right; apply Z.add_lt_mono_l with (p := x); rewrite Z.add_0_r | left ]; assumption. Defined. Lemma not_Zeq_inf : forall n m:Z, n <> m -> {n < m} + {m < n}. Proof. intros x y H. case Z_lt_ge_dec with x y. intro. left. assumption. intro H0. generalize (Z.ge_le _ _ H0). intro. case (Z_le_lt_eq_dec _ _ H1). intro. right. assumption. intro. apply False_rec. apply H. symmetry . assumption. Defined. Lemma Z_dec : forall n m:Z, {n < m} + {n > m} + {n = m}. Proof. intros x y. case (Z_lt_ge_dec x y). intro H. left. left. assumption. intro H. generalize (Z.ge_le _ _ H). intro H0. case (Z_le_lt_eq_dec y x H0). intro H1. left. right. apply Z.lt_gt. assumption. intro. right. symmetry . assumption. Defined. Lemma Z_dec' : forall n m:Z, {n < m} + {m < n} + {n = m}. Proof. intros x y. case (Z.eq_dec x y); intro H; [ right; assumption | left; apply (not_Zeq_inf _ _ H) ]. Defined. (* begin hide *) (* To deprecate ? *) Corollary Z_zerop : forall x:Z, {x = 0} + {x <> 0}. Proof. exact (fun x:Z => Z.eq_dec x 0). Defined. Corollary Z_notzerop : forall (x:Z), {x <> 0} + {x = 0}. Proof (fun x => sumbool_not _ _ (Z_zerop x)). Corollary Z_noteq_dec : forall (x y:Z), {x <> y} + {x = y}. Proof (fun x y => sumbool_not _ _ (Z.eq_dec x y)). (* end hide *) coq-8.4pl4/theories/ZArith/ZOdiv_def.v0000644000175000017500000000132612326224777016720 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 (* 1 *) | xO q => Z.succ (log_inf q) (* 2n *) | xI q => Z.succ (log_inf q) (* 2n+1 *) end. Fixpoint log_sup (p:positive) : Z := match p with | xH => 0 (* 1 *) | xO n => Z.succ (log_sup n) (* 2n *) | xI n => Z.succ (Z.succ (log_inf n)) (* 2n+1 *) end. Hint Unfold log_inf log_sup. Lemma Psize_log_inf : forall p, Zpos (Pos.size p) = Z.succ (log_inf p). Proof. induction p; simpl; now rewrite ?Pos2Z.inj_succ, ?IHp. Qed. Lemma Zlog2_log_inf : forall p, Z.log2 (Zpos p) = log_inf p. Proof. unfold Z.log2. destruct p; simpl; trivial; apply Psize_log_inf. Qed. Lemma Zlog2_up_log_sup : forall p, Z.log2_up (Zpos p) = log_sup p. Proof. induction p; simpl. - change (Zpos p~1) with (2*(Zpos p)+1). rewrite Z.log2_up_succ_double, Zlog2_log_inf; try easy. unfold Z.succ. now rewrite !(Z.add_comm _ 1), Z.add_assoc. - change (Zpos p~0) with (2*Zpos p). now rewrite Z.log2_up_double, IHp. - reflexivity. Qed. (** Then we give the specifications of [log_inf] and [log_sup] and prove their validity *) Hint Resolve Z.le_trans: zarith. Theorem log_inf_correct : forall x:positive, 0 <= log_inf x /\ two_p (log_inf x) <= Zpos x < two_p (Z.succ (log_inf x)). Proof. simple induction x; intros; simpl; [ elim H; intros Hp HR; clear H; split; [ auto with zarith | rewrite two_p_S with (x := Z.succ (log_inf p)) by (apply Z.le_le_succ_r; trivial); rewrite two_p_S by trivial; rewrite two_p_S in HR by trivial; rewrite (BinInt.Pos2Z.inj_xI p); omega ] | elim H; intros Hp HR; clear H; split; [ auto with zarith | rewrite two_p_S with (x := Z.succ (log_inf p)) by (apply Z.le_le_succ_r; trivial); rewrite two_p_S by trivial; rewrite two_p_S in HR by trivial; rewrite (BinInt.Pos2Z.inj_xO p); omega ] | unfold two_power_pos; unfold shift_pos; simpl; omega ]. Qed. Definition log_inf_correct1 (p:positive) := proj1 (log_inf_correct p). Definition log_inf_correct2 (p:positive) := proj2 (log_inf_correct p). Opaque log_inf_correct1 log_inf_correct2. Hint Resolve log_inf_correct1 log_inf_correct2: zarith. Lemma log_sup_correct1 : forall p:positive, 0 <= log_sup p. Proof. simple induction p; intros; simpl; auto with zarith. Qed. (** For every [p], either [p] is a power of two and [(log_inf p)=(log_sup p)] either [(log_sup p)=(log_inf p)+1] *) Theorem log_sup_log_inf : forall p:positive, IF Zpos p = two_p (log_inf p) then Zpos p = two_p (log_sup p) else log_sup p = Z.succ (log_inf p). Proof. simple induction p; intros; [ elim H; right; simpl; rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0)); rewrite BinInt.Pos2Z.inj_xI; unfold Z.succ; omega | elim H; clear H; intro Hif; [ left; simpl; rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0)); rewrite (two_p_S (log_sup p0) (log_sup_correct1 p0)); rewrite <- (proj1 Hif); rewrite <- (proj2 Hif); auto | right; simpl; rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0)); rewrite BinInt.Pos2Z.inj_xO; unfold Z.succ; omega ] | left; auto ]. Qed. Theorem log_sup_correct2 : forall x:positive, two_p (Z.pred (log_sup x)) < Zpos x <= two_p (log_sup x). Proof. intro. elim (log_sup_log_inf x). (* x is a power of two and [log_sup = log_inf] *) intros [E1 E2]; rewrite E2. split; [ apply two_p_pred; apply log_sup_correct1 | apply Z.le_refl ]. intros [E1 E2]; rewrite E2. rewrite (Z.pred_succ (log_inf x)). generalize (log_inf_correct2 x); omega. Qed. Lemma log_inf_le_log_sup : forall p:positive, log_inf p <= log_sup p. Proof. simple induction p; simpl; intros; omega. Qed. Lemma log_sup_le_Slog_inf : forall p:positive, log_sup p <= Z.succ (log_inf p). Proof. simple induction p; simpl; intros; omega. Qed. (** Now it's possible to specify and build the [Log] rounded to the nearest *) Fixpoint log_near (x:positive) : Z := match x with | xH => 0 | xO xH => 1 | xI xH => 2 | xO y => Z.succ (log_near y) | xI y => Z.succ (log_near y) end. Theorem log_near_correct1 : forall p:positive, 0 <= log_near p. Proof. simple induction p; simpl; intros; [ elim p0; auto with zarith | elim p0; auto with zarith | trivial with zarith ]. intros; apply Z.le_le_succ_r. generalize H0; now elim p1. intros; apply Z.le_le_succ_r. generalize H0; now elim p1. Qed. Theorem log_near_correct2 : forall p:positive, log_near p = log_inf p \/ log_near p = log_sup p. Proof. simple induction p. intros p0 [Einf| Esup]. simpl. rewrite Einf. case p0; [ left | left | right ]; reflexivity. simpl; rewrite Esup. elim (log_sup_log_inf p0). generalize (log_inf_le_log_sup p0). generalize (log_sup_le_Slog_inf p0). case p0; auto with zarith. intros; omega. case p0; intros; auto with zarith. intros p0 [Einf| Esup]. simpl. repeat rewrite Einf. case p0; intros; auto with zarith. simpl. repeat rewrite Esup. case p0; intros; auto with zarith. auto. Qed. End Log_pos. Section divers. (** Number of significative digits. *) Definition N_digits (x:Z) := match x with | Zpos p => log_inf p | Zneg p => log_inf p | Z0 => 0 end. Lemma ZERO_le_N_digits : forall x:Z, 0 <= N_digits x. Proof. simple induction x; simpl; [ apply Z.le_refl | exact log_inf_correct1 | exact log_inf_correct1 ]. Qed. Lemma log_inf_shift_nat : forall n:nat, log_inf (shift_nat n 1) = Z.of_nat n. Proof. simple induction n; intros; [ try trivial | rewrite Nat2Z.inj_succ; rewrite <- H; reflexivity ]. Qed. Lemma log_sup_shift_nat : forall n:nat, log_sup (shift_nat n 1) = Z.of_nat n. Proof. simple induction n; intros; [ try trivial | rewrite Nat2Z.inj_succ; rewrite <- H; reflexivity ]. Qed. (** [Is_power p] means that p is a power of two *) Fixpoint Is_power (p:positive) : Prop := match p with | xH => True | xO q => Is_power q | xI q => False end. Lemma Is_power_correct : forall p:positive, Is_power p <-> (exists y : nat, p = shift_nat y 1). Proof. split; [ elim p; [ simpl; tauto | simpl; intros; generalize (H H0); intro H1; elim H1; intros y0 Hy0; exists (S y0); rewrite Hy0; reflexivity | intro; exists 0%nat; reflexivity ] | intros; elim H; intros; rewrite H0; elim x; intros; simpl; trivial ]. Qed. Lemma Is_power_or : forall p:positive, Is_power p \/ ~ Is_power p. Proof. simple induction p; [ intros; right; simpl; tauto | intros; elim H; [ intros; left; simpl; exact H0 | intros; right; simpl; exact H0 ] | left; simpl; trivial ]. Qed. End divers. coq-8.4pl4/theories/ZArith/intro.tex0000755000175000017500000000035612326224777016542 0ustar stephsteph\section{Binary integers : ZArith} The {\tt ZArith} library deals with binary integers (those used by the {\tt Omega} decision tactic). Here are defined various arithmetical notions and their properties, similar to those of {\tt Arith}. coq-8.4pl4/theories/ZArith/BinIntDef.v0000644000175000017500000003503712326224777016657 0ustar stephsteph(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 | pos p => pos p~0 | neg p => neg p~0 end. Definition succ_double x := match x with | 0 => 1 | pos p => pos p~1 | neg p => neg (Pos.pred_double p) end. Definition pred_double x := match x with | 0 => -1 | neg p => neg p~1 | pos p => pos (Pos.pred_double p) end. (** ** Subtraction of positive into Z *) Fixpoint pos_sub (x y:positive) {struct y} : Z := match x, y with | p~1, q~1 => double (pos_sub p q) | p~1, q~0 => succ_double (pos_sub p q) | p~1, 1 => pos p~0 | p~0, q~1 => pred_double (pos_sub p q) | p~0, q~0 => double (pos_sub p q) | p~0, 1 => pos (Pos.pred_double p) | 1, q~1 => neg q~0 | 1, q~0 => neg (Pos.pred_double q) | 1, 1 => Z0 end%positive. (** ** Addition *) Definition add x y := match x, y with | 0, y => y | x, 0 => x | pos x', pos y' => pos (x' + y') | pos x', neg y' => pos_sub x' y' | neg x', pos y' => pos_sub y' x' | neg x', neg y' => neg (x' + y') end. Infix "+" := add : Z_scope. (** ** Opposite *) Definition opp x := match x with | 0 => 0 | pos x => neg x | neg x => pos x end. Notation "- x" := (opp x) : Z_scope. (** ** Successor *) Definition succ x := x + 1. (** ** Predecessor *) Definition pred x := x + -1. (** ** Subtraction *) Definition sub m n := m + -n. Infix "-" := sub : Z_scope. (** ** Multiplication *) Definition mul x y := match x, y with | 0, _ => 0 | _, 0 => 0 | pos x', pos y' => pos (x' * y') | pos x', neg y' => neg (x' * y') | neg x', pos y' => neg (x' * y') | neg x', neg y' => pos (x' * y') end. Infix "*" := mul : Z_scope. (** ** Power function *) Definition pow_pos (z:Z) (n:positive) := Pos.iter n (mul z) 1. Definition pow x y := match y with | pos p => pow_pos x p | 0 => 1 | neg _ => 0 end. Infix "^" := pow : Z_scope. (** ** Square *) Definition square x := match x with | 0 => 0 | pos p => pos (Pos.square p) | neg p => pos (Pos.square p) end. (** ** Comparison *) Definition compare x y := match x, y with | 0, 0 => Eq | 0, pos y' => Lt | 0, neg y' => Gt | pos x', 0 => Gt | pos x', pos y' => (x' ?= y')%positive | pos x', neg y' => Gt | neg x', 0 => Lt | neg x', pos y' => Lt | neg x', neg y' => CompOpp ((x' ?= y')%positive) end. Infix "?=" := compare (at level 70, no associativity) : Z_scope. (** ** Sign function *) Definition sgn z := match z with | 0 => 0 | pos p => 1 | neg p => -1 end. (** Boolean equality and comparisons *) Definition leb x y := match x ?= y with | Gt => false | _ => true end. Definition ltb x y := match x ?= y with | Lt => true | _ => false end. (** Nota: [geb] and [gtb] are provided for compatibility, but [leb] and [ltb] should rather be used instead, since more results will be available on them. *) Definition geb x y := match x ?= y with | Lt => false | _ => true end. Definition gtb x y := match x ?= y with | Gt => true | _ => false end. Fixpoint eqb x y := match x, y with | 0, 0 => true | pos p, pos q => Pos.eqb p q | neg p, neg q => Pos.eqb p q | _, _ => false end. Infix "=?" := eqb (at level 70, no associativity) : Z_scope. Infix "<=?" := leb (at level 70, no associativity) : Z_scope. Infix "=?" := geb (at level 70, no associativity) : Z_scope. Infix ">?" := gtb (at level 70, no associativity) : Z_scope. (** ** Minimum and maximum *) Definition max n m := match n ?= m with | Eq | Gt => n | Lt => m end. Definition min n m := match n ?= m with | Eq | Lt => n | Gt => m end. (** ** Absolute value *) Definition abs z := match z with | 0 => 0 | pos p => pos p | neg p => pos p end. (** ** Conversions *) (** From [Z] to [nat] via absolute value *) Definition abs_nat (z:Z) : nat := match z with | 0 => 0%nat | pos p => Pos.to_nat p | neg p => Pos.to_nat p end. (** From [Z] to [N] via absolute value *) Definition abs_N (z:Z) : N := match z with | 0 => 0%N | pos p => N.pos p | neg p => N.pos p end. (** From [Z] to [nat] by rounding negative numbers to 0 *) Definition to_nat (z:Z) : nat := match z with | pos p => Pos.to_nat p | _ => O end. (** From [Z] to [N] by rounding negative numbers to 0 *) Definition to_N (z:Z) : N := match z with | pos p => N.pos p | _ => 0%N end. (** From [nat] to [Z] *) Definition of_nat (n:nat) : Z := match n with | O => 0 | S n => pos (Pos.of_succ_nat n) end. (** From [N] to [Z] *) Definition of_N (n:N) : Z := match n with | 0%N => 0 | N.pos p => pos p end. (** From [Z] to [positive] by rounding nonpositive numbers to 1 *) Definition to_pos (z:Z) : positive := match z with | pos p => p | _ => 1%positive end. (** ** Iteration of a function By convention, iterating a negative number of times is identity. *) Definition iter (n:Z) {A} (f:A -> A) (x:A) := match n with | pos p => Pos.iter p f x | _ => x end. (** ** Euclidean divisions for binary integers *) (** Concerning the many possible variants of integer divisions, see the headers of the generic files [ZDivFloor], [ZDivTrunc], [ZDivEucl], and the article by R. Boute mentioned there. We provide here two flavours, Floor and Trunc, while the Euclid convention can be found in file Zeuclid.v For non-zero b, they all satisfy [a = b*(a/b) + (a mod b)] and [ |a mod b| < |b| ], but the sign of the modulo will differ when [a<0] and/or [b<0]. *) (** ** Floor division *) (** [div_eucl] provides a Truncated-Toward-Bottom (a.k.a Floor) Euclidean division. Its projections are named [div] (noted "/") and [modulo] (noted with an infix "mod"). These functions correspond to the `div` and `mod` of Haskell. This is the historical convention of Coq. The main properties of this convention are : - we have [sgn (a mod b) = sgn (b)] - [div a b] is the greatest integer smaller or equal to the exact fraction [a/b]. - there is no easy sign rule. In addition, note that we arbitrary take [a/0 = 0] and [a mod 0 = 0]. *) (** First, a division for positive numbers. Even if the second argument is a Z, the answer is arbitrary is it isn't a Zpos. *) Fixpoint pos_div_eucl (a:positive) (b:Z) : Z * Z := match a with | xH => if 2 <=? b then (0, 1) else (1, 0) | xO a' => let (q, r) := pos_div_eucl a' b in let r' := 2 * r in if r' let (q, r) := pos_div_eucl a' b in let r' := 2 * r + 1 in if r' (0, 0) | _, 0 => (0, 0) | pos a', pos _ => pos_div_eucl a' b | neg a', pos _ => let (q, r) := pos_div_eucl a' b in match r with | 0 => (- q, 0) | _ => (- (q + 1), b - r) end | neg a', neg b' => let (q, r) := pos_div_eucl a' (pos b') in (q, - r) | pos a', neg b' => let (q, r) := pos_div_eucl a' (pos b') in match r with | 0 => (- q, 0) | _ => (- (q + 1), b + r) end end. Definition div (a b:Z) : Z := let (q, _) := div_eucl a b in q. Definition modulo (a b:Z) : Z := let (_, r) := div_eucl a b in r. Infix "/" := div : Z_scope. Infix "mod" := modulo (at level 40, no associativity) : Z_scope. (** ** Trunc Division *) (** [quotrem] provides a Truncated-Toward-Zero Euclidean division. Its projections are named [quot] (noted "÷") and [rem]. These functions correspond to the `quot` and `rem` of Haskell. This division convention is used in most programming languages, e.g. Ocaml. With this convention: - we have [sgn(a rem b) = sgn(a)] - sign rule for division: [quot (-a) b = quot a (-b) = -(quot a b)] - and for modulo: [a rem (-b) = a rem b] and [(-a) rem b = -(a rem b)] Note that we arbitrary take here [quot a 0 = 0] and [a rem 0 = a]. *) Definition quotrem (a b:Z) : Z * Z := match a, b with | 0, _ => (0, 0) | _, 0 => (0, a) | pos a, pos b => let (q, r) := N.pos_div_eucl a (N.pos b) in (of_N q, of_N r) | neg a, pos b => let (q, r) := N.pos_div_eucl a (N.pos b) in (-of_N q, - of_N r) | pos a, neg b => let (q, r) := N.pos_div_eucl a (N.pos b) in (-of_N q, of_N r) | neg a, neg b => let (q, r) := N.pos_div_eucl a (N.pos b) in (of_N q, - of_N r) end. Definition quot a b := fst (quotrem a b). Definition rem a b := snd (quotrem a b). Infix "÷" := quot (at level 40, left associativity) : Z_scope. (** No infix notation for rem, otherwise it becomes a keyword *) (** ** Parity functions *) Definition even z := match z with | 0 => true | pos (xO _) => true | neg (xO _) => true | _ => false end. Definition odd z := match z with | 0 => false | pos (xO _) => false | neg (xO _) => false | _ => true end. (** ** Division by two *) (** [div2] performs rounding toward bottom, it is hence a particular case of [div], and for all relative number [n] we have: [n = 2 * div2 n + if odd n then 1 else 0]. *) Definition div2 z := match z with | 0 => 0 | pos 1 => 0 | pos p => pos (Pos.div2 p) | neg p => neg (Pos.div2_up p) end. (** [quot2] performs rounding toward zero, it is hence a particular case of [quot], and for all relative number [n] we have: [n = 2 * quot2 n + if odd n then sgn n else 0]. *) Definition quot2 (z:Z) := match z with | 0 => 0 | pos 1 => 0 | pos p => pos (Pos.div2 p) | neg 1 => 0 | neg p => neg (Pos.div2 p) end. (** NB: [Z.quot2] used to be named [Z.div2] in Coq <= 8.3 *) (** * Base-2 logarithm *) Definition log2 z := match z with | pos (p~1) => pos (Pos.size p) | pos (p~0) => pos (Pos.size p) | _ => 0 end. (** ** Square root *) Definition sqrtrem n := match n with | 0 => (0, 0) | pos p => match Pos.sqrtrem p with | (s, IsPos r) => (pos s, pos r) | (s, _) => (pos s, 0) end | neg _ => (0,0) end. Definition sqrt n := match n with | pos p => pos (Pos.sqrt p) | _ => 0 end. (** ** Greatest Common Divisor *) Definition gcd a b := match a,b with | 0, _ => abs b | _, 0 => abs a | pos a, pos b => pos (Pos.gcd a b) | pos a, neg b => pos (Pos.gcd a b) | neg a, pos b => pos (Pos.gcd a b) | neg a, neg b => pos (Pos.gcd a b) end. (** A generalized gcd, also computing division of a and b by gcd. *) Definition ggcd a b : Z*(Z*Z) := match a,b with | 0, _ => (abs b,(0, sgn b)) | _, 0 => (abs a,(sgn a, 0)) | pos a, pos b => let '(g,(aa,bb)) := Pos.ggcd a b in (pos g, (pos aa, pos bb)) | pos a, neg b => let '(g,(aa,bb)) := Pos.ggcd a b in (pos g, (pos aa, neg bb)) | neg a, pos b => let '(g,(aa,bb)) := Pos.ggcd a b in (pos g, (neg aa, pos bb)) | neg a, neg b => let '(g,(aa,bb)) := Pos.ggcd a b in (pos g, (neg aa, neg bb)) end. (** ** Bitwise functions *) (** When accessing the bits of negative numbers, all functions below will use the two's complement representation. For instance, [-1] will correspond to an infinite stream of true bits. If this isn't what you're looking for, you can use [abs] first and then access the bits of the absolute value. *) (** [testbit] : accessing the [n]-th bit of a number [a]. For negative [n], we arbitrarily answer [false]. *) Definition testbit a n := match n with | 0 => odd a | pos p => match a with | 0 => false | pos a => Pos.testbit a (N.pos p) | neg a => negb (N.testbit (Pos.pred_N a) (N.pos p)) end | neg _ => false end. (** Shifts Nota: a shift to the right by [-n] will be a shift to the left by [n], and vice-versa. For fulfilling the two's complement convention, shifting to the right a negative number should correspond to a division by 2 with rounding toward bottom, hence the use of [div2] instead of [quot2]. *) Definition shiftl a n := match n with | 0 => a | pos p => Pos.iter p (mul 2) a | neg p => Pos.iter p div2 a end. Definition shiftr a n := shiftl a (-n). (** Bitwise operations [lor] [land] [ldiff] [lxor] *) Definition lor a b := match a, b with | 0, _ => b | _, 0 => a | pos a, pos b => pos (Pos.lor a b) | neg a, pos b => neg (N.succ_pos (N.ldiff (Pos.pred_N a) (N.pos b))) | pos a, neg b => neg (N.succ_pos (N.ldiff (Pos.pred_N b) (N.pos a))) | neg a, neg b => neg (N.succ_pos (N.land (Pos.pred_N a) (Pos.pred_N b))) end. Definition land a b := match a, b with | 0, _ => 0 | _, 0 => 0 | pos a, pos b => of_N (Pos.land a b) | neg a, pos b => of_N (N.ldiff (N.pos b) (Pos.pred_N a)) | pos a, neg b => of_N (N.ldiff (N.pos a) (Pos.pred_N b)) | neg a, neg b => neg (N.succ_pos (N.lor (Pos.pred_N a) (Pos.pred_N b))) end. Definition ldiff a b := match a, b with | 0, _ => 0 | _, 0 => a | pos a, pos b => of_N (Pos.ldiff a b) | neg a, pos b => neg (N.succ_pos (N.lor (Pos.pred_N a) (N.pos b))) | pos a, neg b => of_N (N.land (N.pos a) (Pos.pred_N b)) | neg a, neg b => of_N (N.ldiff (Pos.pred_N b) (Pos.pred_N a)) end. Definition lxor a b := match a, b with | 0, _ => b | _, 0 => a | pos a, pos b => of_N (Pos.lxor a b) | neg a, pos b => neg (N.succ_pos (N.lxor (Pos.pred_N a) (N.pos b))) | pos a, neg b => neg (N.succ_pos (N.lxor (N.pos a) (Pos.pred_N b))) | neg a, neg b => of_N (N.lxor (Pos.pred_N a) (Pos.pred_N b)) end. End Z.coq-8.4pl4/theories/ZArith/Zcomplements.v0000644000175000017500000001125012326224777017524 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 1%positive | xO a' => xO (floor_pos a') | xI b' => xO (floor_pos b') end. Definition floor (a:positive) := Zpos (floor_pos a). Lemma floor_gt0 : forall p:positive, floor p > 0. Proof. reflexivity. Qed. Lemma floor_ok : forall p:positive, floor p <= Zpos p < 2 * floor p. Proof. unfold floor. induction p; simpl. - rewrite !Pos2Z.inj_xI, (Pos2Z.inj_xO (xO _)), Pos2Z.inj_xO. omega. - rewrite (Pos2Z.inj_xO (xO _)), (Pos2Z.inj_xO p), Pos2Z.inj_xO. omega. - omega. Qed. (**********************************************************************) (** Two more induction principles over [Z]. *) Theorem Z_lt_abs_rec : forall P:Z -> Set, (forall n:Z, (forall m:Z, Z.abs m < Z.abs n -> P m) -> P n) -> forall n:Z, P n. Proof. intros P HP p. set (Q := fun z => 0 <= z -> P z * P (- z)) in *. cut (Q (Z.abs p)); [ intros | apply (Z_lt_rec Q); auto with zarith ]. elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith. unfold Q; clear Q; intros. split; apply HP. rewrite Z.abs_eq; auto; intros. elim (H (Z.abs m)); intros; auto with zarith. elim (Zabs_dec m); intro eq; rewrite eq; trivial. rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros. elim (H (Z.abs m)); intros; auto with zarith. elim (Zabs_dec m); intro eq; rewrite eq; trivial. Qed. Theorem Z_lt_abs_induction : forall P:Z -> Prop, (forall n:Z, (forall m:Z, Z.abs m < Z.abs n -> P m) -> P n) -> forall n:Z, P n. Proof. intros P HP p. set (Q := fun z => 0 <= z -> P z /\ P (- z)) in *. cut (Q (Z.abs p)); [ intros | apply (Z_lt_induction Q); auto with zarith ]. elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith. unfold Q; clear Q; intros. split; apply HP. rewrite Z.abs_eq; auto; intros. elim (H (Z.abs m)); intros; auto with zarith. elim (Zabs_dec m); intro eq; rewrite eq; trivial. rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros. elim (H (Z.abs m)); intros; auto with zarith. elim (Zabs_dec m); intro eq; rewrite eq; trivial. Qed. (** To do case analysis over the sign of [z] *) Lemma Zcase_sign : forall (n:Z) (P:Prop), (n = 0 -> P) -> (n > 0 -> P) -> (n < 0 -> P) -> P. Proof. intros x P Hzero Hpos Hneg. destruct x; [apply Hzero|apply Hpos|apply Hneg]; easy. Qed. Lemma sqr_pos n : n * n >= 0. Proof. Z.swap_greater. apply Z.square_nonneg. Qed. (**********************************************************************) (** A list length in Z, tail recursive. *) Require Import List. Fixpoint Zlength_aux (acc:Z) (A:Type) (l:list A) : Z := match l with | nil => acc | _ :: l => Zlength_aux (Z.succ acc) A l end. Definition Zlength := Zlength_aux 0. Arguments Zlength [A] l. Section Zlength_properties. Variable A : Type. Implicit Type l : list A. Lemma Zlength_correct l : Zlength l = Z.of_nat (length l). Proof. assert (H : forall l acc, Zlength_aux acc A l = acc + Z.of_nat (length l)). clear l. induction l. auto with zarith. intros. simpl length; simpl Zlength_aux. rewrite IHl, Nat2Z.inj_succ; auto with zarith. unfold Zlength. now rewrite H. Qed. Lemma Zlength_nil : Zlength (A:=A) nil = 0. Proof. reflexivity. Qed. Lemma Zlength_cons (x:A) l : Zlength (x :: l) = Z.succ (Zlength l). Proof. intros. now rewrite !Zlength_correct, <- Nat2Z.inj_succ. Qed. Lemma Zlength_nil_inv l : Zlength l = 0 -> l = nil. Proof. rewrite Zlength_correct. destruct l as [|x l]; auto. now rewrite <- Nat2Z.inj_0, Nat2Z.inj_iff. Qed. End Zlength_properties. Arguments Zlength_correct [A] l. Arguments Zlength_cons [A] x l. Arguments Zlength_nil_inv [A] l _. coq-8.4pl4/theories/ZArith/Int.v0000644000175000017500000003205512326224777015604 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Z. Parameter _0 : t. Parameter _1 : t. Parameter _2 : t. Parameter _3 : t. Parameter plus : t -> t -> t. Parameter opp : t -> t. Parameter minus : t -> t -> t. Parameter mult : t -> t -> t. Parameter max : t -> t -> t. Notation "0" := _0 : Int_scope. Notation "1" := _1 : Int_scope. Notation "2" := _2 : Int_scope. Notation "3" := _3 : Int_scope. Infix "+" := plus : Int_scope. Infix "-" := minus : Int_scope. Infix "*" := mult : Int_scope. Notation "- x" := (opp x) : Int_scope. (** For logical relations, we can rely on their counterparts in Z, since they don't appear after extraction. Moreover, using tactics like omega is easier this way. *) Notation "x == y" := (i2z x = i2z y) (at level 70, y at next level, no associativity) : Int_scope. Notation "x <= y" := (i2z x <= i2z y)%Z : Int_scope. Notation "x < y" := (i2z x < i2z y)%Z : Int_scope. Notation "x >= y" := (i2z x >= i2z y)%Z : Int_scope. Notation "x > y" := (i2z x > i2z y)%Z : Int_scope. Notation "x <= y <= z" := (x <= y /\ y <= z) : Int_scope. Notation "x <= y < z" := (x <= y /\ y < z) : Int_scope. Notation "x < y < z" := (x < y /\ y < z) : Int_scope. Notation "x < y <= z" := (x < y /\ y <= z) : Int_scope. (** Some decidability fonctions (informative). *) Axiom gt_le_dec : forall x y : t, {x > y} + {x <= y}. Axiom ge_lt_dec : forall x y : t, {x >= y} + {x < y}. Axiom eq_dec : forall x y : t, { x == y } + {~ x==y }. (** Specifications *) (** First, we ask [i2z] to be injective. Said otherwise, our ad-hoc equality [==] and the generic [=] are in fact equivalent. We define [==] nonetheless since the translation to [Z] for using automatic tactic is easier. *) Axiom i2z_eq : forall n p : t, n == p -> n = p. (** Then, we express the specifications of the above parameters using their Z counterparts. *) Axiom i2z_0 : i2z _0 = 0%Z. Axiom i2z_1 : i2z _1 = 1%Z. Axiom i2z_2 : i2z _2 = 2%Z. Axiom i2z_3 : i2z _3 = 3%Z. Axiom i2z_plus : forall n p, i2z (n + p) = (i2z n + i2z p)%Z. Axiom i2z_opp : forall n, i2z (-n) = (-i2z n)%Z. Axiom i2z_minus : forall n p, i2z (n - p) = (i2z n - i2z p)%Z. Axiom i2z_mult : forall n p, i2z (n * p) = (i2z n * i2z p)%Z. Axiom i2z_max : forall n p, i2z (max n p) = Z.max (i2z n) (i2z p). End Int. (** * Facts and tactics using [Int] *) Module MoreInt (Import I:Int). Local Notation int := I.t. (** A magic (but costly) tactic that goes from [int] back to the [Z] friendly world ... *) Hint Rewrite -> i2z_0 i2z_1 i2z_2 i2z_3 i2z_plus i2z_opp i2z_minus i2z_mult i2z_max : i2z. Ltac i2z := match goal with | H : ?a = ?b |- _ => generalize (f_equal i2z H); try autorewrite with i2z; clear H; intro H; i2z | |- ?a = ?b => apply (i2z_eq a b); try autorewrite with i2z; i2z | H : _ |- _ => progress autorewrite with i2z in H; i2z | _ => try autorewrite with i2z end. (** A reflexive version of the [i2z] tactic *) (** this [i2z_refl] is actually weaker than [i2z]. For instance, if a [i2z] is buried deep inside a subterm, [i2z_refl] may miss it. See also the limitation about [Set] or [Type] part below. Anyhow, [i2z_refl] is enough for applying [romega]. *) Ltac i2z_gen := match goal with | |- ?a = ?b => apply (i2z_eq a b); i2z_gen | H : ?a = ?b |- _ => generalize (f_equal i2z H); clear H; i2z_gen | H : eq (A:=Z) ?a ?b |- _ => revert H; i2z_gen | H : Z.lt ?a ?b |- _ => revert H; i2z_gen | H : Z.le ?a ?b |- _ => revert H; i2z_gen | H : Z.gt ?a ?b |- _ => revert H; i2z_gen | H : Z.ge ?a ?b |- _ => revert H; i2z_gen | H : _ -> ?X |- _ => (* A [Set] or [Type] part cannot be dealt with easily using the [ExprP] datatype. So we forget it, leaving a goal that can be weaker than the original. *) match type of X with | Type => clear H; i2z_gen | Prop => revert H; i2z_gen end | H : _ <-> _ |- _ => revert H; i2z_gen | H : _ /\ _ |- _ => revert H; i2z_gen | H : _ \/ _ |- _ => revert H; i2z_gen | H : ~ _ |- _ => revert H; i2z_gen | _ => idtac end. Inductive ExprI : Set := | EI0 : ExprI | EI1 : ExprI | EI2 : ExprI | EI3 : ExprI | EIplus : ExprI -> ExprI -> ExprI | EIopp : ExprI -> ExprI | EIminus : ExprI -> ExprI -> ExprI | EImult : ExprI -> ExprI -> ExprI | EImax : ExprI -> ExprI -> ExprI | EIraw : int -> ExprI. Inductive ExprZ : Set := | EZplus : ExprZ -> ExprZ -> ExprZ | EZopp : ExprZ -> ExprZ | EZminus : ExprZ -> ExprZ -> ExprZ | EZmult : ExprZ -> ExprZ -> ExprZ | EZmax : ExprZ -> ExprZ -> ExprZ | EZofI : ExprI -> ExprZ | EZraw : Z -> ExprZ. Inductive ExprP : Type := | EPeq : ExprZ -> ExprZ -> ExprP | EPlt : ExprZ -> ExprZ -> ExprP | EPle : ExprZ -> ExprZ -> ExprP | EPgt : ExprZ -> ExprZ -> ExprP | EPge : ExprZ -> ExprZ -> ExprP | EPimpl : ExprP -> ExprP -> ExprP | EPequiv : ExprP -> ExprP -> ExprP | EPand : ExprP -> ExprP -> ExprP | EPor : ExprP -> ExprP -> ExprP | EPneg : ExprP -> ExprP | EPraw : Prop -> ExprP. (** [int] to [ExprI] *) Ltac i2ei trm := match constr:trm with | 0 => constr:EI0 | 1 => constr:EI1 | 2 => constr:EI2 | 3 => constr:EI3 | ?x + ?y => let ex := i2ei x with ey := i2ei y in constr:(EIplus ex ey) | ?x - ?y => let ex := i2ei x with ey := i2ei y in constr:(EIminus ex ey) | ?x * ?y => let ex := i2ei x with ey := i2ei y in constr:(EImult ex ey) | max ?x ?y => let ex := i2ei x with ey := i2ei y in constr:(EImax ex ey) | - ?x => let ex := i2ei x in constr:(EIopp ex) | ?x => constr:(EIraw x) end (** [Z] to [ExprZ] *) with z2ez trm := match constr:trm with | (?x + ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZplus ex ey) | (?x - ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZminus ex ey) | (?x * ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmult ex ey) | (Z.max ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EZmax ex ey) | (- ?x)%Z => let ex := z2ez x in constr:(EZopp ex) | i2z ?x => let ex := i2ei x in constr:(EZofI ex) | ?x => constr:(EZraw x) end. (** [Prop] to [ExprP] *) Ltac p2ep trm := match constr:trm with | (?x <-> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPequiv ex ey) | (?x -> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPimpl ex ey) | (?x /\ ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPand ex ey) | (?x \/ ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPor ex ey) | (~ ?x) => let ex := p2ep x in constr:(EPneg ex) | (eq (A:=Z) ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EPeq ex ey) | (?x < ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPlt ex ey) | (?x <= ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPle ex ey) | (?x > ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPgt ex ey) | (?x >= ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPge ex ey) | ?x => constr:(EPraw x) end. (** [ExprI] to [int] *) Fixpoint ei2i (e:ExprI) : int := match e with | EI0 => 0 | EI1 => 1 | EI2 => 2 | EI3 => 3 | EIplus e1 e2 => (ei2i e1)+(ei2i e2) | EIminus e1 e2 => (ei2i e1)-(ei2i e2) | EImult e1 e2 => (ei2i e1)*(ei2i e2) | EImax e1 e2 => max (ei2i e1) (ei2i e2) | EIopp e => -(ei2i e) | EIraw i => i end. (** [ExprZ] to [Z] *) Fixpoint ez2z (e:ExprZ) : Z := match e with | EZplus e1 e2 => ((ez2z e1)+(ez2z e2))%Z | EZminus e1 e2 => ((ez2z e1)-(ez2z e2))%Z | EZmult e1 e2 => ((ez2z e1)*(ez2z e2))%Z | EZmax e1 e2 => Z.max (ez2z e1) (ez2z e2) | EZopp e => (-(ez2z e))%Z | EZofI e => i2z (ei2i e) | EZraw z => z end. (** [ExprP] to [Prop] *) Fixpoint ep2p (e:ExprP) : Prop := match e with | EPeq e1 e2 => (ez2z e1) = (ez2z e2) | EPlt e1 e2 => ((ez2z e1)<(ez2z e2))%Z | EPle e1 e2 => ((ez2z e1)<=(ez2z e2))%Z | EPgt e1 e2 => ((ez2z e1)>(ez2z e2))%Z | EPge e1 e2 => ((ez2z e1)>=(ez2z e2))%Z | EPimpl e1 e2 => (ep2p e1) -> (ep2p e2) | EPequiv e1 e2 => (ep2p e1) <-> (ep2p e2) | EPand e1 e2 => (ep2p e1) /\ (ep2p e2) | EPor e1 e2 => (ep2p e1) \/ (ep2p e2) | EPneg e => ~ (ep2p e) | EPraw p => p end. (** [ExprI] (supposed under a [i2z]) to a simplified [ExprZ] *) Fixpoint norm_ei (e:ExprI) : ExprZ := match e with | EI0 => EZraw (0%Z) | EI1 => EZraw (1%Z) | EI2 => EZraw (2%Z) | EI3 => EZraw (3%Z) | EIplus e1 e2 => EZplus (norm_ei e1) (norm_ei e2) | EIminus e1 e2 => EZminus (norm_ei e1) (norm_ei e2) | EImult e1 e2 => EZmult (norm_ei e1) (norm_ei e2) | EImax e1 e2 => EZmax (norm_ei e1) (norm_ei e2) | EIopp e => EZopp (norm_ei e) | EIraw i => EZofI (EIraw i) end. (** [ExprZ] to a simplified [ExprZ] *) Fixpoint norm_ez (e:ExprZ) : ExprZ := match e with | EZplus e1 e2 => EZplus (norm_ez e1) (norm_ez e2) | EZminus e1 e2 => EZminus (norm_ez e1) (norm_ez e2) | EZmult e1 e2 => EZmult (norm_ez e1) (norm_ez e2) | EZmax e1 e2 => EZmax (norm_ez e1) (norm_ez e2) | EZopp e => EZopp (norm_ez e) | EZofI e => norm_ei e | EZraw z => EZraw z end. (** [ExprP] to a simplified [ExprP] *) Fixpoint norm_ep (e:ExprP) : ExprP := match e with | EPeq e1 e2 => EPeq (norm_ez e1) (norm_ez e2) | EPlt e1 e2 => EPlt (norm_ez e1) (norm_ez e2) | EPle e1 e2 => EPle (norm_ez e1) (norm_ez e2) | EPgt e1 e2 => EPgt (norm_ez e1) (norm_ez e2) | EPge e1 e2 => EPge (norm_ez e1) (norm_ez e2) | EPimpl e1 e2 => EPimpl (norm_ep e1) (norm_ep e2) | EPequiv e1 e2 => EPequiv (norm_ep e1) (norm_ep e2) | EPand e1 e2 => EPand (norm_ep e1) (norm_ep e2) | EPor e1 e2 => EPor (norm_ep e1) (norm_ep e2) | EPneg e => EPneg (norm_ep e) | EPraw p => EPraw p end. Lemma norm_ei_correct : forall e:ExprI, ez2z (norm_ei e) = i2z (ei2i e). Proof. induction e; simpl; intros; i2z; auto; try congruence. Qed. Lemma norm_ez_correct : forall e:ExprZ, ez2z (norm_ez e) = ez2z e. Proof. induction e; simpl; intros; i2z; auto; try congruence; apply norm_ei_correct. Qed. Lemma norm_ep_correct : forall e:ExprP, ep2p (norm_ep e) <-> ep2p e. Proof. induction e; simpl; repeat (rewrite norm_ez_correct); intuition. Qed. Lemma norm_ep_correct2 : forall e:ExprP, ep2p (norm_ep e) -> ep2p e. Proof. intros; destruct (norm_ep_correct e); auto. Qed. Ltac i2z_refl := i2z_gen; match goal with |- ?t => let e := p2ep t in change (ep2p e); apply norm_ep_correct2; simpl end. (* i2z_refl can be replaced below by (simpl in *; i2z). The reflexive version improves compilation of AVL files by about 15% *) End MoreInt. (** * An implementation of [Int] *) (** It's always nice to know that our [Int] interface is realizable :-) *) Module Z_as_Int <: Int. Local Open Scope Z_scope. Definition t := Z. Definition _0 := 0. Definition _1 := 1. Definition _2 := 2. Definition _3 := 3. Definition plus := Z.add. Definition opp := Z.opp. Definition minus := Z.sub. Definition mult := Z.mul. Definition max := Z.max. Definition gt_le_dec := Z_gt_le_dec. Definition ge_lt_dec := Z_ge_lt_dec. Definition eq_dec := Z.eq_dec. Definition i2z : t -> Z := fun n => n. Lemma i2z_eq : forall n p, i2z n=i2z p -> n = p. Proof. auto. Qed. Lemma i2z_0 : i2z _0 = 0. Proof. auto. Qed. Lemma i2z_1 : i2z _1 = 1. Proof. auto. Qed. Lemma i2z_2 : i2z _2 = 2. Proof. auto. Qed. Lemma i2z_3 : i2z _3 = 3. Proof. auto. Qed. Lemma i2z_plus n p : i2z (n + p) = i2z n + i2z p. Proof. auto. Qed. Lemma i2z_opp n : i2z (- n) = - i2z n. Proof. auto. Qed. Lemma i2z_minus n p : i2z (n - p) = i2z n - i2z p. Proof. auto. Qed. Lemma i2z_mult n p : i2z (n * p) = i2z n * i2z p. Proof. auto. Qed. Lemma i2z_max n p : i2z (max n p) = Z.max (i2z n) (i2z p). Proof. auto. Qed. End Z_as_Int. coq-8.4pl4/theories/ZArith/Zwf.v0000644000175000017500000000473612326224777015625 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Acc (Zwf c) a). clear a; simple induction n; intros. (** n= 0 *) case H; intros. case (lt_n_O (f a)); auto. apply Acc_intro; unfold Zwf; intros. assert False; omega || contradiction. (** inductive case *) case H0; clear H0; intro; auto. apply Acc_intro; intros. apply H. unfold Zwf in H1. case (Z.le_gt_cases c y); intro; auto with zarith. left. red in H0. apply lt_le_trans with (f a); auto with arith. unfold f. apply Zabs2Nat.inj_lt; omega. apply (H (S (f a))); auto. Qed. End wf_proof. Hint Resolve Zwf_well_founded: datatypes v62. (** We also define the other family of relations: [x (Zwf_up c) y] iff [y < x <= c] *) Definition Zwf_up (c x y:Z) := y < x <= c. (** and we prove that [(Zwf_up c)] is well founded *) Section wf_proof_up. Variable c : Z. (** The proof of well-foundness is classic: we do the proof by induction on a measure in nat, which is here [|c-x|] *) Let f (z:Z) := Z.abs_nat (c - z). Lemma Zwf_up_well_founded : well_founded (Zwf_up c). Proof. apply well_founded_lt_compat with (f := f). unfold Zwf_up, f. intros. apply Zabs2Nat.inj_lt; try (apply Z.le_0_sub; intuition). now apply Z.sub_lt_mono_l. Qed. End wf_proof_up. Hint Resolve Zwf_up_well_founded: datatypes v62. coq-8.4pl4/theories/ZArith/Zpow_facts.v0000644000175000017500000001757012326224777017176 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 < Z.pow_pos x p. Proof. intros. now apply (Z.pow_pos_nonneg x (Zpos p)). Qed. Notation Zpower_1_r := Z.pow_1_r (compat "8.3"). Notation Zpower_1_l := Z.pow_1_l (compat "8.3"). Notation Zpower_0_l := Z.pow_0_l' (compat "8.3"). Notation Zpower_0_r := Z.pow_0_r (compat "8.3"). Notation Zpower_2 := Z.pow_2_r (compat "8.3"). Notation Zpower_gt_0 := Z.pow_pos_nonneg (compat "8.3"). Notation Zpower_ge_0 := Z.pow_nonneg (compat "8.3"). Notation Zpower_Zabs := Z.abs_pow (compat "8.3"). Notation Zpower_Zsucc := Z.pow_succ_r (compat "8.3"). Notation Zpower_mult := Z.pow_mul_r (compat "8.3"). Notation Zpower_le_monotone2 := Z.pow_le_mono_r (compat "8.3"). Theorem Zpower_le_monotone a b c : 0 < a -> 0 <= b <= c -> a^b <= a^c. Proof. intros. now apply Z.pow_le_mono_r. Qed. Theorem Zpower_lt_monotone a b c : 1 < a -> 0 <= b < c -> a^b < a^c. Proof. intros. apply Z.pow_lt_mono_r; auto with zarith. Qed. Theorem Zpower_gt_1 x y : 1 < x -> 0 < y -> 1 < x^y. Proof. apply Z.pow_gt_1. Qed. Theorem Zmult_power p q r : 0 <= r -> (p*q)^r = p^r * q^r. Proof. intros. apply Z.pow_mul_l. Qed. Hint Resolve Z.pow_nonneg Z.pow_pos_nonneg : zarith. Theorem Zpower_le_monotone3 a b c : 0 <= c -> 0 <= a <= b -> a^c <= b^c. Proof. intros. now apply Z.pow_le_mono_l. Qed. Lemma Zpower_le_monotone_inv a b c : 1 < a -> 0 < b -> a^b <= a^c -> b <= c. Proof. intros Ha Hb H. apply (Z.pow_le_mono_r_iff a); trivial. apply Z.lt_le_incl; apply (Z.pow_gt_1 a); trivial. apply Z.lt_le_trans with (a^b); trivial. now apply Z.pow_gt_1. Qed. Notation Zpower_nat_Zpower := Zpower_nat_Zpower (only parsing). Theorem Zpower2_lt_lin n : 0 <= n -> n < 2^n. Proof. intros. now apply Z.pow_gt_lin_r. Qed. Theorem Zpower2_le_lin n : 0 <= n -> n <= 2^n. Proof. intros. apply Z.lt_le_incl. now apply Z.pow_gt_lin_r. Qed. Lemma Zpower2_Psize n p : Zpos p < 2^(Z.of_nat n) <-> (Pos.size_nat p <= n)%nat. Proof. revert p; induction n. destruct p; now split. assert (Hn := Nat2Z.is_nonneg n). destruct p; simpl Pos.size_nat. - specialize IHn with p. rewrite Pos2Z.inj_xI, Nat2Z.inj_succ, Z.pow_succ_r; omega. - specialize IHn with p. rewrite Pos2Z.inj_xO, Nat2Z.inj_succ, Z.pow_succ_r; omega. - split; auto with zarith. intros _. apply Z.pow_gt_1. easy. now rewrite Nat2Z.inj_succ, Z.lt_succ_r. Qed. (** * Z.pow and modulo *) Theorem Zpower_mod p q n : 0 < n -> (p^q) mod n = ((p mod n)^q) mod n. Proof. intros Hn; destruct (Z.le_gt_cases 0 q) as [H1|H1]. - pattern q; apply natlike_ind; trivial. clear q H1. intros q Hq Rec. rewrite !Z.pow_succ_r; trivial. rewrite Z.mul_mod_idemp_l; auto with zarith. rewrite Z.mul_mod, Rec, <- Z.mul_mod; auto with zarith. - rewrite !Z.pow_neg_r; auto with zarith. Qed. (** A direct way to compute Z.pow modulo **) Fixpoint Zpow_mod_pos (a: Z)(m: positive)(n : Z) : Z := match m with | xH => a mod n | xO m' => let z := Zpow_mod_pos a m' n in match z with | 0 => 0 | _ => (z * z) mod n end | xI m' => let z := Zpow_mod_pos a m' n in match z with | 0 => 0 | _ => (z * z * a) mod n end end. Definition Zpow_mod a m n := match m with | 0 => 1 mod n | Zpos p => Zpow_mod_pos a p n | Zneg p => 0 end. Theorem Zpow_mod_pos_correct a m n : n <> 0 -> Zpow_mod_pos a m n = (Z.pow_pos a m) mod n. Proof. intros Hn. induction m. - rewrite Pos.xI_succ_xO at 2. rewrite <- Pos.add_1_r, <- Pos.add_diag. rewrite 2 Zpower_pos_is_exp, Zpower_pos_1_r. rewrite Z.mul_mod, (Z.mul_mod (Z.pow_pos a m)) by trivial. rewrite <- IHm, <- Z.mul_mod by trivial. simpl. now destruct (Zpow_mod_pos a m n). - rewrite <- Pos.add_diag at 2. rewrite Zpower_pos_is_exp. rewrite Z.mul_mod by trivial. rewrite <- IHm. simpl. now destruct (Zpow_mod_pos a m n). - now rewrite Zpower_pos_1_r. Qed. Theorem Zpow_mod_correct a m n : n <> 0 -> Zpow_mod a m n = (a ^ m) mod n. Proof. intros Hn. destruct m; simpl. - trivial. - apply Zpow_mod_pos_correct; auto with zarith. - rewrite Z.mod_0_l; auto with zarith. Qed. (* Complements about power and number theory. *) Lemma Zpower_divide p q : 0 < q -> (p | p ^ q). Proof. exists (p^(q - 1)). rewrite Z.mul_comm, <- Z.pow_succ_r; f_equal; auto with zarith. Qed. Theorem rel_prime_Zpower_r i p q : 0 <= i -> rel_prime p q -> rel_prime p (q^i). Proof. intros Hi Hpq; pattern i; apply natlike_ind; auto with zarith. simpl. apply rel_prime_sym, rel_prime_1. clear i Hi. intros i Hi Rec; rewrite Z.pow_succ_r; auto. apply rel_prime_mult; auto. Qed. Theorem rel_prime_Zpower i j p q : 0 <= i -> 0 <= j -> rel_prime p q -> rel_prime (p^i) (q^j). Proof. intros Hi Hj H. apply rel_prime_Zpower_r; trivial. apply rel_prime_sym. apply rel_prime_Zpower_r; trivial. now apply rel_prime_sym. Qed. Theorem prime_power_prime p q n : 0 <= n -> prime p -> prime q -> (p | q^n) -> p = q. Proof. intros Hn Hp Hq; pattern n; apply natlike_ind; auto; clear n Hn. - simpl; intros. assert (2<=p) by (apply prime_ge_2; auto). assert (p<=1) by (apply Z.divide_pos_le; auto with zarith). omega. - intros n Hn Rec. rewrite Z.pow_succ_r by trivial. intros. assert (2<=p) by (apply prime_ge_2; auto). assert (2<=q) by (apply prime_ge_2; auto). destruct prime_mult with (2 := H); auto. apply prime_div_prime; auto. Qed. Theorem Zdivide_power_2 x p n : 0 <= n -> 0 <= x -> prime p -> (x | p^n) -> exists m, x = p^m. Proof. intros Hn Hx; revert p n Hn. generalize Hx. pattern x; apply Z_lt_induction; auto. clear x Hx; intros x IH Hx p n Hn Hp H. Z.le_elim Hx; subst. apply Z.le_succ_l in Hx; simpl in Hx. Z.le_elim Hx; subst. (* x > 1 *) case (prime_dec x); intros Hpr. exists 1; rewrite Z.pow_1_r; apply prime_power_prime with n; auto. case not_prime_divide with (2 := Hpr); auto. intros p1 ((Hp1, Hpq1),(q1,->)). assert (Hq1 : 0 < q1) by (apply Z.mul_lt_mono_pos_r with p1; auto with zarith). destruct (IH p1) with p n as (r1,Hr1); auto with zarith. transitivity (q1 * p1); trivial. exists q1; auto with zarith. destruct (IH q1) with p n as (r2,Hr2); auto with zarith. split; auto with zarith. rewrite <- (Z.mul_1_r q1) at 1. apply Z.mul_lt_mono_pos_l; auto with zarith. transitivity (q1 * p1); trivial. exists p1; auto with zarith. exists (r2 + r1); subst. symmetry. apply Z.pow_add_r. generalize Hq1; case r2; now auto with zarith. generalize Hp1; case r1; now auto with zarith. (* x = 1 *) exists 0; rewrite Z.pow_0_r; auto. (* x = 0 *) exists n; destruct H; rewrite Z.mul_0_r in H; auto. Qed. (** * Z.square: a direct definition of [z^2] *) Notation Psquare := Pos.square (compat "8.3"). Notation Zsquare := Z.square (compat "8.3"). Notation Psquare_correct := Pos.square_spec (compat "8.3"). Notation Zsquare_correct := Z.square_spec (compat "8.3"). coq-8.4pl4/theories/ZArith/Zorder.v0000644000175000017500000003555712326224777016331 0ustar stephsteph(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* m}. Proof. unfold ">", "<". generalize (Z.compare_eq n m). destruct (n ?= m); [ left; right | left; left | right]; auto. Defined. Theorem Ztrichotomy n m : n < m \/ n = m \/ n > m. Proof. Z.swap_greater. apply Z.lt_trichotomy. Qed. (**********************************************************************) (** * Decidability of equality and order on Z *) Notation dec_eq := Z.eq_decidable (compat "8.3"). Notation dec_Zle := Z.le_decidable (compat "8.3"). Notation dec_Zlt := Z.lt_decidable (compat "8.3"). Theorem dec_Zne n m : decidable (Zne n m). Proof. destruct (Z.eq_decidable n m); [right|left]; subst; auto. Qed. Theorem dec_Zgt n m : decidable (n > m). Proof. destruct (Z.lt_decidable m n); [left|right]; Z.swap_greater; auto. Qed. Theorem dec_Zge n m : decidable (n >= m). Proof. destruct (Z.le_decidable m n); [left|right]; Z.swap_greater; auto. Qed. Theorem not_Zeq n m : n <> m -> n < m \/ m < n. Proof. apply Z.lt_gt_cases. Qed. (** * Relating strict and large orders *) Notation Zgt_lt := Z.gt_lt (compat "8.3"). Notation Zlt_gt := Z.lt_gt (compat "8.3"). Notation Zge_le := Z.ge_le (compat "8.3"). Notation Zle_ge := Z.le_ge (compat "8.3"). Notation Zgt_iff_lt := Z.gt_lt_iff (compat "8.3"). Notation Zge_iff_le := Z.ge_le_iff (compat "8.3"). Lemma Zle_not_lt n m : n <= m -> ~ m < n. Proof. apply Z.le_ngt. Qed. Lemma Zlt_not_le n m : n < m -> ~ m <= n. Proof. apply Z.lt_nge. Qed. Lemma Zle_not_gt n m : n <= m -> ~ n > m. Proof. trivial. Qed. Lemma Zgt_not_le n m : n > m -> ~ n <= m. Proof. Z.swap_greater. apply Z.lt_nge. Qed. Lemma Znot_ge_lt n m : ~ n >= m -> n < m. Proof. Z.swap_greater. apply Z.nle_gt. Qed. Lemma Znot_lt_ge n m : ~ n < m -> n >= m. Proof. trivial. Qed. Lemma Znot_gt_le n m: ~ n > m -> n <= m. Proof. trivial. Qed. Lemma Znot_le_gt n m : ~ n <= m -> n > m. Proof. Z.swap_greater. apply Z.nle_gt. Qed. Lemma not_Zne n m : ~ Zne n m -> n = m. Proof. intros H. destruct (Z.eq_decidable n m); [assumption|now elim H]. Qed. (** * Equivalence and order properties *) (** Reflexivity *) Notation Zle_refl := Z.le_refl (compat "8.3"). Notation Zeq_le := Z.eq_le_incl (compat "8.3"). Hint Resolve Z.le_refl: zarith. (** Antisymmetry *) Notation Zle_antisym := Z.le_antisymm (compat "8.3"). (** Asymmetry *) Notation Zlt_asym := Z.lt_asymm (compat "8.3"). Lemma Zgt_asym n m : n > m -> ~ m > n. Proof. Z.swap_greater. apply Z.lt_asymm. Qed. (** Irreflexivity *) Notation Zlt_irrefl := Z.lt_irrefl (compat "8.3"). Notation Zlt_not_eq := Z.lt_neq (compat "8.3"). Lemma Zgt_irrefl n : ~ n > n. Proof. Z.swap_greater. apply Z.lt_irrefl. Qed. (** Large = strict or equal *) Notation Zlt_le_weak := Z.lt_le_incl (compat "8.3"). Notation Zle_lt_or_eq_iff := Z.lt_eq_cases (compat "8.3"). Lemma Zle_lt_or_eq n m : n <= m -> n < m \/ n = m. Proof. apply Z.lt_eq_cases. Qed. (** Dichotomy *) Notation Zle_or_lt := Z.le_gt_cases (compat "8.3"). (** Transitivity of strict orders *) Notation Zlt_trans := Z.lt_trans (compat "8.3"). Lemma Zgt_trans n m p : n > m -> m > p -> n > p. Proof. Z.swap_greater. intros; now transitivity m. Qed. (** Mixed transitivity *) Notation Zlt_le_trans := Z.lt_le_trans (compat "8.3"). Notation Zle_lt_trans := Z.le_lt_trans (compat "8.3"). Lemma Zle_gt_trans n m p : m <= n -> m > p -> n > p. Proof. Z.swap_greater. Z.order. Qed. Lemma Zgt_le_trans n m p : n > m -> p <= m -> n > p. Proof. Z.swap_greater. Z.order. Qed. (** Transitivity of large orders *) Notation Zle_trans := Z.le_trans (compat "8.3"). Lemma Zge_trans n m p : n >= m -> m >= p -> n >= p. Proof. Z.swap_greater. Z.order. Qed. Hint Resolve Z.le_trans: zarith. (** * Compatibility of order and operations on Z *) (** ** Successor *) (** Compatibility of successor wrt to order *) Lemma Zsucc_le_compat n m : m <= n -> Z.succ m <= Z.succ n. Proof. apply Z.succ_le_mono. Qed. Lemma Zsucc_lt_compat n m : n < m -> Z.succ n < Z.succ m. Proof. apply Z.succ_lt_mono. Qed. Lemma Zsucc_gt_compat n m : m > n -> Z.succ m > Z.succ n. Proof. Z.swap_greater. apply Z.succ_lt_mono. Qed. Hint Resolve Zsucc_le_compat: zarith. (** Simplification of successor wrt to order *) Lemma Zsucc_gt_reg n m : Z.succ m > Z.succ n -> m > n. Proof. Z.swap_greater. apply Z.succ_lt_mono. Qed. Lemma Zsucc_le_reg n m : Z.succ m <= Z.succ n -> m <= n. Proof. apply Z.succ_le_mono. Qed. Lemma Zsucc_lt_reg n m : Z.succ n < Z.succ m -> n < m. Proof. apply Z.succ_lt_mono. Qed. (** Special base instances of order *) Notation Zlt_succ := Z.lt_succ_diag_r (compat "8.3"). Notation Zlt_pred := Z.lt_pred_l (compat "8.3"). Lemma Zgt_succ n : Z.succ n > n. Proof. Z.swap_greater. apply Z.lt_succ_diag_r. Qed. Lemma Znot_le_succ n : ~ Z.succ n <= n. Proof. apply Z.lt_nge, Z.lt_succ_diag_r. Qed. (** Relating strict and large order using successor or predecessor *) Notation Zlt_succ_r := Z.lt_succ_r (compat "8.3"). Notation Zle_succ_l := Z.le_succ_l (compat "8.3"). Lemma Zgt_le_succ n m : m > n -> Z.succ n <= m. Proof. Z.swap_greater. apply Z.le_succ_l. Qed. Lemma Zle_gt_succ n m : n <= m -> Z.succ m > n. Proof. Z.swap_greater. apply Z.lt_succ_r. Qed. Lemma Zle_lt_succ n m : n <= m -> n < Z.succ m. Proof. apply Z.lt_succ_r. Qed. Lemma Zlt_le_succ n m : n < m -> Z.succ n <= m. Proof. apply Z.le_succ_l. Qed. Lemma Zgt_succ_le n m : Z.succ m > n -> n <= m. Proof. Z.swap_greater. apply Z.lt_succ_r. Qed. Lemma Zlt_succ_le n m : n < Z.succ m -> n <= m. Proof. apply Z.lt_succ_r. Qed. Lemma Zle_succ_gt n m : Z.succ n <= m -> m > n. Proof. Z.swap_greater. apply Z.le_succ_l. Qed. (** Weakening order *) Notation Zle_succ := Z.le_succ_diag_r (compat "8.3"). Notation Zle_pred := Z.le_pred_l (compat "8.3"). Notation Zlt_lt_succ := Z.lt_lt_succ_r (compat "8.3"). Notation Zle_le_succ := Z.le_le_succ_r (compat "8.3"). Lemma Zle_succ_le n m : Z.succ n <= m -> n <= m. Proof. intros. now apply Z.lt_le_incl, Z.le_succ_l. Qed. Hint Resolve Z.le_succ_diag_r: zarith. Hint Resolve Z.le_le_succ_r: zarith. (** Relating order wrt successor and order wrt predecessor *) Lemma Zgt_succ_pred n m : m > Z.succ n -> Z.pred m > n. Proof. Z.swap_greater. apply Z.lt_succ_lt_pred. Qed. Lemma Zlt_succ_pred n m : Z.succ n < m -> n < Z.pred m. Proof. apply Z.lt_succ_lt_pred. Qed. (** Relating strict order and large order on positive *) Lemma Zlt_0_le_0_pred n : 0 < n -> 0 <= Z.pred n. Proof. apply Z.lt_le_pred. Qed. Lemma Zgt_0_le_0_pred n : n > 0 -> 0 <= Z.pred n. Proof. Z.swap_greater. apply Z.lt_le_pred. Qed. (** Special cases of ordered integers *) Notation Zlt_0_1 := Z.lt_0_1 (compat "8.3"). Notation Zle_0_1 := Z.le_0_1 (compat "8.3"). Lemma Zle_neg_pos : forall p q:positive, Zneg p <= Zpos q. Proof. easy. Qed. Lemma Zgt_pos_0 : forall p:positive, Zpos p > 0. Proof. easy. Qed. (* weaker but useful (in [Z.pow] for instance) *) Lemma Zle_0_pos : forall p:positive, 0 <= Zpos p. Proof. easy. Qed. Lemma Zlt_neg_0 : forall p:positive, Zneg p < 0. Proof. easy. Qed. Lemma Zle_0_nat : forall n:nat, 0 <= Z.of_nat n. Proof. induction n; simpl; intros. apply Z.le_refl. easy. Qed. Hint Immediate Z.eq_le_incl: zarith. (** Derived lemma *) Lemma Zgt_succ_gt_or_eq n m : Z.succ n > m -> n > m \/ m = n. Proof. Z.swap_greater. intros. now apply Z.lt_eq_cases, Z.lt_succ_r. Qed. (** ** Addition *) (** Compatibility of addition wrt to order *) Notation Zplus_lt_le_compat := Z.add_lt_le_mono (compat "8.3"). Notation Zplus_le_lt_compat := Z.add_le_lt_mono (compat "8.3"). Notation Zplus_le_compat := Z.add_le_mono (compat "8.3"). Notation Zplus_lt_compat := Z.add_lt_mono (compat "8.3"). Lemma Zplus_gt_compat_l n m p : n > m -> p + n > p + m. Proof. Z.swap_greater. apply Z.add_lt_mono_l. Qed. Lemma Zplus_gt_compat_r n m p : n > m -> n + p > m + p. Proof. Z.swap_greater. apply Z.add_lt_mono_r. Qed. Lemma Zplus_le_compat_l n m p : n <= m -> p + n <= p + m. Proof. apply Z.add_le_mono_l. Qed. Lemma Zplus_le_compat_r n m p : n <= m -> n + p <= m + p. Proof. apply Z.add_le_mono_r. Qed. Lemma Zplus_lt_compat_l n m p : n < m -> p + n < p + m. Proof. apply Z.add_lt_mono_l. Qed. Lemma Zplus_lt_compat_r n m p : n < m -> n + p < m + p. Proof. apply Z.add_lt_mono_r. Qed. (** Compatibility of addition wrt to being positive *) Notation Zplus_le_0_compat := Z.add_nonneg_nonneg (compat "8.3"). (** Simplification of addition wrt to order *) Lemma Zplus_le_reg_l n m p : p + n <= p + m -> n <= m. Proof. apply Z.add_le_mono_l. Qed. Lemma Zplus_le_reg_r n m p : n + p <= m + p -> n <= m. Proof. apply Z.add_le_mono_r. Qed. Lemma Zplus_lt_reg_l n m p : p + n < p + m -> n < m. Proof. apply Z.add_lt_mono_l. Qed. Lemma Zplus_lt_reg_r n m p : n + p < m + p -> n < m. Proof. apply Z.add_lt_mono_r. Qed. Lemma Zplus_gt_reg_l n m p : p + n > p + m -> n > m. Proof. Z.swap_greater. apply Z.add_lt_mono_l. Qed. Lemma Zplus_gt_reg_r n m p : n + p > m + p -> n > m. Proof. Z.swap_greater. apply Z.add_lt_mono_r. Qed. (** ** Multiplication *) (** Compatibility of multiplication by a positive wrt to order *) Lemma Zmult_le_compat_r n m p : n <= m -> 0 <= p -> n * p <= m * p. Proof. intros. now apply Z.mul_le_mono_nonneg_r. Qed. Lemma Zmult_le_compat_l n m p : n <= m -> 0 <= p -> p * n <= p * m. Proof. intros. now apply Z.mul_le_mono_nonneg_l. Qed. Lemma Zmult_lt_compat_r n m p : 0 < p -> n < m -> n * p < m * p. Proof. apply Z.mul_lt_mono_pos_r. Qed. Lemma Zmult_gt_compat_r n m p : p > 0 -> n > m -> n * p > m * p. Proof. Z.swap_greater. apply Z.mul_lt_mono_pos_r. Qed. Lemma Zmult_gt_0_lt_compat_r n m p : p > 0 -> n < m -> n * p < m * p. Proof. Z.swap_greater. apply Z.mul_lt_mono_pos_r. Qed. Lemma Zmult_gt_0_le_compat_r n m p : p > 0 -> n <= m -> n * p <= m * p. Proof. Z.swap_greater. apply Z.mul_le_mono_pos_r. Qed. Lemma Zmult_lt_0_le_compat_r n m p : 0 < p -> n <= m -> n * p <= m * p. Proof. apply Z.mul_le_mono_pos_r. Qed. Lemma Zmult_gt_0_lt_compat_l n m p : p > 0 -> n < m -> p * n < p * m. Proof. Z.swap_greater. apply Z.mul_lt_mono_pos_l. Qed. Lemma Zmult_lt_compat_l n m p : 0 < p -> n < m -> p * n < p * m. Proof. apply Z.mul_lt_mono_pos_l. Qed. Lemma Zmult_gt_compat_l n m p : p > 0 -> n > m -> p * n > p * m. Proof. Z.swap_greater. apply Z.mul_lt_mono_pos_l. Qed. Lemma Zmult_ge_compat_r n m p : n >= m -> p >= 0 -> n * p >= m * p. Proof. Z.swap_greater. intros. now apply Z.mul_le_mono_nonneg_r. Qed. Lemma Zmult_ge_compat_l n m p : n >= m -> p >= 0 -> p * n >= p * m. Proof. Z.swap_greater. intros. now apply Z.mul_le_mono_nonneg_l. Qed. Lemma Zmult_ge_compat n m p q : n >= p -> m >= q -> p >= 0 -> q >= 0 -> n * m >= p * q. Proof. Z.swap_greater. intros. now apply Z.mul_le_mono_nonneg. Qed. Lemma Zmult_le_compat n m p q : n <= p -> m <= q -> 0 <= n -> 0 <= m -> n * m <= p * q. Proof. intros. now apply Z.mul_le_mono_nonneg. Qed. (** Simplification of multiplication by a positive wrt to being positive *) Lemma Zmult_gt_0_lt_reg_r n m p : p > 0 -> n * p < m * p -> n < m. Proof. Z.swap_greater. apply Z.mul_lt_mono_pos_r. Qed. Lemma Zmult_lt_reg_r n m p : 0 < p -> n * p < m * p -> n < m. Proof. apply Z.mul_lt_mono_pos_r. Qed. Lemma Zmult_le_reg_r n m p : p > 0 -> n * p <= m * p -> n <= m. Proof. Z.swap_greater. apply Z.mul_le_mono_pos_r. Qed. Lemma Zmult_lt_0_le_reg_r n m p : 0 < p -> n * p <= m * p -> n <= m. Proof. apply Z.mul_le_mono_pos_r. Qed. Lemma Zmult_ge_reg_r n m p : p > 0 -> n * p >= m * p -> n >= m. Proof. Z.swap_greater. apply Z.mul_le_mono_pos_r. Qed. Lemma Zmult_gt_reg_r n m p : p > 0 -> n * p > m * p -> n > m. Proof. Z.swap_greater. apply Z.mul_lt_mono_pos_r. Qed. Lemma Zmult_lt_compat n m p q : 0 <= n < p -> 0 <= m < q -> n * m < p * q. Proof. intros (Hn,Hnp) (Hm,Hmq). now apply Z.mul_lt_mono_nonneg. Qed. Lemma Zmult_lt_compat2 n m p q : 0 < n <= p -> 0 < m < q -> n * m < p * q. Proof. intros (Hn, Hnp) (Hm,Hmq). apply Z.le_lt_trans with (p * m). apply Z.mul_le_mono_pos_r; trivial. apply Z.mul_lt_mono_pos_l; Z.order. Qed. (** Compatibility of multiplication by a positive wrt to being positive *) Notation Zmult_le_0_compat := Z.mul_nonneg_nonneg (compat "8.3"). Notation Zmult_lt_0_compat := Z.mul_pos_pos (compat "8.3"). Notation Zmult_lt_O_compat := Z.mul_pos_pos (compat "8.3"). Lemma Zmult_gt_0_compat n m : n > 0 -> m > 0 -> n * m > 0. Proof. Z.swap_greater. apply Z.mul_pos_pos. Qed. (* To remove someday ... *) Lemma Zmult_gt_0_le_0_compat n m : n > 0 -> 0 <= m -> 0 <= m * n. Proof. Z.swap_greater. intros. apply Z.mul_nonneg_nonneg. trivial. now apply Z.lt_le_incl. Qed. (** Simplification of multiplication by a positive wrt to being positive *) Lemma Zmult_le_0_reg_r n m : n > 0 -> 0 <= m * n -> 0 <= m. Proof. Z.swap_greater. apply Z.mul_nonneg_cancel_r. Qed. Lemma Zmult_lt_0_reg_r n m : 0 < n -> 0 < m * n -> 0 < m. Proof. apply Z.mul_pos_cancel_r. Qed. Lemma Zmult_gt_0_lt_0_reg_r n m : n > 0 -> 0 < m * n -> 0 < m. Proof. Z.swap_greater. apply Z.mul_pos_cancel_r. Qed. Lemma Zmult_gt_0_reg_l n m : n > 0 -> n * m > 0 -> m > 0. Proof. Z.swap_greater. apply Z.mul_pos_cancel_l. Qed. (** ** Square *) (** Simplification of square wrt order *) Lemma Zlt_square_simpl n m : 0 <= n -> m * m < n * n -> m < n. Proof. apply Z.square_lt_simpl_nonneg. Qed. Lemma Zgt_square_simpl n m : n >= 0 -> n * n > m * m -> n > m. Proof. Z.swap_greater. apply Z.square_lt_simpl_nonneg. Qed. (** * Equivalence between inequalities *) Notation Zle_plus_swap := Z.le_add_le_sub_r (compat "8.3"). Notation Zlt_plus_swap := Z.lt_add_lt_sub_r (compat "8.3"). Notation Zlt_minus_simpl_swap := Z.lt_sub_pos (compat "8.3"). Lemma Zeq_plus_swap n m p : n + p = m <-> n = m - p. Proof. apply Z.add_move_r. Qed. Lemma Zlt_0_minus_lt n m : 0 < n - m -> m < n. Proof. apply Z.lt_0_sub. Qed. Lemma Zle_0_minus_le n m : 0 <= n - m -> m <= n. Proof. apply Z.le_0_sub. Qed. Lemma Zle_minus_le_0 n m : m <= n -> 0 <= n - m. Proof. apply Z.le_0_sub. Qed. (** For compatibility *) Notation Zlt_O_minus_lt := Zlt_0_minus_lt (only parsing). coq-8.4pl4/theories/ZArith/Zgcd_alt.v0000644000175000017500000002174112326224777016601 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Z -> Z := fun a b => match n with | O => 1 (* arbitrary, since n should be big enough *) | S n => match a with | Z0 => Z.abs b | Zpos _ => Zgcdn n (Z.modulo b a) a | Zneg a => Zgcdn n (Z.modulo b (Zpos a)) (Zpos a) end end. Definition Zgcd_bound (a:Z) := match a with | Z0 => S O | Zpos p => let n := Pos.size_nat p in (n+n)%nat | Zneg p => let n := Pos.size_nat p in (n+n)%nat end. Definition Zgcd_alt a b := Zgcdn (Zgcd_bound a) a b. (** A first obvious fact : [Z.gcd a b] is positive. *) Lemma Zgcdn_pos : forall n a b, 0 <= Zgcdn n a b. Proof. induction n. simpl; auto with zarith. destruct a; simpl; intros; auto with zarith; auto. Qed. Lemma Zgcd_alt_pos : forall a b, 0 <= Zgcd_alt a b. Proof. intros; unfold Z.gcd; apply Zgcdn_pos; auto. Qed. (** We now prove that Z.gcd is indeed a gcd. *) (** 1) We prove a weaker & easier bound. *) Lemma Zgcdn_linear_bound : forall n a b, Z.abs a < Z.of_nat n -> Zis_gcd a b (Zgcdn n a b). Proof. induction n. simpl; intros. exfalso; generalize (Z.abs_nonneg a); omega. destruct a; intros; simpl; [ generalize (Zis_gcd_0_abs b); intuition | | ]; unfold Z.modulo; generalize (Z_div_mod b (Zpos p) (eq_refl Gt)); destruct (Z.div_eucl b (Zpos p)) as (q,r); intros (H0,H1); rewrite Nat2Z.inj_succ in H; simpl Z.abs in H; (assert (H2: Z.abs r < Z.of_nat n) by (rewrite Z.abs_eq; auto with zarith)); assert (IH:=IHn r (Zpos p) H2); clear IHn; simpl in IH |- *; rewrite H0. apply Zis_gcd_for_euclid2; auto. apply Zis_gcd_minus; apply Zis_gcd_sym. apply Zis_gcd_for_euclid2; auto. Qed. (** 2) For Euclid's algorithm, the worst-case situation corresponds to Fibonacci numbers. Let's define them: *) Fixpoint fibonacci (n:nat) : Z := match n with | O => 1 | S O => 1 | S (S n as p) => fibonacci p + fibonacci n end. Lemma fibonacci_pos : forall n, 0 <= fibonacci n. Proof. cut (forall N n, (n 0<=fibonacci n). eauto. induction N. inversion 1. intros. destruct n. simpl; auto with zarith. destruct n. simpl; auto with zarith. change (0 <= fibonacci (S n) + fibonacci n). generalize (IHN n) (IHN (S n)); omega. Qed. Lemma fibonacci_incr : forall n m, (n<=m)%nat -> fibonacci n <= fibonacci m. Proof. induction 1. auto with zarith. apply Z.le_trans with (fibonacci m); auto. clear. destruct m. simpl; auto with zarith. change (fibonacci (S m) <= fibonacci (S m)+fibonacci m). generalize (fibonacci_pos m); omega. Qed. (** 3) We prove that fibonacci numbers are indeed worst-case: for a given number [n], if we reach a conclusion about [gcd(a,b)] in exactly [n+1] loops, then [fibonacci (n+1)<=a /\ fibonacci(n+2)<=b] *) Lemma Zgcdn_worst_is_fibonacci : forall n a b, 0 < a < b -> Zis_gcd a b (Zgcdn (S n) a b) -> Zgcdn n a b <> Zgcdn (S n) a b -> fibonacci (S n) <= a /\ fibonacci (S (S n)) <= b. Proof. induction n. intros [|a|a]; intros; simpl; omega. intros [|a|a] b (Ha,Ha'); [simpl; omega | | easy ]. remember (S n) as m. rewrite Heqm at 2. simpl Zgcdn. unfold Z.modulo; generalize (Z_div_mod b (Zpos a) eq_refl). destruct (Z.div_eucl b (Zpos a)) as (q,r). intros (EQ,(Hr,Hr')). Z.le_elim Hr. - (* r > 0 *) replace (fibonacci (S (S m))) with (fibonacci (S m) + fibonacci m) by auto. intros. destruct (IHn r (Zpos a) (conj Hr Hr')); auto. + assert (EQ' : r = Zpos a * (-q) + b) by (rewrite EQ; ring). rewrite EQ' at 1. apply Zis_gcd_sym. apply Zis_gcd_for_euclid2; auto. apply Zis_gcd_sym; auto. + split; auto. rewrite EQ. apply Z.add_le_mono; auto. apply Z.le_trans with (Zpos a * 1); auto. now rewrite Z.mul_1_r. apply Z.mul_le_mono_nonneg_l; auto with zarith. change 1 with (Z.succ 0). apply Z.le_succ_l. destruct q; auto with zarith. assert (Zpos a * Zneg p < 0) by now compute. omega. - (* r = 0 *) clear IHn EQ Hr'; intros _. subst r; simpl; rewrite Heqm. destruct n. + simpl. omega. + now destruct 1. Qed. (** 3b) We reformulate the previous result in a more positive way. *) Lemma Zgcdn_ok_before_fibonacci : forall n a b, 0 < a < b -> a < fibonacci (S n) -> Zis_gcd a b (Zgcdn n a b). Proof. destruct a; [ destruct 1; exfalso; omega | | destruct 1; discriminate]. cut (forall k n b, k = (S (Pos.to_nat p) - n)%nat -> 0 < Zpos p < b -> Zpos p < fibonacci (S n) -> Zis_gcd (Zpos p) b (Zgcdn n (Zpos p) b)). destruct 2; eauto. clear n; induction k. intros. assert (Pos.to_nat p < n)%nat by omega. apply Zgcdn_linear_bound. simpl. generalize (inj_le _ _ H2). rewrite Nat2Z.inj_succ. rewrite positive_nat_Z; auto. omega. intros. generalize (Zgcdn_worst_is_fibonacci n (Zpos p) b H0); intros. assert (Zis_gcd (Zpos p) b (Zgcdn (S n) (Zpos p) b)). apply IHk; auto. omega. replace (fibonacci (S (S n))) with (fibonacci (S n)+fibonacci n) by auto. generalize (fibonacci_pos n); omega. replace (Zgcdn n (Zpos p) b) with (Zgcdn (S n) (Zpos p) b); auto. generalize (H2 H3); clear H2 H3; omega. Qed. (** 4) The proposed bound leads to a fibonacci number that is big enough. *) Lemma Zgcd_bound_fibonacci : forall a, 0 < a -> a < fibonacci (Zgcd_bound a). Proof. destruct a; [omega| | intro H; discriminate]. intros _. induction p; [ | | compute; auto ]; simpl Zgcd_bound in *; rewrite plus_comm; simpl plus; set (n:= (Pos.size_nat p+Pos.size_nat p)%nat) in *; simpl; assert (n <> O) by (unfold n; destruct p; simpl; auto). destruct n as [ |m]; [elim H; auto| ]. generalize (fibonacci_pos m); rewrite Pos2Z.inj_xI; omega. destruct n as [ |m]; [elim H; auto| ]. generalize (fibonacci_pos m); rewrite Pos2Z.inj_xO; omega. Qed. (* 5) the end: we glue everything together and take care of situations not corresponding to [0 Zis_gcd (Zpos a) b (Zgcdn n (Zpos a) b). Proof. intros. generalize (Zgcd_bound_fibonacci (Zpos a)). simpl Zgcd_bound in *. remember (Pos.size_nat a+Pos.size_nat a)%nat as m. assert (1 < m)%nat. { rewrite Heqm; destruct a; simpl; rewrite 1?plus_comm; auto with arith. } destruct m as [ |m]; [inversion H0; auto| ]. destruct n as [ |n]; [inversion H; auto| ]. simpl Zgcdn. unfold Z.modulo. generalize (Z_div_mod b (Zpos a) (eq_refl Gt)). destruct (Z.div_eucl b (Zpos a)) as (q,r). intros (->,(H1,H2)) H3. apply Zis_gcd_for_euclid2. Z.le_elim H1. + apply Zgcdn_ok_before_fibonacci; auto. apply Z.lt_le_trans with (fibonacci (S m)); [ omega | apply fibonacci_incr; auto]. + subst r; simpl. destruct m as [ |m]; [exfalso; omega| ]. destruct n as [ |n]; [exfalso; omega| ]. simpl; apply Zis_gcd_sym; apply Zis_gcd_0. Qed. Lemma Zgcdn_is_gcd n a b : (Zgcd_bound a <= n)%nat -> Zis_gcd a b (Zgcdn n a b). Proof. destruct a. - simpl; intros. destruct n; [exfalso; omega | ]. simpl; generalize (Zis_gcd_0_abs b); intuition. - apply Zgcdn_is_gcd_pos. - rewrite <- Zgcd_bound_opp, <- Zgcdn_opp. intros. apply Zis_gcd_minus, Zis_gcd_sym. simpl Z.opp. now apply Zgcdn_is_gcd_pos. Qed. Lemma Zgcd_is_gcd : forall a b, Zis_gcd a b (Zgcd_alt a b). Proof. unfold Zgcd_alt; intros; apply Zgcdn_is_gcd; auto. Qed. coq-8.4pl4/theories/ZArith/Zeuclid.v0000644000175000017500000000330612326224777016446 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* eq==>eq) modulo. Proof. congruence. Qed. Instance div_wd : Proper (eq==>eq==>eq) div. Proof. congruence. Qed. Theorem div_mod a b : b<>0 -> a = b*(div a b) + modulo a b. Proof. intros Hb. unfold div, modulo. rewrite Z.mul_assoc. rewrite Z.sgn_abs. apply Z.div_mod. now destruct b. Qed. Lemma mod_always_pos a b : b<>0 -> 0 <= modulo a b < Z.abs b. Proof. intros Hb. unfold modulo. apply Z.mod_pos_bound. destruct b; compute; trivial. now destruct Hb. Qed. Lemma mod_bound_pos a b : 0<=a -> 0 0 <= modulo a b < b. Proof. intros _ Hb. rewrite <- (Z.abs_eq b) at 3 by Z.order. apply mod_always_pos. Z.order. Qed. Include ZEuclidProp Z Z Z. End ZEuclid. coq-8.4pl4/theories/ZArith/ZArith.v0000644000175000017500000000151112326224777016244 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* fun v1' => a1 = a2' /\ v1' = v2') x v1 with | eq_refl => conj eq_refl eq_refl end. (** Lemmas are done for functions that use [Fin.t] but thanks to [Peano_dec.le_unique], all is true for the one that use [lt] *) Lemma eq_nth_iff A n (v1 v2: t A n): (forall p1 p2, p1 = p2 -> v1 [@ p1 ] = v2 [@ p2 ]) <-> v1 = v2. Proof. split. revert n v1 v2; refine (@rect2 _ _ _ _ _); simpl; intros. reflexivity. f_equal. apply (H0 Fin.F1 Fin.F1 eq_refl). apply H. intros p1 p2 H1; apply (H0 (Fin.FS p1) (Fin.FS p2) (f_equal (@Fin.FS n) H1)). intros; now f_equal. Qed. Lemma nth_order_last A: forall n (v: t A (S n)) (H: n < S n), nth_order v H = last v. Proof. unfold nth_order; refine (@rectS _ _ _ _); now simpl. Qed. Lemma shiftin_nth A a n (v: t A n) k1 k2 (eq: k1 = k2): nth (shiftin a v) (Fin.L_R 1 k1) = nth v k2. Proof. subst k2; induction k1. generalize dependent n. apply caseS ; intros. now simpl. generalize dependent n. refine (@caseS _ _ _) ; intros. now simpl. Qed. Lemma shiftin_last A a n (v: t A n): last (shiftin a v) = a. Proof. induction v ;now simpl. Qed. Lemma shiftrepeat_nth A: forall n k (v: t A (S n)), nth (shiftrepeat v) (Fin.L_R 1 k) = nth v k. Proof. refine (@Fin.rectS _ _ _); intros. revert n v; refine (@caseS _ _ _); simpl; intros. now destruct t. revert p H. refine (match v as v' in t _ m return match m as m' return t A m' -> Type with |S (S n) => fun v => forall p : Fin.t (S n), (forall v0 : t A (S n), (shiftrepeat v0) [@ Fin.L_R 1 p ] = v0 [@p]) -> (shiftrepeat v) [@Fin.L_R 1 (Fin.FS p)] = v [@Fin.FS p] |_ => fun _ => @ID end v' with |[] => @id |h :: t => _ end). destruct n0. exact @id. now simpl. Qed. Lemma shiftrepeat_last A: forall n (v: t A (S n)), last (shiftrepeat v) = last v. Proof. refine (@rectS _ _ _ _); now simpl. Qed. Lemma const_nth A (a: A) n (p: Fin.t n): (const a n)[@ p] = a. Proof. now induction p. Qed. Lemma nth_map {A B} (f: A -> B) {n} v (p1 p2: Fin.t n) (eq: p1 = p2): (map f v) [@ p1] = f (v [@ p2]). Proof. subst p2; induction p1. revert n v; refine (@caseS _ _ _); now simpl. revert n v p1 IHp1; refine (@caseS _ _ _); now simpl. Qed. Lemma nth_map2 {A B C} (f: A -> B -> C) {n} v w (p1 p2 p3: Fin.t n): p1 = p2 -> p2 = p3 -> (map2 f v w) [@p1] = f (v[@p2]) (w[@p3]). Proof. intros; subst p2; subst p3; revert n v w p1. refine (@rect2 _ _ _ _ _); simpl. exact (Fin.case0 _). intros n v1 v2 H a b p; revert n p v1 v2 H; refine (@Fin.caseS _ _ _); now simpl. Qed. Lemma fold_left_right_assoc_eq {A B} {f: A -> B -> A} (assoc: forall a b c, f (f a b) c = f (f a c) b) {n} (v: t B n): forall a, fold_left f a v = fold_right (fun x y => f y x) v a. Proof. assert (forall n h (v: t B n) a, fold_left f (f a h) v = f (fold_left f a v) h). induction v0. now simpl. intros; simpl. rewrite<- IHv0. now f_equal. induction v. reflexivity. simpl. intros; now rewrite<- (IHv). Qed. Lemma to_list_of_list_opp {A} (l: list A): to_list (of_list l) = l. Proof. induction l. reflexivity. unfold to_list; simpl. now f_equal. Qed. coq-8.4pl4/theories/Vectors/VectorDef.v0000644000175000017500000002414112326224777017154 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Type := |nil : t A 0 |cons : forall (h:A) (n:nat), t A n -> t A (S n). Local Notation "[]" := (nil _). Local Notation "h :: t" := (cons _ h _ t) (at level 60, right associativity). Section SCHEMES. (** An induction scheme for non-empty vectors *) Definition rectS {A} (P:forall {n}, t A (S n) -> Type) (bas: forall a: A, P (a :: [])) (rect: forall a {n} (v: t A (S n)), P v -> P (a :: v)) := fix rectS_fix {n} (v: t A (S n)) : P v := match v with |nil => fun devil => False_rect (@ID) devil |cons a 0 v => match v as vnn in t _ nn return match nn,vnn with |0,vm => P (a :: vm) |S _,_ => _ end with |nil => bas a |_ :: _ => fun devil => False_rect (@ID) devil end |cons a (S nn') v => rect a v (rectS_fix v) end. (** An induction scheme for 2 vectors of same length *) Definition rect2 {A B} (P:forall {n}, t A n -> t B n -> Type) (bas : P [] []) (rect : forall {n v1 v2}, P v1 v2 -> forall a b, P (a :: v1) (b :: v2)) := fix rect2_fix {n} (v1:t A n): forall v2 : t B n, P v1 v2 := match v1 as v1' in t _ n1 return forall v2 : t B n1, P v1' v2 with |[] => fun v2 => match v2 with |[] => bas |_ :: _ => fun devil => False_rect (@ID) devil end |h1 :: t1 => fun v2 => match v2 with |[] => fun devil => False_rect (@ID) devil |h2 :: t2 => fun t1' => rect (rect2_fix t1' t2) h1 h2 end t1 end. (** A vector of length [0] is [nil] *) Definition case0 {A} (P:t A 0 -> Type) (H:P (nil A)) v:P v := match v with |[] => H end. (** A vector of length [S _] is [cons] *) Definition caseS {A} (P : forall {n}, t A (S n) -> Type) (H : forall h {n} t, @P n (h :: t)) {n} (v: t A (S n)) : P v := match v as v' in t _ m return match m, v' with |0, _ => False -> True |S _, v0 => P v' end with |[] => fun devil => False_rect _ devil (* subterm !!! *) |h :: t => H h t end. End SCHEMES. Section BASES. (** The first element of a non empty vector *) Definition hd {A} {n} (v:t A (S n)) := Eval cbv delta beta in (caseS (fun n v => A) (fun h n t => h) v). (** The last element of an non empty vector *) Definition last {A} {n} (v : t A (S n)) := Eval cbv delta in (rectS (fun _ _ => A) (fun a => a) (fun _ _ _ H => H) v). (** Build a vector of n{^ th} [a] *) Fixpoint const {A} (a:A) (n:nat) := match n return t A n with | O => nil A | S n => a :: (const a n) end. (** The [p]{^ th} element of a vector of length [m]. Computational behavior of this function should be the same as ocaml function. *) Definition nth {A} := fix nth_fix {m} (v' : t A m) (p : Fin.t m) {struct v'} : A := match p in Fin.t m' return t A m' -> A with |Fin.F1 q => fun v => caseS (fun n v' => A) (fun h n t => h) v |Fin.FS q p' => fun v => (caseS (fun n v' => Fin.t n -> A) (fun h n t p0 => nth_fix t p0) v) p' end v'. (** An equivalent definition of [nth]. *) Definition nth_order {A} {n} (v: t A n) {p} (H: p < n) := (nth v (Fin.of_nat_lt H)). (** Put [a] at the p{^ th} place of [v] *) Fixpoint replace {A n} (v : t A n) (p: Fin.t n) (a : A) {struct p}: t A n := match p with |Fin.F1 k => fun v': t A (S k) => caseS (fun n _ => t A (S n)) (fun h _ t => a :: t) v' |Fin.FS k p' => fun v' => (caseS (fun n _ => Fin.t n -> t A (S n)) (fun h _ t p2 => h :: (replace t p2 a)) v') p' end v. (** Version of replace with [lt] *) Definition replace_order {A n} (v: t A n) {p} (H: p < n) := replace v (Fin.of_nat_lt H). (** Remove the first element of a non empty vector *) Definition tl {A} {n} (v:t A (S n)) := Eval cbv delta beta in (caseS (fun n v => t A n) (fun h n t => t) v). (** Remove last element of a non-empty vector *) Definition shiftout {A} {n:nat} (v:t A (S n)) : t A n := Eval cbv delta beta in (rectS (fun n _ => t A n) (fun a => []) (fun h _ _ H => h :: H) v). (** Add an element at the end of a vector *) Fixpoint shiftin {A} {n:nat} (a : A) (v:t A n) : t A (S n) := match v with |[] => a :: [] |h :: t => h :: (shiftin a t) end. (** Copy last element of a vector *) Definition shiftrepeat {A} {n} (v:t A (S n)) : t A (S (S n)) := Eval cbv delta beta in (rectS (fun n _ => t A (S (S n))) (fun h => h :: h :: []) (fun h _ _ H => h :: H) v). (** Remove [p] last elements of a vector *) Lemma trunc : forall {A} {n} (p:nat), n > p -> t A n -> t A (n - p). Proof. induction p as [| p f]; intros H v. rewrite <- minus_n_O. exact v. apply shiftout. rewrite minus_Sn_m. apply f. auto with *. exact v. auto with *. Defined. (** Concatenation of two vectors *) Fixpoint append {A}{n}{p} (v:t A n) (w:t A p):t A (n+p) := match v with | [] => w | a :: v' => a :: (append v' w) end. Infix "++" := append. (** Two definitions of the tail recursive function that appends two lists but reverses the first one *) (** This one has the exact expected computational behavior *) Fixpoint rev_append_tail {A n p} (v : t A n) (w: t A p) : t A (tail_plus n p) := match v with | [] => w | a :: v' => rev_append_tail v' (a :: w) end. Import EqdepFacts. (** This one has a better type *) Definition rev_append {A n p} (v: t A n) (w: t A p) :t A (n + p) := rew <- (plus_tail_plus n p) in (rev_append_tail v w). (** rev [a₁ ; a₂ ; .. ; an] is [an ; a{n-1} ; .. ; a₁] Caution : There is a lot of rewrite garbage in this definition *) Definition rev {A n} (v : t A n) : t A n := rew <- (plus_n_O _) in (rev_append v []). End BASES. Local Notation "v [@ p ]" := (nth v p) (at level 1). Section ITERATORS. (** * Here are special non dependent useful instantiation of induction schemes *) (** Uniform application on the arguments of the vector *) Definition map {A} {B} (f : A -> B) : forall {n} (v:t A n), t B n := fix map_fix {n} (v : t A n) : t B n := match v with | [] => [] | a :: v' => (f a) :: (map_fix v') end. (** map2 g [x1 .. xn] [y1 .. yn] = [(g x1 y1) .. (g xn yn)] *) Definition map2 {A B C} (g:A -> B -> C) {n} (v1:t A n) (v2:t B n) : t C n := Eval cbv delta beta in rect2 (fun n _ _ => t C n) (nil C) (fun _ _ _ H a b => (g a b) :: H) v1 v2. (** fold_left f b [x1 .. xn] = f .. (f (f b x1) x2) .. xn *) Definition fold_left {A B:Type} (f:B->A->B): forall (b:B) {n} (v:t A n), B := fix fold_left_fix (b:B) {n} (v : t A n) : B := match v with | [] => b | a :: w => (fold_left_fix (f b a) w) end. (** fold_right f [x1 .. xn] b = f x1 (f x2 .. (f xn b) .. ) *) Definition fold_right {A B : Type} (f : A->B->B) := fix fold_right_fix {n} (v : t A n) (b:B) {struct v} : B := match v with | [] => b | a :: w => f a (fold_right_fix w b) end. (** fold_right2 g [x1 .. xn] [y1 .. yn] c = g x1 y1 (g x2 y2 .. (g xn yn c) .. ) *) Definition fold_right2 {A B C} (g:A -> B -> C -> C) {n} (v:t A n) (w : t B n) (c:C) : C := Eval cbv delta beta in rect2 (fun _ _ _ => C) c (fun _ _ _ H a b => g a b H) v w. (** fold_left2 f b [x1 .. xn] [y1 .. yn] = g .. (g (g a x1 y1) x2 y2) .. xn yn *) Definition fold_left2 {A B C: Type} (f : A -> B -> C -> A) := fix fold_left2_fix (a : A) {n} (v : t B n) : t C n -> A := match v in t _ n0 return t C n0 -> A with |[] => fun w => match w in t _ n1 return match n1 with |0 => A |S _ => @ID end with |[] => a |_ :: _ => @id end |cons vh vn vt => fun w => match w in t _ n1 return match n1 with |0 => @ID |S n => t B n -> A end with |[] => @id |wh :: wt => fun vt' => fold_left2_fix (f a vh wh) vt' wt end vt end. End ITERATORS. Section SCANNING. Inductive Forall {A} (P: A -> Prop): forall {n} (v: t A n), Prop := |Forall_nil: Forall P [] |Forall_cons {n} x (v: t A n): P x -> Forall P v -> Forall P (x::v). Hint Constructors Forall. Inductive Exists {A} (P:A->Prop): forall {n}, t A n -> Prop := |Exists_cons_hd {m} x (v: t A m): P x -> Exists P (x::v) |Exists_cons_tl {m} x (v: t A m): Exists P v -> Exists P (x::v). Hint Constructors Exists. Inductive In {A} (a:A): forall {n}, t A n -> Prop := |In_cons_hd {m} (v: t A m): In a (a::v) |In_cons_tl {m} x (v: t A m): In a v -> In a (x::v). Hint Constructors In. Inductive Forall2 {A B} (P:A->B->Prop): forall {n}, t A n -> t B n -> Prop := |Forall2_nil: Forall2 P [] [] |Forall2_cons {m} x1 x2 (v1:t A m) v2: P x1 x2 -> Forall2 P v1 v2 -> Forall2 P (x1::v1) (x2::v2). Hint Constructors Forall2. Inductive Exists2 {A B} (P:A->B->Prop): forall {n}, t A n -> t B n -> Prop := |Exists2_cons_hd {m} x1 x2 (v1: t A m) (v2: t B m): P x1 x2 -> Exists2 P (x1::v1) (x2::v2) |Exists2_cons_tl {m} x1 x2 (v1:t A m) v2: Exists2 P v1 v2 -> Exists2 P (x1::v1) (x2::v2). Hint Constructors Exists2. End SCANNING. Section VECTORLIST. (** * vector <=> list functions *) Fixpoint of_list {A} (l : list A) : t A (length l) := match l as l' return t A (length l') with |Datatypes.nil => [] |(h :: tail)%list => (h :: (of_list tail)) end. Definition to_list {A}{n} (v : t A n) : list A := Eval cbv delta beta in fold_right (fun h H => Datatypes.cons h H) v Datatypes.nil. End VECTORLIST. Module VectorNotations. Notation "[]" := [] : vector_scope. Notation "h :: t" := (h :: t) (at level 60, right associativity) : vector_scope. Notation " [ x ] " := (x :: []) : vector_scope. Notation " [ x ; .. ; y ] " := (cons _ x _ .. (cons _ y _ (nil _)) ..) : vector_scope . Notation "v [@ p ]" := (nth v p) (at level 1, format "v [@ p ]") : vector_scope. Open Scope vector_scope. End VectorNotations. coq-8.4pl4/theories/Vectors/Vector.v0000644000175000017500000000150212326224777016531 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Set := |F1 : forall {n}, t (S n) |FS : forall {n}, t n -> t (S n). Section SCHEMES. Definition case0 P (p: t 0): P p := match p as p' in t n return match n as n' return t n' -> Type with |0 => fun f0 => P f0 |S _ => fun _ => @ID end p' with |F1 _ => @id |FS _ _ => @id end. Definition caseS (P: forall {n}, t (S n) -> Type) (P1: forall n, @P n F1) (PS : forall {n} (p: t n), P (FS p)) {n} (p: t (S n)): P p := match p with |F1 k => P1 k |FS k pp => PS pp end. Definition rectS (P: forall {n}, t (S n) -> Type) (P1: forall n, @P n F1) (PS : forall {n} (p: t (S n)), P p -> P (FS p)): forall {n} (p: t (S n)), P p := fix rectS_fix {n} (p: t (S n)): P p:= match p with |F1 k => P1 k |FS 0 pp => case0 (fun f => P (FS f)) pp |FS (S k) pp => PS pp (rectS_fix pp) end. Definition rect2 (P: forall {n} (a b: t n), Type) (H0: forall n, @P (S n) F1 F1) (H1: forall {n} (f: t n), P F1 (FS f)) (H2: forall {n} (f: t n), P (FS f) F1) (HS: forall {n} (f g : t n), P f g -> P (FS f) (FS g)): forall {n} (a b: t n), P a b := fix rect2_fix {n} (a: t n): forall (b: t n), P a b := match a with |F1 m => fun (b: t (S m)) => match b as b' in t n' return match n',b' with |0,_ => @ID |S n0,b0 => P F1 b0 end with |F1 m' => H0 m' |FS m' b' => H1 b' end |FS m a' => fun (b: t (S m)) => match b with |F1 m' => fun aa: t m' => H2 aa |FS m' b' => fun aa: t m' => HS aa b' (rect2_fix aa b') end a' end. End SCHEMES. Definition FS_inj {n} (x y: t n) (eq: FS x = FS y): x = y := match eq in _ = a return match a as a' in t m return match m with |0 => Prop |S n' => t n' -> Prop end with @F1 _ => fun _ => True |@FS _ y => fun x' => x' = y end x with eq_refl => eq_refl end. (** [to_nat f] = p iff [f] is the p{^ th} element of [fin m]. *) Fixpoint to_nat {m} (n : t m) : {i | i < m} := match n in t k return {i | i< k} with |F1 j => exist (fun i => i< S j) 0 (Lt.lt_0_Sn j) |FS _ p => match to_nat p with |exist i P => exist _ (S i) (Lt.lt_n_S _ _ P) end end. (** [of_nat p n] answers the p{^ th} element of [fin n] if p < n or a proof of p >= n else *) Fixpoint of_nat (p n : nat) : (t n) + { exists m, p = n + m } := match n with |0 => inright _ (ex_intro (fun x => p = 0 + x) p (@eq_refl _ p)) |S n' => match p with |0 => inleft _ (F1) |S p' => match of_nat p' n' with |inleft f => inleft _ (FS f) |inright arg => inright _ (match arg with |ex_intro m e => ex_intro (fun x => S p' = S n' + x) m (f_equal S e) end) end end end. (** [of_nat_lt p n H] answers the p{^ th} element of [fin n] it behaves much better than [of_nat p n] on open term *) Fixpoint of_nat_lt {p n : nat} : p < n -> t n := match n with |0 => fun H : p < 0 => False_rect _ (Lt.lt_n_O p H) |S n' => match p with |0 => fun _ => @F1 n' |S p' => fun H => FS (of_nat_lt (Lt.lt_S_n _ _ H)) end end. Lemma of_nat_to_nat_inv {m} (p : t m) : of_nat_lt (proj2_sig (to_nat p)) = p. Proof. induction p. reflexivity. simpl; destruct (to_nat p). simpl. subst p; repeat f_equal. apply Peano_dec.le_unique. Qed. (** [weak p f] answers a function witch is the identity for the p{^ th} first element of [fin (p + m)] and [FS (FS .. (FS (f k)))] for [FS (FS .. (FS k))] with p FSs *) Fixpoint weak {m}{n} p (f : t m -> t n) : t (p + m) -> t (p + n) := match p as p' return t (p' + m) -> t (p' + n) with |0 => f |S p' => fun x => match x with |F1 n' => fun eq : n' = p' + m => F1 |FS n' y => fun eq : n' = p' + m => FS (weak p' f (eq_rect _ t y _ eq)) end (eq_refl _) end. (** The p{^ th} element of [fin m] viewed as the p{^ th} element of [fin (m + n)] *) Fixpoint L {m} n (p : t m) : t (m + n) := match p with |F1 _ => F1 |FS _ p' => FS (L n p') end. Lemma L_sanity {m} n (p : t m) : proj1_sig (to_nat (L n p)) = proj1_sig (to_nat p). Proof. induction p. reflexivity. simpl; destruct (to_nat (L n p)); simpl in *; rewrite IHp. now destruct (to_nat p). Qed. (** The p{^ th} element of [fin m] viewed as the p{^ th} element of [fin (n + m)] Really really ineficient !!! *) Definition L_R {m} n (p : t m) : t (n + m). induction n. exact p. exact ((fix LS k (p: t k) := match p with |F1 k' => @F1 (S k') |FS _ p' => FS (LS _ p') end) _ IHn). Defined. (** The p{^ th} element of [fin m] viewed as the (n + p){^ th} element of [fin (n + m)] *) Fixpoint R {m} n (p : t m) : t (n + m) := match n with |0 => p |S n' => FS (R n' p) end. Lemma R_sanity {m} n (p : t m) : proj1_sig (to_nat (R n p)) = n + proj1_sig (to_nat p). Proof. induction n. reflexivity. simpl; destruct (to_nat (R n p)); simpl in *; rewrite IHn. now destruct (to_nat p). Qed. Fixpoint depair {m n} (o : t m) (p : t n) : t (m * n) := match o with |F1 m' => L (m' * n) p |FS m' o' => R n (depair o' p) end. Lemma depair_sanity {m n} (o : t m) (p : t n) : proj1_sig (to_nat (depair o p)) = n * (proj1_sig (to_nat o)) + (proj1_sig (to_nat p)). Proof. induction o ; simpl. rewrite L_sanity. now rewrite Mult.mult_0_r. rewrite R_sanity. rewrite IHo. rewrite Plus.plus_assoc. destruct (to_nat o); simpl; rewrite Mult.mult_succ_r. now rewrite (Plus.plus_comm n). Qed. coq-8.4pl4/theories/Wellfounded/0000755000175000017500000000000012365131022015704 5ustar stephstephcoq-8.4pl4/theories/Wellfounded/vo.itarget0000644000175000017500000000025012326224777017727 0ustar stephstephDisjoint_Union.vo Inclusion.vo Inverse_Image.vo Lexicographic_Exponentiation.vo Lexicographic_Product.vo Transitive_Closure.vo Union.vo Wellfounded.vo Well_Ordering.vo coq-8.4pl4/theories/Wellfounded/Wellfounded.v0000644000175000017500000000142012326224777020361 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Type. Variable leA : A -> A -> Prop. Variable leB : forall x:A, B x -> B x -> Prop. Notation LexProd := (lexprod A B leA leB). Lemma acc_A_B_lexprod : forall x:A, Acc leA x -> (forall x0:A, clos_trans A leA x0 x -> well_founded (leB x0)) -> forall y:B x, Acc (leB x) y -> Acc LexProd (existT B x y). Proof. induction 1 as [x _ IHAcc]; intros H2 y. induction 1 as [x0 H IHAcc0]; intros. apply Acc_intro. destruct y as [x2 y1]; intro H6. simple inversion H6; intro. cut (leA x2 x); intros. apply IHAcc; auto with sets. intros. apply H2. apply t_trans with x2; auto with sets. red in H2. apply H2. auto with sets. injection H1. destruct 2. injection H3. destruct 2; auto with sets. rewrite <- H1. injection H3; intros _ Hx1. subst x1. apply IHAcc0. elim inj_pair2 with A B x y' x0; assumption. Defined. Theorem wf_lexprod : well_founded leA -> (forall x:A, well_founded (leB x)) -> well_founded LexProd. Proof. intros wfA wfB; unfold well_founded. destruct a. apply acc_A_B_lexprod; auto with sets; intros. red in wfB. auto with sets. Defined. End WfLexicographic_Product. Section Wf_Symmetric_Product. Variable A : Type. Variable B : Type. Variable leA : A -> A -> Prop. Variable leB : B -> B -> Prop. Notation Symprod := (symprod A B leA leB). Lemma Acc_symprod : forall x:A, Acc leA x -> forall y:B, Acc leB y -> Acc Symprod (x, y). Proof. induction 1 as [x _ IHAcc]; intros y H2. induction H2 as [x1 H3 IHAcc1]. apply Acc_intro; intros y H5. inversion_clear H5; auto with sets. apply IHAcc; auto. apply Acc_intro; trivial. Defined. Lemma wf_symprod : well_founded leA -> well_founded leB -> well_founded Symprod. Proof. red. destruct a. apply Acc_symprod; auto with sets. Defined. End Wf_Symmetric_Product. Section Swap. Variable A : Type. Variable R : A -> A -> Prop. Notation SwapProd := (swapprod A R). Lemma swap_Acc : forall x y:A, Acc SwapProd (x, y) -> Acc SwapProd (y, x). Proof. intros. inversion_clear H. apply Acc_intro. destruct y0; intros. inversion_clear H; inversion_clear H1; apply H0. apply sp_swap. apply right_sym; auto with sets. apply sp_swap. apply left_sym; auto with sets. apply sp_noswap. apply right_sym; auto with sets. apply sp_noswap. apply left_sym; auto with sets. Defined. Lemma Acc_swapprod : forall x y:A, Acc R x -> Acc R y -> Acc SwapProd (x, y). Proof. induction 1 as [x0 _ IHAcc0]; intros H2. cut (forall y0:A, R y0 x0 -> Acc SwapProd (y0, y)). clear IHAcc0. induction H2 as [x1 _ IHAcc1]; intros H4. cut (forall y:A, R y x1 -> Acc SwapProd (x0, y)). clear IHAcc1. intro. apply Acc_intro. destruct y; intro H5. inversion_clear H5. inversion_clear H0; auto with sets. apply swap_Acc. inversion_clear H0; auto with sets. intros. apply IHAcc1; auto with sets; intros. apply Acc_inv with (y0, x1); auto with sets. apply sp_noswap. apply right_sym; auto with sets. auto with sets. Defined. Lemma wf_swapprod : well_founded R -> well_founded SwapProd. Proof. red. destruct a; intros. apply Acc_swapprod; auto with sets. Defined. End Swap. coq-8.4pl4/theories/Wellfounded/Inverse_Image.v0000644000175000017500000000327312326224777020636 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* B -> Prop. Variable f : A -> B. Let Rof (x y:A) : Prop := R (f x) (f y). Remark Acc_lemma : forall y:B, Acc R y -> forall x:A, y = f x -> Acc Rof x. Proof. induction 1 as [y _ IHAcc]; intros x H. apply Acc_intro; intros y0 H1. apply (IHAcc (f y0)); try trivial. rewrite H; trivial. Qed. Lemma Acc_inverse_image : forall x:A, Acc R (f x) -> Acc Rof x. Proof. intros; apply (Acc_lemma (f x)); trivial. Qed. Theorem wf_inverse_image : well_founded R -> well_founded Rof. Proof. red; intros; apply Acc_inverse_image; auto. Qed. Variable F : A -> B -> Prop. Let RoF (x y:A) : Prop := exists2 b : B, F x b & (forall c:B, F y c -> R b c). Lemma Acc_inverse_rel : forall b:B, Acc R b -> forall x:A, F x b -> Acc RoF x. Proof. induction 1 as [x _ IHAcc]; intros x0 H2. constructor; intros y H3. destruct H3. apply (IHAcc x1); auto. Qed. Theorem wf_inverse_rel : well_founded R -> well_founded RoF. Proof. red; constructor; intros. case H0; intros. apply (Acc_inverse_rel x); auto. Qed. End Inverse_Image. coq-8.4pl4/theories/Wellfounded/Well_Ordering.v0000644000175000017500000000362412326224777020655 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Type. Inductive WO : Type := sup : forall (a:A) (f:B a -> WO), WO. Inductive le_WO : WO -> WO -> Prop := le_sup : forall (a:A) (f:B a -> WO) (v:B a), le_WO (f v) (sup a f). Theorem wf_WO : well_founded le_WO. Proof. unfold well_founded; intro. apply Acc_intro. elim a. intros. inversion H0. apply Acc_intro. generalize H4; generalize H1; generalize f0; generalize v. rewrite H3. intros. apply (H v0 y0). cut (f = f1). intros E; rewrite E; auto. symmetry . apply (inj_pair2 A (fun a0:A => B a0 -> WO) a0 f1 f H5). Qed. End WellOrdering. Section Characterisation_wf_relations. (** Wellfounded relations are the inverse image of wellordering types *) (* in course of development *) Variable A : Type. Variable leA : A -> A -> Prop. Definition B (a:A) := {x : A | leA x a}. Definition wof : well_founded leA -> A -> WO A B. Proof. intros. apply (well_founded_induction_type H (fun a:A => WO A B)); auto. intros x H1. apply (sup A B x). unfold B at 1. destruct 1 as [x0]. apply (H1 x0); auto. Qed. End Characterisation_wf_relations. coq-8.4pl4/theories/Wellfounded/Transitive_Closure.v0000644000175000017500000000262712326224777021747 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Acc trans_clos x. induction 1 as [x0 _ H1]. apply Acc_intro. intros y H2. induction H2; auto with sets. apply Acc_inv with y; auto with sets. Defined. Hint Resolve Acc_clos_trans. Lemma Acc_inv_trans : forall x y:A, trans_clos y x -> Acc R x -> Acc R y. Proof. induction 1 as [| x y]; auto with sets. intro; apply Acc_inv with y; assumption. Qed. Theorem wf_clos_trans : well_founded R -> well_founded trans_clos. Proof. unfold well_founded; auto with sets. Defined. End Wf_Transitive_Closure. coq-8.4pl4/theories/Wellfounded/Union.v0000644000175000017500000000432412326224777017207 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* forall x y:A, clos_trans A R1 y x -> forall z:A, R2 z y -> exists2 y' : A, R2 y' x & clos_trans A R1 z y'. Proof. induction 2 as [x y| x y z H0 IH1 H1 IH2]; intros. elim H with y x z; auto with sets; intros x0 H2 H3. exists x0; auto with sets. elim IH1 with z0; auto with sets; intros. elim IH2 with x0; auto with sets; intros. exists x1; auto with sets. apply t_trans with x0; auto with sets. Qed. Lemma Acc_union : commut A R1 R2 -> (forall x:A, Acc R2 x -> Acc R1 x) -> forall a:A, Acc R2 a -> Acc Union a. Proof. induction 3 as [x H1 H2]. apply Acc_intro; intros. elim H3; intros; auto with sets. cut (clos_trans A R1 y x); auto with sets. elimtype (Acc (clos_trans A R1) y); intros. apply Acc_intro; intros. elim H8; intros. apply H6; auto with sets. apply t_trans with x0; auto with sets. elim strip_commut with x x0 y0; auto with sets; intros. apply Acc_inv_trans with x1; auto with sets. unfold union. elim H11; auto with sets; intros. apply t_trans with y1; auto with sets. apply (Acc_clos_trans A). apply Acc_inv with x; auto with sets. apply H0. apply Acc_intro; auto with sets. Qed. Theorem wf_union : commut A R1 R2 -> well_founded R1 -> well_founded R2 -> well_founded Union. Proof. unfold well_founded. intros. apply Acc_union; auto with sets. Qed. End WfUnion. coq-8.4pl4/theories/Wellfounded/Lexicographic_Exponentiation.v0000644000175000017500000002320612326224777023764 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* A -> Prop. Notation Power := (Pow A leA). Notation Lex_Exp := (lex_exp A leA). Notation ltl := (Ltl A leA). Notation Descl := (Desc A leA). Notation List := (list A). Notation Nil := (nil (A:=A)). (* useless but symmetric *) Notation Cons := (cons (A:=A)). Notation "<< x , y >>" := (exist Descl x y) (at level 0, x, y at level 100). (* Hint Resolve d_one d_nil t_step. *) Lemma left_prefix : forall x y z:List, ltl (x ++ y) z -> ltl x z. Proof. simple induction x. simple induction z. simpl; intros H. inversion_clear H. simpl; intros; apply (Lt_nil A leA). intros a l HInd. simpl. intros. inversion_clear H. apply (Lt_hd A leA); auto with sets. apply (Lt_tl A leA). apply (HInd y y0); auto with sets. Qed. Lemma right_prefix : forall x y z:List, ltl x (y ++ z) -> ltl x y \/ (exists y' : List, x = y ++ y' /\ ltl y' z). Proof. intros x y; generalize x. elim y; simpl. right. exists x0; auto with sets. intros. inversion H0. left; apply (Lt_nil A leA). left; apply (Lt_hd A leA); auto with sets. generalize (H x1 z H3). simple induction 1. left; apply (Lt_tl A leA); auto with sets. simple induction 1. simple induction 1; intros. rewrite H8. right; exists x2; auto with sets. Qed. Lemma desc_prefix : forall (x:List) (a:A), Descl (x ++ Cons a Nil) -> Descl x. Proof. intros. inversion H. generalize (app_cons_not_nil _ _ _ H1); simple induction 1. cut (x ++ Cons a Nil = Cons x0 Nil); auto with sets. intro. generalize (app_eq_unit _ _ H0). simple induction 1; simple induction 1; intros. rewrite H4; auto using d_nil with sets. discriminate H5. generalize (app_inj_tail _ _ _ _ H0). simple induction 1; intros. rewrite <- H4; auto with sets. Qed. Lemma desc_tail : forall (x:List) (a b:A), Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b. Proof. intro. apply rev_ind with (A := A) (P := fun x:List => forall a b:A, Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b). intros. inversion H. cut (Cons b (Cons a Nil) = (Nil ++ Cons b Nil) ++ Cons a Nil); auto with sets; intro. generalize H0. intro. generalize (app_inj_tail (l ++ Cons y Nil) (Nil ++ Cons b Nil) _ _ H4); simple induction 1. intros. generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros. generalize H1. rewrite <- H10; rewrite <- H7; intro. apply (t_step A leA); auto with sets. intros. inversion H0. generalize (app_cons_not_nil _ _ _ H3); intro. elim H1. generalize H0. generalize (app_comm_cons (l ++ Cons x0 Nil) (Cons a Nil) b); simple induction 1. intro. generalize (desc_prefix (Cons b (l ++ Cons x0 Nil)) a H5); intro. generalize (H x0 b H6). intro. apply t_trans with (A := A) (y := x0); auto with sets. apply t_step. generalize H1. rewrite H4; intro. generalize (app_inj_tail _ _ _ _ H8); simple induction 1. intros. generalize H2; generalize (app_comm_cons l (Cons x0 Nil) b). intro. generalize H10. rewrite H12; intro. generalize (app_inj_tail _ _ _ _ H13); simple induction 1. intros. rewrite <- H11; rewrite <- H16; auto with sets. Qed. Lemma dist_aux : forall z:List, Descl z -> forall x y:List, z = x ++ y -> Descl x /\ Descl y. Proof. intros z D. elim D. intros. cut (x ++ y = Nil); auto with sets; intro. generalize (app_eq_nil _ _ H0); simple induction 1. intros. rewrite H2; rewrite H3; split; apply d_nil. intros. cut (x0 ++ y = Cons x Nil); auto with sets. intros E. generalize (app_eq_unit _ _ E); simple induction 1. simple induction 1; intros. rewrite H2; rewrite H3; split. apply d_nil. apply d_one. simple induction 1; intros. rewrite H2; rewrite H3; split. apply d_one. apply d_nil. do 5 intro. intros Hind. do 2 intro. generalize x0. apply rev_ind with (A := A) (P := fun y0:List => forall x0:List, (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ y0 -> Descl x0 /\ Descl y0). intro. generalize (app_nil_end x1); simple induction 1; simple induction 1. split. apply d_conc; auto with sets. apply d_nil. do 3 intro. generalize x1. apply rev_ind with (A := A) (P := fun l0:List => forall (x1:A) (x0:List), (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ l0 ++ Cons x1 Nil -> Descl x0 /\ Descl (l0 ++ Cons x1 Nil)). simpl. split. generalize (app_inj_tail _ _ _ _ H2); simple induction 1. simple induction 1; auto with sets. apply d_one. do 5 intro. generalize (app_ass x4 (l1 ++ Cons x2 Nil) (Cons x3 Nil)). simple induction 1. generalize (app_ass x4 l1 (Cons x2 Nil)); simple induction 1. intro E. generalize (app_inj_tail _ _ _ _ E). simple induction 1; intros. generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros. rewrite <- H7; rewrite <- H10; generalize H6. generalize (app_ass x4 l1 (Cons x2 Nil)); intro E1. rewrite E1. intro. generalize (Hind x4 (l1 ++ Cons x2 Nil) H11). simple induction 1; split. auto with sets. generalize H14. rewrite <- H10; intro. apply d_conc; auto with sets. Qed. Lemma dist_Desc_concat : forall x y:List, Descl (x ++ y) -> Descl x /\ Descl y. Proof. intros. apply (dist_aux (x ++ y) H x y); auto with sets. Qed. Lemma desc_end : forall (a b:A) (x:List), Descl (x ++ Cons a Nil) /\ ltl (x ++ Cons a Nil) (Cons b Nil) -> clos_trans A leA a b. Proof. intros a b x. case x. simpl. simple induction 1. intros. inversion H1; auto with sets. inversion H3. simple induction 1. generalize (app_comm_cons l (Cons a Nil) a0). intros E; rewrite <- E; intros. generalize (desc_tail l a a0 H0); intro. inversion H1. apply t_trans with (y := a0); auto with sets. inversion H4. Qed. Lemma ltl_unit : forall (x:List) (a b:A), Descl (x ++ Cons a Nil) -> ltl (x ++ Cons a Nil) (Cons b Nil) -> ltl x (Cons b Nil). Proof. intro. case x. intros; apply (Lt_nil A leA). simpl; intros. inversion_clear H0. apply (Lt_hd A leA a b); auto with sets. inversion_clear H1. Qed. Lemma acc_app : forall (x1 x2:List) (y1:Descl (x1 ++ x2)), Acc Lex_Exp << x1 ++ x2, y1 >> -> forall (x:List) (y:Descl x), ltl x (x1 ++ x2) -> Acc Lex_Exp << x, y >>. Proof. intros. apply (Acc_inv (R:=Lex_Exp) (x:=<< x1 ++ x2, y1 >>)). auto with sets. unfold lex_exp; simpl; auto with sets. Qed. Theorem wf_lex_exp : well_founded leA -> well_founded Lex_Exp. Proof. unfold well_founded at 2. simple induction a; intros x y. apply Acc_intro. simple induction y0. unfold lex_exp at 1; simpl. apply rev_ind with (A := A) (P := fun x:List => forall (x0:List) (y:Descl x0), ltl x0 x -> Acc Lex_Exp << x0, y >>). intros. inversion_clear H0. intro. generalize (well_founded_ind (wf_clos_trans A leA H)). intros GR. apply GR with (P := fun x0:A => forall l:List, (forall (x1:List) (y:Descl x1), ltl x1 l -> Acc Lex_Exp << x1, y >>) -> forall (x1:List) (y:Descl x1), ltl x1 (l ++ Cons x0 Nil) -> Acc Lex_Exp << x1, y >>). intro; intros HInd; intros. generalize (right_prefix x2 l (Cons x1 Nil) H1). simple induction 1. intro; apply (H0 x2 y1 H3). simple induction 1. intro; simple induction 1. clear H4 H2. intro; generalize y1; clear y1. rewrite H2. apply rev_ind with (A := A) (P := fun x3:List => forall y1:Descl (l ++ x3), ltl x3 (Cons x1 Nil) -> Acc Lex_Exp << l ++ x3, y1 >>). intros. generalize (app_nil_end l); intros Heq. generalize y1. clear y1. rewrite <- Heq. intro. apply Acc_intro. simple induction y2. unfold lex_exp at 1. simpl; intros x4 y3. intros. apply (H0 x4 y3); auto with sets. intros. generalize (dist_Desc_concat l (l0 ++ Cons x4 Nil) y1). simple induction 1. intros. generalize (desc_end x4 x1 l0 (conj H8 H5)); intros. generalize y1. rewrite <- (app_ass l l0 (Cons x4 Nil)); intro. generalize (HInd x4 H9 (l ++ l0)); intros HInd2. generalize (ltl_unit l0 x4 x1 H8 H5); intro. generalize (dist_Desc_concat (l ++ l0) (Cons x4 Nil) y2). simple induction 1; intros. generalize (H4 H12 H10); intro. generalize (Acc_inv H14). generalize (acc_app l l0 H12 H14). intros f g. generalize (HInd2 f); intro. apply Acc_intro. simple induction y3. unfold lex_exp at 1; simpl; intros. apply H15; auto with sets. Qed. End Wf_Lexicographic_Exponentiation. coq-8.4pl4/theories/Wellfounded/intro.tex0000755000175000017500000000017712326224777017612 0ustar stephsteph\section{Well-founded relations}\label{Wellfounded} This library gives definitions and results about well-founded relations. coq-8.4pl4/theories/Wellfounded/Disjoint_Union.v0000644000175000017500000000302612326224777021050 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* A -> Prop. Variable leB : B -> B -> Prop. Notation Le_AsB := (le_AsB A B leA leB). Lemma acc_A_sum : forall x:A, Acc leA x -> Acc Le_AsB (inl B x). Proof. induction 1. apply Acc_intro; intros y H2. inversion_clear H2. auto with sets. Qed. Lemma acc_B_sum : well_founded leA -> forall x:B, Acc leB x -> Acc Le_AsB (inr A x). Proof. induction 2. apply Acc_intro; intros y H3. inversion_clear H3; auto with sets. apply acc_A_sum; auto with sets. Qed. Lemma wf_disjoint_sum : well_founded leA -> well_founded leB -> well_founded Le_AsB. Proof. intros. unfold well_founded. destruct a as [a| b]. apply (acc_A_sum a). apply (H a). apply (acc_B_sum H b). apply (H0 b). Qed. End Wf_Disjoint_Union. coq-8.4pl4/theories/Wellfounded/Inclusion.v0000644000175000017500000000174312326224777020064 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* A -> Prop. Lemma Acc_incl : inclusion A R1 R2 -> forall z:A, Acc R2 z -> Acc R1 z. Proof. induction 2. apply Acc_intro; auto with sets. Qed. Hint Resolve Acc_incl. Theorem wf_incl : inclusion A R1 R2 -> well_founded R2 -> well_founded R1. Proof. unfold well_founded; auto with sets. Qed. End WfInclusion. coq-8.4pl4/theories/Bool/0000755000175000017500000000000012365131023014330 5ustar stephstephcoq-8.4pl4/theories/Bool/Bool.v0000644000175000017500000004271212326224777015440 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* True | false => False end. (*******************) (** * Decidability *) (*******************) Lemma bool_dec : forall b1 b2 : bool, {b1 = b2} + {b1 <> b2}. Proof. decide equality. Defined. (*********************) (** * Discrimination *) (*********************) Lemma diff_true_false : true <> false. Proof. discriminate. Qed. Hint Resolve diff_true_false : bool v62. Lemma diff_false_true : false <> true. Proof. discriminate. Qed. Hint Resolve diff_false_true : bool v62. Hint Extern 1 (false <> true) => exact diff_false_true. Lemma eq_true_false_abs : forall b:bool, b = true -> b = false -> False. Proof. destr_bool. Qed. Lemma not_true_is_false : forall b:bool, b <> true -> b = false. Proof. destr_bool; intuition. Qed. Lemma not_false_is_true : forall b:bool, b <> false -> b = true. Proof. destr_bool; intuition. Qed. Lemma not_true_iff_false : forall b, b <> true <-> b = false. Proof. destr_bool; intuition. Qed. Lemma not_false_iff_true : forall b, b <> false <-> b = true. Proof. destr_bool; intuition. Qed. (**********************) (** * Order on booleans *) (**********************) Definition leb (b1 b2:bool) := match b1 with | true => b2 = true | false => True end. Hint Unfold leb: bool v62. Lemma leb_implb : forall b1 b2, leb b1 b2 <-> implb b1 b2 = true. Proof. destr_bool; intuition. Qed. (* Infix "<=" := leb : bool_scope. *) (*************) (** * Equality *) (*************) Definition eqb (b1 b2:bool) : bool := match b1, b2 with | true, true => true | true, false => false | false, true => false | false, false => true end. Lemma eqb_subst : forall (P:bool -> Prop) (b1 b2:bool), eqb b1 b2 = true -> P b1 -> P b2. Proof. destr_bool. Qed. Lemma eqb_reflx : forall b:bool, eqb b b = true. Proof. destr_bool. Qed. Lemma eqb_prop : forall a b:bool, eqb a b = true -> a = b. Proof. destr_bool. Qed. Lemma eqb_true_iff : forall a b:bool, eqb a b = true <-> a = b. Proof. destr_bool; intuition. Qed. Lemma eqb_false_iff : forall a b:bool, eqb a b = false <-> a <> b. Proof. destr_bool; intuition. Qed. (************************) (** * A synonym of [if] on [bool] *) (************************) Definition ifb (b1 b2 b3:bool) : bool := match b1 with | true => b2 | false => b3 end. Open Scope bool_scope. (****************************) (** * De Morgan laws *) (****************************) Lemma negb_orb : forall b1 b2:bool, negb (b1 || b2) = negb b1 && negb b2. Proof. destr_bool. Qed. Lemma negb_andb : forall b1 b2:bool, negb (b1 && b2) = negb b1 || negb b2. Proof. destr_bool. Qed. (********************************) (** * Properties of [negb] *) (********************************) Lemma negb_involutive : forall b:bool, negb (negb b) = b. Proof. destr_bool. Qed. Lemma negb_involutive_reverse : forall b:bool, b = negb (negb b). Proof. destr_bool. Qed. Notation negb_elim := negb_involutive (only parsing). Notation negb_intro := negb_involutive_reverse (only parsing). Lemma negb_sym : forall b b':bool, b' = negb b -> b = negb b'. Proof. destr_bool. Qed. Lemma no_fixpoint_negb : forall b:bool, negb b <> b. Proof. destr_bool. Qed. Lemma eqb_negb1 : forall b:bool, eqb (negb b) b = false. Proof. destr_bool. Qed. Lemma eqb_negb2 : forall b:bool, eqb b (negb b) = false. Proof. destr_bool. Qed. Lemma if_negb : forall (A:Type) (b:bool) (x y:A), (if negb b then x else y) = (if b then y else x). Proof. destr_bool. Qed. Lemma negb_true_iff : forall b, negb b = true <-> b = false. Proof. destr_bool; intuition. Qed. Lemma negb_false_iff : forall b, negb b = false <-> b = true. Proof. destr_bool; intuition. Qed. (********************************) (** * Properties of [orb] *) (********************************) Lemma orb_true_iff : forall b1 b2, b1 || b2 = true <-> b1 = true \/ b2 = true. Proof. destr_bool; intuition. Qed. Lemma orb_false_iff : forall b1 b2, b1 || b2 = false <-> b1 = false /\ b2 = false. Proof. destr_bool; intuition. Qed. Lemma orb_true_elim : forall b1 b2:bool, b1 || b2 = true -> {b1 = true} + {b2 = true}. Proof. destruct b1; simpl; auto. Defined. Lemma orb_prop : forall a b:bool, a || b = true -> a = true \/ b = true. Proof. intros; apply orb_true_iff; trivial. Qed. Lemma orb_true_intro : forall b1 b2:bool, b1 = true \/ b2 = true -> b1 || b2 = true. Proof. intros; apply orb_true_iff; trivial. Qed. Hint Resolve orb_true_intro: bool v62. Lemma orb_false_intro : forall b1 b2:bool, b1 = false -> b2 = false -> b1 || b2 = false. Proof. intros. subst. reflexivity. Qed. Hint Resolve orb_false_intro: bool v62. Lemma orb_false_elim : forall b1 b2:bool, b1 || b2 = false -> b1 = false /\ b2 = false. Proof. intros. apply orb_false_iff; trivial. Qed. Lemma orb_diag : forall b, b || b = b. Proof. destr_bool. Qed. (** [true] is a zero for [orb] *) Lemma orb_true_r : forall b:bool, b || true = true. Proof. destr_bool. Qed. Hint Resolve orb_true_r: bool v62. Lemma orb_true_l : forall b:bool, true || b = true. Proof. reflexivity. Qed. Notation orb_b_true := orb_true_r (only parsing). Notation orb_true_b := orb_true_l (only parsing). (** [false] is neutral for [orb] *) Lemma orb_false_r : forall b:bool, b || false = b. Proof. destr_bool. Qed. Hint Resolve orb_false_r: bool v62. Lemma orb_false_l : forall b:bool, false || b = b. Proof. destr_bool. Qed. Hint Resolve orb_false_l: bool v62. Notation orb_b_false := orb_false_r (only parsing). Notation orb_false_b := orb_false_l (only parsing). (** Complementation *) Lemma orb_negb_r : forall b:bool, b || negb b = true. Proof. destr_bool. Qed. Hint Resolve orb_negb_r: bool v62. Notation orb_neg_b := orb_negb_r (only parsing). (** Commutativity *) Lemma orb_comm : forall b1 b2:bool, b1 || b2 = b2 || b1. Proof. destr_bool. Qed. (** Associativity *) Lemma orb_assoc : forall b1 b2 b3:bool, b1 || (b2 || b3) = b1 || b2 || b3. Proof. destr_bool. Qed. Hint Resolve orb_comm orb_assoc: bool v62. (*******************************) (** * Properties of [andb] *) (*******************************) Lemma andb_true_iff : forall b1 b2:bool, b1 && b2 = true <-> b1 = true /\ b2 = true. Proof. destr_bool; intuition. Qed. Lemma andb_false_iff : forall b1 b2:bool, b1 && b2 = false <-> b1 = false \/ b2 = false. Proof. destr_bool; intuition. Qed. Lemma andb_true_eq : forall a b:bool, true = a && b -> true = a /\ true = b. Proof. destr_bool. auto. Defined. Lemma andb_false_intro1 : forall b1 b2:bool, b1 = false -> b1 && b2 = false. Proof. intros. apply andb_false_iff. auto. Qed. Lemma andb_false_intro2 : forall b1 b2:bool, b2 = false -> b1 && b2 = false. Proof. intros. apply andb_false_iff. auto. Qed. (** [false] is a zero for [andb] *) Lemma andb_false_r : forall b:bool, b && false = false. Proof. destr_bool. Qed. Lemma andb_false_l : forall b:bool, false && b = false. Proof. reflexivity. Qed. Notation andb_b_false := andb_false_r (only parsing). Notation andb_false_b := andb_false_l (only parsing). Lemma andb_diag : forall b, b && b = b. Proof. destr_bool. Qed. (** [true] is neutral for [andb] *) Lemma andb_true_r : forall b:bool, b && true = b. Proof. destr_bool. Qed. Lemma andb_true_l : forall b:bool, true && b = b. Proof. reflexivity. Qed. Notation andb_b_true := andb_true_r (only parsing). Notation andb_true_b := andb_true_l (only parsing). Lemma andb_false_elim : forall b1 b2:bool, b1 && b2 = false -> {b1 = false} + {b2 = false}. Proof. destruct b1; simpl; auto. Defined. Hint Resolve andb_false_elim: bool v62. (** Complementation *) Lemma andb_negb_r : forall b:bool, b && negb b = false. Proof. destr_bool. Qed. Hint Resolve andb_negb_r: bool v62. Notation andb_neg_b := andb_negb_r (only parsing). (** Commutativity *) Lemma andb_comm : forall b1 b2:bool, b1 && b2 = b2 && b1. Proof. destr_bool. Qed. (** Associativity *) Lemma andb_assoc : forall b1 b2 b3:bool, b1 && (b2 && b3) = b1 && b2 && b3. Proof. destr_bool. Qed. Hint Resolve andb_comm andb_assoc: bool v62. (*******************************************) (** * Properties mixing [andb] and [orb] *) (*******************************************) (** Distributivity *) Lemma andb_orb_distrib_r : forall b1 b2 b3:bool, b1 && (b2 || b3) = b1 && b2 || b1 && b3. Proof. destr_bool. Qed. Lemma andb_orb_distrib_l : forall b1 b2 b3:bool, (b1 || b2) && b3 = b1 && b3 || b2 && b3. Proof. destr_bool. Qed. Lemma orb_andb_distrib_r : forall b1 b2 b3:bool, b1 || b2 && b3 = (b1 || b2) && (b1 || b3). Proof. destr_bool. Qed. Lemma orb_andb_distrib_l : forall b1 b2 b3:bool, b1 && b2 || b3 = (b1 || b3) && (b2 || b3). Proof. destr_bool. Qed. (* Compatibility *) Notation demorgan1 := andb_orb_distrib_r (only parsing). Notation demorgan2 := andb_orb_distrib_l (only parsing). Notation demorgan3 := orb_andb_distrib_r (only parsing). Notation demorgan4 := orb_andb_distrib_l (only parsing). (** Absorption *) Lemma absoption_andb : forall b1 b2:bool, b1 && (b1 || b2) = b1. Proof. destr_bool. Qed. Lemma absoption_orb : forall b1 b2:bool, b1 || b1 && b2 = b1. Proof. destr_bool. Qed. (*********************************) (** * Properties of [xorb] *) (*********************************) (** [false] is neutral for [xorb] *) Lemma xorb_false_r : forall b:bool, xorb b false = b. Proof. destr_bool. Qed. Lemma xorb_false_l : forall b:bool, xorb false b = b. Proof. destr_bool. Qed. Notation xorb_false := xorb_false_r (only parsing). Notation false_xorb := xorb_false_l (only parsing). (** [true] is "complementing" for [xorb] *) Lemma xorb_true_r : forall b:bool, xorb b true = negb b. Proof. reflexivity. Qed. Lemma xorb_true_l : forall b:bool, xorb true b = negb b. Proof. reflexivity. Qed. Notation xorb_true := xorb_true_r (only parsing). Notation true_xorb := xorb_true_l (only parsing). (** Nilpotency (alternatively: identity is a inverse for [xorb]) *) Lemma xorb_nilpotent : forall b:bool, xorb b b = false. Proof. destr_bool. Qed. (** Commutativity *) Lemma xorb_comm : forall b b':bool, xorb b b' = xorb b' b. Proof. destr_bool. Qed. (** Associativity *) Lemma xorb_assoc_reverse : forall b b' b'':bool, xorb (xorb b b') b'' = xorb b (xorb b' b''). Proof. destr_bool. Qed. Notation xorb_assoc := xorb_assoc_reverse (only parsing). (* Compatibility *) Lemma xorb_eq : forall b b':bool, xorb b b' = false -> b = b'. Proof. destr_bool. Qed. Lemma xorb_move_l_r_1 : forall b b' b'':bool, xorb b b' = b'' -> b' = xorb b b''. Proof. destr_bool. Qed. Lemma xorb_move_l_r_2 : forall b b' b'':bool, xorb b b' = b'' -> b = xorb b'' b'. Proof. destr_bool. Qed. Lemma xorb_move_r_l_1 : forall b b' b'':bool, b = xorb b' b'' -> xorb b' b = b''. Proof. destr_bool. Qed. Lemma xorb_move_r_l_2 : forall b b' b'':bool, b = xorb b' b'' -> xorb b b'' = b'. Proof. destr_bool. Qed. Lemma negb_xorb_l : forall b b', negb (xorb b b') = xorb (negb b) b'. Proof. destruct b,b'; trivial. Qed. Lemma negb_xorb_r : forall b b', negb (xorb b b') = xorb b (negb b'). Proof. destruct b,b'; trivial. Qed. Lemma xorb_negb_negb : forall b b', xorb (negb b) (negb b') = xorb b b'. Proof. destruct b,b'; trivial. Qed. (** Lemmas about the [b = true] embedding of [bool] to [Prop] *) Lemma eq_iff_eq_true : forall b1 b2, b1 = b2 <-> (b1 = true <-> b2 = true). Proof. destr_bool; intuition. Qed. Lemma eq_true_iff_eq : forall b1 b2, (b1 = true <-> b2 = true) -> b1 = b2. Proof. apply eq_iff_eq_true. Qed. Notation bool_1 := eq_true_iff_eq (only parsing). (* Compatibility *) Lemma eq_true_negb_classical : forall b:bool, negb b <> true -> b = true. Proof. destr_bool; intuition. Qed. Notation bool_3 := eq_true_negb_classical (only parsing). (* Compatibility *) Lemma eq_true_not_negb : forall b:bool, b <> true -> negb b = true. Proof. destr_bool; intuition. Qed. Notation bool_6 := eq_true_not_negb (only parsing). (* Compatibility *) Hint Resolve eq_true_not_negb : bool. (* An interesting lemma for auto but too strong to keep compatibility *) Lemma absurd_eq_bool : forall b b':bool, False -> b = b'. Proof. contradiction. Qed. (* A more specific one that preserves compatibility with old hint bool_3 *) Lemma absurd_eq_true : forall b, False -> b = true. Proof. contradiction. Qed. Hint Resolve absurd_eq_true. (* A specific instance of eq_trans that preserves compatibility with old hint bool_2 *) Lemma trans_eq_bool : forall x y z:bool, x = y -> y = z -> x = z. Proof. apply eq_trans. Qed. Hint Resolve trans_eq_bool. (*****************************************) (** * Reflection of [bool] into [Prop] *) (*****************************************) (** [Is_true] and equality *) Hint Unfold Is_true: bool. Lemma Is_true_eq_true : forall x:bool, Is_true x -> x = true. Proof. destr_bool; tauto. Qed. Lemma Is_true_eq_left : forall x:bool, x = true -> Is_true x. Proof. intros; subst; auto with bool. Qed. Lemma Is_true_eq_right : forall x:bool, true = x -> Is_true x. Proof. intros; subst; auto with bool. Qed. Notation Is_true_eq_true2 := Is_true_eq_right (only parsing). Hint Immediate Is_true_eq_right Is_true_eq_left: bool. Lemma eqb_refl : forall x:bool, Is_true (eqb x x). Proof. destr_bool. Qed. Lemma eqb_eq : forall x y:bool, Is_true (eqb x y) -> x = y. Proof. destr_bool; tauto. Qed. (** [Is_true] and connectives *) Lemma orb_prop_elim : forall a b:bool, Is_true (a || b) -> Is_true a \/ Is_true b. Proof. destr_bool; tauto. Qed. Notation orb_prop2 := orb_prop_elim (only parsing). Lemma orb_prop_intro : forall a b:bool, Is_true a \/ Is_true b -> Is_true (a || b). Proof. destr_bool; tauto. Qed. Lemma andb_prop_intro : forall b1 b2:bool, Is_true b1 /\ Is_true b2 -> Is_true (b1 && b2). Proof. destr_bool; tauto. Qed. Hint Resolve andb_prop_intro: bool v62. Notation andb_true_intro2 := (fun b1 b2 H1 H2 => andb_prop_intro b1 b2 (conj H1 H2)) (only parsing). Lemma andb_prop_elim : forall a b:bool, Is_true (a && b) -> Is_true a /\ Is_true b. Proof. destr_bool; auto. Qed. Hint Resolve andb_prop_elim: bool v62. Notation andb_prop2 := andb_prop_elim (only parsing). Lemma eq_bool_prop_intro : forall b1 b2, (Is_true b1 <-> Is_true b2) -> b1 = b2. Proof. destr_bool; tauto. Qed. Lemma eq_bool_prop_elim : forall b1 b2, b1 = b2 -> (Is_true b1 <-> Is_true b2). Proof. destr_bool; tauto. Qed. Lemma negb_prop_elim : forall b, Is_true (negb b) -> ~ Is_true b. Proof. destr_bool; tauto. Qed. Lemma negb_prop_intro : forall b, ~ Is_true b -> Is_true (negb b). Proof. destr_bool; tauto. Qed. Lemma negb_prop_classical : forall b, ~ Is_true (negb b) -> Is_true b. Proof. destr_bool; tauto. Qed. Lemma negb_prop_involutive : forall b, Is_true b -> ~ Is_true (negb b). Proof. destr_bool; tauto. Qed. (** Rewrite rules about andb, orb and if (used in romega) *) Lemma andb_if : forall (A:Type)(a a':A)(b b' : bool), (if b && b' then a else a') = (if b then if b' then a else a' else a'). Proof. destr_bool. Qed. Lemma negb_if : forall (A:Type)(a a':A)(b:bool), (if negb b then a else a') = (if b then a' else a). Proof. destr_bool. Qed. (*****************************************) (** * Alternative versions of [andb] and [orb] with lazy behavior (for vm_compute) *) (*****************************************) Notation "a &&& b" := (if a then b else false) (at level 40, left associativity) : lazy_bool_scope. Notation "a ||| b" := (if a then true else b) (at level 50, left associativity) : lazy_bool_scope. Local Open Scope lazy_bool_scope. Lemma andb_lazy_alt : forall a b : bool, a && b = a &&& b. Proof. reflexivity. Qed. Lemma orb_lazy_alt : forall a b : bool, a || b = a ||| b. Proof. reflexivity. Qed. (*****************************************) (** * Reflect: a specialized inductive type for relating propositions and booleans, as popularized by the Ssreflect library. *) (*****************************************) Inductive reflect (P : Prop) : bool -> Set := | ReflectT : P -> reflect P true | ReflectF : ~ P -> reflect P false. Hint Constructors reflect : bool. (** Interest: a case on a reflect lemma or hyp performs clever unification, and leave the goal in a convenient shape (a bit like case_eq). *) (** Relation with iff : *) Lemma reflect_iff : forall P b, reflect P b -> (P<->b=true). Proof. destruct 1; intuition; discriminate. Qed. Lemma iff_reflect : forall P b, (P<->b=true) -> reflect P b. Proof. destr_bool; intuition. Defined. (** It would be nice to join [reflect_iff] and [iff_reflect] in a unique [iff] statement, but this isn't allowed since [iff] is in Prop. *) (** Reflect implies decidability of the proposition *) Lemma reflect_dec : forall P b, reflect P b -> {P}+{~P}. Proof. destruct 1; auto. Defined. (** Reciprocally, from a decidability, we could state a [reflect] as soon as we have a [bool_of_sumbool]. *) coq-8.4pl4/theories/Bool/DecBool.v0000644000175000017500000000176212326224777016054 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* forall x y:C, ifdec H x y = x. Proof. intros; case H; auto. intro; absurd B; trivial. Qed. Theorem ifdec_right : forall (A B:Prop) (C:Set) (H:{A} + {B}), ~ A -> forall x y:C, ifdec H x y = y. Proof. intros; case H; auto. intro; absurd A; trivial. Qed. Unset Implicit Arguments. coq-8.4pl4/theories/Bool/vo.itarget0000644000175000017500000000010612326224777016352 0ustar stephstephBoolEq.vo Bool.vo Bvector.vo DecBool.vo IfProp.vo Sumbool.vo Zerob.vo coq-8.4pl4/theories/Bool/Bvector.v0000644000175000017500000000655412326224777016155 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bv | S p' => BshiftL n (BshiftL_iter n bv p') false end. Fixpoint BshiftRl_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) := match p with | O => bv | S p' => BshiftRl n (BshiftRl_iter n bv p') false end. Fixpoint BshiftRa_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) := match p with | O => bv | S p' => BshiftRa n (BshiftRa_iter n bv p') end. End BOOLEAN_VECTORS. coq-8.4pl4/theories/Bool/Sumbool.v0000644000175000017500000000416612326224777016166 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Set), (b = true -> P true) -> (b = false -> P false) -> P b. destruct b; auto. Defined. Definition bool_eq_ind : forall (b:bool) (P:bool -> Prop), (b = true -> P true) -> (b = false -> P false) -> P b. destruct b; auto. Defined. (** Logic connectives on type [sumbool] *) Section connectives. Variables A B C D : Prop. Hypothesis H1 : {A} + {B}. Hypothesis H2 : {C} + {D}. Definition sumbool_and : {A /\ C} + {B \/ D}. case H1; case H2; auto. Defined. Definition sumbool_or : {A \/ C} + {B /\ D}. case H1; case H2; auto. Defined. Definition sumbool_not : {B} + {A}. case H1; auto. Defined. End connectives. Hint Resolve sumbool_and sumbool_or: core. Hint Immediate sumbool_not : core. (** Any decidability function in type [sumbool] can be turned into a function returning a boolean with the corresponding specification: *) Definition bool_of_sumbool : forall A B:Prop, {A} + {B} -> {b : bool | if b then A else B}. intros A B H. elim H; intro; [exists true | exists false]; assumption. Defined. Arguments bool_of_sumbool : default implicits. coq-8.4pl4/theories/Bool/BoolEq.v0000644000175000017500000000361012326224777015720 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* A -> bool. Variable beq_refl : forall x:A, true = beq x x. Variable beq_eq : forall x y:A, true = beq x y -> x = y. Definition beq_eq_true : forall x y:A, x = y -> true = beq x y. Proof. intros x y H. case H. apply beq_refl. Defined. Definition beq_eq_not_false : forall x y:A, x = y -> false <> beq x y. Proof. intros x y e. rewrite <- beq_eq_true; trivial; discriminate. Defined. Definition beq_false_not_eq : forall x y:A, false = beq x y -> x <> y. Proof. exact (fun (x y:A) (H:false = beq x y) (e:x = y) => beq_eq_not_false x y e H). Defined. Definition exists_beq_eq : forall x y:A, {b : bool | b = beq x y}. Proof. intros. exists (beq x y). constructor. Defined. Definition not_eq_false_beq : forall x y:A, x <> y -> false = beq x y. Proof. intros x y H. symmetry . apply not_true_is_false. intro. apply H. apply beq_eq. symmetry . assumption. Defined. Definition eq_dec : forall x y:A, {x = y} + {x <> y}. Proof. intros x y; case (exists_beq_eq x y). intros b; case b; intro H. left; apply beq_eq; assumption. right; apply beq_false_not_eq; assumption. Defined. End Bool_eq_dec. coq-8.4pl4/theories/Bool/Zerob.v0000644000175000017500000000241612326224777015623 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | S _ => false end. Lemma zerob_true_intro : forall n:nat, n = 0 -> zerob n = true. Proof. destruct n; [ trivial with bool | inversion 1 ]. Qed. Hint Resolve zerob_true_intro: bool. Lemma zerob_true_elim : forall n:nat, zerob n = true -> n = 0. Proof. destruct n; [ trivial with bool | inversion 1 ]. Qed. Lemma zerob_false_intro : forall n:nat, n <> 0 -> zerob n = false. Proof. destruct n; [ destruct 1; auto with bool | trivial with bool ]. Qed. Hint Resolve zerob_false_intro: bool. Lemma zerob_false_elim : forall n:nat, zerob n = false -> n <> 0. Proof. destruct n; [ inversion 1 | auto with bool ]. Qed. coq-8.4pl4/theories/Bool/IfProp.v0000644000175000017500000000273512326224777015745 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Prop := | Iftrue : A -> IfProp A B true | Iffalse : B -> IfProp A B false. Hint Resolve Iftrue Iffalse: bool v62. Lemma Iftrue_inv : forall (A B:Prop) (b:bool), IfProp A B b -> b = true -> A. destruct 1; intros; auto with bool. case diff_true_false; auto with bool. Qed. Lemma Iffalse_inv : forall (A B:Prop) (b:bool), IfProp A B b -> b = false -> B. destruct 1; intros; auto with bool. case diff_true_false; trivial with bool. Qed. Lemma IfProp_true : forall A B:Prop, IfProp A B true -> A. intros. inversion H. assumption. Qed. Lemma IfProp_false : forall A B:Prop, IfProp A B false -> B. intros. inversion H. assumption. Qed. Lemma IfProp_or : forall (A B:Prop) (b:bool), IfProp A B b -> A \/ B. destruct 1; auto with bool. Qed. Lemma IfProp_sum : forall (A B:Prop) (b:bool), IfProp A B b -> {A} + {B}. destruct b; intro H. left; inversion H; auto with bool. right; inversion H; auto with bool. Qed. coq-8.4pl4/theories/Bool/intro.tex0000644000175000017500000000110412326224777016221 0ustar stephsteph\section{Bool}\label{Bool} The BOOL library includes the following files: \begin{itemize} \item {\tt Bool.v} defines standard operations on booleans and states and proves simple facts on them. \item {\tt IfProp.v} defines a disjunction which contains its proof and states its properties. \item {\tt Zerob.v} defines the test against 0 on natural numbers and states and proves properties of it. \item {\tt Orb.v} states and proves facts on the boolean or. \item {\tt DecBool.v} defines a conditional from a proof of decidability and states its properties. \end{itemize} coq-8.4pl4/theories/Sets/0000755000175000017500000000000012365131022014352 5ustar stephstephcoq-8.4pl4/theories/Sets/Ensembles.v0000644000175000017500000000766012326224777016510 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Prop. Definition In (A:Ensemble) (x:U) : Prop := A x. Definition Included (B C:Ensemble) : Prop := forall x:U, In B x -> In C x. Inductive Empty_set : Ensemble :=. Inductive Full_set : Ensemble := Full_intro : forall x:U, In Full_set x. (** NB: The following definition builds-in equality of elements in [U] as Leibniz equality. This may have to be changed if we replace [U] by a Setoid on [U] with its own equality [eqs], with [In_singleton: (y: U)(eqs x y) -> (In (Singleton x) y)]. *) Inductive Singleton (x:U) : Ensemble := In_singleton : In (Singleton x) x. Inductive Union (B C:Ensemble) : Ensemble := | Union_introl : forall x:U, In B x -> In (Union B C) x | Union_intror : forall x:U, In C x -> In (Union B C) x. Definition Add (B:Ensemble) (x:U) : Ensemble := Union B (Singleton x). Inductive Intersection (B C:Ensemble) : Ensemble := Intersection_intro : forall x:U, In B x -> In C x -> In (Intersection B C) x. Inductive Couple (x y:U) : Ensemble := | Couple_l : In (Couple x y) x | Couple_r : In (Couple x y) y. Inductive Triple (x y z:U) : Ensemble := | Triple_l : In (Triple x y z) x | Triple_m : In (Triple x y z) y | Triple_r : In (Triple x y z) z. Definition Complement (A:Ensemble) : Ensemble := fun x:U => ~ In A x. Definition Setminus (B C:Ensemble) : Ensemble := fun x:U => In B x /\ ~ In C x. Definition Subtract (B:Ensemble) (x:U) : Ensemble := Setminus B (Singleton x). Inductive Disjoint (B C:Ensemble) : Prop := Disjoint_intro : (forall x:U, ~ In (Intersection B C) x) -> Disjoint B C. Inductive Inhabited (B:Ensemble) : Prop := Inhabited_intro : forall x:U, In B x -> Inhabited B. Definition Strict_Included (B C:Ensemble) : Prop := Included B C /\ B <> C. Definition Same_set (B C:Ensemble) : Prop := Included B C /\ Included C B. (** Extensionality Axiom *) Axiom Extensionality_Ensembles : forall A B:Ensemble, Same_set A B -> A = B. End Ensembles. Hint Unfold In Included Same_set Strict_Included Add Setminus Subtract: sets v62. Hint Resolve Union_introl Union_intror Intersection_intro In_singleton Couple_l Couple_r Triple_l Triple_m Triple_r Disjoint_intro Extensionality_Ensembles: sets v62. coq-8.4pl4/theories/Sets/Relations_2.v0000644000175000017500000000465112326224777016751 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Prop := | Rstar_0 : Rstar x x | Rstar_n : forall y z:U, R x y -> Rstar y z -> Rstar x z. Inductive Rstar1 (x:U) : U -> Prop := | Rstar1_0 : Rstar1 x x | Rstar1_1 : forall y:U, R x y -> Rstar1 x y | Rstar1_n : forall y z:U, Rstar1 x y -> Rstar1 y z -> Rstar1 x z. Inductive Rplus (x:U) : U -> Prop := | Rplus_0 : forall y:U, R x y -> Rplus x y | Rplus_n : forall y z:U, R x y -> Rplus y z -> Rplus x z. Definition Strongly_confluent : Prop := forall x a b:U, R x a -> R x b -> ex (fun z:U => R a z /\ R b z). End Relations_2. Hint Resolve Rstar_0: sets v62. Hint Resolve Rstar1_0: sets v62. Hint Resolve Rstar1_1: sets v62. Hint Resolve Rplus_0: sets v62. coq-8.4pl4/theories/Sets/Relations_1.v0000644000175000017500000000552612326224777016752 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* U -> Prop. Variable R : Relation. Definition Reflexive : Prop := forall x:U, R x x. Definition Transitive : Prop := forall x y z:U, R x y -> R y z -> R x z. Definition Symmetric : Prop := forall x y:U, R x y -> R y x. Definition Antisymmetric : Prop := forall x y:U, R x y -> R y x -> x = y. Definition contains (R R':Relation) : Prop := forall x y:U, R' x y -> R x y. Definition same_relation (R R':Relation) : Prop := contains R R' /\ contains R' R. Inductive Preorder : Prop := Definition_of_preorder : Reflexive -> Transitive -> Preorder. Inductive Order : Prop := Definition_of_order : Reflexive -> Transitive -> Antisymmetric -> Order. Inductive Equivalence : Prop := Definition_of_equivalence : Reflexive -> Transitive -> Symmetric -> Equivalence. Inductive PER : Prop := Definition_of_PER : Symmetric -> Transitive -> PER. End Relations_1. Hint Unfold Reflexive Transitive Antisymmetric Symmetric contains same_relation: sets v62. Hint Resolve Definition_of_preorder Definition_of_order Definition_of_equivalence Definition_of_PER: sets v62. coq-8.4pl4/theories/Sets/Image.v0000644000175000017500000001602012326224777015603 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* V) : Ensemble V := Im_intro : forall x:U, In _ X x -> forall y:V, y = f x -> In _ (Im X f) y. Lemma Im_def : forall (X:Ensemble U) (f:U -> V) (x:U), In _ X x -> In _ (Im X f) (f x). Proof. intros X f x H'; try assumption. apply Im_intro with (x := x); auto with sets. Qed. Lemma Im_add : forall (X:Ensemble U) (x:U) (f:U -> V), Im (Add _ X x) f = Add _ (Im X f) (f x). Proof. intros X x f. apply Extensionality_Ensembles. split; red; intros x0 H'. elim H'; intros. rewrite H0. elim Add_inv with U X x x1; auto using Im_def with sets. destruct 1; auto using Im_def with sets. elim Add_inv with V (Im X f) (f x) x0. destruct 1 as [x0 H y H0]. rewrite H0; auto using Im_def with sets. destruct 1; auto using Im_def with sets. trivial. Qed. Lemma image_empty : forall f:U -> V, Im (Empty_set U) f = Empty_set V. Proof. intro f; try assumption. apply Extensionality_Ensembles. split; auto with sets. red. intros x H'; elim H'. intros x0 H'0; elim H'0; auto with sets. Qed. Lemma finite_image : forall (X:Ensemble U) (f:U -> V), Finite _ X -> Finite _ (Im X f). Proof. intros X f H'; elim H'. rewrite (image_empty f); auto with sets. intros A H'0 H'1 x H'2; clear H' X. rewrite (Im_add A x f); auto with sets. apply Add_preserves_Finite; auto with sets. Qed. Lemma Im_inv : forall (X:Ensemble U) (f:U -> V) (y:V), In _ (Im X f) y -> exists x : U, In _ X x /\ f x = y. Proof. intros X f y H'; elim H'. intros x H'0 y0 H'1; rewrite H'1. exists x; auto with sets. Qed. Definition injective (f:U -> V) := forall x y:U, f x = f y -> x = y. Lemma not_injective_elim : forall f:U -> V, ~ injective f -> exists x : _, (exists y : _, f x = f y /\ x <> y). Proof. unfold injective; intros f H. cut (exists x : _, ~ (forall y:U, f x = f y -> x = y)). 2: apply not_all_ex_not with (P := fun x:U => forall y:U, f x = f y -> x = y); trivial with sets. destruct 1 as [x C]; exists x. cut (exists y : _, ~ (f x = f y -> x = y)). 2: apply not_all_ex_not with (P := fun y:U => f x = f y -> x = y); trivial with sets. destruct 1 as [y D]; exists y. apply imply_to_and; trivial with sets. Qed. Lemma cardinal_Im_intro : forall (A:Ensemble U) (f:U -> V) (n:nat), cardinal _ A n -> exists p : nat, cardinal _ (Im A f) p. Proof. intros. apply finite_cardinal; apply finite_image. apply cardinal_finite with n; trivial with sets. Qed. Lemma In_Image_elim : forall (A:Ensemble U) (f:U -> V), injective f -> forall x:U, In _ (Im A f) (f x) -> In _ A x. Proof. intros. elim Im_inv with A f (f x); trivial with sets. intros z C; elim C; intros InAz E. elim (H z x E); trivial with sets. Qed. Lemma injective_preserves_cardinal : forall (A:Ensemble U) (f:U -> V) (n:nat), injective f -> cardinal _ A n -> forall n':nat, cardinal _ (Im A f) n' -> n' = n. Proof. induction 2 as [| A n H'0 H'1 x H'2]; auto with sets. rewrite (image_empty f). intros n' CE. apply cardinal_unicity with V (Empty_set V); auto with sets. intro n'. rewrite (Im_add A x f). intro H'3. elim cardinal_Im_intro with A f n; trivial with sets. intros i CI. lapply (H'1 i); trivial with sets. cut (~ In _ (Im A f) (f x)). intros H0 H1. apply cardinal_unicity with V (Add _ (Im A f) (f x)); trivial with sets. apply card_add; auto with sets. rewrite <- H1; trivial with sets. red; intro; apply H'2. apply In_Image_elim with f; trivial with sets. Qed. Lemma cardinal_decreases : forall (A:Ensemble U) (f:U -> V) (n:nat), cardinal U A n -> forall n':nat, cardinal V (Im A f) n' -> n' <= n. Proof. induction 1 as [| A n H'0 H'1 x H'2]; auto with sets. rewrite (image_empty f); intros. cut (n' = 0). intro E; rewrite E; trivial with sets. apply cardinal_unicity with V (Empty_set V); auto with sets. intro n'. rewrite (Im_add A x f). elim cardinal_Im_intro with A f n; trivial with sets. intros p C H'3. apply le_trans with (S p). apply card_Add_gen with V (Im A f) (f x); trivial with sets. apply le_n_S; auto with sets. Qed. Theorem Pigeonhole : forall (A:Ensemble U) (f:U -> V) (n:nat), cardinal U A n -> forall n':nat, cardinal V (Im A f) n' -> n' < n -> ~ injective f. Proof. unfold not; intros A f n CAn n' CIfn' ltn'n I. cut (n' = n). intro E; generalize ltn'n; rewrite E; exact (lt_irrefl n). apply injective_preserves_cardinal with (A := A) (f := f) (n := n); trivial with sets. Qed. Lemma Pigeonhole_principle : forall (A:Ensemble U) (f:U -> V) (n:nat), cardinal _ A n -> forall n':nat, cardinal _ (Im A f) n' -> n' < n -> exists x : _, (exists y : _, f x = f y /\ x <> y). Proof. intros; apply not_injective_elim. apply Pigeonhole with A n n'; trivial with sets. Qed. End Image. Hint Resolve Im_def image_empty finite_image: sets v62. coq-8.4pl4/theories/Sets/vo.itarget0000644000175000017500000000053412326224777016402 0ustar stephstephClassical_sets.vo Constructive_sets.vo Cpo.vo Ensembles.vo Finite_sets_facts.vo Finite_sets.vo Image.vo Infinite_sets.vo Integers.vo Multiset.vo Partial_Order.vo Permut.vo Powerset_Classical_facts.vo Powerset_facts.vo Powerset.vo Relations_1_facts.vo Relations_1.vo Relations_2_facts.vo Relations_2.vo Relations_3_facts.vo Relations_3.vo Uniset.vo coq-8.4pl4/theories/Sets/Constructive_sets.v0000644000175000017500000001153212326224777020312 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Same_set U B C. Proof. intros B C H'; rewrite H'; auto with sets. Qed. Lemma Noone_in_empty : forall x:U, ~ In U (Empty_set U) x. Proof. red; destruct 1. Qed. Lemma Included_Empty : forall A:Ensemble U, Included U (Empty_set U) A. Proof. intro; red. intros x H; elim (Noone_in_empty x); auto with sets. Qed. Lemma Add_intro1 : forall (A:Ensemble U) (x y:U), In U A y -> In U (Add U A x) y. Proof. unfold Add at 1; auto with sets. Qed. Lemma Add_intro2 : forall (A:Ensemble U) (x:U), In U (Add U A x) x. Proof. unfold Add at 1; auto with sets. Qed. Lemma Inhabited_add : forall (A:Ensemble U) (x:U), Inhabited U (Add U A x). Proof. intros A x. apply Inhabited_intro with (x := x); auto using Add_intro2 with sets. Qed. Lemma Inhabited_not_empty : forall X:Ensemble U, Inhabited U X -> X <> Empty_set U. Proof. intros X H'; elim H'. intros x H'0; red; intro H'1. absurd (In U X x); auto with sets. rewrite H'1; auto using Noone_in_empty with sets. Qed. Lemma Add_not_Empty : forall (A:Ensemble U) (x:U), Add U A x <> Empty_set U. Proof. intros A x; apply Inhabited_not_empty; apply Inhabited_add. Qed. Lemma not_Empty_Add : forall (A:Ensemble U) (x:U), Empty_set U <> Add U A x. Proof. intros; red; intro H; generalize (Add_not_Empty A x); auto with sets. Qed. Lemma Singleton_inv : forall x y:U, In U (Singleton U x) y -> x = y. Proof. intros x y H'; elim H'; trivial with sets. Qed. Lemma Singleton_intro : forall x y:U, x = y -> In U (Singleton U x) y. Proof. intros x y H'; rewrite H'; trivial with sets. Qed. Lemma Union_inv : forall (B C:Ensemble U) (x:U), In U (Union U B C) x -> In U B x \/ In U C x. Proof. intros B C x H'; elim H'; auto with sets. Qed. Lemma Add_inv : forall (A:Ensemble U) (x y:U), In U (Add U A x) y -> In U A y \/ x = y. Proof. intros A x y H'; induction H'. left; assumption. right; apply Singleton_inv; assumption. Qed. Lemma Intersection_inv : forall (B C:Ensemble U) (x:U), In U (Intersection U B C) x -> In U B x /\ In U C x. Proof. intros B C x H'; elim H'; auto with sets. Qed. Lemma Couple_inv : forall x y z:U, In U (Couple U x y) z -> z = x \/ z = y. Proof. intros x y z H'; elim H'; auto with sets. Qed. Lemma Setminus_intro : forall (A B:Ensemble U) (x:U), In U A x -> ~ In U B x -> In U (Setminus U A B) x. Proof. unfold Setminus at 1; red; auto with sets. Qed. Lemma Strict_Included_intro : forall X Y:Ensemble U, Included U X Y /\ X <> Y -> Strict_Included U X Y. Proof. auto with sets. Qed. Lemma Strict_Included_strict : forall X:Ensemble U, ~ Strict_Included U X X. Proof. intro X; red; intro H'; elim H'. intros H'0 H'1; elim H'1; auto with sets. Qed. End Ensembles_facts. Hint Resolve Singleton_inv Singleton_intro Add_intro1 Add_intro2 Intersection_inv Couple_inv Setminus_intro Strict_Included_intro Strict_Included_strict Noone_in_empty Inhabited_not_empty Add_not_Empty not_Empty_Add Inhabited_add Included_Empty: sets v62. coq-8.4pl4/theories/Sets/Classical_sets.v0000644000175000017500000001074712326224777017527 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Inhabited U A. Proof. intros A NI. elim (not_all_ex_not U (fun x:U => ~ In U A x)). intros x H; apply Inhabited_intro with x. apply NNPP; auto with sets. red; intro. apply NI; red. intros x H'; elim (H x); trivial with sets. Qed. Lemma not_empty_Inhabited : forall A:Ensemble U, A <> Empty_set U -> Inhabited U A. Proof. intros; apply not_included_empty_Inhabited. red; auto with sets. Qed. Lemma Inhabited_Setminus : forall X Y:Ensemble U, Included U X Y -> ~ Included U Y X -> Inhabited U (Setminus U Y X). Proof. intros X Y I NI. elim (not_all_ex_not U (fun x:U => In U Y x -> In U X x) NI). intros x YX. apply Inhabited_intro with x. apply Setminus_intro. apply not_imply_elim with (In U X x); trivial with sets. auto with sets. Qed. Lemma Strict_super_set_contains_new_element : forall X Y:Ensemble U, Included U X Y -> X <> Y -> Inhabited U (Setminus U Y X). Proof. auto 7 using Inhabited_Setminus with sets. Qed. Lemma Subtract_intro : forall (A:Ensemble U) (x y:U), In U A y -> x <> y -> In U (Subtract U A x) y. Proof. unfold Subtract at 1; auto with sets. Qed. Hint Resolve Subtract_intro : sets. Lemma Subtract_inv : forall (A:Ensemble U) (x y:U), In U (Subtract U A x) y -> In U A y /\ x <> y. Proof. intros A x y H'; elim H'; auto with sets. Qed. Lemma Included_Strict_Included : forall X Y:Ensemble U, Included U X Y -> Strict_Included U X Y \/ X = Y. Proof. intros X Y H'; try assumption. elim (classic (X = Y)); auto with sets. Qed. Lemma Strict_Included_inv : forall X Y:Ensemble U, Strict_Included U X Y -> Included U X Y /\ Inhabited U (Setminus U Y X). Proof. intros X Y H'; red in H'. split; [ tauto | idtac ]. elim H'; intros H'0 H'1; try exact H'1; clear H'. apply Strict_super_set_contains_new_element; auto with sets. Qed. Lemma not_SIncl_empty : forall X:Ensemble U, ~ Strict_Included U X (Empty_set U). Proof. intro X; red; intro H'; try exact H'. lapply (Strict_Included_inv X (Empty_set U)); auto with sets. intro H'0; elim H'0; intros H'1 H'2; elim H'2; clear H'0. intros x H'0; elim H'0. intro H'3; elim H'3. Qed. Lemma Complement_Complement : forall A:Ensemble U, Complement U (Complement U A) = A. Proof. unfold Complement; intros; apply Extensionality_Ensembles; auto with sets. red; split; auto with sets. red; intros; apply NNPP; auto with sets. Qed. End Ensembles_classical. Hint Resolve Strict_super_set_contains_new_element Subtract_intro not_SIncl_empty: sets v62. coq-8.4pl4/theories/Sets/Cpo.v0000644000175000017500000001013612326224777015304 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (forall y:U, In U B y -> R y x) -> Upper_Bound B x. Inductive Lower_Bound (B:Ensemble U) (x:U) : Prop := Lower_Bound_definition : In U C x -> (forall y:U, In U B y -> R x y) -> Lower_Bound B x. Inductive Lub (B:Ensemble U) (x:U) : Prop := Lub_definition : Upper_Bound B x -> (forall y:U, Upper_Bound B y -> R x y) -> Lub B x. Inductive Glb (B:Ensemble U) (x:U) : Prop := Glb_definition : Lower_Bound B x -> (forall y:U, Lower_Bound B y -> R y x) -> Glb B x. Inductive Bottom (bot:U) : Prop := Bottom_definition : In U C bot -> (forall y:U, In U C y -> R bot y) -> Bottom bot. Inductive Totally_ordered (B:Ensemble U) : Prop := Totally_ordered_definition : (Included U B C -> forall x y:U, Included U (Couple U x y) B -> R x y \/ R y x) -> Totally_ordered B. Definition Compatible : Relation U := fun x y:U => In U C x -> In U C y -> exists z : _, In U C z /\ Upper_Bound (Couple U x y) z. Inductive Directed (X:Ensemble U) : Prop := Definition_of_Directed : Included U X C -> Inhabited U X -> (forall x1 x2:U, Included U (Couple U x1 x2) X -> exists x3 : _, In U X x3 /\ Upper_Bound (Couple U x1 x2) x3) -> Directed X. Inductive Complete : Prop := Definition_of_Complete : (exists bot : _, Bottom bot) -> (forall X:Ensemble U, Directed X -> exists bsup : _, Lub X bsup) -> Complete. Inductive Conditionally_complete : Prop := Definition_of_Conditionally_complete : (forall X:Ensemble U, Included U X C -> (exists maj : _, Upper_Bound X maj) -> exists bsup : _, Lub X bsup) -> Conditionally_complete. End Bounds. Hint Resolve Totally_ordered_definition Upper_Bound_definition Lower_Bound_definition Lub_definition Glb_definition Bottom_definition Definition_of_Complete Definition_of_Complete Definition_of_Conditionally_complete. Section Specific_orders. Variable U : Type. Record Cpo : Type := Definition_of_cpo {PO_of_cpo : PO U; Cpo_cond : Complete U PO_of_cpo}. Record Chain : Type := Definition_of_chain {PO_of_chain : PO U; Chain_cond : Totally_ordered U PO_of_chain (Carrier_of U PO_of_chain)}. End Specific_orders. coq-8.4pl4/theories/Sets/Powerset_Classical_facts.v0000644000175000017500000002637512326224777021545 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Strict_Included U (Add U A x) (Add U B x) -> Strict_Included U A B. Proof. intros A B x H' H'0; red. lapply (Strict_Included_inv U (Add U A x) (Add U B x)); auto with sets. clear H'0; intro H'0; split. apply incl_add_x with (x := x); tauto. elim H'0; intros H'1 H'2; elim H'2; clear H'0 H'2. intros x0 H'0. red; intro H'2. elim H'0; clear H'0. rewrite <- H'2; auto with sets. Qed. Lemma incl_soustr_in : forall (X:Ensemble U) (x:U), In U X x -> Included U (Subtract U X x) X. Proof. intros X x H'; red. intros x0 H'0; elim H'0; auto with sets. Qed. Lemma incl_soustr : forall (X Y:Ensemble U) (x:U), Included U X Y -> Included U (Subtract U X x) (Subtract U Y x). Proof. intros X Y x H'; red. intros x0 H'0; elim H'0. intros H'1 H'2. apply Subtract_intro; auto with sets. Qed. Lemma incl_soustr_add_l : forall (X:Ensemble U) (x:U), Included U (Subtract U (Add U X x) x) X. Proof. intros X x; red. intros x0 H'; elim H'; auto with sets. intro H'0; elim H'0; auto with sets. intros t H'1 H'2; elim H'2; auto with sets. Qed. Lemma incl_soustr_add_r : forall (X:Ensemble U) (x:U), ~ In U X x -> Included U X (Subtract U (Add U X x) x). Proof. intros X x H'; red. intros x0 H'0; try assumption. apply Subtract_intro; auto with sets. red; intro H'1; apply H'; rewrite H'1; auto with sets. Qed. Hint Resolve incl_soustr_add_r: sets v62. Lemma add_soustr_2 : forall (X:Ensemble U) (x:U), In U X x -> Included U X (Add U (Subtract U X x) x). Proof. intros X x H'; red. intros x0 H'0; try assumption. elim (classic (x = x0)); intro K; auto with sets. elim K; auto with sets. Qed. Lemma add_soustr_1 : forall (X:Ensemble U) (x:U), In U X x -> Included U (Add U (Subtract U X x) x) X. Proof. intros X x H'; red. intros x0 H'0; elim H'0; auto with sets. intros y H'1; elim H'1; auto with sets. intros t H'1; try assumption. rewrite <- (Singleton_inv U x t); auto with sets. Qed. Lemma add_soustr_xy : forall (X:Ensemble U) (x y:U), x <> y -> Subtract U (Add U X x) y = Add U (Subtract U X y) x. Proof. intros X x y H'; apply Extensionality_Ensembles. split; red. intros x0 H'0; elim H'0; auto with sets. intro H'1; elim H'1. intros u H'2 H'3; try assumption. apply Add_intro1. apply Subtract_intro; auto with sets. intros t H'2 H'3; try assumption. elim (Singleton_inv U x t); auto with sets. intros u H'2; try assumption. elim (Add_inv U (Subtract U X y) x u); auto with sets. intro H'0; elim H'0; auto with sets. intro H'0; rewrite <- H'0; auto with sets. Qed. Lemma incl_st_add_soustr : forall (X Y:Ensemble U) (x:U), ~ In U X x -> Strict_Included U (Add U X x) Y -> Strict_Included U X (Subtract U Y x). Proof. intros X Y x H' H'0; apply sincl_add_x with (x := x); auto using add_soustr_1 with sets. split. elim H'0. intros H'1 H'2. generalize (Inclusion_is_transitive U). intro H'4; red in H'4. apply H'4 with (y := Y); auto using add_soustr_2 with sets. red in H'0. elim H'0; intros H'1 H'2; try exact H'1; clear H'0. (* PB *) red; intro H'0; apply H'2. rewrite H'0; auto 8 using add_soustr_xy, add_soustr_1, add_soustr_2 with sets. Qed. Lemma Sub_Add_new : forall (X:Ensemble U) (x:U), ~ In U X x -> X = Subtract U (Add U X x) x. Proof. auto using incl_soustr_add_l with sets. Qed. Lemma Simplify_add : forall (X X0:Ensemble U) (x:U), ~ In U X x -> ~ In U X0 x -> Add U X x = Add U X0 x -> X = X0. Proof. intros X X0 x H' H'0 H'1; try assumption. rewrite (Sub_Add_new X x); auto with sets. rewrite (Sub_Add_new X0 x); auto with sets. rewrite H'1; auto with sets. Qed. Lemma Included_Add : forall (X A:Ensemble U) (x:U), Included U X (Add U A x) -> Included U X A \/ (exists A' : _, X = Add U A' x /\ Included U A' A). Proof. intros X A x H'0; try assumption. elim (classic (In U X x)). intro H'1; right; try assumption. exists (Subtract U X x). split; auto using incl_soustr_in, add_soustr_xy, add_soustr_1, add_soustr_2 with sets. red in H'0. red. intros x0 H'2; try assumption. lapply (Subtract_inv U X x x0); auto with sets. intro H'3; elim H'3; intros K K'; clear H'3. lapply (H'0 x0); auto with sets. intro H'3; try assumption. lapply (Add_inv U A x x0); auto with sets. intro H'4; elim H'4; [ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ]. elim K'; auto with sets. intro H'1; left; try assumption. red in H'0. red. intros x0 H'2; try assumption. lapply (H'0 x0); auto with sets. intro H'3; try assumption. lapply (Add_inv U A x x0); auto with sets. intro H'4; elim H'4; [ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ]. absurd (In U X x0); auto with sets. rewrite <- H'5; auto with sets. Qed. Lemma setcover_inv : forall A x y:Ensemble U, covers (Ensemble U) (Power_set_PO U A) y x -> Strict_Included U x y /\ (forall z:Ensemble U, Included U x z -> Included U z y -> x = z \/ z = y). Proof. intros A x y H'; elim H'. unfold Strict_Rel_of; simpl. intros H'0 H'1; split; [ auto with sets | idtac ]. intros z H'2 H'3; try assumption. elim (classic (x = z)); auto with sets. intro H'4; right; try assumption. elim (classic (z = y)); auto with sets. intro H'5; try assumption. elim H'1. exists z; auto with sets. Qed. Theorem Add_covers : forall A a:Ensemble U, Included U a A -> forall x:U, In U A x -> ~ In U a x -> covers (Ensemble U) (Power_set_PO U A) (Add U a x) a. Proof. intros A a H' x H'0 H'1; try assumption. apply setcover_intro; auto with sets. red. split; [ idtac | red; intro H'2; try exact H'2 ]; auto with sets. apply H'1. rewrite H'2; auto with sets. red; intro H'2; elim H'2; clear H'2. intros z H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2. lapply (Strict_Included_inv U a z); auto with sets; clear H'3. intro H'2; elim H'2; intros H'3 H'5; elim H'5; clear H'2 H'5. intros x0 H'2; elim H'2. intros H'5 H'6; try assumption. generalize H'4; intro K. red in H'4. elim H'4; intros H'8 H'9; red in H'8; clear H'4. lapply (H'8 x0); auto with sets. intro H'7; try assumption. elim (Add_inv U a x x0); auto with sets. intro H'15. cut (Included U (Add U a x) z). intro H'10; try assumption. red in K. elim K; intros H'11 H'12; apply H'12; clear K; auto with sets. rewrite H'15. red. intros x1 H'10; elim H'10; auto with sets. intros x2 H'11; elim H'11; auto with sets. Qed. Theorem covers_Add : forall A a a':Ensemble U, Included U a A -> Included U a' A -> covers (Ensemble U) (Power_set_PO U A) a' a -> exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x. Proof. intros A a a' H' H'0 H'1; try assumption. elim (setcover_inv A a a'); auto with sets. intros H'6 H'7. clear H'1. elim (Strict_Included_inv U a a'); auto with sets. intros H'5 H'8; elim H'8. intros x H'1; elim H'1. intros H'2 H'3; try assumption. exists x. split; [ try assumption | idtac ]. clear H'8 H'1. elim (H'7 (Add U a x)); auto with sets. intro H'1. absurd (a = Add U a x); auto with sets. red; intro H'8; try exact H'8. apply H'3. rewrite H'8; auto with sets. auto with sets. red. intros x0 H'1; elim H'1; auto with sets. intros x1 H'8; elim H'8; auto with sets. split; [ idtac | try assumption ]. red in H'0; auto with sets. Qed. Theorem covers_is_Add : forall A a a':Ensemble U, Included U a A -> Included U a' A -> (covers (Ensemble U) (Power_set_PO U A) a' a <-> (exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x)). Proof. intros A a a' H' H'0; split; intro K. apply covers_Add with (A := A); auto with sets. elim K. intros x H'1; elim H'1; intros H'2 H'3; rewrite H'2; clear H'1. apply Add_covers; intuition. Qed. Theorem Singleton_atomic : forall (x:U) (A:Ensemble U), In U A x -> covers (Ensemble U) (Power_set_PO U A) (Singleton U x) (Empty_set U). Proof. intros x A H'. rewrite <- (Empty_set_zero' U x). apply Add_covers; auto with sets. Qed. Lemma less_than_singleton : forall (X:Ensemble U) (x:U), Strict_Included U X (Singleton U x) -> X = Empty_set U. Proof. intros X x H'; try assumption. red in H'. lapply (Singleton_atomic x (Full_set U)); [ intro H'2; try exact H'2 | apply Full_intro ]. elim H'; intros H'0 H'1; try exact H'1; clear H'. elim (setcover_inv (Full_set U) (Empty_set U) (Singleton U x)); [ intros H'6 H'7; try exact H'7 | idtac ]; auto with sets. elim (H'7 X); [ intro H'5; try exact H'5 | intro H'5 | idtac | idtac ]; auto with sets. elim H'1; auto with sets. Qed. End Sets_as_an_algebra. Hint Resolve incl_soustr_in: sets v62. Hint Resolve incl_soustr: sets v62. Hint Resolve incl_soustr_add_l: sets v62. Hint Resolve incl_soustr_add_r: sets v62. Hint Resolve add_soustr_1 add_soustr_2: sets v62. Hint Resolve add_soustr_xy: sets v62. coq-8.4pl4/theories/Sets/Integers.v0000644000175000017500000001232012326224777016340 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* exists m : nat, Upper_Bound nat nat_po X m. Proof. intros X H'; elim H'. exists 0. apply Upper_Bound_definition. unfold nat_po. simpl. apply triv_nat. intros y H'0; elim H'0; auto with sets arith. intros A H'0 H'1 x H'2; try assumption. elim H'1; intros x0 H'3; clear H'1. elim le_total_order. simpl. intro H'1; try assumption. lapply H'1; [ intro H'4; idtac | try assumption ]; auto with sets arith. generalize (H'4 x0 x). clear H'4. clear H'1. intro H'1; lapply H'1; [ intro H'4; elim H'4; [ intro H'5; try exact H'5; clear H'4 H'1 | intro H'5; clear H'4 H'1 ] | clear H'1 ]. exists x. apply Upper_Bound_definition. simpl. apply triv_nat. intros y H'1; elim H'1. generalize le_trans. intro H'4; red in H'4. intros x1 H'6; try assumption. apply H'4 with (y := x0). elim H'3; simpl; auto with sets arith. trivial. intros x1 H'4; elim H'4. unfold nat_po; simpl; trivial. exists x0. apply Upper_Bound_definition. unfold nat_po. simpl. apply triv_nat. intros y H'1; elim H'1. intros x1 H'4; try assumption. elim H'3; simpl; auto with sets arith. intros x1 H'4; elim H'4; auto with sets arith. red. intros x1 H'1; elim H'1; apply triv_nat. Qed. Lemma Integers_has_no_ub : ~ (exists m : nat, Upper_Bound nat nat_po Integers m). Proof. red; intro H'; elim H'. intros x H'0. elim H'0; intros H'1 H'2. cut (In nat Integers (S x)). intro H'3. specialize H'2 with (y := S x); lapply H'2; [ intro H'5; clear H'2 | try assumption; clear H'2 ]. simpl in H'5. absurd (S x <= x); auto with arith. apply triv_nat. Qed. Lemma Integers_infinite : ~ Finite nat Integers. Proof. generalize Integers_has_no_ub. intro H'; red; intro H'0; try exact H'0. apply H'. apply Finite_subset_has_lub; auto with sets arith. Qed. End Integers_sect. coq-8.4pl4/theories/Sets/Finite_sets_facts.v0000644000175000017500000002757312326224777020234 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* exists n : nat, cardinal U X n. Proof. induction 1 as [| A _ [n H]]. exists 0; auto with sets. exists (S n); auto with sets. Qed. Lemma cardinal_finite : forall (X:Ensemble U) (n:nat), cardinal U X n -> Finite U X. Proof. induction 1; auto with sets. Qed. Theorem Add_preserves_Finite : forall (X:Ensemble U) (x:U), Finite U X -> Finite U (Add U X x). Proof. intros X x H'. elim (classic (In U X x)); intro H'0; auto with sets. rewrite (Non_disjoint_union U X x); auto with sets. Qed. Theorem Singleton_is_finite : forall x:U, Finite U (Singleton U x). Proof. intro x; rewrite <- (Empty_set_zero U (Singleton U x)). change (Finite U (Add U (Empty_set U) x)); auto with sets. Qed. Theorem Union_preserves_Finite : forall X Y:Ensemble U, Finite U X -> Finite U Y -> Finite U (Union U X Y). Proof. intros X Y H; induction H as [|A Fin_A Hind x]. rewrite (Empty_set_zero U Y). trivial. intros. rewrite (Union_commutative U (Add U A x) Y). rewrite <- (Union_add U Y A x). rewrite (Union_commutative U Y A). apply Add_preserves_Finite. apply Hind. assumption. Qed. Lemma Finite_downward_closed : forall A:Ensemble U, Finite U A -> forall X:Ensemble U, Included U X A -> Finite U X. Proof. intros A H'; elim H'; auto with sets. intros X H'0. rewrite (less_than_empty U X H'0); auto with sets. intros; elim Included_Add with U X A0 x; auto with sets. destruct 1 as [A' [H5 H6]]. rewrite H5; auto with sets. Qed. Lemma Intersection_preserves_finite : forall A:Ensemble U, Finite U A -> forall X:Ensemble U, Finite U (Intersection U X A). Proof. intros A H' X; apply Finite_downward_closed with A; auto with sets. Qed. Lemma cardinalO_empty : forall X:Ensemble U, cardinal U X 0 -> X = Empty_set U. Proof. intros X H; apply (cardinal_invert U X 0); trivial with sets. Qed. Lemma inh_card_gt_O : forall X:Ensemble U, Inhabited U X -> forall n:nat, cardinal U X n -> n > 0. Proof. induction 1 as [x H']. intros n H'0. elim (gt_O_eq n); auto with sets. intro H'1; generalize H'; generalize H'0. rewrite <- H'1; intro H'2. rewrite (cardinalO_empty X); auto with sets. intro H'3; elim H'3. Qed. Lemma card_soustr_1 : forall (X:Ensemble U) (n:nat), cardinal U X n -> forall x:U, In U X x -> cardinal U (Subtract U X x) (pred n). Proof. intros X n H'; elim H'. intros x H'0; elim H'0. clear H' n X. intros X n H' H'0 x H'1 x0 H'2. elim (classic (In U X x0)). intro H'4; rewrite (add_soustr_xy U X x x0). elim (classic (x = x0)). intro H'5. absurd (In U X x0); auto with sets. rewrite <- H'5; auto with sets. intro H'3; try assumption. cut (S (pred n) = pred (S n)). intro H'5; rewrite <- H'5. apply card_add; auto with sets. red; intro H'6; elim H'6. intros H'7 H'8; try assumption. elim H'1; auto with sets. unfold pred at 2; symmetry . apply S_pred with (m := 0). change (n > 0). apply inh_card_gt_O with (X := X); auto with sets. apply Inhabited_intro with (x := x0); auto with sets. red; intro H'3. apply H'1. elim H'3; auto with sets. rewrite H'3; auto with sets. elim (classic (x = x0)). intro H'3; rewrite <- H'3. cut (Subtract U (Add U X x) x = X); auto with sets. intro H'4; rewrite H'4; auto with sets. intros H'3 H'4; try assumption. absurd (In U (Add U X x) x0); auto with sets. red; intro H'5; try exact H'5. lapply (Add_inv U X x x0); tauto. Qed. Lemma cardinal_is_functional : forall (X:Ensemble U) (c1:nat), cardinal U X c1 -> forall (Y:Ensemble U) (c2:nat), cardinal U Y c2 -> X = Y -> c1 = c2. Proof. intros X c1 H'; elim H'. intros Y c2 H'0; elim H'0; auto with sets. intros A n H'1 H'2 x H'3 H'5. elim (not_Empty_Add U A x); auto with sets. clear H' c1 X. intros X n H' H'0 x H'1 Y c2 H'2. elim H'2. intro H'3. elim (not_Empty_Add U X x); auto with sets. clear H'2 c2 Y. intros X0 c2 H'2 H'3 x0 H'4 H'5. elim (classic (In U X0 x)). intro H'6; apply f_equal. apply H'0 with (Y := Subtract U (Add U X0 x0) x). elimtype (pred (S c2) = c2); auto with sets. apply card_soustr_1; auto with sets. rewrite <- H'5. apply Sub_Add_new; auto with sets. elim (classic (x = x0)). intros H'6 H'7; apply f_equal. apply H'0 with (Y := X0); auto with sets. apply Simplify_add with (x := x); auto with sets. pattern x at 2; rewrite H'6; auto with sets. intros H'6 H'7. absurd (Add U X x = Add U X0 x0); auto with sets. clear H'0 H' H'3 n H'5 H'4 H'2 H'1 c2. red; intro H'. lapply (Extension U (Add U X x) (Add U X0 x0)); auto with sets. clear H'. intro H'; red in H'. elim H'; intros H'0 H'1; red in H'0; clear H' H'1. absurd (In U (Add U X0 x0) x); auto with sets. lapply (Add_inv U X0 x0 x); [ intuition | apply (H'0 x); apply Add_intro2 ]. Qed. Lemma cardinal_Empty : forall m:nat, cardinal U (Empty_set U) m -> 0 = m. Proof. intros m Cm; generalize (cardinal_invert U (Empty_set U) m Cm). elim m; auto with sets. intros; elim H0; intros; elim H1; intros; elim H2; intros. elim (not_Empty_Add U x x0 H3). Qed. Lemma cardinal_unicity : forall (X:Ensemble U) (n:nat), cardinal U X n -> forall m:nat, cardinal U X m -> n = m. Proof. intros; apply cardinal_is_functional with X X; auto with sets. Qed. Lemma card_Add_gen : forall (A:Ensemble U) (x:U) (n n':nat), cardinal U A n -> cardinal U (Add U A x) n' -> n' <= S n. Proof. intros A x n n' H'. elim (classic (In U A x)). intro H'0. rewrite (Non_disjoint_union U A x H'0). intro H'1; cut (n = n'). intro E; rewrite E; auto with sets. apply cardinal_unicity with A; auto with sets. intros H'0 H'1. cut (n' = S n). intro E; rewrite E; auto with sets. apply cardinal_unicity with (Add U A x); auto with sets. Qed. Lemma incl_st_card_lt : forall (X:Ensemble U) (c1:nat), cardinal U X c1 -> forall (Y:Ensemble U) (c2:nat), cardinal U Y c2 -> Strict_Included U X Y -> c2 > c1. Proof. intros X c1 H'; elim H'. intros Y c2 H'0; elim H'0; auto with sets arith. intro H'1. elim (Strict_Included_strict U (Empty_set U)); auto with sets arith. clear H' c1 X. intros X n H' H'0 x H'1 Y c2 H'2. elim H'2. intro H'3; elim (not_SIncl_empty U (Add U X x)); auto with sets arith. clear H'2 c2 Y. intros X0 c2 H'2 H'3 x0 H'4 H'5; elim (classic (In U X0 x)). intro H'6; apply gt_n_S. apply H'0 with (Y := Subtract U (Add U X0 x0) x). elimtype (pred (S c2) = c2); auto with sets arith. apply card_soustr_1; auto with sets arith. apply incl_st_add_soustr; auto with sets arith. elim (classic (x = x0)). intros H'6 H'7; apply gt_n_S. apply H'0 with (Y := X0); auto with sets arith. apply sincl_add_x with (x := x0). rewrite <- H'6; auto with sets arith. pattern x0 at 1; rewrite <- H'6; trivial with sets arith. intros H'6 H'7; red in H'5. elim H'5; intros H'8 H'9; try exact H'8; clear H'5. red in H'8. generalize (H'8 x). intro H'5; lapply H'5; auto with sets arith. intro H; elim Add_inv with U X0 x0 x; auto with sets arith. intro; absurd (In U X0 x); auto with sets arith. intro; absurd (x = x0); auto with sets arith. Qed. Lemma incl_card_le : forall (X Y:Ensemble U) (n m:nat), cardinal U X n -> cardinal U Y m -> Included U X Y -> n <= m. Proof. intros; elim Included_Strict_Included with U X Y; auto with sets arith; intro. cut (m > n); auto with sets arith. apply incl_st_card_lt with (X := X) (Y := Y); auto with sets arith. generalize H0; rewrite <- H2; intro. cut (n = m). intro E; rewrite E; auto with sets arith. apply cardinal_unicity with X; auto with sets arith. Qed. Lemma G_aux : forall P:Ensemble U -> Prop, (forall X:Ensemble U, Finite U X -> (forall Y:Ensemble U, Strict_Included U Y X -> P Y) -> P X) -> P (Empty_set U). Proof. intros P H'; try assumption. apply H'; auto with sets. clear H'; auto with sets. intros Y H'; try assumption. red in H'. elim H'; intros H'0 H'1; try exact H'1; clear H'. lapply (less_than_empty U Y); [ intro H'3; try exact H'3 | assumption ]. elim H'1; auto with sets. Qed. Lemma Generalized_induction_on_finite_sets : forall P:Ensemble U -> Prop, (forall X:Ensemble U, Finite U X -> (forall Y:Ensemble U, Strict_Included U Y X -> P Y) -> P X) -> forall X:Ensemble U, Finite U X -> P X. Proof. intros P H'0 X H'1. generalize P H'0; clear H'0 P. elim H'1. intros P H'0. apply G_aux; auto with sets. clear H'1 X. intros A H' H'0 x H'1 P H'3. cut (forall Y:Ensemble U, Included U Y (Add U A x) -> P Y); auto with sets. generalize H'1. apply H'0. intros X K H'5 L Y H'6; apply H'3; auto with sets. apply Finite_downward_closed with (A := Add U X x); auto with sets. intros Y0 H'7. elim (Strict_inclusion_is_transitive_with_inclusion U Y0 Y (Add U X x)); auto with sets. intros H'2 H'4. elim (Included_Add U Y0 X x); [ intro H'14 | intro H'14; elim H'14; intros A' E; elim E; intros H'15 H'16; clear E H'14 | idtac ]; auto with sets. elim (Included_Strict_Included U Y0 X); auto with sets. intro H'9; apply H'5 with (Y := Y0); auto with sets. intro H'9; rewrite H'9. apply H'3; auto with sets. intros Y1 H'8; elim H'8. intros H'10 H'11; apply H'5 with (Y := Y1); auto with sets. elim (Included_Strict_Included U A' X); auto with sets. intro H'8; apply H'5 with (Y := A'); auto with sets. rewrite <- H'15; auto with sets. intro H'8. elim H'7. intros H'9 H'10; apply H'10 || elim H'10; try assumption. generalize H'6. rewrite <- H'8. rewrite <- H'15; auto with sets. Qed. End Finite_sets_facts. coq-8.4pl4/theories/Sets/Partial_Order.v0000644000175000017500000000704112326224777017313 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Rel_of p x y /\ x <> y. Inductive covers (y x:U) : Prop := Definition_of_covers : Strict_Rel_of x y -> ~ (exists z : _, Strict_Rel_of x z /\ Strict_Rel_of z y) -> covers y x. End Partial_orders. Hint Unfold Carrier_of Rel_of Strict_Rel_of: sets v62. Hint Resolve Definition_of_covers: sets v62. Section Partial_order_facts. Variable U : Type. Variable D : PO U. Lemma Strict_Rel_Transitive_with_Rel : forall x y z:U, Strict_Rel_of U D x y -> Rel_of U D y z -> Strict_Rel_of U D x z. Proof. unfold Strict_Rel_of at 1. red. elim D; simpl. intros C R H' H'0; elim H'0. intros H'1 H'2 H'3 x y z H'4 H'5; split. apply H'2 with (y := y); tauto. red; intro H'6. elim H'4; intros H'7 H'8; apply H'8; clear H'4. apply H'3; auto. rewrite H'6; tauto. Qed. Lemma Strict_Rel_Transitive_with_Rel_left : forall x y z:U, Rel_of U D x y -> Strict_Rel_of U D y z -> Strict_Rel_of U D x z. Proof. unfold Strict_Rel_of at 1. red. elim D; simpl. intros C R H' H'0; elim H'0. intros H'1 H'2 H'3 x y z H'4 H'5; split. apply H'2 with (y := y); tauto. red; intro H'6. elim H'5; intros H'7 H'8; apply H'8; clear H'5. apply H'3; auto. rewrite <- H'6; auto. Qed. Lemma Strict_Rel_Transitive : Transitive U (Strict_Rel_of U D). red. intros x y z H' H'0. apply Strict_Rel_Transitive_with_Rel with (y := y); [ intuition | unfold Strict_Rel_of in H', H'0; intuition ]. Qed. End Partial_order_facts. coq-8.4pl4/theories/Sets/Powerset_facts.v0000644000175000017500000002046512326224777017561 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* X = Empty_set U. Proof. auto with sets. Qed. Theorem Union_commutative : forall A B:Ensemble U, Union U A B = Union U B A. Proof. auto with sets. Qed. Theorem Union_associative : forall A B C:Ensemble U, Union U (Union U A B) C = Union U A (Union U B C). Proof. auto 9 with sets. Qed. Theorem Union_idempotent : forall A:Ensemble U, Union U A A = A. Proof. auto 7 with sets. Qed. Lemma Union_absorbs : forall A B:Ensemble U, Included U B A -> Union U A B = A. Proof. auto 7 with sets. Qed. Theorem Couple_as_union : forall x y:U, Union U (Singleton U x) (Singleton U y) = Couple U x y. Proof. intros x y; apply Extensionality_Ensembles; split; red. intros x0 H'; elim H'; (intros x1 H'0; elim H'0; auto with sets). intros x0 H'; elim H'; auto with sets. Qed. Theorem Triple_as_union : forall x y z:U, Union U (Union U (Singleton U x) (Singleton U y)) (Singleton U z) = Triple U x y z. Proof. intros x y z; apply Extensionality_Ensembles; split; red. intros x0 H'; elim H'. intros x1 H'0; elim H'0; (intros x2 H'1; elim H'1; auto with sets). intros x1 H'0; elim H'0; auto with sets. intros x0 H'; elim H'; auto with sets. Qed. Theorem Triple_as_Couple : forall x y:U, Couple U x y = Triple U x x y. Proof. intros x y. rewrite <- (Couple_as_union x y). rewrite <- (Union_idempotent (Singleton U x)). apply Triple_as_union. Qed. Theorem Triple_as_Couple_Singleton : forall x y z:U, Triple U x y z = Union U (Couple U x y) (Singleton U z). Proof. intros x y z. rewrite <- (Triple_as_union x y z). rewrite <- (Couple_as_union x y); auto with sets. Qed. Theorem Intersection_commutative : forall A B:Ensemble U, Intersection U A B = Intersection U B A. Proof. intros A B. apply Extensionality_Ensembles. split; red; intros x H'; elim H'; auto with sets. Qed. Theorem Distributivity : forall A B C:Ensemble U, Intersection U A (Union U B C) = Union U (Intersection U A B) (Intersection U A C). Proof. intros A B C. apply Extensionality_Ensembles. split; red; intros x H'. elim H'. intros x0 H'0 H'1; generalize H'0. elim H'1; auto with sets. elim H'; intros x0 H'0; elim H'0; auto with sets. Qed. Theorem Distributivity' : forall A B C:Ensemble U, Union U A (Intersection U B C) = Intersection U (Union U A B) (Union U A C). Proof. intros A B C. apply Extensionality_Ensembles. split; red; intros x H'. elim H'; auto with sets. intros x0 H'0; elim H'0; auto with sets. elim H'. intros x0 H'0; elim H'0; auto with sets. intros x1 H'1 H'2; try exact H'2. generalize H'1. elim H'2; auto with sets. Qed. Theorem Union_add : forall (A B:Ensemble U) (x:U), Add U (Union U A B) x = Union U A (Add U B x). Proof. unfold Add; auto using Union_associative with sets. Qed. Theorem Non_disjoint_union : forall (X:Ensemble U) (x:U), In U X x -> Add U X x = X. Proof. intros X x H'; unfold Add. apply Extensionality_Ensembles; red. split; red; auto with sets. intros x0 H'0; elim H'0; auto with sets. intros t H'1; elim H'1; auto with sets. Qed. Theorem Non_disjoint_union' : forall (X:Ensemble U) (x:U), ~ In U X x -> Subtract U X x = X. Proof. intros X x H'; unfold Subtract. apply Extensionality_Ensembles. split; red; auto with sets. intros x0 H'0; elim H'0; auto with sets. intros x0 H'0; apply Setminus_intro; auto with sets. red; intro H'1; elim H'1. lapply (Singleton_inv U x x0); auto with sets. intro H'4; apply H'; rewrite H'4; auto with sets. Qed. Lemma singlx : forall x y:U, In U (Add U (Empty_set U) x) y -> x = y. Proof. intro x; rewrite (Empty_set_zero' x); auto with sets. Qed. Lemma incl_add : forall (A B:Ensemble U) (x:U), Included U A B -> Included U (Add U A x) (Add U B x). Proof. intros A B x H'; red; auto with sets. intros x0 H'0. lapply (Add_inv U A x x0); auto with sets. intro H'1; elim H'1; [ intro H'2; clear H'1 | intro H'2; rewrite <- H'2; clear H'1 ]; auto with sets. Qed. Lemma incl_add_x : forall (A B:Ensemble U) (x:U), ~ In U A x -> Included U (Add U A x) (Add U B x) -> Included U A B. Proof. unfold Included. intros A B x H' H'0 x0 H'1. lapply (H'0 x0); auto with sets. intro H'2; lapply (Add_inv U B x x0); auto with sets. intro H'3; elim H'3; [ intro H'4; try exact H'4; clear H'3 | intro H'4; clear H'3 ]. absurd (In U A x0); auto with sets. rewrite <- H'4; auto with sets. Qed. Lemma Add_commutative : forall (A:Ensemble U) (x y:U), Add U (Add U A x) y = Add U (Add U A y) x. Proof. intros A x y. unfold Add. rewrite (Union_associative A (Singleton U x) (Singleton U y)). rewrite (Union_commutative (Singleton U x) (Singleton U y)). rewrite <- (Union_associative A (Singleton U y) (Singleton U x)); auto with sets. Qed. Lemma Add_commutative' : forall (A:Ensemble U) (x y z:U), Add U (Add U (Add U A x) y) z = Add U (Add U (Add U A z) x) y. Proof. intros A x y z. rewrite (Add_commutative (Add U A x) y z). rewrite (Add_commutative A x z); auto with sets. Qed. Lemma Add_distributes : forall (A B:Ensemble U) (x y:U), Included U B A -> Add U (Add U A x) y = Union U (Add U A x) (Add U B y). Proof. intros A B x y H'; try assumption. rewrite <- (Union_add (Add U A x) B y). unfold Add at 4. rewrite (Union_commutative A (Singleton U x)). rewrite Union_associative. rewrite (Union_absorbs A B H'). rewrite (Union_commutative (Singleton U x) A). auto with sets. Qed. Lemma setcover_intro : forall (U:Type) (A x y:Ensemble U), Strict_Included U x y -> ~ (exists z : _, Strict_Included U x z /\ Strict_Included U z y) -> covers (Ensemble U) (Power_set_PO U A) y x. Proof. intros; apply Definition_of_covers; auto with sets. Qed. End Sets_as_an_algebra. Hint Resolve Empty_set_zero Empty_set_zero' Union_associative Union_add singlx incl_add: sets v62. coq-8.4pl4/theories/Sets/Relations_2_facts.v0000644000175000017500000001264512326224777020133 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* x = y \/ (exists u : _, R x u /\ Rstar U R u y). Proof. intros U R x y H'; elim H'; auto with sets. intros x0 y0 z H'0 H'1 H'2; right; exists y0; auto with sets. Qed. Theorem Rstar_equiv_Rstar1 : forall (U:Type) (R:Relation U), same_relation U (Rstar U R) (Rstar1 U R). Proof. generalize Rstar_contains_R; intro T; red in T. intros U R; unfold same_relation, contains. split; intros x y H'; elim H'; auto with sets. generalize Rstar_transitive; intro T1; red in T1. intros x0 y0 z H'0 H'1 H'2 H'3; apply T1 with y0; auto with sets. intros x0 y0 z H'0 H'1 H'2; apply Rstar1_n with y0; auto with sets. Qed. Theorem Rsym_imp_Rstarsym : forall (U:Type) (R:Relation U), Symmetric U R -> Symmetric U (Rstar U R). Proof. intros U R H'; red. intros x y H'0; elim H'0; auto with sets. intros x0 y0 z H'1 H'2 H'3. generalize Rstar_transitive; intro T1; red in T1. apply T1 with y0; auto with sets. apply Rstar_n with x0; auto with sets. Qed. Theorem Sstar_contains_Rstar : forall (U:Type) (R S:Relation U), contains U (Rstar U S) R -> contains U (Rstar U S) (Rstar U R). Proof. unfold contains. intros U R S H' x y H'0; elim H'0; auto with sets. generalize Rstar_transitive; intro T1; red in T1. intros x0 y0 z H'1 H'2 H'3; apply T1 with y0; auto with sets. Qed. Theorem star_monotone : forall (U:Type) (R S:Relation U), contains U S R -> contains U (Rstar U S) (Rstar U R). Proof. intros U R S H'. apply Sstar_contains_Rstar; auto with sets. generalize (Rstar_contains_R U S); auto with sets. Qed. Theorem RstarRplus_RRstar : forall (U:Type) (R:Relation U) (x y z:U), Rstar U R x y -> Rplus U R y z -> exists u : _, R x u /\ Rstar U R u z. Proof. generalize Rstar_contains_Rplus; intro T; red in T. generalize Rstar_transitive; intro T1; red in T1. intros U R x y z H'; elim H'. intros x0 H'0; elim H'0. intros x1 y0 H'1; exists y0; auto with sets. intros x1 y0 z0 H'1 H'2 H'3; exists y0; auto with sets. intros x0 y0 z0 H'0 H'1 H'2 H'3; exists y0. split; [ try assumption | idtac ]. apply T1 with z0; auto with sets. Qed. Theorem Lemma1 : forall (U:Type) (R:Relation U), Strongly_confluent U R -> forall x b:U, Rstar U R x b -> forall a:U, R x a -> exists z : _, Rstar U R a z /\ R b z. Proof. intros U R H' x b H'0; elim H'0. intros x0 a H'1; exists a; auto with sets. intros x0 y z H'1 H'2 H'3 a H'4. red in H'. specialize H' with (x := x0) (a := a) (b := y); lapply H'; [ intro H'8; lapply H'8; [ intro H'9; try exact H'9; clear H'8 H' | clear H'8 H' ] | clear H' ]; auto with sets. elim H'9. intros t H'5; elim H'5; intros H'6 H'7; try exact H'6; clear H'5. elim (H'3 t); auto with sets. intros z1 H'5; elim H'5; intros H'8 H'10; try exact H'8; clear H'5. exists z1; split; [ idtac | assumption ]. apply Rstar_n with t; auto with sets. Qed. coq-8.4pl4/theories/Sets/Relations_1_facts.v0000644000175000017500000000770012326224777020126 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ~ R x y. Theorem Rsym_imp_notRsym : forall (U:Type) (R:Relation U), Symmetric U R -> Symmetric U (Complement U R). Proof. unfold Symmetric, Complement. intros U R H' x y H'0; red; intro H'1; apply H'0; auto with sets. Qed. Theorem Equiv_from_preorder : forall (U:Type) (R:Relation U), Preorder U R -> Equivalence U (fun x y:U => R x y /\ R y x). Proof. intros U R H'; elim H'; intros H'0 H'1. apply Definition_of_equivalence. red in H'0; auto 10 with sets. 2: red; intros x y h; elim h; intros H'3 H'4; auto 10 with sets. red in H'1; red; auto 10 with sets. intros x y z h; elim h; intros H'3 H'4; clear h. intro h; elim h; intros H'5 H'6; clear h. split; apply H'1 with y; auto 10 with sets. Qed. Hint Resolve Equiv_from_preorder. Theorem Equiv_from_order : forall (U:Type) (R:Relation U), Order U R -> Equivalence U (fun x y:U => R x y /\ R y x). Proof. intros U R H'; elim H'; auto 10 with sets. Qed. Hint Resolve Equiv_from_order. Theorem contains_is_preorder : forall U:Type, Preorder (Relation U) (contains U). Proof. auto 10 with sets. Qed. Hint Resolve contains_is_preorder. Theorem same_relation_is_equivalence : forall U:Type, Equivalence (Relation U) (same_relation U). Proof. unfold same_relation at 1; auto 10 with sets. Qed. Hint Resolve same_relation_is_equivalence. Theorem cong_reflexive_same_relation : forall (U:Type) (R R':Relation U), same_relation U R R' -> Reflexive U R -> Reflexive U R'. Proof. unfold same_relation; intuition. Qed. Theorem cong_symmetric_same_relation : forall (U:Type) (R R':Relation U), same_relation U R R' -> Symmetric U R -> Symmetric U R'. Proof. compute; intros; elim H; intros; clear H; apply (H3 y x (H0 x y (H2 x y H1))). (*Intuition.*) Qed. Theorem cong_antisymmetric_same_relation : forall (U:Type) (R R':Relation U), same_relation U R R' -> Antisymmetric U R -> Antisymmetric U R'. Proof. compute; intros; elim H; intros; clear H; apply (H0 x y (H3 x y H1) (H3 y x H2)). (*Intuition.*) Qed. Theorem cong_transitive_same_relation : forall (U:Type) (R R':Relation U), same_relation U R R' -> Transitive U R -> Transitive U R'. Proof. intros U R R' H' H'0; red. elim H'. intros H'1 H'2 x y z H'3 H'4; apply H'2. apply H'0 with y; auto with sets. Qed. coq-8.4pl4/theories/Sets/Powerset.v0000644000175000017500000001500612326224777016374 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* In (Ensemble U) (Power_set A) X. Hint Resolve Definition_of_Power_set. Theorem Empty_set_minimal : forall X:Ensemble U, Included U (Empty_set U) X. intro X; red. intros x H'; elim H'. Qed. Hint Resolve Empty_set_minimal. Theorem Power_set_Inhabited : forall X:Ensemble U, Inhabited (Ensemble U) (Power_set X). intro X. apply Inhabited_intro with (Empty_set U); auto with sets. Qed. Hint Resolve Power_set_Inhabited. Theorem Inclusion_is_an_order : Order (Ensemble U) (Included U). auto 6 with sets. Qed. Hint Resolve Inclusion_is_an_order. Theorem Inclusion_is_transitive : Transitive (Ensemble U) (Included U). elim Inclusion_is_an_order; auto with sets. Qed. Hint Resolve Inclusion_is_transitive. Definition Power_set_PO : Ensemble U -> PO (Ensemble U). intro A; try assumption. apply Definition_of_PO with (Power_set A) (Included U); auto with sets. Defined. Hint Unfold Power_set_PO. Theorem Strict_Rel_is_Strict_Included : same_relation (Ensemble U) (Strict_Included U) (Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U))). auto with sets. Qed. Hint Resolve Strict_Rel_Transitive Strict_Rel_is_Strict_Included. Lemma Strict_inclusion_is_transitive_with_inclusion : forall x y z:Ensemble U, Strict_Included U x y -> Included U y z -> Strict_Included U x z. intros x y z H' H'0; try assumption. elim Strict_Rel_is_Strict_Included. unfold contains. intros H'1 H'2; try assumption. apply H'1. apply Strict_Rel_Transitive_with_Rel with (y := y); auto with sets. Qed. Lemma Strict_inclusion_is_transitive_with_inclusion_left : forall x y z:Ensemble U, Included U x y -> Strict_Included U y z -> Strict_Included U x z. intros x y z H' H'0; try assumption. elim Strict_Rel_is_Strict_Included. unfold contains. intros H'1 H'2; try assumption. apply H'1. apply Strict_Rel_Transitive_with_Rel_left with (y := y); auto with sets. Qed. Lemma Strict_inclusion_is_transitive : Transitive (Ensemble U) (Strict_Included U). apply cong_transitive_same_relation with (R := Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U))); auto with sets. Qed. Theorem Empty_set_is_Bottom : forall A:Ensemble U, Bottom (Ensemble U) (Power_set_PO A) (Empty_set U). intro A; apply Bottom_definition; simpl; auto with sets. Qed. Hint Resolve Empty_set_is_Bottom. Theorem Union_minimal : forall a b X:Ensemble U, Included U a X -> Included U b X -> Included U (Union U a b) X. intros a b X H' H'0; red. intros x H'1; elim H'1; auto with sets. Qed. Hint Resolve Union_minimal. Theorem Intersection_maximal : forall a b X:Ensemble U, Included U X a -> Included U X b -> Included U X (Intersection U a b). auto with sets. Qed. Theorem Union_increases_l : forall a b:Ensemble U, Included U a (Union U a b). auto with sets. Qed. Theorem Union_increases_r : forall a b:Ensemble U, Included U b (Union U a b). auto with sets. Qed. Theorem Intersection_decreases_l : forall a b:Ensemble U, Included U (Intersection U a b) a. intros a b; red. intros x H'; elim H'; auto with sets. Qed. Theorem Intersection_decreases_r : forall a b:Ensemble U, Included U (Intersection U a b) b. intros a b; red. intros x H'; elim H'; auto with sets. Qed. Hint Resolve Union_increases_l Union_increases_r Intersection_decreases_l Intersection_decreases_r. Theorem Union_is_Lub : forall A a b:Ensemble U, Included U a A -> Included U b A -> Lub (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b) (Union U a b). intros A a b H' H'0. apply Lub_definition; simpl. apply Upper_Bound_definition; simpl; auto with sets. intros y H'1; elim H'1; auto with sets. intros y H'1; elim H'1; simpl; auto with sets. Qed. Theorem Intersection_is_Glb : forall A a b:Ensemble U, Included U a A -> Included U b A -> Glb (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b) (Intersection U a b). intros A a b H' H'0. apply Glb_definition; simpl. apply Lower_Bound_definition; simpl; auto with sets. apply Definition_of_Power_set. generalize Inclusion_is_transitive; intro IT; red in IT; apply IT with a; auto with sets. intros y H'1; elim H'1; auto with sets. intros y H'1; elim H'1; simpl; auto with sets. Qed. End The_power_set_partial_order. Hint Resolve Empty_set_minimal: sets v62. Hint Resolve Power_set_Inhabited: sets v62. Hint Resolve Inclusion_is_an_order: sets v62. Hint Resolve Inclusion_is_transitive: sets v62. Hint Resolve Union_minimal: sets v62. Hint Resolve Union_increases_l: sets v62. Hint Resolve Union_increases_r: sets v62. Hint Resolve Intersection_decreases_l: sets v62. Hint Resolve Intersection_decreases_r: sets v62. Hint Resolve Empty_set_is_Bottom: sets v62. Hint Resolve Strict_inclusion_is_transitive: sets v62. coq-8.4pl4/theories/Sets/Multiset.v0000644000175000017500000001336112326224777016374 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* A -> Prop. Hypothesis eqA_equiv : Equivalence eqA. Hypothesis Aeq_dec : forall x y:A, {eqA x y} + {~ eqA x y}. Inductive multiset : Type := Bag : (A -> nat) -> multiset. Definition EmptyBag := Bag (fun a:A => 0). Definition SingletonBag (a:A) := Bag (fun a':A => match Aeq_dec a a' with | left _ => 1 | right _ => 0 end). Definition multiplicity (m:multiset) (a:A) : nat := let (f) := m in f a. (** multiset equality *) Definition meq (m1 m2:multiset) := forall a:A, multiplicity m1 a = multiplicity m2 a. Lemma meq_refl : forall x:multiset, meq x x. Proof. destruct x; unfold meq; reflexivity. Qed. Lemma meq_trans : forall x y z:multiset, meq x y -> meq y z -> meq x z. Proof. unfold meq. destruct x; destruct y; destruct z. intros; rewrite H; auto. Qed. Lemma meq_sym : forall x y:multiset, meq x y -> meq y x. Proof. unfold meq. destruct x; destruct y; auto. Qed. (** multiset union *) Definition munion (m1 m2:multiset) := Bag (fun a:A => multiplicity m1 a + multiplicity m2 a). Lemma munion_empty_left : forall x:multiset, meq x (munion EmptyBag x). Proof. unfold meq; unfold munion; simpl; auto. Qed. Lemma munion_empty_right : forall x:multiset, meq x (munion x EmptyBag). Proof. unfold meq; unfold munion; simpl; auto. Qed. Require Plus. (* comm. and ass. of plus *) Lemma munion_comm : forall x y:multiset, meq (munion x y) (munion y x). Proof. unfold meq; unfold multiplicity; unfold munion. destruct x; destruct y; auto with arith. Qed. Lemma munion_ass : forall x y z:multiset, meq (munion (munion x y) z) (munion x (munion y z)). Proof. unfold meq; unfold munion; unfold multiplicity. destruct x; destruct y; destruct z; auto with arith. Qed. Lemma meq_left : forall x y z:multiset, meq x y -> meq (munion x z) (munion y z). Proof. unfold meq; unfold munion; unfold multiplicity. destruct x; destruct y; destruct z. intros; elim H; auto with arith. Qed. Lemma meq_right : forall x y z:multiset, meq x y -> meq (munion z x) (munion z y). Proof. unfold meq; unfold munion; unfold multiplicity. destruct x; destruct y; destruct z. intros; elim H; auto. Qed. (** Here we should make multiset an abstract datatype, by hiding [Bag], [munion], [multiplicity]; all further properties are proved abstractly *) Lemma munion_rotate : forall x y z:multiset, meq (munion x (munion y z)) (munion z (munion x y)). Proof. intros; apply (op_rotate multiset munion meq). apply munion_comm. apply munion_ass. exact meq_trans. exact meq_sym. trivial. Qed. Lemma meq_congr : forall x y z t:multiset, meq x y -> meq z t -> meq (munion x z) (munion y t). Proof. intros; apply (cong_congr multiset munion meq); auto using meq_left, meq_right. exact meq_trans. Qed. Lemma munion_perm_left : forall x y z:multiset, meq (munion x (munion y z)) (munion y (munion x z)). Proof. intros; apply (perm_left multiset munion meq); auto using munion_comm, munion_ass, meq_left, meq_right, meq_sym. exact meq_trans. Qed. Lemma multiset_twist1 : forall x y z t:multiset, meq (munion x (munion (munion y z) t)) (munion (munion y (munion x t)) z). Proof. intros; apply (twist multiset munion meq); auto using munion_comm, munion_ass, meq_sym, meq_left, meq_right. exact meq_trans. Qed. Lemma multiset_twist2 : forall x y z t:multiset, meq (munion x (munion (munion y z) t)) (munion (munion y (munion x z)) t). Proof. intros; apply meq_trans with (munion (munion x (munion y z)) t). apply meq_sym; apply munion_ass. apply meq_left; apply munion_perm_left. Qed. (** specific for treesort *) Lemma treesort_twist1 : forall x y z t u:multiset, meq u (munion y z) -> meq (munion x (munion u t)) (munion (munion y (munion x t)) z). Proof. intros; apply meq_trans with (munion x (munion (munion y z) t)). apply meq_right; apply meq_left; trivial. apply multiset_twist1. Qed. Lemma treesort_twist2 : forall x y z t u:multiset, meq u (munion y z) -> meq (munion x (munion u t)) (munion (munion y (munion x z)) t). Proof. intros; apply meq_trans with (munion x (munion (munion y z) t)). apply meq_right; apply meq_left; trivial. apply multiset_twist2. Qed. (** SingletonBag *) Lemma meq_singleton : forall a a', eqA a a' -> meq (SingletonBag a) (SingletonBag a'). Proof. intros; red; simpl; intro a0. destruct (Aeq_dec a a0) as [Ha|Ha]; rewrite H in Ha; decide (Aeq_dec a' a0) with Ha; reflexivity. Qed. (*i theory of minter to do similarly Require Min. (* multiset intersection *) Definition minter := [m1,m2:multiset] (Bag [a:A](min (multiplicity m1 a)(multiplicity m2 a))). i*) End multiset_defs. Unset Implicit Arguments. Hint Unfold meq multiplicity: v62 datatypes. Hint Resolve munion_empty_right munion_comm munion_ass meq_left meq_right munion_empty_left: v62 datatypes. Hint Immediate meq_sym: v62 datatypes. coq-8.4pl4/theories/Sets/Relations_3_facts.v0000644000175000017500000001430512326224777020127 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* coherent U R x y. Proof. intros U R x y H'; red. exists y; auto with sets. Qed. Hint Resolve Rstar_imp_coherent. Theorem coherent_symmetric : forall (U:Type) (R:Relation U), Symmetric U (coherent U R). Proof. unfold coherent at 1. intros U R; red. intros x y H'; elim H'. intros z H'0; exists z; tauto. Qed. Theorem Strong_confluence : forall (U:Type) (R:Relation U), Strongly_confluent U R -> Confluent U R. Proof. intros U R H'; red. intro x; red; intros a b H'0. unfold coherent at 1. generalize b; clear b. elim H'0; clear H'0. intros x0 b H'1; exists b; auto with sets. intros x0 y z H'1 H'2 H'3 b H'4. generalize (Lemma1 U R); intro h; lapply h; [ intro H'0; generalize (H'0 x0 b); intro h0; lapply h0; [ intro H'5; generalize (H'5 y); intro h1; lapply h1; [ intro h2; elim h2; intros z0 h3; elim h3; intros H'6 H'7; clear h h0 h1 h2 h3 | clear h h0 h1 ] | clear h h0 ] | clear h ]; auto with sets. generalize (H'3 z0); intro h; lapply h; [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; clear h h0 h1 | clear h ]; auto with sets. exists z1; split; auto with sets. apply Rstar_n with z0; auto with sets. Qed. Theorem Strong_confluence_direct : forall (U:Type) (R:Relation U), Strongly_confluent U R -> Confluent U R. Proof. intros U R H'; red. intro x; red; intros a b H'0. unfold coherent at 1. generalize b; clear b. elim H'0; clear H'0. intros x0 b H'1; exists b; auto with sets. intros x0 y z H'1 H'2 H'3 b H'4. cut (ex (fun t:U => Rstar U R y t /\ R b t)). intro h; elim h; intros t h0; elim h0; intros H'0 H'5; clear h h0. generalize (H'3 t); intro h; lapply h; [ intro h0; elim h0; intros z0 h1; elim h1; intros H'6 H'7; clear h h0 h1 | clear h ]; auto with sets. exists z0; split; [ assumption | idtac ]. apply Rstar_n with t; auto with sets. generalize H'1; generalize y; clear H'1. elim H'4. intros x1 y0 H'0; exists y0; auto with sets. intros x1 y0 z0 H'0 H'1 H'5 y1 H'6. red in H'. generalize (H' x1 y0 y1); intro h; lapply h; [ intro H'7; lapply H'7; [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; clear h H'7 h0 h1 | clear h ] | clear h ]; auto with sets. generalize (H'5 z1); intro h; lapply h; [ intro h0; elim h0; intros t h1; elim h1; intros H'7 H'10; clear h h0 h1 | clear h ]; auto with sets. exists t; split; auto with sets. apply Rstar_n with z1; auto with sets. Qed. Theorem Noetherian_contains_Noetherian : forall (U:Type) (R R':Relation U), Noetherian U R -> contains U R R' -> Noetherian U R'. Proof. unfold Noetherian at 2. intros U R R' H' H'0 x. elim (H' x); auto with sets. Qed. Theorem Newman : forall (U:Type) (R:Relation U), Noetherian U R -> Locally_confluent U R -> Confluent U R. Proof. intros U R H' H'0; red; intro x. elim (H' x); unfold confluent. intros x0 H'1 H'2 y z H'3 H'4. generalize (Rstar_cases U R x0 y); intro h; lapply h; [ intro h0; elim h0; [ clear h h0; intro h1 | intro h1; elim h1; intros u h2; elim h2; intros H'5 H'6; clear h h0 h1 h2 ] | clear h ]; auto with sets. elim h1; auto with sets. generalize (Rstar_cases U R x0 z); intro h; lapply h; [ intro h0; elim h0; [ clear h h0; intro h1 | intro h1; elim h1; intros v h2; elim h2; intros H'7 H'8; clear h h0 h1 h2 ] | clear h ]; auto with sets. elim h1; generalize coherent_symmetric; intro t; red in t; auto with sets. unfold Locally_confluent, locally_confluent, coherent in H'0. generalize (H'0 x0 u v); intro h; lapply h; [ intro H'9; lapply H'9; [ intro h0; elim h0; intros t h1; elim h1; intros H'10 H'11; clear h H'9 h0 h1 | clear h ] | clear h ]; auto with sets. clear H'0. unfold coherent at 1 in H'2. generalize (H'2 u); intro h; lapply h; [ intro H'0; generalize (H'0 y t); intro h0; lapply h0; [ intro H'9; lapply H'9; [ intro h1; elim h1; intros y1 h2; elim h2; intros H'12 H'13; clear h h0 H'9 h1 h2 | clear h h0 ] | clear h h0 ] | clear h ]; auto with sets. generalize Rstar_transitive; intro T; red in T. generalize (H'2 v); intro h; lapply h; [ intro H'9; generalize (H'9 y1 z); intro h0; lapply h0; [ intro H'14; lapply H'14; [ intro h1; elim h1; intros z1 h2; elim h2; intros H'15 H'16; clear h h0 H'14 h1 h2 | clear h h0 ] | clear h h0 ] | clear h ]; auto with sets. red; (exists z1; split); auto with sets. apply T with y1; auto with sets. apply T with t; auto with sets. Qed. coq-8.4pl4/theories/Sets/Permut.v0000644000175000017500000000555512326224777016050 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* U -> U. Variable cong : U -> U -> Prop. Hypothesis op_comm : forall x y:U, cong (op x y) (op y x). Hypothesis op_ass : forall x y z:U, cong (op (op x y) z) (op x (op y z)). Hypothesis cong_left : forall x y z:U, cong x y -> cong (op x z) (op y z). Hypothesis cong_right : forall x y z:U, cong x y -> cong (op z x) (op z y). Hypothesis cong_trans : forall x y z:U, cong x y -> cong y z -> cong x z. Hypothesis cong_sym : forall x y:U, cong x y -> cong y x. (** Remark. we do not need: [Hypothesis cong_refl : (x:U)(cong x x)]. *) Lemma cong_congr : forall x y z t:U, cong x y -> cong z t -> cong (op x z) (op y t). Proof. intros; apply cong_trans with (op y z). apply cong_left; trivial. apply cong_right; trivial. Qed. Lemma comm_right : forall x y z:U, cong (op x (op y z)) (op x (op z y)). Proof. intros; apply cong_right; apply op_comm. Qed. Lemma comm_left : forall x y z:U, cong (op (op x y) z) (op (op y x) z). Proof. intros; apply cong_left; apply op_comm. Qed. Lemma perm_right : forall x y z:U, cong (op (op x y) z) (op (op x z) y). Proof. intros. apply cong_trans with (op x (op y z)). apply op_ass. apply cong_trans with (op x (op z y)). apply cong_right; apply op_comm. apply cong_sym; apply op_ass. Qed. Lemma perm_left : forall x y z:U, cong (op x (op y z)) (op y (op x z)). Proof. intros. apply cong_trans with (op (op x y) z). apply cong_sym; apply op_ass. apply cong_trans with (op (op y x) z). apply cong_left; apply op_comm. apply op_ass. Qed. Lemma op_rotate : forall x y z t:U, cong (op x (op y z)) (op z (op x y)). Proof. intros; apply cong_trans with (op (op x y) z). apply cong_sym; apply op_ass. apply op_comm. Qed. (** Needed for treesort ... *) Lemma twist : forall x y z t:U, cong (op x (op (op y z) t)) (op (op y (op x t)) z). Proof. intros. apply cong_trans with (op x (op (op y t) z)). apply cong_right; apply perm_right. apply cong_trans with (op (op x (op y t)) z). apply cong_sym; apply op_ass. apply cong_left; apply perm_left. Qed. End Axiomatisation. coq-8.4pl4/theories/Sets/Relations_3.v0000644000175000017500000000517012326224777016747 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R x z -> coherent y z. Definition Locally_confluent : Prop := forall x:U, locally_confluent x. Definition confluent (x:U) : Prop := forall y z:U, Rstar U R x y -> Rstar U R x z -> coherent y z. Definition Confluent : Prop := forall x:U, confluent x. Inductive noetherian (x: U) : Prop := definition_of_noetherian : (forall y:U, R x y -> noetherian y) -> noetherian x. Definition Noetherian : Prop := forall x:U, noetherian x. End Relations_3. Hint Unfold coherent: sets v62. Hint Unfold locally_confluent: sets v62. Hint Unfold confluent: sets v62. Hint Unfold Confluent: sets v62. Hint Resolve definition_of_noetherian: sets v62. Hint Unfold Noetherian: sets v62. coq-8.4pl4/theories/Sets/intro.tex0000755000175000017500000000133512326224777016255 0ustar stephsteph\section{Sets}\label{Sets} This is a library on sets defined by their characteristic predicate. It contains the following modules: \begin{itemize} \item {\tt Ensembles.v} \item {\tt Constructive\_sets.v}, {\tt Classical\_sets.v} \item {\tt Relations\_1.v}, {\tt Relations\_2.v}, {\tt Relations\_3.v}, {\tt Relations\_1\_facts.v}, \\ {\tt Relations\_2\_facts.v}, {\tt Relations\_3\_facts.v} \item {\tt Partial\_Order.v}, {\tt Cpo.v} \item {\tt Powerset.v}, {\tt Powerset\_facts.v}, {\tt Powerset\_Classical\_facts.v} \item {\tt Finite\_sets.v}, {\tt Finite\_sets\_facts.v} \item {\tt Image.v} \item {\tt Infinite\_sets.v} \item {\tt Integers.v} \end{itemize} %%% Local Variables: %%% mode: latex %%% TeX-master: t %%% End: coq-8.4pl4/theories/Sets/Uniset.v0000644000175000017500000001261712326224777016040 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* A -> Prop. Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. Inductive uniset : Set := Charac : (A -> bool) -> uniset. Definition charac (s:uniset) (a:A) : bool := let (f) := s in f a. Definition Emptyset := Charac (fun a:A => false). Definition Fullset := Charac (fun a:A => true). Definition Singleton (a:A) := Charac (fun a':A => match eqA_dec a a' with | left h => true | right h => false end). Definition In (s:uniset) (a:A) : Prop := charac s a = true. Hint Unfold In. (** uniset inclusion *) Definition incl (s1 s2:uniset) := forall a:A, leb (charac s1 a) (charac s2 a). Hint Unfold incl. (** uniset equality *) Definition seq (s1 s2:uniset) := forall a:A, charac s1 a = charac s2 a. Hint Unfold seq. Lemma leb_refl : forall b:bool, leb b b. Proof. destruct b; simpl; auto. Qed. Hint Resolve leb_refl. Lemma incl_left : forall s1 s2:uniset, seq s1 s2 -> incl s1 s2. Proof. unfold incl; intros s1 s2 E a; elim (E a); auto. Qed. Lemma incl_right : forall s1 s2:uniset, seq s1 s2 -> incl s2 s1. Proof. unfold incl; intros s1 s2 E a; elim (E a); auto. Qed. Lemma seq_refl : forall x:uniset, seq x x. Proof. destruct x; unfold seq; auto. Qed. Hint Resolve seq_refl. Lemma seq_trans : forall x y z:uniset, seq x y -> seq y z -> seq x z. Proof. unfold seq. destruct x; destruct y; destruct z; simpl; intros. rewrite H; auto. Qed. Lemma seq_sym : forall x y:uniset, seq x y -> seq y x. Proof. unfold seq. destruct x; destruct y; simpl; auto. Qed. (** uniset union *) Definition union (m1 m2:uniset) := Charac (fun a:A => orb (charac m1 a) (charac m2 a)). Lemma union_empty_left : forall x:uniset, seq x (union Emptyset x). Proof. unfold seq; unfold union; simpl; auto. Qed. Hint Resolve union_empty_left. Lemma union_empty_right : forall x:uniset, seq x (union x Emptyset). Proof. unfold seq; unfold union; simpl. intros x a; rewrite (orb_b_false (charac x a)); auto. Qed. Hint Resolve union_empty_right. Lemma union_comm : forall x y:uniset, seq (union x y) (union y x). Proof. unfold seq; unfold charac; unfold union. destruct x; destruct y; auto with bool. Qed. Hint Resolve union_comm. Lemma union_ass : forall x y z:uniset, seq (union (union x y) z) (union x (union y z)). Proof. unfold seq; unfold union; unfold charac. destruct x; destruct y; destruct z; auto with bool. Qed. Hint Resolve union_ass. Lemma seq_left : forall x y z:uniset, seq x y -> seq (union x z) (union y z). Proof. unfold seq; unfold union; unfold charac. destruct x; destruct y; destruct z. intros; elim H; auto. Qed. Hint Resolve seq_left. Lemma seq_right : forall x y z:uniset, seq x y -> seq (union z x) (union z y). Proof. unfold seq; unfold union; unfold charac. destruct x; destruct y; destruct z. intros; elim H; auto. Qed. Hint Resolve seq_right. (** All the proofs that follow duplicate [Multiset_of_A] *) (** Here we should make uniset an abstract datatype, by hiding [Charac], [union], [charac]; all further properties are proved abstractly *) Require Import Permut. Lemma union_rotate : forall x y z:uniset, seq (union x (union y z)) (union z (union x y)). Proof. intros; apply (op_rotate uniset union seq); auto. exact seq_trans. Qed. Lemma seq_congr : forall x y z t:uniset, seq x y -> seq z t -> seq (union x z) (union y t). Proof. intros; apply (cong_congr uniset union seq); auto. exact seq_trans. Qed. Lemma union_perm_left : forall x y z:uniset, seq (union x (union y z)) (union y (union x z)). Proof. intros; apply (perm_left uniset union seq); auto. exact seq_trans. Qed. Lemma uniset_twist1 : forall x y z t:uniset, seq (union x (union (union y z) t)) (union (union y (union x t)) z). Proof. intros; apply (twist uniset union seq); auto. exact seq_trans. Qed. Lemma uniset_twist2 : forall x y z t:uniset, seq (union x (union (union y z) t)) (union (union y (union x z)) t). Proof. intros; apply seq_trans with (union (union x (union y z)) t). apply seq_sym; apply union_ass. apply seq_left; apply union_perm_left. Qed. (** specific for treesort *) Lemma treesort_twist1 : forall x y z t u:uniset, seq u (union y z) -> seq (union x (union u t)) (union (union y (union x t)) z). Proof. intros; apply seq_trans with (union x (union (union y z) t)). apply seq_right; apply seq_left; trivial. apply uniset_twist1. Qed. Lemma treesort_twist2 : forall x y z t u:uniset, seq u (union y z) -> seq (union x (union u t)) (union (union y (union x z)) t). Proof. intros; apply seq_trans with (union x (union (union y z) t)). apply seq_right; apply seq_left; trivial. apply uniset_twist2. Qed. (*i theory of minter to do similarly Require Min. (* uniset intersection *) Definition minter := [m1,m2:uniset] (Charac [a:A](andb (charac m1 a)(charac m2 a))). i*) End defs. Unset Implicit Arguments. coq-8.4pl4/theories/Sets/Infinite_sets.v0000644000175000017500000002123212326224777017365 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Included U X A -> Approximant A X. End Approx. Hint Resolve Defn_of_Approximant. Section Infinite_sets. Variable U : Type. Lemma make_new_approximant : forall A X:Ensemble U, ~ Finite U A -> Approximant U A X -> Inhabited U (Setminus U A X). Proof. intros A X H' H'0. elim H'0; intros H'1 H'2. apply Strict_super_set_contains_new_element; auto with sets. red; intro H'3; apply H'. rewrite <- H'3; auto with sets. Qed. Lemma approximants_grow : forall A X:Ensemble U, ~ Finite U A -> forall n:nat, cardinal U X n -> Included U X A -> exists Y : _, cardinal U Y (S n) /\ Included U Y A. Proof. intros A X H' n H'0; elim H'0; auto with sets. intro H'1. cut (Inhabited U (Setminus U A (Empty_set U))). intro H'2; elim H'2. intros x H'3. exists (Add U (Empty_set U) x); auto with sets. split. apply card_add; auto with sets. cut (In U A x). intro H'4; red; auto with sets. intros x0 H'5; elim H'5; auto with sets. intros x1 H'6; elim H'6; auto with sets. elim H'3; auto with sets. apply make_new_approximant; auto with sets. intros A0 n0 H'1 H'2 x H'3 H'5. lapply H'2; [ intro H'6; elim H'6; clear H'2 | clear H'2 ]; auto with sets. intros x0 H'2; try assumption. elim H'2; intros H'7 H'8; try exact H'8; clear H'2. elim (make_new_approximant A x0); auto with sets. intros x1 H'2; try assumption. exists (Add U x0 x1); auto with sets. split. apply card_add; auto with sets. elim H'2; auto with sets. red. intros x2 H'9; elim H'9; auto with sets. intros x3 H'10; elim H'10; auto with sets. elim H'2; auto with sets. auto with sets. apply Defn_of_Approximant; auto with sets. apply cardinal_finite with (n := S n0); auto with sets. Qed. Lemma approximants_grow' : forall A X:Ensemble U, ~ Finite U A -> forall n:nat, cardinal U X n -> Approximant U A X -> exists Y : _, cardinal U Y (S n) /\ Approximant U A Y. Proof. intros A X H' n H'0 H'1; try assumption. elim H'1. intros H'2 H'3. elimtype (exists Y : _, cardinal U Y (S n) /\ Included U Y A). intros x H'4; elim H'4; intros H'5 H'6; try exact H'5; clear H'4. exists x; auto with sets. split; [ auto with sets | idtac ]. apply Defn_of_Approximant; auto with sets. apply cardinal_finite with (n := S n); auto with sets. apply approximants_grow with (X := X); auto with sets. Qed. Lemma approximant_can_be_any_size : forall A X:Ensemble U, ~ Finite U A -> forall n:nat, exists Y : _, cardinal U Y n /\ Approximant U A Y. Proof. intros A H' H'0 n; elim n. exists (Empty_set U); auto with sets. intros n0 H'1; elim H'1. intros x H'2. apply approximants_grow' with (X := x); tauto. Qed. Variable V : Type. Theorem Image_set_continuous : forall (A:Ensemble U) (f:U -> V) (X:Ensemble V), Finite V X -> Included V X (Im U V A f) -> exists n : _, (exists Y : _, (cardinal U Y n /\ Included U Y A) /\ Im U V Y f = X). Proof. intros A f X H'; elim H'. intro H'0; exists 0. exists (Empty_set U); auto with sets. intros A0 H'0 H'1 x H'2 H'3; try assumption. lapply H'1; [ intro H'4; elim H'4; intros n E; elim E; clear H'4 H'1 | clear H'1 ]; auto with sets. intros x0 H'1; try assumption. exists (S n); try assumption. elim H'1; intros H'4 H'5; elim H'4; intros H'6 H'7; try exact H'6; clear H'4 H'1. clear E. generalize H'2. rewrite <- H'5. intro H'1; try assumption. red in H'3. generalize (H'3 x). intro H'4; lapply H'4; [ intro H'8; try exact H'8; clear H'4 | clear H'4 ]; auto with sets. specialize Im_inv with (U := U) (V := V) (X := A) (f := f) (y := x); intro H'11; lapply H'11; [ intro H'13; elim H'11; clear H'11 | clear H'11 ]; auto with sets. intros x1 H'4; try assumption. apply ex_intro with (x := Add U x0 x1). split; [ split; [ try assumption | idtac ] | idtac ]. apply card_add; auto with sets. red; intro H'9; try exact H'9. apply H'1. elim H'4; intros H'10 H'11; rewrite <- H'11; clear H'4; auto with sets. elim H'4; intros H'9 H'10; try exact H'9; clear H'4; auto with sets. red; auto with sets. intros x2 H'4; elim H'4; auto with sets. intros x3 H'11; elim H'11; auto with sets. elim H'4; intros H'9 H'10; rewrite <- H'10; clear H'4; auto with sets. apply Im_add; auto with sets. Qed. Theorem Image_set_continuous' : forall (A:Ensemble U) (f:U -> V) (X:Ensemble V), Approximant V (Im U V A f) X -> exists Y : _, Approximant U A Y /\ Im U V Y f = X. Proof. intros A f X H'; try assumption. cut (exists n : _, (exists Y : _, (cardinal U Y n /\ Included U Y A) /\ Im U V Y f = X)). intro H'0; elim H'0; intros n E; elim E; clear H'0. intros x H'0; try assumption. elim H'0; intros H'1 H'2; elim H'1; intros H'3 H'4; try exact H'3; clear H'1 H'0; auto with sets. exists x. split; [ idtac | try assumption ]. apply Defn_of_Approximant; auto with sets. apply cardinal_finite with (n := n); auto with sets. apply Image_set_continuous; auto with sets. elim H'; auto with sets. elim H'; auto with sets. Qed. Theorem Pigeonhole_bis : forall (A:Ensemble U) (f:U -> V), ~ Finite U A -> Finite V (Im U V A f) -> ~ injective U V f. Proof. intros A f H'0 H'1; try assumption. elim (Image_set_continuous' A f (Im U V A f)); auto with sets. intros x H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2. elim (make_new_approximant A x); auto with sets. intros x0 H'2; elim H'2. intros H'5 H'6. elim (finite_cardinal V (Im U V A f)); auto with sets. intros n E. elim (finite_cardinal U x); auto with sets. intros n0 E0. apply Pigeonhole with (A := Add U x x0) (n := S n0) (n' := n). apply card_add; auto with sets. rewrite (Im_add U V x x0 f); auto with sets. cut (In V (Im U V x f) (f x0)). intro H'8. rewrite (Non_disjoint_union V (Im U V x f) (f x0)); auto with sets. rewrite H'4; auto with sets. elim (Extension V (Im U V x f) (Im U V A f)); auto with sets. apply le_lt_n_Sm. apply cardinal_decreases with (U := U) (V := V) (A := x) (f := f); auto with sets. rewrite H'4; auto with sets. elim H'3; auto with sets. Qed. Theorem Pigeonhole_ter : forall (A:Ensemble U) (f:U -> V) (n:nat), injective U V f -> Finite V (Im U V A f) -> Finite U A. Proof. intros A f H' H'0 H'1. apply NNPP. red; intro H'2. elim (Pigeonhole_bis A f); auto with sets. Qed. End Infinite_sets. coq-8.4pl4/theories/Sets/Finite_sets.v0000644000175000017500000000563612326224777017050 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Prop := | Empty_is_finite : Finite (Empty_set U) | Union_is_finite : forall A:Ensemble U, Finite A -> forall x:U, ~ In U A x -> Finite (Add U A x). Inductive cardinal : Ensemble U -> nat -> Prop := | card_empty : cardinal (Empty_set U) 0 | card_add : forall (A:Ensemble U) (n:nat), cardinal A n -> forall x:U, ~ In U A x -> cardinal (Add U A x) (S n). End Ensembles_finis. Hint Resolve Empty_is_finite Union_is_finite: sets v62. Hint Resolve card_empty card_add: sets v62. Require Import Constructive_sets. Section Ensembles_finis_facts. Variable U : Type. Lemma cardinal_invert : forall (X:Ensemble U) (p:nat), cardinal U X p -> match p with | O => X = Empty_set U | S n => exists A : _, (exists x : _, X = Add U A x /\ ~ In U A x /\ cardinal U A n) end. Proof. induction 1; simpl; auto. exists A; exists x; auto. Qed. Lemma cardinal_elim : forall (X:Ensemble U) (p:nat), cardinal U X p -> match p with | O => X = Empty_set U | S n => Inhabited U X end. Proof. intros X p C; elim C; simpl; trivial with sets. Qed. End Ensembles_finis_facts. coq-8.4pl4/theories/Classes/0000755000175000017500000000000012365131023015032 5ustar stephstephcoq-8.4pl4/theories/Classes/Morphisms.v0000644000175000017500000005055712326224777017236 0ustar stephsteph(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Type) (D : B -> Type) (R : A -> B -> Prop) (R' : forall (x : A) (y : B), C x -> D y -> Prop) : (forall x : A, C x) -> (forall x : B, D x) -> Prop := fun f g => forall x y, R x y -> R' x y (f x) (g y). (** The non-dependent version is an instance where we forget dependencies. *) Definition respectful {A B : Type} (R : relation A) (R' : relation B) : relation (A -> B) := Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R'). (** Notations reminiscent of the old syntax for declaring morphisms. *) Delimit Scope signature_scope with signature. Arguments Proper {A}%type R%signature m. Arguments respectful {A B}%type (R R')%signature _ _. Module ProperNotations. Notation " R ++> R' " := (@respectful _ _ (R%signature) (R'%signature)) (right associativity, at level 55) : signature_scope. Notation " R ==> R' " := (@respectful _ _ (R%signature) (R'%signature)) (right associativity, at level 55) : signature_scope. Notation " R --> R' " := (@respectful _ _ (inverse (R%signature)) (R'%signature)) (right associativity, at level 55) : signature_scope. End ProperNotations. Export ProperNotations. Local Open Scope signature_scope. (** [solve_proper] try to solve the goal [Proper (?==> ... ==>?) f] by repeated introductions and setoid rewrites. It should work fine when [f] is a combination of already known morphisms and quantifiers. *) Ltac solve_respectful t := match goal with | |- respectful _ _ _ _ => let H := fresh "H" in intros ? ? H; solve_respectful ltac:(setoid_rewrite H; t) | _ => t; reflexivity end. Ltac solve_proper := unfold Proper; solve_respectful ltac:(idtac). (** [f_equiv] is a clone of [f_equal] that handles setoid equivalences. For example, if we know that [f] is a morphism for [E1==>E2==>E], then the goal [E (f x y) (f x' y')] will be transformed by [f_equiv] into the subgoals [E1 x x'] and [E2 y y']. *) Ltac f_equiv := match goal with | |- ?R (?f ?x) (?f' _) => let T := type of x in let Rx := fresh "R" in evar (Rx : relation T); let H := fresh in assert (H : (Rx==>R)%signature f f'); unfold Rx in *; clear Rx; [ f_equiv | apply H; clear H; try reflexivity ] | |- ?R ?f ?f' => try reflexivity; change (Proper R f); eauto with typeclass_instances; fail | _ => idtac end. (** [forall_def] reifies the dependent product as a definition. *) Definition forall_def {A : Type} (B : A -> Type) : Type := forall x : A, B x. (** Dependent pointwise lifting of a relation on the range. *) Definition forall_relation {A : Type} {B : A -> Type} (sig : forall a, relation (B a)) : relation (forall x, B x) := fun f g => forall a, sig a (f a) (g a). Arguments forall_relation {A B}%type sig%signature _ _. (** Non-dependent pointwise lifting *) Definition pointwise_relation (A : Type) {B : Type} (R : relation B) : relation (A -> B) := Eval compute in forall_relation (B:=fun _ => B) (fun _ => R). Lemma pointwise_pointwise A B (R : relation B) : relation_equivalence (pointwise_relation A R) (@eq A ==> R). Proof. intros. split. simpl_relation. firstorder. Qed. (** We can build a PER on the Coq function space if we have PERs on the domain and codomain. *) Hint Unfold Reflexive : core. Hint Unfold Symmetric : core. Hint Unfold Transitive : core. Typeclasses Opaque respectful pointwise_relation forall_relation. Program Instance respectful_per `(PER A R, PER B R') : PER (R ==> R'). Next Obligation. Proof with auto. assert(R x0 x0). transitivity y0... symmetry... transitivity (y x0)... Qed. (** Subrelations induce a morphism on the identity. *) Instance subrelation_id_proper `(subrelation A R₁ R₂) : Proper (R₁ ==> R₂) id. Proof. firstorder. Qed. (** The subrelation property goes through products as usual. *) Lemma subrelation_respectful `(subl : subrelation A R₂ R₁, subr : subrelation B S₁ S₂) : subrelation (R₁ ==> S₁) (R₂ ==> S₂). Proof. simpl_relation. apply subr. apply H. apply subl. apply H0. Qed. (** And of course it is reflexive. *) Lemma subrelation_refl A R : @subrelation A R R. Proof. simpl_relation. Qed. Ltac subrelation_tac T U := (is_ground T ; is_ground U ; class_apply @subrelation_refl) || class_apply @subrelation_respectful || class_apply @subrelation_refl. Hint Extern 3 (@subrelation _ ?T ?U) => subrelation_tac T U : typeclass_instances. (** [Proper] is itself a covariant morphism for [subrelation]. *) Lemma subrelation_proper `(mor : Proper A R₁ m, unc : Unconvertible (relation A) R₁ R₂, sub : subrelation A R₁ R₂) : Proper R₂ m. Proof. intros. apply sub. apply mor. Qed. CoInductive apply_subrelation : Prop := do_subrelation. Ltac proper_subrelation := match goal with [ H : apply_subrelation |- _ ] => clear H ; class_apply @subrelation_proper end. Hint Extern 5 (@Proper _ ?H _) => proper_subrelation : typeclass_instances. Instance proper_subrelation_proper : Proper (subrelation ++> eq ==> impl) (@Proper A). Proof. reduce. subst. firstorder. Qed. (** Essential subrelation instances for [iff], [impl] and [pointwise_relation]. *) Instance iff_impl_subrelation : subrelation iff impl | 2. Proof. firstorder. Qed. Instance iff_inverse_impl_subrelation : subrelation iff (inverse impl) | 2. Proof. firstorder. Qed. Instance pointwise_subrelation {A} `(sub : subrelation B R R') : subrelation (pointwise_relation A R) (pointwise_relation A R') | 4. Proof. reduce. unfold pointwise_relation in *. apply sub. apply H. Qed. (** For dependent function types. *) Lemma forall_subrelation A (B : A -> Type) (R S : forall x : A, relation (B x)) : (forall a, subrelation (R a) (S a)) -> subrelation (forall_relation R) (forall_relation S). Proof. reduce. apply H. apply H0. Qed. (** We use an extern hint to help unification. *) Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S)) => apply (@forall_subrelation A B R S) ; intro : typeclass_instances. (** Any symmetric relation is equal to its inverse. *) Lemma subrelation_symmetric A R `(Symmetric A R) : subrelation (inverse R) R. Proof. reduce. red in H0. symmetry. assumption. Qed. Hint Extern 4 (subrelation (inverse _) _) => class_apply @subrelation_symmetric : typeclass_instances. (** The complement of a relation conserves its proper elements. *) Program Definition complement_proper `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) : Proper (RA ==> RA ==> iff) (complement R) := _. Next Obligation. Proof. unfold complement. pose (mR x y H x0 y0 H0). intuition. Qed. Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper : typeclass_instances. (** The [inverse] too, actually the [flip] instance is a bit more general. *) Program Definition flip_proper `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) : Proper (RB ==> RA ==> RC) (flip f) := _. Next Obligation. Proof. apply mor ; auto. Qed. Hint Extern 1 (Proper _ (flip _)) => apply @flip_proper : typeclass_instances. (** Every Transitive relation gives rise to a binary morphism on [impl], contravariant in the first argument, covariant in the second. *) Program Instance trans_contra_co_morphism `(Transitive A R) : Proper (R --> R ++> impl) R. Next Obligation. Proof with auto. transitivity x... transitivity x0... Qed. (** Proper declarations for partial applications. *) Program Instance trans_contra_inv_impl_morphism `(Transitive A R) : Proper (R --> inverse impl) (R x) | 3. Next Obligation. Proof with auto. transitivity y... Qed. Program Instance trans_co_impl_morphism `(Transitive A R) : Proper (R ++> impl) (R x) | 3. Next Obligation. Proof with auto. transitivity x0... Qed. Program Instance trans_sym_co_inv_impl_morphism `(PER A R) : Proper (R ++> inverse impl) (R x) | 3. Next Obligation. Proof with auto. transitivity y... symmetry... Qed. Program Instance trans_sym_contra_impl_morphism `(PER A R) : Proper (R --> impl) (R x) | 3. Next Obligation. Proof with auto. transitivity x0... symmetry... Qed. Program Instance per_partial_app_morphism `(PER A R) : Proper (R ==> iff) (R x) | 2. Next Obligation. Proof with auto. split. intros ; transitivity x0... intros. transitivity y... symmetry... Qed. (** Every Transitive relation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof to get an [R y z] goal. *) Program Instance trans_co_eq_inv_impl_morphism `(Transitive A R) : Proper (R ==> (@eq A) ==> inverse impl) R | 2. Next Obligation. Proof with auto. transitivity y... Qed. (** Every Symmetric and Transitive relation gives rise to an equivariant morphism. *) Program Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1. Next Obligation. Proof with auto. split ; intros. transitivity x0... transitivity x... symmetry... transitivity y... transitivity y0... symmetry... Qed. Lemma symmetric_equiv_inverse `(Symmetric A R) : relation_equivalence R (flip R). Proof. firstorder. Qed. Program Instance compose_proper A B C R₀ R₁ R₂ : Proper ((R₁ ==> R₂) ==> (R₀ ==> R₁) ==> (R₀ ==> R₂)) (@compose A B C). Next Obligation. Proof. simpl_relation. unfold compose. apply H. apply H0. apply H1. Qed. (** Coq functions are morphisms for Leibniz equality, applied only if really needed. *) Instance reflexive_eq_dom_reflexive (A : Type) `(Reflexive B R') : Reflexive (@Logic.eq A ==> R'). Proof. simpl_relation. Qed. (** [respectful] is a morphism for relation equivalence. *) Instance respectful_morphism : Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) (@respectful A B). Proof. reduce. unfold respectful, relation_equivalence, predicate_equivalence in * ; simpl in *. split ; intros. rewrite <- H0. apply H1. rewrite H. assumption. rewrite H0. apply H1. rewrite <- H. assumption. Qed. (** Every element in the carrier of a reflexive relation is a morphism for this relation. We use a proxy class for this case which is used internally to discharge reflexivity constraints. The [Reflexive] instance will almost always be used, but it won't apply in general to any kind of [Proper (A -> B) _ _] goal, making proof-search much slower. A cleaner solution would be to be able to set different priorities in different hint bases and select a particular hint database for resolution of a type class constraint.*) Class ProperProxy {A} (R : relation A) (m : A) : Prop := proper_proxy : R m m. Lemma eq_proper_proxy A (x : A) : ProperProxy (@eq A) x. Proof. firstorder. Qed. Lemma reflexive_proper_proxy `(Reflexive A R) (x : A) : ProperProxy R x. Proof. firstorder. Qed. Lemma proper_proper_proxy `(Proper A R x) : ProperProxy R x. Proof. firstorder. Qed. Hint Extern 1 (ProperProxy _ _) => class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances. Hint Extern 2 (ProperProxy ?R _) => not_evar R; class_apply @proper_proper_proxy : typeclass_instances. (** [R] is Reflexive, hence we can build the needed proof. *) Lemma Reflexive_partial_app_morphism `(Proper (A -> B) (R ==> R') m, ProperProxy A R x) : Proper R' (m x). Proof. simpl_relation. Qed. Class Params {A : Type} (of : A) (arity : nat). Class PartialApplication. CoInductive normalization_done : Prop := did_normalization. Ltac partial_application_tactic := let rec do_partial_apps H m cont := match m with | ?m' ?x => class_apply @Reflexive_partial_app_morphism ; [(do_partial_apps H m' ltac:idtac)|clear H] | _ => cont end in let rec do_partial H ar m := match ar with | 0%nat => do_partial_apps H m ltac:(fail 1) | S ?n' => match m with ?m' ?x => do_partial H n' m' end end in let params m sk fk := (let m' := fresh in head_of_constr m' m ; let n := fresh in evar (n:nat) ; let v := eval compute in n in clear n ; let H := fresh in assert(H:Params m' v) by typeclasses eauto ; let v' := eval compute in v in subst m'; (sk H v' || fail 1)) || fk in let on_morphism m cont := params m ltac:(fun H n => do_partial H n m) ltac:(cont) in match goal with | [ _ : normalization_done |- _ ] => fail 1 | [ _ : @Params _ _ _ |- _ ] => fail 1 | [ |- @Proper ?T _ (?m ?x) ] => match goal with | [ H : PartialApplication |- _ ] => class_apply @Reflexive_partial_app_morphism; [|clear H] | _ => on_morphism (m x) ltac:(class_apply @Reflexive_partial_app_morphism) end end. Hint Extern 4 (@Proper _ _ _) => partial_application_tactic : typeclass_instances. Lemma inverse_respectful : forall (A : Type) (R : relation A) (B : Type) (R' : relation B), relation_equivalence (inverse (R ==> R')) (inverse R ==> inverse R'). Proof. intros. unfold flip, respectful. split ; intros ; intuition. Qed. (** Special-purpose class to do normalization of signatures w.r.t. inverse. *) Class Normalizes (A : Type) (m : relation A) (m' : relation A) : Prop := normalizes : relation_equivalence m m'. (** Current strategy: add [inverse] everywhere and reduce using [subrelation] afterwards. *) Lemma inverse_atom A R : Normalizes A R (inverse (inverse R)). Proof. firstorder. Qed. Lemma inverse_arrow `(NA : Normalizes A R (inverse R'''), NB : Normalizes B R' (inverse R'')) : Normalizes (A -> B) (R ==> R') (inverse (R''' ==> R'')%signature). Proof. unfold Normalizes in *. intros. rewrite NA, NB. firstorder. Qed. Ltac inverse := match goal with | [ |- Normalizes _ (respectful _ _) _ ] => class_apply @inverse_arrow | _ => class_apply @inverse_atom end. Hint Extern 1 (Normalizes _ _ _) => inverse : typeclass_instances. (** Treating inverse: can't make them direct instances as we need at least a [flip] present in the goal. *) Lemma inverse1 `(subrelation A R' R) : subrelation (inverse (inverse R')) R. Proof. firstorder. Qed. Lemma inverse2 `(subrelation A R R') : subrelation R (inverse (inverse R')). Proof. firstorder. Qed. Hint Extern 1 (subrelation (flip _) _) => class_apply @inverse1 : typeclass_instances. Hint Extern 1 (subrelation _ (flip _)) => class_apply @inverse2 : typeclass_instances. (** That's if and only if *) Lemma eq_subrelation `(Reflexive A R) : subrelation (@eq A) R. Proof. simpl_relation. Qed. (* Hint Extern 3 (subrelation eq ?R) => not_evar R ; class_apply eq_subrelation : typeclass_instances. *) (** Once we have normalized, we will apply this instance to simplify the problem. *) Definition proper_inverse_proper `(mor : Proper A R m) : Proper (inverse R) m := mor. Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_inverse_proper : typeclass_instances. (** Bootstrap !!! *) Instance proper_proper : Proper (relation_equivalence ==> eq ==> iff) (@Proper A). Proof. simpl_relation. reduce in H. split ; red ; intros. setoid_rewrite <- H. apply H0. setoid_rewrite H. apply H0. Qed. Lemma proper_normalizes_proper `(Normalizes A R0 R1, Proper A R1 m) : Proper R0 m. Proof. red in H, H0. setoid_rewrite H. assumption. Qed. Ltac proper_normalization := match goal with | [ _ : normalization_done |- _ ] => fail 1 | [ _ : apply_subrelation |- @Proper _ ?R _ ] => let H := fresh "H" in set(H:=did_normalization) ; class_apply @proper_normalizes_proper end. Hint Extern 6 (@Proper _ _ _) => proper_normalization : typeclass_instances. (** Every reflexive relation gives rise to a morphism, only for immediately solving goals without variables. *) Lemma reflexive_proper `{Reflexive A R} (x : A) : Proper R x. Proof. firstorder. Qed. Lemma proper_eq A (x : A) : Proper (@eq A) x. Proof. intros. apply reflexive_proper. Qed. Ltac proper_reflexive := match goal with | [ _ : normalization_done |- _ ] => fail 1 | _ => class_apply proper_eq || class_apply @reflexive_proper end. Hint Extern 7 (@Proper _ _ _) => proper_reflexive : typeclass_instances. (** When the relation on the domain is symmetric, we can inverse the relation on the codomain. Same for binary functions. *) Lemma proper_sym_flip : forall `(Symmetric A R1)`(Proper (A->B) (R1==>R2) f), Proper (R1==>inverse R2) f. Proof. intros A R1 Sym B R2 f Hf. intros x x' Hxx'. apply Hf, Sym, Hxx'. Qed. Lemma proper_sym_flip_2 : forall `(Symmetric A R1)`(Symmetric B R2)`(Proper (A->B->C) (R1==>R2==>R3) f), Proper (R1==>R2==>inverse R3) f. Proof. intros A R1 Sym1 B R2 Sym2 C R3 f Hf. intros x x' Hxx' y y' Hyy'. apply Hf; auto. Qed. (** When the relation on the domain is symmetric, a predicate is compatible with [iff] as soon as it is compatible with [impl]. Same with a binary relation. *) Lemma proper_sym_impl_iff : forall `(Symmetric A R)`(Proper _ (R==>impl) f), Proper (R==>iff) f. Proof. intros A R Sym f Hf x x' Hxx'. repeat red in Hf. split; eauto. Qed. Lemma proper_sym_impl_iff_2 : forall `(Symmetric A R)`(Symmetric B R')`(Proper _ (R==>R'==>impl) f), Proper (R==>R'==>iff) f. Proof. intros A R Sym B R' Sym' f Hf x x' Hxx' y y' Hyy'. repeat red in Hf. split; eauto. Qed. (** A [PartialOrder] is compatible with its underlying equivalence. *) Instance PartialOrder_proper `(PartialOrder A eqA R) : Proper (eqA==>eqA==>iff) R. Proof. intros. apply proper_sym_impl_iff_2; auto with *. intros x x' Hx y y' Hy Hr. transitivity x. generalize (partial_order_equivalence x x'); compute; intuition. transitivity y; auto. generalize (partial_order_equivalence y y'); compute; intuition. Qed. (** From a [PartialOrder] to the corresponding [StrictOrder]: [lt = le /\ ~eq]. If the order is total, we could also say [gt = ~le]. *) Lemma PartialOrder_StrictOrder `(PartialOrder A eqA R) : StrictOrder (relation_conjunction R (complement eqA)). Proof. split; compute. intros x (_,Hx). apply Hx, Equivalence_Reflexive. intros x y z (Hxy,Hxy') (Hyz,Hyz'). split. apply PreOrder_Transitive with y; assumption. intro Hxz. apply Hxy'. apply partial_order_antisym; auto. rewrite Hxz; auto. Qed. Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => class_apply PartialOrder_StrictOrder : typeclass_instances. (** From a [StrictOrder] to the corresponding [PartialOrder]: [le = lt \/ eq]. If the order is total, we could also say [ge = ~lt]. *) Lemma StrictOrder_PreOrder `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iff) R) : PreOrder (relation_disjunction R eqA). Proof. split. intros x. right. reflexivity. intros x y z [Hxy|Hxy] [Hyz|Hyz]. left. transitivity y; auto. left. rewrite <- Hyz; auto. left. rewrite Hxy; auto. right. transitivity y; auto. Qed. Hint Extern 4 (PreOrder (relation_disjunction _ _)) => class_apply StrictOrder_PreOrder : typeclass_instances. Lemma StrictOrder_PartialOrder `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iff) R) : PartialOrder eqA (relation_disjunction R eqA). Proof. intros. intros x y. compute. intuition. elim (StrictOrder_Irreflexive x). transitivity y; auto. Qed. Hint Extern 4 (PartialOrder _ (relation_disjunction _ _)) => class_apply StrictOrder_PartialOrder : typeclass_instances. coq-8.4pl4/theories/Classes/RelationClasses.v0000644000175000017500000003624012326224777020341 0ustar stephsteph(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R x y -> False. (** Opaque for proof-search. *) Typeclasses Opaque complement. (** These are convertible. *) Lemma complement_inverse : forall A (R : relation A), complement (inverse R) = inverse (complement R). Proof. reflexivity. Qed. (** We rebind relations in separate classes to be able to overload each proof. *) Set Implicit Arguments. Unset Strict Implicit. Class Reflexive {A} (R : relation A) := reflexivity : forall x, R x x. Class Irreflexive {A} (R : relation A) := irreflexivity : Reflexive (complement R). Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances. Class Symmetric {A} (R : relation A) := symmetry : forall x y, R x y -> R y x. Class Asymmetric {A} (R : relation A) := asymmetry : forall x y, R x y -> R y x -> False. Class Transitive {A} (R : relation A) := transitivity : forall x y z, R x y -> R y z -> R x z. Hint Resolve @irreflexivity : ord. Unset Implicit Arguments. (** A HintDb for relations. *) Ltac solve_relation := match goal with | [ |- ?R ?x ?x ] => reflexivity | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H end. Hint Extern 4 => solve_relation : relations. (** We can already dualize all these properties. *) Generalizable Variables A B C D R S T U l eqA eqB eqC eqD. Lemma flip_Reflexive `{Reflexive A R} : Reflexive (flip R). Proof. tauto. Qed. Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances. Program Definition flip_Irreflexive `(Irreflexive A R) : Irreflexive (flip R) := irreflexivity (R:=R). Program Definition flip_Symmetric `(Symmetric A R) : Symmetric (flip R) := fun x y H => symmetry (R:=R) H. Program Definition flip_Asymmetric `(Asymmetric A R) : Asymmetric (flip R) := fun x y H H' => asymmetry (R:=R) H H'. Program Definition flip_Transitive `(Transitive A R) : Transitive (flip R) := fun x y z H H' => transitivity (R:=R) H' H. Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances. Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances. Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances. Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances. Definition Reflexive_complement_Irreflexive `(Reflexive A (R : relation A)) : Irreflexive (complement R). Proof. firstorder. Qed. Definition complement_Symmetric `(Symmetric A (R : relation A)) : Symmetric (complement R). Proof. firstorder. Qed. Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances. Hint Extern 3 (Irreflexive (complement _)) => class_apply Reflexive_complement_Irreflexive : typeclass_instances. (** * Standard instances. *) Ltac reduce_hyp H := match type of H with | context [ _ <-> _ ] => fail 1 | _ => red in H ; try reduce_hyp H end. Ltac reduce_goal := match goal with | [ |- _ <-> _ ] => fail 1 | _ => red ; intros ; try reduce_goal end. Tactic Notation "reduce" "in" hyp(Hid) := reduce_hyp Hid. Ltac reduce := reduce_goal. Tactic Notation "apply" "*" constr(t) := first [ refine t | refine (t _) | refine (t _ _) | refine (t _ _ _) | refine (t _ _ _ _) | refine (t _ _ _ _ _) | refine (t _ _ _ _ _ _) | refine (t _ _ _ _ _ _ _) ]. Ltac simpl_relation := unfold flip, impl, arrow ; try reduce ; program_simpl ; try ( solve [ intuition ]). Local Obligation Tactic := simpl_relation. (** Logical implication. *) Program Instance impl_Reflexive : Reflexive impl. Program Instance impl_Transitive : Transitive impl. (** Logical equivalence. *) Instance iff_Reflexive : Reflexive iff := iff_refl. Instance iff_Symmetric : Symmetric iff := iff_sym. Instance iff_Transitive : Transitive iff := iff_trans. (** Leibniz equality. *) Instance eq_Reflexive {A} : Reflexive (@eq A) := @eq_refl A. Instance eq_Symmetric {A} : Symmetric (@eq A) := @eq_sym A. Instance eq_Transitive {A} : Transitive (@eq A) := @eq_trans A. (** Various combinations of reflexivity, symmetry and transitivity. *) (** A [PreOrder] is both Reflexive and Transitive. *) Class PreOrder {A} (R : relation A) : Prop := { PreOrder_Reflexive :> Reflexive R | 2 ; PreOrder_Transitive :> Transitive R | 2 }. (** A partial equivalence relation is Symmetric and Transitive. *) Class PER {A} (R : relation A) : Prop := { PER_Symmetric :> Symmetric R | 3 ; PER_Transitive :> Transitive R | 3 }. (** Equivalence relations. *) Class Equivalence {A} (R : relation A) : Prop := { Equivalence_Reflexive :> Reflexive R ; Equivalence_Symmetric :> Symmetric R ; Equivalence_Transitive :> Transitive R }. (** An Equivalence is a PER plus reflexivity. *) Instance Equivalence_PER `(Equivalence A R) : PER R | 10 := { PER_Symmetric := Equivalence_Symmetric ; PER_Transitive := Equivalence_Transitive }. (** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *) Class Antisymmetric A eqA `{equ : Equivalence A eqA} (R : relation A) := antisymmetry : forall {x y}, R x y -> R y x -> eqA x y. Program Definition flip_antiSymmetric `(Antisymmetric A eqA R) : Antisymmetric A eqA (flip R). Proof. firstorder. Qed. (** Leibinz equality [eq] is an equivalence relation. The instance has low priority as it is always applicable if only the type is constrained. *) Program Instance eq_equivalence : Equivalence (@eq A) | 10. (** Logical equivalence [iff] is an equivalence relation. *) Program Instance iff_equivalence : Equivalence iff. (** We now develop a generalization of results on relations for arbitrary predicates. The resulting theory can be applied to homogeneous binary relations but also to arbitrary n-ary predicates. *) Local Open Scope list_scope. (* Notation " [ ] " := nil : list_scope. *) (* Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) (at level 1) : list_scope. *) (** A compact representation of non-dependent arities, with the codomain singled-out. *) (* Note, we do not use [list Type] because it imposes unnecessary universe constraints *) Inductive Tlist : Type := Tnil : Tlist | Tcons : Type -> Tlist -> Tlist. Local Infix "::" := Tcons. Fixpoint arrows (l : Tlist) (r : Type) : Type := match l with | Tnil => r | A :: l' => A -> arrows l' r end. (** We can define abbreviations for operation and relation types based on [arrows]. *) Definition unary_operation A := arrows (A::Tnil) A. Definition binary_operation A := arrows (A::A::Tnil) A. Definition ternary_operation A := arrows (A::A::A::Tnil) A. (** We define n-ary [predicate]s as functions into [Prop]. *) Notation predicate l := (arrows l Prop). (** Unary predicates, or sets. *) Definition unary_predicate A := predicate (A::Tnil). (** Homogeneous binary relations, equivalent to [relation A]. *) Definition binary_relation A := predicate (A::A::Tnil). (** We can close a predicate by universal or existential quantification. *) Fixpoint predicate_all (l : Tlist) : predicate l -> Prop := match l with | Tnil => fun f => f | A :: tl => fun f => forall x : A, predicate_all tl (f x) end. Fixpoint predicate_exists (l : Tlist) : predicate l -> Prop := match l with | Tnil => fun f => f | A :: tl => fun f => exists x : A, predicate_exists tl (f x) end. (** Pointwise extension of a binary operation on [T] to a binary operation on functions whose codomain is [T]. For an operator on [Prop] this lifts the operator to a binary operation. *) Fixpoint pointwise_extension {T : Type} (op : binary_operation T) (l : Tlist) : binary_operation (arrows l T) := match l with | Tnil => fun R R' => op R R' | A :: tl => fun R R' => fun x => pointwise_extension op tl (R x) (R' x) end. (** Pointwise lifting, equivalent to doing [pointwise_extension] and closing using [predicate_all]. *) Fixpoint pointwise_lifting (op : binary_relation Prop) (l : Tlist) : binary_relation (predicate l) := match l with | Tnil => fun R R' => op R R' | A :: tl => fun R R' => forall x, pointwise_lifting op tl (R x) (R' x) end. (** The n-ary equivalence relation, defined by lifting the 0-ary [iff] relation. *) Definition predicate_equivalence {l : Tlist} : binary_relation (predicate l) := pointwise_lifting iff l. (** The n-ary implication relation, defined by lifting the 0-ary [impl] relation. *) Definition predicate_implication {l : Tlist} := pointwise_lifting impl l. (** Notations for pointwise equivalence and implication of predicates. *) Infix "<∙>" := predicate_equivalence (at level 95, no associativity) : predicate_scope. Infix "-∙>" := predicate_implication (at level 70, right associativity) : predicate_scope. Local Open Scope predicate_scope. (** The pointwise liftings of conjunction and disjunctions. Note that these are [binary_operation]s, building new relations out of old ones. *) Definition predicate_intersection := pointwise_extension and. Definition predicate_union := pointwise_extension or. Infix "/∙\" := predicate_intersection (at level 80, right associativity) : predicate_scope. Infix "\∙/" := predicate_union (at level 85, right associativity) : predicate_scope. (** The always [True] and always [False] predicates. *) Fixpoint true_predicate {l : Tlist} : predicate l := match l with | Tnil => True | A :: tl => fun _ => @true_predicate tl end. Fixpoint false_predicate {l : Tlist} : predicate l := match l with | Tnil => False | A :: tl => fun _ => @false_predicate tl end. Notation "∙âŠĪ∙" := true_predicate : predicate_scope. Notation "∙âŠĨ∙" := false_predicate : predicate_scope. (** Predicate equivalence is an equivalence, and predicate implication defines a preorder. *) Program Instance predicate_equivalence_equivalence : Equivalence (@predicate_equivalence l). Next Obligation. induction l ; firstorder. Qed. Next Obligation. induction l ; firstorder. Qed. Next Obligation. fold pointwise_lifting. induction l. firstorder. intros. simpl in *. pose (IHl (x x0) (y x0) (z x0)). firstorder. Qed. Program Instance predicate_implication_preorder : PreOrder (@predicate_implication l). Next Obligation. induction l ; firstorder. Qed. Next Obligation. induction l. firstorder. unfold predicate_implication in *. simpl in *. intro. pose (IHl (x x0) (y x0) (z x0)). firstorder. Qed. (** We define the various operations which define the algebra on binary relations, from the general ones. *) Definition relation_equivalence {A : Type} : relation (relation A) := @predicate_equivalence (_::_::Tnil). Class subrelation {A:Type} (R R' : relation A) : Prop := is_subrelation : @predicate_implication (A::A::Tnil) R R'. Arguments subrelation {A} R R'. Definition relation_conjunction {A} (R : relation A) (R' : relation A) : relation A := @predicate_intersection (A::A::Tnil) R R'. Definition relation_disjunction {A} (R : relation A) (R' : relation A) : relation A := @predicate_union (A::A::Tnil) R R'. (** Relation equivalence is an equivalence, and subrelation defines a partial order. *) Set Automatic Introduction. Instance relation_equivalence_equivalence (A : Type) : Equivalence (@relation_equivalence A). Proof. exact (@predicate_equivalence_equivalence (A::A::Tnil)). Qed. Instance relation_implication_preorder A : PreOrder (@subrelation A). Proof. exact (@predicate_implication_preorder (A::A::Tnil)). Qed. (** *** Partial Order. A partial order is a preorder which is additionally antisymmetric. We give an equivalent definition, up-to an equivalence relation on the carrier. *) Class PartialOrder {A} eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} := partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (inverse R)). (** The equivalence proof is sufficient for proving that [R] must be a morphism for equivalence (see Morphisms). It is also sufficient to show that [R] is antisymmetric w.r.t. [eqA] *) Instance partial_order_antisym `(PartialOrder A eqA R) : ! Antisymmetric A eqA R. Proof with auto. reduce_goal. pose proof partial_order_equivalence as poe. do 3 red in poe. apply <- poe. firstorder. Qed. (** The partial order defined by subrelation and relation equivalence. *) Program Instance subrelation_partial_order : ! PartialOrder (relation A) relation_equivalence subrelation. Next Obligation. Proof. unfold relation_equivalence in *. compute; firstorder. Qed. Typeclasses Opaque arrows predicate_implication predicate_equivalence relation_equivalence pointwise_lifting. (** Rewrite relation on a given support: declares a relation as a rewrite relation for use by the generalized rewriting tactic. It helps choosing if a rewrite should be handled by the generalized or the regular rewriting tactic using leibniz equality. Users can declare an [RewriteRelation A RA] anywhere to declare default relations. This is also done automatically by the [Declare Relation A RA] commands. *) Class RewriteRelation {A : Type} (RA : relation A). Instance: RewriteRelation impl. Instance: RewriteRelation iff. Instance: RewriteRelation (@relation_equivalence A). (** Any [Equivalence] declared in the context is automatically considered a rewrite relation. *) Instance equivalence_rewrite_relation `(Equivalence A eqA) : RewriteRelation eqA. (** Strict Order *) Class StrictOrder {A : Type} (R : relation A) : Prop := { StrictOrder_Irreflexive :> Irreflexive R ; StrictOrder_Transitive :> Transitive R }. Instance StrictOrder_Asymmetric `(StrictOrder A R) : Asymmetric R. Proof. firstorder. Qed. (** Inversing a [StrictOrder] gives another [StrictOrder] *) Lemma StrictOrder_inverse `(StrictOrder A R) : StrictOrder (inverse R). Proof. firstorder. Qed. (** Same for [PartialOrder]. *) Lemma PreOrder_inverse `(PreOrder A R) : PreOrder (inverse R). Proof. firstorder. Qed. Hint Extern 3 (StrictOrder (inverse _)) => class_apply StrictOrder_inverse : typeclass_instances. Hint Extern 3 (PreOrder (inverse _)) => class_apply PreOrder_inverse : typeclass_instances. Lemma PartialOrder_inverse `(PartialOrder A eqA R) : PartialOrder eqA (inverse R). Proof. firstorder. Qed. Hint Extern 3 (PartialOrder (inverse _)) => class_apply PartialOrder_inverse : typeclass_instances. coq-8.4pl4/theories/Classes/vo.itarget0000644000175000017500000000025212326224777017056 0ustar stephstephEquivalence.vo EquivDec.vo Init.vo Morphisms_Prop.vo Morphisms_Relations.vo Morphisms.vo RelationClasses.vo SetoidClass.vo SetoidDec.vo SetoidTactics.vo RelationPairs.vo coq-8.4pl4/theories/Classes/SetoidClass.v0000644000175000017500000001063212326224777017460 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Equivalence equiv }. (* Too dangerous instance *) (* Program Instance [ eqa : Equivalence A eqA ] => *) (* equivalence_setoid : Setoid A := *) (* equiv := eqA ; setoid_equiv := eqa. *) (** Shortcuts to make proof search easier. *) Definition setoid_refl `(sa : Setoid A) : Reflexive equiv. Proof. typeclasses eauto. Qed. Definition setoid_sym `(sa : Setoid A) : Symmetric equiv. Proof. typeclasses eauto. Qed. Definition setoid_trans `(sa : Setoid A) : Transitive equiv. Proof. typeclasses eauto. Qed. Existing Instance setoid_refl. Existing Instance setoid_sym. Existing Instance setoid_trans. (** Standard setoids. *) (* Program Instance eq_setoid : Setoid A := *) (* equiv := eq ; setoid_equiv := eq_equivalence. *) Program Instance iff_setoid : Setoid Prop := { equiv := iff ; setoid_equiv := iff_equivalence }. (** Overloaded notations for setoid equivalence and inequivalence. Not to be confused with [eq] and [=]. *) (** Subset objects should be first coerced to their underlying type, but that notation doesn't work in the standard case then. *) (* Notation " x == y " := (equiv (x :>) (y :>)) (at level 70, no associativity) : type_scope. *) Notation " x == y " := (equiv x y) (at level 70, no associativity) : type_scope. Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : type_scope. (** Use the [clsubstitute] command which substitutes an equality in every hypothesis. *) Ltac clsubst H := lazymatch type of H with ?x == ?y => substitute H ; clear H x end. Ltac clsubst_nofail := match goal with | [ H : ?x == ?y |- _ ] => clsubst H ; clsubst_nofail | _ => idtac end. (** [subst*] will try its best at substituting every equality in the goal. *) Tactic Notation "clsubst" "*" := clsubst_nofail. Lemma nequiv_equiv_trans : forall `{Setoid A} (x y z : A), x =/= y -> y == z -> x =/= z. Proof with auto. intros; intro. assert(z == y) by (symmetry ; auto). assert(x == y) by (transitivity z ; eauto). contradiction. Qed. Lemma equiv_nequiv_trans : forall `{Setoid A} (x y z : A), x == y -> y =/= z -> x =/= z. Proof. intros; intro. assert(y == x) by (symmetry ; auto). assert(y == z) by (transitivity x ; eauto). contradiction. Qed. Ltac setoid_simplify_one := match goal with | [ H : (?x == ?x)%type |- _ ] => clear H | [ H : (?x == ?y)%type |- _ ] => clsubst H | [ |- (?x =/= ?y)%type ] => let name:=fresh "Hneq" in intro name end. Ltac setoid_simplify := repeat setoid_simplify_one. Ltac setoidify_tac := match goal with | [ s : Setoid ?A, H : ?R ?x ?y |- _ ] => change R with (@equiv A R s) in H | [ s : Setoid ?A |- context C [ ?R ?x ?y ] ] => change (R x y) with (@equiv A R s x y) end. Ltac setoidify := repeat setoidify_tac. (** Every setoid relation gives rise to a morphism, in fact every partial setoid does. *) Program Instance setoid_morphism `(sa : Setoid A) : Proper (equiv ++> equiv ++> iff) equiv := proper_prf. Program Instance setoid_partial_app_morphism `(sa : Setoid A) (x : A) : Proper (equiv ++> iff) (equiv x) := proper_prf. (** Partial setoids don't require reflexivity so we can build a partial setoid on the function space. *) Class PartialSetoid (A : Type) := { pequiv : relation A ; pequiv_prf :> PER pequiv }. (** Overloaded notation for partial setoid equivalence. *) Infix "=~=" := pequiv (at level 70, no associativity) : type_scope. (** Reset the default Program tactic. *) Obligation Tactic := program_simpl. coq-8.4pl4/theories/Classes/SetoidDec.v0000644000175000017500000000731212326224777017107 0ustar stephsteph(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ) (y :>)) (no associativity, at level 70). Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } := match x with | left H => @right _ _ H | right H => @left _ _ H end. Require Import Coq.Program.Program. Local Open Scope program_scope. (** Invert the branches. *) Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x == y } := swap_sumbool (x == y). (** Overloaded notation for inequality. *) Infix "=/=" := nequiv_dec (no associativity, at level 70). (** Define boolean versions, losing the logical information. *) Definition equiv_decb `{EqDec A} (x y : A) : bool := if x == y then true else false. Definition nequiv_decb `{EqDec A} (x y : A) : bool := negb (equiv_decb x y). Infix "==b" := equiv_decb (no associativity, at level 70). Infix "<>b" := nequiv_decb (no associativity, at level 70). (** Decidable leibniz equality instances. *) Require Import Coq.Arith.Arith. (** The equiv is burried inside the setoid, but we can recover it by specifying which setoid we're talking about. *) Program Instance eq_setoid A : Setoid A | 10 := { equiv := eq ; setoid_equiv := eq_equivalence }. Program Instance nat_eq_eqdec : EqDec (eq_setoid nat) := eq_nat_dec. Require Import Coq.Bool.Bool. Program Instance bool_eqdec : EqDec (eq_setoid bool) := bool_dec. Program Instance unit_eqdec : EqDec (eq_setoid unit) := fun x y => in_left. Next Obligation. Proof. destruct x ; destruct y. reflexivity. Qed. Program Instance prod_eqdec `(! EqDec (eq_setoid A), ! EqDec (eq_setoid B)) : EqDec (eq_setoid (prod A B)) := fun x y => let '(x1, x2) := x in let '(y1, y2) := y in if x1 == y1 then if x2 == y2 then in_left else in_right else in_right. Solve Obligations using unfold complement ; program_simpl. (** Objects of function spaces with countable domains like bool have decidable equality. *) Program Instance bool_function_eqdec `(! EqDec (eq_setoid A)) : EqDec (eq_setoid (bool -> A)) := fun f g => if f true == g true then if f false == g false then in_left else in_right else in_right. Solve Obligations using try red ; unfold equiv, complement ; program_simpl. Next Obligation. Proof. extensionality x. destruct x ; auto. Qed. coq-8.4pl4/theories/Classes/Morphisms_Prop.v0000644000175000017500000000766412326224777020237 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* impl) not | 1. Program Instance not_iff_morphism : Proper (iff ++> iff) not. (** Logical conjunction. *) Program Instance and_impl_morphism : Proper (impl ==> impl ==> impl) and | 1. Program Instance and_iff_morphism : Proper (iff ==> iff ==> iff) and. (** Logical disjunction. *) Program Instance or_impl_morphism : Proper (impl ==> impl ==> impl) or | 1. Program Instance or_iff_morphism : Proper (iff ==> iff ==> iff) or. (** Logical implication [impl] is a morphism for logical equivalence. *) Program Instance iff_iff_iff_impl_morphism : Proper (iff ==> iff ==> iff) impl. (** Morphisms for quantifiers *) Program Instance ex_iff_morphism {A : Type} : Proper (pointwise_relation A iff ==> iff) (@ex A). Next Obligation. Proof. unfold pointwise_relation in H. split ; intros. destruct H0 as [x1 H1]. exists x1. rewrite H in H1. assumption. destruct H0 as [x1 H1]. exists x1. rewrite H. assumption. Qed. Program Instance ex_impl_morphism {A : Type} : Proper (pointwise_relation A impl ==> impl) (@ex A) | 1. Next Obligation. Proof. unfold pointwise_relation in H. exists H0. apply H. assumption. Qed. Program Instance ex_inverse_impl_morphism {A : Type} : Proper (pointwise_relation A (inverse impl) ==> inverse impl) (@ex A) | 1. Next Obligation. Proof. unfold pointwise_relation in H. exists H0. apply H. assumption. Qed. Program Instance all_iff_morphism {A : Type} : Proper (pointwise_relation A iff ==> iff) (@all A). Next Obligation. Proof. unfold pointwise_relation, all in *. intuition ; specialize (H x0) ; intuition. Qed. Program Instance all_impl_morphism {A : Type} : Proper (pointwise_relation A impl ==> impl) (@all A) | 1. Next Obligation. Proof. unfold pointwise_relation, all in *. intuition ; specialize (H x0) ; intuition. Qed. Program Instance all_inverse_impl_morphism {A : Type} : Proper (pointwise_relation A (inverse impl) ==> inverse impl) (@all A) | 1. Next Obligation. Proof. unfold pointwise_relation, all in *. intuition ; specialize (H x0) ; intuition. Qed. (** Equivalent points are simultaneously accessible or not *) Instance Acc_pt_morphism {A:Type}(E R : A->A->Prop) `(Equivalence _ E) `(Proper _ (E==>E==>iff) R) : Proper (E==>iff) (Acc R). Proof. apply proper_sym_impl_iff; auto with *. intros x y EQ WF. apply Acc_intro; intros z Hz. rewrite <- EQ in Hz. now apply Acc_inv with x. Qed. (** Equivalent relations have the same accessible points *) Instance Acc_rel_morphism {A:Type} : Proper (@relation_equivalence A ==> Logic.eq ==> iff) (@Acc A). Proof. apply proper_sym_impl_iff_2. red; now symmetry. red; now symmetry. intros R R' EQ a a' Ha WF. subst a'. induction WF as [x _ WF']. constructor. intros y Ryx. now apply WF', EQ. Qed. (** Equivalent relations are simultaneously well-founded or not *) Instance well_founded_morphism {A : Type} : Proper (@relation_equivalence A ==> iff) (@well_founded A). Proof. unfold well_founded. solve_proper. Qed. coq-8.4pl4/theories/Classes/Equivalence.v0000644000175000017500000001023412326224777017502 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* substitute H ; clear H x end. Ltac setoid_subst_nofail := match goal with | [ H : ?x === ?y |- _ ] => setoid_subst H ; setoid_subst_nofail | _ => idtac end. (** [subst*] will try its best at substituting every equality in the goal. *) Tactic Notation "subst" "*" := subst_no_fail ; setoid_subst_nofail. (** Simplify the goal w.r.t. equivalence. *) Ltac equiv_simplify_one := match goal with | [ H : ?x === ?x |- _ ] => clear H | [ H : ?x === ?y |- _ ] => setoid_subst H | [ |- ?x =/= ?y ] => let name:=fresh "Hneq" in intro name | [ |- ~ ?x === ?y ] => let name:=fresh "Hneq" in intro name end. Ltac equiv_simplify := repeat equiv_simplify_one. (** "reify" relations which are equivalences to applications of the overloaded [equiv] method for easy recognition in tactics. *) Ltac equivify_tac := match goal with | [ s : Equivalence ?A ?R, H : ?R ?x ?y |- _ ] => change R with (@equiv A R s) in H | [ s : Equivalence ?A ?R |- context C [ ?R ?x ?y ] ] => change (R x y) with (@equiv A R s x y) end. Ltac equivify := repeat equivify_tac. Section Respecting. (** Here we build an equivalence instance for functions which relates respectful ones only, we do not export it. *) Definition respecting `(eqa : Equivalence A (R : relation A), eqb : Equivalence B (R' : relation B)) : Type := { morph : A -> B | respectful R R' morph morph }. Program Instance respecting_equiv `(eqa : Equivalence A R, eqb : Equivalence B R') : Equivalence (fun (f g : respecting eqa eqb) => forall (x y : A), R x y -> R' (proj1_sig f x) (proj1_sig g y)). Solve Obligations using unfold respecting in * ; simpl_relation ; program_simpl. Next Obligation. Proof. unfold respecting in *. program_simpl. transitivity (y y0); auto. apply H0. reflexivity. Qed. End Respecting. (** The default equivalence on function spaces, with higher-priority than [eq]. *) Program Instance pointwise_equivalence {A} `(eqb : Equivalence B eqB) : Equivalence (pointwise_relation A eqB) | 9. Next Obligation. Proof. transitivity (y a) ; auto. Qed. coq-8.4pl4/theories/Classes/Init.v0000644000175000017500000000265112326224777016150 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unify x y with typeclass_instances ; fail 1 "Convertible" | |- _ => exact tt end. Hint Extern 0 (@Unconvertible _ _ _) => unconvertible : typeclass_instances. coq-8.4pl4/theories/Classes/EquivDec.v0000644000175000017500000001071512326224777016752 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ) (y :>)) (no associativity, at level 70) : equiv_scope. Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } := match x with | left H => @right _ _ H | right H => @left _ _ H end. Local Open Scope program_scope. (** Invert the branches. *) Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x === y } := swap_sumbool (x == y). (** Overloaded notation for inequality. *) Infix "<>" := nequiv_dec (no associativity, at level 70) : equiv_scope. (** Define boolean versions, losing the logical information. *) Definition equiv_decb `{EqDec A} (x y : A) : bool := if x == y then true else false. Definition nequiv_decb `{EqDec A} (x y : A) : bool := negb (equiv_decb x y). Infix "==b" := equiv_decb (no associativity, at level 70). Infix "<>b" := nequiv_decb (no associativity, at level 70). (** Decidable leibniz equality instances. *) (** The equiv is burried inside the setoid, but we can recover it by specifying which setoid we're talking about. *) Program Instance nat_eq_eqdec : EqDec nat eq := eq_nat_dec. Program Instance bool_eqdec : EqDec bool eq := bool_dec. Program Instance unit_eqdec : EqDec unit eq := fun x y => in_left. Next Obligation. Proof. destruct x ; destruct y. reflexivity. Qed. Obligation Tactic := unfold complement, equiv ; program_simpl. Program Instance prod_eqdec `(EqDec A eq, EqDec B eq) : ! EqDec (prod A B) eq := { equiv_dec x y := let '(x1, x2) := x in let '(y1, y2) := y in if x1 == y1 then if x2 == y2 then in_left else in_right else in_right }. Program Instance sum_eqdec `(EqDec A eq, EqDec B eq) : EqDec (sum A B) eq := { equiv_dec x y := match x, y with | inl a, inl b => if a == b then in_left else in_right | inr a, inr b => if a == b then in_left else in_right | inl _, inr _ | inr _, inl _ => in_right end }. (** Objects of function spaces with countable domains like bool have decidable equality. Proving the reflection requires functional extensionality though. *) Program Instance bool_function_eqdec `(EqDec A eq) : ! EqDec (bool -> A) eq := { equiv_dec f g := if f true == g true then if f false == g false then in_left else in_right else in_right }. Next Obligation. Proof. extensionality x. destruct x ; auto. Qed. Require Import List. Program Instance list_eqdec `(eqa : EqDec A eq) : ! EqDec (list A) eq := { equiv_dec := fix aux (x y : list A) := match x, y with | nil, nil => in_left | cons hd tl, cons hd' tl' => if hd == hd' then if aux tl tl' then in_left else in_right else in_right | _, _ => in_right end }. Solve Obligations using unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto). Next Obligation. destruct y ; intuition eauto. Defined. Solve Obligations using unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto). coq-8.4pl4/theories/Classes/RelationPairs.v0000644000175000017500000001153712326224777020024 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* B) : relation A := fun a a' => R (f a) (f a'). Infix "@@" := RelCompFun (at level 30, right associativity) : signature_scope. Notation "R @@1" := (R @@ Fst)%signature (at level 30) : signature_scope. Notation "R @@2" := (R @@ Snd)%signature (at level 30) : signature_scope. (** We declare measures to the system using the [Measure] class. Otherwise the instances would easily introduce loops, never instantiating the [f] function. *) Class Measure {A B} (f : A -> B). (** Standard measures. *) Instance fst_measure : @Measure (A * B) A Fst. Instance snd_measure : @Measure (A * B) B Snd. (** We define a product relation over [A*B]: each components should satisfy the corresponding initial relation. *) Definition RelProd {A B}(RA:relation A)(RB:relation B) : relation (A*B) := relation_conjunction (RA @@1) (RB @@2). Infix "*" := RelProd : signature_scope. Section RelCompFun_Instances. Context {A B : Type} (R : relation B). Global Instance RelCompFun_Reflexive `(Measure A B f, Reflexive _ R) : Reflexive (R@@f). Proof. firstorder. Qed. Global Instance RelCompFun_Symmetric `(Measure A B f, Symmetric _ R) : Symmetric (R@@f). Proof. firstorder. Qed. Global Instance RelCompFun_Transitive `(Measure A B f, Transitive _ R) : Transitive (R@@f). Proof. firstorder. Qed. Global Instance RelCompFun_Irreflexive `(Measure A B f, Irreflexive _ R) : Irreflexive (R@@f). Proof. firstorder. Qed. Global Program Instance RelCompFun_Equivalence `(Measure A B f, Equivalence _ R) : Equivalence (R@@f). Global Program Instance RelCompFun_StrictOrder `(Measure A B f, StrictOrder _ R) : StrictOrder (R@@f). End RelCompFun_Instances. Instance RelProd_Reflexive {A B}(RA:relation A)(RB:relation B) `(Reflexive _ RA, Reflexive _ RB) : Reflexive (RA*RB). Proof. firstorder. Qed. Instance RelProd_Symmetric {A B}(RA:relation A)(RB:relation B) `(Symmetric _ RA, Symmetric _ RB) : Symmetric (RA*RB). Proof. firstorder. Qed. Instance RelProd_Transitive {A B}(RA:relation A)(RB:relation B) `(Transitive _ RA, Transitive _ RB) : Transitive (RA*RB). Proof. firstorder. Qed. Program Instance RelProd_Equivalence {A B}(RA:relation A)(RB:relation B) `(Equivalence _ RA, Equivalence _ RB) : Equivalence (RA*RB). Lemma FstRel_ProdRel {A B}(RA:relation A) : relation_equivalence (RA @@1) (RA*(fun _ _ : B => True)). Proof. firstorder. Qed. Lemma SndRel_ProdRel {A B}(RB:relation B) : relation_equivalence (RB @@2) ((fun _ _ : A =>True) * RB). Proof. firstorder. Qed. Instance FstRel_sub {A B} (RA:relation A)(RB:relation B): subrelation (RA*RB) (RA @@1). Proof. firstorder. Qed. Instance SndRel_sub {A B} (RA:relation A)(RB:relation B): subrelation (RA*RB) (RB @@2). Proof. firstorder. Qed. Instance pair_compat { A B } (RA:relation A)(RB:relation B) : Proper (RA==>RB==> RA*RB) (@pair _ _). Proof. firstorder. Qed. Instance fst_compat { A B } (RA:relation A)(RB:relation B) : Proper (RA*RB ==> RA) Fst. Proof. intros (x,y) (x',y') (Hx,Hy); compute in *; auto. Qed. Instance snd_compat { A B } (RA:relation A)(RB:relation B) : Proper (RA*RB ==> RB) Snd. Proof. intros (x,y) (x',y') (Hx,Hy); compute in *; auto. Qed. Instance RelCompFun_compat {A B}(f:A->B)(R : relation B) `(Proper _ (Ri==>Ri==>Ro) R) : Proper (Ri@@f==>Ri@@f==>Ro) (R@@f)%signature. Proof. unfold RelCompFun; firstorder. Qed. Hint Unfold RelProd RelCompFun. Hint Extern 2 (RelProd _ _ _ _) => split. coq-8.4pl4/theories/Classes/SetoidTactics.v0000644000175000017500000001365012326224777020010 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ?R' => red ; intros ; subst ; red_subst_eq_morphism R' | ?R ==> ?R' => red ; intros ; red_subst_eq_morphism R' | _ => idtac end. Ltac destruct_proper := match goal with | [ |- @Proper ?A ?R ?m ] => red end. Ltac reverse_arrows x := match x with | @Logic.eq ?A ==> ?R' => revert_last ; reverse_arrows R' | ?R ==> ?R' => do 3 revert_last ; reverse_arrows R' | _ => idtac end. Ltac default_add_morphism_tactic := unfold flip ; intros ; (try destruct_proper) ; match goal with | [ |- (?x ==> ?y) _ _ ] => red_subst_eq_morphism (x ==> y) ; reverse_arrows (x ==> y) end. Ltac add_morphism_tactic := default_add_morphism_tactic. Obligation Tactic := program_simpl. (* Notation "'Morphism' s t " := (@Proper _ (s%signature) t) (at level 10, s at next level, t at next level). *) coq-8.4pl4/theories/Classes/Morphisms_Relations.v0000644000175000017500000000455412326224777021252 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* relation_equivalence ==> relation_equivalence) relation_conjunction. Proof. firstorder. Qed. Instance relation_disjunction_morphism : Proper (relation_equivalence (A:=A) ==> relation_equivalence ==> relation_equivalence) relation_disjunction. Proof. firstorder. Qed. (* Predicate equivalence is exactly the same as the pointwise lifting of [iff]. *) Require Import List. Lemma predicate_equivalence_pointwise (l : Tlist) : Proper (@predicate_equivalence l ==> pointwise_lifting iff l) id. Proof. do 2 red. unfold predicate_equivalence. auto. Qed. Lemma predicate_implication_pointwise (l : Tlist) : Proper (@predicate_implication l ==> pointwise_lifting impl l) id. Proof. do 2 red. unfold predicate_implication. auto. Qed. (** The instanciation at relation allows to rewrite applications of relations [R x y] to [R' x y] when [R] and [R'] are in [relation_equivalence]. *) Instance relation_equivalence_pointwise : Proper (relation_equivalence ==> pointwise_relation A (pointwise_relation A iff)) id. Proof. intro. apply (predicate_equivalence_pointwise (Tcons A (Tcons A Tnil))). Qed. Instance subrelation_pointwise : Proper (subrelation ==> pointwise_relation A (pointwise_relation A impl)) id. Proof. intro. apply (predicate_implication_pointwise (Tcons A (Tcons A Tnil))). Qed. Lemma inverse_pointwise_relation A (R : relation A) : relation_equivalence (pointwise_relation A (inverse R)) (inverse (pointwise_relation A R)). Proof. intros. split; firstorder. Qed. coq-8.4pl4/theories/QArith/0000755000175000017500000000000012365131022014624 5ustar stephstephcoq-8.4pl4/theories/QArith/Qpower.v0000644000175000017500000001377712326224777016330 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0)%Z -> 0^n == 0. Proof. intros [|n|n] Hn; try (elim Hn; reflexivity); simpl; rewrite Qpower_positive_0; reflexivity. Qed. Lemma Qpower_not_0_positive : forall a n, ~a==0 -> ~Qpower_positive a n == 0. Proof. intros a n X H. apply X; clear X. induction n; simpl in *; try assumption; destruct (Qmult_integral _ _ H); try destruct (Qmult_integral _ _ H0); auto. Qed. Lemma Qpower_pos_positive : forall p n, 0 <= p -> 0 <= Qpower_positive p n. intros p n Hp. induction n; simpl; repeat apply Qmult_le_0_compat;assumption. Qed. Lemma Qpower_pos : forall p n, 0 <= p -> 0 <= p^n. Proof. intros p [|n|n] Hp; simpl; try discriminate; try apply Qinv_le_0_compat; apply Qpower_pos_positive; assumption. Qed. Lemma Qmult_power_positive : forall a b n, Qpower_positive (a*b) n == (Qpower_positive a n)*(Qpower_positive b n). Proof. induction n; simpl; repeat rewrite IHn; ring. Qed. Lemma Qmult_power : forall a b n, (a*b)^n == a^n*b^n. Proof. intros a b [|n|n]; simpl; try rewrite Qmult_power_positive; try rewrite Qinv_mult_distr; reflexivity. Qed. Lemma Qinv_power_positive : forall a n, Qpower_positive (/a) n == /(Qpower_positive a n). Proof. induction n; simpl; repeat (rewrite IHn || rewrite Qinv_mult_distr); reflexivity. Qed. Lemma Qinv_power : forall a n, (/a)^n == /a^n. Proof. intros a [|n|n]; simpl; try rewrite Qinv_power_positive; reflexivity. Qed. Lemma Qdiv_power : forall a b n, (a/b)^n == (a^n/b^n). Proof. unfold Qdiv. intros a b n. rewrite Qmult_power. rewrite Qinv_power. reflexivity. Qed. Lemma Qinv_power_n : forall n p, (1#p)^n == /(inject_Z ('p))^n. Proof. intros n p. rewrite Qmake_Qdiv. rewrite Qdiv_power. rewrite Qpower_1. unfold Qdiv. ring. Qed. Lemma Qpower_plus_positive : forall a n m, Qpower_positive a (n+m) == (Qpower_positive a n)*(Qpower_positive a m). Proof. intros a n m. unfold Qpower_positive. apply pow_pos_add. apply Q_Setoid. apply Qmult_comp. apply Qmult_assoc. Qed. Lemma Qpower_opp : forall a n, a^(-n) == /a^n. Proof. intros a [|n|n]; simpl; try reflexivity. symmetry; apply Qinv_involutive. Qed. Lemma Qpower_minus_positive : forall a (n m:positive), (m < n)%positive -> Qpower_positive a (n-m)%positive == (Qpower_positive a n)/(Qpower_positive a m). Proof. intros a n m H. destruct (Qeq_dec a 0) as [EQ|NEQ]. - now rewrite EQ, !Qpower_positive_0. - rewrite <- (Qdiv_mult_l (Qpower_positive a (n - m)) (Qpower_positive a m)) by (now apply Qpower_not_0_positive). f_equiv. rewrite <- Qpower_plus_positive. now rewrite Pos.sub_add. Qed. Lemma Qpower_plus : forall a n m, ~a==0 -> a^(n+m) == a^n*a^m. Proof. intros a [|n|n] [|m|m] H; simpl; try ring; try rewrite Qpower_plus_positive; try apply Qinv_mult_distr; try reflexivity; rewrite ?Z.pos_sub_spec; case Pos.compare_spec; intros H0; simpl; subst; try rewrite Qpower_minus_positive; try (field; try split; apply Qpower_not_0_positive); assumption. Qed. Lemma Qpower_plus' : forall a n m, (n+m <> 0)%Z -> a^(n+m) == a^n*a^m. Proof. intros a n m H. destruct (Qeq_dec a 0)as [X|X]. rewrite X. rewrite Qpower_0 by assumption. destruct n; destruct m; try (elim H; reflexivity); simpl; repeat rewrite Qpower_positive_0; ring_simplify; reflexivity. apply Qpower_plus. assumption. Qed. Lemma Qpower_mult_positive : forall a n m, Qpower_positive a (n*m) == Qpower_positive (Qpower_positive a n) m. Proof. intros a n m. induction n using Pos.peano_ind. reflexivity. rewrite Pos.mul_succ_l. rewrite <- Pos.add_1_l. do 2 rewrite Qpower_plus_positive. rewrite IHn. rewrite Qmult_power_positive. reflexivity. Qed. Lemma Qpower_mult : forall a n m, a^(n*m) == (a^n)^m. Proof. intros a [|n|n] [|m|m]; simpl; try rewrite Qpower_positive_1; try rewrite Qpower_mult_positive; try rewrite Qinv_power_positive; try rewrite Qinv_involutive; try reflexivity. Qed. Lemma Zpower_Qpower : forall (a n:Z), (0<=n)%Z -> inject_Z (a^n) == (inject_Z a)^n. Proof. intros a [|n|n] H;[reflexivity| |elim H; reflexivity]. induction n using Pos.peano_ind. replace (a^1)%Z with a by ring. ring. rewrite Pos2Z.inj_succ. unfold Z.succ. rewrite Zpower_exp; auto with *; try discriminate. rewrite Qpower_plus' by discriminate. rewrite <- IHn by discriminate. replace (a^'n*a^1)%Z with (a^'n*a)%Z by ring. ring_simplify. reflexivity. Qed. Lemma Qsqr_nonneg : forall a, 0 <= a^2. Proof. intros a. destruct (Qlt_le_dec 0 a) as [A|A]. apply (Qmult_le_0_compat a a); (apply Qlt_le_weak; assumption). setoid_replace (a^2) with ((-a)*(-a)) by ring. rewrite Qle_minus_iff in A. setoid_replace (0+ - a) with (-a) in A by ring. apply Qmult_le_0_compat; assumption. Qed. Theorem Qpower_decomp p x y : Qpower_positive (x#y) p = x ^ Zpos p # (y ^ p). Proof. induction p; intros; simpl Qpower_positive; rewrite ?IHp. - (* xI *) unfold Qmult, Qnum, Qden. f_equal. + now rewrite <- Z.pow_twice_r, <- Z.pow_succ_r. + apply Pos2Z.inj; rewrite !Pos2Z.inj_mul, !Pos2Z.inj_pow. now rewrite <- Z.pow_twice_r, <- Z.pow_succ_r. - (* xO *) unfold Qmult, Qnum, Qden. f_equal. + now rewrite <- Z.pow_twice_r. + apply Pos2Z.inj; rewrite !Pos2Z.inj_mul, !Pos2Z.inj_pow. now rewrite <- Z.pow_twice_r. - (* xO *) now rewrite Z.pow_1_r, Pos.pow_1_r. Qed. coq-8.4pl4/theories/QArith/vo.itarget0000644000175000017500000000020412326224777016646 0ustar stephstephQabs.vo QArith_base.vo QArith.vo Qcanon.vo Qfield.vo Qpower.vo Qreals.vo Qreduction.vo Qring.vo Qround.vo QOrderedType.vo Qminmax.vocoq-8.4pl4/theories/QArith/QArith.v0000644000175000017500000000113312326224777016222 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* g) by (intro; subst; discriminate). rewrite Z2Pos.id. ring. rewrite <- (Z.mul_pos_cancel_l g); [now rewrite <- Hd | omega]. Close Scope Z_scope. Qed. Lemma Qred_complete : forall p q, p==q -> Qred p = Qred q. Proof. intros (a,b) (c,d). unfold Qred, Qeq in *; simpl in *. Open Scope Z_scope. intros H. generalize (Z.ggcd_gcd a ('b)) (Zgcd_is_gcd a ('b)) (Z.gcd_nonneg a ('b)) (Z.ggcd_correct_divisors a ('b)). destruct (Z.ggcd a (Zpos b)) as (g,(aa,bb)). simpl. intros <- Hg1 Hg2 (Hg3,Hg4). assert (Hg0 : g <> 0) by (intro; now subst g). generalize (Z.ggcd_gcd c ('d)) (Zgcd_is_gcd c ('d)) (Z.gcd_nonneg c ('d)) (Z.ggcd_correct_divisors c ('d)). destruct (Z.ggcd c (Zpos d)) as (g',(cc,dd)). simpl. intros <- Hg'1 Hg'2 (Hg'3,Hg'4). assert (Hg'0 : g' <> 0) by (intro; now subst g'). elim (rel_prime_cross_prod aa bb cc dd). - congruence. - (*rel_prime*) constructor. * exists aa; auto with zarith. * exists bb; auto with zarith. * intros x Ha Hb. destruct Hg1 as (Hg11,Hg12,Hg13). destruct (Hg13 (g*x)) as (x',Hx). { rewrite Hg3. destruct Ha as (xa,Hxa); exists xa; rewrite Hxa; ring. } { rewrite Hg4. destruct Hb as (xb,Hxb); exists xb; rewrite Hxb; ring. } exists x'. apply Z.mul_reg_l with g; auto. rewrite Hx at 1; ring. - (* rel_prime *) constructor. * exists cc; auto with zarith. * exists dd; auto with zarith. * intros x Hc Hd. inversion Hg'1 as (Hg'11,Hg'12,Hg'13). destruct (Hg'13 (g'*x)) as (x',Hx). { rewrite Hg'3. destruct Hc as (xc,Hxc); exists xc; rewrite Hxc; ring. } { rewrite Hg'4. destruct Hd as (xd,Hxd); exists xd; rewrite Hxd; ring. } exists x'. apply Z.mul_reg_l with g'; auto. rewrite Hx at 1; ring. - apply Z.lt_gt. rewrite <- (Z.mul_pos_cancel_l g); [now rewrite <- Hg4 | omega]. - apply Z.lt_gt. rewrite <- (Z.mul_pos_cancel_l g'); [now rewrite <- Hg'4 | omega]. - apply Z.mul_reg_l with (g*g'). * rewrite Z.mul_eq_0. now destruct 1. * rewrite Z.mul_shuffle1, <- Hg3, <- Hg'4. now rewrite Z.mul_shuffle1, <- Hg'3, <- Hg4, H, Z.mul_comm. Close Scope Z_scope. Qed. Add Morphism Qred : Qred_comp. Proof. intros q q' H. rewrite (Qred_correct q); auto. rewrite (Qred_correct q'); auto. Qed. Definition Qplus' (p q : Q) := Qred (Qplus p q). Definition Qmult' (p q : Q) := Qred (Qmult p q). Definition Qminus' x y := Qred (Qminus x y). Lemma Qplus'_correct : forall p q : Q, (Qplus' p q)==(Qplus p q). Proof. intros; unfold Qplus'; apply Qred_correct; auto. Qed. Lemma Qmult'_correct : forall p q : Q, (Qmult' p q)==(Qmult p q). Proof. intros; unfold Qmult'; apply Qred_correct; auto. Qed. Lemma Qminus'_correct : forall p q : Q, (Qminus' p q)==(Qminus p q). Proof. intros; unfold Qminus'; apply Qred_correct; auto. Qed. Add Morphism Qplus' : Qplus'_comp. Proof. intros; unfold Qplus'. rewrite H, H0; auto with qarith. Qed. Add Morphism Qmult' : Qmult'_comp. intros; unfold Qmult'. rewrite H, H0; auto with qarith. Qed. Add Morphism Qminus' : Qminus'_comp. intros; unfold Qminus'. rewrite H, H0; auto with qarith. Qed. Lemma Qred_opp: forall q, Qred (-q) = - (Qred q). Proof. intros (x, y); unfold Qred; simpl. rewrite Z.ggcd_opp; case Z.ggcd; intros p1 (p2, p3); simpl. unfold Qopp; auto. Qed. Theorem Qred_compare: forall x y, Qcompare x y = Qcompare (Qred x) (Qred y). Proof. intros x y; apply Qcompare_comp; apply Qeq_sym; apply Qred_correct. Qed. coq-8.4pl4/theories/QArith/Qcanon.v0000644000175000017500000003065512326224777016264 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Q ; canon : Qred this = this }. Delimit Scope Qc_scope with Qc. Bind Scope Qc_scope with Qc. Arguments Qcmake this%Q _. Open Scope Qc_scope. Lemma Qred_identity : forall q:Q, Z.gcd (Qnum q) (QDen q) = 1%Z -> Qred q = q. Proof. unfold Qred; intros (a,b); simpl. generalize (Z.ggcd_gcd a ('b)) (Z.ggcd_correct_divisors a ('b)). intros. rewrite H1 in H; clear H1. destruct (Z.ggcd a ('b)) as (g,(aa,bb)); simpl in *; subst. destruct H0. rewrite Z.mul_1_l in H, H0. subst; simpl; auto. Qed. Lemma Qred_identity2 : forall q:Q, Qred q = q -> Z.gcd (Qnum q) (QDen q) = 1%Z. Proof. unfold Qred; intros (a,b); simpl. generalize (Z.ggcd_gcd a ('b)) (Z.ggcd_correct_divisors a ('b)) (Z.gcd_nonneg a ('b)). intros. rewrite <- H; rewrite <- H in H1; clear H. destruct (Z.ggcd a ('b)) as (g,(aa,bb)); simpl in *; subst. injection H2; intros; clear H2. destruct H0. clear H0 H3. destruct g as [|g|g]; destruct bb as [|bb|bb]; simpl in *; try discriminate. f_equal. apply Pos.mul_reg_r with bb. injection H2; intros. rewrite <- H0. rewrite H; simpl; auto. elim H1; auto. Qed. Lemma Qred_iff : forall q:Q, Qred q = q <-> Z.gcd (Qnum q) (QDen q) = 1%Z. Proof. split; intros. apply Qred_identity2; auto. apply Qred_identity; auto. Qed. Lemma Qred_involutive : forall q:Q, Qred (Qred q) = Qred q. Proof. intros; apply Qred_complete. apply Qred_correct. Qed. Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q). Arguments Q2Qc q%Q. Notation " !! " := Q2Qc : Qc_scope. Lemma Qc_is_canon : forall q q' : Qc, q == q' -> q = q'. Proof. intros (q,proof_q) (q',proof_q'). simpl. intros H. assert (H0:=Qred_complete _ _ H). assert (q = q') by congruence. subst q'. assert (proof_q = proof_q'). apply eq_proofs_unicity; auto; intros. repeat decide equality. congruence. Qed. Hint Resolve Qc_is_canon. Notation " 0 " := (!!0) : Qc_scope. Notation " 1 " := (!!1) : Qc_scope. Definition Qcle (x y : Qc) := (x <= y)%Q. Definition Qclt (x y : Qc) := (x < y)%Q. Notation Qcgt := (fun x y : Qc => Qlt y x). Notation Qcge := (fun x y : Qc => Qle y x). Infix "<" := Qclt : Qc_scope. Infix "<=" := Qcle : Qc_scope. Infix ">" := Qcgt : Qc_scope. Infix ">=" := Qcge : Qc_scope. Notation "x <= y <= z" := (x<=y/\y<=z) : Qc_scope. Notation "x < y < z" := (x (p ?= q) = Eq. Proof. unfold Qccompare. intros; rewrite <- Qeq_alt. split; auto. intro H; rewrite H; auto with qarith. Qed. Lemma Qclt_alt : forall p q, (p (p?=q = Lt). Proof. intros; exact (Qlt_alt p q). Qed. Lemma Qcgt_alt : forall p q, (p>q) <-> (p?=q = Gt). Proof. intros; exact (Qgt_alt p q). Qed. Lemma Qle_alt : forall p q, (p<=q) <-> (p?=q <> Gt). Proof. intros; exact (Qle_alt p q). Qed. Lemma Qge_alt : forall p q, (p>=q) <-> (p?=q <> Lt). Proof. intros; exact (Qge_alt p q). Qed. (** equality on [Qc] is decidable: *) Theorem Qc_eq_dec : forall x y:Qc, {x=y} + {x<>y}. Proof. intros. destruct (Qeq_dec x y) as [H|H]; auto. right; contradict H; subst; auto with qarith. Defined. (** The addition, multiplication and opposite are defined in the straightforward way: *) Definition Qcplus (x y : Qc) := !!(x+y). Infix "+" := Qcplus : Qc_scope. Definition Qcmult (x y : Qc) := !!(x*y). Infix "*" := Qcmult : Qc_scope. Definition Qcopp (x : Qc) := !!(-x). Notation "- x" := (Qcopp x) : Qc_scope. Definition Qcminus (x y : Qc) := x+-y. Infix "-" := Qcminus : Qc_scope. Definition Qcinv (x : Qc) := !!(/x). Notation "/ x" := (Qcinv x) : Qc_scope. Definition Qcdiv (x y : Qc) := x*/y. Infix "/" := Qcdiv : Qc_scope. (** [0] and [1] are apart *) Lemma Q_apart_0_1 : 1 <> 0. Proof. unfold Q2Qc. intros H; discriminate H. Qed. Ltac qc := match goal with | q:Qc |- _ => destruct q; qc | _ => apply Qc_is_canon; simpl; repeat rewrite Qred_correct end. Opaque Qred. (** Addition is associative: *) Theorem Qcplus_assoc : forall x y z, x+(y+z)=(x+y)+z. Proof. intros; qc; apply Qplus_assoc. Qed. (** [0] is a neutral element for addition: *) Lemma Qcplus_0_l : forall x, 0+x = x. Proof. intros; qc; apply Qplus_0_l. Qed. Lemma Qcplus_0_r : forall x, x+0 = x. Proof. intros; qc; apply Qplus_0_r. Qed. (** Commutativity of addition: *) Theorem Qcplus_comm : forall x y, x+y = y+x. Proof. intros; qc; apply Qplus_comm. Qed. (** Properties of [Qopp] *) Lemma Qcopp_involutive : forall q, - -q = q. Proof. intros; qc; apply Qopp_involutive. Qed. Theorem Qcplus_opp_r : forall q, q+(-q) = 0. Proof. intros; qc; apply Qplus_opp_r. Qed. (** Multiplication is associative: *) Theorem Qcmult_assoc : forall n m p, n*(m*p)=(n*m)*p. Proof. intros; qc; apply Qmult_assoc. Qed. (** [1] is a neutral element for multiplication: *) Lemma Qcmult_1_l : forall n, 1*n = n. Proof. intros; qc; apply Qmult_1_l. Qed. Theorem Qcmult_1_r : forall n, n*1=n. Proof. intros; qc; apply Qmult_1_r. Qed. (** Commutativity of multiplication *) Theorem Qcmult_comm : forall x y, x*y=y*x. Proof. intros; qc; apply Qmult_comm. Qed. (** Distributivity *) Theorem Qcmult_plus_distr_r : forall x y z, x*(y+z)=(x*y)+(x*z). Proof. intros; qc; apply Qmult_plus_distr_r. Qed. Theorem Qcmult_plus_distr_l : forall x y z, (x+y)*z=(x*z)+(y*z). Proof. intros; qc; apply Qmult_plus_distr_l. Qed. (** Integrality *) Theorem Qcmult_integral : forall x y, x*y=0 -> x=0 \/ y=0. Proof. intros. destruct (Qmult_integral x y); try qc; auto. injection H; clear H; intros. rewrite <- (Qred_correct (x*y)). rewrite <- (Qred_correct 0). rewrite H; auto with qarith. Qed. Theorem Qcmult_integral_l : forall x y, ~ x = 0 -> x*y = 0 -> y = 0. Proof. intros; destruct (Qcmult_integral _ _ H0); tauto. Qed. (** Inverse and division. *) Theorem Qcmult_inv_r : forall x, x<>0 -> x*(/x) = 1. Proof. intros; qc; apply Qmult_inv_r; auto. Qed. Theorem Qcmult_inv_l : forall x, x<>0 -> (/x)*x = 1. Proof. intros. rewrite Qcmult_comm. apply Qcmult_inv_r; auto. Qed. Lemma Qcinv_mult_distr : forall p q, / (p * q) = /p * /q. Proof. intros; qc; apply Qinv_mult_distr. Qed. Theorem Qcdiv_mult_l : forall x y, y<>0 -> (x*y)/y = x. Proof. unfold Qcdiv. intros. rewrite <- Qcmult_assoc. rewrite Qcmult_inv_r; auto. apply Qcmult_1_r. Qed. Theorem Qcmult_div_r : forall x y, ~ y = 0 -> y*(x/y) = x. Proof. unfold Qcdiv. intros. rewrite Qcmult_assoc. rewrite Qcmult_comm. rewrite Qcmult_assoc. rewrite Qcmult_inv_l; auto. apply Qcmult_1_l. Qed. (** Properties of order upon Q. *) Lemma Qcle_refl : forall x, x<=x. Proof. unfold Qcle; intros; simpl; apply Qle_refl. Qed. Lemma Qcle_antisym : forall x y, x<=y -> y<=x -> x=y. Proof. unfold Qcle; intros; simpl in *. apply Qc_is_canon; apply Qle_antisym; auto. Qed. Lemma Qcle_trans : forall x y z, x<=y -> y<=z -> x<=z. Proof. unfold Qcle; intros; eapply Qle_trans; eauto. Qed. Lemma Qclt_not_eq : forall x y, x x<>y. Proof. unfold Qclt; intros; simpl in *. intro; destruct (Qlt_not_eq _ _ H). subst; auto with qarith. Qed. (** Large = strict or equal *) Lemma Qclt_le_weak : forall x y, x x<=y. Proof. unfold Qcle, Qclt; intros; apply Qlt_le_weak; auto. Qed. Lemma Qcle_lt_trans : forall x y z, x<=y -> y x y<=z -> x y x y<=x. Proof. unfold Qcle, Qclt; intros; apply Qnot_lt_le; auto. Qed. Lemma Qcnot_le_lt : forall x y, ~ x<=y -> y ~ y<=x. Proof. unfold Qcle, Qclt; intros; apply Qlt_not_le; auto. Qed. Lemma Qcle_not_lt : forall x y, x<=y -> ~ y x -q <= -p. Proof. unfold Qcle, Qcopp; intros; simpl in *. repeat rewrite Qred_correct. apply Qopp_le_compat; auto. Qed. Lemma Qcle_minus_iff : forall p q, p <= q <-> 0 <= q+-p. Proof. unfold Qcle, Qcminus; intros; simpl in *. repeat rewrite Qred_correct. apply Qle_minus_iff; auto. Qed. Lemma Qclt_minus_iff : forall p q, p < q <-> 0 < q+-p. Proof. unfold Qclt, Qcplus, Qcopp; intros; simpl in *. repeat rewrite Qred_correct. apply Qlt_minus_iff; auto. Qed. Lemma Qcplus_le_compat : forall x y z t, x<=y -> z<=t -> x+z <= y+t. Proof. unfold Qcplus, Qcle; intros; simpl in *. repeat rewrite Qred_correct. apply Qplus_le_compat; auto. Qed. Lemma Qcmult_le_compat_r : forall x y z, x <= y -> 0 <= z -> x*z <= y*z. Proof. unfold Qcmult, Qcle; intros; simpl in *. repeat rewrite Qred_correct. apply Qmult_le_compat_r; auto. Qed. Lemma Qcmult_lt_0_le_reg_r : forall x y z, 0 < z -> x*z <= y*z -> x <= y. Proof. unfold Qcmult, Qcle, Qclt; intros; simpl in *. repeat progress rewrite Qred_correct in * |-. eapply Qmult_lt_0_le_reg_r; eauto. Qed. Lemma Qcmult_lt_compat_r : forall x y z, 0 < z -> x < y -> x*z < y*z. Proof. unfold Qcmult, Qclt; intros; simpl in *. repeat progress rewrite Qred_correct in *. eapply Qmult_lt_compat_r; eauto. Qed. (** Rational to the n-th power *) Fixpoint Qcpower (q:Qc)(n:nat) : Qc := match n with | O => 1 | S n => q * (Qcpower q n) end. Notation " q ^ n " := (Qcpower q n) : Qc_scope. Lemma Qcpower_1 : forall n, 1^n = 1. Proof. induction n; simpl; auto with qarith. rewrite IHn; auto with qarith. Qed. Lemma Qcpower_0 : forall n, n<>O -> 0^n = 0. Proof. destruct n; simpl. destruct 1; auto. intros. now apply Qc_is_canon. Qed. Lemma Qcpower_pos : forall p n, 0 <= p -> 0 <= p^n. Proof. induction n; simpl; auto with qarith. easy. intros. apply Qcle_trans with (0*(p^n)). easy. apply Qcmult_le_compat_r; auto. Qed. (** And now everything is easier concerning tactics: *) (** A ring tactic for rational numbers *) Definition Qc_eq_bool (x y : Qc) := if Qc_eq_dec x y then true else false. Lemma Qc_eq_bool_correct : forall x y : Qc, Qc_eq_bool x y = true -> x=y. Proof. intros x y; unfold Qc_eq_bool; case (Qc_eq_dec x y); simpl; auto. intros _ H; inversion H. Qed. Definition Qcrt : ring_theory 0 1 Qcplus Qcmult Qcminus Qcopp (eq(A:=Qc)). Proof. constructor. exact Qcplus_0_l. exact Qcplus_comm. exact Qcplus_assoc. exact Qcmult_1_l. exact Qcmult_comm. exact Qcmult_assoc. exact Qcmult_plus_distr_l. reflexivity. exact Qcplus_opp_r. Qed. Definition Qcft : field_theory 0%Qc 1%Qc Qcplus Qcmult Qcminus Qcopp Qcdiv Qcinv (eq(A:=Qc)). Proof. constructor. exact Qcrt. exact Q_apart_0_1. reflexivity. exact Qcmult_inv_l. Qed. Add Field Qcfield : Qcft. (** A field tactic for rational numbers *) Example test_field : (forall x y : Qc, y<>0 -> (x/y)*y = x)%Qc. intros. field. auto. Qed. Theorem Qc_decomp: forall x y: Qc, (Qred x = x -> Qred y = y -> (x:Q) = y)-> x = y. Proof. intros (q, Hq) (q', Hq'); simpl; intros H. assert (H1 := H Hq Hq'). subst q'. assert (Hq = Hq'). apply Eqdep_dec.eq_proofs_unicity; auto; intros. repeat decide equality. congruence. Qed. coq-8.4pl4/theories/QArith/QArith_base.v0000644000175000017500000005615212326224777017227 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* y" := (Qlt y x)(only parsing) : Q_scope. Notation "x >= y" := (Qle y x)(only parsing) : Q_scope. Notation "x <= y <= z" := (x<=y/\y<=z) : Q_scope. (** injection from Z is injective. *) Lemma inject_Z_injective (a b: Z): inject_Z a == inject_Z b <-> a = b. Proof. unfold Qeq. simpl. omega. Qed. (** Another approach : using Qcompare for defining order relations. *) Definition Qcompare (p q : Q) := (Qnum p * QDen q ?= Qnum q * QDen p)%Z. Notation "p ?= q" := (Qcompare p q) : Q_scope. Lemma Qeq_alt p q : (p == q) <-> (p ?= q) = Eq. Proof. symmetry. apply Z.compare_eq_iff. Qed. Lemma Qlt_alt p q : (p (p?=q = Lt). Proof. reflexivity. Qed. Lemma Qgt_alt p q : (p>q) <-> (p?=q = Gt). Proof. symmetry. apply Z.gt_lt_iff. Qed. Lemma Qle_alt p q : (p<=q) <-> (p?=q <> Gt). Proof. reflexivity. Qed. Lemma Qge_alt p q : (p>=q) <-> (p?=q <> Lt). Proof. symmetry. apply Z.ge_le_iff. Qed. Hint Unfold Qeq Qlt Qle : qarith. Hint Extern 5 (?X1 <> ?X2) => intro; discriminate: qarith. Lemma Qcompare_antisym x y : CompOpp (x ?= y) = (y ?= x). Proof. symmetry. apply Z.compare_antisym. Qed. Lemma Qcompare_spec x y : CompareSpec (x==y) (x y == x. Proof. auto with qarith. Qed. Theorem Qeq_trans x y z : x == y -> y == z -> x == z. Proof. unfold Qeq; intros XY YZ. apply Z.mul_reg_r with (QDen y); [auto with qarith|]. now rewrite Z.mul_shuffle0, XY, Z.mul_shuffle0, YZ, Z.mul_shuffle0. Qed. Hint Immediate Qeq_sym : qarith. Hint Resolve Qeq_refl Qeq_trans : qarith. (** In a word, [Qeq] is a setoid equality. *) Instance Q_Setoid : Equivalence Qeq. Proof. split; red; eauto with qarith. Qed. (** Furthermore, this equality is decidable: *) Theorem Qeq_dec x y : {x==y} + {~ x==y}. Proof. apply Z.eq_dec. Defined. Definition Qeq_bool x y := (Zeq_bool (Qnum x * QDen y) (Qnum y * QDen x))%Z. Definition Qle_bool x y := (Z.leb (Qnum x * QDen y) (Qnum y * QDen x))%Z. Lemma Qeq_bool_iff x y : Qeq_bool x y = true <-> x == y. Proof. symmetry; apply Zeq_is_eq_bool. Qed. Lemma Qeq_bool_eq x y : Qeq_bool x y = true -> x == y. Proof. apply Qeq_bool_iff. Qed. Lemma Qeq_eq_bool x y : x == y -> Qeq_bool x y = true. Proof. apply Qeq_bool_iff. Qed. Lemma Qeq_bool_neq x y : Qeq_bool x y = false -> ~ x == y. Proof. rewrite <- Qeq_bool_iff. now intros ->. Qed. Lemma Qle_bool_iff x y : Qle_bool x y = true <-> x <= y. Proof. symmetry; apply Zle_is_le_bool. Qed. Lemma Qle_bool_imp_le x y : Qle_bool x y = true -> x <= y. Proof. apply Qle_bool_iff. Qed. Theorem Qnot_eq_sym x y : ~x == y -> ~y == x. Proof. auto with qarith. Qed. Hint Resolve Qnot_eq_sym : qarith. (** * Addition, multiplication and opposite *) (** The addition, multiplication and opposite are defined in the straightforward way: *) Definition Qplus (x y : Q) := (Qnum x * QDen y + Qnum y * QDen x) # (Qden x * Qden y). Definition Qmult (x y : Q) := (Qnum x * Qnum y) # (Qden x * Qden y). Definition Qopp (x : Q) := (- Qnum x) # (Qden x). Definition Qminus (x y : Q) := Qplus x (Qopp y). Definition Qinv (x : Q) := match Qnum x with | Z0 => 0 | Zpos p => (QDen x)#p | Zneg p => (Zneg (Qden x))#p end. Definition Qdiv (x y : Q) := Qmult x (Qinv y). Infix "+" := Qplus : Q_scope. Notation "- x" := (Qopp x) : Q_scope. Infix "-" := Qminus : Q_scope. Infix "*" := Qmult : Q_scope. Notation "/ x" := (Qinv x) : Q_scope. Infix "/" := Qdiv : Q_scope. (** A light notation for [Zpos] *) Notation " ' x " := (Zpos x) (at level 20, no associativity) : Z_scope. Lemma Qmake_Qdiv a b : a#b==inject_Z a/inject_Z ('b). Proof. unfold Qeq. simpl. ring. Qed. (** * Setoid compatibility results *) Instance Qplus_comp : Proper (Qeq==>Qeq==>Qeq) Qplus. Proof. unfold Qeq, Qplus; simpl. Open Scope Z_scope. intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *. simpl_mult; ring_simplify. replace (p1 * 'r2 * 'q2) with (p1 * 'q2 * 'r2) by ring. rewrite H. replace (r1 * 'p2 * 'q2 * 's2) with (r1 * 's2 * 'p2 * 'q2) by ring. rewrite H0. ring. Close Scope Z_scope. Qed. Instance Qopp_comp : Proper (Qeq==>Qeq) Qopp. Proof. unfold Qeq, Qopp; simpl. Open Scope Z_scope. intros x y H; simpl. replace (- Qnum x * ' Qden y) with (- (Qnum x * ' Qden y)) by ring. rewrite H; ring. Close Scope Z_scope. Qed. Instance Qminus_comp : Proper (Qeq==>Qeq==>Qeq) Qminus. Proof. intros x x' Hx y y' Hy. unfold Qminus. rewrite Hx, Hy; auto with qarith. Qed. Instance Qmult_comp : Proper (Qeq==>Qeq==>Qeq) Qmult. Proof. unfold Qeq; simpl. Open Scope Z_scope. intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *. intros; simpl_mult; ring_simplify. replace (q1 * s1 * 'p2) with (q1 * 'p2 * s1) by ring. rewrite <- H. replace (p1 * r1 * 'q2 * 's2) with (r1 * 's2 * p1 * 'q2) by ring. rewrite H0. ring. Close Scope Z_scope. Qed. Instance Qinv_comp : Proper (Qeq==>Qeq) Qinv. Proof. unfold Qeq, Qinv; simpl. Open Scope Z_scope. intros (p1, p2) (q1, q2) EQ; simpl in *. destruct q1; simpl in *. - apply Z.mul_eq_0 in EQ. destruct EQ; now subst. - destruct p1; simpl in *; try discriminate. now rewrite Pos.mul_comm, <- EQ, Pos.mul_comm. - destruct p1; simpl in *; try discriminate. now rewrite Pos.mul_comm, <- EQ, Pos.mul_comm. Close Scope Z_scope. Qed. Instance Qdiv_comp : Proper (Qeq==>Qeq==>Qeq) Qdiv. Proof. intros x x' Hx y y' Hy; unfold Qdiv. rewrite Hx, Hy; auto with qarith. Qed. Instance Qcompare_comp : Proper (Qeq==>Qeq==>eq) Qcompare. Proof. unfold Qeq, Qcompare. Open Scope Z_scope. intros (p1,p2) (q1,q2) H (r1,r2) (s1,s2) H'; simpl in *. rewrite <- (Zcompare_mult_compat (q2*s2) (p1*'r2)). rewrite <- (Zcompare_mult_compat (p2*r2) (q1*'s2)). change ('(q2*s2)) with ('q2 * 's2). change ('(p2*r2)) with ('p2 * 'r2). replace ('q2 * 's2 * (p1*'r2)) with ((p1*'q2)*'r2*'s2) by ring. rewrite H. replace ('q2 * 's2 * (r1*'p2)) with ((r1*'s2)*'q2*'p2) by ring. rewrite H'. f_equal; ring. Close Scope Z_scope. Qed. Instance Qle_comp : Proper (Qeq==>Qeq==>iff) Qle. Proof. intros p q H r s H'. rewrite 2 Qle_alt, H, H'; auto with *. Qed. Instance Qlt_compat : Proper (Qeq==>Qeq==>iff) Qlt. Proof. intros p q H r s H'. rewrite 2 Qlt_alt, H, H'; auto with *. Qed. Instance Qeqb_comp : Proper (Qeq==>Qeq==>eq) Qeq_bool. Proof. intros p q H r s H'; apply eq_true_iff_eq. rewrite 2 Qeq_bool_iff, H, H'; split; auto with qarith. Qed. Instance Qleb_comp : Proper (Qeq==>Qeq==>eq) Qle_bool. Proof. intros p q H r s H'; apply eq_true_iff_eq. rewrite 2 Qle_bool_iff, H, H'; split; auto with qarith. Qed. (** [0] and [1] are apart *) Lemma Q_apart_0_1 : ~ 1 == 0. Proof. unfold Qeq; auto with qarith. Qed. (** * Properties of [Qadd] *) (** Addition is associative: *) Theorem Qplus_assoc : forall x y z, x+(y+z)==(x+y)+z. Proof. intros (x1, x2) (y1, y2) (z1, z2). unfold Qeq, Qplus; simpl; simpl_mult; ring. Qed. (** [0] is a neutral element for addition: *) Lemma Qplus_0_l : forall x, 0+x == x. Proof. intros (x1, x2); unfold Qeq, Qplus; simpl; ring. Qed. Lemma Qplus_0_r : forall x, x+0 == x. Proof. intros (x1, x2); unfold Qeq, Qplus; simpl. rewrite Pos.mul_comm; simpl; ring. Qed. (** Commutativity of addition: *) Theorem Qplus_comm : forall x y, x+y == y+x. Proof. intros (x1, x2); unfold Qeq, Qplus; simpl. intros; rewrite Pos.mul_comm; ring. Qed. (** * Properties of [Qopp] *) Lemma Qopp_involutive : forall q, - -q == q. Proof. red; simpl; intros; ring. Qed. Theorem Qplus_opp_r : forall q, q+(-q) == 0. Proof. red; simpl; intro; ring. Qed. (** Injectivity of addition (uses theory about Qopp above): *) Lemma Qplus_inj_r (x y z: Q): x + z == y + z <-> x == y. Proof. split; intro E. rewrite <- (Qplus_0_r x), <- (Qplus_0_r y). rewrite <- (Qplus_opp_r z); auto. do 2 rewrite Qplus_assoc. rewrite E. reflexivity. rewrite E. reflexivity. Qed. Lemma Qplus_inj_l (x y z: Q): z + x == z + y <-> x == y. Proof. rewrite (Qplus_comm z x), (Qplus_comm z y). apply Qplus_inj_r. Qed. (** * Properties of [Qmult] *) (** Multiplication is associative: *) Theorem Qmult_assoc : forall n m p, n*(m*p)==(n*m)*p. Proof. intros; red; simpl; rewrite Pos.mul_assoc; ring. Qed. (** multiplication and zero *) Lemma Qmult_0_l : forall x , 0*x == 0. Proof. intros; compute; reflexivity. Qed. Lemma Qmult_0_r : forall x , x*0 == 0. Proof. intros; red; simpl; ring. Qed. (** [1] is a neutral element for multiplication: *) Lemma Qmult_1_l : forall n, 1*n == n. Proof. intro; red; simpl; destruct (Qnum n); auto. Qed. Theorem Qmult_1_r : forall n, n*1==n. Proof. intro; red; simpl. rewrite Z.mul_1_r with (n := Qnum n). rewrite Pos.mul_comm; simpl; trivial. Qed. (** Commutativity of multiplication *) Theorem Qmult_comm : forall x y, x*y==y*x. Proof. intros; red; simpl; rewrite Pos.mul_comm; ring. Qed. (** Distributivity over [Qadd] *) Theorem Qmult_plus_distr_r : forall x y z, x*(y+z)==(x*y)+(x*z). Proof. intros (x1, x2) (y1, y2) (z1, z2). unfold Qeq, Qmult, Qplus; simpl; simpl_mult; ring. Qed. Theorem Qmult_plus_distr_l : forall x y z, (x+y)*z==(x*z)+(y*z). Proof. intros (x1, x2) (y1, y2) (z1, z2). unfold Qeq, Qmult, Qplus; simpl; simpl_mult; ring. Qed. (** Integrality *) Theorem Qmult_integral : forall x y, x*y==0 -> x==0 \/ y==0. Proof. intros (x1,x2) (y1,y2). unfold Qeq, Qmult; simpl. now rewrite <- Z.mul_eq_0, !Z.mul_1_r. Qed. Theorem Qmult_integral_l : forall x y, ~ x == 0 -> x*y == 0 -> y == 0. Proof. intros (x1, x2) (y1, y2). unfold Qeq, Qmult; simpl. rewrite !Z.mul_1_r, Z.mul_eq_0. intuition. Qed. (** * inject_Z is a ring homomorphism: *) Lemma inject_Z_plus (x y: Z): inject_Z (x + y) = inject_Z x + inject_Z y. Proof. unfold Qplus, inject_Z. simpl. f_equal. ring. Qed. Lemma inject_Z_mult (x y: Z): inject_Z (x * y) = inject_Z x * inject_Z y. Proof. reflexivity. Qed. Lemma inject_Z_opp (x: Z): inject_Z (- x) = - inject_Z x. Proof. reflexivity. Qed. (** * Inverse and division. *) Lemma Qinv_involutive : forall q, (/ / q) == q. Proof. intros [[|n|n] d]; red; simpl; reflexivity. Qed. Theorem Qmult_inv_r : forall x, ~ x == 0 -> x*(/x) == 1. Proof. intros (x1, x2); unfold Qeq, Qdiv, Qmult; case x1; simpl; intros; simpl_mult; try ring. elim H; auto. Qed. Lemma Qinv_mult_distr : forall p q, / (p * q) == /p * /q. Proof. intros (x1,x2) (y1,y2); unfold Qeq, Qinv, Qmult; simpl. destruct x1; simpl; auto; destruct y1; simpl; auto. Qed. Theorem Qdiv_mult_l : forall x y, ~ y == 0 -> (x*y)/y == x. Proof. intros; unfold Qdiv. rewrite <- (Qmult_assoc x y (Qinv y)). rewrite (Qmult_inv_r y H). apply Qmult_1_r. Qed. Theorem Qmult_div_r : forall x y, ~ y == 0 -> y*(x/y) == x. Proof. intros; unfold Qdiv. rewrite (Qmult_assoc y x (Qinv y)). rewrite (Qmult_comm y x). fold (Qdiv (Qmult x y) y). apply Qdiv_mult_l; auto. Qed. (** Injectivity of Qmult (requires theory about Qinv above): *) Lemma Qmult_inj_r (x y z: Q): ~ z == 0 -> (x * z == y * z <-> x == y). Proof. intro z_ne_0. split; intro E. rewrite <- (Qmult_1_r x), <- (Qmult_1_r y). rewrite <- (Qmult_inv_r z); auto. do 2 rewrite Qmult_assoc. rewrite E. reflexivity. rewrite E. reflexivity. Qed. Lemma Qmult_inj_l (x y z: Q): ~ z == 0 -> (z * x == z * y <-> x == y). Proof. rewrite (Qmult_comm z x), (Qmult_comm z y). apply Qmult_inj_r. Qed. (** * Properties of order upon Q. *) Lemma Qle_refl x : x<=x. Proof. unfold Qle; auto with zarith. Qed. Lemma Qle_antisym x y : x<=y -> y<=x -> x==y. Proof. unfold Qle, Qeq; auto with zarith. Qed. Lemma Qle_trans : forall x y z, x<=y -> y<=z -> x<=z. Proof. unfold Qle; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros. Open Scope Z_scope. apply Z.mul_le_mono_pos_r with ('y2); [easy|]. apply Z.le_trans with (y1 * 'x2 * 'z2). - rewrite Z.mul_shuffle0. now apply Z.mul_le_mono_pos_r. - rewrite Z.mul_shuffle0, (Z.mul_shuffle0 z1). now apply Z.mul_le_mono_pos_r. Close Scope Z_scope. Qed. Hint Resolve Qle_trans : qarith. Lemma Qlt_irrefl x : ~x ~ x==y. Proof. unfold Qlt, Qeq; auto with zarith. Qed. Lemma Zle_Qle (x y: Z): (x <= y)%Z = (inject_Z x <= inject_Z y). Proof. unfold Qle. simpl. now rewrite !Z.mul_1_r. Qed. Lemma Zlt_Qlt (x y: Z): (x < y)%Z = (inject_Z x < inject_Z y). Proof. unfold Qlt. simpl. now rewrite !Z.mul_1_r. Qed. (** Large = strict or equal *) Lemma Qle_lteq x y : x<=y <-> x x<=y. Proof. unfold Qle, Qlt; auto with zarith. Qed. Lemma Qle_lt_trans : forall x y z, x<=y -> y x y<=z -> x y x y<=x. Proof. unfold Qle, Qlt; auto with zarith. Qed. Lemma Qnot_le_lt : forall x y, ~ x<=y -> y ~ y<=x. Proof. unfold Qle, Qlt; auto with zarith. Qed. Lemma Qle_not_lt : forall x y, x<=y -> ~ y x -q <= -p. Proof. intros (a1,a2) (b1,b2); unfold Qle, Qlt; simpl. rewrite !Z.mul_opp_l. omega. Qed. Hint Resolve Qopp_le_compat : qarith. Lemma Qle_minus_iff : forall p q, p <= q <-> 0 <= q+-p. Proof. intros (x1,x2) (y1,y2); unfold Qle; simpl. rewrite Z.mul_opp_l. omega. Qed. Lemma Qlt_minus_iff : forall p q, p < q <-> 0 < q+-p. Proof. intros (x1,x2) (y1,y2); unfold Qlt; simpl. rewrite Z.mul_opp_l. omega. Qed. Lemma Qplus_le_compat : forall x y z t, x<=y -> z<=t -> x+z <= y+t. Proof. unfold Qplus, Qle; intros (x1, x2) (y1, y2) (z1, z2) (t1, t2); simpl; simpl_mult. Open Scope Z_scope. intros. match goal with |- ?a <= ?b => ring_simplify a b end. rewrite Z.add_comm. apply Z.add_le_mono. match goal with |- ?a <= ?b => ring_simplify z1 t1 ('z2) ('t2) a b end. auto with zarith. match goal with |- ?a <= ?b => ring_simplify x1 y1 ('x2) ('y2) a b end. auto with zarith. Close Scope Z_scope. Qed. Lemma Qplus_lt_le_compat : forall x y z t, x z<=t -> x+z < y+t. Proof. unfold Qplus, Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2) (t1, t2); simpl; simpl_mult. Open Scope Z_scope. intros. match goal with |- ?a < ?b => ring_simplify a b end. rewrite Z.add_comm. apply Z.add_le_lt_mono. match goal with |- ?a <= ?b => ring_simplify z1 t1 ('z2) ('t2) a b end. auto with zarith. match goal with |- ?a < ?b => ring_simplify x1 y1 ('x2) ('y2) a b end. do 2 (apply Z.mul_lt_mono_pos_r;try easy). Close Scope Z_scope. Qed. Lemma Qplus_le_l (x y z: Q): x + z <= y + z <-> x <= y. Proof. split; intros. rewrite <- (Qplus_0_r x), <- (Qplus_0_r y), <- (Qplus_opp_r z). do 2 rewrite Qplus_assoc. apply Qplus_le_compat; auto with *. apply Qplus_le_compat; auto with *. Qed. Lemma Qplus_le_r (x y z: Q): z + x <= z + y <-> x <= y. Proof. rewrite (Qplus_comm z x), (Qplus_comm z y). apply Qplus_le_l. Qed. Lemma Qplus_lt_l (x y z: Q): x + z < y + z <-> x < y. Proof. split; intros. rewrite <- (Qplus_0_r x), <- (Qplus_0_r y), <- (Qplus_opp_r z). do 2 rewrite Qplus_assoc. apply Qplus_lt_le_compat; auto with *. apply Qplus_lt_le_compat; auto with *. Qed. Lemma Qplus_lt_r (x y z: Q): z + x < z + y <-> x < y. Proof. rewrite (Qplus_comm z x), (Qplus_comm z y). apply Qplus_lt_l. Qed. Lemma Qmult_le_compat_r : forall x y z, x <= y -> 0 <= z -> x*z <= y*z. Proof. intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl. Open Scope Z_scope. intros; simpl_mult. rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). apply Z.mul_le_mono_nonneg_r; auto with zarith. Close Scope Z_scope. Qed. Lemma Qmult_lt_0_le_reg_r : forall x y z, 0 < z -> x*z <= y*z -> x <= y. Proof. intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl. Open Scope Z_scope. simpl_mult. rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). intros LT LE. apply Z.mul_le_mono_pos_r in LE; trivial. apply Z.mul_pos_pos; [omega|easy]. Close Scope Z_scope. Qed. Lemma Qmult_le_r (x y z: Q): 0 < z -> (x*z <= y*z <-> x <= y). Proof. split; intro. now apply Qmult_lt_0_le_reg_r with z. apply Qmult_le_compat_r; auto with qarith. Qed. Lemma Qmult_le_l (x y z: Q): 0 < z -> (z*x <= z*y <-> x <= y). Proof. rewrite (Qmult_comm z x), (Qmult_comm z y). apply Qmult_le_r. Qed. Lemma Qmult_lt_compat_r : forall x y z, 0 < z -> x < y -> x*z < y*z. Proof. intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl. Open Scope Z_scope. intros; simpl_mult. rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). apply Z.mul_lt_mono_pos_r; auto with zarith. apply Z.mul_pos_pos; [omega|reflexivity]. Close Scope Z_scope. Qed. Lemma Qmult_lt_r: forall x y z, 0 < z -> (x*z < y*z <-> x < y). Proof. Open Scope Z_scope. intros (a1,a2) (b1,b2) (c1,c2). unfold Qle, Qlt; simpl. simpl_mult. rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). intro LT. rewrite <- Z.mul_lt_mono_pos_r. reflexivity. apply Z.mul_pos_pos; [omega|reflexivity]. Close Scope Z_scope. Qed. Lemma Qmult_lt_l (x y z: Q): 0 < z -> (z*x < z*y <-> x < y). Proof. rewrite (Qmult_comm z x), (Qmult_comm z y). apply Qmult_lt_r. Qed. Lemma Qmult_le_0_compat : forall a b, 0 <= a -> 0 <= b -> 0 <= a*b. Proof. intros a b Ha Hb. unfold Qle in *. simpl in *. auto with *. Qed. Lemma Qinv_le_0_compat : forall a, 0 <= a -> 0 <= /a. Proof. intros [[|n|n] d] Ha; assumption. Qed. Lemma Qle_shift_div_l : forall a b c, 0 < c -> a*c <= b -> a <= b/c. Proof. intros a b c Hc H. apply Qmult_lt_0_le_reg_r with (c). assumption. setoid_replace (b/c*c) with (c*(b/c)) by apply Qmult_comm. rewrite Qmult_div_r; try assumption. auto with *. Qed. Lemma Qle_shift_inv_l : forall a c, 0 < c -> a*c <= 1 -> a <= /c. Proof. intros a c Hc H. setoid_replace (/c) with (1*/c) by (symmetry; apply Qmult_1_l). change (a <= 1/c). apply Qle_shift_div_l; assumption. Qed. Lemma Qle_shift_div_r : forall a b c, 0 < b -> a <= c*b -> a/b <= c. Proof. intros a b c Hc H. apply Qmult_lt_0_le_reg_r with b. assumption. setoid_replace (a/b*b) with (b*(a/b)) by apply Qmult_comm. rewrite Qmult_div_r; try assumption. auto with *. Qed. Lemma Qle_shift_inv_r : forall b c, 0 < b -> 1 <= c*b -> /b <= c. Proof. intros b c Hc H. setoid_replace (/b) with (1*/b) by (symmetry; apply Qmult_1_l). change (1/b <= c). apply Qle_shift_div_r; assumption. Qed. Lemma Qinv_lt_0_compat : forall a, 0 < a -> 0 < /a. Proof. intros [[|n|n] d] Ha; assumption. Qed. Lemma Qlt_shift_div_l : forall a b c, 0 < c -> a*c < b -> a < b/c. Proof. intros a b c Hc H. apply Qnot_le_lt. intros H0. apply (Qlt_not_le _ _ H). apply Qmult_lt_0_le_reg_r with (/c). apply Qinv_lt_0_compat. assumption. setoid_replace (a*c/c) with (a) by (apply Qdiv_mult_l; auto with *). assumption. Qed. Lemma Qlt_shift_inv_l : forall a c, 0 < c -> a*c < 1 -> a < /c. Proof. intros a c Hc H. setoid_replace (/c) with (1*/c) by (symmetry; apply Qmult_1_l). change (a < 1/c). apply Qlt_shift_div_l; assumption. Qed. Lemma Qlt_shift_div_r : forall a b c, 0 < b -> a < c*b -> a/b < c. Proof. intros a b c Hc H. apply Qnot_le_lt. intros H0. apply (Qlt_not_le _ _ H). apply Qmult_lt_0_le_reg_r with (/b). apply Qinv_lt_0_compat. assumption. setoid_replace (c*b/b) with (c) by (apply Qdiv_mult_l; auto with *). assumption. Qed. Lemma Qlt_shift_inv_r : forall b c, 0 < b -> 1 < c*b -> /b < c. Proof. intros b c Hc H. setoid_replace (/b) with (1*/b) by (symmetry; apply Qmult_1_l). change (1/b < c). apply Qlt_shift_div_r; assumption. Qed. (** * Rational to the n-th power *) Definition Qpower_positive (q:Q)(p:positive) : Q := pow_pos Qmult q p. Instance Qpower_positive_comp : Proper (Qeq==>eq==>Qeq) Qpower_positive. Proof. intros x x' Hx y y' Hy. rewrite <-Hy; clear y' Hy. unfold Qpower_positive. induction y; simpl; try rewrite IHy; try rewrite Hx; reflexivity. Qed. Definition Qpower (q:Q) (z:Z) := match z with | Zpos p => Qpower_positive q p | Z0 => 1 | Zneg p => /Qpower_positive q p end. Notation " q ^ z " := (Qpower q z) : Q_scope. Instance Qpower_comp : Proper (Qeq==>eq==>Qeq) Qpower. Proof. intros x x' Hx y y' Hy. rewrite <- Hy; clear y' Hy. destruct y; simpl; rewrite ?Hx; auto with *. Qed. coq-8.4pl4/theories/QArith/QOrderedType.v0000644000175000017500000000340012326224777017400 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Qeq==>iff) Qlt. Proof. auto with *. Qed. Definition le_lteq := Qle_lteq. Definition compare_spec := Qcompare_spec. End Q_as_OT. (** * An [order] tactic for [Q] numbers *) Module QOrder := OTF_to_OrderTac Q_as_OT. Ltac q_order := QOrder.order. (** Note that [q_order] is domain-agnostic: it will not prove [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x==y]. *) coq-8.4pl4/theories/QArith/Qfield.v0000644000175000017500000000507012326224777016242 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* isZcst z | Qmake ?n ?d => match isZcst n with true => isPcst d | _ => false end | _ => false end. Ltac Qcst t := match isQcst t with true => t | _ => NotConstant end. Ltac Qpow_tac t := match t with | Z0 => N0 | Zpos ?n => Ncst (Npos n) | Z.of_N ?n => Ncst n | NtoZ ?n => Ncst n | _ => NotConstant end. Add Field Qfield : Qsft (decidable Qeq_bool_eq, completeness Qeq_eq_bool, constants [Qcst], power_tac Qpower_theory [Qpow_tac]). (** Exemple of use: *) Section Examples. Let ex1 : forall x y z : Q, (x+y)*z == (x*z)+(y*z). intros. ring. Qed. Let ex2 : forall x y : Q, x+y == y+x. intros. ring. Qed. Let ex3 : forall x y z : Q, (x+y)+z == x+(y+z). intros. ring. Qed. Let ex4 : (inject_Z 1)+(inject_Z 1)==(inject_Z 2). ring. Qed. Let ex5 : 1+1 == 2#1. ring. Qed. Let ex6 : (1#1)+(1#1) == 2#1. ring. Qed. Let ex7 : forall x : Q, x-x== 0. intro. ring. Qed. Let ex8 : forall x : Q, x^1 == x. intro. ring. Qed. Let ex9 : forall x : Q, x^0 == 1. intro. ring. Qed. Let ex10 : forall x y : Q, ~(y==0) -> (x/y)*y == x. intros. field. auto. Qed. End Examples. Lemma Qopp_plus : forall a b, -(a+b) == -a + -b. Proof. intros; ring. Qed. Lemma Qopp_opp : forall q, - -q==q. Proof. intros; ring. Qed. coq-8.4pl4/theories/QArith/Qminmax.v0000644000175000017500000000410712326224777016450 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Type), (0 <= x -> P x) -> (x <= 0 -> P (- x)) -> P (Qabs x). Proof. intros x P H1 H2. destruct x as [[|xn|xn] xd]; [apply H1|apply H1|apply H2]; abstract (compute; discriminate). Defined. Add Morphism Qabs with signature Qeq ==> Qeq as Qabs_wd. intros [xn xd] [yn yd] H. simpl. unfold Qeq in *. simpl in *. change (' yd)%Z with (Z.abs (' yd)). change (' xd)%Z with (Z.abs (' xd)). repeat rewrite <- Z.abs_mul. congruence. Qed. Lemma Qabs_pos : forall x, 0 <= x -> Qabs x == x. Proof. intros x H. apply Qabs_case. reflexivity. intros H0. setoid_replace x with 0. reflexivity. apply Qle_antisym; assumption. Qed. Lemma Qabs_neg : forall x, x <= 0 -> Qabs x == - x. Proof. intros x H. apply Qabs_case. intros H0. setoid_replace x with 0. reflexivity. apply Qle_antisym; assumption. reflexivity. Qed. Lemma Qabs_nonneg : forall x, 0 <= (Qabs x). intros x. apply Qabs_case. auto. apply (Qopp_le_compat x 0). Qed. Lemma Zabs_Qabs : forall n d, (Z.abs n#d)==Qabs (n#d). Proof. intros [|n|n]; reflexivity. Qed. Lemma Qabs_opp : forall x, Qabs (-x) == Qabs x. Proof. intros x. do 2 apply Qabs_case; try (intros; ring); (intros H0 H1; setoid_replace x with 0;[reflexivity|]; apply Qle_antisym);try assumption; rewrite Qle_minus_iff in *; ring_simplify; ring_simplify in H1; assumption. Qed. Lemma Qabs_triangle : forall x y, Qabs (x+y) <= Qabs x + Qabs y. Proof. intros [xn xd] [yn yd]. unfold Qplus. unfold Qle. simpl. apply Z.mul_le_mono_nonneg_r;auto with *. change (' yd)%Z with (Z.abs (' yd)). change (' xd)%Z with (Z.abs (' xd)). repeat rewrite <- Z.abs_mul. apply Z.abs_triangle. Qed. Lemma Qabs_Qmult : forall a b, Qabs (a*b) == (Qabs a)*(Qabs b). Proof. intros [an ad] [bn bd]. simpl. rewrite Z.abs_mul. reflexivity. Qed. Lemma Qabs_Qminus x y: Qabs (x - y) = Qabs (y - x). Proof. unfold Qminus, Qopp. simpl. rewrite Pos.mul_comm, <- Z.abs_opp. do 2 f_equal. ring. Qed. Lemma Qle_Qabs : forall a, a <= Qabs a. Proof. intros a. apply Qabs_case; auto with *. intros H. apply Qle_trans with 0; try assumption. change 0 with (-0). apply Qopp_le_compat. assumption. Qed. Lemma Qabs_triangle_reverse : forall x y, Qabs x - Qabs y <= Qabs (x - y). Proof. intros x y. rewrite Qle_minus_iff. setoid_replace (Qabs (x - y) + - (Qabs x - Qabs y)) with ((Qabs (x - y) + Qabs y) + - Qabs x) by ring. rewrite <- Qle_minus_iff. setoid_replace (Qabs x) with (Qabs (x-y+y)). apply Qabs_triangle. apply Qabs_wd. ring. Qed. Lemma Qabs_Qle_condition x y: Qabs x <= y <-> -y <= x <= y. Proof. split. split. rewrite <- (Qopp_opp x). apply Qopp_le_compat. apply Qle_trans with (Qabs (-x)). apply Qle_Qabs. now rewrite Qabs_opp. apply Qle_trans with (Qabs x); auto using Qle_Qabs. intros (H,H'). apply Qabs_case; trivial. intros. rewrite <- (Qopp_opp y). now apply Qopp_le_compat. Qed. Lemma Qabs_diff_Qle_condition x y r: Qabs (x - y) <= r <-> x - r <= y <= x + r. Proof. intros. unfold Qminus. rewrite Qabs_Qle_condition. rewrite <- (Qplus_le_l (-r) (x+-y) (y+r)). rewrite <- (Qplus_le_l (x+-y) r (y-r)). setoid_replace (-r + (y + r)) with y by ring. setoid_replace (r + (y - r)) with y by ring. setoid_replace (x + - y + (y + r)) with (x + r) by ring. setoid_replace (x + - y + (y - r)) with (x - r) by ring. intuition. Qed. coq-8.4pl4/theories/QArith/Qreals.v0000644000175000017500000001521312326224777016265 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0%R. intros; apply not_O_IZR; auto with qarith. Qed. Hint Resolve IZR_nz Rmult_integral_contrapositive. Lemma eqR_Qeq : forall x y : Q, Q2R x = Q2R y -> x==y. Proof. unfold Qeq, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; intros. apply eq_IZR. do 2 rewrite mult_IZR. set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); set (X2 := IZR (Zpos x2)) in *. set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); set (Y2 := IZR (Zpos y2)) in *. assert ((X2 * X1 * / X2)%R = (X2 * (Y1 * / Y2))%R). rewrite <- H; field; auto. rewrite Rinv_r_simpl_m in H0; auto; rewrite H0; field; auto. Qed. Lemma Qeq_eqR : forall x y : Q, x==y -> Q2R x = Q2R y. Proof. unfold Qeq, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; intros. set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); set (X2 := IZR (Zpos x2)) in *. set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); set (Y2 := IZR (Zpos y2)) in *. assert ((X1 * Y2)%R = (Y1 * X2)%R). unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR. apply IZR_eq; auto. clear H. field_simplify_eq; auto. ring_simplify X1 Y2 (Y2 * X1)%R. rewrite H0; ring. Qed. Lemma Rle_Qle : forall x y : Q, (Q2R x <= Q2R y)%R -> x<=y. Proof. unfold Qle, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; intros. apply le_IZR. do 2 rewrite mult_IZR. set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); set (X2 := IZR (Zpos x2)) in *. set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); set (Y2 := IZR (Zpos y2)) in *. replace (X1 * Y2)%R with (X1 * / X2 * (X2 * Y2))%R; try (field; auto). replace (Y1 * X2)%R with (Y1 * / Y2 * (X2 * Y2))%R; try (field; auto). apply Rmult_le_compat_r; auto. apply Rmult_le_pos. unfold X2; replace 0%R with (IZR 0); auto; apply IZR_le; auto with zarith. unfold Y2; replace 0%R with (IZR 0); auto; apply IZR_le; auto with zarith. Qed. Lemma Qle_Rle : forall x y : Q, x<=y -> (Q2R x <= Q2R y)%R. Proof. unfold Qle, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; intros. set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); set (X2 := IZR (Zpos x2)) in *. set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); set (Y2 := IZR (Zpos y2)) in *. assert (X1 * Y2 <= Y1 * X2)%R. unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR. apply IZR_le; auto. clear H. replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto). replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto). apply Rmult_le_compat_r; auto. apply Rmult_le_pos; apply Rlt_le; apply Rinv_0_lt_compat. unfold X2; replace 0%R with (IZR 0); auto; apply IZR_lt; red; auto with zarith. unfold Y2; replace 0%R with (IZR 0); auto; apply IZR_lt; red; auto with zarith. Qed. Lemma Rlt_Qlt : forall x y : Q, (Q2R x < Q2R y)%R -> x (Q2R x < Q2R y)%R. Proof. unfold Qlt, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden; intros. set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2); set (X2 := IZR (Zpos x2)) in *. set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2); set (Y2 := IZR (Zpos y2)) in *. assert (X1 * Y2 < Y1 * X2)%R. unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR. apply IZR_lt; auto. clear H. replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto). replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto). apply Rmult_lt_compat_r; auto. apply Rmult_lt_0_compat; apply Rinv_0_lt_compat. unfold X2; replace 0%R with (IZR 0); auto; apply IZR_lt; red; auto with zarith. unfold Y2; replace 0%R with (IZR 0); auto; apply IZR_lt; red; auto with zarith. Qed. Lemma Q2R_plus : forall x y : Q, Q2R (x+y) = (Q2R x + Q2R y)%R. Proof. unfold Qplus, Qeq, Q2R; intros (x1, x2) (y1, y2); unfold Qden, Qnum. simpl_mult. rewrite plus_IZR. do 3 rewrite mult_IZR. field; auto. Qed. Lemma Q2R_mult : forall x y : Q, Q2R (x*y) = (Q2R x * Q2R y)%R. Proof. unfold Qmult, Qeq, Q2R; intros (x1, x2) (y1, y2); unfold Qden, Qnum. simpl_mult. do 2 rewrite mult_IZR. field; auto. Qed. Lemma Q2R_opp : forall x : Q, Q2R (- x) = (- Q2R x)%R. Proof. unfold Qopp, Qeq, Q2R; intros (x1, x2); unfold Qden, Qnum. rewrite Ropp_Ropp_IZR. field; auto. Qed. Lemma Q2R_minus : forall x y : Q, Q2R (x-y) = (Q2R x - Q2R y)%R. unfold Qminus; intros; rewrite Q2R_plus; rewrite Q2R_opp; auto. Qed. Lemma Q2R_inv : forall x : Q, ~ x==0 -> Q2R (/x) = (/ Q2R x)%R. Proof. unfold Qinv, Q2R, Qeq; intros (x1, x2); unfold Qden, Qnum. case x1. simpl; intros; elim H; trivial. intros; field; auto. intros; change (IZR (Zneg x2)) with (- IZR (' x2))%R; change (IZR (Zneg p)) with (- IZR (' p))%R; field; (*auto 8 with real.*) repeat split; auto; auto with real. Qed. Lemma Q2R_div : forall x y : Q, ~ y==0 -> Q2R (x/y) = (Q2R x / Q2R y)%R. Proof. unfold Qdiv, Rdiv. intros; rewrite Q2R_mult. rewrite Q2R_inv; auto. Qed. Hint Rewrite Q2R_plus Q2R_mult Q2R_opp Q2R_minus Q2R_inv Q2R_div : q2r_simpl. Section LegacyQField. (** In the past, the field tactic was not able to deal with setoid datatypes, so translating from Q to R and applying field on reals was a workaround. See now Qfield for a direct field tactic on Q. *) Ltac QField := apply eqR_Qeq; autorewrite with q2r_simpl; try field; auto. (** Examples of use: *) Let ex1 : forall x y z : Q, (x+y)*z == (x*z)+(y*z). intros; QField. Qed. Let ex2 : forall x y : Q, ~ y==0 -> (x/y)*y == x. intros; QField. intro; apply H; apply eqR_Qeq. rewrite H0; unfold Q2R; simpl; field; auto with real. Qed. End LegacyQField. coq-8.4pl4/theories/QArith/Qround.v0000644000175000017500000000674412326224777016317 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* - q < - p. Proof. intros (a1,a2) (b1,b2); unfold Qle, Qlt; simpl. rewrite !Z.mul_opp_l; omega. Qed. Hint Resolve Qopp_lt_compat : qarith. (************) Local Coercion inject_Z : Z >-> Q. Definition Qfloor (x:Q) := let (n,d) := x in Z.div n (Zpos d). Definition Qceiling (x:Q) := (-(Qfloor (-x)))%Z. Lemma Qfloor_Z : forall z:Z, Qfloor z = z. Proof. intros z. simpl. auto with *. Qed. Lemma Qceiling_Z : forall z:Z, Qceiling z = z. Proof. intros z. unfold Qceiling. simpl. rewrite Zdiv_1_r. auto with *. Qed. Lemma Qfloor_le : forall x, Qfloor x <= x. Proof. intros [n d]. simpl. unfold Qle. simpl. replace (n*1)%Z with n by ring. rewrite Z.mul_comm. apply Z_mult_div_ge. auto with *. Qed. Hint Resolve Qfloor_le : qarith. Lemma Qle_ceiling : forall x, x <= Qceiling x. Proof. intros x. apply Qle_trans with (- - x). rewrite Qopp_involutive. auto with *. change (Qceiling x:Q) with (-(Qfloor(-x))). auto with *. Qed. Hint Resolve Qle_ceiling : qarith. Lemma Qle_floor_ceiling : forall x, Qfloor x <= Qceiling x. Proof. eauto with qarith. Qed. Lemma Qlt_floor : forall x, x < (Qfloor x+1)%Z. Proof. intros [n d]. simpl. unfold Qlt. simpl. replace (n*1)%Z with n by ring. ring_simplify. replace (n / ' d * ' d + ' d)%Z with (('d * (n / 'd) + n mod 'd) + 'd - n mod 'd)%Z by ring. rewrite <- Z_div_mod_eq; auto with*. rewrite <- Z.lt_add_lt_sub_r. destruct (Z_mod_lt n ('d)); auto with *. Qed. Hint Resolve Qlt_floor : qarith. Lemma Qceiling_lt : forall x, (Qceiling x-1)%Z < x. Proof. intros x. unfold Qceiling. replace (- Qfloor (- x) - 1)%Z with (-(Qfloor (-x) + 1))%Z by ring. change ((- (Qfloor (- x) + 1))%Z:Q) with (-(Qfloor (- x) + 1)%Z). apply Qlt_le_trans with (- - x); auto with *. rewrite Qopp_involutive. auto with *. Qed. Hint Resolve Qceiling_lt : qarith. Lemma Qfloor_resp_le : forall x y, x <= y -> (Qfloor x <= Qfloor y)%Z. Proof. intros [xn xd] [yn yd] Hxy. unfold Qle in *. simpl in *. rewrite <- (Zdiv_mult_cancel_r xn ('xd) ('yd)); auto with *. rewrite <- (Zdiv_mult_cancel_r yn ('yd) ('xd)); auto with *. rewrite (Z.mul_comm ('yd) ('xd)). apply Z_div_le; auto with *. Qed. Hint Resolve Qfloor_resp_le : qarith. Lemma Qceiling_resp_le : forall x y, x <= y -> (Qceiling x <= Qceiling y)%Z. Proof. intros x y Hxy. unfold Qceiling. cut (Qfloor (-y) <= Qfloor (-x))%Z; auto with *. Qed. Hint Resolve Qceiling_resp_le : qarith. Add Morphism Qfloor with signature Qeq ==> eq as Qfloor_comp. Proof. intros x y H. apply Z.le_antisymm. auto with *. symmetry in H; auto with *. Qed. Add Morphism Qceiling with signature Qeq ==> eq as Qceiling_comp. Proof. intros x y H. apply Z.le_antisymm. auto with *. symmetry in H; auto with *. Qed. Lemma Zdiv_Qdiv (n m: Z): (n / m)%Z = Qfloor (n / m). Proof. unfold Qfloor. intros. simpl. destruct m as [?|?|p]; simpl. now rewrite Zdiv_0_r, Z.mul_0_r. now rewrite Z.mul_1_r. rewrite <- Z.opp_eq_mul_m1. rewrite <- (Z.opp_involutive (Zpos p)). now rewrite Zdiv_opp_opp. Qed. coq-8.4pl4/theories/QArith/Qring.v0000644000175000017500000000104512326224777016114 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit (** Is this history stack active (i.e. nonempty) ? The stack is currently inactive when compiling files (coqc). *) val is_active : unit -> bool (** The [Invalid] exception is raised when one of the following function tries to empty the history stack, or reach an unknown states, etc. The stack is preserved in these cases. *) exception Invalid (** Nota Bene: it is critical for the following functions that proofs are nested in a regular way (i.e. no more Resume or Suspend commands as earlier). *) (** Backtracking by a certain number of (non-state-preserving) commands. This is used by Coqide. It may actually undo more commands than asked : for instance instead of jumping back in the middle of a finished proof, we jump back before this proof. The number of extra backtracked command is returned at the end. *) val back : int -> int (** Backtracking to a certain state number, and reset proofs accordingly. We may end on some earlier state if needed to avoid re-opening proofs. Return the state number on which we finally end. *) val backto : int -> int (** Old [Backtrack] code with corresponding update of the history stack. [Backtrack] is now deprecated (in favor of [BackTo]) but is kept for compatibility with ProofGeneral. It's completely up to ProofGeneral to decide where to go and how to adapt proofs. Note that the choices of ProofGeneral are currently not always perfect (for instance when backtracking an Undo). *) val backtrack : int -> int -> int -> unit (** [reset_initial] resets the system and clears the command history stack, only pushing back the initial entry. It should be equivalent to [backto Lib.first_command_label], but sligthly more efficient. *) val reset_initial : unit -> unit (** Reset to the last known state just before defining [id] *) val reset_name : Names.identifier Util.located -> unit (** When a proof is ended (via either Qed/Admitted/Restart/Abort), old proof steps should be marked differently to avoid jumping back to them: - either this proof isn't there anymore in the proof engine - either a proof with the same name is there, but it's a more recent attempt after a Restart/Abort, we shouldn't mix the two. We also mark as unreachable the proof steps cancelled via a Undo. *) val mark_unreachable : ?after:int -> Names.identifier list -> unit (** Parse the history stack for printing the script of a proof *) val get_script : Names.identifier -> (Vernacexpr.vernac_expr * int) list (** For debug purpose, a dump of the history *) type info = { label : int; nproofs : int; prfname : Names.identifier option; prfdepth : int; ngoals : int; cmd : Vernacexpr.vernac_expr; mutable reachable : bool; } val dump_history : unit -> info list coq-8.4pl4/toplevel/ide_intf.mli0000644000175000017500000000373612326224777015762 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* interp_rty call val rewind : rewind_sty -> rewind_rty call val goals : goals_sty -> goals_rty call val hints : hints_sty -> hints_rty call val status : status_sty -> status_rty call val inloadpath : inloadpath_sty -> inloadpath_rty call val mkcases : mkcases_sty -> mkcases_rty call val evars : evars_sty -> evars_rty call val search : search_sty -> search_rty call val get_options : get_options_sty -> get_options_rty call val set_options : set_options_sty -> set_options_rty call val quit : quit_sty -> quit_rty call val abstract_eval_call : handler -> 'a call -> 'a value (** * Protocol version *) val protocol_version : string (** * XML data marshalling *) exception Marshal_error val of_call : 'a call -> xml val to_call : xml -> unknown call val of_message : message -> xml val to_message : xml -> message val is_message : xml -> bool val of_value : ('a -> xml) -> 'a value -> xml val of_feedback : feedback -> xml val to_feedback : xml -> feedback val is_feedback : xml -> bool val of_answer : 'a call -> 'a value -> xml val to_answer : xml -> 'a call -> 'a value (** * Debug printing *) val pr_call : 'a call -> string val pr_value : 'a value -> string val pr_full_value : 'a call -> 'a value -> string coq-8.4pl4/toplevel/vernac.ml0000644000175000017500000003055512326224777015305 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* !atomic_load); Goptions.optwrite = ((:=) atomic_load) } (* Specifies which file is read. The intermediate file names are discarded here. The Drop exception becomes an error. We forget if the error ocurred during interpretation or not *) let raise_with_file file exc = let (cmdloc,re) = match exc with | DuringCommandInterp(loc,e) -> (loc,e) | e -> (dummy_loc,e) in let (inner,inex) = match re with | Error_in_file (_, (b,f,loc), e) when loc <> dummy_loc -> ((b, f, loc), e) | Loc.Exc_located (loc, e) when loc <> dummy_loc -> ((false,file, loc), e) | Loc.Exc_located (_, e) | e -> ((false,file,cmdloc), e) in raise (Error_in_file (file, inner, disable_drop inex)) let real_error = function | Loc.Exc_located (_, e) -> e | Error_in_file (_, _, e) -> e | e -> e let user_error loc s = Util.user_err_loc (loc,"_",str s) (** Timeout handling *) (** A global default timeout, controled by option "Set Default Timeout n". Use "Unset Default Timeout" to deactivate it (or set it to 0). *) let default_timeout = ref None let _ = Goptions.declare_int_option { Goptions.optsync = true; Goptions.optdepr = false; Goptions.optname = "the default timeout"; Goptions.optkey = ["Default";"Timeout"]; Goptions.optread = (fun () -> !default_timeout); Goptions.optwrite = ((:=) default_timeout) } (** When interpreting a command, the current timeout is initially the default one, but may be modified locally by a Timeout command. *) let current_timeout = ref None (** Installing and de-installing a timer. Note: according to ocaml documentation, Unix.alarm isn't available for native win32. *) let timeout_handler _ = raise Timeout let set_timeout n = let psh = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in ignore (Unix.alarm n); Some psh let default_set_timeout () = match !current_timeout with | Some n -> set_timeout n | None -> None let restore_timeout = function | None -> () | Some psh -> (* stop alarm *) ignore(Unix.alarm 0); (* restore handler *) Sys.set_signal Sys.sigalrm psh (* Open an utf-8 encoded file and skip the byte-order mark if any *) let open_utf8_file_in fname = let is_bom s = Char.code s.[0] = 0xEF && Char.code s.[1] = 0xBB && Char.code s.[2] = 0xBF in let in_chan = open_in fname in let s = " " in if input in_chan s 0 3 < 3 || not (is_bom s) then seek_in in_chan 0; in_chan (* Opening and closing a channel. Open it twice when verbose: the first channel is used to read the commands, and the second one to print them. Note: we could use only one thanks to seek_in, but seeking on and on in the file we parse seems a bit risky to me. B.B. *) let open_file_twice_if verbosely fname = let paths = Library.get_load_paths () in let _,longfname = find_file_in_path ~warn:(Flags.is_verbose()) paths fname in let in_chan = open_utf8_file_in longfname in let verb_ch = if verbosely then Some (open_utf8_file_in longfname) else None in let po = Pcoq.Gram.parsable (Stream.of_channel in_chan) in (in_chan, longfname, (po, verb_ch)) let close_input in_chan (_,verb) = try close_in in_chan; match verb with | Some verb_ch -> close_in verb_ch | _ -> () with e when Errors.noncritical e -> () let verbose_phrase verbch loc = let loc = unloc loc in match verbch with | Some ch -> let len = snd loc - fst loc in let s = String.create len in seek_in ch (fst loc); really_input ch s 0 len; message s; pp_flush() | _ -> () exception End_of_input let parse_sentence (po, verbch) = match Pcoq.Gram.entry_parse Pcoq.main_entry po with | Some (loc,_ as com) -> verbose_phrase verbch loc; com | None -> raise End_of_input (* vernac parses the given stream, executes interpfun on the syntax tree it * parses, and is verbose on "primitives" commands if verbosely is true *) let just_parsing = ref false let chan_beautify = ref stdout let beautify_suffix = ".beautified" let set_formatter_translator() = let ch = !chan_beautify in let out s b e = output ch s b e in Format.set_formatter_output_functions out (fun () -> flush ch); Format.set_max_boxes max_int let pr_new_syntax loc ocom = let loc = unloc loc in if !beautify_file then set_formatter_translator(); let fs = States.freeze () in let com = match ocom with | Some VernacNop -> mt() | Some com -> pr_vernac com | None -> mt() in if !beautify_file then msg (hov 0 (comment (fst loc) ++ com ++ comment (snd loc))) else msgnl (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); States.unfreeze fs; Format.set_formatter_out_channel stdout let rec vernac_com interpfun checknav (loc,com) = let rec interp = function | VernacLoad (verbosely, fname) -> let fname = expand_path_macros fname in (* translator state *) let ch = !chan_beautify in let cs = Lexer.com_state() in let cl = !Pp.comments in (* end translator state *) (* coqdoc state *) let cds = Dumpglob.coqdoc_freeze() in if !Flags.beautify_file then begin let _,f = find_file_in_path ~warn:(Flags.is_verbose()) (Library.get_load_paths ()) (make_suffix fname ".v") in chan_beautify := open_out (f^beautify_suffix); Pp.comments := [] end; begin try read_vernac_file verbosely (make_suffix fname ".v"); if !Flags.beautify_file then close_out !chan_beautify; chan_beautify := ch; Lexer.restore_com_state cs; Pp.comments := cl; Dumpglob.coqdoc_unfreeze cds with reraise -> if !Flags.beautify_file then close_out !chan_beautify; chan_beautify := ch; Lexer.restore_com_state cs; Pp.comments := cl; Dumpglob.coqdoc_unfreeze cds; raise reraise end | VernacList l -> List.iter (fun (_,v) -> interp v) l | v when !just_parsing -> () | VernacFail v -> begin try (* If the command actually works, ignore its effects on the state *) States.with_state_protection (fun v -> interp v; raise HasNotFailed) v with e when Errors.noncritical e -> match real_error e with | HasNotFailed -> errorlabstrm "Fail" (str "The command has not failed !") | e -> (* Anomalies are re-raised by the next line *) let msg = Errors.print_no_anomaly e in if_verbose msgnl (str "The command has indeed failed with message:" ++ fnl () ++ str "=> " ++ hov 0 msg) end | VernacTime v -> let tstart = System.get_time() in interp v; let tend = System.get_time() in msgnl (str"Finished transaction in " ++ System.fmt_time_difference tstart tend) | VernacTimeout(n,v) -> current_timeout := Some n; interp v | v -> let psh = default_set_timeout () in try States.with_heavy_rollback interpfun Cerrors.process_vernac_interp_error v; restore_timeout psh with reraise -> restore_timeout psh; raise reraise in try checknav loc com; current_timeout := !default_timeout; if do_beautify () then pr_new_syntax loc (Some com); interp com with any -> Format.set_formatter_out_channel stdout; raise (DuringCommandInterp (loc, any)) and read_vernac_file verbosely s = Flags.make_warn verbosely; let interpfun = if verbosely then Vernacentries.interp else Flags.silently Vernacentries.interp in let checknav loc cmd = if is_navigation_vernac cmd && not (is_reset cmd) then user_error loc "Navigation commands forbidden in files" in let end_inner_command cmd = if !atomic_load || is_reset cmd then Lib.mark_end_of_command () (* for Reset in coqc or coqtop -l *) else Backtrack.mark_command cmd; (* for Show Script, cf bug #2820 *) in let (in_chan, fname, input) = open_file_twice_if verbosely s in try (* we go out of the following infinite loop when a End_of_input is * raised, which means that we raised the end of the file being loaded *) while true do let loc_ast = parse_sentence input in vernac_com interpfun checknav loc_ast; end_inner_command (snd loc_ast); pp_flush () done with reraise -> (* whatever the exception *) Format.set_formatter_out_channel stdout; close_input in_chan input; (* we must close the file first *) match real_error reraise with | End_of_input -> if do_beautify () then pr_new_syntax (make_loc (max_int,max_int)) None | _ -> raise_with_file fname reraise (** [eval_expr : ?preserving:bool -> Pp.loc * Vernacexpr.vernac_expr -> unit] It executes one vernacular command. By default the command is considered as non-state-preserving, in which case we add it to the Backtrack stack (triggering a save of a frozen state and the generation of a new state label). An example of state-preserving command is one coming from the query panel of Coqide. *) let checknav loc ast = if is_deep_navigation_vernac ast then user_error loc "Navigation commands forbidden in nested commands" let eval_expr ?(preserving=false) loc_ast = vernac_com Vernacentries.interp checknav loc_ast; if not preserving && not (is_navigation_vernac (snd loc_ast)) then Backtrack.mark_command (snd loc_ast) (* raw_do_vernac : Pcoq.Gram.parsable -> unit * vernac_step . parse_sentence *) let raw_do_vernac po = eval_expr (parse_sentence (po,None)) (* XML output hooks *) let xml_start_library = ref (fun _ -> ()) let xml_end_library = ref (fun _ -> ()) let set_xml_start_library f = xml_start_library := f let set_xml_end_library f = xml_end_library := f (* Load a vernac file. Errors are annotated with file and location *) let load_vernac verb file = chan_beautify := if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout; try Lib.mark_end_of_command (); (* in case we're still in coqtop init *) read_vernac_file verb file; if !Flags.beautify_file then close_out !chan_beautify; with reraise -> if !Flags.beautify_file then close_out !chan_beautify; raise_with_file file reraise (* Compile a vernac file (f is assumed without .v suffix) *) let compile verbosely f = let ldir,long_f_dot_v = Flags.verbosely Library.start_library f in Dumpglob.start_dump_glob long_f_dot_v; Dumpglob.dump_string ("F" ^ Names.string_of_dirpath ldir ^ "\n"); if !Flags.xml_export then !xml_start_library (); let _ = load_vernac verbosely long_f_dot_v in if Pfedit.get_all_proof_names () <> [] then (message "Error: There are pending proofs"; exit 1); if !Flags.xml_export then !xml_end_library (); Dumpglob.end_dump_glob (); Library.save_library_to ldir (long_f_dot_v ^ "o") coq-8.4pl4/toplevel/ide_slave.ml0000644000175000017500000003740312326224777015761 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* flush_all (); orig_stdout := Unix.out_channel_of_descr (Unix.dup Unix.stdout); Unix.dup2 Unix.stderr Unix.stdout; Pp_control.std_ft := out_ft; Pp_control.err_ft := out_ft; Pp_control.deep_ft := deep_out_ft; set_binary_mode_out !orig_stdout true; set_binary_mode_in stdin true; ), (fun () -> Format.pp_print_flush out_ft (); let r = Buffer.contents out_buff in Buffer.clear out_buff; r) let pr_debug s = if !Flags.debug then Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s (** Categories of commands *) let coqide_known_option table = List.mem table [ ["Printing";"Implicit"]; ["Printing";"Coercions"]; ["Printing";"Matching"]; ["Printing";"Synth"]; ["Printing";"Notations"]; ["Printing";"All"]; ["Printing";"Records"]; ["Printing";"Existential";"Instances"]; ["Printing";"Universes"]] let is_known_option cmd = match cmd with | VernacSetOption (_,o,BoolValue true) | VernacUnsetOption (_,o) -> coqide_known_option o | _ -> false let is_debug cmd = match cmd with | VernacSetOption (_,["Ltac";"Debug"], _) -> true | _ -> false let is_query cmd = match cmd with | VernacChdir None | VernacMemOption _ | VernacPrintOption _ | VernacCheckMayEval _ | VernacGlobalCheck _ | VernacPrint _ | VernacSearch _ | VernacLocate _ -> true | _ -> false let is_undo cmd = match cmd with | VernacUndo _ | VernacUndoTo _ -> true | _ -> false (** Check whether a command is forbidden by CoqIDE *) let coqide_cmd_checks (loc,ast) = let user_error s = raise (Loc.Exc_located (loc, Util.UserError ("CoqIde", str s))) in if is_debug ast then user_error "Debug mode not available within CoqIDE"; if is_known_option ast then user_error "Use CoqIDE display menu instead"; if is_navigation_vernac ast then user_error "Use CoqIDE navigation instead"; if is_undo ast then msgerrnl (str "Warning: rather use CoqIDE navigation instead"); if is_query ast then msgerrnl (str "Warning: query commands should not be inserted in scripts") (** Interpretation (cf. [Ide_intf.interp]) *) let interp (id,raw,verbosely,s) = let pa = Pcoq.Gram.parsable (Stream.of_string s) in let loc_ast = Vernac.parse_sentence (pa,None) in if not raw then coqide_cmd_checks loc_ast; Flags.make_silent (not verbosely); Vernac.eval_expr ~preserving:raw loc_ast; Flags.make_silent true; read_stdout () (** Goal display *) let hyp_next_tac sigma env (id,_,ast) = let id_s = Names.string_of_id id in let type_s = string_of_ppcmds (pr_ltype_env env ast) in [ ("clear "^id_s),("clear "^id_s^"."); ("apply "^id_s),("apply "^id_s^"."); ("exact "^id_s),("exact "^id_s^"."); ("generalize "^id_s),("generalize "^id_s^"."); ("absurd <"^id_s^">"),("absurd "^type_s^".") ] @ [ ("discriminate "^id_s),("discriminate "^id_s^"."); ("injection "^id_s),("injection "^id_s^".") ] @ [ ("rewrite "^id_s),("rewrite "^id_s^"."); ("rewrite <- "^id_s),("rewrite <- "^id_s^".") ] @ [ ("elim "^id_s), ("elim "^id_s^"."); ("inversion "^id_s), ("inversion "^id_s^"."); ("inversion clear "^id_s), ("inversion_clear "^id_s^".") ] let concl_next_tac sigma concl = let expand s = (s,s^".") in List.map expand ([ "intro"; "intros"; "intuition" ] @ [ "reflexivity"; "discriminate"; "symmetry" ] @ [ "assumption"; "omega"; "ring"; "auto"; "eauto"; "tauto"; "trivial"; "decide equality"; "simpl"; "subst"; "red"; "split"; "left"; "right" ]) let process_goal sigma g = let env = Goal.V82.env sigma g in let id = Goal.uid g in let ccl = let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in string_of_ppcmds (pr_goal_concl_style_env env norm_constr) in let process_hyp h_env d acc = let d = Term.map_named_declaration (Reductionops.nf_evar sigma) d in (string_of_ppcmds (pr_var_decl h_env d)) :: acc in let hyps = List.rev (Environ.fold_named_context process_hyp env ~init: []) in { Interface.goal_hyp = hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; } let goals () = try let pfts = Proof_global.give_me_the_proof () in let (goals, zipper, sigma) = Proof.proof pfts in let fg = List.map (process_goal sigma) goals in let map_zip (lg, rg) = let lg = List.map (process_goal sigma) lg in let rg = List.map (process_goal sigma) rg in (lg, rg) in let bg = List.map map_zip zipper in Some { Interface.fg_goals = fg; Interface.bg_goals = bg; } with Proof_global.NoCurrentProof -> None let evars () = try let pfts = Proof_global.give_me_the_proof () in let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in let exl = Evarutil.non_instantiated sigma in let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar ev); } in let el = List.map map_evar exl in Some el with Proof_global.NoCurrentProof -> None let hints () = try let pfts = Proof_global.give_me_the_proof () in let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in match all_goals with | [] -> None | g :: _ -> let env = Goal.V82.env sigma g in let hint_goal = concl_next_tac sigma g in let get_hint_hyp env d accu = hyp_next_tac sigma env d :: accu in let hint_hyps = List.rev (Environ.fold_named_context get_hint_hyp env ~init: []) in Some (hint_hyps, hint_goal) with Proof_global.NoCurrentProof -> None (** Other API calls *) let inloadpath dir = Library.is_in_load_paths (System.physical_path_of_string dir) let status () = (** We remove the initial part of the current [dir_path] (usually Top in an interactive session, cf "coqtop -top"), and display the other parts (opened sections and modules) *) let path = let l = Names.repr_dirpath (Lib.cwd ()) in List.rev_map Names.string_of_id l in let proof = try Some (Names.string_of_id (Proof_global.get_current_proof_name ())) with Proof_global.NoCurrentProof -> None in let allproofs = let l = Proof_global.get_all_proof_names () in List.map Names.string_of_id l in { Interface.status_path = path; Interface.status_proofname = proof; Interface.status_allproofs = allproofs; Interface.status_statenum = Lib.current_command_label (); Interface.status_proofnum = Pfedit.current_proof_depth (); } (** This should be elsewhere... *) let search flags = let env = Global.env () in let rec extract_flags name tpe subtpe mods blacklist = function | [] -> (name, tpe, subtpe, mods, blacklist) | (Interface.Name_Pattern s, b) :: l -> let regexp = try Str.regexp s with e when Errors.noncritical e -> Util.error ("Invalid regexp: " ^ s) in extract_flags ((regexp, b) :: name) tpe subtpe mods blacklist l | (Interface.Type_Pattern s, b) :: l -> let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in let (_, pat) = Constrintern.intern_constr_pattern Evd.empty env constr in extract_flags name ((pat, b) :: tpe) subtpe mods blacklist l | (Interface.SubType_Pattern s, b) :: l -> let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in let (_, pat) = Constrintern.intern_constr_pattern Evd.empty env constr in extract_flags name tpe ((pat, b) :: subtpe) mods blacklist l | (Interface.In_Module m, b) :: l -> let path = String.concat "." m in let m = Pcoq.parse_string Pcoq.Constr.global path in let (_, qid) = Libnames.qualid_of_reference m in let id = try Nametab.full_name_module qid with Not_found -> Util.error ("Module " ^ path ^ " not found.") in extract_flags name tpe subtpe ((id, b) :: mods) blacklist l | (Interface.Include_Blacklist, b) :: l -> extract_flags name tpe subtpe mods b l in let (name, tpe, subtpe, mods, blacklist) = extract_flags [] [] [] [] false flags in let filter_function ref env constr = let id = Names.string_of_id (Nametab.basename_of_global ref) in let path = Libnames.dirpath (Nametab.path_of_global ref) in let toggle x b = if x then b else not b in let match_name (regexp, flag) = toggle (Str.string_match regexp id 0) flag in let match_type (pat, flag) = toggle (Matching.is_matching pat constr) flag in let match_subtype (pat, flag) = toggle (Matching.is_matching_appsubterm ~closed:false pat constr) flag in let match_module (mdl, flag) = toggle (Libnames.is_dirpath_prefix_of mdl path) flag in let in_blacklist = blacklist || (Search.filter_blacklist ref env constr) in List.for_all match_name name && List.for_all match_type tpe && List.for_all match_subtype subtpe && List.for_all match_module mods && in_blacklist in let ans = ref [] in let print_function ref env constr = let fullpath = repr_dirpath (Nametab.dirpath_of_global ref) in let qualid = Nametab.shortest_qualid_of_global Idset.empty ref in let (shortpath, basename) = Libnames.repr_qualid qualid in let shortpath = repr_dirpath shortpath in (* [shortpath] is a suffix of [fullpath] and we're looking for the missing prefix *) let rec prefix full short accu = match full, short with | _, [] -> let full = List.rev_map string_of_id full in (full, accu) | _ :: full, m :: short -> prefix full short (string_of_id m :: accu) | _ -> assert false in let (prefix, qualid) = prefix fullpath shortpath [string_of_id basename] in let answer = { Interface.coq_object_prefix = prefix; Interface.coq_object_qualid = qualid; Interface.coq_object_object = string_of_ppcmds (pr_lconstr_env env constr); } in ans := answer :: !ans; in let () = Search.gen_filtered_search filter_function print_function in !ans let get_options () = let table = Goptions.get_tables () in let fold key state accu = (key, state) :: accu in Goptions.OptionMap.fold fold table [] let set_options options = let iter (name, value) = match value with | BoolValue b -> Goptions.set_bool_option_value name b | IntValue i -> Goptions.set_int_option_value name i | StringValue s -> Goptions.set_string_option_value name s in List.iter iter options let about () = { Interface.coqtop_version = Coq_config.version; Interface.protocol_version = Ide_intf.protocol_version; Interface.release_date = Coq_config.date; Interface.compile_date = Coq_config.compile_date; } (** Grouping all call handlers together + error handling *) exception Quit let eval_call c = let rec handle_exn e = catch_break := false; let pr_exn e = (read_stdout ())^("\n"^(string_of_ppcmds (Errors.print e))) in match e with | Quit -> (* Here we do send an acknowledgement message to prove everything went OK. *) let dummy = Interface.Good () in let xml_answer = Ide_intf.of_answer (Ide_intf.quit ()) dummy in let () = Xml_utils.print_xml !orig_stdout xml_answer in let () = flush !orig_stdout in let () = pr_debug "Exiting gracefully." in exit 0 | Vernacexpr.Drop -> None, "Drop is not allowed by coqide!" | Vernacexpr.Quit -> None, "Quit is not allowed by coqide!" | Vernac.DuringCommandInterp (_,inner) -> handle_exn inner | Error_in_file (_,_,inner) -> None, pr_exn inner | Loc.Exc_located (loc, inner) when loc = dummy_loc -> None, pr_exn inner | Loc.Exc_located (loc, inner) -> Some (Util.unloc loc), pr_exn inner | e -> None, pr_exn e in let interruptible f x = catch_break := true; Util.check_for_interrupt (); let r = f x in catch_break := false; r in let handler = { Interface.interp = interruptible interp; Interface.rewind = interruptible Backtrack.back; Interface.goals = interruptible goals; Interface.evars = interruptible evars; Interface.hints = interruptible hints; Interface.status = interruptible status; Interface.search = interruptible search; Interface.inloadpath = interruptible inloadpath; Interface.get_options = interruptible get_options; Interface.set_options = interruptible set_options; Interface.mkcases = interruptible Vernacentries.make_cases; Interface.quit = (fun () -> raise Quit); Interface.about = interruptible about; Interface.handle_exn = handle_exn; } in (* If the messages of last command are still there, we remove them *) ignore (read_stdout ()); Ide_intf.abstract_eval_call handler c (** The main loop *) (** Exceptions during eval_call should be converted into [Interface.Fail] messages by [handle_exn] above. Otherwise, we die badly, after having tried to send a last message to the ide: trying to recover from errors with the current protocol would most probably bring desynchronisation between coqtop and ide. With marshalling, reading an answer to a different request could hang the ide... *) let fail err = Ide_intf.of_value (fun _ -> assert false) (Interface.Fail (None, err)) let loop () = let p = Xml_parser.make () in let () = Xml_parser.check_eof p false in init_signal_handler (); catch_break := false; (* We'll handle goal fetching and display in our own way *) Vernacentries.enable_goal_printing := false; Vernacentries.qed_display_script := false; try while true do let xml_answer = try let xml_query = Xml_parser.parse p (Xml_parser.SChannel stdin) in let q = Ide_intf.to_call xml_query in let () = pr_debug ("<-- " ^ Ide_intf.pr_call q) in let r = eval_call q in let () = pr_debug ("--> " ^ Ide_intf.pr_full_value q r) in Ide_intf.of_answer q r with | Xml_parser.Error (Xml_parser.Empty, _) -> pr_debug ("End of input, exiting"); exit 0 | Xml_parser.Error (err, loc) -> let msg = "Syntax error in query: " ^ Xml_parser.error_msg err in fail msg | Ide_intf.Marshal_error -> fail "Incorrect query." in Xml_utils.print_xml !orig_stdout xml_answer; flush !orig_stdout done with any -> let msg = Printexc.to_string any in let r = "Fatal exception in coqtop:\n" ^ msg in pr_debug ("==> " ^ r); (try Xml_utils.print_xml !orig_stdout (fail r); flush !orig_stdout with any -> ()); exit 1 coq-8.4pl4/toplevel/cerrors.ml0000644000175000017500000001133212326224777015476 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ") else let loc = unloc loc in (int (fst loc) ++ str"-" ++ int (snd loc)) let guill s = "\""^s^"\"" exception EvaluatedError of std_ppcmds * exn option (** Registration of generic errors Nota: explain_exn does NOT end with a newline anymore! *) let explain_exn_default = function (* Basic interaction exceptions *) | Stream.Error txt -> hov 0 (str ("Syntax error: " ^ txt ^ ".")) | Token.Error txt -> hov 0 (str ("Syntax error: " ^ txt ^ ".")) | Lexer.Error.E err -> hov 0 (str (Lexer.Error.to_string err)) | Sys_error msg -> hov 0 (str ("System error: " ^ guill msg)) | Out_of_memory -> hov 0 (str "Out of memory.") | Stack_overflow -> hov 0 (str "Stack overflow.") | Timeout -> hov 0 (str "Timeout!") | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.") (* Meta-exceptions *) | Loc.Exc_located (loc,exc) -> hov 0 ((if loc = dummy_loc then (mt ()) else (str"At location " ++ print_loc loc ++ str":" ++ fnl ())) ++ Errors.print_no_anomaly exc) | EvaluatedError (msg,None) -> msg | EvaluatedError (msg,Some reraise) -> msg ++ Errors.print_no_anomaly reraise (* Otherwise, not handled here *) | _ -> raise Errors.Unhandled let _ = Errors.register_handler explain_exn_default (** Pre-explain a vernac interpretation error *) let wrap_vernac_error strm = EvaluatedError (hov 0 (str "Error:" ++ spc () ++ strm), None) let rec process_vernac_interp_error = function | Univ.UniverseInconsistency (o,u,v) -> let msg = if !Constrextern.print_universes then spc() ++ str "(cannot enforce" ++ spc() ++ Univ.pr_uni u ++ spc() ++ str (match o with Univ.Lt -> "<" | Univ.Le -> "<=" | Univ.Eq -> "=") ++ spc() ++ Univ.pr_uni v ++ str")" else mt() in wrap_vernac_error (str "Universe inconsistency" ++ msg ++ str ".") | TypeError(ctx,te) -> wrap_vernac_error (Himsg.explain_type_error ctx Evd.empty te) | PretypeError(ctx,sigma,te) -> wrap_vernac_error (Himsg.explain_pretype_error ctx sigma te) | Typeclasses_errors.TypeClassError(env, te) -> wrap_vernac_error (Himsg.explain_typeclass_error env te) | InductiveError e -> wrap_vernac_error (Himsg.explain_inductive_error e) | Modops.ModuleTypingError e -> wrap_vernac_error (Himsg.explain_module_error e) | Modintern.ModuleInternalizationError e -> wrap_vernac_error (Himsg.explain_module_internalization_error e) | RecursionSchemeError e -> wrap_vernac_error (Himsg.explain_recursion_scheme_error e) | Cases.PatternMatchingError (env,e) -> wrap_vernac_error (Himsg.explain_pattern_matching_error env e) | Tacred.ReductionTacticError e -> wrap_vernac_error (Himsg.explain_reduction_tactic_error e) | Logic.RefinerError e -> wrap_vernac_error (Himsg.explain_refiner_error e) | Nametab.GlobalizationError q -> wrap_vernac_error (str "The reference" ++ spc () ++ Libnames.pr_qualid q ++ spc () ++ str "was not found" ++ spc () ++ str "in the current" ++ spc () ++ str "environment.") | Nametab.GlobalizationConstantError q -> wrap_vernac_error (str "No constant of this name:" ++ spc () ++ Libnames.pr_qualid q ++ str ".") | Refiner.FailError (i,s) -> wrap_vernac_error (str "Tactic failure" ++ (if Lazy.force s <> mt() then str ":" ++ Lazy.force s else mt ()) ++ if i=0 then str "." else str " (level " ++ int i ++ str").") | AlreadyDeclared msg -> wrap_vernac_error (msg ++ str ".") | Proof_type.LtacLocated (_,(Refiner.FailError (i,s) as exc)) when Lazy.force s <> mt () -> process_vernac_interp_error exc | Proof_type.LtacLocated (s,exc) -> EvaluatedError (hov 0 (Himsg.explain_ltac_call_trace s ++ fnl()), Some (process_vernac_interp_error exc)) | Loc.Exc_located (loc,exc) -> Loc.Exc_located (loc,process_vernac_interp_error exc) | exc -> exc let _ = Tactic_debug.explain_logic_error := (fun e -> Errors.print (process_vernac_interp_error e)) let _ = Tactic_debug.explain_logic_error_no_anomaly := (fun e -> Errors.print_no_report (process_vernac_interp_error e)) coq-8.4pl4/toplevel/backtrack.ml0000644000175000017500000002063012326224777015745 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* l:=i::!l) history; !l (** Basic manipulation of the command history stack *) exception Invalid let pop () = ignore (Stack.pop history) let npop n = (* Since our history stack always contains an initial entry, it's invalid to try to completely empty it *) if n < 0 || n >= Stack.length history then raise Invalid else for i = 1 to n do pop () done let top () = try Stack.top history with Stack.Empty -> raise Invalid (** Search the history stack for a suitable location. We perform first a non-destructive search: in case of search failure, the stack is unchanged. *) exception Found of info let search test = try Stack.iter (fun i -> if test i then raise (Found i)) history; raise Invalid with Found i -> while i != Stack.top history do pop () done (** An auxiliary function to retrieve the number of remaining subgoals *) let get_ngoals () = try let prf = Proof_global.give_me_the_proof () in List.length (Evd.sig_it (Proof.V82.background_subgoals prf)) with Proof_global.NoCurrentProof -> 0 (** Register the end of a command and store the current state *) let mark_command ast = Lib.add_frozen_state(); Lib.mark_end_of_command(); Stack.push { label = Lib.current_command_label (); nproofs = List.length (Pfedit.get_all_proof_names ()); prfname = (try Some (Pfedit.get_current_proof_name ()) with Proof_global.NoCurrentProof -> None); prfdepth = max 0 (Pfedit.current_proof_depth ()); reachable = true; ngoals = get_ngoals (); cmd = ast } history (** Backtrack by aborting [naborts] proofs, then setting proof-depth back to [pnum] and finally going to state number [snum]. *) let raw_backtrack snum pnum naborts = for i = 1 to naborts do Pfedit.delete_current_proof () done; Pfedit.undo_todepth pnum; Lib.reset_label snum (** Re-sync the state of the system (label, proofs) with the top of the history stack. We may end on some earlier state to avoid re-opening proofs. This function will return the final label and the number of extra backtracking steps performed. *) let sync nb_opened_proofs = (* Backtrack by enough additional steps to avoid re-opening proofs. Typically, when a Qed has been crossed, we backtrack to the proof start. NB: We cannot reach the empty stack, since the first entry in the stack has no opened proofs and is tagged as reachable. *) let extra = ref 0 in while not (top()).reachable do incr extra; pop () done; let target = top () in (* Now the opened proofs at target is a subset of the opened proofs before the backtrack, we simply abort the extra proofs (if any). NB: It is critical here that proofs are nested in a regular way (i.e. no more Resume or Suspend commands as earlier). This way, we can simply count the extra proofs to abort instead of taking care of their names. *) let naborts = nb_opened_proofs - target.nproofs in (* We are now ready to do a low-level backtrack *) raw_backtrack target.label target.prfdepth naborts; (target.label, !extra) (** Backtracking by a certain number of (non-state-preserving) commands. This is used by Coqide. It may actually undo more commands than asked : for instance instead of jumping back in the middle of a finished proof, we jump back before this proof. The number of extra backtracked command is returned at the end. *) let back count = if count = 0 then 0 else let nb_opened_proofs = List.length (Pfedit.get_all_proof_names ()) in npop count; snd (sync nb_opened_proofs) (** Backtracking to a certain state number, and reset proofs accordingly. We may end on some earlier state if needed to avoid re-opening proofs. Return the final state number. *) let backto snum = if snum = Lib.current_command_label () then snum else let nb_opened_proofs = List.length (Pfedit.get_all_proof_names ()) in search (fun i -> i.label = snum); fst (sync nb_opened_proofs) (** Old [Backtrack] code with corresponding update of the history stack. [Backtrack] is now deprecated (in favor of [BackTo]) but is kept for compatibility with ProofGeneral. It's completely up to ProofGeneral to decide where to go and how to adapt proofs. Note that the choices of ProofGeneral are currently not always perfect (for instance when backtracking an Undo). *) let backtrack snum pnum naborts = raw_backtrack snum pnum naborts; search (fun i -> i.label = snum) (** [reset_initial] resets the system and clears the command history stack, only pushing back the initial entry. It should be equivalent to [backto Lib.first_command_label], but sligthly more efficient. *) let reset_initial () = let init_label = Lib.first_command_label in if Lib.current_command_label () = init_label then () else begin Pfedit.delete_all_proofs (); Lib.reset_label init_label; Stack.clear history; Stack.push { label = init_label; nproofs = 0; prfname = None; prfdepth = 0; ngoals = 0; reachable = true; cmd = VernacNop } history end (** Reset to the last known state just before defining [id] *) let reset_name id = let lbl = try Lib.label_before_name id with Not_found -> raise Invalid in ignore (backto lbl) (** When a proof is ended (via either Qed/Admitted/Restart/Abort), old proof steps should be marked differently to avoid jumping back to them: - either this proof isn't there anymore in the proof engine - either it's there but it's a more recent attempt after a Restart, so we shouldn't mix the two. We also mark as unreachable the proof steps cancelled via a Undo. *) let mark_unreachable ?(after=0) prf_lst = let fix i = match i.prfname with | None -> raise Not_found (* stop hacking the history outside of proofs *) | Some p -> if List.mem p prf_lst && i.prfdepth > after then i.reachable <- false in try Stack.iter fix history with Not_found -> () (** Parse the history stack for printing the script of a proof *) let get_script prf = let script = ref [] in let select i = match i.prfname with | None -> raise Not_found | Some p when p=prf && i.reachable -> script := i :: !script | _ -> () in (try Stack.iter select history with Not_found -> ()); (* Get rid of intermediate commands which don't grow the proof depth *) let rec filter n = function | [] -> [] | {prfdepth=d; cmd=c; ngoals=ng}::l when n < d -> (c,ng) :: filter d l | {prfdepth=d}::l -> filter d l in (* initial proof depth (after entering the lemma statement) is 1 *) filter 1 !script coq-8.4pl4/toplevel/class.ml0000644000175000017500000002142512326224777015130 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (Printer.pr_global g ++ str" is already a coercion") | NotAFunction -> (Printer.pr_global g ++ str" is not a function") | NoSource (Some cl) -> (str "Cannot recognize " ++ pr_class cl ++ str " as a source class of " ++ Printer.pr_global g) | NoSource None -> (str ": cannot find the source class of " ++ Printer.pr_global g) | ForbiddenSourceClass cl -> pr_class cl ++ str " cannot be a source class" | NotUniform -> (Printer.pr_global g ++ str" does not respect the uniform inheritance condition"); | NoTarget -> (str"Cannot find the target class") | WrongTarget (clt,cl) -> (str"Found target class " ++ pr_class cl ++ str " instead of " ++ pr_class clt) | NotAClass ref -> (str "Type of " ++ Printer.pr_global ref ++ str " does not end with a sort") | NotEnoughClassArgs cl -> (str"Wrong number of parameters for " ++ pr_class cl) (* Verifications pour l'ajout d'une classe *) let check_reference_arity ref = if not (Reductionops.is_arity (Global.env()) Evd.empty (Global.type_of_global ref)) then raise (CoercionError (NotAClass ref)) let check_arity = function | CL_FUN | CL_SORT -> () | CL_CONST cst -> check_reference_arity (ConstRef cst) | CL_SECVAR id -> check_reference_arity (VarRef id) | CL_IND kn -> check_reference_arity (IndRef kn) (* Coercions *) (* check that the computed target is the provided one *) let check_target clt = function | Some cl when cl <> clt -> raise (CoercionError (WrongTarget(clt,cl))) | _ -> () (* condition d'heritage uniforme *) let uniform_cond nargs lt = let rec aux = function | (0,[]) -> true | (n,t::l) -> let t = strip_outer_cast t in isRel t && destRel t = n && aux ((n-1),l) | _ -> false in aux (nargs,lt) let class_of_global = function | ConstRef sp -> CL_CONST sp | IndRef sp -> CL_IND sp | VarRef id -> CL_SECVAR id | ConstructRef _ as c -> errorlabstrm "class_of_global" (str "Constructors, such as " ++ Printer.pr_global c ++ str ", cannot be used as a class.") (* lp est la liste (inverse'e) des arguments de la coercion ids est le nom de la classe source sps_opt est le sp de la classe source dans le cas des structures retourne: la classe source nbre d'arguments de la classe le constr de la class la liste des variables dont depend la classe source l'indice de la classe source dans la liste lp *) let get_source lp source = match source with | None -> let (cl1,lv1) = match lp with | [] -> raise Not_found | t1::_ -> find_class_type Evd.empty t1 in (cl1,lv1,1) | Some cl -> let rec aux = function | [] -> raise Not_found | t1::lt -> try let cl1,lv1 = find_class_type Evd.empty t1 in if cl = cl1 then cl1,lv1,(List.length lt+1) else raise Not_found with Not_found -> aux lt in aux (List.rev lp) let get_target t ind = if (ind > 1) then CL_FUN else fst (find_class_type Evd.empty t) let prods_of t = let rec aux acc d = match kind_of_term d with | Prod (_,c1,c2) -> aux (c1::acc) c2 | Cast (c,_,_) -> aux acc c | _ -> (d,acc) in aux [] t let strength_of_cl = function | CL_CONST kn -> Global | CL_SECVAR id -> Local | _ -> Global let get_strength stre ref cls clt = let stres = strength_of_cl cls in let stret = strength_of_cl clt in let stref = strength_of_global ref in strength_min [stre;stres;stret;stref] let ident_key_of_class = function | CL_FUN -> "Funclass" | CL_SORT -> "Sortclass" | CL_CONST sp -> string_of_label (con_label sp) | CL_IND (sp,_) -> string_of_label (mind_label sp) | CL_SECVAR id -> string_of_id id (* coercion identité *) let error_not_transparent source = errorlabstrm "build_id_coercion" (pr_class source ++ str " must be a transparent constant.") let build_id_coercion idf_opt source = let env = Global.env () in let vs = match source with | CL_CONST sp -> mkConst sp | _ -> error_not_transparent source in let c = match constant_opt_value env (destConst vs) with | Some c -> c | None -> error_not_transparent source in let lams,t = decompose_lam_assum c in let val_f = it_mkLambda_or_LetIn (mkLambda (Name (id_of_string "x"), applistc vs (extended_rel_list 0 lams), mkRel 1)) lams in let typ_f = it_mkProd_wo_LetIn (mkProd (Anonymous, applistc vs (extended_rel_list 0 lams), lift 1 t)) lams in (* juste pour verification *) let _ = if not (Reductionops.is_conv_leq env Evd.empty (Typing.type_of env Evd.empty val_f) typ_f) then errorlabstrm "" (strbrk "Cannot be defined as coercion (maybe a bad number of arguments).") in let idf = match idf_opt with | Some idf -> idf | None -> let cl,_ = find_class_type Evd.empty t in id_of_string ("Id_"^(ident_key_of_class source)^"_"^ (ident_key_of_class cl)) in let constr_entry = (* Cast is necessary to express [val_f] is identity *) DefinitionEntry { const_entry_body = mkCast (val_f, DEFAULTcast, typ_f); const_entry_secctx = None; const_entry_type = Some typ_f; const_entry_opaque = false } in let kn = declare_constant idf (constr_entry,IsDefinition IdentityCoercion) in ConstRef kn let check_source = function | Some (CL_FUN|CL_SORT as s) -> raise (CoercionError (ForbiddenSourceClass s)) | _ -> () (* nom de la fonction coercion strength de f nom de la classe source (optionnel) sp de la classe source (dans le cas des structures) nom de la classe target (optionnel) booleen "coercion identite'?" lorque source est None alors target est None aussi. *) let add_new_coercion_core coef stre source target isid = check_source source; let t = Global.type_of_global coef in if coercion_exists coef then raise (CoercionError AlreadyExists); let tg,lp = prods_of t in let llp = List.length lp in if llp = 0 then raise (CoercionError NotAFunction); let (cls,lvs,ind) = try get_source lp source with Not_found -> raise (CoercionError (NoSource source)) in check_source (Some cls); if not (uniform_cond (llp-ind) lvs) then msg_warn (Pp.string_of_ppcmds (explain_coercion_error coef NotUniform)); let clt = try get_target tg ind with Not_found -> raise (CoercionError NoTarget) in check_target clt target; check_arity cls; check_arity clt; let stre' = get_strength stre coef cls clt in declare_coercion coef stre' ~isid ~src:cls ~target:clt ~params:(List.length lvs) let try_add_new_coercion_core ref b c d e = try add_new_coercion_core ref b c d e with CoercionError e -> errorlabstrm "try_add_new_coercion_core" (explain_coercion_error ref e ++ str ".") let try_add_new_coercion ref stre = try_add_new_coercion_core ref stre None None false let try_add_new_coercion_subclass cl stre = let coe_ref = build_id_coercion None cl in try_add_new_coercion_core coe_ref stre (Some cl) None true let try_add_new_coercion_with_target ref stre ~source ~target = try_add_new_coercion_core ref stre (Some source) (Some target) false let try_add_new_identity_coercion id stre ~source ~target = let ref = build_id_coercion (Some id) source in try_add_new_coercion_core ref stre (Some source) (Some target) true let try_add_new_coercion_with_source ref stre ~source = try_add_new_coercion_core ref stre (Some source) None false let add_coercion_hook stre ref = try_add_new_coercion ref stre; Flags.if_verbose message (string_of_qualid (shortest_qualid_of_global Idset.empty ref) ^ " is now a coercion") let add_subclass_hook stre ref = let cl = class_of_global ref in try_add_new_coercion_subclass cl stre coq-8.4pl4/toplevel/metasyntax.mli0000644000175000017500000000416712326224777016375 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit (** Adding a tactic notation in the environment *) val add_tactic_notation : int * grammar_tactic_prod_item_expr list * raw_tactic_expr -> unit (** Adding a (constr) notation in the environment*) val add_infix : locality_flag -> (lstring * syntax_modifier list) -> constr_expr -> scope_name option -> unit val add_notation : locality_flag -> constr_expr -> (lstring * syntax_modifier list) -> scope_name option -> unit (** Declaring delimiter keys and default scopes *) val add_delimiters : scope_name -> string -> unit val add_class_scope : scope_name -> Classops.cl_typ -> unit (** Add only the interpretation of a notation that already has pa/pp rules *) val add_notation_interpretation : (lstring * constr_expr * scope_name option) -> unit (** Add a notation interpretation for supporting the "where" clause *) val set_notation_for_interpretation : Constrintern.internalization_env -> (lstring * constr_expr * scope_name option) -> unit (** Add only the parsing/printing rule of a notation *) val add_syntax_extension : locality_flag -> (lstring * syntax_modifier list) -> unit (** Add a syntactic definition (as in "Notation f := ...") *) val add_syntactic_definition : identifier -> identifier list * constr_expr -> bool -> Flags.compat_version option -> unit (** Print the Camlp4 state of a grammar *) val print_grammar : string -> unit val check_infix_modifiers : syntax_modifier list -> unit val with_syntax_protection : ('a -> 'b) -> 'a -> 'b coq-8.4pl4/toplevel/classes.mli0000644000175000017500000000372712326224777015636 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr_expr list -> rel_context -> 'a val mismatched_props : env -> constr_expr list -> rel_context -> 'a (** Post-hoc class declaration. *) val declare_class : reference -> unit (** Instance declaration *) val existing_instance : bool -> reference -> unit val declare_instance_constant : typeclass -> int option -> (** priority *) bool -> (** globality *) Impargs.manual_explicitation list -> (** implicits *) ?hook:(Libnames.global_reference -> unit) -> identifier -> (** name *) Term.constr -> (** body *) Term.types -> (** type *) Names.identifier val new_instance : ?abstract:bool -> (** Not abstract by default. *) ?global:bool -> (** Not global by default. *) local_binder list -> typeclass_constraint -> constr_expr option -> ?generalize:bool -> ?tac:Proof_type.tactic -> ?hook:(Libnames.global_reference -> unit) -> int option -> identifier (** Setting opacity *) val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit (** For generation on names based on classes only *) val id_of_class : typeclass -> identifier (** Context command *) val context : local_binder list -> unit (** Forward ref for refine *) val refine_ref : (open_constr -> Proof_type.tactic) ref coq-8.4pl4/toplevel/ind_tables.mli0000644000175000017500000000363212326224777016300 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr array type individual_scheme_object_function = inductive -> constr (** Main functions to register a scheme builder *) val declare_mutual_scheme_object : string -> ?aux:string -> mutual_scheme_object_function -> mutual scheme_kind val declare_individual_scheme_object : string -> ?aux:string -> individual_scheme_object_function -> individual scheme_kind (* val declare_scheme : 'a scheme_kind -> (inductive * constant) array -> unit *) (** Force generation of a (mutually) scheme with possibly user-level names *) val define_individual_scheme : individual scheme_kind -> Declare.internal_flag (** internal *) -> identifier option -> inductive -> constant val define_mutual_scheme : mutual scheme_kind -> Declare.internal_flag (** internal *) -> (int * identifier) list -> mutual_inductive -> constant array (** Main function to retrieve a scheme in the cache or to generate it *) val find_scheme : 'a scheme_kind -> inductive -> constant val check_scheme : 'a scheme_kind -> inductive -> bool coq-8.4pl4/toplevel/ide_slave.mli0000644000175000017500000000163112326224777016124 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val loop : unit -> unit coq-8.4pl4/toplevel/command.mli0000644000175000017500000001161212326224777015607 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit) -> unit val get_declare_definition_hook : unit -> (definition_entry -> unit) val set_declare_assumptions_hook : (types -> unit) -> unit (** {6 Definitions/Let} *) val interp_definition : local_binder list -> red_expr option -> constr_expr -> constr_expr option -> definition_entry * Impargs.manual_implicits val declare_definition : identifier -> locality * definition_object_kind -> definition_entry -> Impargs.manual_implicits -> declaration_hook -> unit (** {6 Parameters/Assumptions} *) val interp_assumption : local_binder list -> constr_expr -> types * Impargs.manual_implicits val declare_assumption : coercion_flag -> assumption_kind -> types -> Impargs.manual_implicits -> bool (** implicit *) -> Entries.inline -> variable located -> unit val declare_assumptions : variable located list -> coercion_flag -> assumption_kind -> types -> Impargs.manual_implicits -> bool -> Entries.inline -> unit (** {6 Inductive and coinductive types} *) (** Extracting the semantical components out of the raw syntax of mutual inductive declarations *) type structured_one_inductive_expr = { ind_name : identifier; ind_arity : constr_expr; ind_lc : (identifier * constr_expr) list } type structured_inductive_expr = local_binder list * structured_one_inductive_expr list val extract_mutual_inductive_declaration_components : (one_inductive_expr * decl_notation list) list -> structured_inductive_expr * (*coercions:*) qualid list * decl_notation list (** Typing mutual inductive definitions *) type one_inductive_impls = Impargs.manual_implicits (** for inds *)* Impargs.manual_implicits list (** for constrs *) val interp_mutual_inductive : structured_inductive_expr -> decl_notation list -> bool -> mutual_inductive_entry * one_inductive_impls list (** Registering a mutual inductive definition together with its associated schemes *) val declare_mutual_inductive_with_eliminations : Declare.internal_flag -> mutual_inductive_entry -> one_inductive_impls list -> mutual_inductive (** Entry points for the vernacular commands Inductive and CoInductive *) val do_mutual_inductive : (one_inductive_expr * decl_notation list) list -> bool -> unit (** {6 Fixpoints and cofixpoints} *) type structured_fixpoint_expr = { fix_name : identifier; fix_annot : identifier located option; fix_binders : local_binder list; fix_body : constr_expr option; fix_type : constr_expr } (** Extracting the semantical components out of the raw syntax of (co)fixpoints declarations *) val extract_fixpoint_components : bool -> (fixpoint_expr * decl_notation list) list -> structured_fixpoint_expr list * decl_notation list val extract_cofixpoint_components : (cofixpoint_expr * decl_notation list) list -> structured_fixpoint_expr list * decl_notation list (** Typing global fixpoints and cofixpoint_expr *) type recursive_preentry = identifier list * constr option list * types list val interp_fixpoint : structured_fixpoint_expr list -> decl_notation list -> recursive_preentry * (name list * Impargs.manual_implicits * int option) list val interp_cofixpoint : structured_fixpoint_expr list -> decl_notation list -> recursive_preentry * (name list * Impargs.manual_implicits * int option) list (** Registering fixpoints and cofixpoints in the environment *) val declare_fixpoint : recursive_preentry * (name list * Impargs.manual_implicits * int option) list -> lemma_possible_guards -> decl_notation list -> unit val declare_cofixpoint : recursive_preentry * (name list * Impargs.manual_implicits * int option) list -> decl_notation list -> unit (** Entry points for the vernacular commands Fixpoint and CoFixpoint *) val do_fixpoint : (fixpoint_expr * decl_notation list) list -> unit val do_cofixpoint : (cofixpoint_expr * decl_notation list) list -> unit (** Utils *) val check_mutuality : Environ.env -> bool -> (identifier * types) list -> unit val declare_fix : definition_object_kind -> identifier -> constr -> types -> Impargs.manual_implicits -> global_reference coq-8.4pl4/toplevel/toplevel.mllib0000644000175000017500000000036012326224777016337 0ustar stephstephHimsg Cerrors Class Vernacexpr Metasyntax Auto_ind_decl Libtypes Search Autoinstance Lemmas Indschemes Command Classes Record Ppvernac Backtrack Vernacinterp Mltop Vernacentries Whelp Vernac Ide_intf Ide_slave Toplevel Usage Coqinit Coqtop coq-8.4pl4/toplevel/vernac.mli0000644000175000017500000000346612326224777015457 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Util.loc * Vernacexpr.vernac_expr (** Reads and executes vernac commands from a stream. The boolean [just_parsing] disables interpretation of commands. *) exception DuringCommandInterp of Util.loc * exn exception End_of_input val just_parsing : bool ref (** [eval_expr] executes one vernacular command. By default the command is considered as non-state-preserving, in which case we add it to the Backtrack stack (triggering a save of a frozen state and the generation of a new state label). An example of state-preserving command is one coming from the query panel of Coqide. *) val eval_expr : ?preserving:bool -> Util.loc * Vernacexpr.vernac_expr -> unit val raw_do_vernac : Pcoq.Gram.parsable -> unit (** Set XML hooks *) val set_xml_start_library : (unit -> unit) -> unit val set_xml_end_library : (unit -> unit) -> unit (** Load a vernac file, verbosely or not. Errors are annotated with file and location *) val load_vernac : bool -> string -> unit (** Compile a vernac file, verbosely or not (f is assumed without .v suffix) *) val compile : bool -> string -> unit coq-8.4pl4/toplevel/coqtop.mli0000644000175000017500000000160112326224777015473 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val start : unit -> unit coq-8.4pl4/toplevel/vernacexpr.ml0000644000175000017500000004205612326224777016203 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Current, it contains the name of the coq version which this notation is trying to be compatible with *) type option_value = Goptionstyp.option_value = | BoolValue of bool | IntValue of int option | StringValue of string type option_ref_value = | StringRefValue of string | QualidRefValue of reference type sort_expr = Glob_term.glob_sort type definition_expr = | ProveBody of local_binder list * constr_expr | DefineBody of local_binder list * raw_red_expr option * constr_expr * constr_expr option type fixpoint_expr = identifier located * (identifier located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr option type cofixpoint_expr = identifier located * local_binder list * constr_expr * constr_expr option type local_decl_expr = | AssumExpr of lname * constr_expr | DefExpr of lname * constr_expr * constr_expr option type inductive_kind = Inductive_kw | CoInductive | Record | Structure | Class of bool (* true = definitional, false = inductive *) type decl_notation = lstring * constr_expr * scope_name option type simple_binder = lident list * constr_expr type class_binder = lident * constr_expr list type 'a with_coercion = coercion_flag * 'a type 'a with_instance = instance_flag * 'a type 'a with_notation = 'a * decl_notation list type 'a with_priority = 'a * int option type constructor_expr = (lident * constr_expr) with_coercion type constructor_list_or_record_decl_expr = | Constructors of constructor_expr list | RecordDecl of lident option * local_decl_expr with_instance with_priority with_notation list type inductive_expr = lident with_coercion * local_binder list * constr_expr option * inductive_kind * constructor_list_or_record_decl_expr type one_inductive_expr = lident * local_binder list * constr_expr option * constructor_expr list type module_ast_inl = module_ast annotated type module_binder = bool option * lident list * module_ast_inl type grammar_tactic_prod_item_expr = | TacTerm of string | TacNonTerm of loc * string * (Names.identifier * string) option type syntax_modifier = | SetItemLevel of string list * production_level | SetLevel of int | SetAssoc of gram_assoc | SetEntryType of string * simple_constr_prod_entry_key | SetOnlyParsing of Flags.compat_version | SetFormat of string located type proof_end = | Admitted | Proved of opacity_flag * (lident * theorem_kind option) option type scheme = | InductionScheme of bool * reference or_by_notation * sort_expr | CaseScheme of bool * reference or_by_notation * sort_expr | EqualityScheme of reference or_by_notation type inline = int option (* inlining level, none for no inlining *) type bullet = | Dash | Star | Plus type vernac_expr = (* Control *) | VernacList of located_vernac_expr list | VernacLoad of verbose_flag * string | VernacTime of vernac_expr | VernacTimeout of int * vernac_expr | VernacFail of vernac_expr (* Syntax *) | VernacTacticNotation of int * grammar_tactic_prod_item_expr list * raw_tactic_expr | VernacSyntaxExtension of locality_flag * (lstring * syntax_modifier list) | VernacOpenCloseScope of (locality_flag * bool * scope_name) | VernacDelimiters of scope_name * string | VernacBindScope of scope_name * class_rawexpr list | VernacInfix of locality_flag * (lstring * syntax_modifier list) * constr_expr * scope_name option | VernacNotation of locality_flag * constr_expr * (lstring * syntax_modifier list) * scope_name option (* Gallina *) | VernacDefinition of definition_kind * lident * definition_expr * declaration_hook | VernacStartTheoremProof of theorem_kind * (lident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option)) list * bool * declaration_hook | VernacEndProof of proof_end | VernacExactProof of constr_expr | VernacAssumption of assumption_kind * inline * simple_binder with_coercion list | VernacInductive of inductive_flag * infer_flag * (inductive_expr * decl_notation list) list | VernacFixpoint of (fixpoint_expr * decl_notation list) list | VernacCoFixpoint of (cofixpoint_expr * decl_notation list) list | VernacScheme of (lident option * scheme) list | VernacCombinedScheme of lident * lident list (* Gallina extensions *) | VernacBeginSection of lident | VernacEndSegment of lident | VernacRequire of export_flag option * specif_flag option * lreference list | VernacImport of export_flag * lreference list | VernacCanonical of reference or_by_notation | VernacCoercion of locality * reference or_by_notation * class_rawexpr * class_rawexpr | VernacIdentityCoercion of locality * lident * class_rawexpr * class_rawexpr (* Type classes *) | VernacInstance of bool * (* abstract instance *) bool * (* global *) local_binder list * (* super *) typeclass_constraint * (* instance name, class name, params *) constr_expr option * (* props *) int option (* Priority *) | VernacContext of local_binder list | VernacDeclareInstances of bool (* global *) * reference list (* instance names *) | VernacDeclareClass of reference (* inductive or definition name *) (* Modules and Module Types *) | VernacDeclareModule of bool option * lident * module_binder list * module_ast_inl | VernacDefineModule of bool option * lident * module_binder list * module_ast_inl module_signature * module_ast_inl list | VernacDeclareModuleType of lident * module_binder list * module_ast_inl list * module_ast_inl list | VernacInclude of module_ast_inl list (* Solving *) | VernacSolve of int * raw_tactic_expr * bool | VernacSolveExistential of int * constr_expr (* Auxiliary file and library management *) | VernacRequireFrom of export_flag option * specif_flag option * string | VernacAddLoadPath of rec_flag * string * dir_path option | VernacRemoveLoadPath of string | VernacAddMLPath of rec_flag * string | VernacDeclareMLModule of locality_flag * string list | VernacChdir of string option (* State management *) | VernacWriteState of string | VernacRestoreState of string (* Resetting *) | VernacResetName of lident | VernacResetInitial | VernacBack of int | VernacBackTo of int (* Commands *) | VernacDeclareTacticDefinition of (locality_flag * rec_flag * (reference * bool * raw_tactic_expr) list) | VernacCreateHintDb of locality_flag * string * bool | VernacRemoveHints of locality_flag * string list * reference list | VernacHints of locality_flag * string list * hints_expr | VernacSyntacticDefinition of identifier located * (identifier list * constr_expr) * locality_flag * onlyparsing_flag | VernacDeclareImplicits of locality_flag * reference or_by_notation * (explicitation * bool * bool) list list | VernacArguments of locality_flag * reference or_by_notation * ((name * bool * (loc * string) option * bool * bool) list) list * int * [ `SimplDontExposeCase | `SimplNeverUnfold | `Rename | `ExtraScopes | `ClearImplicits | `ClearScopes | `DefaultImplicits ] list | VernacArgumentsScope of locality_flag * reference or_by_notation * scope_name option list | VernacReserve of simple_binder list | VernacGeneralizable of locality_flag * (lident list) option | VernacSetOpacity of locality_flag * (Conv_oracle.level * reference or_by_notation list) list | VernacUnsetOption of full_locality_flag * Goptions.option_name | VernacSetOption of full_locality_flag * Goptions.option_name * option_value | VernacAddOption of Goptions.option_name * option_ref_value list | VernacRemoveOption of Goptions.option_name * option_ref_value list | VernacMemOption of Goptions.option_name * option_ref_value list | VernacPrintOption of Goptions.option_name | VernacCheckMayEval of raw_red_expr option * int option * constr_expr | VernacGlobalCheck of constr_expr | VernacDeclareReduction of locality_flag * string * raw_red_expr | VernacPrint of printable | VernacSearch of searchable * search_restriction | VernacLocate of locatable | VernacComments of comment list | VernacNop (* Proof management *) | VernacGoal of constr_expr | VernacAbort of lident option | VernacAbortAll | VernacRestart | VernacUndo of int | VernacUndoTo of int | VernacBacktrack of int*int*int | VernacFocus of int option | VernacUnfocus | VernacUnfocused | VernacBullet of bullet | VernacSubproof of int option | VernacEndSubproof | VernacShow of showable | VernacCheckGuard | VernacProof of raw_tactic_expr option * lident list option | VernacProofMode of string (* Toplevel control *) | VernacToplevelControl of exn (* For extension *) | VernacExtend of string * raw_generic_argument list and located_vernac_expr = loc * vernac_expr (** Categories of [vernac_expr] *) let rec strip_vernac = function | VernacTime c | VernacTimeout(_,c) | VernacFail c -> strip_vernac c | c -> c (* TODO: what about VernacList ? *) let rec is_navigation_vernac = function | VernacResetInitial | VernacResetName _ | VernacBacktrack _ | VernacBackTo _ | VernacBack _ -> true | VernacTime c -> is_navigation_vernac c (* Time Back* is harmless *) | c -> is_deep_navigation_vernac c and is_deep_navigation_vernac = function | VernacTimeout (_,c) | VernacFail c -> is_navigation_vernac c | VernacList l -> List.exists (fun (_,c) -> is_navigation_vernac c) l | _ -> false (* NB: Reset is now allowed again as asked by A. Chlipala *) let is_reset = function | VernacResetInitial | VernacResetName _ -> true | _ -> false (* Locating errors raised just after the dot is parsed but before the interpretation phase *) let syntax_checking_error loc s = user_err_loc (loc,"",Pp.str s) (**********************************************************************) (* Managing locality *) let locality_flag = ref None let local_of_bool = function true -> Local | false -> Global let check_locality () = match !locality_flag with | Some (loc,true) -> syntax_checking_error loc "This command does not support the \"Local\" prefix."; | Some (loc,false) -> syntax_checking_error loc "This command does not support the \"Global\" prefix." | None -> () (** Extracting the locality flag *) (* Commands which supported an inlined Local flag *) let enforce_locality_full local = let local = match !locality_flag with | Some (_,false) when local -> error "Cannot be simultaneously Local and Global." | Some (_,true) when local -> error "Use only prefix \"Local\"." | None -> if local then begin Flags.if_warn Pp.msg_warning (Pp.str"Obsolete syntax: use \"Local\" as a prefix."); Some true end else None | Some (_,b) -> Some b in locality_flag := None; local (* Commands which did not supported an inlined Local flag (synonym of [enforce_locality_full false]) *) let use_locality_full () = let r = Option.map snd !locality_flag in locality_flag := None; r (** Positioning locality for commands supporting discharging and export outside of modules *) (* For commands whose default is to discharge and export: Global is the default and is neutral; Local in a section deactivates discharge, Local not in a section deactivates export *) let make_locality = function Some true -> true | _ -> false let use_locality () = make_locality (use_locality_full ()) let use_locality_exp () = local_of_bool (use_locality ()) let enforce_locality local = make_locality (enforce_locality_full local) let enforce_locality_exp local = local_of_bool (enforce_locality local) (* For commands whose default is not to discharge and not to export: Global forces discharge and export; Local is the default and is neutral *) let use_non_locality () = match use_locality_full () with Some false -> false | _ -> true (* For commands whose default is to not discharge but to export: Global in sections forces discharge, Global not in section is the default; Local in sections is the default, Local not in section forces non-export *) let make_section_locality = function Some b -> b | None -> Lib.sections_are_opened () let use_section_locality () = make_section_locality (use_locality_full ()) let enforce_section_locality local = make_section_locality (enforce_locality_full local) (** Positioning locality for commands supporting export but not discharge *) (* For commands whose default is to export (if not in section): Global in sections is forbidden, Global not in section is neutral; Local in sections is the default, Local not in section forces non-export *) let make_module_locality = function | Some false -> if Lib.sections_are_opened () then error "This command does not support the Global option in sections."; false | Some true -> true | None -> false let use_module_locality () = make_module_locality (use_locality_full ()) let enforce_module_locality local = make_module_locality (enforce_locality_full local) (**********************************************************************) coq-8.4pl4/toplevel/mltop.mli0000644000175000017500000000454512326224777015333 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit; use_file : string -> unit; add_dir : string -> unit; ml_loop : unit -> unit } (** Sets and initializes a toplevel (if any) *) val set_top : toplevel -> unit (** Are we in a native version of Coq? *) val is_native : bool (** Removes the toplevel (if any) *) val remove : unit -> unit (** Tests if an Ocaml toplevel runs under Coq *) val is_ocaml_top : unit -> bool (** Tests if we can load ML files *) val has_dynlink : bool (** Starts the Ocaml toplevel loop *) val ocaml_toploop : unit -> unit (** Dynamic loading of .cmo *) val dir_ml_load : string -> unit (** Dynamic interpretation of .ml *) val dir_ml_use : string -> unit (** Adds a path to the ML paths *) val add_ml_dir : string -> unit val add_rec_ml_dir : string -> unit (** Adds a path to the Coq and ML paths *) val add_path : unix_path:string -> coq_root:Names.dir_path -> unit val add_rec_path : unix_path:string -> coq_root:Names.dir_path -> unit (** List of modules linked to the toplevel *) val add_known_module : string -> unit val module_is_known : string -> bool val load_ml_object : string -> string -> unit (** Declare a plugin and its initialization function. A plugin is just an ML module with an initialization function. Adding a known plugin implies adding it as a known ML module. The initialization function is granted to be called after Coq is fully bootstrapped, even if the plugin is statically linked with the toplevel *) val add_known_plugin : (unit -> unit) -> string -> unit (** Calls all initialization functions in a non-specified order *) val init_known_plugins : unit -> unit val declare_ml_modules : Vernacexpr.locality_flag -> string list -> unit val print_ml_path : unit -> unit val print_ml_modules : unit -> unit coq-8.4pl4/toplevel/record.ml0000644000175000017500000004216712326224777015307 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let impl, t' = interp_evars evars env impls Pretyping.IsType t in let b' = Option.map (fun x -> snd (interp_evars evars env impls (Pretyping.OfType (Some t')) x)) b in let impls = match i with | Anonymous -> impls | Name id -> Idmap.add id (compute_internalization_data env Constrintern.Method t' impl) impls in let d = (i,b',t') in List.iter (Metasyntax.set_notation_for_interpretation impls) no; (push_rel d env, impl :: uimpls, d::params, impls)) (env, [], [], impls_env) nots l let binder_of_decl = function | Vernacexpr.AssumExpr(n,t) -> (n,None,t) | Vernacexpr.DefExpr(n,c,t) -> (n,Some c, match t with Some c -> c | None -> CHole (fst n, None)) let binders_of_decls = List.map binder_of_decl let typecheck_params_and_fields id t ps nots fs = let env0 = Global.env () in let evars = ref Evd.empty in let _ = let error bk (loc, name) = match bk with | Default _ -> if name = Anonymous then user_err_loc (loc, "record", str "Record parameters must be named") | _ -> () in List.iter (function LocalRawDef (b, _) -> error default_binder_kind b | LocalRawAssum (ls, bk, ce) -> List.iter (error bk) ls) ps in let impls_env, ((env1,newps), imps) = interp_context_evars evars env0 ps in let fullarity = it_mkProd_or_LetIn (Option.cata (fun x -> x) (Termops.new_Type ()) t) newps in let env_ar = push_rel_context newps (push_rel (Name id,None,fullarity) env0) in let env2,impls,newfs,data = interp_fields_evars evars env_ar impls_env nots (binders_of_decls fs) in let evars = Evarconv.consider_remaining_unif_problems env_ar !evars in let evars = Typeclasses.resolve_typeclasses env_ar evars in let sigma = evars in let newps = Evarutil.nf_rel_context_evar sigma newps in let newfs = Evarutil.nf_rel_context_evar sigma newfs in let ce t = Evarutil.check_evars env0 Evd.empty evars t in List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newps); List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newfs); imps, newps, impls, newfs let degenerate_decl (na,b,t) = let id = match na with | Name id -> id | Anonymous -> anomaly "Unnamed record variable" in match b with | None -> (id, Entries.LocalAssum t) | Some b -> (id, Entries.LocalDef b) type record_error = | MissingProj of identifier * identifier list | BadTypedProj of identifier * env * Type_errors.type_error let warning_or_error coe indsp err = let st = match err with | MissingProj (fi,projs) -> let s,have = if List.length projs > 1 then "s","were" else "","was" in (str(string_of_id fi) ++ strbrk" cannot be defined because the projection" ++ str s ++ spc () ++ prlist_with_sep pr_comma pr_id projs ++ spc () ++ str have ++ strbrk " not defined.") | BadTypedProj (fi,ctx,te) -> match te with | ElimArity (_,_,_,_,Some (_,_,NonInformativeToInformative)) -> (pr_id fi ++ strbrk" cannot be defined because it is informative and " ++ Printer.pr_inductive (Global.env()) indsp ++ strbrk " is not.") | ElimArity (_,_,_,_,Some (_,_,StrongEliminationOnNonSmallType)) -> (pr_id fi ++ strbrk" cannot be defined because it is large and " ++ Printer.pr_inductive (Global.env()) indsp ++ strbrk " is not.") | _ -> (pr_id fi ++ strbrk " cannot be defined because it is not typable.") in if coe then errorlabstrm "structure" st; Flags.if_verbose ppnl (hov 0 (str"Warning: " ++ st)) type field_status = | NoProjection of name | Projection of constr exception NotDefinable of record_error (* This replaces previous projection bodies in current projection *) (* Undefined projs are collected and, at least one undefined proj occurs *) (* in the body of current projection then the latter can not be defined *) (* [c] is defined in ctxt [[params;fields]] and [l] is an instance of *) (* [[fields]] defined in ctxt [[params;x:ind]] *) let subst_projection fid l c = let lv = List.length l in let bad_projs = ref [] in let rec substrec depth c = match kind_of_term c with | Rel k -> (* We are in context [[params;fields;x:ind;...depth...]] *) if k <= depth+1 then c else if k-depth-1 <= lv then match List.nth l (k-depth-2) with | Projection t -> lift depth t | NoProjection (Name id) -> bad_projs := id :: !bad_projs; mkRel k | NoProjection Anonymous -> errorlabstrm "" (str "Field " ++ pr_id fid ++ str " depends on the " ++ str (ordinal (k-depth-1)) ++ str " field which has no name.") else mkRel (k-lv) | _ -> map_constr_with_binders succ substrec depth c in let c' = lift 1 c in (* to get [c] defined in ctxt [[params;fields;x:ind]] *) let c'' = substrec 0 c' in if !bad_projs <> [] then raise (NotDefinable (MissingProj (fid,List.rev !bad_projs))); c'' let instantiate_possibly_recursive_type indsp paramdecls fields = let subst = list_map_i (fun i _ -> mkRel i) 1 paramdecls in Termops.substl_rel_context (subst@[mkInd indsp]) fields (* We build projections *) let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls fields = let env = Global.env() in let (mib,mip) = Global.lookup_inductive indsp in let paramdecls = mib.mind_params_ctxt in let r = mkInd indsp in let rp = applist (r, Termops.extended_rel_list 0 paramdecls) in let paramargs = Termops.extended_rel_list 1 paramdecls in (*def in [[params;x:rp]]*) let x = match name with Some n -> Name n | None -> Namegen.named_hd (Global.env()) r Anonymous in let fields = instantiate_possibly_recursive_type indsp paramdecls fields in let lifted_fields = Termops.lift_rel_context 1 fields in let (_,kinds,sp_projs,_) = list_fold_left3 (fun (nfi,kinds,sp_projs,subst) coe (fi,optci,ti) impls -> let (sp_projs,subst) = match fi with | Anonymous -> (None::sp_projs,NoProjection fi::subst) | Name fid -> try let ccl = subst_projection fid subst ti in let body = match optci with | Some ci -> subst_projection fid subst ci | None -> (* [ccl] is defined in context [params;x:rp] *) (* [ccl'] is defined in context [params;x:rp;x:rp] *) let ccl' = liftn 1 2 ccl in let p = mkLambda (x, lift 1 rp, ccl') in let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in let ci = Inductiveops.make_case_info env indsp LetStyle in mkCase (ci, p, mkRel 1, [|branch|]) in let proj = it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in let kn = try let cie = { const_entry_body = proj; const_entry_secctx = None; const_entry_type = Some projtyp; const_entry_opaque = false } in let k = (DefinitionEntry cie,IsDefinition kind) in let kn = declare_constant ~internal:KernelSilent fid k in Flags.if_verbose message (string_of_id fid ^" is defined"); kn with Type_errors.TypeError (ctx,te) -> raise (NotDefinable (BadTypedProj (fid,ctx,te))) in let refi = ConstRef kn in let constr_fi = mkConst kn in Impargs.maybe_declare_manual_implicits false refi impls; if coe then begin let cl = Class.class_of_global (IndRef indsp) in Class.try_add_new_coercion_with_source refi Global ~source:cl end; let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in let constr_fip = applist (constr_fi,proj_args) in (Some kn::sp_projs, Projection constr_fip::subst) with NotDefinable why -> warning_or_error coe indsp why; (None::sp_projs,NoProjection fi::subst) in (nfi-1,(fi, optci=None)::kinds,sp_projs,subst)) (List.length fields,[],[],[]) coers (List.rev fields) (List.rev fieldimpls) in (kinds,sp_projs) let structure_signature ctx = let rec deps_to_evar evm l = match l with [] -> Evd.empty | [(_,_,typ)] -> Evd.add evm (Evarutil.new_untyped_evar()) (Evd.make_evar Environ.empty_named_context_val typ) | (_,_,typ)::tl -> let ev = Evarutil.new_untyped_evar() in let evm = Evd.add evm ev (Evd.make_evar Environ.empty_named_context_val typ) in let new_tl = Util.list_map_i (fun pos (n,c,t) -> n,c, Termops.replace_term (mkRel pos) (mkEvar(ev,[||])) t) 1 tl in deps_to_evar evm new_tl in deps_to_evar Evd.empty (List.rev ctx) open Typeclasses let declare_structure finite infer id idbuild paramimpls params arity fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers sign = let nparams = List.length params and nfields = List.length fields in let args = Termops.extended_rel_list nfields params in let ind = applist (mkRel (1+nparams+nfields), args) in let type_constructor = it_mkProd_or_LetIn ind fields in let mie_ind = { mind_entry_typename = id; mind_entry_arity = arity; mind_entry_consnames = [idbuild]; mind_entry_lc = [type_constructor] } in (* spiwack: raises an error if the structure is supposed to be non-recursive, but isn't *) (* there is probably a way to push this to "declare_mutual" *) begin match finite with | BiFinite -> if Termops.dependent (mkRel (nparams+1)) (it_mkProd_or_LetIn mkProp fields) then error "Records declared with the keyword Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command." | _ -> () end; let mie = { mind_entry_params = List.map degenerate_decl params; mind_entry_record = true; mind_entry_finite = recursivity_flag_of_kind finite; mind_entry_inds = [mie_ind] } in let kn = Command.declare_mutual_inductive_with_eliminations KernelVerbose mie [(paramimpls,[])] in let rsp = (kn,0) in (* This is ind path of idstruc *) let cstr = (rsp,1) in let kinds,sp_projs = declare_projections rsp ~kind ?name coers fieldimpls fields in let build = ConstructRef cstr in if is_coe then Class.try_add_new_coercion build Global; Recordops.declare_structure(rsp,cstr,List.rev kinds,List.rev sp_projs); if infer then Evd.fold (fun ev evi () -> Recordops.declare_method (ConstructRef cstr) ev sign) sign (); rsp let implicits_of_context ctx = list_map_i (fun i name -> let explname = match name with | Name n -> Some n | Anonymous -> None in ExplByPos (i, explname), (true, true, true)) 1 (List.rev (Anonymous :: (List.map pi1 ctx))) let declare_instance_cst glob con pri = let instance = Typeops.type_of_constant (Global.env ()) con in let _, r = decompose_prod_assum instance in match class_of_constr r with | Some (_, (tc, _)) -> add_instance (new_instance tc pri glob (ConstRef con)) | None -> errorlabstrm "" (Pp.strbrk "Constant does not build instances of a declared type class.") let declare_class finite def infer id idbuild paramimpls params arity fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers priorities sign = let fieldimpls = (* Make the class and all params implicits in the projections *) let ctx_impls = implicits_of_context params in let len = succ (List.length params) in List.map (fun x -> ctx_impls @ Impargs.lift_implicits len x) fieldimpls in let impl, projs = match fields with | [(Name proj_name, _, field)] when def -> let class_body = it_mkLambda_or_LetIn field params in let class_type = Option.map (fun ar -> it_mkProd_or_LetIn ar params) arity in let class_entry = { const_entry_body = class_body; const_entry_secctx = None; const_entry_type = class_type; const_entry_opaque = false } in let cst = Declare.declare_constant (snd id) (DefinitionEntry class_entry, IsDefinition Definition) in let inst_type = appvectc (mkConst cst) (Termops.rel_vect 0 (List.length params)) in let proj_type = it_mkProd_or_LetIn (mkProd(Name (snd id), inst_type, lift 1 field)) params in let proj_body = it_mkLambda_or_LetIn (mkLambda (Name (snd id), inst_type, mkRel 1)) params in let proj_entry = { const_entry_body = proj_body; const_entry_secctx = None; const_entry_type = Some proj_type; const_entry_opaque = false } in let proj_cst = Declare.declare_constant proj_name (DefinitionEntry proj_entry, IsDefinition Definition) in let cref = ConstRef cst in Impargs.declare_manual_implicits false cref [paramimpls]; Impargs.declare_manual_implicits false (ConstRef proj_cst) [List.hd fieldimpls]; Classes.set_typeclass_transparency (EvalConstRef cst) false false; if infer then Evd.fold (fun ev evi _ -> Recordops.declare_method (ConstRef cst) ev sign) sign (); let sub = match List.hd coers with Some b -> Some ((if b then Backward else Forward), List.hd priorities) | None -> None in cref, [Name proj_name, sub, Some proj_cst] | _ -> let idarg = Namegen.next_ident_away (snd id) (Termops.ids_of_context (Global.env())) in let ind = declare_structure BiFinite infer (snd id) idbuild paramimpls params (Option.default (Termops.new_Type ()) arity) fieldimpls fields ~kind:Method ~name:idarg false (List.map (fun _ -> false) fields) sign in let coers = List.map2 (fun coe pri -> Option.map (fun b -> if b then Backward, pri else Forward, pri) coe) coers priorities in IndRef ind, (list_map3 (fun (id, _, _) b y -> (id, b, y)) (List.rev fields) coers (Recordops.lookup_projections ind)) in let ctx_context = List.map (fun (na, b, t) -> match Typeclasses.class_of_constr t with | Some (_, (cl, _)) -> Some (cl.cl_impl, true) (*List.exists (fun (_, n) -> n = na) supnames)*) | None -> None) params, params in let k = { cl_impl = impl; cl_context = ctx_context; cl_props = fields; cl_projs = projs } in (* list_iter3 (fun p sub pri -> *) (* if sub then match p with (_, _, Some p) -> declare_instance_cst true p pri | _ -> ()) *) (* k.cl_projs coers priorities; *) add_class k; impl let interp_and_check_sort sort = Option.map (fun sort -> let env = Global.env() and sigma = Evd.empty in let s = interp_constr sigma env sort in if isSort (Reductionops.whd_betadeltaiota env sigma s) then s else user_err_loc (constr_loc sort,"", str"Sort expected.")) sort open Vernacexpr open Autoinstance (* [fs] corresponds to fields and [ps] to parameters; [coers] is a list telling if the corresponding fields must me declared as coercions or subinstances *) let definition_structure (kind,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) = let cfs,notations = List.split cfs in let cfs,priorities = List.split cfs in let coers,fs = List.split cfs in let extract_name acc = function Vernacexpr.AssumExpr((_,Name id),_) -> id::acc | Vernacexpr.DefExpr ((_,Name id),_,_) -> id::acc | _ -> acc in let allnames = idstruc::(List.fold_left extract_name [] fs) in if not (list_distinct allnames) then error "Two objects have the same name"; if not (kind = Class false) && List.exists ((<>) None) priorities then error "Priorities only allowed for type class substructures"; (* Now, younger decl in params and fields is on top *) let sc = interp_and_check_sort s in let implpars, params, implfs, fields = States.with_state_protection (fun () -> typecheck_params_and_fields idstruc sc ps notations fs) () in let sign = structure_signature (fields@params) in match kind with | Class def -> let gr = declare_class finite def infer (loc,idstruc) idbuild implpars params sc implfs fields is_coe coers priorities sign in if infer then search_record declare_class_instance gr sign; gr | _ -> let arity = Option.default (Termops.new_Type ()) sc in let implfs = List.map (fun impls -> implpars @ Impargs.lift_implicits (succ (List.length params)) impls) implfs in let ind = declare_structure finite infer idstruc idbuild implpars params arity implfs fields is_coe (List.map (fun coe -> coe <> None) coers) sign in if infer then search_record declare_record_instance (ConstructRef (ind,1)) sign; IndRef ind coq-8.4pl4/toplevel/coqinit.ml0000644000175000017500000001277012326224777015474 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* () (* Flags.if_verbose mSGNL (str ("No coqrc or coqrc."^Coq_config.version^ " found. Skipping rcfile loading.")) *) with reraise -> (msgnl (str"Load of rcfile failed."); raise reraise) else Flags.if_verbose msgnl (str"Skipping rcfile loading.") (* Puts dir in the path of ML and in the LoadPath *) let coq_add_path unix_path s = Mltop.add_path ~unix_path ~coq_root:(Names.make_dirpath [Nameops.coq_root;Names.id_of_string s]) let coq_add_rec_path unix_path = Mltop.add_rec_path ~unix_path ~coq_root:(Names.make_dirpath [Nameops.coq_root]) (* By the option -include -I or -R of the command line *) let includes = ref [] let push_include (s, alias) = includes := (s,alias,false) :: !includes let push_rec_include (s, alias) = includes := (s,alias,true) :: !includes (* The list of all theories in the standard library /!\ order does matter *) let theories_dirs_map = [ "theories/Unicode", "Unicode" ; "theories/Classes", "Classes" ; "theories/Program", "Program" ; "theories/MSets", "MSets" ; "theories/FSets", "FSets" ; "theories/Reals", "Reals" ; "theories/Strings", "Strings" ; "theories/Sorting", "Sorting" ; "theories/Setoids", "Setoids" ; "theories/Sets", "Sets" ; "theories/Structures", "Structures" ; "theories/Lists", "Lists" ; "theories/Vectors", "Vectors" ; "theories/Wellfounded", "Wellfounded" ; "theories/Relations", "Relations" ; "theories/Numbers", "Numbers" ; "theories/QArith", "QArith" ; "theories/PArith", "PArith" ; "theories/NArith", "NArith" ; "theories/ZArith", "ZArith" ; "theories/Arith", "Arith" ; "theories/Bool", "Bool" ; "theories/Logic", "Logic" ; "theories/Init", "Init" ] (* Initializes the LoadPath *) let init_load_path () = let coqlib = Envars.coqlib () in let user_contrib = coqlib/"user-contrib" in let xdg_dirs = Envars.xdg_dirs in let coqpath = Envars.coqpath in let dirs = ["states";"plugins"] in (* NOTE: These directories are searched from last to first *) (* first, developer specific directory to open *) if Coq_config.local then coq_add_path (coqlib/"dev") "dev"; (* then standard library *) List.iter (fun (s,alias) -> Mltop.add_rec_path ~unix_path:(coqlib/s) ~coq_root:(Names.make_dirpath [Names.id_of_string alias; Nameops.coq_root])) theories_dirs_map; (* then states and plugins *) List.iter (fun s -> coq_add_rec_path (coqlib/s)) dirs; (* then user-contrib *) if Sys.file_exists user_contrib then Mltop.add_rec_path ~unix_path:user_contrib ~coq_root:Nameops.default_root_prefix; (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME *) List.iter (fun s -> Mltop.add_rec_path ~unix_path:s ~coq_root:Nameops.default_root_prefix) xdg_dirs; (* then directories in COQPATH *) List.iter (fun s -> Mltop.add_rec_path ~unix_path:s ~coq_root:Nameops.default_root_prefix) coqpath; (* then current directory *) Mltop.add_path ~unix_path:"." ~coq_root:Nameops.default_root_prefix; (* additional loadpath, given with -I -include -R options *) List.iter (fun (unix_path, coq_root, reci) -> if reci then Mltop.add_rec_path ~unix_path ~coq_root else Mltop.add_path ~unix_path ~coq_root) (List.rev !includes) let init_library_roots () = includes := [] (* Initialises the Ocaml toplevel before launching it, so that it can find the "include" file in the *source* directory *) let init_ocaml_path () = let add_subdir dl = Mltop.add_ml_dir (List.fold_left (/) Envars.coqroot dl) in Mltop.add_ml_dir (Envars.coqlib ()); List.iter add_subdir [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ]; [ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ]; [ "tactics" ]; [ "toplevel" ]; [ "translate" ]; [ "ide" ] ] let get_compat_version = function | "8.3" -> Flags.V8_3 | "8.2" -> Flags.V8_2 | ("8.1" | "8.0") as s -> msg_warn ("Compatibility with version "^s^" not supported."); Flags.V8_2 | s -> Util.error ("Unknown compatibility version \""^s^"\".") coq-8.4pl4/toplevel/himsg.mli0000644000175000017500000000310412326224777015275 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Evd.evar_map -> type_error -> std_ppcmds val explain_pretype_error : env -> Evd.evar_map -> pretype_error -> std_ppcmds val explain_inductive_error : inductive_error -> std_ppcmds val explain_typeclass_error : env -> typeclass_error -> Pp.std_ppcmds val explain_recursion_scheme_error : recursion_scheme_error -> std_ppcmds val explain_refiner_error : refiner_error -> std_ppcmds val explain_pattern_matching_error : env -> pattern_matching_error -> std_ppcmds val explain_reduction_tactic_error : Tacred.reduction_tactic_error -> std_ppcmds val explain_ltac_call_trace : int * Proof_type.ltac_call_kind * Proof_type.ltac_trace * Util.loc -> std_ppcmds val explain_module_error : Modops.module_typing_error -> std_ppcmds val explain_module_internalization_error : Modintern.module_internalization_error -> std_ppcmds coq-8.4pl4/toplevel/usage.ml0000644000175000017500000001214712326224777015130 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* \n\n" let print_usage_coqc () = print_usage "Usage: coqc file...\n\ \noptions are:\ \n -verbose compile verbosely\ \n -image f specify an alternative executable for Coq\ \n -t keep temporary files\n\n" (* Print the configuration information *) let print_config () = if Coq_config.local then Printf.printf "LOCAL=1\n" else Printf.printf "LOCAL=0\n"; Printf.printf "COQLIB=%s/\n" (Envars.coqlib ()); Printf.printf "DOCDIR=%s/\n" (Envars.docdir ()); Printf.printf "OCAMLDEP=%s\n" Coq_config.ocamldep; Printf.printf "OCAMLC=%s\n" Coq_config.ocamlc; Printf.printf "OCAMLOPT=%s\n" Coq_config.ocamlopt; Printf.printf "OCAMLDOC=%s\n" Coq_config.ocamldoc; Printf.printf "CAMLBIN=%s/\n" (Envars.camlbin ()); Printf.printf "CAMLLIB=%s/\n" (Envars.camllib ()); Printf.printf "CAMLP4=%s\n" Coq_config.camlp4; Printf.printf "CAMLP4BIN=%s/\n" (Envars.camlp4bin ()); Printf.printf "CAMLP4LIB=%s\n" (Envars.camlp4lib ()); Printf.printf "HASNATDYNLINK=%s\n" (if Coq_config.has_natdynlink then "true" else "false") coq-8.4pl4/toplevel/lemmas.ml0000644000175000017500000003221712326224777015302 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (pi2 (Global.lookup_named id),variable_opacity id) | ConstRef cst -> let cb = Global.lookup_constant cst in (Option.map Declarations.force (body_of_constant cb), is_opaque cb) | _ -> assert false let adjust_guardness_conditions const = function | [] -> const (* Not a recursive statement *) | possible_indexes -> (* Try all combinations... not optimal *) match kind_of_term const.const_entry_body with | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> (* let possible_indexes = List.map2 (fun i c -> match i with Some i -> i | None -> interval 0 (List.length ((lam_assum c)))) lemma_guard (Array.to_list fixdefs) in *) let indexes = search_guard dummy_loc (Global.env()) possible_indexes fixdecls in { const with const_entry_body = mkFix ((indexes,0),fixdecls) } | c -> const let find_mutually_recursive_statements thms = let n = List.length thms in let inds = List.map (fun (id,(t,impls,annot)) -> let (hyps,ccl) = decompose_prod_assum t in let x = (id,(t,impls)) in match annot with (* Explicit fixpoint decreasing argument is given *) | Some (Some (_,id),CStructRec) -> let i,b,typ = lookup_rel_id id hyps in (match kind_of_term t with | Ind (kn,_ as ind) when let mind = Global.lookup_mind kn in mind.mind_finite & b = None -> [ind,x,i],[] | _ -> error "Decreasing argument is not an inductive assumption.") (* Unsupported cases *) | Some (_,(CWfRec _|CMeasureRec _)) -> error "Only structural decreasing is supported for mutual statements." (* Cofixpoint or fixpoint w/o explicit decreasing argument *) | None | Some (None, CStructRec) -> let whnf_hyp_hds = map_rel_context_in_env (fun env c -> fst (whd_betadeltaiota_stack env Evd.empty c)) (Global.env()) hyps in let ind_hyps = List.flatten (list_map_i (fun i (_,b,t) -> match kind_of_term t with | Ind (kn,_ as ind) when let mind = Global.lookup_mind kn in mind.mind_finite & b = None -> [ind,x,i] | _ -> []) 0 (List.rev whnf_hyp_hds)) in let ind_ccl = let cclenv = push_rel_context hyps (Global.env()) in let whnf_ccl,_ = whd_betadeltaiota_stack cclenv Evd.empty ccl in match kind_of_term whnf_ccl with | Ind (kn,_ as ind) when let mind = Global.lookup_mind kn in mind.mind_ntypes = n & not mind.mind_finite -> [ind,x,0] | _ -> [] in ind_hyps,ind_ccl) thms in let inds_hyps,ind_ccls = List.split inds in let of_same_mutind ((kn,_),_,_) = function ((kn',_),_,_) -> kn = kn' in (* Check if all conclusions are coinductive in the same type *) (* (degenerated cartesian product since there is at most one coind ccl) *) let same_indccl = list_cartesians_filter (fun hyp oks -> if List.for_all (of_same_mutind hyp) oks then Some (hyp::oks) else None) [] ind_ccls in let ordered_same_indccl = List.filter (list_for_all_i (fun i ((kn,j),_,_) -> i=j) 0) same_indccl in (* Check if some hypotheses are inductive in the same type *) let common_same_indhyp = list_cartesians_filter (fun hyp oks -> if List.for_all (of_same_mutind hyp) oks then Some (hyp::oks) else None) [] inds_hyps in let ordered_inds,finite,guard = match ordered_same_indccl, common_same_indhyp with | indccl::rest, _ -> assert (rest=[]); (* One occ. of common coind ccls and no common inductive hyps *) if common_same_indhyp <> [] then if_verbose msgnl (str "Assuming mutual coinductive statements."); flush_all (); indccl, true, [] | [], _::_ -> if same_indccl <> [] && list_distinct (List.map pi1 (List.hd same_indccl)) then if_verbose msgnl (strbrk "Coinductive statements do not follow the order of definition, assuming the proof to be by induction."); flush_all (); let possible_guards = List.map (List.map pi3) inds_hyps in (* assume the largest indices as possible *) list_last common_same_indhyp, false, possible_guards | _, [] -> error ("Cannot find common (mutual) inductive premises or coinductive" ^ " conclusions in the statements.") in (finite,guard,None), ordered_inds let look_for_possibly_mutual_statements = function | [id,(t,impls,None)] -> (* One non recursively proved theorem *) None,[id,(t,impls)],None | _::_ as thms -> (* More than one statement and/or an explicit decreasing mark: *) (* we look for a common inductive hyp or a common coinductive conclusion *) let recguard,ordered_inds = find_mutually_recursive_statements thms in let thms = List.map pi2 ordered_inds in Some recguard,thms, Some (List.map (fun (_,_,i) -> succ i) ordered_inds) | [] -> anomaly "Empty list of theorems." (* Saving a goal *) let save id const do_guard (locality,kind) hook = let const = adjust_guardness_conditions const do_guard in let {const_entry_body = pft; const_entry_type = tpo; const_entry_opaque = opacity } = const in let k = logical_kind_of_goal_kind kind in let l,r = match locality with | Local when Lib.sections_are_opened () -> let c = SectionLocalDef (pft, tpo, opacity) in let _ = declare_variable id (Lib.cwd(), c, k) in (Local, VarRef id) | Local | Global -> let kn = declare_constant id (DefinitionEntry const, k) in Autoinstance.search_declaration (ConstRef kn); (Global, ConstRef kn) in Pfedit.delete_current_proof (); definition_message id; hook l r let default_thm_id = id_of_string "Unnamed_thm" let compute_proof_name locality = function | Some (loc,id) -> (* We check existence here: it's a bit late at Qed time *) if Nametab.exists_cci (Lib.make_path id) || is_section_variable id || locality=Global && Nametab.exists_cci (Lib.make_path_except_section id) then user_err_loc (loc,"",pr_id id ++ str " already exists."); id | None -> next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()) let save_remaining_recthms (local,kind) body opaq i (id,(t_i,(_,imps))) = match body with | None -> (match local with | Local -> let impl=false in (* copy values from Vernacentries *) let k = IsAssumption Conjectural in let c = SectionLocalAssum (t_i,impl) in let _ = declare_variable id (Lib.cwd(),c,k) in (Local,VarRef id,imps) | Global -> let k = IsAssumption Conjectural in let kn = declare_constant id (ParameterEntry (None,t_i,None), k) in (Global,ConstRef kn,imps)) | Some body -> let k = logical_kind_of_goal_kind kind in let body_i = match kind_of_term body with | Fix ((nv,0),decls) -> mkFix ((nv,i),decls) | CoFix (0,decls) -> mkCoFix (i,decls) | _ -> anomaly "Not a proof by induction" in match local with | Local -> let c = SectionLocalDef (body_i, Some t_i, opaq) in let _ = declare_variable id (Lib.cwd(), c, k) in (Local,VarRef id,imps) | Global -> let const = { const_entry_body = body_i; const_entry_secctx = None; const_entry_type = Some t_i; const_entry_opaque = opaq } in let kn = declare_constant id (DefinitionEntry const, k) in (Global,ConstRef kn,imps) let save_hook = ref ignore let set_save_hook f = save_hook := f let get_proof opacity = let id,(const,do_guard,persistence,hook) = Pfedit.cook_proof !save_hook in id,{const with const_entry_opaque = opacity},do_guard,persistence,hook let save_named opacity = let p = Proof_global.give_me_the_proof () in Proof.transaction p begin fun () -> let id,const,do_guard,persistence,hook = get_proof opacity in save id const do_guard persistence hook end let check_anonymity id save_ident = if atompart_of_id id <> string_of_id (default_thm_id) then error "This command can only be used for unnamed theorem." let save_anonymous opacity save_ident = let p = Proof_global.give_me_the_proof () in Proof.transaction p begin fun () -> let id,const,do_guard,persistence,hook = get_proof opacity in check_anonymity id save_ident; save save_ident const do_guard persistence hook end let save_anonymous_with_strength kind opacity save_ident = let p = Proof_global.give_me_the_proof () in Proof.transaction p begin fun () -> let id,const,do_guard,_,hook = get_proof opacity in check_anonymity id save_ident; (* we consider that non opaque behaves as local for discharge *) save save_ident const do_guard (Global, Proof kind) hook end (* Starting a goal *) let start_hook = ref ignore let set_start_hook = (:=) start_hook let start_proof id kind c ?init_tac ?(compute_guard=[]) hook = let sign = initialize_named_context_for_proof () in !start_hook c; Pfedit.start_proof id kind sign c ?init_tac ~compute_guard hook let rec_tac_initializer finite guard thms snl = if finite then match List.map (fun (id,(t,_)) -> (id,t)) thms with | (id,_)::l -> Hiddentac.h_mutual_cofix true id l | _ -> assert false else (* nl is dummy: it will be recomputed at Qed-time *) let nl = match snl with | None -> List.map succ (List.map list_last guard) | Some nl -> nl in match List.map2 (fun (id,(t,_)) n -> (id,n,t)) thms nl with | (id,n,_)::l -> Hiddentac.h_mutual_fix true id n l | _ -> assert false let start_proof_with_initialization kind recguard thms snl hook = let intro_tac (_, (_, (ids, _))) = Refiner.tclMAP (function | Name id -> Tactics.intro_mustbe_force id | Anonymous -> Tactics.intro) (List.rev ids) in let init_tac,guard = match recguard with | Some (finite,guard,init_tac) -> let rec_tac = rec_tac_initializer finite guard thms snl in Some (match init_tac with | None -> if Flags.is_auto_intros () then tclTHENS rec_tac (List.map intro_tac thms) else rec_tac | Some tacl -> tclTHENS rec_tac (if Flags.is_auto_intros () then List.map2 (fun tac thm -> tclTHEN tac (intro_tac thm)) tacl thms else tacl)),guard | None -> assert (List.length thms = 1); (if Flags.is_auto_intros () then Some (intro_tac (List.hd thms)) else None), [] in match thms with | [] -> anomaly "No proof to start" | (id,(t,(_,imps)))::other_thms -> let hook strength ref = let other_thms_data = if other_thms = [] then [] else (* there are several theorems defined mutually *) let body,opaq = retrieve_first_recthm ref in list_map_i (save_remaining_recthms kind body opaq) 1 other_thms in let thms_data = (strength,ref,imps)::other_thms_data in List.iter (fun (strength,ref,imps) -> maybe_declare_manual_implicits false ref imps; hook strength ref) thms_data in start_proof id kind t ?init_tac hook ~compute_guard:guard let start_proof_com kind thms hook = let evdref = ref Evd.empty in let env0 = Global.env () in let thms = List.map (fun (sopt,(bl,t,guard)) -> let impls, ((env, ctx), imps) = interp_context_evars evdref env0 bl in let t', imps' = interp_type_evars_impls ~impls ~evdref env t in Sign.iter_rel_context (check_evars env Evd.empty !evdref) ctx; let ids = List.map pi1 ctx in (compute_proof_name (fst kind) sopt, (nf_evar !evdref (it_mkProd_or_LetIn t' ctx), (ids, imps @ lift_implicits (List.length ids) imps'), guard))) thms in let recguard,thms,snl = look_for_possibly_mutual_statements thms in start_proof_with_initialization kind recguard thms snl hook (* Admitted *) let admit () = let (id,k,typ,hook) = Pfedit.current_proof_statement () in let e = Pfedit.get_used_variables(), typ, None in let kn = declare_constant id (ParameterEntry e,IsAssumption Conjectural) in Pfedit.delete_current_proof (); assumption_message id; hook Global (ConstRef kn) (* Miscellaneous *) let get_current_context () = try Pfedit.get_current_goal_context () with e when Logic.catchable_exception e -> (Evd.empty, Global.env()) coq-8.4pl4/toplevel/metasyntax.ml0000644000175000017500000012714312326224777016224 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* obj = declare_object {(default_object "TOKEN") with open_function = (fun i o -> if i=1 then cache_token o); cache_function = cache_token; subst_function = Libobject.ident_subst_function; classify_function = (fun o -> Substitute o)} let add_token_obj s = Lib.add_anonymous_leaf (inToken s) (**********************************************************************) (* Tactic Notation *) let interp_prod_item lev = function | TacTerm s -> GramTerminal s | TacNonTerm (loc, nt, po) -> let sep = match po with Some (_,sep) -> sep | _ -> "" in let (etyp, e) = interp_entry_name true (Some lev) nt sep in GramNonTerminal (loc, etyp, e, Option.map fst po) let make_terminal_status = function | GramTerminal s -> Some s | GramNonTerminal _ -> None let rec make_tags = function | GramTerminal s :: l -> make_tags l | GramNonTerminal (loc, etyp, _, po) :: l -> etyp :: make_tags l | [] -> [] let cache_tactic_notation (_,(pa,pp)) = Egrammar.extend_grammar (Egrammar.TacticGrammar pa); Pptactic.declare_extra_tactic_pprule pp let subst_tactic_parule subst (key,n,p,(d,tac)) = (key,n,p,(d,Tacinterp.subst_tactic subst tac)) let subst_tactic_notation (subst,(pa,pp)) = (subst_tactic_parule subst pa,pp) type tactic_grammar_obj = (string * int * grammar_prod_item list * (dir_path * Tacexpr.glob_tactic_expr)) * (string * Genarg.argument_type list * (int * Pptactic.grammar_terminals)) let inTacticGrammar : tactic_grammar_obj -> obj = declare_object {(default_object "TacticGrammar") with open_function = (fun i o -> if i=1 then cache_tactic_notation o); cache_function = cache_tactic_notation; subst_function = subst_tactic_notation; classify_function = (fun o -> Substitute o)} let cons_production_parameter l = function | GramTerminal _ -> l | GramNonTerminal (_,_,_,ido) -> Option.List.cons ido l let rec tactic_notation_key = function | GramTerminal id :: _ -> id | _ :: l -> tactic_notation_key l | [] -> "terminal_free_notation" let rec next_key_away key t = if Pptactic.exists_extra_tactic_pprule key t then next_key_away (key^"'") t else key let add_tactic_notation (n,prods,e) = let prods = List.map (interp_prod_item n) prods in let tags = make_tags prods in let key = next_key_away (tactic_notation_key prods) tags in let pprule = (key,tags,(n,List.map make_terminal_status prods)) in let ids = List.fold_left cons_production_parameter [] prods in let tac = Tacinterp.glob_tactic_env ids (Global.env()) e in let parule = (key,n,prods,(Lib.cwd(),tac)) in Lib.add_anonymous_leaf (inTacticGrammar (parule,pprule)) (**********************************************************************) (* Printing grammar entries *) let print_grammar = function | "constr" | "operconstr" | "binder_constr" -> msgnl (str "Entry constr is"); Gram.entry_print Pcoq.Constr.constr; msgnl (str "and lconstr is"); Gram.entry_print Pcoq.Constr.lconstr; msgnl (str "where binder_constr is"); Gram.entry_print Pcoq.Constr.binder_constr; msgnl (str "and operconstr is"); Gram.entry_print Pcoq.Constr.operconstr; | "pattern" -> Gram.entry_print Pcoq.Constr.pattern | "tactic" -> msgnl (str "Entry tactic_expr is"); Gram.entry_print Pcoq.Tactic.tactic_expr; msgnl (str "Entry binder_tactic is"); Gram.entry_print Pcoq.Tactic.binder_tactic; msgnl (str "Entry simple_tactic is"); Gram.entry_print Pcoq.Tactic.simple_tactic; | "vernac" -> msgnl (str "Entry vernac is"); Gram.entry_print Pcoq.Vernac_.vernac; msgnl (str "Entry command is"); Gram.entry_print Pcoq.Vernac_.command; msgnl (str "Entry syntax is"); Gram.entry_print Pcoq.Vernac_.syntax; msgnl (str "Entry gallina is"); Gram.entry_print Pcoq.Vernac_.gallina; msgnl (str "Entry gallina_ext is"); Gram.entry_print Pcoq.Vernac_.gallina_ext; | _ -> error "Unknown or unprintable grammar entry." (**********************************************************************) (* Parse a format (every terminal starting with a letter or a single quote (except a single quote alone) must be quoted) *) let parse_format (loc,str) = let str = " "^str in let l = String.length str in let push_token a = function | cur::l -> (a::cur)::l | [] -> [[a]] in let push_white n l = if n = 0 then l else push_token (UnpTerminal (String.make n ' ')) l in let close_box i b = function | a::(_::_ as l) -> push_token (UnpBox (b,a)) l | _ -> error "Non terminated box in format." in let close_quotation i = if i < String.length str & str.[i] = '\'' & (i+1 = l or str.[i+1] = ' ') then i+1 else error "Incorrectly terminated quoted expression." in let rec spaces n i = if i < String.length str & str.[i] = ' ' then spaces (n+1) (i+1) else n in let rec nonspaces quoted n i = if i < String.length str & str.[i] <> ' ' then if str.[i] = '\'' & quoted & (i+1 >= String.length str or str.[i+1] = ' ') then if n=0 then error "Empty quoted token." else n else nonspaces quoted (n+1) (i+1) else if quoted then error "Spaces are not allowed in (quoted) symbols." else n in let rec parse_non_format i = let n = nonspaces false 0 i in push_token (UnpTerminal (String.sub str i n)) (parse_token (i+n)) and parse_quoted n i = if i < String.length str then match str.[i] with (* Parse " // " *) | '/' when i <= String.length str & str.[i+1] = '/' -> (* We forget the useless n spaces... *) push_token (UnpCut PpFnl) (parse_token (close_quotation (i+2))) (* Parse " .. / .. " *) | '/' when i <= String.length str -> let p = spaces 0 (i+1) in push_token (UnpCut (PpBrk (n,p))) (parse_token (close_quotation (i+p+1))) | c -> (* The spaces are real spaces *) push_white n (match c with | '[' -> if i <= String.length str then match str.[i+1] with (* Parse " [h .. ", *) | 'h' when i+1 <= String.length str & str.[i+2] = 'v' -> (parse_box (fun n -> PpHVB n) (i+3)) (* Parse " [v .. ", *) | 'v' -> parse_box (fun n -> PpVB n) (i+2) (* Parse " [ .. ", *) | ' ' | '\'' -> parse_box (fun n -> PpHOVB n) (i+1) | _ -> error "\"v\", \"hv\", \" \" expected after \"[\" in format." else error "\"v\", \"hv\" or \" \" expected after \"[\" in format." (* Parse "]" *) | ']' -> ([] :: parse_token (close_quotation (i+1))) (* Parse a non formatting token *) | c -> let n = nonspaces true 0 i in push_token (UnpTerminal (String.sub str (i-1) (n+2))) (parse_token (close_quotation (i+n)))) else if n = 0 then [] else error "Ending spaces non part of a format annotation." and parse_box box i = let n = spaces 0 i in close_box i (box n) (parse_token (close_quotation (i+n))) and parse_token i = let n = spaces 0 i in let i = i+n in if i < l then match str.[i] with (* Parse a ' *) | '\'' when i+1 >= String.length str or str.[i+1] = ' ' -> push_white (n-1) (push_token (UnpTerminal "'") (parse_token (i+1))) (* Parse the beginning of a quoted expression *) | '\'' -> parse_quoted (n-1) (i+1) (* Otherwise *) | _ -> push_white (n-1) (parse_non_format i) else push_white n [[]] in try if str <> "" then match parse_token 0 with | [l] -> l | _ -> error "Box closed without being opened in format." else error "Empty format." with e when Errors.noncritical e -> Loc.raise loc e (***********************) (* Analyzing notations *) type symbol_token = WhiteSpace of int | String of string let split_notation_string str = let push_token beg i l = if beg = i then l else let s = String.sub str beg (i - beg) in String s :: l in let push_whitespace beg i l = if beg = i then l else WhiteSpace (i-beg) :: l in let rec loop beg i = if i < String.length str then if str.[i] = ' ' then push_token beg i (loop_on_whitespace (i+1) (i+1)) else loop beg (i+1) else push_token beg i [] and loop_on_whitespace beg i = if i < String.length str then if str.[i] <> ' ' then push_whitespace beg i (loop i (i+1)) else loop_on_whitespace beg (i+1) else push_whitespace beg i [] in loop 0 0 (* Interpret notations with a recursive component *) let out_nt = function NonTerminal x -> x | _ -> assert false let msg_expected_form_of_recursive_notation = "In the notation, the special symbol \"..\" must occur in\na configuration of the form \"x symbs .. symbs y\"." let rec find_pattern nt xl = function | Break n as x :: l, Break n' :: l' when n=n' -> find_pattern nt (x::xl) (l,l') | Terminal s as x :: l, Terminal s' :: l' when s = s' -> find_pattern nt (x::xl) (l,l') | [], NonTerminal x' :: l' -> (out_nt nt,x',List.rev xl),l' | _, Terminal s :: _ | Terminal s :: _, _ -> error ("The token \""^s^"\" occurs on one side of \"..\" but not on the other side.") | _, Break s :: _ | Break s :: _, _ -> error ("A break occurs on one side of \"..\" but not on the other side.") | _, [] -> error msg_expected_form_of_recursive_notation | ((SProdList _ | NonTerminal _) :: _), _ | _, (SProdList _ :: _) -> anomaly "Only Terminal or Break expected on left, non-SProdList on right" let rec interp_list_parser hd = function | [] -> [], List.rev hd | NonTerminal id :: tl when id = ldots_var -> if hd = [] then error msg_expected_form_of_recursive_notation; let hd = List.rev hd in let ((x,y,sl),tl') = find_pattern (List.hd hd) [] (List.tl hd,tl) in let xyl,tl'' = interp_list_parser [] tl' in (* We remember each pair of variable denoting a recursive part to *) (* remove the second copy of it afterwards *) (x,y)::xyl, SProdList (x,sl) :: tl'' | (Terminal _ | Break _) as s :: tl -> if hd = [] then let yl,tl' = interp_list_parser [] tl in yl, s :: tl' else interp_list_parser (s::hd) tl | NonTerminal _ as x :: tl -> let xyl,tl' = interp_list_parser [x] tl in xyl, List.rev_append hd tl' | SProdList _ :: _ -> anomaly "Unexpected SProdList in interp_list_parser" (* Find non-terminal tokens of notation *) (* To protect alphabetic tokens and quotes from being seen as variables *) let quote_notation_token x = let n = String.length x in let norm = is_ident x in if (n > 0 & norm) or (n > 2 & x.[0] = '\'') then "'"^x^"'" else x let rec raw_analyze_notation_tokens = function | [] -> [] | String ".." :: sl -> NonTerminal ldots_var :: raw_analyze_notation_tokens sl | String "_" :: _ -> error "_ must be quoted." | String x :: sl when is_ident x -> NonTerminal (Names.id_of_string x) :: raw_analyze_notation_tokens sl | String s :: sl -> Terminal (drop_simple_quotes s) :: raw_analyze_notation_tokens sl | WhiteSpace n :: sl -> Break n :: raw_analyze_notation_tokens sl let is_numeral symbs = match List.filter (function Break _ -> false | _ -> true) symbs with | ([Terminal "-"; Terminal x] | [Terminal x]) -> (try let _ = Bigint.of_string x in true with e when Errors.noncritical e -> false) | _ -> false let rec get_notation_vars = function | [] -> [] | NonTerminal id :: sl -> let vars = get_notation_vars sl in if id = ldots_var then vars else if List.mem id vars then error ("Variable "^string_of_id id^" occurs more than once.") else id::vars | (Terminal _ | Break _) :: sl -> get_notation_vars sl | SProdList _ :: _ -> assert false let analyze_notation_tokens l = let l = raw_analyze_notation_tokens l in let vars = get_notation_vars l in let recvars,l = interp_list_parser [] l in recvars, list_subtract vars (List.map snd recvars), l let error_not_same_scope x y = error ("Variables "^string_of_id x^" and "^string_of_id y^ " must be in the same scope.") (**********************************************************************) (* Build pretty-printing rules *) type printing_precedence = int * parenRelation type parsing_precedence = int option let prec_assoc = function | RightA -> (L,E) | LeftA -> (E,L) | NonA -> (L,L) let precedence_of_entry_type from = function | ETConstr (NumLevel n,BorderProd (_,None)) -> n, Prec n | ETConstr (NumLevel n,BorderProd (b,Some a)) -> n, let (lp,rp) = prec_assoc a in if b=Left then lp else rp | ETConstr (NumLevel n,InternalProd) -> n, Prec n | ETConstr (NextLevel,_) -> from, L | _ -> 0, E (* ?? *) (* Some breaking examples *) (* "x = y" : "x /1 = y" (breaks before any symbol) *) (* "x =S y" : "x /1 =S /1 y" (protect from confusion; each side for symmetry)*) (* "+ {" : "+ {" may breaks reversibility without space but oth. not elegant *) (* "x y" : "x spc y" *) (* "{ x } + { y }" : "{ x } / + { y }" *) (* "< x , y > { z , t }" : "< x , / y > / { z , / t }" *) let is_left_bracket s = let l = String.length s in l <> 0 & (s.[0] = '{' or s.[0] = '[' or s.[0] = '(') let is_right_bracket s = let l = String.length s in l <> 0 & (s.[l-1] = '}' or s.[l-1] = ']' or s.[l-1] = ')') let is_comma s = let l = String.length s in l <> 0 & (s.[0] = ',' or s.[0] = ';') let is_operator s = let l = String.length s in l <> 0 & (s.[0] = '+' or s.[0] = '*' or s.[0] = '=' or s.[0] = '-' or s.[0] = '/' or s.[0] = '<' or s.[0] = '>' or s.[0] = '@' or s.[0] = '\\' or s.[0] = '&' or s.[0] = '~' or s.[0] = '$') let is_prod_ident = function | Terminal s when is_letter s.[0] or s.[0] = '_' -> true | _ -> false let rec is_non_terminal = function | NonTerminal _ | SProdList _ -> true | _ -> false let add_break n l = UnpCut (PpBrk(n,0)) :: l let check_open_binder isopen sl m = if isopen & sl <> [] then errorlabstrm "" (str "as " ++ pr_id m ++ str " is a non-closed binder, no such \"" ++ prlist_with_sep spc (function Terminal s -> str s | _ -> assert false) sl ++ strbrk "\" is allowed to occur.") (* Heuristics for building default printing rules *) type previous_prod_status = NoBreak | CanBreak let make_hunks etyps symbols from = let vars,typs = List.split etyps in let rec make ws = function | NonTerminal m :: prods -> let i = list_index m vars in let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in let u = UnpMetaVar (i,prec) in if prods <> [] && is_non_terminal (List.hd prods) then u :: add_break 1 (make CanBreak prods) else u :: make CanBreak prods | Terminal s :: prods when List.exists is_non_terminal prods -> if is_comma s then UnpTerminal s :: add_break 1 (make NoBreak prods) else if is_right_bracket s then UnpTerminal s :: add_break 0 (make NoBreak prods) else if is_left_bracket s then if ws = CanBreak then add_break 1 (UnpTerminal s :: make CanBreak prods) else UnpTerminal s :: make CanBreak prods else if is_operator s then if ws = CanBreak then UnpTerminal (" "^s) :: add_break 1 (make NoBreak prods) else UnpTerminal s :: add_break 1 (make NoBreak prods) else if is_ident_tail s.[String.length s - 1] then let sep = if is_prod_ident (List.hd prods) then "" else " " in if ws = CanBreak then add_break 1 (UnpTerminal (s^sep) :: make CanBreak prods) else UnpTerminal (s^sep) :: make CanBreak prods else if ws = CanBreak then add_break 1 (UnpTerminal (s^" ") :: make CanBreak prods) else UnpTerminal s :: make CanBreak prods | Terminal s :: prods -> if is_right_bracket s then UnpTerminal s :: make NoBreak prods else if ws = CanBreak then add_break 1 (UnpTerminal s :: make NoBreak prods) else UnpTerminal s :: make NoBreak prods | Break n :: prods -> add_break n (make NoBreak prods) | SProdList (m,sl) :: prods -> let i = list_index m vars in let typ = List.nth typs (i-1) in let _,prec = precedence_of_entry_type from typ in let sl' = (* If no separator: add a break *) if sl = [] then add_break 1 [] (* We add NonTerminal for simulation but remove it afterwards *) else snd (list_sep_last (make NoBreak (sl@[NonTerminal m]))) in let hunk = match typ with | ETConstr _ -> UnpListMetaVar (i,prec,sl') | ETBinder isopen -> check_open_binder isopen sl m; UnpBinderListMetaVar (i,isopen,sl') | _ -> assert false in hunk :: make CanBreak prods | [] -> [] in make NoBreak symbols (* Build default printing rules from explicit format *) let error_format () = error "The format does not match the notation." let rec split_format_at_ldots hd = function | UnpTerminal s :: fmt when s = string_of_id ldots_var -> List.rev hd, fmt | u :: fmt -> check_no_ldots_in_box u; split_format_at_ldots (u::hd) fmt | [] -> raise Exit and check_no_ldots_in_box = function | UnpBox (_,fmt) -> (try let _ = split_format_at_ldots [] fmt in error ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse.") with Exit -> ()) | _ -> () let skip_var_in_recursive_format = function | UnpTerminal _ :: sl (* skip first var *) -> (* To do, though not so important: check that the names match the names in the notation *) sl | _ -> error_format () let read_recursive_format sl fmt = let get_head fmt = let sl = skip_var_in_recursive_format fmt in try split_format_at_ldots [] sl with Exit -> error_format () in let rec get_tail = function | a :: sepfmt, b :: fmt when a = b -> get_tail (sepfmt, fmt) | [], tail -> skip_var_in_recursive_format tail | _ -> error "The format is not the same on the right and left hand side of the special token \"..\"." in let slfmt, fmt = get_head fmt in slfmt, get_tail (slfmt, fmt) let hunks_of_format (from,(vars,typs)) symfmt = let rec aux = function | symbs, (UnpTerminal s' as u) :: fmt when s' = String.make (String.length s') ' ' -> let symbs, l = aux (symbs,fmt) in symbs, u :: l | Terminal s :: symbs, (UnpTerminal s') :: fmt when s = drop_simple_quotes s' -> let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l | NonTerminal s :: symbs, UnpTerminal s' :: fmt when s = id_of_string s' -> let i = list_index s vars in let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in let symbs, l = aux (symbs,fmt) in symbs, UnpMetaVar (i,prec) :: l | symbs, UnpBox (a,b) :: fmt -> let symbs', b' = aux (symbs,b) in let symbs', l = aux (symbs',fmt) in symbs', UnpBox (a,b') :: l | symbs, (UnpCut _ as u) :: fmt -> let symbs, l = aux (symbs,fmt) in symbs, u :: l | SProdList (m,sl) :: symbs, fmt -> let i = list_index m vars in let typ = List.nth typs (i-1) in let _,prec = precedence_of_entry_type from typ in let slfmt,fmt = read_recursive_format sl fmt in let sl, slfmt = aux (sl,slfmt) in if sl <> [] then error_format (); let symbs, l = aux (symbs,fmt) in let hunk = match typ with | ETConstr _ -> UnpListMetaVar (i,prec,slfmt) | ETBinder isopen -> check_open_binder isopen sl m; UnpBinderListMetaVar (i,isopen,slfmt) | _ -> assert false in symbs, hunk :: l | symbs, [] -> symbs, [] | _, _ -> error_format () in match aux symfmt with | [], l -> l | _ -> error_format () (**********************************************************************) (* Build parsing rules *) let assoc_of_type n (_,typ) = precedence_of_entry_type n typ let is_not_small_constr = function ETConstr _ -> true | ETOther("constr","binder_constr") -> true | _ -> false let rec define_keywords_aux = function | GramConstrNonTerminal(e,Some _) as n1 :: GramConstrTerminal(IDENT k) :: l when is_not_small_constr e -> message ("Identifier '"^k^"' now a keyword"); Lexer.add_keyword k; n1 :: GramConstrTerminal(KEYWORD k) :: define_keywords_aux l | n :: l -> n :: define_keywords_aux l | [] -> [] (* Ensure that IDENT articulation terminal symbols are keywords *) let define_keywords = function | GramConstrTerminal(IDENT k)::l -> message ("Identifier '"^k^"' now a keyword"); Lexer.add_keyword k; GramConstrTerminal(KEYWORD k) :: define_keywords_aux l | l -> define_keywords_aux l let distribute a ll = List.map (fun l -> a @ l) ll (* Expand LIST1(t,sep) into the combination of t and t;sep;LIST1(t,sep) as many times as expected in [n] argument *) let rec expand_list_rule typ tkl x n i hds ll = if i = n then let hds = GramConstrListMark (n,true) :: hds @ [GramConstrNonTerminal (ETConstrList (typ,tkl), Some x)] in distribute hds ll else let camlp4_message_name = Some (add_suffix x ("_"^string_of_int n)) in let main = GramConstrNonTerminal (ETConstr typ, camlp4_message_name) in let tks = List.map (fun x -> GramConstrTerminal x) tkl in distribute (GramConstrListMark (i+1,false) :: hds @ [main]) ll @ expand_list_rule typ tkl x n (i+1) (main :: tks @ hds) ll let make_production etyps symbols = let prod = List.fold_right (fun t ll -> match t with | NonTerminal m -> let typ = List.assoc m etyps in distribute [GramConstrNonTerminal (typ, Some m)] ll | Terminal s -> distribute [GramConstrTerminal (terminal s)] ll | Break _ -> ll | SProdList (x,sl) -> let tkl = List.flatten (List.map (function Terminal s -> [terminal s] | Break _ -> [] | _ -> anomaly "Found a non terminal token in recursive notation separator") sl) in match List.assoc x etyps with | ETConstr typ -> expand_list_rule typ tkl x 1 0 [] ll | ETBinder o -> distribute [GramConstrNonTerminal (ETBinderList (o,tkl), Some x)] ll | _ -> error "Components of recursive patterns in notation must be terms or binders.") symbols [[]] in List.map define_keywords prod let rec find_symbols c_current c_next c_last = function | [] -> [] | NonTerminal id :: sl -> let prec = if sl <> [] then c_current else c_last in (id, prec) :: (find_symbols c_next c_next c_last sl) | Terminal s :: sl -> find_symbols c_next c_next c_last sl | Break n :: sl -> find_symbols c_current c_next c_last sl | SProdList (x,_) :: sl' -> (x,c_next)::(find_symbols c_next c_next c_last sl') let border = function | (_,ETConstr(_,BorderProd (_,a))) :: _ -> a | _ -> None let recompute_assoc typs = match border typs, border (List.rev typs) with | Some LeftA, Some RightA -> assert false | Some LeftA, _ -> Some LeftA | _, Some RightA -> Some RightA | _ -> None (**************************************************************************) (* Registration of syntax extensions (parsing/printing, no interpretation)*) let pr_arg_level from = function | (n,L) when n=from -> str "at next level" | (n,E) -> str "at level " ++ int n | (n,L) -> str "at level below " ++ int n | (n,Prec m) when m=n -> str "at level " ++ int n | (n,_) -> str "Unknown level" let pr_level ntn (from,args) = str "at level " ++ int from ++ spc () ++ str "with arguments" ++ spc() ++ prlist_with_sep pr_comma (pr_arg_level from) args let error_incompatible_level ntn oldprec prec = errorlabstrm "" (str ("Notation "^ntn^" is already defined") ++ spc() ++ pr_level ntn oldprec ++ spc() ++ str "while it is now required to be" ++ spc() ++ pr_level ntn prec ++ str ".") let cache_one_syntax_extension (typs,prec,ntn,gr,pp) = try let oldprec = Notation.level_of_notation ntn in if prec <> oldprec then error_incompatible_level ntn oldprec prec with Not_found -> (* Reserve the notation level *) Notation.declare_notation_level ntn prec; (* Declare the parsing rule *) Egrammar.extend_grammar (Egrammar.Notation (prec,typs,gr)); (* Declare the printing rule *) Notation.declare_notation_printing_rule ntn (pp,fst prec) let cache_syntax_extension (_,(_,sy_rules)) = List.iter cache_one_syntax_extension sy_rules let subst_parsing_rule subst x = x let subst_printing_rule subst x = x let subst_syntax_extension (subst,(local,sy)) = (local, List.map (fun (typs,prec,ntn,gr,pp) -> (typs,prec,ntn,subst_parsing_rule subst gr,subst_printing_rule subst pp)) sy) let classify_syntax_definition (local,_ as o) = if local then Dispose else Substitute o type syntax_extension_obj = bool * (notation_var_internalization_type list * Notation.level * notation * notation_grammar * unparsing list) list let inSyntaxExtension : syntax_extension_obj -> obj = declare_object {(default_object "SYNTAX-EXTENSION") with open_function = (fun i o -> if i=1 then cache_syntax_extension o); cache_function = cache_syntax_extension; subst_function = subst_syntax_extension; classify_function = classify_syntax_definition} (**************************************************************************) (* Precedences *) (* Interpreting user-provided modifiers *) let interp_modifiers modl = let onlyparsing = ref false in let rec interp assoc level etyps format = function | [] -> (assoc,level,etyps,!onlyparsing,format) | SetEntryType (s,typ) :: l -> let id = id_of_string s in if List.mem_assoc id etyps then error (s^" is already assigned to an entry or constr level."); interp assoc level ((id,typ)::etyps) format l | SetItemLevel ([],n) :: l -> interp assoc level etyps format l | SetItemLevel (s::idl,n) :: l -> let id = id_of_string s in if List.mem_assoc id etyps then error (s^" is already assigned to an entry or constr level."); let typ = ETConstr (n,()) in interp assoc level ((id,typ)::etyps) format (SetItemLevel (idl,n)::l) | SetLevel n :: l -> if level <> None then error "A level is given more than once."; interp assoc (Some n) etyps format l | SetAssoc a :: l -> if assoc <> None then error"An associativity is given more than once."; interp (Some a) level etyps format l | SetOnlyParsing _ :: l -> onlyparsing := true; interp assoc level etyps format l | SetFormat s :: l -> if format <> None then error "A format is given more than once."; interp assoc level etyps (Some s) l in interp None None [] None modl let check_infix_modifiers modifiers = let (assoc,level,t,b,fmt) = interp_modifiers modifiers in if t <> [] then error "Explicit entry level or type unexpected in infix notation." let no_syntax_modifiers = function | [] | [SetOnlyParsing _] -> true | _ -> false let is_only_parsing = function | [SetOnlyParsing _] -> true | _ -> false (* Compute precedences from modifiers (or find default ones) *) let set_entry_type etyps (x,typ) = let typ = try match List.assoc x etyps, typ with | ETConstr (n,()), (_,BorderProd (left,_)) -> ETConstr (n,BorderProd (left,None)) | ETConstr (n,()), (_,InternalProd) -> ETConstr (n,InternalProd) | (ETPattern | ETName | ETBigint | ETOther _ | ETReference | ETBinder _ as t), _ -> t | (ETBinderList _ |ETConstrList _), _ -> assert false with Not_found -> ETConstr typ in (x,typ) let join_auxiliary_recursive_types recvars etyps = List.fold_right (fun (x,y) typs -> let xtyp = try Some (List.assoc x etyps) with Not_found -> None in let ytyp = try Some (List.assoc y etyps) with Not_found -> None in match xtyp,ytyp with | None, None -> typs | Some _, None -> typs | None, Some ytyp -> (x,ytyp)::typs | Some xtyp, Some ytyp when xtyp = ytyp -> typs | Some xtyp, Some ytyp -> errorlabstrm "" (strbrk "In " ++ pr_id x ++ str " .. " ++ pr_id y ++ strbrk ", both ends have incompatible types.")) recvars etyps let internalization_type_of_entry_type = function | ETConstr _ -> NtnInternTypeConstr | ETBigint | ETReference -> NtnInternTypeConstr | ETBinder _ -> NtnInternTypeBinder | ETName -> NtnInternTypeIdent | ETPattern | ETOther _ -> error "Not supported." | ETBinderList _ | ETConstrList _ -> assert false let set_internalization_type typs = List.map (down_snd internalization_type_of_entry_type) typs let make_internalization_vars recvars mainvars typs = let maintyps = List.combine mainvars typs in let extratyps = List.map (fun (x,y) -> (y,List.assoc x maintyps)) recvars in maintyps@extratyps let make_interpretation_type isrec = function | NtnInternTypeConstr when isrec -> NtnTypeConstrList | NtnInternTypeConstr | NtnInternTypeIdent -> NtnTypeConstr | NtnInternTypeBinder when isrec -> NtnTypeBinderList | NtnInternTypeBinder -> error "Type not allowed in recursive notation." let make_interpretation_vars recvars allvars = List.iter (fun (x,y) -> if fst (List.assoc x allvars) <> fst (List.assoc y allvars) then error_not_same_scope x y) recvars; let useless_recvars = List.map snd recvars in let mainvars = List.filter (fun (x,_) -> not (List.mem x useless_recvars)) allvars in List.map (fun (x,(sc,typ)) -> (x,(sc,make_interpretation_type (List.mem_assoc x recvars) typ))) mainvars let check_rule_productivity l = if List.for_all (function NonTerminal _ -> true | _ -> false) l then error "A notation must include at least one symbol."; if (match l with SProdList _ :: _ -> true | _ -> false) then error "A recursive notation must start with at least one symbol." let is_not_printable = function | AVar _ -> msg_warn "This notation will not be used for printing as it is bound to a \nsingle variable"; true | _ -> false let find_precedence lev etyps symbols = match symbols with | NonTerminal x :: _ -> (try match List.assoc x etyps with | ETConstr _ -> error "The level of the leftmost non-terminal cannot be changed." | ETName | ETBigint | ETReference -> if lev = None then ([msgnl,str "Setting notation at level 0."],0) else if lev <> Some 0 then error "A notation starting with an atomic expression must be at level 0." else ([],0) | ETPattern | ETBinder _ | ETOther _ -> (* Give a default ? *) if lev = None then error "Need an explicit level." else [],Option.get lev | ETConstrList _ | ETBinderList _ -> assert false (* internally used in grammar only *) with Not_found -> if lev = None then error "A left-recursive notation must have an explicit level." else [],Option.get lev) | Terminal _ ::l when (match list_last symbols with Terminal _ -> true |_ -> false) -> if lev = None then ([msgnl,str "Setting notation at level 0."], 0) else [],Option.get lev | _ -> if lev = None then error "Cannot determine the level."; [],Option.get lev let check_curly_brackets_notation_exists () = try let _ = Notation.level_of_notation "{ _ }" in () with Not_found -> error "Notations involving patterns of the form \"{ _ }\" are treated \n\ specially and require that the notation \"{ _ }\" is already reserved." (* Remove patterns of the form "{ _ }", unless it is the "{ _ }" notation *) let remove_curly_brackets l = let rec skip_break acc = function | Break _ as br :: l -> skip_break (br::acc) l | l -> List.rev acc, l in let rec aux deb = function | [] -> [] | Terminal "{" as t1 :: l -> let br,next = skip_break [] l in (match next with | NonTerminal _ as x :: l' as l0 -> let br',next' = skip_break [] l' in (match next' with | Terminal "}" as t2 :: l'' as l1 -> if l <> l0 or l' <> l1 then msg_warn "Skipping spaces inside curly brackets"; if deb & l'' = [] then [t1;x;t2] else begin check_curly_brackets_notation_exists (); x :: aux false l'' end | l1 -> t1 :: br @ x :: br' @ aux false l1) | l0 -> t1 :: aux false l0) | x :: l -> x :: aux false l in aux true l let compute_syntax_data (df,modifiers) = let (assoc,n,etyps,onlyparse,fmt) = interp_modifiers modifiers in let assoc = match assoc with None -> (* default *) Some NonA | a -> a in let toks = split_notation_string df in let (recvars,mainvars,symbols) = analyze_notation_tokens toks in let ntn_for_interp = make_notation_key symbols in let symbols' = remove_curly_brackets symbols in let need_squash = (symbols <> symbols') in let ntn_for_grammar = make_notation_key symbols' in check_rule_productivity symbols'; let msgs,n = find_precedence n etyps symbols' in let innerlevel = NumLevel 200 in let typs = find_symbols (NumLevel n,BorderProd(Left,assoc)) (innerlevel,InternalProd) (NumLevel n,BorderProd(Right,assoc)) symbols' in (* To globalize... *) let etyps = join_auxiliary_recursive_types recvars etyps in let sy_typs = List.map (set_entry_type etyps) typs in let prec = (n,List.map (assoc_of_type n) sy_typs) in let i_typs = set_internalization_type sy_typs in let sy_data = (n,sy_typs,symbols',fmt) in let sy_fulldata = (i_typs,ntn_for_grammar,prec,need_squash,sy_data) in let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in let i_data = (onlyparse,recvars,mainvars,(ntn_for_interp,df')) in (* Return relevant data for interpretation and for parsing/printing *) (msgs,i_data,i_typs,sy_fulldata) let compute_pure_syntax_data (df,mods) = let (msgs,(onlyparse,_,_,_),_,sy_data) = compute_syntax_data (df,mods) in let msgs = if onlyparse then (msg_warning, str "The only parsing modifier has no effect in Reserved Notation.")::msgs else msgs in msgs, sy_data (**********************************************************************) (* Registration of notations interpretation *) let load_notation _ (_,(_,scope,pat,onlyparse,_)) = Option.iter Notation.declare_scope scope let open_notation i (_,(_,scope,pat,onlyparse,(ntn,df))) = if i=1 & not (Notation.exists_notation_in_scope scope ntn pat) then begin (* Declare the interpretation *) Notation.declare_notation_interpretation ntn scope pat df; (* Declare the uninterpretation *) if not onlyparse then Notation.declare_uninterpretation (NotationRule (scope,ntn)) pat end let cache_notation o = load_notation 1 o; open_notation 1 o let subst_notation (subst,(lc,scope,pat,b,ndf)) = (lc,scope,subst_interpretation subst pat,b,ndf) let classify_notation (local,_,_,_,_ as o) = if local then Dispose else Substitute o type notation_obj = bool * scope_name option * interpretation * bool * (notation * notation_location) let inNotation : notation_obj -> obj = declare_object {(default_object "NOTATION") with open_function = open_notation; cache_function = cache_notation; subst_function = subst_notation; load_function = load_notation; classify_function = classify_notation} (**********************************************************************) let with_lib_stk_protection f x = let fs = Lib.freeze () in try let a = f x in Lib.unfreeze fs; a with reraise -> Lib.unfreeze fs; raise reraise let with_syntax_protection f x = with_lib_stk_protection (with_grammar_rule_protection (with_notation_protection f)) x (**********************************************************************) (* Recovering existing syntax *) let contract_notation ntn = if ntn = "{ _ }" then ntn else let rec aux ntn i = if i <= String.length ntn - 5 then let ntn' = if String.sub ntn i 5 = "{ _ }" then String.sub ntn 0 i ^ "_" ^ String.sub ntn (i+5) (String.length ntn -i-5) else ntn in aux ntn' (i+1) else ntn in aux ntn 0 exception NoSyntaxRule let recover_syntax ntn = try let prec = Notation.level_of_notation ntn in let pp_rule,_ = Notation.find_notation_printing_rule ntn in let typs,pa_rule = Egrammar.recover_notation_grammar ntn prec in (typs,prec,ntn,pa_rule,pp_rule) with Not_found -> raise NoSyntaxRule let recover_squash_syntax () = recover_syntax "{ _ }" let recover_notation_syntax rawntn = let ntn = contract_notation rawntn in let (typs,_,_,_,_ as sy_rule) = recover_syntax ntn in let need_squash = ntn<>rawntn in typs,if need_squash then [sy_rule; recover_squash_syntax ()] else [sy_rule] (**********************************************************************) (* Main entry point for building parsing and printing rules *) let make_pa_rule (n,typs,symbols,_) ntn = let assoc = recompute_assoc typs in let prod = make_production typs symbols in (n,assoc,ntn,prod) let make_pp_rule (n,typs,symbols,fmt) = match fmt with | None -> [UnpBox (PpHOVB 0, make_hunks typs symbols n)] | Some fmt -> hunks_of_format (n,List.split typs) (symbols,parse_format fmt) let make_syntax_rules (i_typs,ntn,prec,need_squash,sy_data) = let pa_rule = make_pa_rule sy_data ntn in let pp_rule = make_pp_rule sy_data in let sy_rule = (i_typs,prec,ntn,pa_rule,pp_rule) in (* By construction, the rule for "{ _ }" is declared, but we need to redeclare it because the file where it is declared needs not be open when the current file opens (especially in presence of -nois) *) if need_squash then [sy_rule; recover_squash_syntax ()] else [sy_rule] (**********************************************************************) (* Main functions about notations *) let add_notation_in_scope local df c mods scope = let (msgs,i_data,i_typs,sy_data) = compute_syntax_data (df,mods) in (* Prepare the parsing and printing rules *) let sy_rules = make_syntax_rules sy_data in (* Prepare the interpretation *) let (onlyparse,recvars,mainvars,df') = i_data in let i_vars = make_internalization_vars recvars mainvars i_typs in let (acvars,ac) = interp_aconstr i_vars recvars c in let a = (make_interpretation_vars recvars acvars,ac) in let onlyparse = onlyparse or is_not_printable ac in (* Ready to change the global state *) Flags.if_verbose (List.iter (fun (f,x) -> f x)) msgs; Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules)); Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df')); df' let add_notation_interpretation_core local df ?(impls=empty_internalization_env) c scope onlyparse = let dfs = split_notation_string df in let (recvars,mainvars,symbs) = analyze_notation_tokens dfs in (* Recover types of variables and pa/pp rules; redeclare them if needed *) let i_typs = if not (is_numeral symbs) then begin let i_typs,sy_rules = recover_notation_syntax (make_notation_key symbs) in Lib.add_anonymous_leaf (inSyntaxExtension (local,sy_rules)); i_typs end else [] in (* Declare interpretation *) let path = (Lib.library_dp(),Lib.current_dirpath true) in let df' = (make_notation_key symbs,(path,df)) in let i_vars = make_internalization_vars recvars mainvars i_typs in let (acvars,ac) = interp_aconstr ~impls i_vars recvars c in let a = (make_interpretation_vars recvars acvars,ac) in let onlyparse = onlyparse or is_not_printable ac in Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df')); df' (* Notations without interpretation (Reserved Notation) *) let add_syntax_extension local ((loc,df),mods) = let msgs,sy_data = compute_pure_syntax_data (df,mods) in let sy_rules = make_syntax_rules sy_data in Flags.if_verbose (List.iter (fun (f,x) -> f x)) msgs; Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules)) (* Notations with only interpretation *) let add_notation_interpretation ((loc,df),c,sc) = let df' = add_notation_interpretation_core false df c sc false in Dumpglob.dump_notation (loc,df') sc true let set_notation_for_interpretation impls ((_,df),c,sc) = (try ignore (silently (add_notation_interpretation_core false df ~impls c sc) false); with NoSyntaxRule -> error "Parsing rule for this notation has to be previously declared."); Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc (* Main entry point *) let add_notation local c ((loc,df),modifiers) sc = let df' = if no_syntax_modifiers modifiers then (* No syntax data: try to rely on a previously declared rule *) let onlyparse = is_only_parsing modifiers in try add_notation_interpretation_core local df c sc onlyparse with NoSyntaxRule -> (* Try to determine a default syntax rule *) add_notation_in_scope local df c modifiers sc else (* Declare both syntax and interpretation *) add_notation_in_scope local df c modifiers sc in Dumpglob.dump_notation (loc,df') sc true (* Infix notations *) let inject_var x = CRef (Ident (dummy_loc, id_of_string x)) let add_infix local ((loc,inf),modifiers) pr sc = check_infix_modifiers modifiers; (* check the precedence *) let metas = [inject_var "x"; inject_var "y"] in let c = mkAppC (pr,metas) in let df = "x "^(quote_notation_token inf)^" y" in add_notation local c ((loc,df),modifiers) sc (**********************************************************************) (* Delimiters and classes bound to scopes *) type scope_command = ScopeDelim of string | ScopeClasses of Classops.cl_typ let load_scope_command _ (_,(scope,dlm)) = Notation.declare_scope scope let open_scope_command i (_,(scope,o)) = if i=1 then match o with | ScopeDelim dlm -> Notation.declare_delimiters scope dlm | ScopeClasses cl -> Notation.declare_class_scope scope cl let cache_scope_command o = load_scope_command 1 o; open_scope_command 1 o let subst_scope_command (subst,(scope,o as x)) = match o with | ScopeClasses cl -> let cl' = Classops.subst_cl_typ subst cl in if cl'==cl then x else scope, ScopeClasses cl' | _ -> x let inScopeCommand : scope_name * scope_command -> obj = declare_object {(default_object "DELIMITERS") with cache_function = cache_scope_command; open_function = open_scope_command; load_function = load_scope_command; subst_function = subst_scope_command; classify_function = (fun obj -> Substitute obj)} let add_delimiters scope key = Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeDelim key)) let add_class_scope scope cl = Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeClasses cl)) (* Check if abbreviation to a name and avoid early insertion of maximal implicit arguments *) let try_interp_name_alias = function | [], CRef ref -> intern_reference ref | _ -> raise Not_found let add_syntactic_definition ident (vars,c) local onlyparse = let vars,pat = try [], ARef (try_interp_name_alias (vars,c)) with Not_found -> let i_vars = List.map (fun id -> (id,NtnInternTypeConstr)) vars in let vars,pat = interp_aconstr i_vars [] c in List.map (fun (id,(sc,kind)) -> (id,sc)) vars, pat in let onlyparse = match onlyparse with | None when (is_not_printable pat) -> Some Flags.Current | p -> p in Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat) coq-8.4pl4/toplevel/ind_tables.ml0000644000175000017500000001453712326224777016135 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr array type individual_scheme_object_function = inductive -> constr type 'a scheme_kind = string let scheme_map = ref Indmap.empty let cache_one_scheme kind (ind,const) = let map = try Indmap.find ind !scheme_map with Not_found -> Stringmap.empty in scheme_map := Indmap.add ind (Stringmap.add kind const map) !scheme_map let cache_scheme (_,(kind,l)) = Array.iter (cache_one_scheme kind) l let subst_one_scheme subst ((mind,i),const) = (* Remark: const is a def: the result of substitution is a constant *) ((subst_ind subst mind,i),fst (subst_con subst const)) let subst_scheme (subst,(kind,l)) = (kind,Array.map (subst_one_scheme subst) l) let discharge_scheme (_,(kind,l)) = Some (kind,Array.map (fun (ind,const) -> (Lib.discharge_inductive ind,Lib.discharge_con const)) l) let inScheme : string * (inductive * constant) array -> obj = declare_object {(default_object "SCHEME") with cache_function = cache_scheme; load_function = (fun _ -> cache_scheme); subst_function = subst_scheme; classify_function = (fun obj -> Substitute obj); discharge_function = discharge_scheme} (**********************************************************************) (* Saving/restoring the table of scheme *) let freeze_schemes () = !scheme_map let unfreeze_schemes sch = scheme_map := sch let init_schemes () = scheme_map := Indmap.empty let _ = Summary.declare_summary "Schemes" { Summary.freeze_function = freeze_schemes; Summary.unfreeze_function = unfreeze_schemes; Summary.init_function = init_schemes } (**********************************************************************) (* The table of scheme building functions *) type individual type mutual type scheme_object_function = | MutualSchemeFunction of (mutual_inductive -> constr array) | IndividualSchemeFunction of (inductive -> constr) let scheme_object_table = (Hashtbl.create 17 : (string, string * scheme_object_function) Hashtbl.t) let declare_scheme_object s aux f = (try check_ident ("ind"^s) with e when Errors.noncritical e -> error ("Illegal induction scheme suffix: "^s)); let key = if aux = "" then s else aux in try let _ = Hashtbl.find scheme_object_table key in (* let aux_msg = if aux="" then "" else " (with key "^aux^")" in*) error ("Scheme object "^key^" already declared.") with Not_found -> Hashtbl.add scheme_object_table key (s,f); key let declare_mutual_scheme_object s ?(aux="") f = declare_scheme_object s aux (MutualSchemeFunction f) let declare_individual_scheme_object s ?(aux="") f = declare_scheme_object s aux (IndividualSchemeFunction f) (**********************************************************************) (* Defining/retrieving schemes *) let declare_scheme kind indcl = Lib.add_anonymous_leaf (inScheme (kind,indcl)) let is_visible_name id = try ignore (Nametab.locate (Libnames.qualid_of_ident id)); true with Not_found -> false let compute_name internal id = match internal with | KernelVerbose | UserVerbose -> id | KernelSilent -> Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name let define internal id c = let fd = declare_constant ~internal in let id = compute_name internal id in let kn = fd id (DefinitionEntry { const_entry_body = c; const_entry_secctx = None; const_entry_type = None; const_entry_opaque = false }, Decl_kinds.IsDefinition Scheme) in (match internal with | KernelSilent -> () | _-> definition_message id); kn let define_individual_scheme_base kind suff f internal idopt (mind,i as ind) = let c = f ind in let mib = Global.lookup_mind mind in let id = match idopt with | Some id -> id | None -> add_suffix mib.mind_packets.(i).mind_typename suff in let const = define internal id c in declare_scheme kind [|ind,const|]; const let define_individual_scheme kind internal names (mind,i as ind) = match Hashtbl.find scheme_object_table kind with | _,MutualSchemeFunction f -> assert false | s,IndividualSchemeFunction f -> define_individual_scheme_base kind s f internal names ind let define_mutual_scheme_base kind suff f internal names mind = let cl = f mind in let mib = Global.lookup_mind mind in let ids = Array.init (Array.length mib.mind_packets) (fun i -> try List.assoc i names with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in let consts = array_map2 (define internal) ids cl in declare_scheme kind (Array.mapi (fun i cst -> ((mind,i),cst)) consts); consts let define_mutual_scheme kind internal names mind = match Hashtbl.find scheme_object_table kind with | _,IndividualSchemeFunction _ -> assert false | s,MutualSchemeFunction f -> define_mutual_scheme_base kind s f internal names mind let find_scheme kind (mind,i as ind) = try Stringmap.find kind (Indmap.find ind !scheme_map) with Not_found -> match Hashtbl.find scheme_object_table kind with | s,IndividualSchemeFunction f -> define_individual_scheme_base kind s f KernelSilent None ind | s,MutualSchemeFunction f -> (define_mutual_scheme_base kind s f KernelSilent [] mind).(i) let check_scheme kind ind = try let _ = Stringmap.find kind (Indmap.find ind !scheme_map) in true with Not_found -> false coq-8.4pl4/toplevel/classes.ml0000644000175000017500000002700612326224777015461 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let path = try Auto.PathHints [global_of_constr inst] with e when Errors.noncritical e -> Auto.PathAny in Flags.silently (fun () -> Auto.add_hints local [typeclasses_db] (Auto.HintsResolveEntry [pri, false, path, inst])) ()); Typeclasses.register_set_typeclass_transparency set_typeclass_transparency; Typeclasses.register_classes_transparent_state (fun () -> Auto.Hint_db.transparent_state (Auto.searchtable_map typeclasses_db)) let declare_class g = match global g with | ConstRef x -> Typeclasses.add_constant_class x | IndRef x -> Typeclasses.add_inductive_class x | _ -> user_err_loc (loc_of_reference g, "declare_class", Pp.str"Unsupported class type, only constants and inductives are allowed") (** TODO: add subinstances *) let existing_instance glob g = let c = global g in let instance = Typing.type_of (Global.env ()) Evd.empty (constr_of_global c) in let _, r = decompose_prod_assum instance in match class_of_constr r with | Some (_, (tc, _)) -> add_instance (new_instance tc None glob c) | None -> user_err_loc (loc_of_reference g, "declare_instance", Pp.str "Constant does not build instances of a declared type class.") let mismatched_params env n m = mismatched_ctx_inst env Parameters n m let mismatched_props env n m = mismatched_ctx_inst env Properties n m type binder_list = (identifier located * bool * constr_expr) list (* Declare everything in the parameters as implicit, and the class instance as well *) open Topconstr let type_ctx_instance evars env ctx inst subst = let rec aux (subst, instctx) l = function (na, b, t) :: ctx -> let t' = substl subst t in let c', l = match b with | None -> interp_casted_constr_evars evars env (List.hd l) t', List.tl l | Some b -> substl subst b, l in let d = na, Some c', t' in aux (c' :: subst, d :: instctx) l ctx | [] -> subst in aux (subst, []) inst (List.rev ctx) let refine_ref = ref (fun _ -> assert(false)) let id_of_class cl = match cl.cl_impl with | ConstRef kn -> let _,_,l = repr_con kn in id_of_label l | IndRef (kn,i) -> let mip = (Environ.lookup_mind kn (Global.env ())).Declarations.mind_packets in mip.(0).Declarations.mind_typename | _ -> assert false open Pp let ($$) g f = fun x -> g (f x) let instance_hook k pri global imps ?hook cst = Impargs.maybe_declare_manual_implicits false cst ~enriching:false imps; Typeclasses.declare_instance pri (not global) cst; (match hook with Some h -> h cst | None -> ()) let declare_instance_constant k pri global imps ?hook id term termtype = let cdecl = let kind = IsDefinition Instance in let entry = { const_entry_body = term; const_entry_secctx = None; const_entry_type = Some termtype; const_entry_opaque = false } in DefinitionEntry entry, kind in let kn = Declare.declare_constant id cdecl in Declare.definition_message id; instance_hook k pri global imps ?hook (ConstRef kn); id let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) ?(tac:Proof_type.tactic option) ?(hook:(global_reference -> unit) option) pri = let env = Global.env() in let evars = ref Evd.empty in let tclass, ids = match bk with | Implicit -> Implicit_quantifiers.implicit_application Idset.empty ~allow_partial:false (fun avoid (clname, (id, _, t)) -> match clname with | Some (cl, b) -> let t = CHole (Util.dummy_loc, None) in t, avoid | None -> failwith ("new instance: under-applied typeclass")) cl | Explicit -> cl, Idset.empty in let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in let k, cty, ctx', ctx, len, imps, subst = let impls, ((env', ctx), imps) = interp_context_evars evars env ctx in let c', imps' = interp_type_evars_impls ~impls ~evdref:evars ~fail_evar:false env' tclass in let len = List.length ctx in let imps = imps @ Impargs.lift_implicits len imps' in let ctx', c = decompose_prod_assum c' in let ctx'' = ctx' @ ctx in let cl, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in let _, args = List.fold_right (fun (na, b, t) (args, args') -> match b with | None -> (List.tl args, List.hd args :: args') | Some b -> (args, substl args' b :: args')) (snd cl.cl_context) (args, []) in cl, c', ctx', ctx, len, imps, args in let id = match snd instid with Name id -> let sp = Lib.make_path id in if Nametab.exists_cci sp then errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists."); id | Anonymous -> let i = Nameops.add_suffix (id_of_class k) "_instance_0" in Namegen.next_global_ident_away i (Termops.ids_of_context env) in let env' = push_rel_context ctx env in evars := Evarutil.nf_evar_map !evars; evars := resolve_typeclasses env !evars; let sigma = !evars in let subst = List.map (Evarutil.nf_evar sigma) subst in if abstract then begin if not (Lib.is_modtype ()) then error "Declare Instance while not in Module Type."; let _, ty_constr = instance_constructor k (List.rev subst) in let termtype = let t = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in Evarutil.nf_evar !evars t in Evarutil.check_evars env Evd.empty !evars termtype; let cst = Declare.declare_constant ~internal:Declare.KernelSilent id (Entries.ParameterEntry (None,termtype,None), Decl_kinds.IsAssumption Decl_kinds.Logical) in instance_hook k None global imps ?hook (ConstRef cst); id end else begin let props = match props with | Some (CRecord (loc, _, fs)) -> if List.length fs > List.length k.cl_props then mismatched_props env' (List.map snd fs) k.cl_props; Some (Inl fs) | Some t -> Some (Inr t) | None -> None in let subst = match props with | None -> if k.cl_props = [] then Some (Inl subst) else None | Some (Inr term) -> let c = interp_casted_constr_evars evars env' term cty in Some (Inr (c, subst)) | Some (Inl props) -> let get_id = function | Ident id' -> id' | _ -> errorlabstrm "new_instance" (Pp.str "Only local structures are handled") in let props, rest = List.fold_left (fun (props, rest) (id,b,_) -> if b = None then try let (loc_mid, c) = List.find (fun (id', _) -> Name (snd (get_id id')) = id) rest in let rest' = List.filter (fun (id', _) -> Name (snd (get_id id')) <> id) rest in let (loc, mid) = get_id loc_mid in List.iter (fun (n, _, x) -> if n = Name mid then Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) x) k.cl_projs; c :: props, rest' with Not_found -> (CHole (Util.dummy_loc, None) :: props), rest else props, rest) ([], props) k.cl_props in if rest <> [] then unbound_method env' k.cl_impl (get_id (fst (List.hd rest))) else Some (Inl (type_ctx_instance evars (push_rel_context ctx' env') k.cl_props props subst)) in evars := Evarutil.nf_evar_map !evars; let term, termtype = match subst with | None -> let termtype = it_mkProd_or_LetIn cty ctx in None, termtype | Some (Inl subst) -> let subst = List.fold_left2 (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst') [] subst (k.cl_props @ snd k.cl_context) in let app, ty_constr = instance_constructor k subst in let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in let term = Termops.it_mkLambda_or_LetIn (Option.get app) (ctx' @ ctx) in Some term, termtype | Some (Inr (def, subst)) -> let termtype = it_mkProd_or_LetIn cty ctx in let term = Termops.it_mkLambda_or_LetIn def ctx in Some term, termtype in let _ = evars := Evarutil.nf_evar_map !evars; evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env !evars; (* Try resolving fields that are typeclasses automatically. *) evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:false env !evars in let termtype = Evarutil.nf_evar !evars termtype in let term = Option.map (Evarutil.nf_evar !evars) term in let evm = undefined_evars !evars in Evarutil.check_evars env Evd.empty !evars termtype; if Evd.is_empty evm && term <> None then declare_instance_constant k pri global imps ?hook id (Option.get term) termtype else begin let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in Flags.silently (fun () -> Lemmas.start_proof id kind termtype (fun _ -> instance_hook k pri global imps ?hook); if term <> None then Pfedit.by (!refine_ref (evm, Option.get term)) else if Flags.is_auto_intros () then Pfedit.by (Refiner.tclDO len Tactics.intro); (match tac with Some tac -> Pfedit.by tac | None -> ())) (); Flags.if_verbose (msg $$ Printer.pr_open_subgoals) (); id end end let named_of_rel_context l = let acc, ctx = List.fold_right (fun (na, b, t) (subst, ctx) -> let id = match na with Anonymous -> raise (Invalid_argument "named_of_rel_context") | Name id -> id in let d = (id, Option.map (substl subst) b, substl subst t) in (mkVar id :: subst, d :: ctx)) l ([], []) in ctx let string_of_global r = string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty r) let context l = let env = Global.env() in let evars = ref Evd.empty in let _, ((env', fullctx), impls) = interp_context_evars evars env l in let fullctx = Evarutil.nf_rel_context_evar !evars fullctx in let ce t = Evarutil.check_evars env Evd.empty !evars t in List.iter (fun (n, b, t) -> Option.iter ce b; ce t) fullctx; let ctx = try named_of_rel_context fullctx with e when Errors.noncritical e -> error "Anonymous variables not allowed in contexts." in let fn (id, _, t) = if Lib.is_modtype () && not (Lib.sections_are_opened ()) then let cst = Declare.declare_constant ~internal:Declare.KernelSilent id (ParameterEntry (None,t,None), IsAssumption Logical) in match class_of_constr t with | Some (rels, (tc, args) as _cl) -> add_instance (Typeclasses.new_instance tc None false (ConstRef cst)) (* declare_subclasses (ConstRef cst) cl *) | None -> () else ( let impl = List.exists (fun (x,_) -> match x with ExplByPos (_, Some id') -> id = id' | _ -> false) impls in Command.declare_assumption false (Local (* global *), Definitional) t [] impl (* implicit *) None (* inline *) (dummy_loc, id)) in List.iter fn (List.rev ctx) coq-8.4pl4/toplevel/libtypes.ml0000644000175000017500000000573712326224777015666 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* obj = declare_object { (default_object "LIBTYPES") with load_function = (fun _ -> load); subst_function = (fun (s,t) -> subst s t); classify_function = (fun x -> Substitute x) } let update () = Lib.add_anonymous_leaf (input !defined_types) (* * Search interface *) let search_pattern pat = TypeDnet.search_pattern !all_types pat let search_concl pat = TypeDnet.search_concl !all_types pat let search_head_concl pat = TypeDnet.search_head_concl !all_types pat let search_eq_concl eq pat = TypeDnet.search_eq_concl !all_types eq pat let add typ gr = defined_types := TypeDnet.add typ gr !defined_types; all_types := TypeDnet.add typ gr !all_types (* let add_key = Profile.declare_profile "add" let add a b = Profile.profile1 add_key add a b *) (* * Hooks declaration *) let _ = Declare.add_cache_hook ( fun sp -> let gr = Nametab.global_of_path sp in let ty = Global.type_of_global gr in add ty gr ) let _ = Declaremods.set_end_library_hook update coq-8.4pl4/toplevel/coqtop.ml0000644000175000017500000003061212326224777015326 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (Coq_config.version,Coq_config.date) let print_header () = let (ver,rev) = (get_version_date ()) in Printf.printf "Welcome to Coq %s (%s)\n" ver rev; flush stdout let output_context = ref false let memory_stat = ref false let print_memory_stat () = if !memory_stat then Format.printf "total heap size = %d kbytes\n" (heap_size_kb ()) let _ = at_exit print_memory_stat let engagement = ref None let set_engagement c = engagement := Some c let engage () = match !engagement with Some c -> Global.set_engagement c | None -> () let set_batch_mode () = batch_mode := true let toplevel_default_name = make_dirpath [id_of_string "Top"] let toplevel_name = ref (Some toplevel_default_name) let set_toplevel_name dir = if dir = empty_dirpath then error "Need a non empty toplevel module name"; toplevel_name := Some dir let unset_toplevel_name () = toplevel_name := None let remove_top_ml () = Mltop.remove () let inputstate = ref None let set_inputstate s = inputstate:= Some s let inputstate () = match !inputstate with | Some "" -> () | Some s -> intern_state s | None -> intern_state "initial.coq" let outputstate = ref "" let set_outputstate s = outputstate:=s let outputstate () = if !outputstate <> "" then extern_state !outputstate let set_default_include d = push_include (d,Nameops.default_root_prefix) let set_include d p = let p = dirpath_of_string p in push_include (d,p) let set_rec_include d p = let p = dirpath_of_string p in push_rec_include(d,p) let load_vernacular_list = ref ([] : (string * bool) list) let add_load_vernacular verb s = load_vernacular_list := ((make_suffix s ".v"),verb) :: !load_vernacular_list let load_vernacular () = List.iter (fun (s,b) -> if Flags.do_beautify () then with_option beautify_file (Vernac.load_vernac b) s else Vernac.load_vernac b s) (List.rev !load_vernacular_list) let load_vernacular_obj = ref ([] : string list) let add_vernac_obj s = load_vernacular_obj := s :: !load_vernacular_obj let load_vernac_obj () = List.iter (fun f -> Library.require_library_from_file None f None) (List.rev !load_vernacular_obj) let require_list = ref ([] : string list) let add_require s = require_list := s :: !require_list let require () = List.iter (fun s -> Library.require_library_from_file None s (Some false)) (List.rev !require_list) let compile_list = ref ([] : (bool * string) list) let add_compile verbose s = set_batch_mode (); Flags.make_silent true; compile_list := (verbose,s) :: !compile_list let compile_files () = let init_state = States.freeze() in let coqdoc_init_state = Dumpglob.coqdoc_freeze () in List.iter (fun (v,f) -> States.unfreeze init_state; Dumpglob.coqdoc_unfreeze coqdoc_init_state; if Flags.do_beautify () then with_option beautify_file (Vernac.compile v) f else Vernac.compile v f) (List.rev !compile_list) (*s options for the virtual machine *) let boxed_val = ref false let use_vm = ref false let set_vm_opt () = Vm.set_transp_values (not !boxed_val); Vconv.set_use_vm !use_vm (*s Parsing of the command line. We no longer use [Arg.parse], in order to use share [Usage.print_usage] between coqtop and coqc. *) let usage () = if !batch_mode then Usage.print_usage_coqc () else Usage.print_usage_coqtop () ; flush stderr ; exit 1 let warning s = msg_warning (str s) let ide_slave = ref false let filter_opts = ref false let verb_compat_ntn = ref false let no_compat_ntn = ref false let parse_args arglist = let glob_opt = ref false in let rec parse = function | [] -> [] | "-with-geoproof" :: s :: rem -> if s = "yes" then Coq_config.with_geoproof := true else if s = "no" then Coq_config.with_geoproof := false else usage (); parse rem | "-impredicative-set" :: rem -> set_engagement Declarations.ImpredicativeSet; parse rem | ("-I"|"-include") :: d :: "-as" :: p :: rem -> set_include d p; parse rem | ("-I"|"-include") :: d :: "-as" :: [] -> usage () | ("-I"|"-include") :: d :: rem -> set_default_include d; parse rem | ("-I"|"-include") :: [] -> usage () | "-R" :: d :: "-as" :: p :: rem -> set_rec_include d p;parse rem | "-R" :: d :: "-as" :: [] -> usage () | "-R" :: d :: p :: rem -> set_rec_include d p;parse rem | "-R" :: ([] | [_]) -> usage () | "-top" :: d :: rem -> set_toplevel_name (dirpath_of_string d); parse rem | "-top" :: [] -> usage () | "-exclude-dir" :: f :: rem -> exclude_search_in_dirname f; parse rem | "-exclude-dir" :: [] -> usage () | "-notop" :: rem -> unset_toplevel_name (); parse rem | "-q" :: rem -> no_load_rc (); parse rem | "-opt" :: rem -> warning "option -opt deprecated, call with .opt suffix\n"; parse rem | "-byte" :: rem -> warning "option -byte deprecated, call with .byte suffix\n"; parse rem | "-full" :: rem -> warning "option -full deprecated\n"; parse rem | "-batch" :: rem -> set_batch_mode (); parse rem | "-boot" :: rem -> boot := true; no_load_rc (); parse rem | "-quality" :: rem -> term_quality := true; no_load_rc (); parse rem | "-outputstate" :: s :: rem -> Flags.load_proofs := Flags.Force; set_outputstate s; parse rem | "-outputstate" :: [] -> usage () | "-nois" :: rem -> set_inputstate ""; parse rem | ("-inputstate"|"-is") :: s :: rem -> set_inputstate s; parse rem | ("-inputstate"|"-is") :: [] -> usage () | "-load-ml-object" :: f :: rem -> Mltop.dir_ml_load f; parse rem | "-load-ml-object" :: [] -> usage () | "-load-ml-source" :: f :: rem -> Mltop.dir_ml_use f; parse rem | "-load-ml-source" :: [] -> usage () | ("-load-vernac-source"|"-l") :: f :: rem -> add_load_vernacular false f; parse rem | ("-load-vernac-source"|"-l") :: [] -> usage () | ("-load-vernac-source-verbose"|"-lv") :: f :: rem -> add_load_vernacular true f; parse rem | ("-load-vernac-source-verbose"|"-lv") :: [] -> usage () | "-load-vernac-object" :: f :: rem -> add_vernac_obj f; parse rem | "-load-vernac-object" :: [] -> usage () | "-dump-glob" :: "stdout" :: rem -> Dumpglob.dump_to_stdout (); glob_opt := true; parse rem (* À ne pas documenter : l'option 'stdout' n'ÃĐtant ÃĐventuellement utile que pour le debugging... *) | "-dump-glob" :: f :: rem -> Dumpglob.dump_into_file f; glob_opt := true; parse rem | "-dump-glob" :: [] -> usage () | ("-no-glob" | "-noglob") :: rem -> Dumpglob.noglob (); glob_opt := true; parse rem | "-require" :: f :: rem -> add_require f; parse rem | "-require" :: [] -> usage () | "-compile" :: f :: rem -> add_compile false f; if not !glob_opt then Dumpglob.dump_to_dotglob (); parse rem | "-compile" :: [] -> usage () | "-compile-verbose" :: f :: rem -> add_compile true f; if not !glob_opt then Dumpglob.dump_to_dotglob (); parse rem | "-compile-verbose" :: [] -> usage () | "-force-load-proofs" :: rem -> Flags.load_proofs := Flags.Force; parse rem | "-lazy-load-proofs" :: rem -> Flags.load_proofs := Flags.Lazy; parse rem | "-dont-load-proofs" :: rem -> Flags.load_proofs := Flags.Dont; parse rem | "-beautify" :: rem -> make_beautify true; parse rem | "-unsafe" :: f :: rem -> add_unsafe f; parse rem | "-unsafe" :: [] -> usage () | "-debug" :: rem -> set_debug (); parse rem | "-compat" :: v :: rem -> Flags.compat_version := get_compat_version v; parse rem | "-compat" :: [] -> usage () | "-verbose-compat-notations" :: rem -> verb_compat_ntn := true; parse rem | "-no-compat-notations" :: rem -> no_compat_ntn := true; parse rem | "-vm" :: rem -> use_vm := true; parse rem | "-emacs" :: rem -> Flags.print_emacs := true; Pp.make_pp_emacs(); Vernacentries.qed_display_script := false; parse rem | "-emacs-U" :: rem -> warning "Obsolete option \"-emacs-U\", use -emacs instead."; parse ("-emacs" :: rem) | "-unicode" :: rem -> add_require "Utf8_core"; parse rem | "-coqlib" :: d :: rem -> Flags.coqlib_spec:=true; Flags.coqlib:=d; parse rem | "-coqlib" :: [] -> usage () | "-where" :: _ -> print_endline (Envars.coqlib ()); exit (if !filter_opts then 2 else 0) | ("-config"|"--config") :: _ -> Usage.print_config (); exit (if !filter_opts then 2 else 0) | ("-quiet"|"-silent") :: rem -> Flags.make_silent true; parse rem | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () | ("-v"|"--version") :: _ -> Usage.version (if !filter_opts then 2 else 0) | "-init-file" :: f :: rem -> set_rcfile f; parse rem | "-init-file" :: [] -> usage () | "-notactics" :: rem -> warning "Obsolete option \"-notactics\"."; remove_top_ml (); parse rem | "-just-parsing" :: rem -> Vernac.just_parsing := true; parse rem | ("-m" | "--memory") :: rem -> memory_stat := true; parse rem | "-xml" :: rem -> Flags.xml_export := true; parse rem | "-output-context" :: rem -> output_context := true; parse rem (* Scanned in Flags. *) | "-v7" :: rem -> error "This version of Coq does not support v7 syntax" | "-v8" :: rem -> parse rem | "-no-hash-consing" :: rem -> Flags.hash_cons_proofs := false; parse rem | "-ideslave" :: rem -> ide_slave := true; parse rem | "-filteropts" :: rem -> filter_opts := true; parse rem | s :: rem -> if !filter_opts then s :: (parse rem) else (prerr_endline ("Don't know what to do with " ^ s); usage ()) in try parse arglist with | UserError(_,s) as e -> begin try Stream.empty s; exit 1 with Stream.Failure -> msgnl (Errors.print e); exit 1 end | any -> begin msgnl (Errors.print any); exit 1 end let init arglist = Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) Lib.init(); (* Default Proofb Mode starts with an alternative default. *) Goptions.set_string_option_value ["Default";"Proof";"Mode"] "Classic"; begin try let foreign_args = parse_args arglist in if !filter_opts then (print_string (String.concat "\n" foreign_args); exit 0); if !ide_slave then begin Flags.make_silent true; Ide_slave.init_stdout () end; if_verbose print_header (); init_load_path (); inputstate (); Mltop.init_known_plugins (); set_vm_opt (); engage (); (* Be careful to set these variables after the inputstate *) Syntax_def.set_verbose_compat_notations !verb_compat_ntn; Syntax_def.set_compat_notations (not !no_compat_ntn); if (not !batch_mode|| !compile_list=[]) && Global.env_is_empty() then Option.iter Declaremods.start_library !toplevel_name; init_library_roots (); load_vernac_obj (); require (); load_rcfile(); load_vernacular (); compile_files (); outputstate () with any -> flush_all(); if not !batch_mode then message "Error during initialization:"; msgnl (Toplevel.print_toplevel_error any); exit 1 end; if !batch_mode then (flush_all(); if !output_context then Pp.ppnl (with_option raw_print Prettyp.print_full_pure_context ()); Profile.print_profile (); exit 0); (* We initialize the command history stack with a first entry *) Backtrack.mark_command Vernacexpr.VernacNop let init_toplevel = init let start () = init_toplevel (List.tl (Array.to_list Sys.argv)); if !ide_slave then Ide_slave.loop () else Toplevel.loop(); (* Initialise and launch the Ocaml toplevel *) Coqinit.init_ocaml_path(); Mltop.ocaml_toploop(); exit 1 (* [Coqtop.start] will be called by the code produced by coqmktop *) coq-8.4pl4/toplevel/discharge.mli0000644000175000017500000000125512326224777016124 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* work_list -> mutual_inductive_body -> mutual_inductive_entry coq-8.4pl4/toplevel/whelp.ml40000644000175000017500000001711312326224777015225 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* !whelp_server_name); optwrite = (fun s -> whelp_server_name := s) } let _ = declare_string_option { optsync = false; optdepr = false; optname = "Whelp getter"; optkey = ["Whelp";"Getter"]; optread = (fun () -> !getter_server_name); optwrite = (fun s -> getter_server_name := s) } let make_whelp_request req c = !whelp_server_name ^ "/apply?xmluri=" ^ !getter_server_name ^ "/getempty¶m.profile=firewall&profile=firewall¶m.keys=d_c%2CC1%2CHC2%2CL¶m.embedkeys=d_c%2CTC1%2CHC2%2CL¶m.thkeys=T1%2CT2%2CL%2CE¶m.prooftreekeys=HAT%2CG%2CHAO%2CL¶m.media-type=text%2Fhtml¶m.thmedia-type=&prooftreemedia-type=¶m.doctype-public=¶m.encoding=¶m.thencoding=¶m.prooftreeencoding=&advanced=no&keys=S%2CT1%2CT2%2CL%2CRT%2CE¶m.expression=" ^ c ^ "¶m.action=" ^ req let b = Buffer.create 16 let url_char c = if 'A' <= c & c <= 'Z' or 'a' <= c & c <= 'z' or '0' <= c & c <= '9' or c ='.' then Buffer.add_char b c else Buffer.add_string b (Printf.sprintf "%%%2X" (Char.code c)) let url_string s = String.iter url_char s let rec url_list_with_sep sep f = function | [] -> () | [a] -> f a | a::l -> f a; url_string sep; url_list_with_sep sep f l let url_id id = url_string (string_of_id id) let uri_of_dirpath dir = url_string "cic:/"; url_list_with_sep "/" url_id (List.rev dir) let error_whelp_unknown_reference ref = let qid = Nametab.shortest_qualid_of_global Idset.empty ref in errorlabstrm "" (strbrk "Definitions of the current session, like " ++ pr_qualid qid ++ strbrk ", are not supported in Whelp.") let uri_of_repr_kn ref (mp,dir,l) = match mp with | MPfile sl -> uri_of_dirpath (id_of_label l :: repr_dirpath dir @ repr_dirpath sl) | _ -> error_whelp_unknown_reference ref let url_paren f l = url_char '('; f l; url_char ')' let url_bracket f l = url_char '['; f l; url_char ']' let whelp_of_glob_sort = function | GProp Null -> "Prop" | GProp Pos -> "Set" | GType _ -> "Type" let uri_int n = Buffer.add_string b (string_of_int n) let uri_of_ind_pointer l = url_string ".ind#xpointer"; url_paren (url_list_with_sep "/" uri_int) l let uri_of_global ref = match ref with | VarRef id -> error ("Unknown Whelp reference: "^(string_of_id id)^".") | ConstRef cst -> uri_of_repr_kn ref (repr_con cst); url_string ".con" | IndRef (kn,i) -> uri_of_repr_kn ref (repr_mind kn); uri_of_ind_pointer [1;i+1] | ConstructRef ((kn,i),j) -> uri_of_repr_kn ref (repr_mind kn); uri_of_ind_pointer [1;i+1;j] let whelm_special = id_of_string "WHELM_ANON_VAR" let url_of_name = function | Name id -> url_id id | Anonymous -> url_id whelm_special (* No anon id in Whelp *) let uri_of_binding f (id,c) = url_id id; url_string "\\Assign "; f c let uri_params f = function | [] -> () | l -> url_string "\\subst"; url_bracket (url_list_with_sep ";" (uri_of_binding f)) l let get_discharged_hyp_names sp = List.map basename (get_discharged_hyps sp) let section_parameters = function | GRef (_,(ConstructRef ((induri,_),_) | IndRef (induri,_))) -> get_discharged_hyp_names (path_of_global (IndRef(induri,0))) | GRef (_,(ConstRef cst as ref)) -> get_discharged_hyp_names (path_of_global ref) | _ -> [] let merge vl al = let rec aux acc = function | ([],l) | (_,([] as l)) -> List.rev acc, l | (v::vl,a::al) -> aux ((v,a)::acc) (vl,al) in aux [] (vl,al) let rec uri_of_constr c = match c with | GVar (_,id) -> url_id id | GRef (_,ref) -> uri_of_global ref | GHole _ | GEvar _ -> url_string "?" | GSort (_,s) -> url_string (whelp_of_glob_sort s) | _ -> url_paren (fun () -> match c with | GApp (_,f,args) -> let inst,rest = merge (section_parameters f) args in uri_of_constr f; url_char ' '; uri_params uri_of_constr inst; url_list_with_sep " " uri_of_constr rest | GLambda (_,na,k,ty,c) -> url_string "\\lambda "; url_of_name na; url_string ":"; uri_of_constr ty; url_string "."; uri_of_constr c | GProd (_,Anonymous,k,ty,c) -> uri_of_constr ty; url_string "\\to "; uri_of_constr c | GProd (_,Name id,k,ty,c) -> url_string "\\forall "; url_id id; url_string ":"; uri_of_constr ty; url_string "."; uri_of_constr c | GLetIn (_,na,b,c) -> url_string "let "; url_of_name na; url_string "\\def "; uri_of_constr b; url_string " in "; uri_of_constr c | GCast (_,c, CastConv (_,t)) -> uri_of_constr c; url_string ":"; uri_of_constr t | GRec _ | GIf _ | GLetTuple _ | GCases _ -> error "Whelp does not support pattern-matching and (co-)fixpoint." | GVar _ | GRef _ | GHole _ | GEvar _ | GSort _ | GCast (_,_, CastCoerce) -> anomaly "Written w/o parenthesis" | GPatVar _ -> anomaly "Found constructors not supported in constr") () let make_string f x = Buffer.reset b; f x; Buffer.contents b let send_whelp req s = let url = make_whelp_request req s in let command = subst_command_placeholder browser_cmd_fmt url in let _ = run_command (fun x -> x) print_string command in () let whelp_constr req c = let c = detype false [whelm_special] [] c in send_whelp req (make_string uri_of_constr c) let whelp_constr_expr req c = let (sigma,env)= Lemmas.get_current_context () in let _,c = interp_open_constr sigma env c in whelp_constr req c let whelp_locate s = send_whelp "locate" s let whelp_elim ind = send_whelp "elim" (make_string uri_of_global (IndRef ind)) let on_goal f = let { Evd.it=goals ; sigma=sigma } = Proof.V82.subgoals (get_pftreestate ()) in let gls = { Evd.it=List.hd goals ; sigma = sigma } in f (Termops.it_mkNamedProd_or_LetIn (pf_concl gls) (pf_hyps gls)) type whelp_request = | Locate of string | Elim of inductive | Constr of string * constr let whelp = function | Locate s -> whelp_locate s | Elim ind -> whelp_elim ind | Constr (s,c) -> whelp_constr s c VERNAC ARGUMENT EXTEND whelp_constr_request | [ "Match" ] -> [ "match" ] | [ "Instance" ] -> [ "instance" ] END VERNAC COMMAND EXTEND Whelp | [ "Whelp" "Locate" string(s) ] -> [ whelp_locate s ] | [ "Whelp" "Locate" preident(s) ] -> [ whelp_locate s ] | [ "Whelp" "Elim" global(r) ] -> [ whelp_elim (Smartlocate.global_inductive_with_alias r) ] | [ "Whelp" whelp_constr_request(req) constr(c) ] -> [ whelp_constr_expr req c] END VERNAC COMMAND EXTEND WhelpHint | [ "Whelp" "Hint" constr(c) ] -> [ whelp_constr_expr "hint" c ] | [ "Whelp" "Hint" ] -> [ on_goal (whelp_constr "hint") ] END coq-8.4pl4/toplevel/cerrors.mli0000644000175000017500000000153712326224777015655 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* std_ppcmds (** Pre-explain a vernac interpretation error *) val process_vernac_interp_error : exn -> exn (** General explain function. Should not be used directly now, see instead function [Errors.print] and variants *) val explain_exn_default : exn -> std_ppcmds coq-8.4pl4/toplevel/vernacinterp.mli0000644000175000017500000000156312326224777016675 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* exn val vinterp_add : string -> (raw_generic_argument list -> unit -> unit) -> unit val overwriting_vinterp_add : string -> (raw_generic_argument list -> unit -> unit) -> unit val vinterp_init : unit -> unit val call : string * raw_generic_argument list -> unit coq-8.4pl4/toplevel/coqinit.mli0000644000175000017500000000166312326224777015644 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val set_rcfile : string -> unit val no_load_rc : unit -> unit val load_rcfile : unit -> unit val push_include : string * Names.dir_path -> unit val push_rec_include : string * Names.dir_path -> unit val init_load_path : unit -> unit val init_library_roots : unit -> unit val init_ocaml_path : unit -> unit val get_compat_version : string -> Flags.compat_version coq-8.4pl4/toplevel/command.ml0000644000175000017500000006111012326224777015434 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* mkLambda (x,t,under_binders (push_rel (x,None,t) env) f (n-1) c) | LetIn (x,b,t,c) -> mkLetIn (x,b,t,under_binders (push_rel (x,Some b,t) env) f (n-1) c) | _ -> assert false let rec complete_conclusion a cs = function | CProdN (loc,bl,c) -> CProdN (loc,bl,complete_conclusion a cs c) | CLetIn (loc,b,t,c) -> CLetIn (loc,b,t,complete_conclusion a cs c) | CHole (loc, k) -> let (has_no_args,name,params) = a in if not has_no_args then user_err_loc (loc,"", strbrk"Cannot infer the non constant arguments of the conclusion of " ++ pr_id cs ++ str "."); let args = List.map (fun id -> CRef(Ident(loc,id))) params in CAppExpl (loc,(None,Ident(loc,name)),List.rev args) | c -> c (* Commands of the interface *) (* 1| Constant definitions *) let red_constant_entry n ce = function | None -> ce | Some red -> let body = ce.const_entry_body in { ce with const_entry_body = under_binders (Global.env()) (fst (reduction_of_red_expr red)) n body } let interp_definition bl red_option c ctypopt = let env = Global.env() in let evdref = ref Evd.empty in let impls, ((env_bl, ctx), imps1) = interp_context_evars evdref env bl in let nb_args = List.length ctx in let imps,ce = match ctypopt with None -> let c, imps2 = interp_constr_evars_impls ~impls ~evdref ~fail_evar:false env_bl c in let body = nf_evar !evdref (it_mkLambda_or_LetIn c ctx) in check_evars env Evd.empty !evdref body; imps1@(Impargs.lift_implicits nb_args imps2), { const_entry_body = body; const_entry_secctx = None; const_entry_type = None; const_entry_opaque = false } | Some ctyp -> let ty, impsty = interp_type_evars_impls ~impls ~evdref ~fail_evar:false env_bl ctyp in let c, imps2 = interp_casted_constr_evars_impls ~impls ~evdref ~fail_evar:false env_bl c ty in let body = nf_evar !evdref (it_mkLambda_or_LetIn c ctx) in let typ = nf_evar !evdref (it_mkProd_or_LetIn ty ctx) in check_evars env Evd.empty !evdref body; check_evars env Evd.empty !evdref typ; (* Check that all implicit arguments inferable from the term is inferable from the type *) if not (try List.for_all (fun (key,va) -> List.assoc key impsty = va) imps2 with Not_found -> false) then warn (str "Implicit arguments declaration relies on type." ++ spc () ++ str "The term declares more implicits than the type here."); imps1@(Impargs.lift_implicits nb_args impsty), { const_entry_body = body; const_entry_secctx = None; const_entry_type = Some typ; const_entry_opaque = false } in red_constant_entry (rel_context_length ctx) ce red_option, imps let declare_global_definition ident ce local k imps = let kn = declare_constant ident (DefinitionEntry ce,IsDefinition k) in let gr = ConstRef kn in maybe_declare_manual_implicits false gr imps; if local = Local && Flags.is_verbose() then msg_warning (pr_id ident ++ str" is declared as a global definition"); definition_message ident; Autoinstance.search_declaration (ConstRef kn); gr let declare_definition_hook = ref ignore let set_declare_definition_hook = (:=) declare_definition_hook let get_declare_definition_hook () = !declare_definition_hook let declare_definition ident (local,k) ce imps hook = !declare_definition_hook ce; let r = match local with | Local when Lib.sections_are_opened () -> let c = SectionLocalDef(ce.const_entry_body ,ce.const_entry_type,false) in let _ = declare_variable ident (Lib.cwd(),c,IsDefinition k) in definition_message ident; if Pfedit.refining () then Flags.if_warn msg_warning (str"Local definition " ++ pr_id ident ++ str" is not visible from current goals"); VarRef ident | (Global|Local) -> declare_global_definition ident ce local k imps in hook local r (* 2| Variable/Hypothesis/Parameter/Axiom declarations *) let declare_assumption is_coe (local,kind) c imps impl nl (_,ident) = let r = match local with | Local when Lib.sections_are_opened () -> let _ = declare_variable ident (Lib.cwd(), SectionLocalAssum (c,impl), IsAssumption kind) in assumption_message ident; if is_verbose () & Pfedit.refining () then msgerrnl (str"Warning: Variable " ++ pr_id ident ++ str" is not visible from current goals"); let r = VarRef ident in Typeclasses.declare_instance None true r; r | (Global|Local) -> let kn = declare_constant ident (ParameterEntry (None,c,nl), IsAssumption kind) in let gr = ConstRef kn in maybe_declare_manual_implicits false gr imps; assumption_message ident; if local=Local & Flags.is_verbose () then msg_warning (pr_id ident ++ str" is declared as a parameter" ++ str" because it is at a global level"); Autoinstance.search_declaration (ConstRef kn); Typeclasses.declare_instance None false gr; gr in if is_coe then Class.try_add_new_coercion r local let declare_assumptions_hook = ref ignore let set_declare_assumptions_hook = (:=) declare_assumptions_hook let interp_assumption bl c = let c = prod_constr_expr c bl in let env = Global.env () in interp_type_evars_impls env c let declare_assumptions idl is_coe k c imps impl_is_on nl = !declare_assumptions_hook c; List.iter (declare_assumption is_coe k c imps impl_is_on nl) idl (* 3a| Elimination schemes for mutual inductive definitions *) (* 3b| Mutual inductive definitions *) let push_named_types env idl tl = List.fold_left2 (fun env id t -> Environ.push_named (id,None,t) env) env idl tl let push_types env idl tl = List.fold_left2 (fun env id t -> Environ.push_rel (Name id,None,t) env) env idl tl type structured_one_inductive_expr = { ind_name : identifier; ind_arity : constr_expr; ind_lc : (identifier * constr_expr) list } type structured_inductive_expr = local_binder list * structured_one_inductive_expr list let minductive_message = function | [] -> error "No inductive definition." | [x] -> (pr_id x ++ str " is defined") | l -> hov 0 (prlist_with_sep pr_comma pr_id l ++ spc () ++ str "are defined") let check_all_names_different indl = let ind_names = List.map (fun ind -> ind.ind_name) indl in let cstr_names = list_map_append (fun ind -> List.map fst ind.ind_lc) indl in let l = list_duplicates ind_names in if l <> [] then raise (InductiveError (SameNamesTypes (List.hd l))); let l = list_duplicates cstr_names in if l <> [] then raise (InductiveError (SameNamesConstructors (List.hd l))); let l = list_intersect ind_names cstr_names in if l <> [] then raise (InductiveError (SameNamesOverlap l)) let mk_mltype_data evdref env assums arity indname = let is_ml_type = is_sort env !evdref arity in (is_ml_type,indname,assums) let prepare_param = function | (na,None,t) -> out_name na, LocalAssum t | (na,Some b,_) -> out_name na, LocalDef b let interp_ind_arity evdref env ind = interp_type_evars_impls ~evdref env ind.ind_arity let interp_cstrs evdref env impls mldata arity ind = let cnames,ctyps = List.split ind.ind_lc in (* Complete conclusions of constructor types if given in ML-style syntax *) let ctyps' = List.map2 (complete_conclusion mldata) cnames ctyps in (* Interpret the constructor types *) let ctyps'', cimpls = List.split (List.map (interp_type_evars_impls ~evdref env ~impls) ctyps') in (cnames, ctyps'', cimpls) let interp_mutual_inductive (paramsl,indl) notations finite = check_all_names_different indl; let env0 = Global.env() in let evdref = ref Evd.empty in let _, ((env_params, ctx_params), userimpls) = interp_context_evars evdref env0 paramsl in let indnames = List.map (fun ind -> ind.ind_name) indl in (* Names of parameters as arguments of the inductive type (defs removed) *) let assums = List.filter(fun (_,b,_) -> b=None) ctx_params in let params = List.map (fun (na,_,_) -> out_name na) assums in (* Interpret the arities *) let arities = List.map (interp_ind_arity evdref env_params) indl in let fullarities = List.map (fun (c, _) -> it_mkProd_or_LetIn c ctx_params) arities in let env_ar = push_types env0 indnames fullarities in let env_ar_params = push_rel_context ctx_params env_ar in (* Compute interpretation metadatas *) let indimpls = List.map (fun (_, impls) -> userimpls @ lift_implicits (rel_context_nhyps ctx_params) impls) arities in let arities = List.map fst arities in let impls = compute_internalization_env env0 (Inductive params) indnames fullarities indimpls in let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in let constructors = Metasyntax.with_syntax_protection (fun () -> (* Temporary declaration of notations and scopes *) List.iter (Metasyntax.set_notation_for_interpretation impls) notations; (* Interpret the constructor types *) list_map3 (interp_cstrs evdref env_ar_params impls) mldatas arities indl) () in (* Instantiate evars and check all are resolved *) let evd = consider_remaining_unif_problems env_params !evdref in let evd = Typeclasses.resolve_typeclasses ~filter:(Typeclasses.no_goals) ~fail:true env_params evd in let sigma = evd in let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map (nf_evar sigma) cl,impsl)) constructors in let ctx_params = Sign.map_rel_context (nf_evar sigma) ctx_params in let arities = List.map (nf_evar sigma) arities in List.iter (check_evars env_params Evd.empty evd) arities; Sign.iter_rel_context (check_evars env0 Evd.empty evd) ctx_params; List.iter (fun (_,ctyps,_) -> List.iter (check_evars env_ar_params Evd.empty evd) ctyps) constructors; (* Build the inductive entries *) let entries = list_map3 (fun ind arity (cnames,ctypes,cimpls) -> { mind_entry_typename = ind.ind_name; mind_entry_arity = arity; mind_entry_consnames = cnames; mind_entry_lc = ctypes }) indl arities constructors in let impls = let len = rel_context_nhyps ctx_params in List.map2 (fun indimpls (_,_,cimpls) -> indimpls, List.map (fun impls -> userimpls @ (lift_implicits len impls)) cimpls) indimpls constructors in (* Build the mutual inductive entry *) { mind_entry_params = List.map prepare_param ctx_params; mind_entry_record = false; mind_entry_finite = finite; mind_entry_inds = entries }, impls (* Very syntactical equality *) let eq_local_binder d1 d2 = match d1,d2 with | LocalRawAssum (nal1,k1,c1), LocalRawAssum (nal2,k2,c2) -> List.length nal1 = List.length nal2 && k1 = k2 && List.for_all2 (fun (_,na1) (_,na2) -> na1 = na2) nal1 nal2 && Constrextern.is_same_type c1 c2 | LocalRawDef ((_,id1),c1), LocalRawDef ((_,id2),c2) -> id1 = id2 && Constrextern.is_same_type c1 c2 | _ -> false let eq_local_binders bl1 bl2 = List.length bl1 = List.length bl2 && List.for_all2 eq_local_binder bl1 bl2 let extract_coercions indl = let mkqid (_,((_,id),_)) = qualid_of_ident id in let extract lc = List.filter (fun (iscoe,_) -> iscoe) lc in List.map mkqid (List.flatten(List.map (fun (_,_,_,lc) -> extract lc) indl)) let extract_params indl = let paramsl = List.map (fun (_,params,_,_) -> params) indl in match paramsl with | [] -> anomaly "empty list of inductive types" | params::paramsl -> if not (List.for_all (eq_local_binders params) paramsl) then error "Parameters should be syntactically the same for each inductive type."; params let extract_inductive indl = List.map (fun ((_,indname),_,ar,lc) -> { ind_name = indname; ind_arity = Option.cata (fun x -> x) (CSort (dummy_loc, Glob_term.GType None)) ar; ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc }) indl let extract_mutual_inductive_declaration_components indl = let indl,ntnl = List.split indl in let params = extract_params indl in let coes = extract_coercions indl in let indl = extract_inductive indl in (params,indl), coes, List.flatten ntnl let declare_mutual_inductive_with_eliminations isrecord mie impls = let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in let (_,kn) = declare_mind isrecord mie in let mind = Global.mind_of_delta_kn kn in list_iter_i (fun i (indimpls, constrimpls) -> let ind = (mind,i) in Autoinstance.search_declaration (IndRef ind); maybe_declare_manual_implicits false (IndRef ind) indimpls; list_iter_i (fun j impls -> (* Autoinstance.search_declaration (ConstructRef (ind,j));*) maybe_declare_manual_implicits false (ConstructRef (ind, succ j)) impls) constrimpls) impls; if_verbose ppnl (minductive_message names); declare_default_schemes mind; mind open Vernacexpr type one_inductive_impls = Impargs.manual_explicitation list (* for inds *)* Impargs.manual_explicitation list list (* for constrs *) type one_inductive_expr = lident * local_binder list * constr_expr option * constructor_expr list let do_mutual_inductive indl finite = let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in (* Interpret the types *) let mie,impls = interp_mutual_inductive indl ntns finite in (* Declare the mutual inductive block with its associated schemes *) ignore (declare_mutual_inductive_with_eliminations UserVerbose mie impls); (* Declare the possible notations of inductive types *) List.iter Metasyntax.add_notation_interpretation ntns; (* Declare the coercions *) List.iter (fun qid -> Class.try_add_new_coercion (locate qid) Global) coes (* 3c| Fixpoints and co-fixpoints *) (* An (unoptimized) function that maps preorders to partial orders... Input: a list of associations (x,[y1;...;yn]), all yi distincts and different of x, meaning x<=y1, ..., x<=yn Output: a list of associations (x,Inr [y1;...;yn]), collecting all distincts yi greater than x, _or_, (x, Inl y) meaning that x is in the same class as y (in which case, x occurs nowhere else in the association map) partial_order : ('a * 'a list) list -> ('a * ('a,'a list) union) list *) let rec partial_order = function | [] -> [] | (x,xge)::rest -> let rec browse res xge' = function | [] -> let res = List.map (function | (z, Inr zge) when List.mem x zge -> (z, Inr (list_union zge xge')) | r -> r) res in (x,Inr xge')::res | y::xge -> let rec link y = try match List.assoc y res with | Inl z -> link z | Inr yge -> if List.mem x yge then let res = List.remove_assoc y res in let res = List.map (function | (z, Inl t) -> if t = y then (z, Inl x) else (z, Inl t) | (z, Inr zge) -> if List.mem y zge then (z, Inr (list_add_set x (list_remove y zge))) else (z, Inr zge)) res in browse ((y,Inl x)::res) xge' (list_union xge (list_remove x yge)) else browse res (list_add_set y (list_union xge' yge)) xge with Not_found -> browse res (list_add_set y xge') xge in link y in browse (partial_order rest) [] xge let non_full_mutual_message x xge y yge isfix rest = let reason = if List.mem x yge then string_of_id y^" depends on "^string_of_id x^" but not conversely" else if List.mem y xge then string_of_id x^" depends on "^string_of_id y^" but not conversely" else string_of_id y^" and "^string_of_id x^" are not mutually dependent" in let e = if rest <> [] then "e.g.: "^reason else reason in let k = if isfix then "fixpoint" else "cofixpoint" in let w = if isfix then strbrk "Well-foundedness check may fail unexpectedly." ++ fnl() else mt () in strbrk ("Not a fully mutually defined "^k) ++ fnl () ++ strbrk ("("^e^").") ++ fnl () ++ w let check_mutuality env isfix fixl = let names = List.map fst fixl in let preorder = List.map (fun (id,def) -> (id, List.filter (fun id' -> id<>id' & occur_var env id' def) names)) fixl in let po = partial_order preorder in match List.filter (function (_,Inr _) -> true | _ -> false) po with | (x,Inr xge)::(y,Inr yge)::rest -> if_warn msg_warning (non_full_mutual_message x xge y yge isfix rest) | _ -> () type structured_fixpoint_expr = { fix_name : identifier; fix_annot : identifier located option; fix_binders : local_binder list; fix_body : constr_expr option; fix_type : constr_expr } let interp_fix_context evdref env isfix fix = let before, after = if isfix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in let impl_env, ((env', ctx), imps) = interp_context_evars evdref env before in let impl_env', ((env'', ctx'), imps') = interp_context_evars ~impl_env evdref env' after in let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) let interp_fix_ccl evdref impls (env,_) fix = interp_type_evars_impls ~impls ~evdref ~fail_evar:false env fix.fix_type let interp_fix_body evdref env_rec impls (_,ctx) fix ccl = Option.map (fun body -> let env = push_rel_context ctx env_rec in let body = interp_casted_constr_evars evdref env ~impls body ccl in it_mkLambda_or_LetIn body ctx) fix.fix_body let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx let declare_fix kind f def t imps = let ce = { const_entry_body = def; const_entry_secctx = None; const_entry_type = Some t; const_entry_opaque = false } in let kn = declare_constant f (DefinitionEntry ce,IsDefinition kind) in let gr = ConstRef kn in Autoinstance.search_declaration (ConstRef kn); maybe_declare_manual_implicits false gr imps; gr let prepare_recursive_declaration fixnames fixtypes fixdefs = let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in let names = List.map (fun id -> Name id) fixnames in (Array.of_list names, Array.of_list fixtypes, Array.of_list defs) (* Jump over let-bindings. *) let compute_possible_guardness_evidences (ids,_,na) = match na with | Some i -> [i] | None -> (* If recursive argument was not given by user, we try all args. An earlier approach was to look only for inductive arguments, but doing it properly involves delta-reduction, and it finally doesn't seem to worth the effort (except for huge mutual fixpoints ?) *) interval 0 (List.length ids - 1) type recursive_preentry = identifier list * constr option list * types list let interp_recursive isfix fixl notations = let env = Global.env() in let fixnames = List.map (fun fix -> fix.fix_name) fixl in (* Interp arities allowing for unresolved types *) let evdref = ref Evd.empty in let fixctxs, fiximppairs, fixannots = list_split3 (List.map (interp_fix_context evdref env isfix) fixl) in let fixctximpenvs, fixctximps = List.split fiximppairs in let fixccls,fixcclimps = List.split (list_map3 (interp_fix_ccl evdref) fixctximpenvs fixctxs fixl) in let fixtypes = List.map2 build_fix_type fixctxs fixccls in let fixtypes = List.map (nf_evar !evdref) fixtypes in let fiximps = list_map3 (fun ctximps cclimps (_,ctx) -> ctximps@(Impargs.lift_implicits (List.length ctx) cclimps)) fixctximps fixcclimps fixctxs in let env_rec = push_named_types env fixnames fixtypes in (* Get interpretation metadatas *) let impls = compute_internalization_env env Recursive fixnames fixtypes fiximps in (* Interp bodies with rollback because temp use of notations/implicit *) let fixdefs = Metasyntax.with_syntax_protection (fun () -> List.iter (Metasyntax.set_notation_for_interpretation impls) notations; list_map4 (fun fixctximpenv -> interp_fix_body evdref env_rec (Idmap.fold Idmap.add fixctximpenv impls)) fixctximpenvs fixctxs fixl fixccls) () in (* Instantiate evars and check all are resolved *) let evd = consider_remaining_unif_problems env_rec !evdref in let fixdefs = List.map (Option.map (nf_evar evd)) fixdefs in let fixtypes = List.map (nf_evar evd) fixtypes in let fixctxnames = List.map (fun (_,ctx) -> List.map pi1 ctx) fixctxs in let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in List.iter (Option.iter (check_evars env_rec Evd.empty evd)) fixdefs; List.iter (check_evars env Evd.empty evd) fixtypes; if not (List.mem None fixdefs) then begin let fixdefs = List.map Option.get fixdefs in check_mutuality env isfix (List.combine fixnames fixdefs) end; (* Build the fix declaration block *) (fixnames,fixdefs,fixtypes), list_combine3 fixctxnames fiximps fixannots let interp_fixpoint = interp_recursive true let interp_cofixpoint = interp_recursive false let declare_fixpoint ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns = if List.mem None fixdefs then (* Some bodies to define by proof *) let thms = list_map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in let init_tac = Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC) fixdefs) in Lemmas.start_proof_with_initialization (Global,DefinitionBody Fixpoint) (Some(false,indexes,init_tac)) thms None (fun _ _ -> ()) else begin (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in let indexes = search_guard dummy_loc (Global.env()) indexes fixdecls in let fiximps = List.map (fun (n,r,p) -> r) fiximps in let fixdecls = list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in ignore (list_map4 (declare_fix Fixpoint) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) fixpoint_message (Some indexes) fixnames; end; (* Declare notations *) List.iter Metasyntax.add_notation_interpretation ntns let declare_cofixpoint ((fixnames,fixdefs,fixtypes),fiximps) ntns = if List.mem None fixdefs then (* Some bodies to define by proof *) let thms = list_map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in let init_tac = Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC) fixdefs) in Lemmas.start_proof_with_initialization (Global,DefinitionBody CoFixpoint) (Some(true,[],init_tac)) thms None (fun _ _ -> ()) else begin (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in let fixdecls = list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in ignore (list_map4 (declare_fix CoFixpoint) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) cofixpoint_message fixnames end; (* Declare notations *) List.iter Metasyntax.add_notation_interpretation ntns let extract_decreasing_argument limit = function | (na,CStructRec) -> na | (na,_) when not limit -> na | _ -> error "Only structural decreasing is supported for a non-Program Fixpoint" let extract_fixpoint_components limit l = let fixl, ntnl = List.split l in let fixl = List.map (fun ((_,id),ann,bl,typ,def) -> let ann = extract_decreasing_argument limit ann in {fix_name = id; fix_annot = ann; fix_binders = bl; fix_body = def; fix_type = typ}) fixl in fixl, List.flatten ntnl let extract_cofixpoint_components l = let fixl, ntnl = List.split l in List.map (fun ((_,id),bl,typ,def) -> {fix_name = id; fix_annot = None; fix_binders = bl; fix_body = def; fix_type = typ}) fixl, List.flatten ntnl let do_fixpoint l = let fixl,ntns = extract_fixpoint_components true l in let fix = interp_fixpoint fixl ntns in let possible_indexes = List.map compute_possible_guardness_evidences (snd fix) in declare_fixpoint fix possible_indexes ntns let do_cofixpoint l = let fixl,ntns = extract_cofixpoint_components l in declare_cofixpoint (interp_cofixpoint fixl ntns) ntns coq-8.4pl4/toplevel/indschemes.mli0000644000175000017500000000331412326224777016313 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val declare_eq_decidability : mutual_inductive -> unit (** Build and register a congruence scheme for an equality-like inductive type *) val declare_congr_scheme : inductive -> unit (** Build and register rewriting schemes for an equality-like inductive type *) val declare_rewriting_schemes : inductive -> unit (** Mutual Minimality/Induction scheme *) val do_mutual_induction_scheme : (identifier located * bool * inductive * glob_sort) list -> unit (** Main calls to interpret the Scheme command *) val do_scheme : (identifier located option * scheme) list -> unit (** Combine a list of schemes into a conjunction of them *) val build_combined_scheme : env -> constant list -> constr * types val do_combined_scheme : identifier located -> identifier located list -> unit (** Hook called at each inductive type definition *) val declare_default_schemes : mutual_inductive -> unit coq-8.4pl4/toplevel/lemmas.mli0000644000175000017500000000460412326224777015452 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit) -> unit val start_proof : identifier -> goal_kind -> types -> ?init_tac:tactic -> ?compute_guard:lemma_possible_guards -> declaration_hook -> unit val start_proof_com : goal_kind -> (lident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option)) list -> declaration_hook -> unit val start_proof_with_initialization : goal_kind -> (bool * lemma_possible_guards * tactic list option) option -> (identifier * (types * (name list * Impargs.manual_explicitation list))) list -> int list option -> declaration_hook -> unit (** A hook the next three functions pass to cook_proof *) val set_save_hook : (Proof.proof -> unit) -> unit (** {6 ... } *) (** [save_named b] saves the current completed proof under the name it was started; boolean [b] tells if the theorem is declared opaque; it fails if the proof is not completed *) val save_named : bool -> unit (** [save_anonymous b name] behaves as [save_named] but declares the theorem under the name [name] and respects the strength of the declaration *) val save_anonymous : bool -> identifier -> unit (** [save_anonymous_with_strength s b name] behaves as [save_anonymous] but declares the theorem under the name [name] and gives it the strength [strength] *) val save_anonymous_with_strength : theorem_kind -> bool -> identifier -> unit (** [admit ()] aborts the current goal and save it as an assmumption *) val admit : unit -> unit (** [get_current_context ()] returns the evar context and env of the current open proof if any, otherwise returns the empty evar context and the current global env *) val get_current_context : unit -> Evd.evar_map * Environ.env coq-8.4pl4/toplevel/usage.mli0000644000175000017500000000170112326224777015273 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a (** {6 Prints the usage on the error output, preceeded by a user-provided message. } *) val print_usage : string -> unit (** {6 Prints the usage on the error output. } *) val print_usage_coqtop : unit -> unit val print_usage_coqc : unit -> unit (** {6 Prints the configuration information } *) val print_config : unit -> unit coq-8.4pl4/toplevel/class.mli0000644000175000017500000000376312326224777015306 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* locality -> source:cl_typ -> target:cl_typ -> unit (** [try_add_new_coercion ref s] declares [ref], assumed to be of type [(x1:T1)...(xn:Tn)src->tg], as a coercion from [src] to [tg] *) val try_add_new_coercion : global_reference -> locality -> unit (** [try_add_new_coercion_subclass cst s] expects that [cst] denotes a transparent constant which unfolds to some class [tg]; it declares an identity coercion from [cst] to [tg], named something like ["Id_cst_tg"] *) val try_add_new_coercion_subclass : cl_typ -> locality -> unit (** [try_add_new_coercion_with_source ref s src] declares [ref] as a coercion from [src] to [tg] where the target is inferred from the type of [ref] *) val try_add_new_coercion_with_source : global_reference -> locality -> source:cl_typ -> unit (** [try_add_new_identity_coercion id s src tg] enriches the environment with a new definition of name [id] declared as an identity coercion from [src] to [tg] *) val try_add_new_identity_coercion : identifier -> locality -> source:cl_typ -> target:cl_typ -> unit val add_coercion_hook : Tacexpr.declaration_hook val add_subclass_hook : Tacexpr.declaration_hook val class_of_global : global_reference -> cl_typ coq-8.4pl4/toplevel/record.mli0000644000175000017500000000334412326224777015452 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ?kind:Decl_kinds.definition_object_kind -> ?name:identifier -> coercion_flag list -> manual_explicitation list list -> rel_context -> (name * bool) list * constant option list val declare_structure : Decl_kinds.recursivity_kind -> bool (**infer?*) -> identifier -> identifier -> manual_explicitation list -> rel_context -> (** params *) constr -> (** arity *) Impargs.manual_explicitation list list -> rel_context -> (** fields *) ?kind:Decl_kinds.definition_object_kind -> ?name:identifier -> bool -> (** coercion? *) bool list -> (** field coercions *) Evd.evar_map -> inductive val definition_structure : inductive_kind * Decl_kinds.recursivity_kind * bool(**infer?*)* lident with_coercion * local_binder list * (local_decl_expr with_instance with_priority with_notation) list * identifier * constr_expr option -> global_reference coq-8.4pl4/toplevel/ide_intf.ml0000644000175000017500000005745312326224777015616 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* mkGood (handler.interp x) | Rewind x -> mkGood (handler.rewind x) | Goal x -> mkGood (handler.goals x) | Evars x -> mkGood (handler.evars x) | Hints x -> mkGood (handler.hints x) | Status x -> mkGood (handler.status x) | Search x -> mkGood (handler.search x) | GetOptions x -> mkGood (handler.get_options x) | SetOptions x -> mkGood (handler.set_options x) | InLoadPath x -> mkGood (handler.inloadpath x) | MkCases x -> mkGood (handler.mkcases x) | Quit x -> mkGood (handler.quit x) | About x -> mkGood (handler.about x) with any -> Fail (handler.handle_exn any) (* To read and typecheck the answers we give a description of the types, and a way to statically check that the reified version is in sync *) module ReifType : sig type 'a val_t val unit_t : unit val_t val string_t : string val_t val int_t : int val_t val bool_t : bool val_t val goals_t : goals val_t val evar_t : evar val_t val state_t : status val_t val coq_info_t : coq_info val_t val option_state_t : option_state val_t val option_t : 'a val_t -> 'a option val_t val list_t : 'a val_t -> 'a list val_t val coq_object_t : 'a val_t -> 'a coq_object val_t val pair_t : 'a val_t -> 'b val_t -> ('a * 'b) val_t val union_t : 'a val_t -> 'b val_t -> ('a ,'b) Util.union val_t type value_type = private | Unit | String | Int | Bool | Goals | Evar | State | Option_state | Coq_info | Option of value_type | List of value_type | Coq_object of value_type | Pair of value_type * value_type | Union of value_type * value_type val check : 'a val_t -> value_type end = struct type value_type = | Unit | String | Int | Bool | Goals | Evar | State | Option_state | Coq_info | Option of value_type | List of value_type | Coq_object of value_type | Pair of value_type * value_type | Union of value_type * value_type type 'a val_t = value_type let check x = x let unit_t = Unit let string_t = String let int_t = Int let bool_t = Bool let goals_t = Goals let evar_t = Evar let state_t = State let coq_info_t = Coq_info let option_state_t = Option_state let option_t x = Option x let list_t x = List x let coq_object_t x = Coq_object x let pair_t x y = Pair (x, y) let union_t x y = Union (x, y) end open ReifType (* For every (call : 'a call), we build the reification of 'a. * In OCaml 4 we could use GATDs to do that I guess *) let expected_answer_type call : value_type = let hint = list_t (pair_t string_t string_t) in let hints = pair_t (list_t hint) hint in let options = pair_t (list_t string_t) option_state_t in let objs = coq_object_t string_t in match call with | Interp _ -> check (string_t : interp_rty val_t) | Rewind _ -> check (int_t : rewind_rty val_t) | Goal _ -> check (option_t goals_t : goals_rty val_t) | Evars _ -> check (option_t (list_t evar_t) : evars_rty val_t) | Hints _ -> check (option_t hints : hints_rty val_t) | Status _ -> check (state_t : status_rty val_t) | Search _ -> check (list_t objs : search_rty val_t) | GetOptions _ -> check (list_t options : get_options_rty val_t) | SetOptions _ -> check (unit_t : set_options_rty val_t) | InLoadPath _ -> check (bool_t : inloadpath_rty val_t) | MkCases _ -> check (list_t (list_t string_t) : mkcases_rty val_t) | Quit _ -> check (unit_t : quit_rty val_t) | About _ -> check (coq_info_t : about_rty val_t) (** * XML data marshalling *) exception Marshal_error (** Utility functions *) let massoc x l = try List.assoc x l with Not_found -> raise Marshal_error let constructor t c args = Element (t, ["val", c], args) let do_match constr t mf = match constr with | Element (s, attrs, args) -> if s = t then let c = massoc "val" attrs in mf c args else raise Marshal_error | _ -> raise Marshal_error let singleton = function | [x] -> x | _ -> raise Marshal_error let raw_string = function | [] -> "" | [PCData s] -> s | _ -> raise Marshal_error let bool_arg tag b = if b then [tag, ""] else [] (** Base types *) let of_unit () = Element ("unit", [], []) let to_unit : xml -> unit = function | Element ("unit", [], []) -> () | _ -> raise Marshal_error let of_bool (b : bool) : xml = if b then constructor "bool" "true" [] else constructor "bool" "false" [] let to_bool xml : bool = do_match xml "bool" (fun s _ -> match s with | "true" -> true | "false" -> false | _ -> raise Marshal_error) let of_list (f : 'a -> xml) (l : 'a list) = Element ("list", [], List.map f l) let to_list (f : xml -> 'a) : xml -> 'a list = function | Element ("list", [], l) -> List.map f l | _ -> raise Marshal_error let of_option (f : 'a -> xml) : 'a option -> xml = function | None -> Element ("option", ["val", "none"], []) | Some x -> Element ("option", ["val", "some"], [f x]) let to_option (f : xml -> 'a) : xml -> 'a option = function | Element ("option", ["val", "none"], []) -> None | Element ("option", ["val", "some"], [x]) -> Some (f x) | _ -> raise Marshal_error let of_string (s : string) : xml = Element ("string", [], [PCData s]) let to_string : xml -> string = function | Element ("string", [], l) -> raw_string l | _ -> raise Marshal_error let of_int (i : int) : xml = Element ("int", [], [PCData (string_of_int i)]) let to_int : xml -> int = function | Element ("int", [], [PCData s]) -> (try int_of_string s with Failure _ -> raise Marshal_error) | _ -> raise Marshal_error let of_pair (f : 'a -> xml) (g : 'b -> xml) : 'a * 'b -> xml = function (x,y) -> Element ("pair", [], [f x; g y]) let to_pair (f : xml -> 'a) (g : xml -> 'b) : xml -> 'a * 'b = function | Element ("pair", [], [x; y]) -> (f x, g y) | _ -> raise Marshal_error let of_union (f : 'a -> xml) (g : 'b -> xml) : ('a,'b) Util.union -> xml = function | Util.Inl x -> Element ("union", ["val","in_l"], [f x]) | Util.Inr x -> Element ("union", ["val","in_r"], [g x]) let to_union (f : xml -> 'a) (g : xml -> 'b) : xml -> ('a,'b) Util.union= function | Element ("union", ["val","in_l"], [x]) -> Util.Inl (f x) | Element ("union", ["val","in_r"], [x]) -> Util.Inr (g x) | _ -> raise Marshal_error (** More elaborate types *) let of_option_value = function | IntValue i -> constructor "option_value" "intvalue" [of_option of_int i] | BoolValue b -> constructor "option_value" "boolvalue" [of_bool b] | StringValue s -> constructor "option_value" "stringvalue" [of_string s] let to_option_value xml = do_match xml "option_value" (fun s args -> match s with | "intvalue" -> IntValue (to_option to_int (singleton args)) | "boolvalue" -> BoolValue (to_bool (singleton args)) | "stringvalue" -> StringValue (to_string (singleton args)) | _ -> raise Marshal_error ) let of_option_state s = Element ("option_state", [], [ of_bool s.opt_sync; of_bool s.opt_depr; of_string s.opt_name; of_option_value s.opt_value] ) let to_option_state = function | Element ("option_state", [], [sync; depr; name; value]) -> { opt_sync = to_bool sync; opt_depr = to_bool depr; opt_name = to_string name; opt_value = to_option_value value; } | _ -> raise Marshal_error let of_search_constraint = function | Name_Pattern s -> constructor "search_constraint" "name_pattern" [of_string s] | Type_Pattern s -> constructor "search_constraint" "type_pattern" [of_string s] | SubType_Pattern s -> constructor "search_constraint" "subtype_pattern" [of_string s] | In_Module m -> constructor "search_constraint" "in_module" [of_list of_string m] | Include_Blacklist -> constructor "search_constraint" "include_blacklist" [] let to_search_constraint xml = do_match xml "search_constraint" (fun s args -> match s with | "name_pattern" -> Name_Pattern (to_string (singleton args)) | "type_pattern" -> Type_Pattern (to_string (singleton args)) | "subtype_pattern" -> SubType_Pattern (to_string (singleton args)) | "in_module" -> In_Module (to_list to_string (singleton args)) | "include_blacklist" -> Include_Blacklist | _ -> raise Marshal_error) let of_coq_object f ans = let prefix = of_list of_string ans.coq_object_prefix in let qualid = of_list of_string ans.coq_object_qualid in let obj = f ans.coq_object_object in Element ("coq_object", [], [prefix; qualid; obj]) let to_coq_object f = function | Element ("coq_object", [], [prefix; qualid; obj]) -> let prefix = to_list to_string prefix in let qualid = to_list to_string qualid in let obj = f obj in { coq_object_prefix = prefix; coq_object_qualid = qualid; coq_object_object = obj; } | _ -> raise Marshal_error let of_value f = function | Good x -> Element ("value", ["val", "good"], [f x]) | Fail (loc, msg) -> let loc = match loc with | None -> [] | Some (s, e) -> [("loc_s", string_of_int s); ("loc_e", string_of_int e)] in Element ("value", ["val", "fail"] @ loc, [PCData msg]) let to_value f = function | Element ("value", attrs, l) -> let ans = massoc "val" attrs in if ans = "good" then Good (f (singleton l)) else if ans = "fail" then let loc = try let loc_s = int_of_string (List.assoc "loc_s" attrs) in let loc_e = int_of_string (List.assoc "loc_e" attrs) in Some (loc_s, loc_e) with Not_found | Failure _ -> None in let msg = raw_string l in Fail (loc, msg) else raise Marshal_error | _ -> raise Marshal_error let of_call = function | Interp (id,raw, vrb, cmd) -> let flags = (bool_arg "raw" raw) @ (bool_arg "verbose" vrb) in Element ("call", ("val", "interp") :: ("id", string_of_int id) :: flags, [PCData cmd]) | Rewind n -> Element ("call", ("val", "rewind") :: ["steps", string_of_int n], []) | Goal () -> Element ("call", ["val", "goal"], []) | Evars () -> Element ("call", ["val", "evars"], []) | Hints () -> Element ("call", ["val", "hints"], []) | Status () -> Element ("call", ["val", "status"], []) | Search flags -> let args = List.map (of_pair of_search_constraint of_bool) flags in Element ("call", ["val", "search"], args) | GetOptions () -> Element ("call", ["val", "getoptions"], []) | SetOptions opts -> let args = List.map (of_pair (of_list of_string) of_option_value) opts in Element ("call", ["val", "setoptions"], args) | InLoadPath file -> Element ("call", ["val", "inloadpath"], [PCData file]) | MkCases ind -> Element ("call", ["val", "mkcases"], [PCData ind]) | Quit () -> Element ("call", ["val", "quit"], []) | About () -> Element ("call", ["val", "about"], []) let to_call = function | Element ("call", attrs, l) -> let ans = massoc "val" attrs in begin match ans with | "interp" -> begin try let id = List.assoc "id" attrs in let raw = List.mem_assoc "raw" attrs in let vrb = List.mem_assoc "verbose" attrs in Interp (int_of_string id, raw, vrb, raw_string l) with Not_found -> raise Marshal_error end | "rewind" -> let steps = int_of_string (massoc "steps" attrs) in Rewind steps | "goal" -> Goal () | "evars" -> Evars () | "status" -> Status () | "search" -> let args = List.map (to_pair to_search_constraint to_bool) l in Search args | "getoptions" -> GetOptions () | "setoptions" -> let args = List.map (to_pair (to_list to_string) to_option_value) l in SetOptions args | "inloadpath" -> InLoadPath (raw_string l) | "mkcases" -> MkCases (raw_string l) | "hints" -> Hints () | "quit" -> Quit () | "about" -> About () | _ -> raise Marshal_error end | _ -> raise Marshal_error let of_status s = let of_so = of_option of_string in let of_sl = of_list of_string in Element ("status", [], [ of_sl s.status_path; of_so s.status_proofname; of_sl s.status_allproofs; of_int s.status_statenum; of_int s.status_proofnum; ] ) let to_status = function | Element ("status", [], [path; name; prfs; snum; pnum]) -> { status_path = to_list to_string path; status_proofname = to_option to_string name; status_allproofs = to_list to_string prfs; status_statenum = to_int snum; status_proofnum = to_int pnum; } | _ -> raise Marshal_error let of_evar s = Element ("evar", [], [PCData s.evar_info]) let to_evar = function | Element ("evar", [], data) -> { evar_info = raw_string data; } | _ -> raise Marshal_error let of_goal g = let hyp = of_list of_string g.goal_hyp in let ccl = of_string g.goal_ccl in let id = of_string g.goal_id in Element ("goal", [], [id; hyp; ccl]) let to_goal = function | Element ("goal", [], [id; hyp; ccl]) -> let hyp = to_list to_string hyp in let ccl = to_string ccl in let id = to_string id in { goal_hyp = hyp; goal_ccl = ccl; goal_id = id; } | _ -> raise Marshal_error let of_goals g = let of_glist = of_list of_goal in let fg = of_list of_goal g.fg_goals in let bg = of_list (of_pair of_glist of_glist) g.bg_goals in Element ("goals", [], [fg; bg]) let to_goals = function | Element ("goals", [], [fg; bg]) -> let to_glist = to_list to_goal in let fg = to_list to_goal fg in let bg = to_list (to_pair to_glist to_glist) bg in { fg_goals = fg; bg_goals = bg; } | _ -> raise Marshal_error let of_coq_info info = let version = of_string info.coqtop_version in let protocol = of_string info.protocol_version in let release = of_string info.release_date in let compile = of_string info.compile_date in Element ("coq_info", [], [version; protocol; release; compile]) let to_coq_info = function | Element ("coq_info", [], [version; protocol; release; compile]) -> { coqtop_version = to_string version; protocol_version = to_string protocol; release_date = to_string release; compile_date = to_string compile; } | _ -> raise Marshal_error let of_message_level = function | Debug s -> constructor "message_level" "debug" [PCData s] | Info -> constructor "message_level" "info" [] | Notice -> constructor "message_level" "notice" [] | Warning -> constructor "message_level" "warning" [] | Error -> constructor "message_level" "error" [] let to_message_level xml = do_match xml "message_level" (fun s args -> match s with | "debug" -> Debug (raw_string args) | "info" -> Info | "notice" -> Notice | "warning" -> Warning | "error" -> Error | _ -> raise Marshal_error) let of_message msg = let lvl = of_message_level msg.message_level in let content = of_string msg.message_content in Element ("message", [], [lvl; content]) let to_message xml = match xml with | Element ("message", [], [lvl; content]) -> { message_level = to_message_level lvl; message_content = to_string content } | _ -> raise Marshal_error let is_message = function | Element ("message", _, _) -> true | _ -> false let of_loc loc = let start, stop = loc in Element ("loc",[("start",string_of_int start);("stop",string_of_int stop)],[]) let to_loc xml = match xml with | Element ("loc", l,[]) -> (try let start = List.assoc "start" l in let stop = List.assoc "stop" l in (int_of_string start, int_of_string stop) with Not_found | Invalid_argument _ -> raise Marshal_error) | _ -> raise Marshal_error let to_feedback_content xml = do_match xml "feedback_content" (fun s args -> match s with | "addedaxiom" -> AddedAxiom | "processed" -> Processed | "globref" -> (match args with | [loc; filepath; modpath; ident; ty] -> GlobRef(to_loc loc, to_string filepath, to_string modpath, to_string ident, to_string ty) | _ -> raise Marshal_error) | _ -> raise Marshal_error) let of_feedback_content = function | AddedAxiom -> constructor "feedback_content" "addedaxiom" [] | Processed -> constructor "feedback_content" "processed" [] | GlobRef(loc, filepath, modpath, ident, ty) -> constructor "feedback_content" "globref" [ of_loc loc; of_string filepath; of_string modpath; of_string ident; of_string ty ] let of_feedback msg = let content = of_feedback_content msg.content in Element ("feedback", ["id",string_of_int msg.edit_id], [content]) let to_feedback xml = match xml with | Element ("feedback", ["id",id], [content]) -> { edit_id = int_of_string id; content = to_feedback_content content } | _ -> raise Marshal_error let is_feedback = function | Element ("feedback", _, _) -> true | _ -> false (** Conversions between ['a value] and xml answers When decoding an xml answer, we dynamically check that it is compatible with the original call. For that we now rely on the fact that all sub-fonctions [to_xxx : xml -> xxx] check that the current xml element is "xxx", and raise [Marshal_error] if anything goes wrong. *) let of_answer (q : 'a call) (r : 'a value) : xml = let rec convert ty : 'a -> xml = match ty with | Unit -> Obj.magic of_unit | Bool -> Obj.magic of_bool | String -> Obj.magic of_string | Int -> Obj.magic of_int | State -> Obj.magic of_status | Option_state -> Obj.magic of_option_state | Coq_info -> Obj.magic of_coq_info | Goals -> Obj.magic of_goals | Evar -> Obj.magic of_evar | List t -> Obj.magic (of_list (convert t)) | Option t -> Obj.magic (of_option (convert t)) | Coq_object t -> Obj.magic (of_coq_object (convert t)) | Pair (t1,t2) -> Obj.magic (of_pair (convert t1) (convert t2)) | Union (t1,t2) -> Obj.magic (of_union (convert t1) (convert t2)) in of_value (convert (expected_answer_type q)) r let to_answer xml (c : 'a call) : 'a value = let rec convert ty : xml -> 'a = match ty with | Unit -> Obj.magic to_unit | Bool -> Obj.magic to_bool | String -> Obj.magic to_string | Int -> Obj.magic to_int | State -> Obj.magic to_status | Option_state -> Obj.magic to_option_state | Coq_info -> Obj.magic to_coq_info | Goals -> Obj.magic to_goals | Evar -> Obj.magic to_evar | List t -> Obj.magic (to_list (convert t)) | Option t -> Obj.magic (to_option (convert t)) | Coq_object t -> Obj.magic (to_coq_object (convert t)) | Pair (t1,t2) -> Obj.magic (to_pair (convert t1) (convert t2)) | Union (t1,t2) -> Obj.magic (to_union (convert t1) (convert t2)) in to_value (convert (expected_answer_type c)) xml (** * Debug printing *) let pr_unit () = "" let pr_string s = Printf.sprintf "%S" s let pr_int i = string_of_int i let pr_bool b = Printf.sprintf "%B" b let pr_goal (g : goals) = if g.fg_goals = [] then if g.bg_goals = [] then "Proof completed." else let rec pr_focus _ = function | [] -> assert false | [lg, rg] -> Printf.sprintf "%i" (List.length lg + List.length rg) | (lg, rg) :: l -> Printf.sprintf "%i:%a" (List.length lg + List.length rg) pr_focus l in Printf.sprintf "Still focussed: [%a]." pr_focus g.bg_goals else let pr_menu s = s in let pr_goal { goal_hyp = hyps; goal_ccl = goal } = "[" ^ String.concat "; " (List.map pr_menu hyps) ^ " |- " ^ pr_menu goal ^ "]" in String.concat " " (List.map pr_goal g.fg_goals) let pr_evar (e : evar) = "[" ^ e.evar_info ^ "]" let pr_status (s : status) = let path = let l = String.concat "." s.status_path in "path=" ^ l ^ ";" in let name = match s.status_proofname with | None -> "no proof;" | Some n -> "proof = " ^ n ^ ";" in "Status: " ^ path ^ name let pr_coq_info (i : coq_info) = "FIXME" let pr_option_value = function | IntValue None -> "none" | IntValue (Some i) -> string_of_int i | StringValue s -> s | BoolValue b -> if b then "true" else "false" let pr_option_state (s : option_state) = Printf.sprintf "sync := %b; depr := %b; name := %s; value := %s\n" s.opt_sync s.opt_depr s.opt_name (pr_option_value s.opt_value) let pr_list pr l = "["^String.concat ";" (List.map pr l)^"]" let pr_option pr = function None -> "None" | Some x -> "Some("^pr x^")" let pr_coq_object (o : 'a coq_object) = "FIXME" let pr_pair pr1 pr2 (a,b) = "("^pr1 a^","^pr2 b^")" let pr_union pr1 pr2 = function Util.Inl x -> pr1 x | Util.Inr x -> pr2 x let pr_call = function | Interp (id,r,b,s) -> let raw = if r then "RAW" else "" in let verb = if b then "" else "SILENT" in "INTERP"^raw^verb^" "^string_of_int id^" ["^s^"]" | Rewind i -> "REWIND "^(string_of_int i) | Goal _ -> "GOALS" | Evars _ -> "EVARS" | Hints _ -> "HINTS" | Status _ -> "STATUS" | Search _ -> "SEARCH" | GetOptions _ -> "GETOPTIONS" | SetOptions l -> "SETOPTIONS" ^ " [" ^ String.concat ";" (List.map (pr_pair (pr_list pr_string) pr_option_value) l) ^ "]" | InLoadPath s -> "INLOADPATH "^s | MkCases s -> "MKCASES "^s | Quit _ -> "QUIT" | About _ -> "ABOUT" let pr_value_gen pr = function | Good v -> "GOOD " ^ pr v | Fail (_,str) -> "FAIL ["^str^"]" let pr_value v = pr_value_gen (fun _ -> "FIXME") v let pr_full_value call value = let rec pr = function | Unit -> Obj.magic pr_unit | Bool -> Obj.magic pr_bool | String -> Obj.magic pr_string | Int -> Obj.magic pr_int | State -> Obj.magic pr_status | Option_state -> Obj.magic pr_option_state | Coq_info -> Obj.magic pr_coq_info | Goals -> Obj.magic pr_goal | Evar -> Obj.magic pr_evar | List t -> Obj.magic (pr_list (pr t)) | Option t -> Obj.magic (pr_option (pr t)) | Coq_object t -> Obj.magic pr_coq_object | Pair (t1,t2) -> Obj.magic (pr_pair (pr t1) (pr t2)) | Union (t1,t2) -> Obj.magic (pr_union (pr t1) (pr t2)) in pr_value_gen (pr (expected_answer_type call)) value coq-8.4pl4/toplevel/mltop.ml40000644000175000017500000002523312326224777015243 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* canonical_path_name path') in coq_mlpath_copy := path :: List.filter filter !coq_mlpath_copy (* If there is a toplevel under Coq *) type toplevel = { load_obj : string -> unit; use_file : string -> unit; add_dir : string -> unit; ml_loop : unit -> unit } (* Determines the behaviour of Coq with respect to ML files (compiled or not) *) type kind_load = | WithTop of toplevel | WithoutTop (* Must be always initialized *) let load = ref WithoutTop (* Are we in a native version of Coq? *) let is_native = IFDEF Byte THEN false ELSE true END (* Sets and initializes a toplevel (if any) *) let set_top toplevel = load := WithTop toplevel (* Removes the toplevel (if any) *) let remove ()= load := WithoutTop (* Tests if an Ocaml toplevel runs under Coq *) let is_ocaml_top () = match !load with | WithTop _ -> true |_ -> false (* Tests if we can load ML files *) let has_dynlink = IFDEF HasDynlink THEN true ELSE false END (* Runs the toplevel loop of Ocaml *) let ocaml_toploop () = match !load with | WithTop t -> Printexc.catch t.ml_loop () | _ -> () (* Dynamic loading of .cmo/.cma *) let dir_ml_load s = match !load with | WithTop t -> (try t.load_obj s with | (UserError _ | Failure _ | Anomaly _ | Not_found as u) -> raise u | e when Errors.noncritical e -> errorlabstrm "Mltop.load_object" (str"Cannot link ml-object " ++ str s ++ str" to Coq code.")) (* TO DO: .cma loading without toplevel *) | WithoutTop -> IFDEF HasDynlink THEN (* WARNING * if this code section starts to use a module not used elsewhere * in this file, the Makefile dependency logic needs to be updated. *) let warn = Flags.is_verbose() in let _,gname = find_file_in_path ~warn !coq_mlpath_copy s in try Dynlink.loadfile gname; with | Dynlink.Error a -> errorlabstrm "Mltop.load_object" (str (Dynlink.error_message a)) ELSE errorlabstrm "Mltop.no_load_object" (str"Loading of ML object file forbidden in a native Coq.") END (* Dynamic interpretation of .ml *) let dir_ml_use s = match !load with | WithTop t -> t.use_file s | _ -> msg_warn "Cannot access the ML compiler" (* Adds a path to the ML paths *) let add_ml_dir s = match !load with | WithTop t -> t.add_dir s; keep_copy_mlpath s | WithoutTop when has_dynlink -> keep_copy_mlpath s | _ -> () (* For Rec Add ML Path *) let add_rec_ml_dir unix_path = List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs ~unix_path) (* Adding files to Coq and ML loadpath *) let add_path ~unix_path:dir ~coq_root:coq_dirpath = if exists_dir dir then begin add_ml_dir dir; Library.add_load_path true (dir,coq_dirpath) end else msg_warning (str ("Cannot open " ^ dir)) let convert_string d = try Names.id_of_string d with e when Errors.noncritical e -> if_warn msg_warning (str ("Directory "^d^" cannot be used as a Coq identifier (skipped)")); flush_all (); failwith "caught" let add_rec_path ~unix_path ~coq_root = if exists_dir unix_path then let dirs = all_subdirs ~unix_path in let prefix = Names.repr_dirpath coq_root in let convert_dirs (lp,cp) = (lp,Names.make_dirpath (List.map convert_string (List.rev cp)@prefix)) in let dirs = map_succeed convert_dirs dirs in List.iter (fun lpe -> add_ml_dir (fst lpe)) dirs; add_ml_dir unix_path; List.iter (Library.add_load_path false) dirs; Library.add_load_path true (unix_path, coq_root) else msg_warning (str ("Cannot open " ^ unix_path)) (* convertit un nom quelconque en nom de fichier ou de module *) let mod_of_name name = let base = if Filename.check_suffix name ".cmo" then Filename.chop_suffix name ".cmo" else name in String.capitalize base let get_ml_object_suffix name = if Filename.check_suffix name ".cmo" then Some ".cmo" else if Filename.check_suffix name ".cma" then Some ".cma" else if Filename.check_suffix name ".cmxs" then Some ".cmxs" else None let file_of_name name = let name = String.uncapitalize name in let suffix = get_ml_object_suffix name in let fail s = errorlabstrm "Mltop.load_object" (str"File not found on loadpath : " ++ str s) in if is_native then let name = match suffix with | Some ((".cmo"|".cma") as suffix) -> (Filename.chop_suffix name suffix) ^ ".cmxs" | Some ".cmxs" -> name | _ -> name ^ ".cmxs" in if is_in_path !coq_mlpath_copy name then name else fail name else let (full, base) = match suffix with | Some ".cmo" | Some ".cma" -> true, name | Some ".cmxs" -> false, Filename.chop_suffix name ".cmxs" | _ -> false, name in if full then if is_in_path !coq_mlpath_copy base then base else fail base else let name = base ^ ".cmo" in if is_in_path !coq_mlpath_copy name then name else let name = base ^ ".cma" in if is_in_path !coq_mlpath_copy name then name else fail (base ^ ".cm[oa]") (** Is the ML code of the standard library placed into loadable plugins or statically compiled into coqtop ? For the moment this choice is made according to the presence of native dynlink : even if bytecode coqtop could always load plugins, we prefer to have uniformity between bytecode and native versions. *) (* [known_loaded_module] contains the names of the loaded ML modules * (linked or loaded with load_object). It is used not to load a * module twice. It is NOT the list of ML modules Coq knows. *) let known_loaded_modules = ref Stringset.empty let add_known_module mname = let mname = String.capitalize mname in known_loaded_modules := Stringset.add mname !known_loaded_modules let module_is_known mname = Stringset.mem (String.capitalize mname) !known_loaded_modules (** A plugin is just an ML module with an initialization function. *) let known_loaded_plugins = ref Stringmap.empty let add_known_plugin init name = let name = String.capitalize name in add_known_module name; known_loaded_plugins := Stringmap.add name init !known_loaded_plugins let init_known_plugins () = Stringmap.iter (fun _ f -> f()) !known_loaded_plugins (** ml object = ml module or plugin *) let init_ml_object mname = try Stringmap.find mname !known_loaded_plugins () with Not_found -> () let load_ml_object mname fname= dir_ml_load fname; add_known_module mname; init_ml_object mname (* Summary of declared ML Modules *) (* List and not Stringset because order is important: most recent first. *) let loaded_modules = ref [] let get_loaded_modules () = List.rev !loaded_modules let add_loaded_module md = loaded_modules := md :: !loaded_modules let reset_loaded_modules () = loaded_modules := [] let if_verbose_load verb f name fname = if not verb then f name fname else let info = "[Loading ML file "^fname^" ..." in try f name fname; msgnl (str (info^" done]")); with reraise -> msgnl (str (info^" failed]")); raise reraise (** Load a module for the first time (i.e. dynlink it) or simulate its reload (i.e. doing nothing except maybe an initialization function). *) let cache_ml_object verb reinit name = begin if module_is_known name then (if reinit then init_ml_object name) else if not has_dynlink then error ("Dynamic link not supported (module "^name^")") else if_verbose_load (verb && is_verbose ()) load_ml_object name (file_of_name name) end; add_loaded_module name let unfreeze_ml_modules x = reset_loaded_modules (); List.iter (cache_ml_object false false) x let _ = Summary.declare_summary "ML-MODULES" { Summary.freeze_function = get_loaded_modules; Summary.unfreeze_function = unfreeze_ml_modules; Summary.init_function = reset_loaded_modules } (* Liboject entries of declared ML Modules *) type ml_module_object = { mlocal : Vernacexpr.locality_flag; mnames : string list } let cache_ml_objects (_,{mnames=mnames}) = List.iter (cache_ml_object true true) mnames let classify_ml_objects ({mlocal=mlocal} as o) = if mlocal then Dispose else Substitute o let inMLModule : ml_module_object -> obj = declare_object {(default_object "ML-MODULE") with load_function = (fun _ -> cache_ml_objects); cache_function = cache_ml_objects; subst_function = (fun (_,o) -> o); classify_function = classify_ml_objects } let declare_ml_modules local l = let l = List.map mod_of_name l in Lib.add_anonymous_leaf (inMLModule {mlocal=local; mnames=l}) let print_ml_path () = let l = !coq_mlpath_copy in ppnl (str"ML Load Path:" ++ fnl () ++ str" " ++ hv 0 (prlist_with_sep pr_fnl pr_str l)) (* Printing of loaded ML modules *) let print_ml_modules () = let l = get_loaded_modules () in pp (str"Loaded ML Modules: " ++ pr_vertical_list pr_str l) coq-8.4pl4/toplevel/himsg.ml0000644000175000017500000011764612326224777015145 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* pr_id id | Anonymous, _, _ -> str "<>" with Not_found -> str "UNBOUND_REL_" ++ int i let explain_unbound_rel env n = let pe = pr_ne_context_of (str "In environment") env in str "Unbound reference: " ++ pe ++ str "The reference " ++ int n ++ str " is free." let explain_unbound_var env v = let var = pr_id v in str "No such section variable or assumption: " ++ var ++ str "." let explain_not_type env sigma j = let j = j_nf_evar sigma j in let pe = pr_ne_context_of (str "In environment") env in let pc,pt = pr_ljudge_env env j in pe ++ str "The term" ++ brk(1,1) ++ pc ++ spc () ++ str "has type" ++ spc () ++ pt ++ spc () ++ str "which should be Set, Prop or Type." let explain_bad_assumption env j = let pe = pr_ne_context_of (str "In environment") env in let pc,pt = pr_ljudge_env env j in pe ++ str "Cannot declare a variable or hypothesis over the term" ++ brk(1,1) ++ pc ++ spc () ++ str "of type" ++ spc () ++ pt ++ spc () ++ str "because this term is not a type." let explain_reference_variables c = let pc = pr_lconstr c in str "The constant" ++ spc () ++ pc ++ spc () ++ str "refers to variables which are not in the context." let rec pr_disjunction pr = function | [a] -> pr a | [a;b] -> pr a ++ str " or" ++ spc () ++ pr b | a::l -> pr a ++ str "," ++ spc () ++ pr_disjunction pr l | [] -> assert false let explain_elim_arity env ind sorts c pj okinds = let env = make_all_name_different env in let pi = pr_inductive env ind in let pc = pr_lconstr_env env c in let msg = match okinds with | Some(kp,ki,explanation) -> let pki = pr_sort_family ki in let pkp = pr_sort_family kp in let explanation = match explanation with | NonInformativeToInformative -> "proofs can be eliminated only to build proofs" | StrongEliminationOnNonSmallType -> "strong elimination on non-small inductive types leads to paradoxes" | WrongArity -> "wrong arity" in let ppar = pr_disjunction (fun s -> quote (pr_sort_family s)) sorts in let ppt = pr_lconstr_env env ((strip_prod_assum pj.uj_type)) in hov 0 (str "the return type has sort" ++ spc () ++ ppt ++ spc () ++ str "while it" ++ spc () ++ str "should be " ++ ppar ++ str ".") ++ fnl () ++ hov 0 (str "Elimination of an inductive object of sort " ++ pki ++ brk(1,0) ++ str "is not allowed on a predicate in sort " ++ pkp ++ fnl () ++ str "because" ++ spc () ++ str explanation ++ str ".") | None -> str "ill-formed elimination predicate." in hov 0 ( str "Incorrect elimination of" ++ spc () ++ pc ++ spc () ++ str "in the inductive type" ++ spc () ++ quote pi ++ str ":") ++ fnl () ++ msg let explain_case_not_inductive env sigma cj = let cj = j_nf_evar sigma cj in let env = make_all_name_different env in let pc = pr_lconstr_env env cj.uj_val in let pct = pr_lconstr_env env cj.uj_type in match kind_of_term cj.uj_type with | Evar _ -> str "Cannot infer a type for this expression." | _ -> str "The term" ++ brk(1,1) ++ pc ++ spc () ++ str "has type" ++ brk(1,1) ++ pct ++ spc () ++ str "which is not a (co-)inductive type." let explain_number_branches env sigma cj expn = let cj = j_nf_evar sigma cj in let env = make_all_name_different env in let pc = pr_lconstr_env env cj.uj_val in let pct = pr_lconstr_env env cj.uj_type in str "Matching on term" ++ brk(1,1) ++ pc ++ spc () ++ str "of type" ++ brk(1,1) ++ pct ++ spc () ++ str "expects " ++ int expn ++ str " branches." let explain_ill_formed_branch env sigma c ci actty expty = let simp t = Reduction.nf_betaiota (nf_evar sigma t) in let c = nf_evar sigma c in let env = make_all_name_different env in let pc = pr_lconstr_env env c in let pa = pr_lconstr_env env (simp actty) in let pe = pr_lconstr_env env (simp expty) in strbrk "In pattern-matching on term" ++ brk(1,1) ++ pc ++ spc () ++ strbrk "the branch for constructor" ++ spc () ++ quote (pr_constructor env ci) ++ spc () ++ str "has type" ++ brk(1,1) ++ pa ++ spc () ++ str "which should be" ++ brk(1,1) ++ pe ++ str "." let explain_generalization env (name,var) j = let pe = pr_ne_context_of (str "In environment") env in let pv = pr_ltype_env env var in let (pc,pt) = pr_ljudge_env (push_rel_assum (name,var) env) j in pe ++ str "Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++ str "over" ++ brk(1,1) ++ pc ++ str "," ++ spc () ++ str "it has type" ++ spc () ++ pt ++ spc () ++ str "which should be Set, Prop or Type." let explain_actual_type env sigma j pt = let j = j_nf_betaiotaevar sigma j in let pt = Reductionops.nf_betaiota sigma pt in let pe = pr_ne_context_of (str "In environment") env in let (pc,pct) = pr_ljudge_env env j in let pt = pr_lconstr_env env pt in pe ++ str "The term" ++ brk(1,1) ++ pc ++ spc () ++ str "has type" ++ brk(1,1) ++ pct ++ brk(1,1) ++ str "while it is expected to have type" ++ brk(1,1) ++ pt ++ str "." let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl = let randl = jv_nf_betaiotaevar sigma randl in let exptyp = nf_evar sigma exptyp in let actualtyp = Reductionops.nf_betaiota sigma actualtyp in let rator = j_nf_evar sigma rator in let env = make_all_name_different env in let nargs = Array.length randl in (* let pe = pr_ne_context_of (str "in environment") env in*) let pr,prt = pr_ljudge_env env rator in let term_string1 = str (plural nargs "term") in let term_string2 = if nargs>1 then str "The " ++ nth n ++ str " term" else str "This term" in let appl = prvect_with_sep pr_fnl (fun c -> let pc,pct = pr_ljudge_env env c in hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl in str "Illegal application (Type Error): " ++ (* pe ++ *) fnl () ++ str "The term" ++ brk(1,1) ++ pr ++ spc () ++ str "of type" ++ brk(1,1) ++ prt ++ spc () ++ str "cannot be applied to the " ++ term_string1 ++ fnl () ++ str " " ++ v 0 appl ++ fnl () ++ term_string2 ++ str " has type" ++ brk(1,1) ++ pr_lconstr_env env actualtyp ++ spc () ++ str "which should be coercible to" ++ brk(1,1) ++ pr_lconstr_env env exptyp ++ str "." let explain_cant_apply_not_functional env sigma rator randl = let randl = jv_nf_evar sigma randl in let rator = j_nf_evar sigma rator in let env = make_all_name_different env in let nargs = Array.length randl in (* let pe = pr_ne_context_of (str "in environment") env in*) let pr = pr_lconstr_env env rator.uj_val in let prt = pr_lconstr_env env rator.uj_type in let appl = prvect_with_sep pr_fnl (fun c -> let pc = pr_lconstr_env env c.uj_val in let pct = pr_lconstr_env env c.uj_type in hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl in str "Illegal application (Non-functional construction): " ++ (* pe ++ *) fnl () ++ str "The expression" ++ brk(1,1) ++ pr ++ spc () ++ str "of type" ++ brk(1,1) ++ prt ++ spc () ++ str "cannot be applied to the " ++ str (plural nargs "term") ++ fnl () ++ str " " ++ v 0 appl let explain_unexpected_type env sigma actual_type expected_type = let actual_type = nf_evar sigma actual_type in let expected_type = nf_evar sigma expected_type in let pract = pr_lconstr_env env actual_type in let prexp = pr_lconstr_env env expected_type in str "Found type" ++ spc () ++ pract ++ spc () ++ str "where" ++ spc () ++ prexp ++ str " was expected." let explain_not_product env sigma c = let c = nf_evar sigma c in let pr = pr_lconstr_env env c in str "The type of this term is a product" ++ spc () ++ str "while it is expected to be" ++ (if is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "." (* TODO: use the names *) (* (co)fixpoints *) let explain_ill_formed_rec_body env err names i fixenv vdefj = let prt_name i = match names.(i) with Name id -> str "Recursive definition of " ++ pr_id id | Anonymous -> str "The " ++ nth i ++ str " definition" in let st = match err with (* Fixpoint guard errors *) | NotEnoughAbstractionInFixBody -> str "Not enough abstractions in the definition" | RecursionNotOnInductiveType c -> str "Recursive definition on" ++ spc () ++ pr_lconstr_env env c ++ spc () ++ str "which should be an inductive type" | RecursionOnIllegalTerm(j,(arg_env, arg),le,lt) -> let arg_env = make_all_name_different arg_env in let called = match names.(j) with Name id -> pr_id id | Anonymous -> str "the " ++ nth i ++ str " definition" in let pr_db x = quote (pr_db env x) in let vars = match (lt,le) with ([],[]) -> assert false | ([],[x]) -> str "a subterm of " ++ pr_db x | ([],_) -> str "a subterm of the following variables: " ++ prlist_with_sep pr_spc pr_db le | ([x],_) -> pr_db x | _ -> str "one of the following variables: " ++ prlist_with_sep pr_spc pr_db lt in str "Recursive call to " ++ called ++ spc () ++ strbrk "has principal argument equal to" ++ spc () ++ pr_lconstr_env arg_env arg ++ strbrk " instead of " ++ vars | NotEnoughArgumentsForFixCall j -> let called = match names.(j) with Name id -> pr_id id | Anonymous -> str "the " ++ nth i ++ str " definition" in str "Recursive call to " ++ called ++ str " has not enough arguments" (* CoFixpoint guard errors *) | CodomainNotInductiveType c -> str "The codomain is" ++ spc () ++ pr_lconstr_env env c ++ spc () ++ str "which should be a coinductive type" | NestedRecursiveOccurrences -> str "Nested recursive occurrences" | UnguardedRecursiveCall c -> str "Unguarded recursive call in" ++ spc () ++ pr_lconstr_env env c | RecCallInTypeOfAbstraction c -> str "Recursive call forbidden in the domain of an abstraction:" ++ spc () ++ pr_lconstr_env env c | RecCallInNonRecArgOfConstructor c -> str "Recursive call on a non-recursive argument of constructor" ++ spc () ++ pr_lconstr_env env c | RecCallInTypeOfDef c -> str "Recursive call forbidden in the type of a recursive definition" ++ spc () ++ pr_lconstr_env env c | RecCallInCaseFun c -> str "Invalid recursive call in a branch of" ++ spc () ++ pr_lconstr_env env c | RecCallInCaseArg c -> str "Invalid recursive call in the argument of \"match\" in" ++ spc () ++ pr_lconstr_env env c | RecCallInCasePred c -> str "Invalid recursive call in the \"return\" clause of \"match\" in" ++ spc () ++ pr_lconstr_env env c | NotGuardedForm c -> str "Sub-expression " ++ pr_lconstr_env env c ++ strbrk " not in guarded form (should be a constructor," ++ strbrk " an abstraction, a match, a cofix or a recursive call)" in prt_name i ++ str " is ill-formed." ++ fnl () ++ pr_ne_context_of (str "In environment") env ++ st ++ str "." ++ fnl () ++ (try (* May fail with unresolved globals. *) let fixenv = make_all_name_different fixenv in let pvd = pr_lconstr_env fixenv vdefj.(i).uj_val in str"Recursive definition is:" ++ spc () ++ pvd ++ str "." with e when Errors.noncritical e -> mt ()) let explain_ill_typed_rec_body env sigma i names vdefj vargs = let vdefj = jv_nf_evar sigma vdefj in let vargs = Array.map (nf_evar sigma) vargs in let env = make_all_name_different env in let pvd,pvdt = pr_ljudge_env env (vdefj.(i)) in let pv = pr_lconstr_env env vargs.(i) in str "The " ++ (if Array.length vdefj = 1 then mt () else nth (i+1) ++ spc ()) ++ str "recursive definition" ++ spc () ++ pvd ++ spc () ++ str "has type" ++ spc () ++ pvdt ++ spc () ++ str "while it should be" ++ spc () ++ pv ++ str "." let explain_cant_find_case_type env sigma c = let c = nf_evar sigma c in let env = make_all_name_different env in let pe = pr_lconstr_env env c in str "Cannot infer type of pattern-matching on" ++ ws 1 ++ pe ++ str "." let explain_occur_check env sigma ev rhs = let rhs = nf_evar sigma rhs in let env = make_all_name_different env in let id = Evd.string_of_existential ev in let pt = pr_lconstr_env env rhs in str "Cannot define " ++ str id ++ str " with term" ++ brk(1,1) ++ pt ++ spc () ++ str "that would depend on itself." let pr_ne_context_of header footer env = if Environ.rel_context env = empty_rel_context & Environ.named_context env = empty_named_context then footer else pr_ne_context_of header env let explain_hole_kind env evi = function | QuestionMark _ -> str "this placeholder" | CasesType -> str "the type of this pattern-matching problem" | BinderType (Name id) -> str "the type of " ++ Nameops.pr_id id | BinderType Anonymous -> str "the type of this anonymous binder" | ImplicitArg (c,(n,ido),b) -> let id = Option.get ido in str "the implicit parameter " ++ pr_id id ++ spc () ++ str "of" ++ spc () ++ Nametab.pr_global_env Idset.empty c | InternalHole -> str "an internal placeholder" ++ Option.cata (fun evi -> let env = Evd.evar_env evi in str " of type " ++ pr_lconstr_env env evi.evar_concl ++ pr_ne_context_of (str " in environment:"++ fnl ()) (mt ()) env) (mt ()) evi | TomatchTypeParameter (tyi,n) -> str "the " ++ nth n ++ str " argument of the inductive type (" ++ pr_inductive env tyi ++ str ") of this term" | GoalEvar -> str "an existential variable" | ImpossibleCase -> str "the type of an impossible pattern-matching clause" | MatchingVar _ -> assert false let explain_not_clean env sigma ev t k = let t = nf_evar sigma t in let env = make_all_name_different env in let id = Evd.string_of_existential ev in let var = pr_lconstr_env env t in str "Tried to instantiate " ++ explain_hole_kind env None k ++ str " (" ++ str id ++ str ")" ++ spc () ++ str "with a term using variable " ++ var ++ spc () ++ str "which is not in its scope." let explain_unsolvability = function | None -> mt() | Some (SeveralInstancesFound n) -> strbrk " (several distinct possible instances found)" let explain_typeclass_resolution env evi k = match Typeclasses.class_of_constr evi.evar_concl with | Some c -> let env = Evd.evar_env evi in fnl () ++ str "Could not find an instance for " ++ pr_lconstr_env env evi.evar_concl ++ pr_ne_context_of (str " in environment:"++ fnl ()) (str ".") env | _ -> mt() let explain_unsolvable_implicit env evi k explain = str "Cannot infer " ++ explain_hole_kind env (Some evi) k ++ explain_unsolvability explain ++ str "." ++ explain_typeclass_resolution env evi k let explain_var_not_found env id = str "The variable" ++ spc () ++ pr_id id ++ spc () ++ str "was not found" ++ spc () ++ str "in the current" ++ spc () ++ str "environment" ++ str "." let explain_wrong_case_info env ind ci = let pi = pr_inductive (Global.env()) ind in if ci.ci_ind = ind then str "Pattern-matching expression on an object of inductive type" ++ spc () ++ pi ++ spc () ++ str "has invalid information." else let pc = pr_inductive (Global.env()) ci.ci_ind in str "A term of inductive type" ++ spc () ++ pi ++ spc () ++ str "was given to a pattern-matching expression on the inductive type" ++ spc () ++ pc ++ str "." let explain_cannot_unify env sigma m n = let m = nf_evar sigma m in let n = nf_evar sigma n in let pm = pr_lconstr_env env m in let pn = pr_lconstr_env env n in str "Impossible to unify" ++ brk(1,1) ++ pm ++ spc () ++ str "with" ++ brk(1,1) ++ pn ++ str "." let explain_cannot_unify_local env sigma m n subn = let pm = pr_lconstr_env env m in let pn = pr_lconstr_env env n in let psubn = pr_lconstr_env env subn in str "Impossible to unify" ++ brk(1,1) ++ pm ++ spc () ++ str "with" ++ brk(1,1) ++ pn ++ spc () ++ str "as" ++ brk(1,1) ++ psubn ++ str " contains local variables." let explain_refiner_cannot_generalize env ty = str "Cannot find a well-typed generalisation of the goal with type: " ++ pr_lconstr_env env ty ++ str "." let explain_no_occurrence_found env c id = str "Found no subterm matching " ++ pr_lconstr_env env c ++ str " in " ++ (match id with | Some id -> pr_id id | None -> str"the current goal") ++ str "." let explain_cannot_unify_binding_type env m n = let pm = pr_lconstr_env env m in let pn = pr_lconstr_env env n in str "This binding has type" ++ brk(1,1) ++ pm ++ spc () ++ str "which should be unifiable with" ++ brk(1,1) ++ pn ++ str "." let explain_cannot_find_well_typed_abstraction env p l = str "Abstracting over the " ++ str (plural (List.length l) "term") ++ spc () ++ hov 0 (pr_enum (pr_lconstr_env env) l) ++ spc () ++ str "leads to a term" ++ spc () ++ pr_lconstr_env env p ++ spc () ++ str "which is ill-typed." let explain_abstraction_over_meta _ m n = strbrk "Too complex unification problem: cannot find a solution for both " ++ pr_name m ++ spc () ++ str "and " ++ pr_name n ++ str "." let explain_non_linear_unification env m t = strbrk "Cannot unambiguously instantiate " ++ pr_name m ++ str ":" ++ strbrk " which would require to abstract twice on " ++ pr_lconstr_env env t ++ str "." let explain_type_error env sigma err = let env = make_all_name_different env in match err with | UnboundRel n -> explain_unbound_rel env n | UnboundVar v -> explain_unbound_var env v | NotAType j -> explain_not_type env sigma j | BadAssumption c -> explain_bad_assumption env c | ReferenceVariables id -> explain_reference_variables id | ElimArity (ind, aritylst, c, pj, okinds) -> explain_elim_arity env ind aritylst c pj okinds | CaseNotInductive cj -> explain_case_not_inductive env sigma cj | NumberBranches (cj, n) -> explain_number_branches env sigma cj n | IllFormedBranch (c, i, actty, expty) -> explain_ill_formed_branch env sigma c i actty expty | Generalization (nvar, c) -> explain_generalization env nvar c | ActualType (j, pt) -> explain_actual_type env sigma j pt | CantApplyBadType (t, rator, randl) -> explain_cant_apply_bad_type env sigma t rator randl | CantApplyNonFunctional (rator, randl) -> explain_cant_apply_not_functional env sigma rator randl | IllFormedRecBody (err, lna, i, fixenv, vdefj) -> explain_ill_formed_rec_body env err lna i fixenv vdefj | IllTypedRecBody (i, lna, vdefj, vargs) -> explain_ill_typed_rec_body env sigma i lna vdefj vargs | WrongCaseInfo (ind,ci) -> explain_wrong_case_info env ind ci let explain_pretype_error env sigma err = let env = env_nf_betaiotaevar sigma env in let env = make_all_name_different env in match err with | CantFindCaseType c -> explain_cant_find_case_type env sigma c | OccurCheck (n,c) -> explain_occur_check env sigma n c | NotClean (n,c,k) -> explain_not_clean env sigma n c k | UnsolvableImplicit (evi,k,exp) -> explain_unsolvable_implicit env evi k exp | VarNotFound id -> explain_var_not_found env id | UnexpectedType (actual,expect) -> explain_unexpected_type env sigma actual expect | NotProduct c -> explain_not_product env sigma c | CannotUnify (m,n) -> explain_cannot_unify env sigma m n | CannotUnifyLocal (m,n,sn) -> explain_cannot_unify_local env sigma m n sn | CannotGeneralize ty -> explain_refiner_cannot_generalize env ty | NoOccurrenceFound (c, id) -> explain_no_occurrence_found env c id | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type env m n | CannotFindWellTypedAbstraction (p,l) -> explain_cannot_find_well_typed_abstraction env p l | AbstractionOverMeta (m,n) -> explain_abstraction_over_meta env m n | NonLinearUnification (m,c) -> explain_non_linear_unification env m c | TypingError t -> explain_type_error env sigma t (* Module errors *) open Modops let explain_not_match_error = function | InductiveFieldExpected _ -> strbrk "an inductive definition is expected" | DefinitionFieldExpected -> strbrk "a definition is expected" | ModuleFieldExpected -> strbrk "a module is expected" | ModuleTypeFieldExpected -> strbrk "a module type is expected" | NotConvertibleInductiveField id | NotConvertibleConstructorField id -> str "types given to " ++ str (string_of_id id) ++ str " differ" | NotConvertibleBodyField -> str "the body of definitions differs" | NotConvertibleTypeField (env, typ1, typ2) -> str "expected type" ++ spc () ++ quote (Printer.safe_pr_lconstr_env env typ2) ++ spc () ++ str "but found type" ++ spc () ++ quote (Printer.safe_pr_lconstr_env env typ1) | NotSameConstructorNamesField -> str "constructor names differ" | NotSameInductiveNameInBlockField -> str "inductive types names differ" | FiniteInductiveFieldExpected isfinite -> str "type is expected to be " ++ str (if isfinite then "coinductive" else "inductive") | InductiveNumbersFieldExpected n -> str "number of inductive types differs" | InductiveParamsNumberField n -> str "inductive type has not the right number of parameters" | RecordFieldExpected isrecord -> str "type is expected " ++ str (if isrecord then "" else "not ") ++ str "to be a record" | RecordProjectionsExpected nal -> (if List.length nal >= 2 then str "expected projection names are " else str "expected projection name is ") ++ pr_enum (function Name id -> str (string_of_id id) | _ -> str "_") nal | NotEqualInductiveAliases -> str "Aliases to inductive types do not match" | NoTypeConstraintExpected -> strbrk "a definition whose type is constrained can only be subtype of a definition whose type is itself constrained" let explain_signature_mismatch l spec why = str "Signature components for label " ++ str (string_of_label l) ++ str " do not match:" ++ spc () ++ explain_not_match_error why ++ str "." let explain_label_already_declared l = str ("The label "^string_of_label l^" is already declared.") let explain_application_to_not_path _ = str "Application of modules is restricted to paths." let explain_not_a_functor mtb = str "Application of not a functor." let explain_incompatible_module_types mexpr1 mexpr2 = str "Incompatible module types." let explain_not_equal_module_paths mp1 mp2 = str "Non equal modules." let explain_no_such_label l = str "No such label " ++ str (string_of_label l) ++ str "." let explain_incompatible_labels l l' = str "Opening and closing labels are not the same: " ++ str (string_of_label l) ++ str " <> " ++ str (string_of_label l') ++ str "!" let explain_signature_expected mtb = str "Signature expected." let explain_no_module_to_end () = str "No open module to end." let explain_no_module_type_to_end () = str "No open module type to end." let explain_not_a_module s = quote (str s) ++ str " is not a module." let explain_not_a_module_type s = quote (str s) ++ str " is not a module type." let explain_not_a_constant l = quote (pr_label l) ++ str " is not a constant." let explain_incorrect_label_constraint l = str "Incorrect constraint for label " ++ quote (pr_label l) ++ str "." let explain_generative_module_expected l = str "The module " ++ str (string_of_label l) ++ strbrk " is not generative. Only components of generative modules can be changed using the \"with\" construct." let explain_non_empty_local_context = function | None -> str "The local context is not empty." | Some l -> str "The local context of the component " ++ str (string_of_label l) ++ str " is not empty." let explain_label_missing l s = str "The field " ++ str (string_of_label l) ++ str " is missing in " ++ str s ++ str "." let explain_module_error = function | SignatureMismatch (l,spec,err) -> explain_signature_mismatch l spec err | LabelAlreadyDeclared l -> explain_label_already_declared l | ApplicationToNotPath mexpr -> explain_application_to_not_path mexpr | NotAFunctor mtb -> explain_not_a_functor mtb | IncompatibleModuleTypes (m1,m2) -> explain_incompatible_module_types m1 m2 | NotEqualModulePaths (mp1,mp2) -> explain_not_equal_module_paths mp1 mp2 | NoSuchLabel l -> explain_no_such_label l | IncompatibleLabels (l1,l2) -> explain_incompatible_labels l1 l2 | SignatureExpected mtb -> explain_signature_expected mtb | NoModuleToEnd -> explain_no_module_to_end () | NoModuleTypeToEnd -> explain_no_module_type_to_end () | NotAModule s -> explain_not_a_module s | NotAModuleType s -> explain_not_a_module_type s | NotAConstant l -> explain_not_a_constant l | IncorrectWithConstraint l -> explain_incorrect_label_constraint l | GenerativeModuleExpected l -> explain_generative_module_expected l | NonEmptyLocalContect lopt -> explain_non_empty_local_context lopt | LabelMissing (l,s) -> explain_label_missing l s (* Module internalization errors *) (* let explain_declaration_not_path _ = str "Declaration is not a path." *) let explain_not_module_nor_modtype s = quote (str s) ++ str " is not a module or module type." let explain_incorrect_with_in_module () = str "The syntax \"with\" is not allowed for modules." let explain_incorrect_module_application () = str "Illegal application to a module type." open Modintern let explain_module_internalization_error = function | NotAModuleNorModtype s -> explain_not_module_nor_modtype s | IncorrectWithInModule -> explain_incorrect_with_in_module () | IncorrectModuleApplication -> explain_incorrect_module_application () (* Typeclass errors *) let explain_not_a_class env c = pr_constr_env env c ++ str" is not a declared type class." let explain_unbound_method env cid id = str "Unbound method name " ++ Nameops.pr_id (snd id) ++ spc () ++ str"of class" ++ spc () ++ pr_global cid ++ str "." let pr_constr_exprs exprs = hv 0 (List.fold_right (fun d pps -> ws 2 ++ Ppconstr.pr_constr_expr d ++ pps) exprs (mt ())) let explain_no_instance env (_,id) l = str "No instance found for class " ++ Nameops.pr_id id ++ spc () ++ str "applied to arguments" ++ spc () ++ prlist_with_sep pr_spc (pr_lconstr_env env) l let is_goal_evar evi = match evi.evar_source with (_, GoalEvar) -> true | _ -> false let pr_constraints printenv env evm = let l = Evd.to_list evm in assert(l <> []); let (ev, evi) = List.hd l in if List.for_all (fun (ev', evi') -> eq_named_context_val evi.evar_hyps evi'.evar_hyps) l then let pe = pr_ne_context_of (str "In environment:") (mt ()) (reset_with_named_context evi.evar_hyps env) in (if printenv then pe ++ fnl () else mt ()) ++ prlist_with_sep (fun () -> fnl ()) (fun (ev, evi) -> str(string_of_existential ev) ++ str " : " ++ pr_lconstr evi.evar_concl) l ++ fnl() ++ pr_evar_map_constraints evm else pr_evar_map None evm let explain_unsatisfiable_constraints env evd constr = let evm = Evd.undefined_evars (Evarutil.nf_evar_map_undefined evd) in (* Remove goal evars *) let undef = fold_undefined (fun ev evi evm' -> if is_goal_evar evi then Evd.remove evm' ev else evm') evm evm in match constr with | None -> str"Unable to satisfy the following constraints:" ++ fnl() ++ pr_constraints true env undef | Some (ev, k) -> explain_typeclass_resolution env (Evd.find evm ev) k ++ fnl () ++ (let remaining = Evd.remove undef ev in if Evd.has_undefined remaining then str"With the following constraints:" ++ fnl() ++ pr_constraints false env remaining else mt ()) let explain_mismatched_contexts env c i j = str"Mismatched contexts while declaring instance: " ++ brk (1,1) ++ hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env j) ++ fnl () ++ brk (1,1) ++ hov 1 (str"Found:" ++ brk (1, 1) ++ pr_constr_exprs i) let explain_typeclass_error env err = match err with | NotAClass c -> explain_not_a_class env c | UnboundMethod (cid, id) -> explain_unbound_method env cid id | NoInstance (id, l) -> explain_no_instance env id l | UnsatisfiableConstraints (evd, c) -> explain_unsatisfiable_constraints env evd c | MismatchedContextInstance (c, i, j) -> explain_mismatched_contexts env c i j (* Refiner errors *) let explain_refiner_bad_type arg ty conclty = str "Refiner was given an argument" ++ brk(1,1) ++ pr_lconstr arg ++ spc () ++ str "of type" ++ brk(1,1) ++ pr_lconstr ty ++ spc () ++ str "instead of" ++ brk(1,1) ++ pr_lconstr conclty ++ str "." let explain_refiner_unresolved_bindings l = str "Unable to find an instance for the " ++ str (plural (List.length l) "variable") ++ spc () ++ prlist_with_sep pr_comma pr_name l ++ str"." let explain_refiner_cannot_apply t harg = str "In refiner, a term of type" ++ brk(1,1) ++ pr_lconstr t ++ spc () ++ str "could not be applied to" ++ brk(1,1) ++ pr_lconstr harg ++ str "." let explain_refiner_not_well_typed c = str "The term " ++ pr_lconstr c ++ str " is not well-typed." let explain_intro_needs_product () = str "Introduction tactics needs products." let explain_does_not_occur_in c hyp = str "The term" ++ spc () ++ pr_lconstr c ++ spc () ++ str "does not occur in" ++ spc () ++ pr_id hyp ++ str "." let explain_non_linear_proof c = str "Cannot refine with term" ++ brk(1,1) ++ pr_lconstr c ++ spc () ++ str "because a metavariable has several occurrences." let explain_meta_in_type c = str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_lconstr c ++ str " of another meta" let explain_refiner_error = function | BadType (arg,ty,conclty) -> explain_refiner_bad_type arg ty conclty | UnresolvedBindings t -> explain_refiner_unresolved_bindings t | CannotApply (t,harg) -> explain_refiner_cannot_apply t harg | NotWellTyped c -> explain_refiner_not_well_typed c | IntroNeedsProduct -> explain_intro_needs_product () | DoesNotOccurIn (c,hyp) -> explain_does_not_occur_in c hyp | NonLinearProof c -> explain_non_linear_proof c | MetaInType c -> explain_meta_in_type c (* Inductive errors *) let error_non_strictly_positive env c v = let pc = pr_lconstr_env env c in let pv = pr_lconstr_env env v in str "Non strictly positive occurrence of " ++ pv ++ str " in" ++ brk(1,1) ++ pc ++ str "." let error_ill_formed_inductive env c v = let pc = pr_lconstr_env env c in let pv = pr_lconstr_env env v in str "Not enough arguments applied to the " ++ pv ++ str " in" ++ brk(1,1) ++ pc ++ str "." let error_ill_formed_constructor env id c v nparams nargs = let pv = pr_lconstr_env env v in let atomic = (nb_prod c = 0) in str "The type of constructor" ++ brk(1,1) ++ pr_id id ++ brk(1,1) ++ str "is not valid;" ++ brk(1,1) ++ strbrk (if atomic then "it must be " else "its conclusion must be ") ++ pv ++ (* warning: because of implicit arguments it is difficult to say which parameters must be explicitly given *) (if nparams<>0 then strbrk " applied to its " ++ str (plural nparams "parameter") else mt()) ++ (if nargs<>0 then str (if nparams<>0 then " and" else " applied") ++ strbrk " to some " ++ str (plural nargs "argument") else mt()) ++ str "." let pr_ltype_using_barendregt_convention_env env c = (* Use goal_concl_style as an approximation of Barendregt's convention (?) *) quote (pr_goal_concl_style_env env c) let error_bad_ind_parameters env c n v1 v2 = let pc = pr_ltype_using_barendregt_convention_env env c in let pv1 = pr_lconstr_env env v1 in let pv2 = pr_lconstr_env env v2 in str "Last occurrence of " ++ pv2 ++ str " must have " ++ pv1 ++ str " as " ++ nth n ++ str " argument in " ++ brk(1,1) ++ pc ++ str "." let error_same_names_types id = str "The name" ++ spc () ++ pr_id id ++ spc () ++ str "is used more than once." let error_same_names_constructors id = str "The constructor name" ++ spc () ++ pr_id id ++ spc () ++ str "is used more than once." let error_same_names_overlap idl = strbrk "The following names are used both as type names and constructor " ++ str "names:" ++ spc () ++ prlist_with_sep pr_comma pr_id idl ++ str "." let error_not_an_arity env c = str "The type" ++ spc () ++ pr_lconstr_env env c ++ spc () ++ str "is not an arity." let error_bad_entry () = str "Bad inductive definition." let error_large_non_prop_inductive_not_in_type () = str "Large non-propositional inductive types must be in Type." (* Recursion schemes errors *) let error_not_allowed_case_analysis isrec kind i = str (if isrec then "Induction" else "Case analysis") ++ strbrk " on sort " ++ pr_sort kind ++ strbrk " is not allowed for inductive definition " ++ pr_inductive (Global.env()) i ++ str "." let error_not_mutual_in_scheme ind ind' = if ind = ind' then str "The inductive type " ++ pr_inductive (Global.env()) ind ++ str " occurs twice." else str "The inductive types " ++ pr_inductive (Global.env()) ind ++ spc () ++ str "and" ++ spc () ++ pr_inductive (Global.env()) ind' ++ spc () ++ str "are not mutually defined." (* Inductive constructions errors *) let explain_inductive_error = function | NonPos (env,c,v) -> error_non_strictly_positive env c v | NotEnoughArgs (env,c,v) -> error_ill_formed_inductive env c v | NotConstructor (env,id,c,v,n,m) -> error_ill_formed_constructor env id c v n m | NonPar (env,c,n,v1,v2) -> error_bad_ind_parameters env c n v1 v2 | SameNamesTypes id -> error_same_names_types id | SameNamesConstructors id -> error_same_names_constructors id | SameNamesOverlap idl -> error_same_names_overlap idl | NotAnArity (env, c) -> error_not_an_arity env c | BadEntry -> error_bad_entry () | LargeNonPropInductiveNotInType -> error_large_non_prop_inductive_not_in_type () (* Recursion schemes errors *) let explain_recursion_scheme_error = function | NotAllowedCaseAnalysis (isrec,k,i) -> error_not_allowed_case_analysis isrec k i | NotMutualInScheme (ind,ind')-> error_not_mutual_in_scheme ind ind' (* Pattern-matching errors *) let explain_bad_pattern env cstr ty = let env = make_all_name_different env in let pt = pr_lconstr_env env ty in let pc = pr_constructor env cstr in str "Found the constructor " ++ pc ++ brk(1,1) ++ str "while matching a term of type " ++ pt ++ brk(1,1) ++ str "which is not an inductive type." let explain_bad_constructor env cstr ind = let pi = pr_inductive env ind in (* let pc = pr_constructor env cstr in*) let pt = pr_inductive env (inductive_of_constructor cstr) in str "Found a constructor of inductive type " ++ pt ++ brk(1,1) ++ str "while a constructor of " ++ pi ++ brk(1,1) ++ str "is expected." let decline_string n s = if n = 0 then "no "^s^"s" else if n = 1 then "1 "^s else (string_of_int n^" "^s^"s") let explain_wrong_numarg_constructor env cstr n = str "The constructor " ++ pr_constructor env cstr ++ str " expects " ++ str (decline_string n "argument") ++ str "." let explain_wrong_numarg_inductive env ind n = str "The inductive type " ++ pr_inductive env ind ++ str " expects " ++ str (decline_string n "argument") ++ str "." let explain_wrong_predicate_arity env pred nondep_arity dep_arity= let env = make_all_name_different env in let pp = pr_lconstr_env env pred in str "The elimination predicate " ++ spc () ++ pp ++ fnl () ++ str "should be of arity" ++ spc () ++ pr_lconstr_env env nondep_arity ++ spc () ++ str "(for non dependent case) or" ++ spc () ++ pr_lconstr_env env dep_arity ++ spc () ++ str "(for dependent case)." let explain_needs_inversion env x t = let env = make_all_name_different env in let px = pr_lconstr_env env x in let pt = pr_lconstr_env env t in str "Sorry, I need inversion to compile pattern matching on term " ++ px ++ str " of type: " ++ pt ++ str "." let explain_unused_clause env pats = (* Without localisation let s = if List.length pats > 1 then "s" else "" in (str ("Unused clause with pattern"^s) ++ spc () ++ hov 0 (prlist_with_sep pr_spc pr_cases_pattern pats) ++ str ")") *) str "This clause is redundant." let explain_non_exhaustive env pats = str "Non exhaustive pattern-matching: no clause found for " ++ str (plural (List.length pats) "pattern") ++ spc () ++ hov 0 (prlist_with_sep pr_spc pr_cases_pattern pats) let explain_cannot_infer_predicate env typs = let env = make_all_name_different env in let pr_branch (cstr,typ) = let cstr,_ = decompose_app cstr in str "For " ++ pr_lconstr_env env cstr ++ str ": " ++ pr_lconstr_env env typ in str "Unable to unify the types found in the branches:" ++ spc () ++ hov 0 (prlist_with_sep pr_fnl pr_branch (Array.to_list typs)) let explain_pattern_matching_error env = function | BadPattern (c,t) -> explain_bad_pattern env c t | BadConstructor (c,ind) -> explain_bad_constructor env c ind | WrongNumargConstructor (c,n) -> explain_wrong_numarg_constructor env c n | WrongNumargInductive (c,n) -> explain_wrong_numarg_inductive env c n | WrongPredicateArity (pred,n,dep) -> explain_wrong_predicate_arity env pred n dep | NeedsInversion (x,t) -> explain_needs_inversion env x t | UnusedClause tms -> explain_unused_clause env tms | NonExhaustive tms -> explain_non_exhaustive env tms | CannotInferPredicate typs -> explain_cannot_infer_predicate env typs let explain_reduction_tactic_error = function | Tacred.InvalidAbstraction (env,c,(env',e)) -> str "The abstracted term" ++ spc () ++ quote (pr_goal_concl_style_env env c) ++ spc () ++ str "is not well typed." ++ fnl () ++ explain_type_error env' Evd.empty e let explain_ltac_call_trace (nrep,last,trace,loc) = let calls = (nrep,last) :: List.rev (List.map(fun(n,_,ck)->(n,ck))trace) in let tacexpr_differ te te' = (* NB: The following comparison may raise an exception since a tacexpr may embed a functional part via a TacExtend *) try te <> te' with Invalid_argument _ -> false in let pr_call (n,ck) = (match ck with | Proof_type.LtacNotationCall s -> quote (str s) | Proof_type.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) | Proof_type.LtacVarCall (id,t) -> quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" | Proof_type.LtacAtomCall (te,otac) -> quote (Pptactic.pr_glob_tactic (Global.env()) (Tacexpr.TacAtom (dummy_loc,te))) ++ (match !otac with | Some te' when tacexpr_differ (Obj.magic te') te -> strbrk " (expanded to " ++ quote (Pptactic.pr_tactic (Global.env()) (Tacexpr.TacAtom (dummy_loc,te'))) ++ str ")" | _ -> mt ()) | Proof_type.LtacConstrInterp (c,(vars,unboundvars)) -> let filter = function (id,None) -> None | (id,Some id') -> Some(id,([],mkVar id')) in let unboundvars = list_map_filter filter unboundvars in quote (pr_glob_constr_env (Global.env()) c) ++ (if unboundvars <> [] or vars <> [] then strbrk " (with " ++ prlist_with_sep pr_comma (fun (id,c) -> pr_id id ++ str ":=" ++ Printer.pr_lconstr_under_binders c) (List.rev vars @ unboundvars) ++ str ")" else mt())) ++ (if n=2 then str " (repeated twice)" else if n>2 then str " (repeated "++int n++str" times)" else mt()) in if calls <> [] then let kind_of_last_call = match list_last calls with | (_,Proof_type.LtacConstrInterp _) -> ", last term evaluation failed." | _ -> ", last call failed." in hov 0 (str "In nested Ltac calls to " ++ pr_enum pr_call calls ++ strbrk kind_of_last_call) else mt () coq-8.4pl4/toplevel/search.ml0000644000175000017500000001726012326224777015272 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* head_const d | LetIn (_,_,_,d) -> head_const d | App (f,_) -> head_const f | Cast (d,_,_) -> head_const d | _ -> c (* General search, restricted to head constant if [only_head] *) let gen_crible refopt (fn : global_reference -> env -> constr -> unit) = let env = Global.env () in let crible_rec (sp,kn) lobj = match object_tag lobj with | "VARIABLE" -> (try let (id,_,typ) = Global.lookup_named (basename sp) in if refopt = None || head_const typ = constr_of_global (Option.get refopt) then fn (VarRef id) env typ with Not_found -> (* we are in a section *) ()) | "CONSTANT" -> let cst = Global.constant_of_delta_kn kn in let typ = Typeops.type_of_constant env cst in if refopt = None || head_const typ = constr_of_global (Option.get refopt) then fn (ConstRef cst) env typ | "INDUCTIVE" -> let mind = Global.mind_of_delta_kn kn in let mib = Global.lookup_mind mind in (match refopt with | Some (IndRef ((kn',tyi) as ind)) when eq_mind mind kn' -> print_constructors ind fn env (Array.length (mib.mind_packets.(tyi).mind_user_lc)) | Some _ -> () | _ -> Array.iteri (fun i mip -> print_constructors (mind,i) fn env (Array.length mip.mind_user_lc)) mib.mind_packets) | _ -> () in try Declaremods.iter_all_segments crible_rec with Not_found -> () let crible ref = gen_crible (Some ref) (* Fine Search. By Yves Bertot. *) exception No_full_path let rec head c = let c = strip_outer_cast c in match kind_of_term c with | Prod (_,_,c) -> head c | LetIn (_,_,_,c) -> head c | _ -> c let xor a b = (a or b) & (not (a & b)) let plain_display ref a c = let pc = pr_lconstr_env a c in let pr = pr_global ref in msg (hov 2 (pr ++ str":" ++ spc () ++ pc) ++ fnl ()) let filter_by_module (module_list:dir_path list) (accept:bool) (ref:global_reference) _ _ = try let sp = path_of_global ref in let sl = dirpath sp in let rec filter_aux = function | m :: tl -> (not (is_dirpath_prefix_of m sl)) && (filter_aux tl) | [] -> true in xor accept (filter_aux module_list) with No_full_path -> false let ref_eq = Libnames.encode_mind Coqlib.logic_module (id_of_string "eq"), 0 let c_eq = mkInd ref_eq let gref_eq = IndRef ref_eq let mk_rewrite_pattern1 eq pattern = PApp (PRef eq, [| PMeta None; pattern; PMeta None |]) let mk_rewrite_pattern2 eq pattern = PApp (PRef eq, [| PMeta None; PMeta None; pattern |]) let pattern_filter pat _ a c = try try is_matching pat (head c) with e when Errors.noncritical e -> is_matching pat (head (Typing.type_of (Global.env()) Evd.empty c)) with UserError _ -> false let filtered_search filter_function display_function ref = crible ref (fun s a c -> if filter_function s a c then display_function s a c) let rec id_from_pattern = function | PRef gr -> gr (* should be appear as a PRef (VarRef sp) !! | PVar id -> Nametab.locate (make_qualid [] (string_of_id id)) *) | PApp (p,_) -> id_from_pattern p | _ -> error "The pattern is not simple enough." let raw_pattern_search extra_filter display_function pat = let name = id_from_pattern pat in filtered_search (fun s a c -> (pattern_filter pat s a c) & extra_filter s a c) display_function name let raw_search_rewrite extra_filter display_function pattern = filtered_search (fun s a c -> ((pattern_filter (mk_rewrite_pattern1 gref_eq pattern) s a c) || (pattern_filter (mk_rewrite_pattern2 gref_eq pattern) s a c)) && extra_filter s a c) display_function gref_eq let raw_search_by_head extra_filter display_function pattern = Util.todo "raw_search_by_head" let name_of_reference ref = string_of_id (basename_of_global ref) let full_name_of_reference ref = let (dir,id) = repr_path (path_of_global ref) in string_of_dirpath dir ^ "." ^ string_of_id id (* * functions to use the new Libtypes facility *) let raw_search search_function extra_filter display_function pat = let env = Global.env() in List.iter (fun (gr,_,_) -> let typ = Global.type_of_global gr in if extra_filter gr env typ then display_function gr env typ ) (search_function pat) let text_pattern_search extra_filter = raw_search Libtypes.search_concl extra_filter plain_display let text_search_rewrite extra_filter = raw_search (Libtypes.search_eq_concl c_eq) extra_filter plain_display let text_search_by_head extra_filter = raw_search Libtypes.search_head_concl extra_filter plain_display let filter_by_module_from_list = function | [], _ -> (fun _ _ _ -> true) | l, outside -> filter_by_module l (not outside) let filter_blacklist gr _ _ = let name = full_name_of_reference gr in let l = SearchBlacklist.elements () in List.for_all (fun str -> not (string_string_contains ~where:name ~what:str)) l let (&&&&&) f g x y z = f x y z && g x y z let search_by_head pat inout = text_search_by_head (filter_by_module_from_list inout &&&&& filter_blacklist) pat let search_rewrite pat inout = text_search_rewrite (filter_by_module_from_list inout &&&&& filter_blacklist) pat let search_pattern pat inout = text_pattern_search (filter_by_module_from_list inout &&&&& filter_blacklist) pat let gen_filtered_search filter_function display_function = gen_crible None (fun s a c -> if filter_function s a c then display_function s a c) (** SearchAbout *) type glob_search_about_item = | GlobSearchSubPattern of constr_pattern | GlobSearchString of string let search_about_item (itemref,typ) = function | GlobSearchSubPattern pat -> is_matching_appsubterm ~closed:false pat typ | GlobSearchString s -> string_string_contains ~where:(name_of_reference itemref) ~what:s let raw_search_about filter_modules display_function l = let filter ref' env typ = filter_modules ref' env typ && List.for_all (fun (b,i) -> b = search_about_item (ref',typ) i) l && filter_blacklist ref' () () in gen_filtered_search filter display_function let search_about ref inout = raw_search_about (filter_by_module_from_list inout) plain_display ref coq-8.4pl4/toplevel/whelp.mli0000644000175000017500000000143312326224777015310 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit coq-8.4pl4/toplevel/toplevel.mli0000644000175000017500000000311212326224777016017 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string; mutable str : string; (** buffer of already read characters *) mutable len : int; (** number of chars in the buffer *) mutable bols : int list; (** offsets in str of begining of lines *) mutable tokens : Pcoq.Gram.parsable; (** stream of tokens *) mutable start : int } (** stream count of the first char of the buffer *) (** The input buffer of stdin. *) val top_buffer : input_buffer val set_prompt : (unit -> string) -> unit (** Toplevel error explanation, dealing with locations, Drop, Ctrl-D May raise only the following exceptions: [Drop] and [End_of_input], meaning we get out of the Coq loop. *) val print_toplevel_error : exn -> std_ppcmds (** Parse and execute a vernac command. *) val do_vernac : unit -> unit (** Main entry point of Coq: read and execute vernac commands. *) val loop : unit -> unit coq-8.4pl4/toplevel/discharge.ml0000644000175000017500000000625512326224777015760 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* id, Entries.LocalAssum p | (Name id,Some p,_) -> id, Entries.LocalDef p | (Anonymous,_,_) -> anomaly"Unnamed inductive local variable" (* Replace Var(y1)..Var(yq):C1..Cq |- Ij:Bj Var(y1)..Var(yq):C1..Cq; I1..Ip:B1..Bp |- ci : Ti by |- Ij: (y1..yq:C1..Cq)Bj I1..Ip:(B1 y1..yq)..(Bp y1..yq) |- ci : (y1..yq:C1..Cq)Ti[Ij:=(Ij y1..yq)] *) let abstract_inductive hyps nparams inds = let ntyp = List.length inds in let nhyp = named_context_length hyps in let args = instance_from_named_context (List.rev hyps) in let subs = list_tabulate (fun k -> lift nhyp (mkApp(mkRel (k+1),args))) ntyp in let inds' = List.map (function (tname,arity,cnames,lc) -> let lc' = List.map (substl subs) lc in let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b hyps) lc' in let arity' = Termops.it_mkNamedProd_wo_LetIn arity hyps in (tname,arity',cnames,lc'')) inds in let nparams' = nparams + Array.length args in (* To be sure to be the same as before, should probably be moved to process_inductive *) let params' = let (_,arity,_,_) = List.hd inds' in let (params,_) = decompose_prod_n_assum nparams' arity in List.map detype_param params in let ind'' = List.map (fun (a,arity,c,lc) -> let _, short_arity = decompose_prod_n_assum nparams' arity in let shortlc = List.map (fun c -> snd (decompose_prod_n_assum nparams' c)) lc in { mind_entry_typename = a; mind_entry_arity = short_arity; mind_entry_consnames = c; mind_entry_lc = shortlc }) inds' in (params',ind'') let refresh_polymorphic_type_of_inductive (_,mip) = match mip.mind_arity with | Monomorphic s -> s.mind_user_arity | Polymorphic ar -> let ctx = List.rev mip.mind_arity_ctxt in mkArity (List.rev ctx,Termops.new_Type_sort()) let process_inductive sechyps modlist mib = let nparams = mib.mind_nparams in let inds = array_map_to_list (fun mip -> let arity = expmod_constr modlist (refresh_polymorphic_type_of_inductive (mib,mip)) in let lc = Array.map (expmod_constr modlist) mip.mind_user_lc in (mip.mind_typename, arity, Array.to_list mip.mind_consnames, Array.to_list lc)) mib.mind_packets in let sechyps' = map_named_context (expmod_constr modlist) sechyps in let (params',inds') = abstract_inductive sechyps' nparams inds in { mind_entry_record = mib.mind_record; mind_entry_finite = mib.mind_finite; mind_entry_params = params'; mind_entry_inds = inds' } coq-8.4pl4/toplevel/search.mli0000644000175000017500000000440412326224777015437 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* dir_path list * bool -> unit val search_rewrite : constr -> dir_path list * bool -> unit val search_pattern : constr -> dir_path list * bool -> unit val search_about : (bool * glob_search_about_item) list -> dir_path list * bool -> unit (** The filtering function that is by standard search facilities. It can be passed as argument to the raw search functions. It is used in pcoq. *) val filter_by_module_from_list : dir_path list * bool -> global_reference -> env -> 'a -> bool val filter_blacklist : global_reference -> env -> constr -> bool (** raw search functions can be used for various extensions. They are also used for pcoq. *) val gen_filtered_search : (global_reference -> env -> constr -> bool) -> (global_reference -> env -> constr -> unit) -> unit val filtered_search : (global_reference -> env -> constr -> bool) -> (global_reference -> env -> constr -> unit) -> global_reference -> unit val raw_pattern_search : (global_reference -> env -> constr -> bool) -> (global_reference -> env -> constr -> unit) -> constr_pattern -> unit val raw_search_rewrite : (global_reference -> env -> constr -> bool) -> (global_reference -> env -> constr -> unit) -> constr_pattern -> unit val raw_search_about : (global_reference -> env -> constr -> bool) -> (global_reference -> env -> constr -> unit) -> (bool * glob_search_about_item) list -> unit val raw_search_by_head : (global_reference -> env -> constr -> bool) -> (global_reference -> env -> constr -> unit) -> constr_pattern -> unit coq-8.4pl4/toplevel/libtypes.mli0000644000175000017500000000226612326224777016031 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* types (** The different types of search available. See term_dnet.mli for more explanations *) val search_pattern : types -> result list val search_concl : types -> result list val search_head_concl : types -> result list val search_eq_concl : constr -> types -> result list coq-8.4pl4/toplevel/autoinstance.mli0000644000175000017500000000275112326224777016672 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* rel_context -> constr list -> unit (** [search_declaration gr] Search in the library if the (new) * declaration gr can form an instance of a registered record/class *) val search_declaration : global_reference -> unit (** [search_record declf gr evm] Search the library for instances of the (new) record/class declaration [gr], and register them using [declf]. [evm] is the signature of the record (to avoid recomputing it) *) val search_record : instance_decl_function -> global_reference -> evar_map -> unit (** Instance declaration for both scenarios *) val declare_record_instance : instance_decl_function val declare_class_instance : instance_decl_function coq-8.4pl4/toplevel/toplevel.ml0000644000175000017500000003062612326224777015660 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string; mutable str : string; (* buffer of already read characters *) mutable len : int; (* number of chars in the buffer *) mutable bols : int list; (* offsets in str of begining of lines *) mutable tokens : Gram.parsable; (* stream of tokens *) mutable start : int } (* stream count of the first char of the buffer *) (* Double the size of the buffer. *) let resize_buffer ibuf = let nstr = String.create (2 * String.length ibuf.str + 1) in String.blit ibuf.str 0 nstr 0 (String.length ibuf.str); ibuf.str <- nstr (* Delete all irrelevent lines of the input buffer. Keep the last line in the buffer (useful when there are several commands on the same line. *) let resynch_buffer ibuf = match ibuf.bols with | ll::_ -> let new_len = ibuf.len - ll in String.blit ibuf.str ll ibuf.str 0 new_len; ibuf.len <- new_len; ibuf.bols <- []; ibuf.start <- ibuf.start + ll | _ -> () (* emacs special prompt tag for easy detection. No special character, to avoid interfering with utf8. Compatibility code removed. *) let emacs_prompt_startstring() = Printer.emacs_str "" let emacs_prompt_endstring() = Printer.emacs_str "" (* Read a char in an input channel, displaying a prompt at every beginning of line. *) let prompt_char ic ibuf count = let bol = match ibuf.bols with | ll::_ -> ibuf.len == ll | [] -> ibuf.len == 0 in if bol && not !print_emacs then msgerr (str (ibuf.prompt())); try let c = input_char ic in if c == '\n' then ibuf.bols <- (ibuf.len+1) :: ibuf.bols; if ibuf.len == String.length ibuf.str then resize_buffer ibuf; ibuf.str.[ibuf.len] <- c; ibuf.len <- ibuf.len + 1; Some c with End_of_file -> None (* Reinitialize the char stream (after a Drop) *) let reset_input_buffer ic ibuf = ibuf.str <- ""; ibuf.len <- 0; ibuf.bols <- []; ibuf.tokens <- Gram.parsable (Stream.from (prompt_char ic ibuf)); ibuf.start <- 0 (* Functions to print underlined locations from an input buffer. *) (* Given a location, returns the list of locations of each line. The last line is returned separately. It also checks the location bounds. *) let get_bols_of_loc ibuf (bp,ep) = let add_line (b,e) lines = if b < 0 or e < b then anomaly "Bad location"; match lines with | ([],None) -> ([], Some (b,e)) | (fl,oe) -> ((b,e)::fl, oe) in let rec lines_rec ba after = function | [] -> add_line (0,ba) after | ll::_ when ll <= bp -> add_line (ll,ba) after | ll::fl -> let nafter = if ll < ep then add_line (ll,ba) after else after in lines_rec ll nafter fl in let (fl,ll) = lines_rec ibuf.len ([],None) ibuf.bols in (fl,Option.get ll) let dotted_location (b,e) = if e-b < 3 then ("", String.make (e-b) ' ') else (String.make (e-b-1) '.', " ") let blanch_utf8_string s bp ep = let s' = String.make (ep-bp) ' ' in let j = ref 0 in for i = bp to ep - 1 do let n = Char.code s.[i] in (* Heuristic: assume utf-8 chars are printed using a single fixed-size char and therefore contract all utf-8 code into one space; in any case, preserve tabulation so that its effective interpretation in terms of spacing is preserved *) if s.[i] = '\t' then s'.[!j] <- '\t'; if n < 0x80 || 0xC0 <= n then incr j done; String.sub s' 0 !j let print_highlight_location ib loc = let (bp,ep) = unloc loc in let bp = bp - ib.start and ep = ep - ib.start in let highlight_lines = match get_bols_of_loc ib (bp,ep) with | ([],(bl,el)) -> let shift = blanch_utf8_string ib.str bl bp in let span = String.length (blanch_utf8_string ib.str bp ep) in (str"> " ++ str(String.sub ib.str bl (el-bl-1)) ++ fnl () ++ str"> " ++ str(shift) ++ str(String.make span '^')) | ((b1,e1)::ml,(bn,en)) -> let (d1,s1) = dotted_location (b1,bp) in let (dn,sn) = dotted_location (ep,en) in let l1 = (str"> " ++ str d1 ++ str s1 ++ str(String.sub ib.str bp (e1-bp))) in let li = prlist (fun (bi,ei) -> (str"> " ++ str(String.sub ib.str bi (ei-bi)))) ml in let ln = (str"> " ++ str(String.sub ib.str bn (ep-bn)) ++ str sn ++ str dn) in (l1 ++ li ++ ln) in let loc = make_loc (bp,ep) in (str"Toplevel input, characters " ++ Cerrors.print_loc loc ++ str":" ++ fnl () ++ highlight_lines ++ fnl ()) (* Functions to report located errors in a file. *) let print_location_in_file s inlibrary fname loc = let errstrm = str"Error while reading " ++ str s in if loc = dummy_loc then hov 1 (errstrm ++ spc() ++ str" (unknown location):") ++ fnl () else let errstrm = if s = fname then mt() else errstrm ++ str":" ++ fnl() in if inlibrary then hov 0 (errstrm ++ str"Module " ++ str ("\""^fname^"\"") ++ spc() ++ str"characters " ++ Cerrors.print_loc loc) ++ fnl () else let (bp,ep) = unloc loc in let ic = open_in fname in let rec line_of_pos lin bol cnt = if cnt < bp then if input_char ic == '\n' then line_of_pos (lin + 1) (cnt +1) (cnt+1) else line_of_pos lin bol (cnt+1) else (lin, bol) in try let (line, bol) = line_of_pos 1 0 0 in close_in ic; hov 0 (* No line break so as to follow emacs error message format *) (errstrm ++ str"File " ++ str ("\""^fname^"\"") ++ str", line " ++ int line ++ str", characters " ++ Cerrors.print_loc (make_loc (bp-bol,ep-bol))) ++ str":" ++ fnl () with e when Errors.noncritical e -> (close_in ic; hov 1 (errstrm ++ spc() ++ str"(invalid location):") ++ fnl ()) let print_command_location ib dloc = match dloc with | Some (bp,ep) -> (str"Error during interpretation of command:" ++ fnl () ++ str(String.sub ib.str (bp-ib.start) (ep-bp)) ++ fnl ()) | None -> (mt ()) let valid_loc dloc loc = loc <> dummy_loc & match dloc with | Some dloc -> let (bd,ed) = unloc dloc in let (b,e) = unloc loc in bd<=b & e<=ed | _ -> true let valid_buffer_loc ib dloc loc = valid_loc dloc loc & let (b,e) = unloc loc in b-ib.start >= 0 & e-ib.start < ib.len & b<=e (*s The Coq prompt is the name of the focused proof, if any, and "Coq" otherwise. We trap all exceptions to prevent the error message printing from cycling. *) let make_prompt () = try (Names.string_of_id (Pfedit.get_current_proof_name ())) ^ " < " with Proof_global.NoCurrentProof -> "Coq < " (*let build_pending_list l = let pl = ref ">" in let l' = ref l in let res = while List.length !l' > 1 do pl := !pl ^ "|" Names.string_of_id x; l':=List.tl !l' done in let last = try List.hd !l' with _ -> in "<"^l' *) (* the coq prompt added to the default one when in emacs mode The prompt contains the current state label [n] (for global backtracking) and the current proof state [p] (for proof backtracking) plus the list of open (nested) proofs (for proof aborting when backtracking). It looks like: "n |lem1|lem2|lem3| p < " *) let make_emacs_prompt() = let statnum = string_of_int (Lib.current_command_label ()) in let dpth = Pfedit.current_proof_depth() in let pending = Pfedit.get_all_proof_names() in let pendingprompt = List.fold_left (fun acc x -> acc ^ (if acc <> "" then "|" else "") ^ Names.string_of_id x) "" pending in let proof_info = if dpth >= 0 then string_of_int dpth else "0" in if !Flags.print_emacs then statnum ^ " |" ^ pendingprompt ^ "| " ^ proof_info ^ " < " else "" (* A buffer to store the current command read on stdin. It is * initialized when a vernac command is immediately followed by "\n", * or after a Drop. *) let top_buffer = let pr() = emacs_prompt_startstring() ^ make_prompt() ^ make_emacs_prompt() ^ emacs_prompt_endstring() in { prompt = pr; str = ""; len = 0; bols = []; tokens = Gram.parsable (Stream.of_list []); start = 0 } let set_prompt prompt = top_buffer.prompt <- (fun () -> emacs_prompt_startstring() ^ prompt () ^ emacs_prompt_endstring()) (* Removes and prints the location of the error. The following exceptions need not be located. *) let rec is_pervasive_exn = function | Out_of_memory | Stack_overflow | Sys.Break -> true | Error_in_file (_,_,e) -> is_pervasive_exn e | Loc.Exc_located (_,e) -> is_pervasive_exn e | DuringCommandInterp (_,e) -> is_pervasive_exn e | _ -> false (* Toplevel error explanation, dealing with locations, Drop, Ctrl-D May raise only the following exceptions: Drop and End_of_input, meaning we get out of the Coq loop *) let print_toplevel_error exc = let (dloc,exc) = match exc with | DuringCommandInterp (loc,ie) -> if loc = dummy_loc then (None,ie) else (Some loc, ie) | _ -> (None, exc) in let (locstrm,exc) = match exc with | Loc.Exc_located (loc, ie) -> if valid_buffer_loc top_buffer dloc loc then (print_highlight_location top_buffer loc, ie) else ((mt ()) (* print_command_location top_buffer dloc *), ie) | Error_in_file (s, (inlibrary, fname, loc), ie) -> (print_location_in_file s inlibrary fname loc, ie) | _ -> ((mt ()) (* print_command_location top_buffer dloc *), exc) in match exc with | End_of_input -> msgerrnl (mt ()); pp_flush(); exit 0 | Vernacexpr.Drop -> (* Last chance *) if Mltop.is_ocaml_top() then raise Vernacexpr.Drop; (str"Error: There is no ML toplevel." ++ fnl ()) | Vernacexpr.Quit -> raise Vernacexpr.Quit | _ -> (if is_pervasive_exn exc then (mt ()) else locstrm) ++ Errors.print exc (* Read the input stream until a dot is encountered *) let parse_to_dot = let rec dot st = match get_tok (Stream.next st) with | Tok.KEYWORD "." -> () | Tok.EOI -> raise End_of_input | _ -> dot st in Gram.Entry.of_parser "Coqtoplevel.dot" dot (* We assume that when a lexer error occurs, at least one char was eaten *) let rec discard_to_dot () = try Gram.entry_parse parse_to_dot top_buffer.tokens with Loc.Exc_located(_,(Token.Error _|Lexer.Error.E _)) -> discard_to_dot() (* If the error occured while parsing, we read the input until a dot token * in encountered. *) let process_error = function | DuringCommandInterp _ as e -> e | e -> if is_pervasive_exn e then e else try discard_to_dot (); e with | End_of_input -> End_of_input | any -> if is_pervasive_exn any then any else e (* do_vernac reads and executes a toplevel phrase, and print error messages when an exception is raised, except for the following: Drop: kill the Coq toplevel, going down to the Caml toplevel if it exists. Otherwise, exit. End_of_input: Ctrl-D was typed in, we will quit *) let do_vernac () = msgerrnl (mt ()); if !print_emacs then msgerr (str (top_buffer.prompt())); resynch_buffer top_buffer; begin try raw_do_vernac top_buffer.tokens with any -> msgnl (print_toplevel_error (process_error any)) end; flush_all() (* coq and go read vernacular expressions until Drop is entered. * Ctrl-C will raise the exception Break instead of aborting Coq. * Here we catch the exceptions terminating the Coq loop, and decide * if we really must quit. *) let rec loop () = Sys.catch_break true; try reset_input_buffer stdin top_buffer; while true do do_vernac() done with | Vernacexpr.Drop -> () | End_of_input -> msgerrnl (mt ()); pp_flush(); exit 0 | Vernacexpr.Quit -> exit 0 | any -> msgerrnl (str"Anomaly. Please report."); loop () coq-8.4pl4/toplevel/vernacentries.mli0000644000175000017500000000461012326224777017041 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit (** Vernacular entries *) val show_script : unit -> unit val show_prooftree : unit -> unit val show_node : unit -> unit (** This function can be used by any command that want to observe terms in the context of the current goal, as for instance in pcoq *) val get_current_context_of_args : int option -> Evd.evar_map * Environ.env type pcoq_hook = { start_proof : unit -> unit; solve : int -> unit; abort : string -> unit; search : searchable -> dir_path list * bool -> unit; print_name : Libnames.reference Genarg.or_by_notation -> unit; print_check : Environ.env -> Environ.unsafe_judgment -> unit; print_eval : Reductionops.reduction_function -> Environ.env -> Evd.evar_map -> constr_expr -> Environ.unsafe_judgment -> unit; show_goal : goal_reference -> unit } val set_pcoq_hook : pcoq_hook -> unit (** The main interpretation function of vernacular expressions *) val interp : Vernacexpr.vernac_expr -> unit (** Print subgoals when the verbose flag is on. Meant to be used inside vernac commands from plugins. *) val print_subgoals : unit -> unit (** The printing of goals via [print_subgoals] or during [interp] can be controlled by the following flag. Used for instance by coqide, since it has its own goal-fetching mechanism. *) val enable_goal_printing : bool ref (** Should Qed try to display the proof script ? True by default, but false in ProofGeneral and coqIDE *) val qed_display_script : bool ref (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name followed by enough pattern variables. [Not_found] is raised if the given string isn't the qualid of a known inductive type. *) val make_cases : string -> string list list coq-8.4pl4/toplevel/indschemes.ml0000644000175000017500000003721712326224777016153 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* !elim_flag) ; optwrite = (fun b -> elim_flag := b) } let case_flag = ref false let _ = declare_bool_option { optsync = true; optdepr = false; optname = "automatic declaration of case analysis schemes"; optkey = ["Case";"Analysis";"Schemes"]; optread = (fun () -> !case_flag) ; optwrite = (fun b -> case_flag := b) } let eq_flag = ref false let _ = declare_bool_option { optsync = true; optdepr = false; optname = "automatic declaration of boolean equality"; optkey = ["Boolean";"Equality";"Schemes"]; optread = (fun () -> !eq_flag) ; optwrite = (fun b -> eq_flag := b) } let _ = (* compatibility *) declare_bool_option { optsync = true; optdepr = true; optname = "automatic declaration of boolean equality"; optkey = ["Equality";"Scheme"]; optread = (fun () -> !eq_flag) ; optwrite = (fun b -> eq_flag := b) } let is_eq_flag () = !eq_flag && Flags.version_strictly_greater Flags.V8_2 let eq_dec_flag = ref false let _ = declare_bool_option { optsync = true; optdepr = false; optname = "automatic declaration of decidable equality"; optkey = ["Decidable";"Equality";"Schemes"]; optread = (fun () -> !eq_dec_flag) ; optwrite = (fun b -> eq_dec_flag := b) } let rewriting_flag = ref false let _ = declare_bool_option { optsync = true; optdepr = false; optname ="automatic declaration of rewriting schemes for equality types"; optkey = ["Rewriting";"Schemes"]; optread = (fun () -> !rewriting_flag) ; optwrite = (fun b -> rewriting_flag := b) } (* Util *) let define id internal c t = let f = declare_constant ~internal in let kn = f id (DefinitionEntry { const_entry_body = c; const_entry_secctx = None; const_entry_type = t; const_entry_opaque = false }, Decl_kinds.IsDefinition Scheme) in definition_message id; kn (* Boolean equality *) let declare_beq_scheme_gen internal names kn = ignore (define_mutual_scheme beq_scheme_kind internal names kn) let alarm what internal msg = let debug = false in match internal with | KernelVerbose | KernelSilent -> (if debug then Flags.if_warn Pp.msg_warning (hov 0 msg ++ fnl () ++ what ++ str " not defined.")) | _ -> errorlabstrm "" msg let try_declare_scheme what f internal names kn = try f internal names kn with | ParameterWithoutEquality cst -> alarm what internal (str "Boolean equality not found for parameter " ++ pr_con cst ++ str".") | InductiveWithProduct -> alarm what internal (str "Unable to decide equality of functional arguments.") | InductiveWithSort -> alarm what internal (str "Unable to decide equality of type arguments.") | NonSingletonProp ind -> alarm what internal (str "Cannot extract computational content from proposition " ++ quote (Printer.pr_inductive (Global.env()) ind) ++ str ".") | EqNotFound (ind',ind) -> alarm what internal (str "Boolean equality on " ++ quote (Printer.pr_inductive (Global.env()) ind') ++ strbrk " is missing.") | UndefinedCst s -> alarm what internal (strbrk "Required constant " ++ str s ++ str " undefined.") | AlreadyDeclared msg -> alarm what internal (msg ++ str ".") | e when Errors.noncritical e -> alarm what internal (str "Unknown exception during scheme creation.") let beq_scheme_msg mind = let mib = Global.lookup_mind mind in (* TODO: mutual inductive case *) str "Boolean equality on " ++ pr_enum (fun ind -> quote (Printer.pr_inductive (Global.env()) ind)) (list_tabulate (fun i -> (mind,i)) (Array.length mib.mind_packets)) let declare_beq_scheme_with l kn = try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen UserVerbose l kn let try_declare_beq_scheme kn = (* TODO: handle Fix, eventually handle proof-irrelevance; improve decidability by depending on decidability for the parameters rather than on the bl and lb properties *) try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen KernelVerbose [] kn let declare_beq_scheme = declare_beq_scheme_with [] (* Case analysis schemes *) let declare_one_case_analysis_scheme ind = let (mib,mip) = Global.lookup_inductive ind in let kind = inductive_sort_family mip in let dep = if kind = InProp then case_scheme_kind_from_prop else case_dep_scheme_kind_from_type in let kelim = elim_sorts (mib,mip) in (* in case the inductive has a type elimination, generates only one induction scheme, the other ones share the same code with the apropriate type *) if List.mem InType kelim then ignore (define_individual_scheme dep KernelVerbose None ind) (* Induction/recursion schemes *) let kinds_from_prop = [InType,rect_scheme_kind_from_prop; InProp,ind_scheme_kind_from_prop; InSet,rec_scheme_kind_from_prop] let kinds_from_type = [InType,rect_dep_scheme_kind_from_type; InProp,ind_dep_scheme_kind_from_type; InSet,rec_dep_scheme_kind_from_type] let declare_one_induction_scheme ind = let (mib,mip) = Global.lookup_inductive ind in let kind = inductive_sort_family mip in let from_prop = kind = InProp in let kelim = elim_sorts (mib,mip) in let elims = list_map_filter (fun (sort,kind) -> if List.mem sort kelim then Some kind else None) (if from_prop then kinds_from_prop else kinds_from_type) in List.iter (fun kind -> ignore (define_individual_scheme kind KernelVerbose None ind)) elims let declare_induction_schemes kn = let mib = Global.lookup_mind kn in if mib.mind_finite then begin for i = 0 to Array.length mib.mind_packets - 1 do declare_one_induction_scheme (kn,i); done; end (* Decidable equality *) let declare_eq_decidability_gen internal names kn = let mib = Global.lookup_mind kn in if mib.mind_finite then ignore (define_mutual_scheme eq_dec_scheme_kind internal names kn) let eq_dec_scheme_msg ind = (* TODO: mutual inductive case *) str "Decidable equality on " ++ quote (Printer.pr_inductive (Global.env()) ind) let declare_eq_decidability_scheme_with l kn = try_declare_scheme (eq_dec_scheme_msg (kn,0)) declare_eq_decidability_gen UserVerbose l kn let try_declare_eq_decidability kn = try_declare_scheme (eq_dec_scheme_msg (kn,0)) declare_eq_decidability_gen KernelVerbose [] kn let declare_eq_decidability = declare_eq_decidability_scheme_with [] let ignore_error f x = try ignore (f x) with e when Errors.noncritical e -> () let declare_rewriting_schemes ind = if Hipattern.is_inductive_equality ind then begin ignore (define_individual_scheme rew_r2l_scheme_kind KernelVerbose None ind); ignore (define_individual_scheme rew_r2l_dep_scheme_kind KernelVerbose None ind); ignore (define_individual_scheme rew_r2l_forward_dep_scheme_kind KernelVerbose None ind); (* These ones expect the equality to be symmetric; the first one also *) (* needs eq *) ignore_error (define_individual_scheme rew_l2r_scheme_kind KernelVerbose None) ind; ignore_error (define_individual_scheme rew_l2r_dep_scheme_kind KernelVerbose None) ind; ignore_error (define_individual_scheme rew_l2r_forward_dep_scheme_kind KernelVerbose None) ind end let declare_congr_scheme ind = if Hipattern.is_equality_type (mkInd ind) then begin if try Coqlib.check_required_library Coqlib.logic_module_name; true with e when Errors.noncritical e -> false then ignore (define_individual_scheme congr_scheme_kind KernelVerbose None ind) else msg_warn "Cannot build congruence scheme because eq is not found" end let declare_sym_scheme ind = if Hipattern.is_inductive_equality ind then (* Expect the equality to be symmetric *) ignore_error (define_individual_scheme sym_scheme_kind KernelVerbose None) ind (* Scheme command *) let rec split_scheme l = let env = Global.env() in match l with | [] -> [],[] | (Some id,t)::q -> let l1,l2 = split_scheme q in ( match t with | InductionScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2 | CaseScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2 | EqualityScheme x -> l1,((Some id,smart_global_inductive x)::l2) ) (* if no name has been provided, we build one from the types of the ind requested *) | (None,t)::q -> let l1,l2 = split_scheme q in let names inds recs isdep y z = let ind = smart_global_inductive y in let sort_of_ind = inductive_sort_family (snd (lookup_mind_specif env ind)) in let z' = family_of_sort (interp_sort z) in let suffix = ( match sort_of_ind with | InProp -> if isdep then (match z' with | InProp -> inds ^ "_dep" | InSet -> recs ^ "_dep" | InType -> recs ^ "t_dep") else ( match z' with | InProp -> inds | InSet -> recs | InType -> recs ^ "t" ) | _ -> if isdep then (match z' with | InProp -> inds | InSet -> recs | InType -> recs ^ "t" ) else (match z' with | InProp -> inds ^ "_nodep" | InSet -> recs ^ "_nodep" | InType -> recs ^ "t_nodep") ) in let newid = add_suffix (basename_of_global (IndRef ind)) suffix in let newref = (dummy_loc,newid) in ((newref,isdep,ind,z)::l1),l2 in match t with | CaseScheme (x,y,z) -> names "_case" "_case" x y z | InductionScheme (x,y,z) -> names "_ind" "_rec" x y z | EqualityScheme x -> l1,((None,smart_global_inductive x)::l2) let do_mutual_induction_scheme lnamedepindsort = let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort and sigma = Evd.empty and env0 = Global.env() in let lrecspec = List.map (fun (_,dep,ind,sort) -> (ind,dep,interp_elimination_sort sort)) lnamedepindsort in let listdecl = Indrec.build_mutual_induction_scheme env0 sigma lrecspec in let rec declare decl fi lrecref = let decltype = Retyping.get_type_of env0 Evd.empty decl in let decltype = refresh_universes decltype in let cst = define fi UserVerbose decl (Some decltype) in ConstRef cst :: lrecref in let _ = List.fold_right2 declare listdecl lrecnames [] in fixpoint_message None lrecnames let get_common_underlying_mutual_inductive = function | [] -> assert false | (id,(mind,i as ind))::l as all -> match List.filter (fun (_,(mind',_)) -> mind <> mind') l with | (_,ind')::_ -> raise (RecursionSchemeError (NotMutualInScheme (ind,ind'))) | [] -> if not (list_distinct (List.map snd (List.map snd all))) then error "A type occurs twice"; mind, list_map_filter (function (Some id,(_,i)) -> Some (i,snd id) | (None,_) -> None) all let do_scheme l = let ischeme,escheme = split_scheme l in (* we want 1 kind of scheme at a time so we check if the user tried to declare different schemes at once *) if (ischeme <> []) && (escheme <> []) then error "Do not declare equality and induction scheme at the same time." else ( if ischeme <> [] then do_mutual_induction_scheme ischeme else let mind,l = get_common_underlying_mutual_inductive escheme in declare_beq_scheme_with l mind; declare_eq_decidability_scheme_with l mind ) (**********************************************************************) (* Combined scheme *) (* Matthieu Sozeau, Dec 2006 *) let list_split_rev_at index l = let rec aux i acc = function hd :: tl when i = index -> acc, tl | hd :: tl -> aux (succ i) (hd :: acc) tl | [] -> failwith "list_split_when: Invalid argument" in aux 0 [] l let fold_left' f = function [] -> raise (Invalid_argument "fold_left'") | hd :: tl -> List.fold_left f hd tl let build_combined_scheme env schemes = let defs = List.map (fun cst -> (cst, Typeops.type_of_constant env cst)) schemes in (* let nschemes = List.length schemes in *) let find_inductive ty = let (ctx, arity) = decompose_prod ty in let (_, last) = List.hd ctx in match kind_of_term last with | App (ind, args) -> let ind = destInd ind in let (_,spec) = Inductive.lookup_mind_specif env ind in ctx, ind, spec.mind_nrealargs | _ -> ctx, destInd last, 0 in let (c, t) = List.hd defs in let ctx, ind, nargs = find_inductive t in (* Number of clauses, including the predicates quantification *) let prods = nb_prod t - (nargs + 1) in let coqand = Coqlib.build_coq_and () and coqconj = Coqlib.build_coq_conj () in let relargs = rel_vect 0 prods in let concls = List.rev_map (fun (cst, t) -> mkApp(mkConst cst, relargs), snd (decompose_prod_n prods t)) defs in let concl_bod, concl_typ = fold_left' (fun (accb, acct) (cst, x) -> mkApp (coqconj, [| x; acct; cst; accb |]), mkApp (coqand, [| x; acct |])) concls in let ctx, _ = list_split_rev_at prods (List.rev_map (fun (x, y) -> x, None, y) ctx) in let typ = it_mkProd_wo_LetIn concl_typ ctx in let body = it_mkLambda_or_LetIn concl_bod ctx in (body, typ) let do_combined_scheme name schemes = let csts = List.map (fun x -> let refe = Ident x in let qualid = qualid_of_reference refe in try Nametab.locate_constant (snd qualid) with Not_found -> error ((string_of_qualid (snd qualid))^" is not declared.")) schemes in let body,typ = build_combined_scheme (Global.env ()) csts in ignore (define (snd name) UserVerbose body (Some typ)); fixpoint_message None [snd name] (**********************************************************************) let map_inductive_block f kn n = for i=0 to n-1 do f (kn,i) done let mutual_inductive_size kn = Array.length (Global.lookup_mind kn).mind_packets let declare_default_schemes kn = let n = mutual_inductive_size kn in if !elim_flag then declare_induction_schemes kn; if !case_flag then map_inductive_block declare_one_case_analysis_scheme kn n; if is_eq_flag() then try_declare_beq_scheme kn; if !eq_dec_flag then try_declare_eq_decidability kn; if !rewriting_flag then map_inductive_block declare_congr_scheme kn n; if !rewriting_flag then map_inductive_block declare_sym_scheme kn n; if !rewriting_flag then map_inductive_block declare_rewriting_schemes kn n coq-8.4pl4/toplevel/vernacinterp.ml0000644000175000017500000000354512326224777016526 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Drop then e else UserError("Vernac.disable_drop",(str"Drop is forbidden.")) (* Table of vernac entries *) let vernac_tab = (Hashtbl.create 51 : (string, Tacexpr.raw_generic_argument list -> unit -> unit) Hashtbl.t) let vinterp_add s f = try Hashtbl.add vernac_tab s f with Failure _ -> errorlabstrm "vinterp_add" (str"Cannot add the vernac command " ++ str s ++ str" twice.") let overwriting_vinterp_add s f = begin try let _ = Hashtbl.find vernac_tab s in Hashtbl.remove vernac_tab s with Not_found -> () end; Hashtbl.add vernac_tab s f let vinterp_map s = try Hashtbl.find vernac_tab s with Not_found -> errorlabstrm "Vernac Interpreter" (str"Cannot find vernac command " ++ str s ++ str".") let vinterp_init () = Hashtbl.clear vernac_tab (* Interpretation of a vernac command *) let call (opn,converted_args) = let loc = ref "Looking up command" in try let callback = vinterp_map opn in loc:= "Checking arguments"; let hunk = callback converted_args in loc:= "Executing command"; hunk() with | Drop -> raise Drop | reraise -> if !Flags.debug then msgnl (str"Vernac Interpreter " ++ str !loc); raise reraise coq-8.4pl4/toplevel/doc.tex0000644000175000017500000000036612326224777014761 0ustar stephsteph \newpage \section*{The Coq toplevel} \ocwsection \label{toplevel} This chapter describes the highest modules of the \Coq\ system. They are organized as follows: \bigskip \begin{center}\epsfig{file=toplevel.dep.ps,width=\linewidth}\end{center} coq-8.4pl4/toplevel/vernacentries.ml0000644000175000017500000017071012326224777016675 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit; solve : int -> unit; abort : string -> unit; search : searchable -> dir_path list * bool -> unit; print_name : reference Genarg.or_by_notation -> unit; print_check : Environ.env -> Environ.unsafe_judgment -> unit; print_eval : Reductionops.reduction_function -> Environ.env -> Evd.evar_map -> constr_expr -> Environ.unsafe_judgment -> unit; show_goal : goal_reference -> unit } let pcoq = ref None let set_pcoq_hook f = pcoq := Some f (* Misc *) let cl_of_qualid = function | FunClass -> Classops.CL_FUN | SortClass -> Classops.CL_SORT | RefClass r -> Class.class_of_global (Smartlocate.smart_global r) (*******************) (* "Show" commands *) let show_proof () = (* spiwack: this would probably be cooler with a bit of polishing. *) let p = Proof_global.give_me_the_proof () in let pprf = Proof.partial_proof p in msgnl (Util.prlist_with_sep Pp.fnl Printer.pr_constr pprf) let show_node () = (* spiwack: I'm have little clue what this function used to do. I deactivated it, could, possibly, be cleaned away. (Feb. 2010) *) () (* indentation code for Show Script, initially contributed by D. de Rauglaudre *) let indent_script_item ((ng1,ngl1),nl,beginend,ppl) (cmd,ng) = (* ng1 : number of goals remaining at the current level (before cmd) ngl1 : stack of previous levels with their remaining goals ng : number of goals after the execution of cmd beginend : special indentation stack for { } *) let ngprev = List.fold_left (+) ng1 ngl1 in let new_ngl = if ng > ngprev then (* We've branched *) (ng - ngprev + 1, ng1 - 1 :: ngl1) else if ng < ngprev then (* A subgoal have been solved. Let's compute the new current level by discarding all levels with 0 remaining goals. *) let _ = assert (ng = ngprev - 1) in let rec loop = function | (0, ng2::ngl2) -> loop (ng2,ngl2) | p -> p in loop (ng1-1, ngl1) else (* Standard case, same goal number as before *) (ng1, ngl1) in (* When a subgoal have been solved, separate this block by an empty line *) let new_nl = (ng < ngprev) in (* Indentation depth *) let ind = List.length ngl1 in (* Some special handling of bullets and { }, to get a nicer display *) let pred n = max 0 (n-1) in let ind, nl, new_beginend = match cmd with | VernacSubproof _ -> pred ind, nl, (pred ind)::beginend | VernacEndSubproof -> List.hd beginend, false, List.tl beginend | VernacBullet _ -> pred ind, nl, beginend | _ -> ind, nl, beginend in let pp = (if nl then fnl () else mt ()) ++ (hov (ind+1) (str (String.make ind ' ') ++ Ppvernac.pr_vernac cmd)) in (new_ngl, new_nl, new_beginend, pp :: ppl) let show_script () = let prf = Pfedit.get_current_proof_name () in let cmds = Backtrack.get_script prf in let _,_,_,indented_cmds = List.fold_left indent_script_item ((1,[]),false,[],[]) cmds in let indented_cmds = List.rev (indented_cmds) in msgnl (v 0 (Util.prlist_with_sep Pp.fnl (fun x -> x) indented_cmds)) let show_thesis () = msgnl (anomaly "TODO" ) let show_top_evars () = (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) let pfts = get_pftreestate () in let gls = Proof.V82.subgoals pfts in let sigma = gls.Evd.sigma in msg (pr_evars_int 1 (Evarutil.non_instantiated sigma)) let show_prooftree () = (* Spiwack: proof tree is currently not working *) () let enable_goal_printing = ref true let print_subgoals () = if !enable_goal_printing && is_verbose () then msg (pr_open_subgoals ()) let try_print_subgoals () = Pp.flush_all(); try print_subgoals () with Proof_global.NoCurrentProof | UserError _ -> () (* Simulate the Intro(s) tactic *) let show_intro all = let pf = get_pftreestate() in let {Evd.it=gls ; sigma=sigma} = Proof.V82.subgoals pf in let gl = {Evd.it=List.hd gls ; sigma = sigma} in let l,_= decompose_prod_assum (strip_outer_cast (pf_concl gl)) in if all then let lid = Tactics.find_intro_names l gl in msgnl (hov 0 (prlist_with_sep spc pr_id lid)) else try let n = list_last l in msgnl (pr_id (List.hd (Tactics.find_intro_names [n] gl))) with Failure "list_last" -> message "" (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name followed by enough pattern variables. [Not_found] is raised if the given string isn't the qualid of a known inductive type. *) let make_cases s = let qualified_name = Libnames.qualid_of_string s in let glob_ref = Nametab.locate qualified_name in match glob_ref with | Libnames.IndRef i -> let {Declarations.mind_nparams = np} , {Declarations.mind_consnames = carr ; Declarations.mind_nf_lc = tarr } = Global.lookup_inductive i in Util.array_fold_right2 (fun consname typ l -> let al = List.rev (fst (Term.decompose_prod typ)) in let al = Util.list_skipn np al in let rec rename avoid = function | [] -> [] | (n,_)::l -> let n' = Namegen.next_name_away_in_cases_pattern n avoid in string_of_id n' :: rename (n'::avoid) l in let al' = rename [] al in (string_of_id consname :: al') :: l) carr tarr [] | _ -> raise Not_found (** Textual display of a generic "match" template *) let show_match id = let patterns = try make_cases (string_of_id (snd id)) with Not_found -> error "Unknown inductive type." in let pr_branch l = str "| " ++ hov 1 (prlist_with_sep spc str l) ++ str " =>" in msg (v 1 (str "match # with" ++ fnl () ++ prlist_with_sep fnl pr_branch patterns ++ fnl () ++ str "end" ++ fnl ())) (* "Print" commands *) let print_path_entry (s,l) = (str (string_of_dirpath l) ++ str " " ++ tbrk (0,0) ++ str s) let print_loadpath dir = let l = Library.get_full_load_paths () in let l = match dir with | None -> l | Some dir -> List.filter (fun (s,l) -> is_dirpath_prefix_of dir l) l in msgnl (Pp.t (str "Logical Path: " ++ tab () ++ str "Physical path:" ++ fnl () ++ prlist_with_sep pr_fnl print_path_entry l)) let print_modules () = let opened = Library.opened_libraries () and loaded = Library.loaded_libraries () in (* we intersect over opened to preserve the order of opened since *) (* non-commutative operations (e.g. visibility) are done at import time *) let loaded_opened = list_intersect opened loaded and only_loaded = list_subtract loaded opened in str"Loaded and imported library files: " ++ pr_vertical_list pr_dirpath loaded_opened ++ fnl () ++ str"Loaded and not imported library files: " ++ pr_vertical_list pr_dirpath only_loaded let print_module r = let (loc,qid) = qualid_of_reference r in try let globdir = Nametab.locate_dir qid in match globdir with DirModule (dirpath,(mp,_)) -> msgnl (Printmod.print_module (Printmod.printable_body dirpath) mp) | _ -> raise Not_found with Not_found -> msgnl (str"Unknown Module " ++ pr_qualid qid) let print_modtype r = let (loc,qid) = qualid_of_reference r in try let kn = Nametab.locate_modtype qid in msgnl (Printmod.print_modtype kn) with Not_found -> (* Is there a module of this name ? If yes we display its type *) try let mp = Nametab.locate_module qid in msgnl (Printmod.print_module false mp) with Not_found -> msgnl (str"Unknown Module Type or Module " ++ pr_qualid qid) let dump_universes_gen g s = let output = open_out s in let output_constraint, close = if Filename.check_suffix s ".dot" || Filename.check_suffix s ".gv" then begin (* the lazy unit is to handle errors while printing the first line *) let init = lazy (Printf.fprintf output "digraph universes {\n") in begin fun kind left right -> let () = Lazy.force init in match kind with | Univ.Lt -> Printf.fprintf output " \"%s\" -> \"%s\" [style=bold];\n" right left | Univ.Le -> Printf.fprintf output " \"%s\" -> \"%s\" [style=solid];\n" right left | Univ.Eq -> Printf.fprintf output " \"%s\" -> \"%s\" [style=dashed];\n" left right end, begin fun () -> if Lazy.lazy_is_val init then Printf.fprintf output "}\n"; close_out output end end else begin begin fun kind left right -> let kind = match kind with | Univ.Lt -> "<" | Univ.Le -> "<=" | Univ.Eq -> "=" in Printf.fprintf output "%s %s %s ;\n" left kind right end, (fun () -> close_out output) end in try Univ.dump_universes output_constraint g; close (); msgnl (str ("Universes written to file \""^s^"\".")) with reraise -> close (); raise reraise let dump_universes sorted s = let g = Global.universes () in let g = if sorted then Univ.sort_universes g else g in dump_universes_gen g s (*********************) (* "Locate" commands *) let locate_file f = let _,file = System.find_file_in_path ~warn:false (Library.get_load_paths ()) f in msgnl (str file) let msg_found_library = function | Library.LibLoaded, fulldir, file -> msgnl (hov 0 (pr_dirpath fulldir ++ strbrk " has been loaded from file " ++ str file)) | Library.LibInPath, fulldir, file -> msgnl (hov 0 (pr_dirpath fulldir ++ strbrk " is bound to file " ++ str file)) let msg_notfound_library loc qid = function | Library.LibUnmappedDir -> let dir = fst (repr_qualid qid) in user_err_loc (loc,"locate_library", strbrk "Cannot find a physical path bound to logical path " ++ pr_dirpath dir ++ str".") | Library.LibNotFound -> msgnl (hov 0 (strbrk "Unable to locate library " ++ pr_qualid qid ++ str".")) | e -> assert false let print_located_library r = let (loc,qid) = qualid_of_reference r in try msg_found_library (Library.locate_qualified_library false qid) with e when Errors.noncritical e -> msg_notfound_library loc qid e let print_located_module r = let (loc,qid) = qualid_of_reference r in let msg = try let dir = Nametab.full_name_module qid in str "Module " ++ pr_dirpath dir with Not_found -> (if fst (repr_qualid qid) = empty_dirpath then str "No module is referred to by basename " else str "No module is referred to by name ") ++ pr_qualid qid in msgnl msg let print_located_tactic r = let (loc,qid) = qualid_of_reference r in msgnl (try str "Ltac " ++ pr_path (Nametab.path_of_tactic (Nametab.locate_tactic qid)) with Not_found -> str "No Ltac definition is referred to by " ++ pr_qualid qid) let smart_global r = let gr = Smartlocate.smart_global r in Dumpglob.add_glob (Genarg.loc_of_or_by_notation loc_of_reference r) gr; gr let dump_global r = try let gr = Smartlocate.smart_global r in Dumpglob.add_glob (Genarg.loc_of_or_by_notation loc_of_reference r) gr with e when Errors.noncritical e -> () (**********) (* Syntax *) let vernac_syntax_extension = Metasyntax.add_syntax_extension let vernac_delimiters = Metasyntax.add_delimiters let vernac_bind_scope sc cll = List.iter (fun cl -> Metasyntax.add_class_scope sc (cl_of_qualid cl)) cll let vernac_open_close_scope = Notation.open_close_scope let vernac_arguments_scope local r scl = Notation.declare_arguments_scope local (smart_global r) scl let vernac_infix = Metasyntax.add_infix let vernac_notation = Metasyntax.add_notation (***********) (* Gallina *) let start_proof_and_print k l hook = check_locality (); (* early check, cf #2975 *) start_proof_com k l hook; print_subgoals (); if !pcoq <> None then (Option.get !pcoq).start_proof () let vernac_definition (local,k) (loc,id as lid) def hook = if local = Local then Dumpglob.dump_definition lid true "var" else Dumpglob.dump_definition lid false "def"; (match def with | ProveBody (bl,t) -> (* local binders, typ *) let hook _ _ = () in start_proof_and_print (local,DefinitionBody Definition) [Some lid, (bl,t,None)] hook | DefineBody (bl,red_option,c,typ_opt) -> let red_option = match red_option with | None -> None | Some r -> let (evc,env)= get_current_context () in Some (snd (interp_redexp env evc r)) in let ce,imps = interp_definition bl red_option c typ_opt in declare_definition id (local,k) ce imps hook) let vernac_start_proof kind l lettop hook = if Dumpglob.dump () then List.iter (fun (id, _) -> match id with | Some lid -> Dumpglob.dump_definition lid false "prf" | None -> ()) l; if not(refining ()) then if lettop then errorlabstrm "Vernacentries.StartProof" (str "Let declarations can only be used in proof editing mode."); start_proof_and_print (Global, Proof kind) l hook let qed_display_script = ref true let vernac_end_proof = function | Admitted -> Backtrack.mark_unreachable [Pfedit.get_current_proof_name ()]; admit () | Proved (is_opaque,idopt) -> let prf = Pfedit.get_current_proof_name () in if is_verbose () && !qed_display_script then (show_script (); msg (fnl())); begin match idopt with | None -> save_named is_opaque | Some ((_,id),None) -> save_anonymous is_opaque id | Some ((_,id),Some kind) -> save_anonymous_with_strength kind is_opaque id end; Backtrack.mark_unreachable [prf] (* A stupid macro that should be replaced by ``Exact c. Save.'' all along the theories [??] *) let vernac_exact_proof c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the begining of a proof. *) let prf = Pfedit.get_current_proof_name () in by (Tactics.exact_proof c); save_named true; Backtrack.mark_unreachable [prf] let vernac_assumption kind l nl= let global = fst kind = Global in List.iter (fun (is_coe,(idl,c)) -> if Dumpglob.dump () then List.iter (fun lid -> if global then Dumpglob.dump_definition lid false "ax" else Dumpglob.dump_definition lid true "var") idl; let t,imps = interp_assumption [] c in declare_assumptions idl is_coe kind t imps false nl) l let vernac_record k finite infer struc binders sort nameopt cfs = let const = match nameopt with | None -> add_prefix "Build_" (snd (snd struc)) | Some (_,id as lid) -> Dumpglob.dump_definition lid false "constr"; id in if Dumpglob.dump () then ( Dumpglob.dump_definition (snd struc) false "rec"; List.iter (fun (((_, x), _), _) -> match x with | Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj" | _ -> ()) cfs); ignore(Record.definition_structure (k,finite,infer,struc,binders,cfs,const,sort)) let vernac_inductive finite infer indl = if Dumpglob.dump () then List.iter (fun (((coe,lid), _, _, _, cstrs), _) -> match cstrs with | Constructors cstrs -> Dumpglob.dump_definition lid false "ind"; List.iter (fun (_, (lid, _)) -> Dumpglob.dump_definition lid false "constr") cstrs | _ -> () (* dumping is done by vernac_record (called below) *) ) indl; match indl with | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] -> vernac_record (match b with Class true -> Class false | _ -> b) finite infer id bl c oc fs | [ ( id , bl , c , Class true, Constructors [l]), _ ] -> let f = let (coe, ((loc, id), ce)) = l in let coe' = if coe then Some true else None in (((coe', AssumExpr ((loc, Name id), ce)), None), []) in vernac_record (Class true) finite infer id bl c None [f] | [ ( id , bl , c , Class true, _), _ ] -> Util.error "Definitional classes must have a single method" | [ ( id , bl , c , Class false, Constructors _), _ ] -> Util.error "Inductive classes not supported" | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] -> Util.error "where clause not supported for (co)inductive records" | _ -> let unpack = function | ( (_, id) , bl , c , _ , Constructors l ) , ntn -> ( id , bl , c , l ) , ntn | _ -> Util.error "Cannot handle mutually (co)inductive records." in let indl = List.map unpack indl in do_mutual_inductive indl (recursivity_flag_of_kind finite) let vernac_fixpoint l = if Dumpglob.dump () then List.iter (fun ((lid, _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; do_fixpoint l let vernac_cofixpoint l = if Dumpglob.dump () then List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; do_cofixpoint l let vernac_scheme l = if Dumpglob.dump () then List.iter (fun (lid, s) -> Option.iter (fun lid -> Dumpglob.dump_definition lid false "def") lid; match s with | InductionScheme (_, r, _) | CaseScheme (_, r, _) | EqualityScheme r -> dump_global r) l; Indschemes.do_scheme l let vernac_combined_scheme lid l = if Dumpglob.dump () then (Dumpglob.dump_definition lid false "def"; List.iter (fun lid -> dump_global (Genarg.AN (Ident lid))) l); Indschemes.do_combined_scheme lid l (**********************) (* Modules *) let vernac_import export refl = let import ref = Library.import_module export (qualid_of_reference ref) in List.iter import refl; Lib.add_frozen_state () let vernac_declare_module export (loc, id) binders_ast mty_ast = (* We check the state of the system (in section, in module type) and what module information is supplied *) if Lib.sections_are_opened () then error "Modules and Module Types are not allowed inside sections."; let binders_ast = List.map (fun (export,idl,ty) -> if export <> None then error ("Arguments of a functor declaration cannot be exported. " ^ "Remove the \"Export\" and \"Import\" keywords from every functor " ^ "argument.") else (idl,ty)) binders_ast in let mp = Declaremods.declare_module Modintern.interp_modtype Modintern.interp_modexpr Modintern.interp_modexpr_or_modtype id binders_ast (Enforce mty_ast) [] in Dumpglob.dump_moddef loc mp "mod"; if_verbose message ("Module "^ string_of_id id ^" is declared"); Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = (* We check the state of the system (in section, in module type) and what module information is supplied *) if Lib.sections_are_opened () then error "Modules and Module Types are not allowed inside sections."; match mexpr_ast_l with | [] -> check_no_pending_proofs (); let binders_ast,argsexport = List.fold_right (fun (export,idl,ty) (args,argsexport) -> (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast ([],[]) in let mp = Declaremods.start_module Modintern.interp_modtype export id binders_ast mty_ast_o in Dumpglob.dump_moddef loc mp "mod"; if_verbose message ("Interactive Module "^ string_of_id id ^" started") ; List.iter (fun (export,id) -> Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export ) argsexport | _::_ -> let binders_ast = List.map (fun (export,idl,ty) -> if export <> None then error ("Arguments of a functor definition can be imported only if" ^ " the definition is interactive. Remove the \"Export\" and " ^ "\"Import\" keywords from every functor argument.") else (idl,ty)) binders_ast in let mp = Declaremods.declare_module Modintern.interp_modtype Modintern.interp_modexpr Modintern.interp_modexpr_or_modtype id binders_ast mty_ast_o mexpr_ast_l in Dumpglob.dump_moddef loc mp "mod"; if_verbose message ("Module "^ string_of_id id ^" is defined"); Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export let vernac_end_module export (loc,id as lid) = let mp = Declaremods.end_module () in Dumpglob.dump_modref loc mp "mod"; if_verbose message ("Module "^ string_of_id id ^" is defined") ; Option.iter (fun export -> vernac_import export [Ident lid]) export let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = if Lib.sections_are_opened () then error "Modules and Module Types are not allowed inside sections."; match mty_ast_l with | [] -> check_no_pending_proofs (); let binders_ast,argsexport = List.fold_right (fun (export,idl,ty) (args,argsexport) -> (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast ([],[]) in let mp = Declaremods.start_modtype Modintern.interp_modtype id binders_ast mty_sign in Dumpglob.dump_moddef loc mp "modtype"; if_verbose message ("Interactive Module Type "^ string_of_id id ^" started"); List.iter (fun (export,id) -> Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export ) argsexport | _ :: _ -> let binders_ast = List.map (fun (export,idl,ty) -> if export <> None then error ("Arguments of a functor definition can be imported only if" ^ " the definition is interactive. Remove the \"Export\" " ^ "and \"Import\" keywords from every functor argument.") else (idl,ty)) binders_ast in let mp = Declaremods.declare_modtype Modintern.interp_modtype Modintern.interp_modexpr_or_modtype id binders_ast mty_sign mty_ast_l in Dumpglob.dump_moddef loc mp "modtype"; if_verbose message ("Module Type "^ string_of_id id ^" is defined") let vernac_end_modtype (loc,id) = let mp = Declaremods.end_modtype () in Dumpglob.dump_modref loc mp "modtype"; if_verbose message ("Module Type "^ string_of_id id ^" is defined") let vernac_include l = Declaremods.declare_include Modintern.interp_modexpr_or_modtype l (**********************) (* Gallina extensions *) (* Sections *) let vernac_begin_section (_, id as lid) = check_no_pending_proofs (); Dumpglob.dump_definition lid true "sec"; Lib.open_section id let vernac_end_section (loc,_) = Dumpglob.dump_reference loc (string_of_dirpath (Lib.current_dirpath true)) "<>" "sec"; Lib.close_section () (* Dispatcher of the "End" command *) let vernac_end_segment (_,id as lid) = check_no_pending_proofs (); match Lib.find_opening_node id with | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid | Lib.OpenedModule (true,_,_,_) -> vernac_end_modtype lid | Lib.OpenedSection _ -> vernac_end_section lid | _ -> assert false (* Libraries *) let vernac_require import _ qidl = let qidl = List.map qualid_of_reference qidl in let modrefl = Flags.silently (List.map Library.try_locate_qualified_library) qidl in if Dumpglob.dump () then List.iter2 (fun (loc, _) dp -> Dumpglob.dump_libref loc dp "lib") qidl (List.map fst modrefl); Library.require_library_from_dirpath modrefl import (* Coercions and canonical structures *) let vernac_canonical r = Recordops.declare_canonical_structure (smart_global r) let vernac_coercion stre ref qids qidt = let target = cl_of_qualid qidt in let source = cl_of_qualid qids in let ref' = smart_global ref in Class.try_add_new_coercion_with_target ref' stre ~source ~target; if_verbose msgnl (pr_global ref' ++ str " is now a coercion") let vernac_identity_coercion stre id qids qidt = let target = cl_of_qualid qidt in let source = cl_of_qualid qids in Class.try_add_new_identity_coercion id stre ~source ~target (* Type classes *) let vernac_instance abst glob sup inst props pri = Dumpglob.dump_constraint inst false "inst"; ignore(Classes.new_instance ~abstract:abst ~global:glob sup inst props pri) let vernac_context l = Classes.context l let vernac_declare_instances glob ids = List.iter (fun (id) -> Classes.existing_instance glob id) ids let vernac_declare_class id = Classes.declare_class id (***********) (* Solving *) let command_focus = Proof.new_focus_kind () let focus_command_cond = Proof.no_cond command_focus let vernac_solve n tcom b = if not (refining ()) then error "Unknown command of the non proof-editing mode."; let p = Proof_global.give_me_the_proof () in Proof.transaction p begin fun () -> solve_nth n (Tacinterp.hide_interp tcom None) ~with_end_tac:b; (* in case a strict subtree was completed, go back to the top of the prooftree *) Proof_global.maximal_unfocus command_focus p; print_subgoals(); if !pcoq <> None then (Option.get !pcoq).solve n end (* A command which should be a tactic. It has been added by Christine to patch an error in the design of the proof machine, and enables to instantiate existential variables when there are no more goals to solve. It cannot be a tactic since all tactics fail if there are no further goals to prove. *) let vernac_solve_existential = instantiate_nth_evar_com let vernac_set_end_tac tac = if not (refining ()) then error "Unknown command of the non proof-editing mode."; if tac <> (Tacexpr.TacId []) then set_end_tac (Tacinterp.interp tac) else () (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) let vernac_set_used_variables l = let l = List.map snd l in if not (list_distinct l) then error "Used variables list contains duplicates"; let vars = Environ.named_context (Global.env ()) in List.iter (fun id -> if not (List.exists (fun (id',_,_) -> id = id') vars) then error ("Unknown variable: " ^ string_of_id id)) l; set_used_variables l (*****************************) (* Auxiliary file management *) let vernac_require_from export spec filename = Library.require_library_from_file None (System.expand_path_macros filename) export let vernac_add_loadpath isrec pdir ldiropt = let pdir = System.expand_path_macros pdir in let alias = match ldiropt with | None -> Nameops.default_root_prefix | Some ldir -> ldir in (if isrec then Mltop.add_rec_path else Mltop.add_path) ~unix_path:pdir ~coq_root:alias let vernac_remove_loadpath path = Library.remove_load_path (System.expand_path_macros path) (* Coq syntax for ML or system commands *) let vernac_add_ml_path isrec path = (if isrec then Mltop.add_rec_ml_dir else Mltop.add_ml_dir) (System.expand_path_macros path) let vernac_declare_ml_module local l = Mltop.declare_ml_modules local (List.map System.expand_path_macros l) let vernac_chdir = function | None -> message (Sys.getcwd()) | Some path -> begin try Sys.chdir (System.expand_path_macros path) with Sys_error str -> msg_warn ("Cd failed: " ^ str) end; if_verbose message (Sys.getcwd()) (********************) (* State management *) let vernac_write_state file = Pfedit.delete_all_proofs (); States.extern_state file let vernac_restore_state file = Pfedit.delete_all_proofs (); States.intern_state file (************) (* Commands *) let vernac_declare_tactic_definition (local,x,def) = Tacinterp.add_tacdef local x def let vernac_create_hintdb local id b = Auto.create_hint_db local id full_transparent_state b let vernac_remove_hints local dbs ids = Auto.remove_hints local dbs (List.map Smartlocate.global_with_alias ids) let vernac_hints local lb h = Auto.add_hints local lb (Auto.interp_hints h) let vernac_syntactic_definition lid = Dumpglob.dump_definition lid false "syndef"; Metasyntax.add_syntactic_definition (snd lid) let vernac_declare_implicits local r = function | [] -> Impargs.declare_implicits local (smart_global r) | _::_ as imps -> Impargs.declare_manual_implicits local (smart_global r) ~enriching:false (List.map (List.map (fun (ex,b,f) -> ex, (b,true,f))) imps) let vernac_declare_arguments local r l nargs flags = let extra_scope_flag = List.mem `ExtraScopes flags in let names = List.map (List.map (fun (id, _,_,_,_) -> id)) l in let names, rest = List.hd names, List.tl names in let scopes = List.map (List.map (fun (_,_, s, _,_) -> s)) l in if List.exists ((<>) names) rest then error "All arguments lists must declare the same names."; if not (Util.list_distinct (List.filter ((<>) Anonymous) names)) then error "Arguments names must be distinct."; let sr = smart_global r in let inf_names = Impargs.compute_implicits_names (Global.env()) (Global.type_of_global sr) in let string_of_name = function Anonymous -> "_" | Name id -> string_of_id id in let rec check li ld ls = match li, ld, ls with | [], [], [] -> () | [], Anonymous::ld, (Some _)::ls when extra_scope_flag -> check li ld ls | [], _::_, (Some _)::ls when extra_scope_flag -> error "Extra notation scopes can be set on anonymous arguments only" | [], x::_, _ -> error ("Extra argument " ^ string_of_name x ^ ".") | l, [], _ -> error ("The following arguments are not declared: " ^ (String.concat ", " (List.map string_of_name l)) ^ ".") | _::li, _::ld, _::ls -> check li ld ls | _ -> assert false in if l <> [[]] then List.iter2 (fun l -> check inf_names l) (names :: rest) scopes; (* we take extra scopes apart, and we check they are consistent *) let l, scopes = let scopes, rest = List.hd scopes, List.tl scopes in if List.exists (List.exists ((<>) None)) rest then error "Notation scopes can be given only once"; if not extra_scope_flag then l, scopes else let l, _ = List.split (List.map (list_chop (List.length inf_names)) l) in l, scopes in (* we interpret _ as the inferred names *) let l = if l = [[]] then l else let name_anons = function | (Anonymous, a,b,c,d), Name id -> Name id, a,b,c,d | x, _ -> x in List.map (fun ns -> List.map name_anons (List.combine ns inf_names)) l in let names_decl = List.map (List.map (fun (id, _,_,_,_) -> id)) l in let renamed_arg = ref None in let set_renamed a b = if !renamed_arg = None && a <> b then renamed_arg := Some(b,a) in let pr_renamed_arg () = match !renamed_arg with None -> "" | Some (o,n) -> "\nArgument "^string_of_id o ^" renamed to "^string_of_id n^"." in let some_renaming_specified = try Arguments_renaming.arguments_names sr <> names_decl with Not_found -> false in let some_renaming_specified, implicits = if l = [[]] then false, [[]] else Util.list_fold_map (fun sr il -> let sr', impl = Util.list_fold_map (fun b -> function | (Anonymous, _,_, true, max), Name id -> assert false | (Name x, _,_, true, _), Anonymous -> error ("Argument "^string_of_id x^" cannot be declared implicit.") | (Name iid, _,_, true, max), Name id -> set_renamed iid id; b || iid <> id, Some (ExplByName id, max, false) | (Name iid, _,_, _, _), Name id -> set_renamed iid id; b || iid <> id, None | _ -> b, None) sr (List.combine il inf_names) in sr || sr', Util.list_map_filter (fun x -> x) impl) some_renaming_specified l in if some_renaming_specified then if not (List.mem `Rename flags) then error ("To rename arguments the \"rename\" flag must be specified." ^ pr_renamed_arg ()) else Arguments_renaming.rename_arguments local sr names_decl; (* All other infos are in the first item of l *) let l = List.hd l in let some_implicits_specified = implicits <> [[]] in let scopes = List.map (function | None -> None | Some (o, k) -> try Some(ignore(Notation.find_scope k); k) with e when Errors.noncritical e -> Some (Notation.find_delimiters_scope o k)) scopes in let some_scopes_specified = List.exists ((<>) None) scopes in let rargs = Util.list_map_filter (function (n, true) -> Some n | _ -> None) (Util.list_map_i (fun i (_, b, _,_,_) -> i, b) 0 l) in if some_scopes_specified || List.mem `ClearScopes flags then vernac_arguments_scope local r scopes; if not some_implicits_specified && List.mem `DefaultImplicits flags then vernac_declare_implicits local r [] else if some_implicits_specified || List.mem `ClearImplicits flags then vernac_declare_implicits local r implicits; if nargs >= 0 && nargs < List.fold_left max 0 rargs then error "The \"/\" option must be placed after the last \"!\"."; let rec narrow = function | #Tacred.simpl_flag as x :: tl -> x :: narrow tl | [] -> [] | _ :: tl -> narrow tl in let flags = narrow flags in if rargs <> [] || nargs >= 0 || flags <> [] then match sr with | ConstRef _ as c -> Tacred.set_simpl_behaviour local c (rargs, nargs, flags) | _ -> errorlabstrm "" (strbrk "Modifiers of the behavior of the simpl tactic are relevant for constants only.") let vernac_reserve bl = let sb_decl = (fun (idl,c) -> let t = Constrintern.interp_type Evd.empty (Global.env()) c in let t = Detyping.detype false [] [] t in let t = aconstr_of_glob_constr [] [] t in Reserve.declare_reserved_type idl t) in List.iter sb_decl bl let vernac_generalizable = Implicit_quantifiers.declare_generalizable let make_silent_if_not_pcoq b = if !pcoq <> None then error "Turning on/off silent flag is not supported in Pcoq mode." else make_silent b let _ = declare_bool_option { optsync = false; optdepr = false; optname = "silent"; optkey = ["Silent"]; optread = is_silent; optwrite = make_silent_if_not_pcoq } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "implicit arguments"; optkey = ["Implicit";"Arguments"]; optread = Impargs.is_implicit_args; optwrite = Impargs.make_implicit_args } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "strict implicit arguments"; optkey = ["Strict";"Implicit"]; optread = Impargs.is_strict_implicit_args; optwrite = Impargs.make_strict_implicit_args } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "strong strict implicit arguments"; optkey = ["Strongly";"Strict";"Implicit"]; optread = Impargs.is_strongly_strict_implicit_args; optwrite = Impargs.make_strongly_strict_implicit_args } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "contextual implicit arguments"; optkey = ["Contextual";"Implicit"]; optread = Impargs.is_contextual_implicit_args; optwrite = Impargs.make_contextual_implicit_args } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "implicit status of reversible patterns"; optkey = ["Reversible";"Pattern";"Implicit"]; optread = Impargs.is_reversible_pattern_implicit_args; optwrite = Impargs.make_reversible_pattern_implicit_args } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "maximal insertion of implicit"; optkey = ["Maximal";"Implicit";"Insertion"]; optread = Impargs.is_maximal_implicit_args; optwrite = Impargs.make_maximal_implicit_args } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "automatic introduction of variables"; optkey = ["Automatic";"Introduction"]; optread = Flags.is_auto_intros; optwrite = make_auto_intros } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "coercion printing"; optkey = ["Printing";"Coercions"]; optread = (fun () -> !Constrextern.print_coercions); optwrite = (fun b -> Constrextern.print_coercions := b) } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "printing of existential variable instances"; optkey = ["Printing";"Existential";"Instances"]; optread = (fun () -> !Constrextern.print_evar_arguments); optwrite = (:=) Constrextern.print_evar_arguments } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "implicit arguments printing"; optkey = ["Printing";"Implicit"]; optread = (fun () -> !Constrextern.print_implicits); optwrite = (fun b -> Constrextern.print_implicits := b) } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "implicit arguments defensive printing"; optkey = ["Printing";"Implicit";"Defensive"]; optread = (fun () -> !Constrextern.print_implicits_defensive); optwrite = (fun b -> Constrextern.print_implicits_defensive := b) } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "projection printing using dot notation"; optkey = ["Printing";"Projections"]; optread = (fun () -> !Constrextern.print_projections); optwrite = (fun b -> Constrextern.print_projections := b) } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "notations printing"; optkey = ["Printing";"Notations"]; optread = (fun () -> not !Constrextern.print_no_symbol); optwrite = (fun b -> Constrextern.print_no_symbol := not b) } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "raw printing"; optkey = ["Printing";"All"]; optread = (fun () -> !Flags.raw_print); optwrite = (fun b -> Flags.raw_print := b) } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "record printing"; optkey = ["Printing";"Records"]; optread = (fun () -> !Flags.record_print); optwrite = (fun b -> Flags.record_print := b) } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "use of virtual machine inside the kernel"; optkey = ["Virtual";"Machine"]; optread = (fun () -> Vconv.use_vm ()); optwrite = (fun b -> Vconv.set_use_vm b) } let _ = declare_int_option { optsync = true; optdepr = false; optname = "the level of inling duging functor application"; optkey = ["Inline";"Level"]; optread = (fun () -> Some (Flags.get_inline_level ())); optwrite = (fun o -> let lev = Option.default Flags.default_inline_level o in Flags.set_inline_level lev) } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "use of boxed values"; optkey = ["Boxed";"Values"]; optread = (fun _ -> not (Vm.transp_values ())); optwrite = (fun b -> Vm.set_transp_values (not b)) } (* No more undo limit in the new proof engine. The command still exists for compatibility (e.g. with ProofGeneral) *) let _ = declare_int_option { optsync = false; optdepr = true; optname = "the undo limit (OBSOLETE)"; optkey = ["Undo"]; optread = (fun _ -> None); optwrite = (fun _ -> ()) } let _ = declare_int_option { optsync = false; optdepr = false; optname = "the hypotheses limit"; optkey = ["Hyps";"Limit"]; optread = Flags.print_hyps_limit; optwrite = Flags.set_print_hyps_limit } let _ = declare_int_option { optsync = true; optdepr = false; optname = "the printing depth"; optkey = ["Printing";"Depth"]; optread = Pp_control.get_depth_boxes; optwrite = Pp_control.set_depth_boxes } let _ = declare_int_option { optsync = true; optdepr = false; optname = "the printing width"; optkey = ["Printing";"Width"]; optread = Pp_control.get_margin; optwrite = Pp_control.set_margin } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "printing of universes"; optkey = ["Printing";"Universes"]; optread = (fun () -> !Constrextern.print_universes); optwrite = (fun b -> Constrextern.print_universes:=b) } let vernac_debug b = set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) let _ = declare_bool_option { optsync = false; optdepr = false; optname = "Ltac debug"; optkey = ["Ltac";"Debug"]; optread = (fun () -> get_debug () <> Tactic_debug.DebugOff); optwrite = vernac_debug } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "explicitly parsing implicit arguments"; optkey = ["Parsing";"Explicit"]; optread = (fun () -> !Constrintern.parsing_explicit); optwrite = (fun b -> Constrintern.parsing_explicit := b) } let vernac_set_opacity local str = let glob_ref r = match smart_global r with | ConstRef sp -> EvalConstRef sp | VarRef id -> EvalVarRef id | _ -> error "cannot set an inductive type or a constructor as transparent" in let str = List.map (fun (lev,ql) -> (lev,List.map glob_ref ql)) str in Redexpr.set_strategy local str let vernac_set_option locality key = function | StringValue s -> set_string_option_value_gen locality key s | IntValue n -> set_int_option_value_gen locality key n | BoolValue b -> set_bool_option_value_gen locality key b let vernac_unset_option locality key = unset_option_value_gen locality key let vernac_add_option key lv = let f = function | StringRefValue s -> (get_string_table key)#add s | QualidRefValue locqid -> (get_ref_table key)#add locqid in try List.iter f lv with Not_found -> error_undeclared_key key let vernac_remove_option key lv = let f = function | StringRefValue s -> (get_string_table key)#remove s | QualidRefValue locqid -> (get_ref_table key)#remove locqid in try List.iter f lv with Not_found -> error_undeclared_key key let vernac_mem_option key lv = let f = function | StringRefValue s -> (get_string_table key)#mem s | QualidRefValue locqid -> (get_ref_table key)#mem locqid in try List.iter f lv with Not_found -> error_undeclared_key key let vernac_print_option key = try (get_ref_table key)#print with Not_found -> try (get_string_table key)#print with Not_found -> try print_option_value key with Not_found -> error_undeclared_key key let get_current_context_of_args = function | Some n -> get_goal_context n | None -> get_current_context () let vernac_check_may_eval redexp glopt rc = let module P = Pretype_errors in let (sigma, env) = get_current_context_of_args glopt in let sigma', c = interp_open_constr sigma env rc in let sigma' = Evarconv.consider_remaining_unif_problems env sigma' in let j = try Evarutil.check_evars env sigma sigma' c; Arguments_renaming.rename_typing env c with P.PretypeError (_,_,P.UnsolvableImplicit _) | Compat.Loc.Exc_located (_,P.PretypeError (_,_,P.UnsolvableImplicit _)) -> Evarutil.j_nf_evar sigma' (Retyping.get_judgment_of env sigma' c) in match redexp with | None -> if !pcoq <> None then (Option.get !pcoq).print_check env j else msg (print_judgment env j) | Some r -> Tacinterp.dump_glob_red_expr r; let (sigma',r_interp) = interp_redexp env sigma' r in let redfun = fst (reduction_of_red_expr r_interp) in if !pcoq <> None then (Option.get !pcoq).print_eval redfun env sigma' rc j else msg (print_eval redfun env sigma' rc j) let vernac_declare_reduction locality s r = declare_red_expr locality s (snd (interp_redexp (Global.env()) Evd.empty r)) (* The same but avoiding the current goal context if any *) let vernac_global_check c = let evmap = Evd.empty in let env = Global.env() in let c = interp_constr evmap env c in let senv = Global.safe_env() in let j = Safe_typing.typing senv c in msg (print_safe_judgment env j) let vernac_print = function | PrintTables -> print_tables () | PrintFullContext-> msg (print_full_context_typ ()) | PrintSectionContext qid -> msg (print_sec_context_typ qid) | PrintInspect n -> msg (inspect n) | PrintGrammar ent -> Metasyntax.print_grammar ent | PrintLoadPath dir -> (* For compatibility ? *) print_loadpath dir | PrintModules -> msg (print_modules ()) | PrintModule qid -> print_module qid | PrintModuleType qid -> print_modtype qid | PrintMLLoadPath -> Mltop.print_ml_path () | PrintMLModules -> Mltop.print_ml_modules () | PrintName qid -> if !pcoq <> None then (Option.get !pcoq).print_name qid else msg (print_name qid) | PrintGraph -> ppnl (Prettyp.print_graph()) | PrintClasses -> ppnl (Prettyp.print_classes()) | PrintTypeClasses -> ppnl (Prettyp.print_typeclasses()) | PrintInstances c -> ppnl (Prettyp.print_instances (smart_global c)) | PrintLtac qid -> ppnl (Tacinterp.print_ltac (snd (qualid_of_reference qid))) | PrintCoercions -> ppnl (Prettyp.print_coercions()) | PrintCoercionPaths (cls,clt) -> ppnl (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt)) | PrintCanonicalConversions -> ppnl (Prettyp.print_canonical_projections ()) | PrintUniverses (b, None) -> let univ = Global.universes () in let univ = if b then Univ.sort_universes univ else univ in pp (Univ.pr_universes univ) | PrintUniverses (b, Some s) -> dump_universes b s | PrintHint r -> Auto.print_hint_ref (smart_global r) | PrintHintGoal -> Auto.print_applicable_hint () | PrintHintDbName s -> Auto.print_hint_db_by_name s | PrintRewriteHintDbName s -> Autorewrite.print_rewrite_hintdb s | PrintHintDb -> Auto.print_searchtable () | PrintScopes -> pp (Notation.pr_scopes (Constrextern.without_symbols pr_lglob_constr)) | PrintScope s -> pp (Notation.pr_scope (Constrextern.without_symbols pr_lglob_constr) s) | PrintVisibility s -> pp (Notation.pr_visibility (Constrextern.without_symbols pr_lglob_constr) s) | PrintAbout qid -> msg (print_about qid) | PrintImplicit qid -> dump_global qid; msg (print_impargs qid) | PrintAssumptions (o,r) -> (* Prints all the axioms and section variables used by a term *) let cstr = constr_of_global (smart_global r) in let st = Conv_oracle.get_transp_state () in let nassums = Assumptions.assumptions st ~add_opaque:o cstr in msg (Printer.pr_assumptionset (Global.env ()) nassums) let global_module r = let (loc,qid) = qualid_of_reference r in try Nametab.full_name_module qid with Not_found -> user_err_loc (loc, "global_module", str "Module/section " ++ pr_qualid qid ++ str " not found.") let interp_search_restriction = function | SearchOutside l -> (List.map global_module l, true) | SearchInside l -> (List.map global_module l, false) open Search let is_ident s = try ignore (check_ident s); true with UserError _ -> false let interp_search_about_item = function | SearchSubPattern pat -> let _,pat = intern_constr_pattern Evd.empty (Global.env()) pat in GlobSearchSubPattern pat | SearchString (s,None) when is_ident s -> GlobSearchString s | SearchString (s,sc) -> try let ref = Notation.interp_notation_as_global_reference dummy_loc (fun _ -> true) s sc in GlobSearchSubPattern (Pattern.PRef ref) with UserError _ -> error ("Unable to interp \""^s^"\" either as a reference or \ as an identifier component") let vernac_search s r = let r = interp_search_restriction r in if !pcoq <> None then (Option.get !pcoq).search s r else match s with | SearchPattern c -> let (_,c) = interp_open_constr_patvar Evd.empty (Global.env()) c in Search.search_pattern c r | SearchRewrite c -> let _,pat = interp_open_constr_patvar Evd.empty (Global.env()) c in Search.search_rewrite pat r | SearchHead c -> let _,pat = interp_open_constr_patvar Evd.empty (Global.env()) c in Search.search_by_head pat r | SearchAbout sl -> Search.search_about (List.map (on_snd interp_search_about_item) sl) r let vernac_locate = function | LocateTerm (Genarg.AN qid) -> msgnl (print_located_qualid qid) | LocateTerm (Genarg.ByNotation (_,ntn,sc)) -> ppnl (Notation.locate_notation (Constrextern.without_symbols pr_lglob_constr) ntn sc) | LocateLibrary qid -> print_located_library qid | LocateModule qid -> print_located_module qid | LocateTactic qid -> print_located_tactic qid | LocateFile f -> locate_file f (****************) (* Backtracking *) (** NB: these commands are now forbidden in non-interactive use, e.g. inside VernacLoad, VernacList, ... *) let vernac_backto lbl = try let lbl' = Backtrack.backto lbl in if lbl <> lbl' then Pp.msg_warning (str "Actually back to state "++ Pp.int lbl' ++ str "."); try_print_subgoals () with Backtrack.Invalid -> error "Invalid backtrack." let vernac_back n = try let extra = Backtrack.back n in if extra <> 0 then Pp.msg_warning (str "Actually back by " ++ Pp.int (extra+n) ++ str " steps."); try_print_subgoals () with Backtrack.Invalid -> error "Invalid backtrack." let vernac_reset_name id = try let globalized = try let gr = Smartlocate.global_with_alias (Ident id) in Dumpglob.add_glob (fst id) gr; true with e when Errors.noncritical e -> false in if not globalized then begin try begin match Lib.find_opening_node (snd id) with | Lib.OpenedSection _ -> Dumpglob.dump_reference (fst id) (string_of_dirpath (Lib.current_dirpath true)) "<>" "sec"; (* Might be nice to implement module cases, too.... *) | _ -> () end with UserError _ -> () end; if Backtrack.is_active () then (Backtrack.reset_name id; try_print_subgoals ()) else (* When compiling files, Reset is now allowed again as asked by A. Chlipala. we emulate a simple reset, that discards all proofs. *) let lbl = Lib.label_before_name id in Pfedit.delete_all_proofs (); Pp.msg_warning (str "Reset command occurred in non-interactive mode."); Lib.reset_label lbl with Backtrack.Invalid | Not_found -> error "Invalid Reset." let vernac_reset_initial () = if Backtrack.is_active () then Backtrack.reset_initial () else begin Pp.msg_warning (str "Reset command occurred in non-interactive mode."); Lib.reset_label Lib.first_command_label end (* For compatibility with ProofGeneral: *) let vernac_backtrack snum pnum naborts = Backtrack.backtrack snum pnum naborts; try_print_subgoals () (********************) (* Proof management *) let vernac_abort = function | None -> Backtrack.mark_unreachable [Pfedit.get_current_proof_name ()]; delete_current_proof (); if_verbose message "Current goal aborted"; if !pcoq <> None then (Option.get !pcoq).abort "" | Some id -> Backtrack.mark_unreachable [snd id]; delete_proof id; let s = string_of_id (snd id) in if_verbose message ("Goal "^s^" aborted"); if !pcoq <> None then (Option.get !pcoq).abort s let vernac_abort_all () = if refining() then begin Backtrack.mark_unreachable (Pfedit.get_all_proof_names ()); delete_all_proofs (); message "Current goals aborted" end else error "No proof-editing in progress." let vernac_restart () = Backtrack.mark_unreachable [Pfedit.get_current_proof_name ()]; restart_proof(); print_subgoals () let vernac_undo n = let d = Pfedit.current_proof_depth () - n in Backtrack.mark_unreachable ~after:d [Pfedit.get_current_proof_name ()]; Pfedit.undo n; print_subgoals () let vernac_undoto n = Backtrack.mark_unreachable ~after:n [Pfedit.get_current_proof_name ()]; Pfedit.undo_todepth n; print_subgoals () let vernac_focus gln = let p = Proof_global.give_me_the_proof () in let n = match gln with None -> 1 | Some n -> n in if n = 0 then Util.error "Invalid goal number: 0. Goal numbering starts with 1." else Proof.focus focus_command_cond () n p; print_subgoals () (* Unfocuses one step in the focus stack. *) let vernac_unfocus () = let p = Proof_global.give_me_the_proof () in Proof.unfocus command_focus p; print_subgoals () (* Checks that a proof is fully unfocused. Raises an error if not. *) let vernac_unfocused () = let p = Proof_global.give_me_the_proof () in if Proof.unfocused p then msg (str"The proof is indeed fully unfocused.") else error "The proof is not fully unfocused." (* BeginSubproof / EndSubproof. BeginSubproof (vernac_subproof) focuses on the first goal, or the goal given as argument. EndSubproof (vernac_end_subproof) unfocuses from a BeginSubproof, provided that the proof of the goal has been completed. *) let subproof_kind = Proof.new_focus_kind () let subproof_cond = Proof.done_cond subproof_kind let vernac_subproof gln = let p = Proof_global.give_me_the_proof () in begin match gln with | None -> Proof.focus subproof_cond () 1 p | Some n -> Proof.focus subproof_cond () n p end ; print_subgoals () let vernac_end_subproof () = let p = Proof_global.give_me_the_proof () in Proof.unfocus subproof_kind p ; print_subgoals () let vernac_bullet (bullet:Proof_global.Bullet.t) = let p = Proof_global.give_me_the_proof () in Proof.transaction p (fun () -> Proof_global.Bullet.put p bullet); (* Makes the focus visible in emacs by re-printing the goal. *) if !Flags.print_emacs then print_subgoals () let vernac_show = function | ShowGoal goalref -> if !pcoq <> None then (Option.get !pcoq).show_goal goalref else msg (match goalref with | OpenSubgoals -> pr_open_subgoals () | NthGoal n -> pr_nth_open_subgoal n | GoalId id -> pr_goal_by_id id) | ShowGoalImplicitly None -> Constrextern.with_implicits msg (pr_open_subgoals ()) | ShowGoalImplicitly (Some n) -> Constrextern.with_implicits msg (pr_nth_open_subgoal n) | ShowProof -> show_proof () | ShowNode -> show_node () | ShowScript -> show_script () | ShowExistentials -> show_top_evars () | ShowTree -> show_prooftree () | ShowProofNames -> msgnl (prlist_with_sep pr_spc pr_id (Pfedit.get_all_proof_names())) | ShowIntros all -> show_intro all | ShowMatch id -> show_match id | ShowThesis -> show_thesis () let vernac_check_guard () = let pts = get_pftreestate () in let pfterm = List.hd (Proof.partial_proof pts) in let message = try let { Evd.it=gl ; sigma=sigma } = Proof.V82.top_goal pts in Inductiveops.control_only_guard (Goal.V82.env sigma gl) pfterm; (str "The condition holds up to here") with UserError(_,s) -> (str ("Condition violated: ") ++s) in msgnl message let interp c = match c with (* Control (done in vernac) *) | (VernacTime _|VernacList _|VernacLoad _|VernacTimeout _|VernacFail _) -> assert false (* Syntax *) | VernacTacticNotation (n,r,e) -> Metasyntax.add_tactic_notation (n,r,e) | VernacSyntaxExtension (lcl,sl) -> vernac_syntax_extension lcl sl | VernacDelimiters (sc,lr) -> vernac_delimiters sc lr | VernacBindScope (sc,rl) -> vernac_bind_scope sc rl | VernacOpenCloseScope sc -> vernac_open_close_scope sc | VernacArgumentsScope (lcl,qid,scl) -> vernac_arguments_scope lcl qid scl | VernacInfix (local,mv,qid,sc) -> vernac_infix local mv qid sc | VernacNotation (local,c,infpl,sc) -> vernac_notation local c infpl sc (* Gallina *) | VernacDefinition (k,lid,d,f) -> vernac_definition k lid d f | VernacStartTheoremProof (k,l,top,f) -> vernac_start_proof k l top f | VernacEndProof e -> vernac_end_proof e | VernacExactProof c -> vernac_exact_proof c | VernacAssumption (stre,nl,l) -> vernac_assumption stre l nl | VernacInductive (finite,infer,l) -> vernac_inductive finite infer l | VernacFixpoint l -> vernac_fixpoint l | VernacCoFixpoint l -> vernac_cofixpoint l | VernacScheme l -> vernac_scheme l | VernacCombinedScheme (id, l) -> vernac_combined_scheme id l (* Modules *) | VernacDeclareModule (export,lid,bl,mtyo) -> vernac_declare_module export lid bl mtyo | VernacDefineModule (export,lid,bl,mtys,mexprl) -> vernac_define_module export lid bl mtys mexprl | VernacDeclareModuleType (lid,bl,mtys,mtyo) -> vernac_declare_module_type lid bl mtys mtyo | VernacInclude in_asts -> vernac_include in_asts (* Gallina extensions *) | VernacBeginSection lid -> vernac_begin_section lid | VernacEndSegment lid -> vernac_end_segment lid | VernacRequire (export,spec,qidl) -> vernac_require export spec qidl | VernacImport (export,qidl) -> vernac_import export qidl | VernacCanonical qid -> vernac_canonical qid | VernacCoercion (str,r,s,t) -> vernac_coercion str r s t | VernacIdentityCoercion (str,(_,id),s,t) -> vernac_identity_coercion str id s t (* Type classes *) | VernacInstance (abst, glob, sup, inst, props, pri) -> vernac_instance abst glob sup inst props pri | VernacContext sup -> vernac_context sup | VernacDeclareInstances (glob, ids) -> vernac_declare_instances glob ids | VernacDeclareClass id -> vernac_declare_class id (* Solving *) | VernacSolve (n,tac,b) -> vernac_solve n tac b | VernacSolveExistential (n,c) -> vernac_solve_existential n c (* Auxiliary file and library management *) | VernacRequireFrom (exp,spec,f) -> vernac_require_from exp spec f | VernacAddLoadPath (isrec,s,alias) -> vernac_add_loadpath isrec s alias | VernacRemoveLoadPath s -> vernac_remove_loadpath s | VernacAddMLPath (isrec,s) -> vernac_add_ml_path isrec s | VernacDeclareMLModule (local, l) -> vernac_declare_ml_module local l | VernacChdir s -> vernac_chdir s (* State management *) | VernacWriteState s -> vernac_write_state s | VernacRestoreState s -> vernac_restore_state s (* Resetting *) | VernacResetName id -> vernac_reset_name id | VernacResetInitial -> vernac_reset_initial () | VernacBack n -> vernac_back n | VernacBackTo n -> vernac_backto n (* Commands *) | VernacDeclareTacticDefinition def -> vernac_declare_tactic_definition def | VernacCreateHintDb (local,dbname,b) -> vernac_create_hintdb local dbname b | VernacRemoveHints (local,dbnames,ids) -> vernac_remove_hints local dbnames ids | VernacHints (local,dbnames,hints) -> vernac_hints local dbnames hints | VernacSyntacticDefinition (id,c,l,b) ->vernac_syntactic_definition id c l b | VernacDeclareImplicits (local,qid,l) ->vernac_declare_implicits local qid l | VernacArguments (local, qid, l, narg, flags) -> vernac_declare_arguments local qid l narg flags | VernacReserve bl -> vernac_reserve bl | VernacGeneralizable (local,gen) -> vernac_generalizable local gen | VernacSetOpacity (local,qidl) -> vernac_set_opacity local qidl | VernacSetOption (locality,key,v) -> vernac_set_option locality key v | VernacUnsetOption (locality,key) -> vernac_unset_option locality key | VernacRemoveOption (key,v) -> vernac_remove_option key v | VernacAddOption (key,v) -> vernac_add_option key v | VernacMemOption (key,v) -> vernac_mem_option key v | VernacPrintOption key -> vernac_print_option key | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval r g c | VernacDeclareReduction (b,s,r) -> vernac_declare_reduction b s r | VernacGlobalCheck c -> vernac_global_check c | VernacPrint p -> vernac_print p | VernacSearch (s,r) -> vernac_search s r | VernacLocate l -> vernac_locate l | VernacComments l -> if_verbose message ("Comments ok\n") | VernacNop -> () (* Proof management *) | VernacGoal t -> vernac_start_proof Theorem [None,([],t,None)] false (fun _ _->()) | VernacAbort id -> vernac_abort id | VernacAbortAll -> vernac_abort_all () | VernacRestart -> vernac_restart () | VernacUndo n -> vernac_undo n | VernacUndoTo n -> vernac_undoto n | VernacBacktrack (snum,pnum,naborts) -> vernac_backtrack snum pnum naborts | VernacFocus n -> vernac_focus n | VernacUnfocus -> vernac_unfocus () | VernacUnfocused -> vernac_unfocused () | VernacBullet b -> vernac_bullet b | VernacSubproof n -> vernac_subproof n | VernacEndSubproof -> vernac_end_subproof () | VernacShow s -> vernac_show s | VernacCheckGuard -> vernac_check_guard () | VernacProof (None, None) -> print_subgoals () | VernacProof (Some tac, None) -> vernac_set_end_tac tac ; print_subgoals () | VernacProof (None, Some l) -> vernac_set_used_variables l ; print_subgoals () | VernacProof (Some tac, Some l) -> vernac_set_end_tac tac; vernac_set_used_variables l ; print_subgoals () | VernacProofMode mn -> Proof_global.set_proof_mode mn (* Toplevel control *) | VernacToplevelControl e -> raise e (* Extensions *) | VernacExtend (opn,args) -> Vernacinterp.call (opn,args) let interp c = interp c ; check_locality () coq-8.4pl4/toplevel/autoinstance.ml0000644000175000017500000002744412326224777016527 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* rel_context -> constr list -> unit (* * Search algorithm *) let rec subst_evar evar def n c = match kind_of_term c with | Evar (e,_) when e=evar -> lift n def | _ -> map_constr_with_binders (fun n->n+1) (subst_evar evar def) n c let subst_evar_in_evm evar def evm = Evd.fold (fun ev evi acc -> let evar_body = match evi.evar_body with | Evd.Evar_empty -> Evd.Evar_empty | Evd.Evar_defined c -> Evd.Evar_defined (subst_evar evar def 0 c) in let evar_concl = subst_evar evar def 0 evi.evar_concl in Evd.add acc ev {evi with evar_body=evar_body; evar_concl=evar_concl} ) evm empty (* Tries to define ev by c in evd. Fails if ev := c1 and c1 /= c ev : * T1, c : T2 and T1 /= T2. Defines recursively all evars instantiated * by this definition. *) let rec safe_define evm ev c = if not (closedn (-1) c) then raise Termops.CannotFilter else (* msgnl(str"safe_define "++pr_evar_map evm++spc()++str" |- ?"++Util.pr_int ev++str" := "++pr_constr c);*) let evi = (Evd.find evm ev) in let define_subst evm sigma = Util.Intmap.fold ( fun ev (e,c) evm -> match kind_of_term c with Evar (i,_) when i=ev -> evm | _ -> safe_define evm ev (lift (-List.length e) c) ) sigma evm in match evi.evar_body with | Evd.Evar_defined def -> define_subst evm (Termops.filtering [] Reduction.CUMUL def c) | Evd.Evar_empty -> let t = Libtypes.reduce (Typing.type_of (Global.env()) evm c) in let u = Libtypes.reduce (evar_concl evi) in let evm = subst_evar_in_evm ev c evm in define_subst (Evd.define ev c evm) (Termops.filtering [] Reduction.CUMUL t u) let add_gen_ctx (cl,gen,evm) ctx : signature * constr list = let rec really_new_evar () = let ev = Evarutil.new_untyped_evar() in if Evd.is_evar evm ev then really_new_evar() else ev in let add_gen_evar (cl,gen,evm) ev ty : signature = let evm = Evd.add evm ev (Evd.make_evar Environ.empty_named_context_val ty) in (cl,ev::gen,evm) in let rec mksubst b = function | [] -> [] | a::tl -> b::(mksubst (a::b) tl) in let evl = List.map (fun _ -> really_new_evar()) ctx in let evcl = List.map (fun i -> mkEvar (i,[||])) evl in let substl = List.rev (mksubst [] (evcl)) in let ctx = List.map2 (fun s t -> substnl s 0 t) substl ctx in let sign = List.fold_left2 add_gen_evar (cl,gen,evm) (List.rev evl) ctx in sign,evcl (* TODO : for full proof-irrelevance in the search, provide a real compare function for constr instead of Pervasive's one! *) module SubstSet : Set.S with type elt = Termops.subst = Set.Make (struct type t = Termops.subst let compare = Util.Intmap.compare (Pervasives.compare) end) (* searches instatiations in the library for just one evar [ev] of a signature. [k] is called on each resulting signature *) let complete_evar (cl,gen,evm:signature) (ev,evi) (k:signature -> unit) = let ev_typ = Libtypes.reduce (evar_concl evi) in let sort_is_prop = is_Prop (Typing.type_of (Global.env()) evm (evar_concl evi)) in (* msgnl(str"cherche "++pr_constr ev_typ++str" pour "++Util.pr_int ev);*) let substs = ref SubstSet.empty in try List.iter ( fun (gr,(pat,_),s) -> let (_,genl,_) = Termops.decompose_prod_letin pat in let genl = List.map (fun (_,_,t) -> t) genl in let ((cl,gen,evm),argl) = add_gen_ctx (cl,gen,evm) genl in let def = applistc (Libnames.constr_of_global gr) argl in (* msgnl(str"essayons ?"++Util.pr_int ev++spc()++str":="++spc() ++pr_constr def++spc()++str":"++spc()++pr_constr (Global.type_of_global gr)*) (*++spc()++str"dans"++spc()++pr_evar_map evm++spc());*) try let evm = safe_define evm ev def in k (cl,gen,evm); if sort_is_prop && SubstSet.mem s !substs then raise Exit; substs := SubstSet.add s !substs with Termops.CannotFilter -> () ) (Libtypes.search_concl ev_typ) with Exit -> () let evm_fold_rev f evm acc = let l = Evd.fold (fun ev evi acc -> (ev,evi)::acc) evm [] in List.fold_left (fun acc (ev,evi) -> f ev evi acc) acc l exception Continue of Evd.evar * Evd.evar_info (* searches matches for all the uninstantiated evars of evd in the context. For each totally instantiated evar_map found, apply k. *) let rec complete_signature (k:signature -> unit) (cl,gen,evm:signature) = try evm_fold_rev ( fun ev evi _ -> if not (is_defined evm ev) && not (List.mem ev gen) then raise (Continue (ev,evi)) ) evm (); k (cl,gen,evm) with Continue (ev,evi) -> complete_evar (cl,gen,evm) (ev,evi) (complete_signature k) (* define all permutations of the evars to evd and call k on the resulting evd *) let complete_with_evars_permut (cl,gen,evm:signature) evl c (k:signature -> unit) : unit = let rec aux evm = List.iter ( fun (ctx,ev) -> let tyl = List.map (fun (_,_,t) -> t) ctx in let ((cl,gen,evm),argl) = add_gen_ctx (cl,gen,evm) tyl in let def = applistc c argl in (* msgnl(str"trouvÃĐ def ?"++Util.pr_int ev++str" := "++pr_constr def++str " dans "++pr_evar_map evm);*) try if not (Evd.is_defined evm ev) then let evm = safe_define evm ev def in aux evm; k (cl,gen,evm) with Termops.CannotFilter -> () ) evl in aux evm let new_inst_no = let cnt = ref 0 in fun () -> incr cnt; string_of_int !cnt let make_instance_ident gr = Nameops.add_suffix (Nametab.basename_of_global gr) ("_autoinstance_"^new_inst_no()) let new_instance_message ident typ def = Flags.if_verbose msgnl (str"new instance"++spc() ++Nameops.pr_id ident++spc()++str":"++spc() ++pr_constr typ++spc()++str":="++spc() ++pr_constr def) open Entries let rec deep_refresh_universes c = match kind_of_term c with | Sort (Type _) -> Termops.new_Type() | _ -> map_constr deep_refresh_universes c let declare_record_instance gr ctx params = let ident = make_instance_ident gr in let def = it_mkLambda_or_LetIn (applistc (constr_of_global gr) params) ctx in let def = deep_refresh_universes def in let ce = { const_entry_body= def; const_entry_secctx = None; const_entry_type=None; const_entry_opaque=false } in let cst = Declare.declare_constant ident (DefinitionEntry ce,Decl_kinds.IsDefinition Decl_kinds.StructureComponent) in new_instance_message ident (Typeops.type_of_constant (Global.env()) cst) def let declare_class_instance gr ctx params = let ident = make_instance_ident gr in let cl = Typeclasses.class_info gr in let (def,typ) = Typeclasses.instance_constructor cl params in let (def,typ) = it_mkLambda_or_LetIn (Option.get def) ctx, it_mkProd_or_LetIn typ ctx in let def = deep_refresh_universes def in let typ = deep_refresh_universes typ in let ce = Entries.DefinitionEntry { const_entry_type = Some typ; const_entry_secctx = None; const_entry_body= def; const_entry_opaque=false } in try let cst = Declare.declare_constant ident (ce,Decl_kinds.IsDefinition Decl_kinds.Instance) in Typeclasses.add_instance (Typeclasses.new_instance cl (Some 100) true (ConstRef cst)); new_instance_message ident typ def with e when Errors.noncritical e -> msgnl (str"Error defining instance := "++pr_constr def++str" : "++pr_constr typ++str" "++Errors.print e) let rec iter_under_prod (f:rel_context->constr->unit) (ctx:rel_context) t = f ctx t; match kind_of_term t with | Prod (n,t,c) -> iter_under_prod f ((n,None,t)::ctx) c | _ -> () (* main search function: search for total instances containing gr, and apply k to each of them *) let complete_signature_with_def gr deftyp (k:instance_decl_function -> signature -> unit) : unit = let gr_c = Libnames.constr_of_global gr in let (smap:(Libnames.global_reference * Evd.evar_map, ('a * 'b * Term.constr) list * Evd.evar) Gmapl.t ref) = ref Gmapl.empty in iter_under_prod ( fun ctx typ -> List.iter (fun ((cl,ev,evm),_,_) -> (* msgnl(pr_global gr++str" : "++pr_constr typ++str" matche ?"++Util.pr_int ev++str " dans "++pr_evar_map evm);*) smap := Gmapl.add (cl,evm) (ctx,ev) !smap) (Recordops.methods_matching typ) ) [] deftyp; Gmapl.iter ( fun (cl,evm) evl -> let f = if Typeclasses.is_class cl then declare_class_instance else declare_record_instance in complete_with_evars_permut (cl,[],evm) evl gr_c (fun sign -> complete_signature (k f) sign) ) !smap (* * Interface with other parts: hooks & declaration *) let evar_definition evi = match evar_body evi with Evar_empty -> assert false | Evar_defined c -> c let gen_sort_topo l evm = let iter_evar f ev = let rec aux c = match kind_of_term c with Evar (e,_) -> f e | _ -> iter_constr aux c in aux (Evd.evar_concl (Evd.find evm ev)); if Evd.is_defined evm ev then aux (evar_definition (Evd.find evm ev)) in let r = ref [] in let rec dfs ev = iter_evar dfs ev; if not(List.mem ev !r) then r := ev::!r in List.iter dfs l; List.rev !r (* register real typeclass instance given a totally defined evd *) let declare_instance (k:global_reference -> rel_context -> constr list -> unit) (cl,gen,evm:signature) = let evm = Evarutil.nf_evar_map evm in let gen = gen_sort_topo gen evm in let (evm,gen) = List.fold_right (fun ev (evm,gen) -> if Evd.is_defined evm ev then Evd.remove evm ev,gen else evm,(ev::gen)) gen (evm,[]) in (* msgnl(str"instance complÃĻte : ["++Util.prlist_with_sep (fun _ -> str";") Util.pr_int gen++str"] : "++spc()++pr_evar_map evm);*) let ngen = List.length gen in let (_,ctx,evm) = List.fold_left ( fun (i,ctx,evm) ev -> let ctx = (Anonymous,None,lift (-i) (Evd.evar_concl(Evd.find evm ev)))::ctx in let evm = subst_evar_in_evm ev (mkRel i) (Evd.remove evm ev) in (i-1,ctx,evm) ) (ngen,[],evm) gen in let fields = List.rev (Evd.fold ( fun ev evi l -> evar_definition evi::l ) evm []) in k cl ctx fields let autoinstance_opt = ref true let search_declaration gr = if !autoinstance_opt && not (Lib.is_modtype()) then let deftyp = Global.type_of_global gr in complete_signature_with_def gr deftyp declare_instance let search_record k cons sign = if !autoinstance_opt && not (Lib.is_modtype()) then complete_signature (declare_instance k) (cons,[],sign) (* let dh_key = Profile.declare_profile "declaration_hook" let ch_key = Profile.declare_profile "class_decl_hook" let declaration_hook = Profile.profile1 dh_key declaration_hook let class_decl_hook = Profile.profile1 ch_key class_decl_hook *) (* * Options and bookeeping *) let begin_autoinstance () = if not !autoinstance_opt then ( autoinstance_opt := true; ) let end_autoinstance () = if !autoinstance_opt then ( autoinstance_opt := false; ) let _ = Goptions.declare_bool_option { Goptions.optsync=true; Goptions.optdepr=false; Goptions.optkey=["Autoinstance"]; Goptions.optname="automatic typeclass instance recognition"; Goptions.optread=(fun () -> !autoinstance_opt); Goptions.optwrite=(fun b -> if b then begin_autoinstance() else end_autoinstance()) } coq-8.4pl4/toplevel/auto_ind_decl.mli0000644000175000017500000000307112326224777016762 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr array (** {6 Build equivalence between boolean equality and Leibniz equality } *) val lb_scheme_kind : mutual scheme_kind val make_lb_scheme : mutual_inductive -> constr array val bl_scheme_kind : mutual scheme_kind val make_bl_scheme : mutual_inductive -> constr array (** {6 Build decidability of equality } *) val eq_dec_scheme_kind : mutual scheme_kind val make_eq_decidability : mutual_inductive -> constr array coq-8.4pl4/toplevel/auto_ind_decl.ml0000644000175000017500000010267112326224777016617 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [] | t::q -> t::(kick_last q) | [] -> failwith "kick_last" and aux = function | (0,l') -> l' | (n,h::t) -> aux (n-1,t) | _ -> failwith "quick_chop" in if n > (List.length l) then failwith "quick_chop args" else kick_last (aux (n,l) ) let rec deconstruct_type t = let l,r = decompose_prod t in (List.map (fun (_,b) -> b) (List.rev l))@[r] exception EqNotFound of inductive * inductive exception EqUnknown of string exception UndefinedCst of string exception InductiveWithProduct exception InductiveWithSort exception ParameterWithoutEquality of constant exception NonSingletonProp of inductive let dl = dummy_loc (* Some pre declaration of constant we are going to use *) let bb = constr_of_global Coqlib.glob_bool let andb_prop = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb_prop let andb_true_intro = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb_true_intro let tt = constr_of_global Coqlib.glob_true let ff = constr_of_global Coqlib.glob_false let eq = constr_of_global Coqlib.glob_eq let sumbool = Coqlib.build_coq_sumbool let andb = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb let induct_on c = new_induct false [Tacexpr.ElimOnConstr (Evd.empty,(c,Glob_term.NoBindings))] None (None,None) None let destruct_on_using c id = new_destruct false [Tacexpr.ElimOnConstr (Evd.empty,(c,Glob_term.NoBindings))] None (None,Some (dl,Genarg.IntroOrAndPattern [ [dl,Genarg.IntroAnonymous]; [dl,Genarg.IntroIdentifier id]])) None let destruct_on c = new_destruct false [Tacexpr.ElimOnConstr (Evd.empty,(c,Glob_term.NoBindings))] None (None,None) None (* reconstruct the inductive with the correct deBruijn indexes *) let mkFullInd ind n = let mib = Global.lookup_mind (fst ind) in let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in (* params context divided *) let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in if nparrec > 0 then mkApp (mkInd ind, Array.of_list(extended_rel_list (nparrec+n) lnamesparrec)) else mkInd ind let check_bool_is_defined () = try let _ = Global.type_of_global Coqlib.glob_bool in () with e when Errors.noncritical e -> raise (UndefinedCst "bool") let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined") let build_beq_scheme kn = check_bool_is_defined (); (* fetching global env *) let env = Global.env() in (* fetching the mutual inductive body *) let mib = Global.lookup_mind kn in (* number of inductives in the mutual *) let nb_ind = Array.length mib.mind_packets in (* number of params in the type *) let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in (* params context divided *) let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in (* predef coq's boolean type *) (* rec name *) let rec_name i =(string_of_id (Array.get mib.mind_packets i).mind_typename)^ "_eqrec" in (* construct the "fun A B ... N, eqA eqB eqC ... N => fixpoint" part *) let create_input c = let myArrow u v = mkArrow u (lift 1 v) and eqName = function | Name s -> id_of_string ("eq_"^(string_of_id s)) | Anonymous -> id_of_string "eq_A" in let ext_rel_list = extended_rel_list 0 lnamesparrec in let lift_cnt = ref 0 in let eqs_typ = List.map (fun aa -> let a = lift !lift_cnt aa in incr lift_cnt; myArrow a (myArrow a bb) ) ext_rel_list in let eq_input = List.fold_left2 ( fun a b (n,_,_) -> (* mkLambda(n,b,a) ) *) (* here I leave the Naming thingy so that the type of the function is more readable for the user *) mkNamedLambda (eqName n) b a ) c (List.rev eqs_typ) lnamesparrec in List.fold_left (fun a (n,_,t) ->(* mkLambda(n,t,a)) eq_input rel_list *) (* Same here , hoping the auto renaming will do something good ;) *) mkNamedLambda (match n with Name s -> s | Anonymous -> id_of_string "A") t a) eq_input lnamesparrec in let make_one_eq cur = let ind = kn,cur in (* current inductive we are working on *) let cur_packet = mib.mind_packets.(snd ind) in (* Inductive toto : [rettyp] := *) let rettyp = Inductive.type_of_inductive env (mib,cur_packet) in (* split rettyp in a list without the non rec params and the last -> e.g. Inductive vec (A:Set) : nat -> Set := ... will do [nat] *) let rettyp_l = quick_chop nparrec (deconstruct_type rettyp) in (* give a type A, this function tries to find the equality on A declared previously *) (* nlist = the number of args (A , B , ... ) eqA = the deBruijn index of the first eq param ndx = how much to translate due to the 2nd Case *) let compute_A_equality rel_list nlist eqA ndx t = let lifti = ndx in let rec aux c = let (c,a) = Reductionops.whd_betaiota_stack Evd.empty c in match kind_of_term c with | Rel x -> mkRel (x-nlist+ndx) | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))) | Cast (x,_,_) -> aux (applist (x,a)) | App _ -> assert false | Ind (kn',i as ind') -> if eq_mind kn kn' then mkRel(eqA-nlist-i+nb_ind-1) else ( try let a = Array.of_list a in let eq = mkConst (find_scheme (!beq_scheme_kind_aux()) (kn',i)) and eqa = Array.map aux a in let args = Array.append (Array.map (fun x->lift lifti x) a) eqa in if args = [||] then eq else mkApp (eq,Array.append (Array.map (fun x->lift lifti x) a) eqa) with Not_found -> raise(EqNotFound (ind',ind)) ) | Sort _ -> raise InductiveWithSort | Prod _ -> raise InductiveWithProduct | Lambda _-> raise (EqUnknown "Lambda") | LetIn _ -> raise (EqUnknown "LetIn") | Const kn -> (match Environ.constant_opt_value env kn with | None -> raise (ParameterWithoutEquality kn) | Some c -> aux (applist (c,a))) | Construct _ -> raise (EqUnknown "Construct") | Case _ -> raise (EqUnknown "Case") | CoFix _ -> raise (EqUnknown "CoFix") | Fix _ -> raise (EqUnknown "Fix") | Meta _ -> raise (EqUnknown "Meta") | Evar _ -> raise (EqUnknown "Evar") in aux t in (* construct the predicate for the Case part*) let do_predicate rel_list n = List.fold_left (fun a b -> mkLambda(Anonymous,b,a)) (mkLambda (Anonymous, mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1), bb)) (List.rev rettyp_l) in (* make_one_eq *) (* do the [| C1 ... => match Y with ... end ... Cn => match Y with ... end |] part *) let ci = make_case_info env ind MatchStyle in let constrs n = get_constructors env (make_ind_family (ind, extended_rel_list (n+nb_ind-1) mib.mind_params_ctxt)) in let constrsi = constrs (3+nparrec) in let n = Array.length constrsi in let ar = Array.create n ff in for i=0 to n-1 do let nb_cstr_args = List.length constrsi.(i).cs_args in let ar2 = Array.create n ff in let constrsj = constrs (3+nparrec+nb_cstr_args) in for j=0 to n-1 do if (i=j) then ar2.(j) <- let cc = (match nb_cstr_args with | 0 -> tt | _ -> let eqs = Array.make nb_cstr_args tt in for ndx = 0 to nb_cstr_args-1 do let _,_,cc = List.nth constrsi.(i).cs_args ndx in let eqA = compute_A_equality rel_list nparrec (nparrec+3+2*nb_cstr_args) (nb_cstr_args+ndx+1) cc in Array.set eqs ndx (mkApp (eqA, [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|] )) done; Array.fold_left (fun a b -> mkApp (andb(),[|b;a|])) (eqs.(0)) (Array.sub eqs 1 (nb_cstr_args - 1)) ) in (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) cc (constrsj.(j).cs_args) ) else ar2.(j) <- (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) ff (constrsj.(j).cs_args) ) done; ar.(i) <- (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) (mkCase (ci,do_predicate rel_list nb_cstr_args, mkVar (id_of_string "Y") ,ar2)) (constrsi.(i).cs_args)) done; mkNamedLambda (id_of_string "X") (mkFullInd ind (nb_ind-1+1)) ( mkNamedLambda (id_of_string "Y") (mkFullInd ind (nb_ind-1+2)) ( mkCase (ci, do_predicate rel_list 0,mkVar (id_of_string "X"),ar))) in (* build_beq_scheme *) let names = Array.make nb_ind Anonymous and types = Array.make nb_ind mkSet and cores = Array.make nb_ind mkSet in for i=0 to (nb_ind-1) do names.(i) <- Name (id_of_string (rec_name i)); types.(i) <- mkArrow (mkFullInd (kn,i) 0) (mkArrow (mkFullInd (kn,i) 1) bb); cores.(i) <- make_one_eq i done; Array.init nb_ind (fun i -> let kelim = Inductive.elim_sorts (mib,mib.mind_packets.(i)) in if not (List.mem InSet kelim) then raise (NonSingletonProp (kn,i)); let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in create_input fix) let beq_scheme_kind = declare_mutual_scheme_object "_beq" build_beq_scheme let _ = beq_scheme_kind_aux := fun () -> beq_scheme_kind (* This function tryies to get the [inductive] between a constr the constr should be Ind i or App(Ind i,[|args|]) *) let destruct_ind c = try let u,v = destApp c in let indc = destInd u in indc,v with e when Errors.noncritical e -> let indc = destInd c in indc,[||] (* In the following, avoid is the list of names to avoid. If the args of the Inductive type are A1 ... An then avoid should be [| lb_An ... lb _A1 (resp. bl_An ... bl_A1) eq_An .... eq_A1 An ... A1 |] so from Ai we can find the the correct eq_Ai bl_ai or lb_ai *) (* used in the leib -> bool side*) let do_replace_lb lb_scheme_key aavoid narg gls p q = let avoid = Array.of_list aavoid in let do_arg v offset = try let x = narg*offset in let s = destVar v in let n = Array.length avoid in let rec find i = if avoid.(n-i) = s then avoid.(n-i-x) else (if i (* if this happen then the args have to be already declared as a Parameter*) ( let mp,dir,lbl = repr_con (destConst v) in mkConst (make_con mp dir (mk_label ( if offset=1 then ("eq_"^(string_of_label lbl)) else ((string_of_label lbl)^"_lb") ))) ) in let type_of_pq = pf_type_of gls p in let u,v = destruct_ind type_of_pq in let lb_type_of_p = try mkConst (find_scheme lb_scheme_key u) with Not_found -> (* spiwack: the format of this error message should probably be improved. *) let err_msg = string_of_ppcmds (str "Leibniz->boolean:" ++ str "You have to declare the" ++ str "decidability over " ++ Printer.pr_constr type_of_pq ++ str " first.") in error err_msg in let lb_args = Array.append (Array.append (Array.map (fun x -> x) v) (Array.map (fun x -> do_arg x 1) v)) (Array.map (fun x -> do_arg x 2) v) in let app = if lb_args = [||] then lb_type_of_p else mkApp (lb_type_of_p,lb_args) in [Equality.replace p q ; apply app ; Auto.default_auto] (* used in the bool -> leib side *) let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt = let avoid = Array.of_list aavoid in let do_arg v offset = try let x = narg*offset in let s = destVar v in let n = Array.length avoid in let rec find i = if avoid.(n-i) = s then avoid.(n-i-x) else (if i (* if this happen then the args have to be already declared as a Parameter*) ( let mp,dir,lbl = repr_con (destConst v) in mkConst (make_con mp dir (mk_label ( if offset=1 then ("eq_"^(string_of_label lbl)) else ((string_of_label lbl)^"_bl") ))) ) in let rec aux l1 l2 = match (l1,l2) with | (t1::q1,t2::q2) -> let tt1 = pf_type_of gls t1 in if t1=t2 then aux q1 q2 else ( let u,v = try destruct_ind tt1 (* trick so that the good sequence is returned*) with e when Errors.noncritical e -> ind,[||] in if u = ind then (Equality.replace t1 t2)::(Auto.default_auto)::(aux q1 q2) else ( let bl_t1 = try mkConst (find_scheme bl_scheme_key u) with Not_found -> (* spiwack: the format of this error message should probably be improved. *) let err_msg = string_of_ppcmds (str "boolean->Leibniz:" ++ str "You have to declare the" ++ str "decidability over " ++ Printer.pr_constr tt1 ++ str " first.") in error err_msg in let bl_args = Array.append (Array.append (Array.map (fun x -> x) v) (Array.map (fun x -> do_arg x 1) v)) (Array.map (fun x -> do_arg x 2) v ) in let app = if bl_args = [||] then bl_t1 else mkApp (bl_t1,bl_args) in (Equality.replace_by t1 t2 (tclTHEN (apply app) (Auto.default_auto)))::(aux q1 q2) ) ) | ([],[]) -> [] | _ -> error "Both side of the equality must have the same arity." in let (ind1,ca1) = try destApp lft with e when Errors.noncritical e -> error "replace failed." and (ind2,ca2) = try destApp rgt with e when Errors.noncritical e -> error "replace failed." in let (sp1,i1) = try destInd ind1 with e when Errors.noncritical e -> try fst (destConstruct ind1) with e when Errors.noncritical e -> error "The expected type is an inductive one." and (sp2,i2) = try destInd ind2 with e when Errors.noncritical e -> try fst (destConstruct ind2) with e when Errors.noncritical e -> error "The expected type is an inductive one." in if (sp1 <> sp2) || (i1 <> i2) then (error "Eq should be on the same type") else (aux (Array.to_list ca1) (Array.to_list ca2)) (* create, from a list of ids [i1,i2,...,in] the list [(in,eq_in,in_bl,in_al),,...,(i1,eq_i1,i1_bl_i1_al )] *) let list_id l = List.fold_left ( fun a (n,_,t) -> let s' = match n with Name s -> string_of_id s | Anonymous -> "A" in (id_of_string s',id_of_string ("eq_"^s'), id_of_string (s'^"_bl"), id_of_string (s'^"_lb")) ::a ) [] l (* build the right eq_I A B.. N eq_A .. eq_N *) let eqI ind l = let list_id = list_id l in let eA = Array.of_list((List.map (fun (s,_,_,_) -> mkVar s) list_id)@ (List.map (fun (_,seq,_,_)-> mkVar seq) list_id )) and e = try mkConst (find_scheme beq_scheme_kind ind) with Not_found -> error ("The boolean equality on "^(string_of_mind (fst ind))^" is needed."); in (if eA = [||] then e else mkApp(e,eA)) (**********************************************************************) (* Boolean->Leibniz *) let compute_bl_goal ind lnamesparrec nparrec = let eqI = eqI ind lnamesparrec in let list_id = list_id lnamesparrec in let create_input c = let x = id_of_string "x" and y = id_of_string "y" in let bl_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( mkArrow ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) )) ) list_id in let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b -> mkNamedProd sbl b a ) c (List.rev list_id) (List.rev bl_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a ) bl_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a (n,_,t) -> mkNamedProd (match n with Name s -> s | Anonymous -> id_of_string "A") t a) eq_input lnamesparrec in let n = id_of_string "x" and m = id_of_string "y" in create_input ( mkNamedProd n (mkFullInd ind nparrec) ( mkNamedProd m (mkFullInd ind (nparrec+1)) ( mkArrow (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) (mkApp(eq,[|mkFullInd ind (nparrec+3);mkVar n;mkVar m|])) ))) let compute_bl_tact bl_scheme_key ind lnamesparrec nparrec gsig = let list_id = list_id lnamesparrec in let avoid = ref [] in let first_intros = ( List.map (fun (s,_,_,_) -> s ) list_id ) @ ( List.map (fun (_,seq,_,_ ) -> seq) list_id ) @ ( List.map (fun (_,_,sbl,_ ) -> sbl) list_id ) in let fresh_first_intros = List.map ( fun s -> let fresh = fresh_id (!avoid) s gsig in avoid := fresh::(!avoid); fresh ) first_intros in let freshn = fresh_id (!avoid) (id_of_string "x") gsig in let freshm = avoid := freshn::(!avoid); fresh_id (!avoid) (id_of_string "y") gsig in let freshz = avoid := freshm::(!avoid); fresh_id (!avoid) (id_of_string "Z") gsig in (* try with *) avoid := freshz::(!avoid); tclTHENSEQ [ intros_using fresh_first_intros; intro_using freshn ; induct_on (mkVar freshn); intro_using freshm; destruct_on (mkVar freshm); intro_using freshz; intros; tclTRY ( tclORELSE reflexivity (Equality.discr_tac false None) ); simpl_in_hyp (freshz,InHyp); (* repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). *) tclREPEAT ( tclTHENSEQ [ simple_apply_in freshz (andb_prop()); fun gl -> let fresht = fresh_id (!avoid) (id_of_string "Z") gsig in avoid := fresht::(!avoid); (new_destruct false [Tacexpr.ElimOnConstr (Evd.empty,((mkVar freshz,Glob_term.NoBindings)))] None (None, Some (dl,Genarg.IntroOrAndPattern [[ dl,Genarg.IntroIdentifier fresht; dl,Genarg.IntroIdentifier freshz]])) None) gl ]); (* Ci a1 ... an = Ci b1 ... bn replace bi with ai; auto || replace bi with ai by apply typeofbi_prod ; auto *) fun gls-> let gl = pf_concl gls in match (kind_of_term gl) with | App (c,ca) -> ( match (kind_of_term c) with | Ind indeq -> if IndRef indeq = Coqlib.glob_eq then ( tclTHENSEQ ((do_replace_bl bl_scheme_key ind gls (!avoid) nparrec (ca.(2)) (ca.(1)))@[Auto.default_auto]) gls ) else (error "Failure while solving Boolean->Leibniz.") | _ -> error "Failure while solving Boolean->Leibniz." ) | _ -> error "Failure while solving Boolean->Leibniz." ] gsig let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined") let make_bl_scheme mind = let mib = Global.lookup_mind mind in if Array.length mib.mind_packets <> 1 then errorlabstrm "" (str "Automatic building of boolean->Leibniz lemmas not supported"); let ind = (mind,0) in let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in [|Pfedit.build_by_tactic (Global.env()) (compute_bl_goal ind lnamesparrec nparrec) (compute_bl_tact (!bl_scheme_kind_aux()) ind lnamesparrec nparrec)|] let bl_scheme_kind = declare_mutual_scheme_object "_dec_bl" make_bl_scheme let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind (**********************************************************************) (* Leibniz->Boolean *) let compute_lb_goal ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let eqI = eqI ind lnamesparrec in let create_input c = let x = id_of_string "x" and y = id_of_string "y" in let lb_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( mkArrow ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) )) ) list_id in let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b -> mkNamedProd slb b a ) c (List.rev list_id) (List.rev lb_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a ) lb_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a (n,_,t) -> mkNamedProd (match n with Name s -> s | Anonymous -> id_of_string "A") t a) eq_input lnamesparrec in let n = id_of_string "x" and m = id_of_string "y" in create_input ( mkNamedProd n (mkFullInd ind nparrec) ( mkNamedProd m (mkFullInd ind (nparrec+1)) ( mkArrow (mkApp(eq,[|mkFullInd ind (nparrec+2);mkVar n;mkVar m|])) (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) ))) let compute_lb_tact lb_scheme_key ind lnamesparrec nparrec gsig = let list_id = list_id lnamesparrec in let avoid = ref [] in let first_intros = ( List.map (fun (s,_,_,_) -> s ) list_id ) @ ( List.map (fun (_,seq,_,_) -> seq) list_id ) @ ( List.map (fun (_,_,_,slb) -> slb) list_id ) in let fresh_first_intros = List.map ( fun s -> let fresh = fresh_id (!avoid) s gsig in avoid := fresh::(!avoid); fresh ) first_intros in let freshn = fresh_id (!avoid) (id_of_string "x") gsig in let freshm = avoid := freshn::(!avoid); fresh_id (!avoid) (id_of_string "y") gsig in let freshz = avoid := freshm::(!avoid); fresh_id (!avoid) (id_of_string "Z") gsig in (* try with *) avoid := freshz::(!avoid); tclTHENSEQ [ intros_using fresh_first_intros; intro_using freshn ; induct_on (mkVar freshn); intro_using freshm; destruct_on (mkVar freshm); intro_using freshz; intros; tclTRY ( tclORELSE reflexivity (Equality.discr_tac false None) ); Equality.inj [] false (mkVar freshz,Glob_term.NoBindings); intros; simpl_in_concl; Auto.default_auto; tclREPEAT ( tclTHENSEQ [apply (andb_true_intro()); simplest_split ;Auto.default_auto ] ); fun gls -> let gl = pf_concl gls in (* assume the goal to be eq (eq_type ...) = true *) match (kind_of_term gl) with | App(c,ca) -> (match (kind_of_term ca.(1)) with | App(c',ca') -> let n = Array.length ca' in tclTHENSEQ (do_replace_lb lb_scheme_key (!avoid) nparrec gls ca'.(n-2) ca'.(n-1)) gls | _ -> error "Failure while solving Leibniz->Boolean." ) | _ -> error "Failure while solving Leibniz->Boolean." ] gsig let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined") let make_lb_scheme mind = let mib = Global.lookup_mind mind in if Array.length mib.mind_packets <> 1 then errorlabstrm "" (str "Automatic building of Leibniz->boolean lemmas not supported"); let ind = (mind,0) in let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in [|Pfedit.build_by_tactic (Global.env()) (compute_lb_goal ind lnamesparrec nparrec) (compute_lb_tact (!lb_scheme_kind_aux()) ind lnamesparrec nparrec)|] let lb_scheme_kind = declare_mutual_scheme_object "_dec_lb" make_lb_scheme let _ = lb_scheme_kind_aux := fun () -> lb_scheme_kind (**********************************************************************) (* Decidable equality *) let check_not_is_defined () = try ignore (Coqlib.build_coq_not ()) with e when Errors.noncritical e -> raise (UndefinedCst "not") (* {n=m}+{n<>m} part *) let compute_dec_goal ind lnamesparrec nparrec = check_not_is_defined (); let list_id = list_id lnamesparrec in let create_input c = let x = id_of_string "x" and y = id_of_string "y" in let lb_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( mkArrow ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) )) ) list_id in let bl_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( mkArrow ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) )) ) list_id in let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b -> mkNamedProd slb b a ) c (List.rev list_id) (List.rev lb_typ) in let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b -> mkNamedProd sbl b a ) lb_input (List.rev list_id) (List.rev bl_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a ) bl_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a (n,_,t) -> mkNamedProd (match n with Name s -> s | Anonymous -> id_of_string "A") t a) eq_input lnamesparrec in let n = id_of_string "x" and m = id_of_string "y" in let eqnm = mkApp(eq,[|mkFullInd ind (2*nparrec+2);mkVar n;mkVar m|]) in create_input ( mkNamedProd n (mkFullInd ind (2*nparrec)) ( mkNamedProd m (mkFullInd ind (2*nparrec+1)) ( mkApp(sumbool(),[|eqnm;mkApp (Coqlib.build_coq_not(),[|eqnm|])|]) ) ) ) let compute_dec_tact ind lnamesparrec nparrec gsig = let list_id = list_id lnamesparrec in let eqI = eqI ind lnamesparrec in let avoid = ref [] in let eqtrue x = mkApp(eq,[|bb;x;tt|]) in let eqfalse x = mkApp(eq,[|bb;x;ff|]) in let first_intros = ( List.map (fun (s,_,_,_) -> s ) list_id ) @ ( List.map (fun (_,seq,_,_) -> seq) list_id ) @ ( List.map (fun (_,_,sbl,_) -> sbl) list_id ) @ ( List.map (fun (_,_,_,slb) -> slb) list_id ) in let fresh_first_intros = List.map ( fun s -> let fresh = fresh_id (!avoid) s gsig in avoid := fresh::(!avoid); fresh ) first_intros in let freshn = fresh_id (!avoid) (id_of_string "x") gsig in let freshm = avoid := freshn::(!avoid); fresh_id (!avoid) (id_of_string "y") gsig in let freshH = avoid := freshm::(!avoid); fresh_id (!avoid) (id_of_string "H") gsig in let eqbnm = mkApp(eqI,[|mkVar freshn;mkVar freshm|]) in avoid := freshH::(!avoid); let arfresh = Array.of_list fresh_first_intros in let xargs = Array.sub arfresh 0 (2*nparrec) in let blI = try mkConst (find_scheme bl_scheme_kind ind) with Not_found -> error ( "Error during the decidability part, boolean to leibniz"^ " equality is required.") in let lbI = try mkConst (find_scheme lb_scheme_kind ind) with Not_found -> error ( "Error during the decidability part, leibniz to boolean"^ " equality is required.") in tclTHENSEQ [ intros_using fresh_first_intros; intros_using [freshn;freshm]; (*we do this so we don't have to prove the same goal twice *) assert_by (Name freshH) ( mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|]) ) (tclTHEN (destruct_on eqbnm) Auto.default_auto); (fun gsig -> let freshH2 = fresh_id (!avoid) (id_of_string "H") gsig in avoid := freshH2::(!avoid); tclTHENS (destruct_on_using (mkVar freshH) freshH2) [ (* left *) tclTHENSEQ [ simplest_left; apply (mkApp(blI,Array.map(fun x->mkVar x) xargs)); Auto.default_auto ]; (*right *) (fun gsig -> let freshH3 = fresh_id (!avoid) (id_of_string "H") gsig in avoid := freshH3::(!avoid); tclTHENSEQ [ simplest_right ; unfold_constr (Lazy.force Coqlib.coq_not_ref); intro; Equality.subst_all; assert_by (Name freshH3) (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|])) (tclTHENSEQ [ apply (mkApp(lbI,Array.map (fun x->mkVar x) xargs)); Auto.default_auto ]); Equality.general_rewrite_bindings_in true all_occurrences true false (List.hd !avoid) ((mkVar (List.hd (List.tl !avoid))), Glob_term.NoBindings ) true; Equality.discr_tac false None ] gsig) ] gsig) ] gsig let make_eq_decidability mind = let mib = Global.lookup_mind mind in if Array.length mib.mind_packets <> 1 then anomaly "Decidability lemma for mutual inductive types not supported"; let ind = (mind,0) in let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in [|Pfedit.build_by_tactic (Global.env()) (compute_dec_goal ind lnamesparrec nparrec) (compute_dec_tact ind lnamesparrec nparrec)|] let eq_dec_scheme_kind = declare_mutual_scheme_object "_eq_dec" make_eq_decidability (* The eq_dec_scheme proofs depend on the equality and discr tactics but the inj tactics, that comes with discr, depends on the eq_dec_scheme... *) let _ = Equality.set_eq_dec_scheme_kind eq_dec_scheme_kind coq-8.4pl4/toplevel/interface.mli0000644000175000017500000001620012326224777016127 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* interp_rty; rewind : rewind_sty -> rewind_rty; goals : goals_sty -> goals_rty; evars : evars_sty -> evars_rty; hints : hints_sty -> hints_rty; status : status_sty -> status_rty; search : search_sty -> search_rty; get_options : get_options_sty -> get_options_rty; set_options : set_options_sty -> set_options_rty; inloadpath : inloadpath_sty -> inloadpath_rty; mkcases : mkcases_sty -> mkcases_rty; quit : quit_sty -> quit_rty; about : about_sty -> about_rty; handle_exn : handle_exn_sty -> handle_exn_rty; } coq-8.4pl4/CHANGES0000644000175000017500000035325412326224777012642 0ustar stephstephChanges from V8.4pl3 to V8.4pl4 =============================== WARNING: The current logic of Coq is now known to be inconsistent with Axiom prop_extensionality : forall A B:Prop, (A <-> B) -> A = B. For more details, see: https://gforge.inria.fr/plugins/scmgit/cgi-bin/gitweb.cgi?p=coq/coq.git;a=blob_plain;f=test-suite/failure/subterm2.v;hb=HEAD or https://gforge.inria.fr/plugins/scmgit/cgi-bin/gitweb.cgi?p=coq/coq.git;a=blob_plain;f=test-suite/failure/subterm3.v;hb=HEAD Kernel - Bug #3211: unsound check of elimination sort. - Fix guard condition for nested cofixpoints. - Bug #3243: Univ constraints of module subtyping were not propagated. Tactics - A new option "Set Stable Omega" ensures that repeated identical calls to omega will produce identical proof terms. This option is off by default for maximal compatibility, but should be pretty safe to activate. - The interpretation of the open_constr tactic argument was erroneously firing type classes resolution in some corner cases. This has been fixed. The tactic argument type open_constr_wTC is provided for retro compatibility purposes. - Fixing bug #3228 (fixing precedence of ltac variables over variables in env) introduces rare and justified tactic failure. Bug fixes - Solved bugs: #3260, #2697, #3037, #3262, #2900, #3131, #3238, #3204, #1758, #1039, #3144 - micromega: solved an ambiguous symbol resolution. - Coq always uses / as separator between directories on all platforms. - remove trailing '\r' from file names returned by coqtop. - bug correction in proving inversion principles for Function. - ocamlbuild: minor fixes related to camlp4 and cross-compilation. Changes from V8.4pl2 to V8.4pl3 =============================== Ide_slave XML interface - 20120712, 20130419 : Invalidated protocol versions - From 20130419 extra datastructure : union (Inl "" = , Inr _ = ...) - 20130419~1 : new toplevel entry : message, not send by coptop v8.4 and not handle by coqide v8.4. A message has a level and a content (of string). Message levels are Debug of string, Info, Notice, Warning and Error. - 20130425 : * new toplevel entry : feedback, once again not send by coqtop v8.4 and not handle by coqide v8.4. A feedback gives the id of the sentence it provides info about and a content. Feedback contents are Processed, AddedAxiom and GlobRef of Util.loc * string * string * string * string * must provide an attribute id of type int. It is OK in coqtop v8.4 to alwais send Bug fixes - Solved bugs: #2230 #2837 #2846 #2987 #3003 #3001 #3013 #3023 #3025 #3036 #3118 #3169 #(3150, 3151, 3152, 3153) - Fixing a significant efficiency leak in the code of the field tactic. - Fix caching of local hint database in typeclasses eauto which could miss some hypotheses. - Fix automatic solving of obligation in program, which was not trying to solve obligations that had no undefined dependencies left. Changes from V8.4pl1 to V8.4pl2 =============================== Bug fixes - Solved bugs : #2466 #2629 #2668 #2750 #2839 #2869 #2954 #2955 #2959 #2962 #2966 #2967 #2969 #2970 #2975 #2976 #2977 #2978 #2981 #2983 #2995 #3000 #3004 #3008 - Partially fixed bugs : #2830 #2949 - Coqtop should now react more reliably when receiving interrupt signals: all the "try...with" constructs have been protected against undue handling of the Sys.Break exception. Coqide - The Windows-specific code handling the interrupt button of Coqide had to be reworked (cf. bug #2869). Now, in Win32 this button does not target a specific coqtop client, but instead sends a Ctrl-C to any process sharing its console with Coqide. To avoid awkward effects, it is recommended to launch Coqide via its icon, its menu, or in a dedicated console window. Extraction - The option Extraction AccessOpaque is now set by default, restoring compatibility of older versions of Coq (cf bug #2952). Changes from V8.4 to V8.4pl1 ============================ Bug fixes - Solved bugs : #2851 #2863 #2865 #2893 #2895 #2892 #2905 #2906 #2907 #2917 #2921 #2930 #2941 #2878 - Partially fixed bug : #2904 - Various fixes concerning coq_makefile Optimizations - "Union by rank" optimization for universes contributed by J.H. Jourdan and G. Sherrer (see union-find-and-coq-universes on gagallium blog). Libraries - Internal organisation of some modular libraries have slightly changed due to bug #2904 (GenericMinMax, OrdersTac) - No more constant "int" in ZArith/Int.v to avoid name clash with OCaml (cf bug #2878). Coqide - Improved shutdown of coqtop processes spawned by coqide (in particular added a missing close_on_exec primitive before forking). - On windows, launching coqide with the -debug option now produces a log file in the user's temporary directory. The location of this log file is displayed in the "About" message. Changes from V8.4beta2 to V8.4 ============================== Vernacular commands - The "Reset" command is now supported again in files given to coqc or Load. - "Show Script" now indents again the displayed scripts. It can also work correctly across Load'ed files if the option "Unset Atomic Load" is used. - "Open Scope" can now be given the delimiter (e.g. Z) instead of the full scope name (e.g. Z_scope). Notations - Most compatibility notations of the standard library are now tagged as (compat xyz), where xyz is a former Coq version, for instance "8.3". These notations behave as (only parsing) notations, except that they may triggers warnings (or errors) when used while Coq is not in a corresponding -compat mode. - To activate these compatibility warnings, use "Set Verbose Compat Notations" or the command-line flag -verbose-compat-notations. - For a strict mode without these compatibility notations, use "Unset Compat Notations" or the command-line flag -no-compat-notations. Tactics - An annotation "eqn:H" or "eqn:?" can be added to a "destruct" or "induction" to make it generate equations in the spirit of "case_eq". The former syntax "_eqn" is discontinued. - The name of the hypothesis introduced by tactic "remember" can be set via the new syntax "remember t as x eqn:H" (wish #2489). Libraries - Reals: changed definition of PI, no more axiom about sin(PI/2). - SetoidPermutation: a notion of permutation for lists modulo a setoid equality. - BigN: fixed the ocaml code doing the parsing/printing of big numbers. Changes from V8.4beta to V8.4beta2 ================================== Vernacular commands - Commands "Back" and "BackTo" are now handling the proof states. They may perform some extra steps of backtrack to avoid states where the proof state is unavailable (typically a closed proof). - The commands "Suspend" and "Resume" have been removed. - A basic Show Script has been reintroduced (no indentation). - New command "Set Parsing Explicit" for deactivating parsing (and printing) of implicit arguments (useful for teaching). - New command "Grab Existential Variables" to transform the unresolved evars at the end of a proof into goals. Tactics - Still no general "info" tactical, but new specific tactics info_auto, info_eauto, info_trivial which provides information on the proofs found by auto/eauto/trivial. Display of these details could also be activated by "Set Info Auto"/"Set Info Eauto"/"Set Info Trivial". - Details on everything tried by auto/eauto/trivial during a proof search could be obtained by "debug auto", "debug eauto", "debug trivial" or by a global "Set Debug Auto"/"Set Debug Eauto"/"Set Debug Trivial". - New command "r string" in Ltac debugger that interprets "idtac string" in Ltac code as a breakpoint and jumps to its next use. - Tactics from the Dp plugin (simplify, ergo, yices, cvc3, z3, cvcl, harvey, zenon, gwhy) have been removed, since Why2 has not been maintained for the last few years. The Why3 plugin should be a suitable replacement in most cases. Libraries - MSetRBT: a new implementation of MSets via Red-Black trees (initial contribution by Andrew Appel). - MSetAVL: for maximal sharing with the new MSetRBT, the argument order of Node has changed (this should be transparent to regular MSets users). Module System - The names of modules (and module types) are now in a fully separated namespace from ordinary definitions: "Definition E:=0. Module E. End E." is now accepted. CoqIDE - Coqide now supports the "Restart" command, and "Undo" (with a warning). Better support for "Abort". Changes from V8.3 to V8.4beta ============================= Logic - Standard eta-conversion now supported (dependent product only). - Guard condition improvement: subterm property is propagated through beta-redex blocked by pattern-matching, as in "(match v with C .. => fun x => u end) x"; this allows for instance to use "rewrite ... in ..." without breaking the guard condition. Specification language and notations - Maximal implicit arguments can now be set locally by { }. The registration traverses fixpoints and lambdas. Because there is conversion in types, maximal implicit arguments are not taken into account in partial applications (use eta expanded form with explicit { } instead). - Added support for recursive notations with binders (allows for instance to write "exists x y z, P"). - Structure/Record printing can be disable by "Unset Printing Records". In addition, it can be controlled on type by type basis using "Add Printing Record" or "Add Printing Constructor". - Pattern-matching compilation algorithm: in "match x, y with ... end", possible dependencies of x (or of the indices of its type) in the type of y are now taken into account. Tactics - New proof engine. - Scripts can now be structured thanks to bullets - * + and to subgoal delimitation via { }. Note: for use with Proof General, a cvs version of Proof General no older than mid-July 2011 is currently required. - Support for tactical "info" is suspended. - Support for command "Show Script" is suspended. - New tactics constr_eq, is_evar and has_evar for use in Ltac. - Removed the two-argument variant of "decide equality". - New experimental tactical "timeout ". Since is a time in second for the moment, this feature should rather be avoided in scripts meant to be machine-independent. - Fix in "destruct": removal of unexpected local definitions in context might result in some rare incompatibilities (solvable by adapting name hypotheses). - Introduction pattern "_" made more robust. - Tactic (and Eval command) vm_compute can now be interrupted via Ctrl-C. - Unification in "apply" supports unification of patterns of the form ?f x y = g(x,y) (compatibility ensured by using "Unset Tactic Pattern Unification"). It also supports (full) betaiota. - Tactic autorewrite does no longer instantiate pre-existing existential variables (theoretical source of possible incompatibilities). - Tactic "dependent rewrite" now supports equality in "sig". - Tactic omega now understands Zpred (wish #1912) and can prove any goal from a context containing an arithmetical contradiction (wish #2236). - Using "auto with nocore" disables the use of the "core" database (wish #2188). This pseudo-database "nocore" can also be used with trivial and eauto. - Tactics "set", "destruct" and "induction" accepts incomplete terms and use the goal to complete the pattern assuming it is non ambiguous. - When used on arguments with a dependent type, tactics such as "destruct", "induction", "case", "elim", etc. now try to abstract automatically the dependencies over the arguments of the types (based on initial ideas from Chung-Kil Hur, extension to nested dependencies suggested by Dan Grayson) - Tactic "injection" now failing on an equality showing no constructors while it was formerly generalizing again the goal over the given equality. - In Ltac, the "context [...]" syntax has now a variant "appcontext [...]" allowing to match partial applications in larger applications. - When applying destruct or inversion on a fixpoint hiding an inductive type, recursive calls to the fixpoint now remain folded by default (rare source of incompatibility generally solvable by adding a call to simpl). - In an ltac pattern containing a "match", a final "| _ => _" branch could be used now instead of enumerating all remaining constructors. Moreover, the pattern "match _ with _ => _ end" now allows to match any "match". A "in" annotation can also be added to restrict to a precise inductive type. - The behavior of "simpl" can be tuned using the "Arguments" vernacular. In particular constants can be marked so that they are always/never unfolded by "simpl", or unfolded only when a set of arguments evaluates to a constructor. Last one can mark a constant so that it is unfolded only if the simplified term does not expose a match in head position. Vernacular commands - It is now mandatory to have a space (or tabulation or newline or end-of-file) after a "." ending a sentence. - In SearchAbout, the [ ] delimiters are now optional. - New command "Add/Remove Search Blacklist ...": a Search or SearchAbout or similar query will never mention lemmas whose qualified names contain any of the declared substrings. The default blacklisted substrings are "_admitted" "_subproof" "Private_". - When the output file of "Print Universes" ends in ".dot" or ".gv", the universe graph is printed in the DOT language, and can be processed by Graphviz tools. - New command "Print Sorted Universes". - The undocumented and obsolete option "Set/Unset Boxed Definitions" has been removed, as well as syntaxes like "Boxed Fixpoint foo". - A new option "Set Default Timeout n / Unset Default Timeout". - Qed now uses information from the reduction tactics used in proof script to avoid conversion at Qed time to go into a very long computation. - New command "Show Goal ident" to display the statement of a goal, even a closed one (available from Proof General). - Command "Proof" accept a new modifier "using" to force generalization over a given list of section variables at section ending. - New command "Arguments" generalizing "Implicit Arguments" and "Arguments Scope" and that also allows to rename the parameters of a definition and to tune the behavior of the tactic "simpl". Module System - During subtyping checks, an opaque constant in a module type could now be implemented by anything of the right type, even if bodies differ. Said otherwise, with respect to subtyping, an opaque constant behaves just as a parameter. Coqchk was already implementing this, but not coqtop. - The inlining done during application of functors can now be controlled more precisely, by the annotations (no inline) or (inline at level XX). With the latter annotation, only functor parameters whose levels are lower or equal than XX will be inlined. The level of a parameter can be fixed by "Parameter Inline(30) foo". When levels aren't given, the default value is 100. One can also use the flag "Set Inline Level ..." to set a level. - Print Assumptions should now handle correctly opaque modules (#2168). - Print Module (Type) now tries to print more details, such as types and bodies of the module elements. Note that Print Module Type could be used on a module to display only its interface. The option "Set Short Module Printing" could be used to switch back to the earlier behavior were only field names were displayed. Libraries - Extension of the abstract part of Numbers, which now provide axiomatizations and results about many more integer functions, such as pow, gcd, lcm, sqrt, log2 and bitwise functions. These functions are implemented for nat, N, BigN, Z, BigZ. See in particular file NPeano for new functions about nat. - The definition of types positive, N, Z is now in file BinNums.v - Major reorganization of ZArith. The initial file ZArith/BinInt.v now contains an internal module Z implementing the Numbers interface for integers. This module Z regroups: * all functions over type Z : Z.add, Z.mul, ... * the minimal proofs of specifications for these functions : Z.add_0_l, ... * an instantation of all derived properties proved generically in Numbers : Z.add_comm, Z.add_assoc, ... A large part of ZArith is now simply compatibility notations, for instance Zplus_comm is an alias for Z.add_comm. The direct use of module Z is now recommended instead of relying on these compatibility notations. - Similar major reorganization of NArith, via a module N in NArith/BinNat.v - Concerning the positive datatype, BinPos.v is now in a specific directory PArith, and contains an internal submodule Pos. We regroup there functions such as Pos.add Pos.mul etc as well as many results about them. These results are here proved directly (no Number interface for strictly positive numbers). - Note that in spite of the compatibility layers, all these reorganizations may induce some marginal incompatibilies in scripts. In particular: * the "?=" notation for positive now refers to a binary function Pos.compare, instead of the infamous ternary Pcompare (now Pos.compare_cont). * some hypothesis names generated by the system may changed (typically for a "destruct Z_le_gt_dec") since naming is done after the short name of the head predicate (here now "le" in module Z instead of "Zle", etc). * the internals of Z.add has changed, now relying of Z.pos_sub. - Also note these new notations: * "= XP SP1. - The communication between CoqIDE and Coqtop is now done via a dialect of XML. - The backtrack engine of CoqIDE has been reworked, it now uses the "Backtrack" command similarly to Proof General. - The Coqide parsing of sentences has be reworked and now supports tactic delimitation via { }. - Coqide now accepts the Abort command (wish #2357). - Coqide can read coq_makefile files as "project file" and use it to set automatically options to send to coqtop. - Preference files have moved to $XDG_CONFIG_HOME/coq and accelerators are not stored as a list anymore. Tools - Coq now searches directories specified in COQPATH, $XDG_DATA_HOME/coq, $XDG_DATA_DIRS/coq, and user-contribs before the standard library. - Coq rc file has moved to $XDG_CONFIG_HOME/coq. - Major changes to coq_makefile: * mli/mlpack/mllib taken into account, ml not preproccessed anymore, ml4 work; * mlihtml generates doc of mli, install-doc install the html doc in DOCDIR with the same policy as vo in COQLIB; * More variables are given by coqtop -config, others are defined only if the users doesn't have defined them elsewhere. Consequently, generated makefile should work directly on any architecture; * Packagers can take advantage of $(DSTROOT) introduction. Installation can be made in $XDG_DATA_HOME/coq; * -arg option allows to send option as argument to coqc. Changes from V8.2 to V8.3 ========================= Rewriting tactics - Tactic "rewrite" now supports rewriting on ad hoc equalities such as eq_true. - "Hint Rewrite" now checks that the lemma looks like an equation. - New tactic "etransitivity". - Support for heterogeneous equality (JMeq) in "injection" and "discriminate". - Tactic "subst" now supports heterogeneous equality and equality proofs that are dependent (use "simple subst" for preserving compatibility). - Added support for Leibniz-rewriting of dependent hypotheses. - Renamed "Morphism" into "Proper" and "respect" into "proper_prf" (possible source of incompatibility). A partial fix is to define "Notation Morphism R f := (Proper (R%signature) f)." - New tactic variants "rewrite* by" and "autorewrite*" that rewrite respectively the first and all matches whose side-conditions are solved. - "Require Import Setoid" does not export all of "Morphisms" and "RelationClasses" anymore (possible source of incompatibility, fixed by importing "Morphisms" too). - Support added for using Chung-Kil Hur's Heq library for rewriting over heterogeneous equality (courtesy of the library's author). - Tactic "replace" supports matching terms with holes. Automation tactics - Tactic "intuition" now preserves inner "iff" and "not" (exceptional source of incompatibilities solvable by redefining "intuition" as "unfold iff, not in *; intuition", or, for iff only, by using "Set Intuition Iff Unfolding".) - Tactic "tauto" now proves classical tautologies as soon as classical logic (i.e. library Classical_Prop or Classical) is loaded. - Tactic "gappa" has been removed from the Dp plugin. - Tactic "firstorder" now supports the combination of its "using" and "with" options. - New "Hint Resolve ->" (or "<-") for declaring iff's as oriented hints (wish #2104). - An inductive type as argument of the "using" option of "auto/eauto/firstorder" is interpreted as using the collection of its constructors. - New decision tactic "nsatz" to prove polynomial equations by computation of Groebner bases. Other tactics - Tactic "discriminate" now performs intros before trying to discriminate an hypothesis of the goal (previously it applied intro only if the goal had the form t1<>t2) (exceptional source of incompatibilities - former behavior can be obtained by "Unset Discriminate Introduction"). - Tactic "quote" now supports quotation of arbitrary terms (not just the goal). - Tactic "idtac" now displays its "list" arguments. - New introduction patterns "*" for introducing the next block of dependent variables and "**" for introducing all quantified variables and hypotheses. - Pattern Unification for existential variables activated in tactics and new option "Unset Tactic Evars Pattern Unification" to deactivate it. - Resolution of canonical structure is now part of the tactic's unification algorithm. - New tactic "decide lemma with hyp" for rewriting decidability lemmas when one knows which side is true. - Improved support of dependent goals over objects in dependent types for "destruct" (rare source of incompatibility that can be avoided by unsetting option "Dependent Propositions Elimination"). - Tactic "exists", "eexists", "destruct" and "edestruct" supports iteration using comma-separated arguments. - Tactic names "case" and "elim" now support clauses "as" and "in" and become then synonymous of "destruct" and "induction" respectively. - A new tactic name "exfalso" for the use of 'ex-falso quodlibet' principle. This tactic is simply a shortcut for "elimtype False". - Made quantified hypotheses get the name they would have if introduced in the context (possible but rare source of incompatibilities). - When applying a component of a conjunctive lemma, "apply in" (and sequences of "apply in") now leave the side conditions of the lemmas uniformly after the main goal (possible source of rare incompatibilities). - In "simpl c" and "change c with d", c can be a pattern. - Tactic "revert" now preserves let-in's making it the exact inverse of "intro". - New tactics "clear dependent H" and "revert dependent H" that clears (resp. reverts) H and all the hypotheses that depend on H. - Ltac's pattern-matching now supports matching metavariables that depend on variables bound upwards in the pattern. Tactic definitions - Ltac definitions support Local option for non-export outside modules. - Support for parsing non-empty lists with separators in tactic notations. - New command "Locate Ltac" to get the full name of an Ltac definition. Notations - Record syntax "{|x=...; y=...|}" now works inside patterns too. - Abbreviations from non-imported module now invisible at printing time. - Abbreviations now use implicit arguments and arguments scopes for printing. - Abbreviations to pure names now strictly behave like the name they refer to (make redirections of qualified names easier). - Abbreviations for applied constant now propagate the implicit arguments and arguments scope of the underlying reference (possible source of incompatibilities generally solvable by changing such abbreviations from e.g. "Notation foo' := (foo x)" to "Notation foo' y := (foo x (y:=y))"). - The "where" clause now supports multiple notations per defined object. - Recursive notations automatically expand one step on the left for better factorization; recursion notations inner separators now ensured being tokens. - Added "Reserved Infix" as a specific shortcut of the corresponding "Reserved Notation". - Open/Close Scope command supports Global option in sections. Specification language - New support for local binders in the syntax of Record/Structure fields. - Fixpoint/CoFixpoint now support building part or all of bodies using tactics. - Binders given before ":" in lemmas and in definitions built by tactics are now automatically introduced (possible source of incompatibility that can be resolved by invoking "Unset Automatic Introduction"). - New support for multiple implicit arguments signatures per reference. Module system - Include Type is now deprecated since Include now accept both modules and module types. - Declare ML Module supports Local option. - The sharing between non-logical object and the management of the name-space has been improved by the new "Delta-equivalence" on qualified name. - The include operator has been extended to high-order structures - Sequences of Include can be abbreviated via new syntax "<+". - A module (or module type) can be given several "<:" signatures. - Interactive proofs are now permitted in module type. Functors can hence be declared as Module Type and be used later to type themselves. - A functor application can be prefixed by a "!" to make it ignore any "Inline" annotation in the type of its argument(s) (for examples of use of the new features, see libraries Structures and Numbers). - Coercions are now active only when modules are imported (use "Set Automatic Coercions Import" to get the behavior of the previous versions of Coq). Extraction - When using (Recursive) Extraction Library, the filenames are directly the Coq ones with new appropriate extensions : we do not force anymore uncapital first letters for Ocaml and capital ones for Haskell. - The extraction now tries harder to avoid code transformations that can be dangerous for the complexity. In particular many eta-expansions at the top of functions body are now avoided, clever partial applications will likely be preserved, let-ins are almost always kept, etc. - In the same spirit, auto-inlining is now disabled by default, except for induction principles, since this feature was producing more frequently weird code than clear gain. The previous behavior can be restored via "Set Extraction AutoInline". - Unicode characters in identifiers are now transformed into ascii strings that are legal in Ocaml and other languages. - Harsh support of module extraction to Haskell and Scheme: module hierarchy is flattened, module abbreviations and functor applications are expanded, module types and unapplied functors are discarded. - Less unsupported situations when extracting modules to Ocaml. In particular module parameters might be alpha-renamed if a name clash is detected. - Extract Inductive is now possible toward non-inductive types (e.g. nat => int) - Extraction Implicit: this new experimental command allows to mark some arguments of a function or constructor for removed during extraction, even if these arguments don't fit the usual elimination principles of extraction, for instance the length n of a vector. - Files ExtrOcaml*.v in plugins/extraction try to provide a library of common extraction commands: mapping of basics types toward Ocaml's counterparts, conversions from/to int and big_int, or even complete mapping of nat,Z,N to int or big_int, or mapping of ascii to char and string to char list (in this case recognition of ascii constants is hard-wired in the extraction). Program - Streamlined definitions using well-founded recursion and measures so that they can work on any subset of the arguments directly (uses currying). - Try to automatically clear structural fixpoint prototypes in obligations to avoid issues with opacity. - Use return type clause inference in pattern-matching as in the standard typing algorithm. - Support [Local Obligation Tactic] and [Next Obligation with tactic]. - Use [Show Obligation Tactic] to print the current default tactic. - [fst] and [snd] have maximal implicit arguments in Program now (possible source of incompatibility). Type classes - Declaring axiomatic type class instances in Module Type should be now done via new command "Declare Instance", while the syntax "Instance" now always provides a concrete instance, both in and out of Module Type. - Use [Existing Class foo] to declare foo as a class a posteriori. [foo] can be an inductive type or a constant definition. No projections or instances are defined. - Various bug fixes and improvements: support for defined fields, anonymous instances, declarations giving terms, better handling of sections and [Context]. Vernacular commands - New command "Timeout ." interprets a command and a timeout interrupts the interpretation after seconds. - New command "Compute ." is a shortcut for "Eval vm_compute in ". - New command "Fail ." interprets a command and is successful iff the command fails on an error (but not an anomaly). Handy for tests and illustration of wrong commands. - Most commands referring to constant (e.g. Print or About) now support referring to the constant by a notation string. - New option "Boolean Equality Schemes" to make generation of boolean equality automatic for datatypes (together with option "Decidable Equality Schemes", this replaces deprecated option "Equality Scheme"). - Made support for automatic generation of case analysis schemes available to user (governed by option "Set Case Analysis Schemes"). - New command "(Global?) Generalizable [All|No] Variable(s)? ident(s)?" to declare which identifiers are generalizable in `{} and `() binders. - New command "Print Opaque Dependencies" to display opaque constants in addition to all variables, parameters or axioms a theorem or definition relies on. - New command "Declare Reduction := ", allowing to write later "Eval in ...". This command accepts a Local variant. - Syntax of Implicit Type now supports more than one block of variables of a given type. - Command "Canonical Structure" now warns when it has no effects. - Commands of the form "Set X" or "Unset X" now support "Local" and "Global" prefixes. Library - Use "standard" Coq names for the properties of eq and identity (e.g. refl_equal is now eq_refl). Support for compatibility is provided. - The function Compare_dec.nat_compare is now defined directly, instead of relying on lt_eq_lt_dec. The earlier version is still available under the name nat_compare_alt. - Lemmas in library Relations and Reals have been homogenized a bit. - The implicit argument of Logic.eq is now maximally inserted, allowing to simply write "eq" instead of "@eq _" in morphism signatures. - Wrongly named lemmas (Zlt_gt_succ and Zlt_succ_gt) fixed (potential source of incompatibilities) - List library: - Definitions of list, length and app are now in Init/Datatypes. Support for compatibility is provided. - Definition of Permutation is now in Sorting/Permtation.v - Some other light revisions and extensions (possible source of incompatibilities solvable by qualifying names accordingly). - In ListSet, set_map has been fixed (source of incompatibilities if used). - Sorting library: - new mergesort of worst-case complexity O(n*ln(n)) made available in Mergesort.v; - former notion of permutation up to setoid from Permutation.v is deprecated and moved to PermutSetoid.v; - heapsort from Heap.v of worst-case complexity O(n*n) is deprecated; - new file Sorted.v for some definitions of being sorted. - Structure library. This new library is meant to contain generic structures such as types with equalities or orders, either in Module version (for now) or Type Classes (still to do): - DecidableType.v and OrderedType.v: initial notions for FSets/FMaps, left for compatibility but considered as deprecated. - Equalities.v and Orders.v: evolutions of the previous files, with fine-grain Module architecture, many variants, use of Equivalence and other relevant Type Classes notions. - OrdersTac.v: a generic tactic for solving chains of (in)equalities over variables. See {Nat,N,Z,P}OrderedType.v for concrete instances. - GenericMinMax.v: any ordered type can be equipped with min and max. We derived here all the generic properties of these functions. - MSets library: an important evolution of the FSets library. "MSets" stands for Modular (Finite) Sets, by contrast with a forthcoming library of Class (Finite) Sets contributed by S. Lescuyer which will be integrated with the next release of Coq. The main features of MSets are: - The use of Equivalence, Proper and other Type Classes features easing the handling of setoid equalities. - The interfaces are now stated in iff-style. Old specifications are now derived properties. - The compare functions are now pure, and return a "comparison" value. Thanks to the CompSpec inductive type, reasoning on them remains easy. - Sets structures requiring invariants (i.e. sorted lists) are built first as "Raw" sets (pure objects and separate proofs) and attached with their proofs thanks to a generic functor. "Raw" sets have now a proper interface and can be manipulated directly. Note: No Maps yet in MSets. The FSets library is still provided for compatibility, but will probably be considered as deprecated in the next release of Coq. - Numbers library: - The abstract layer (NatInt, Natural/Abstract, Integer/Abstract) has been simplified and enhance thanks to new features of the module system such as Include (see above). It has been extended to Euclidean division (three flavors for integers: Trunc, Floor and Math). - The arbitrary-large efficient numbers (BigN, BigZ, BigQ) has also been reworked. They benefit from the abstract layer improvements (especially for div and mod). Note that some specifications have slightly changed (compare, div, mod, shift{r,l}). Ring/Field should work better (true recognition of constants). Tools - Option -R now supports binding Coq root read-only. - New coqtop/coqc option -beautify to reformat .v files (usable e.g. to globally update notations). - New tool beautify-archive to beautify a full archive of developments. - New coqtop/coqc option -compat X.Y to simulate the general behavior of previous versions of Coq (provides e.g. support for 8.2 compatibility). Coqdoc - List have been revamped. List depth and scope is now determined by an "offside" whitespace rule. - Text may be italicized by placing it in _underscores_. - The "--index " flag changes the filename of the index. - The "--toc-depth " flag limits the depth of headers which are included in the table of contents. - The "--lib-name " flag prints " Foo" instead of "Library Foo" where library titles are called for. The "--no-lib-name" flag eliminates the extra title. - New option "--parse-comments" to allow parsing of regular "(* *)" comments. - New option "--plain-comments" to disable interpretation inside comments. - New option "--interpolate" to try and typeset identifiers in Coq escapings using the available globalization information. - New option "--external url root" to refer to external libraries. - Links to section variables and notations now supported. Internal infrastructure - To avoid confusion with the repository of user's contributions, the subdirectory "contrib" has been renamed into "plugins". On platforms supporting ocaml native dynlink, code located there is built as loadable plugins for coqtop. - An experimental build mechanism via ocamlbuild is provided. From the top of the archive, run ./configure as usual, and then ./build. Feedback about this build mechanism is most welcome. Compiling Coq on platforms such as Windows might be simpler this way, but this remains to be tested. - The Makefile system has been simplified and factorized with the ocamlbuild system. In particular "make" takes advantage of .mllib files for building .cma/.cmxa. The .vo files to compile are now listed in several vo.itarget files. Changes from V8.1 to V8.2 ========================= Language - If a fixpoint is not written with an explicit { struct ... }, then all arguments are tried successively (from left to right) until one is found that satisfies the structural decreasing condition. - New experimental typeclass system giving ad-hoc polymorphism and overloading based on dependent records and implicit arguments. - New syntax "let 'pat := b in c" for let-binding using irrefutable patterns. - New syntax "forall {A}, T" for specifying maximally inserted implicit arguments in terms. - Sort of Record/Structure, Inductive and CoInductive defaults to Type if omitted. - (Co)Inductive types can be defined as records (e.g. "CoInductive stream := { hd : nat; tl : stream }.") - New syntax "Theorem id1:t1 ... with idn:tn" for proving mutually dependent statements. - Support for sort-polymorphism on constants denoting inductive types. - Several evolutions of the module system (handling of module aliases, functorial module types, an Include feature, etc). - Prop now a subtype of Set (predicative and impredicative forms). - Recursive inductive types in Prop with a single constructor of which all arguments are in Prop is now considered to be a singleton type. It consequently supports all eliminations to Prop, Set and Type. As a consequence, Acc_rect has now a more direct proof [possible source of easily fixed incompatibility in case of manual definition of a recursor in a recursive singleton inductive type]. Vernacular commands - Added option Global to "Arguments Scope" for section surviving. - Added option "Unset Elimination Schemes" to deactivate the automatic generation of elimination schemes. - Modification of the Scheme command so you can ask for the name to be automatically computed (e.g. Scheme Induction for nat Sort Set). - New command "Combined Scheme" to build combined mutual induction principles from existing mutual induction principles. - New command "Scheme Equality" to build a decidable (boolean) equality for simple inductive datatypes and a decision property over this equality (e.g. Scheme Equality for nat). - Added option "Set Equality Scheme" to make automatic the declaration of the boolean equality when possible. - Source of universe inconsistencies now printed when option "Set Printing Universes" is activated. - New option "Set Printing Existential Instances" for making the display of existential variable instances explicit. - Support for option "[id1 ... idn]", and "-[id1 ... idn]", for the "compute"/"cbv" reduction strategy, respectively meaning reduce only, or everything but, the constants id1 ... idn. "lazy" alone or followed by "[id1 ... idn]", and "-[id1 ... idn]" also supported, meaning apply all of beta-iota-zeta-delta, possibly restricting delta. - New command "Strategy" to control the expansion of constants during conversion tests. It generalizes commands Opaque and Transparent by introducing a range of levels. Lower levels are assigned to constants that should be expanded first. - New options Global and Local to Opaque and Transparent. - New command "Print Assumptions" to display all variables, parameters or axioms a theorem or definition relies on. - "Add Rec LoadPath" now provides references to libraries using partially qualified names (this holds also for coqtop/coqc option -R). - SearchAbout supports negated search criteria, reference to logical objects by their notation, and more generally search of subterms. - "Declare ML Module" now allows to import .cmxs files when Coq is compiled in native code with a version of OCaml that supports native Dynlink (>= 3.11). - Specific sort constraints on Record now taken into account. - "Print LoadPath" supports a path argument to filter the display. Libraries - Several parts of the libraries are now in Type, in particular FSets, SetoidList, ListSet, Sorting, Zmisc. This may induce a few incompatibilities. In case of trouble while fixing existing development, it may help to simply declare Set as an alias for Type (see file SetIsType). - New arithmetical library in theories/Numbers. It contains: * an abstract modular development of natural and integer arithmetics in Numbers/Natural/Abstract and Numbers/Integer/Abstract * an implementation of efficient computational bounded and unbounded integers that can be mapped to processor native arithmetics. See Numbers/Cyclic/Int31 for 31-bit integers and Numbers/Natural/BigN for unbounded natural numbers and Numbers/Integer/BigZ for unbounded integers. * some proofs that both older libraries Arith, ZArith and NArith and newer BigN and BigZ implement the abstract modular development. This allows in particular BigN and BigZ to already come with a large database of basic lemmas and some generic tactics (ring), This library has still an experimental status, as well as the processor-acceleration mechanism, but both its abstract and its concrete parts are already quite usable and could challenge the use of nat, N and Z in actual developments. Moreover, an extension of this framework to rational numbers is ongoing, and an efficient Q structure is already provided (see Numbers/Rational/BigQ), but this part is currently incomplete (no abstract layer and generic lemmas). - Many changes in FSets/FMaps. In practice, compatibility with earlier version should be fairly good, but some adaptations may be required. * Interfaces of unordered ("weak") and ordered sets have been factorized thanks to new features of Coq modules (in particular Include), see FSetInterface. Same for maps. Hints in these interfaces have been reworked (they are now placed in a "set" database). * To allow full subtyping between weak and ordered sets, a field "eq_dec" has been added to OrderedType. The old version of OrderedType is now called MiniOrderedType and functor MOT_to_OT allow to convert to the new version. The interfaces and implementations of sets now contain also such a "eq_dec" field. * FSetDecide, contributed by Aaron Bohannon, contains a decision procedure allowing to solve basic set-related goals (for instance, is a point in a particular set ?). See FSetProperties for examples. * Functors of properties have been improved, especially the ones about maps, that now propose some induction principles. Some properties of fold need less hypothesis. * More uniformity in implementations of sets and maps: they all use implicit arguments, and no longer export unnecessary scopes (see bug #1347) * Internal parts of the implementations based on AVL have evolved a lot. The main files FSetAVL and FMapAVL are now much more lightweight now. In particular, minor changes in some functions has allowed to fully separate the proofs of operational correctness from the proofs of well-balancing: well-balancing is critical for efficiency, but not anymore for proving that these trees implement our interfaces, hence we have moved these proofs into appendix files FSetFullAVL and FMapFullAVL. Moreover, a few functions like union and compare have been modified in order to be structural yet efficient. The appendix files also contains alternative versions of these few functions, much closer to the initial Ocaml code and written via the Function framework. - Library IntMap, subsumed by FSets/FMaps, has been removed from Coq Standard Library and moved into a user contribution Cachan/IntMap - Better computational behavior of some constants (eq_nat_dec and le_lt_dec more efficient, Z_lt_le_dec and Positive_as_OT.compare transparent, ...) (exceptional source of incompatibilities). - Boolean operators moved from module Bool to module Datatypes (may need to rename qualified references in script and force notations || and && to be at levels 50 and 40 respectively). - The constructors xI and xO of type positive now have postfix notations "~1" and "~0", allowing to write numbers in binary form easily, for instance 6 is 1~1~0 and 4*p is p~0~0 (see BinPos.v). - Improvements to NArith (Nminus, Nmin, Nmax), and to QArith (in particular a better power function). - Changes in ZArith: several additional lemmas (used in theories/Numbers), especially in Zdiv, Znumtheory, Zpower. Moreover, many results in Zdiv have been generalized: the divisor may simply be non-null instead of strictly positive (see lemmas with name ending by "_full"). An alternative file ZOdiv proposes a different behavior (the one of Ocaml) when dividing by negative numbers. - Changes in Arith: EqNat and Wf_nat now exported from Arith, some constructions on nat that were outside Arith are now in (e.g. iter_nat). - In SetoidList, eqlistA now expresses that two lists have similar elements at the same position, while the predicate previously called eqlistA is now equivlistA (this one only states that the lists contain the same elements, nothing more). - Changes in Reals: * Most statement in "sigT" (including the completeness axiom) are now in "sig" (in case of incompatibility, use proj1_sig instead of projT1, sig instead of sigT, etc). * More uniform naming scheme (identifiers in French moved to English, consistent use of 0 -- zero -- instead of O -- letter O --, etc). * Lemma on prod_f_SO is now on prod_f_R0. * Useless hypothesis of ln_exists1 dropped. * New Rlogic.v states a few logical properties about R axioms. * RIneq.v extended and made cleaner. - Slight restructuration of the Logic library regarding choice and classical logic. Addition of files providing intuitionistic axiomatizations of descriptions: Epsilon.v, Description.v and IndefiniteDescription.v. - Definition of pred and minus made compatible with the structural decreasing criterion for use in fixpoints. - Files Relations/Rstar.v and Relations/Newman.v moved out to the user contribution repository (contribution CoC_History). New lemmas about transitive closure added and some bound variables renamed (exceptional risk of incompatibilities). - Syntax for binders in terms (e.g. for "exists") supports anonymous names. Notations, coercions, implicit arguments and type inference - More automation in the inference of the return clause of dependent pattern-matching problems. - Experimental allowance for omission of the clauses easily detectable as impossible in pattern-matching problems. - Improved inference of implicit arguments. - New options "Set Maximal Implicit Insertion", "Set Reversible Pattern Implicit", "Set Strongly Strict Implicit" and "Set Printing Implicit Defensive" for controlling inference and use of implicit arguments. - New modifier in "Implicit Arguments" to force an implicit argument to be maximally inserted. - New modifier of "Implicit Arguments" to enrich the set of implicit arguments. - New options Global and Local to "Implicit Arguments" for section surviving or non export outside module. - Level "constr" moved from 9 to 8. - Structure/Record now printed as Record (unless option Printing All is set). - Support for parametric notations defining constants. - Insertion of coercions below product types refrains to unfold constants (possible source of incompatibility). - New support for fix/cofix in notations. Tactic Language - Second-order pattern-matching now working in Ltac "match" clauses (syntax for second-order unification variable is "@?X"). - Support for matching on let bindings in match context using syntax "H := body" or "H := body : type". - Ltac accepts integer arguments (syntax is "ltac:nnn" for nnn an integer). - The general sequence tactical "expr_0 ; [ expr_1 | ... | expr_n ]" is extended so that at most one expr_i may have the form "expr .." or just "..". Also, n can be different from the number of subgoals generated by expr_0. In this case, the value of expr (or idtac in case of just "..") is applied to the intermediate subgoals to make the number of tactics equal to the number of subgoals. - A name used as the name of the parameter of a lemma (like f in "apply f_equal with (f:=t)") is now interpreted as a ltac variable if such a variable exists (this is a possible source of incompatibility and it can be fixed by renaming the variables of a ltac function into names that do not clash with the lemmas parameter names used in the tactic). - New syntax "Ltac tac ::= ..." to rebind a tactic to a new expression. - "let rec ... in ... " now supported for expressions without explicit parameters; interpretation is lazy to the contrary of "let ... in ..."; hence, the "rec" keyword can be used to turn the argument of a "let ... in ..." into a lazy one. - Patterns for hypotheses types in "match goal" are now interpreted in type_scope. - A bound variable whose name is not used elsewhere now serves as metavariable in "match" and it gets instantiated by an identifier (allow e.g. to extract the name of a statement like "exists x, P x"). - New printing of Ltac call trace for better debugging. Tactics - New tactics "apply -> term", "apply <- term", "apply -> term in ident", "apply <- term in ident" for applying equivalences (iff). - Slight improvement of the hnf and simpl tactics when applied on expressions with explicit occurrences of match or fix. - New tactics "eapply in", "erewrite", "erewrite in". - New tactics "ediscriminate", "einjection", "esimplify_eq". - Tactics "discriminate", "injection", "simplify_eq" now support any term as argument. Clause "with" is also supported. - Unfoldable references can be given by notation's string rather than by name in unfold. - The "with" arguments are now typed using informations from the current goal: allows support for coercions and more inference of implicit arguments. - Application of "f_equal"-style lemmas works better. - Tactics elim, case, destruct and induction now support variants eelim, ecase, edestruct and einduction. - Tactics destruct and induction now support the "with" option and the "in" clause option. If the option "in" is used, an equality is added to remember the term to which the induction or case analysis applied (possible source of parsing incompatibilities when destruct or induction is part of a let-in expression in Ltac; extra parentheses are then required). - New support for "as" clause in tactics "apply in" and "eapply in". - Some new intro patterns: * intro pattern "?A" genererates a fresh name based on A. Caveat about a slight loss of compatibility: Some intro patterns don't need space between them. In particular intros ?a?b used to be legal and equivalent to intros ? a ? b. Now it is still legal but equivalent to intros ?a ?b. * intro pattern "(A & ... & Y & Z)" synonym to "(A,....,(Y,Z)))))" for right-associative constructs like /\ or exists. - Several syntax extensions concerning "rewrite": * "rewrite A,B,C" can be used to rewrite A, then B, then C. These rewrites occur only on the first subgoal: in particular, side-conditions of the "rewrite A" are not concerned by the "rewrite B,C". * "rewrite A by tac" allows to apply tac on all side-conditions generated by the "rewrite A". * "rewrite A at n" allows to select occurrences to rewrite: rewrite only happen at the n-th exact occurrence of the first successful matching of A in the goal. * "rewrite 3 A" or "rewrite 3!A" is equivalent to "rewrite A,A,A". * "rewrite !A" means rewriting A as long as possible (and at least once). * "rewrite 3?A" means rewriting A at most three times. * "rewrite ?A" means rewriting A as long as possible (possibly never). * many of the above extensions can be combined with each other. - Introduction patterns better respect the structure of context in presence of missing or extra names in nested disjunction-conjunction patterns [possible source of rare incompatibilities]. - New syntax "rename a into b, c into d" for "rename a into b; rename c into d" - New tactics "dependent induction/destruction H [ generalizing id_1 .. id_n ]" to do induction-inversion on instantiated inductive families à la BasicElim. - Tactics "apply" and "apply in" now able to reason modulo unfolding of constants (possible source of incompatibility in situations where apply may fail, e.g. as argument of a try or a repeat and in a ltac function); versions that do not unfold are renamed into "simple apply" and "simple apply in" (usable for compatibility or for automation). - Tactics "apply" and "apply in" now able to traverse conjunctions and to select the first matching lemma among the components of the conjunction; tactic "apply" also able to apply lemmas of conclusion an empty type. - Tactic "apply" now supports application of several lemmas in a row. - Tactics "set" and "pose" can set functions using notation "(f x1..xn := c)". - New tactic "instantiate" (without argument). - Tactic firstorder "with" and "using" options have their meaning swapped for consistency with auto/eauto (source of incompatibility). - Tactic "generalize" now supports "at" options to specify occurrences and "as" options to name the quantified hypotheses. - New tactic "specialize H with a" or "specialize (H a)" allows to transform in-place a universally-quantified hypothesis (H : forall x, T x) into its instantiated form (H : T a). Nota: "specialize" was in fact there in earlier versions of Coq, but was undocumented, and had a slightly different behavior. - New tactic "contradict H" can be used to solve any kind of goal as long as the user can provide afterwards a proof of the negation of the hypothesis H. If H is already a negation, say ~T, then a proof of T is asked. If the current goal is a negation, say ~U, then U is saved in H afterwards, hence this new tactic "contradict" extends earlier tactic "swap", which is now obsolete. - Tactics f_equal is now done in ML instead of Ltac: it now works on any equality of functions, regardless of the arity of the function. - New options "before id", "at top", "at bottom" for tactics "move"/"intro". - Some more debug of reflexive omega (romega), and internal clarifications. Moreover, romega now has a variant "romega with *" that can be also used on non-Z goals (nat, N, positive) via a call to a translation tactic named zify (its purpose is to Z-ify your goal...). This zify may also be used independantly of romega. - Tactic "remember" now supports an "in" clause to remember only selected occurrences of a term. - Tactic "pose proof" supports name overwriting in case of specialization of an hypothesis. - Semi-decision tactic "jp" for first-order intuitionistic logic moved to user contributions (subsumed by "firstorder"). Program - Moved useful tactics in theories/Program and documented them. - Add Program.Basics which contains standard definitions for functional programming (id, apply, flip...) - More robust obligation handling, dependent pattern-matching and well-founded definitions. - New syntax " dest term as pat in term " for destructing objects using an irrefutable pattern while keeping equalities (use this instead of "let" in Programs). - Program CoFixpoint is accepted, Program Fixpoint uses the new way to infer which argument decreases structurally. - Program Lemma, Axiom etc... now permit to have obligations in the statement iff they can be automatically solved by the default tactic. - Renamed "Obligations Tactic" command to "Obligation Tactic". - New command "Preterm [ of id ]" to see the actual term fed to Coq for debugging purposes. - New option "Transparent Obligations" to control the declaration of obligations as transparent or opaque. All obligations are now transparent by default, otherwise the system declares them opaque if possible. - Changed the notations "left" and "right" to "in_left" and "in_right" to hide the proofs in standard disjunctions, to avoid breaking existing scripts when importing Program. Also, put them in program_scope. Type Classes - New "Class", "Instance" and "Program Instance" commands to define classes and instances documented in the reference manual. - New binding construct " [ Class_1 param_1 .. param_n, Class_2 ... ] " for binding type classes, usable everywhere. - New command " Print Classes " and " Print Instances some_class " to print tables for typeclasses. - New default eauto hint database "typeclass_instances" used by the default typeclass instance search tactic. - New theories directory "theories/Classes" for standard typeclasses declarations. Module Classes.RelationClasses is a typeclass port of Relation_Definitions plus a generic development of algebra on n-ary heterogeneous predicates. Setoid rewriting - Complete (and still experimental) rewrite of the tactic based on typeclasses. The old interface and semantics are almost entirely respected, except: - Import Setoid is now mandatory to be able to call setoid_replace and declare morphisms. - "-->", "++>" and "==>" are now right associative notations declared at level 55 in scope signature_scope. Their introduction may break existing scripts that defined them as notations with different levels. - One needs to use [Typeclasses unfold [cst]] if [cst] is used as an abbreviation hiding products in types of morphisms, e.g. if ones redefines [relation] and declares morphisms whose type mentions [relation]. - The [setoid_rewrite]'s semantics change when rewriting with a lemma: it can rewrite two different instantiations of the lemma at once. Use [setoid_rewrite H at 1] for (almost) the usual semantics. [setoid_rewrite] will also try to rewrite under binders now, and can succeed on different terms than before. In particular, it will unify under let-bound variables. When called through [rewrite], the semantics are unchanged though. - [Add Morphism term : id] has different semantics when used with parametric morphism: it will try to find a relation on the parameters too. The behavior has also changed with respect to default relations: the most recently declared Setoid/Relation will be used, the documentation explains how to customize this behavior. - Parametric Relation and Morphism are declared differently, using the new [Add Parametric] commands, documented in the manual. - Setoid_Theory is now an alias to Equivalence, scripts building objects of type Setoid_Theory need to unfold (or "red") the definitions of Reflexive, Symmetric and Transitive in order to get the same goals as before. Scripts which introduced variables explicitely will not break. - The order of subgoals when doing [setoid_rewrite] with side-conditions is always the same: first the new goal, then the conditions. - New standard library modules Classes.Morphisms declares standard morphisms on refl/sym/trans relations. Classes.Morphisms_Prop declares morphisms on propositional connectives and Classes.Morphisms_Relations on generalized predicate connectives. Classes.Equivalence declares notations and tactics related to equivalences and Classes.SetoidTactics defines the setoid_replace tactics and some support for the "Add *" interface, notably the tactic applied automatically before each "Add Morphism" proof. - User-defined subrelations are supported, as well as higher-order morphisms and rewriting under binders. The tactic is also extensible entirely in Ltac. The documentation has been updated to cover these features. - [setoid_rewrite] and [rewrite] now support the [at] modifier to select occurrences to rewrite, and both use the [setoid_rewrite] code, even when rewriting with leibniz equality if occurrences are specified. Extraction - Improved behavior of the Caml extraction of modules: name clashes should not happen anymore. - The command Extract Inductive has now a syntax for infix notations. This allows in particular to map Coq lists and pairs onto Caml ones: Extract Inductive list => list [ "[]" "(::)" ]. Extract Inductive prod => "(*)" [ "(,)" ]. - In pattern matchings, a default pattern "| _ -> ..." is now used whenever possible if several branches are identical. For instance, functions corresponding to decidability of equalities are now linear instead of quadratic. - A new instruction Extraction Blacklist id1 .. idn allows to prevent filename conflits with existing code, for instance when extracting module List to Ocaml. CoqIDE - CoqIDE font defaults to monospace so as indentation to be meaningful. - CoqIDE supports nested goals and any other kind of declaration in the middle of a proof. - Undoing non-tactic commands in CoqIDE works faster. - New CoqIDE menu for activating display of various implicit informations. - Added the possibility to choose the location of tabs in coqide: (in Edit->Preferences->Misc) - New Open and Save As dialogs in CoqIDE which filter *.v files. Tools - New stand-alone .vo files verifier "coqchk". - Extended -I coqtop/coqc option to specify a logical dir: "-I dir -as coqdir". - New coqtop/coqc option -exclude-dir to exclude subdirs for option -R. - The binary "parser" has been renamed to "coq-parser". - Improved coqdoc and dump of globalization information to give more meta-information on identifiers. All categories of Coq definitions are supported, which makes typesetting trivial in the generated documentation. Support for hyperlinking and indexing developments in the tex output has been implemented as well. Miscellaneous - Coq installation provides enough files so that Ocaml's extensions need not the Coq sources to be compiled (this assumes O'Caml 3.10 and Camlp5). - New commands "Set Whelp Server" and "Set Whelp Getter" to customize the Whelp search tool. - Syntax of "Test Printing Let ref" and "Test Printing If ref" changed into "Test Printing Let for ref" and "Test Printing If for ref". - An overhauled build system (new Makefiles); see dev/doc/build-system.txt. - Add -browser option to configure script. - Build a shared library for the C part of Coq, and use it by default on non-(Windows or MacOS) systems. Bytecode executables are now pure. The behaviour is configurable with -coqrunbyteflags, -coqtoolsbyteflags and -custom configure options. - Complexity tests can be skipped by setting the environment variable COQTEST_SKIPCOMPLEXITY. Changes from V8.1gamma to V8.1 ============================== Bug fixes - Many bugs have been fixed (cf coq-bugs web page) Tactics - New tactics ring, ring_simplify and new tactic field now able to manage power to a positive integer constant. Tactic ring on Z and R, and field on R manage power (may lead to incompatibilities with V8.1gamma). - Tactic field_simplify now applicable in hypotheses. - New field_simplify_eq for simplifying field equations into ring equations. - Tactics ring, ring_simplify, field, field_simplify and field_simplify_eq all able to apply user-given equations to rewrite monoms on the fly (see documentation). Libraries - New file ConstructiveEpsilon.v defining an epsilon operator and proving the axiom of choice constructively for a countable domain and a decidable predicate. Changes from V8.1beta to V8.1gamma ================================== Syntax - changed parsing precedence of let/in and fun constructions of Ltac: let x := t in e1; e2 is now parsed as let x := t in (e1;e2). Language and commands - Added sort-polymorphism for definitions in Type (but finally abandonned). - Support for implicit arguments in the types of parameters in (co-)fixpoints and (co-)inductive declarations. - Improved type inference: use as much of possible general information. before applying irreversible unification heuristics (allow e.g. to infer the predicate in "(exist _ 0 (refl_equal 0) : {n:nat | n=0 })"). - Support for Miller-Pfenning's patterns unification in type synthesis (e.g. can infer P such that P x y = phi(x,y)). - Support for "where" clause in cofixpoint definitions. - New option "Set Printing Universes" for making Type levels explicit. Tactics - Improved implementation of the ring and field tactics. For compatibility reasons, the previous tactics are renamed as legacy ring and legacy field, but should be considered as deprecated. - New declarative mathematical proof language. - Support for argument lists of arbitrary length in Tactic Notation. - [rewrite ... in H] now fails if [H] is used either in an hypothesis or in the goal. - The semantics of [rewrite ... in *] has been slightly modified (see doc). - Support for "as" clause in tactic injection. - New forward-reasoning tactic "apply in". - Ltac fresh operator now builds names from a concatenation of its arguments. - New ltac tactic "remember" to abstract over a subterm and keep an equality - Support for Miller-Pfenning's patterns unification in apply/rewrite/... (may lead to few incompatibilities - generally now useless tactic calls). Bug fixes - Fix for notations involving basic "match" expressions. - Numerous other bugs solved (a few fixes may lead to incompatibilities). Changes from V8.0 to V8.1beta ============================= Logic - Added sort-polymorphism on inductive families - Allowance for recursively non uniform parameters in inductive types Syntax - No more support for version 7 syntax and for translation to version 8 syntax. - In fixpoints, the { struct ... } annotation is not mandatory any more when only one of the arguments has an inductive type - Added disjunctive patterns in match-with patterns - Support for primitive interpretation of string literals - Extended support for Unicode ranges Vernacular commands - Added "Print Ltac qualid" to print a user defined tactic. - Added "Print Rewrite HintDb" to print the content of a DB used by autorewrite. - Added "Print Canonical Projections". - Added "Example" as synonym of "Definition". - Added "Proposition" and "Corollary" as extra synonyms of "Lemma". - New command "Whelp" to send requests to the Helm database of proofs formalized in the Calculus of Inductive Constructions. - Command "functional induction" has been re-implemented from the new "Function" command. Ltac and tactic syntactic extensions - New primitive "external" for communication with tool external to Coq - New semantics for "match t with": if a clause returns a tactic, it is now applied to the current goal. If it fails, the next clause or next matching subterm is tried (i.e. it behaves as "match goal with" does). The keyword "lazymatch" can be used to delay the evaluation of tactics occurring in matching clauses. - Hint base names can be parametric in auto and trivial. - Occurrence values can be parametric in unfold, pattern, etc. - Added entry constr_may_eval for tactic extensions. - Low-priority term printer made available in ML-written tactic extensions. - "Tactic Notation" extended to allow notations of tacticals. Tactics - New implementation and generalization of [setoid_]* (setoid_rewrite, setoid_symmetry, setoid_transitivity, setoid_reflexivity and autorewite). New syntax for declaring relations and morphisms (old syntax still working with minor modifications, but deprecated). - New implementation (still experimental) of the ring tactic with a built-in notion of coefficients and a better usage of setoids. - New conversion tactic "vm_compute": evaluates the goal (or an hypothesis) with a call-by-value strategy, using the compiled version of terms. - When rewriting H where H is not directly a Coq equality, search first H for a registered setoid equality before starting to reduce in H. This is unlikely to break any script. Should this happen nonetheless, one can insert manually some "unfold ... in H" before rewriting. - Fixed various bugs about (setoid) rewrite ... in ... (in particular #1101) - "rewrite ... in" now accepts a clause as place where to rewrite instead of juste a simple hypothesis name. For instance: rewrite H in H1,H2 |- * means rewrite H in H1; rewrite H in H2; rewrite H rewrite H in * |- will do try rewrite H in Hi for all hypothesis Hi <> H. - Added "dependent rewrite term" and "dependent rewrite term in hyp". - Added "autorewrite with ... in hyp [using ...]". - Tactic "replace" now accepts a "by" tactic clause. - Added "clear - id" to clear all hypotheses except the ones depending in id. - The argument of Declare Left Step and Declare Right Step is now a term (it used to be a reference). - Omega now handles arbitrary precision integers. - Several bug fixes in Reflexive Omega (romega). - Idtac can now be left implicit in a [...|...] construct: for instance, [ foo | | bar ] stands for [ foo | idtac | bar ]. - Fixed a "fold" bug (non critical but possible source of incompatibilities). - Added classical_left and classical_right which transforms |- A \/ B into ~B |- A and ~A |- B respectively. - Added command "Declare Implicit Tactic" to set up a default tactic to be used to solve unresolved subterms of term arguments of tactics. - Better support for coercions to Sortclass in tactics expecting type arguments. - Tactic "assert" now accepts "as" intro patterns and "by" tactic clauses. - New tactic "pose proof" that generalizes "assert (id:=p)" with intro patterns. - New introduction pattern "?" for letting Coq choose a name. - Introduction patterns now support side hypotheses (e.g. intros [|] on "(nat -> nat) -> nat" works). - New introduction patterns "->" and "<-" for immediate rewriting of introduced hypotheses. - Introduction patterns coming after non trivial introduction patterns now force full introduction of the first pattern (e.g. "intros [[|] p]" on "nat->nat->nat" now behaves like "intros [[|?] p]") - Added "eassumption". - Added option 'using lemmas' to auto, trivial and eauto. - Tactic "congruence" is now complete for its intended scope (ground equalities and inequalities with constructors). Furthermore, it tries to equates goal and hypotheses. - New tactic "rtauto" solves pure propositional logic and gives a reflective version of the available proof. - Numbering of "pattern", "unfold", "simpl", ... occurrences in "match with" made consistent with the printing of the return clause after the term to match in the "match-with" construct (use "Set Printing All" to see hidden occurrences). - Generalization of induction "induction x1...xn using scheme" where scheme is an induction principle with complex predicates (like the ones generated by function induction). - Some small Ltac tactics has been added to the standard library (file Tactics.v): * f_equal : instead of using the different f_equalX lemmas * case_eq : a "case" without loss of information. An equality stating the current situation is generated in every sub-cases. * swap : for a negated goal ~B and a negated hypothesis H:~A, swap H asks you to prove A from hypothesis B * revert : revert H is generalize H; clear H. Extraction - All type parts should now disappear instead of sometimes producing _ (for instance in Map.empty). - Haskell extraction: types of functions are now printed, better unsafeCoerce mechanism, both for hugs and ghc. - Scheme extraction improved, see http://www.pps.jussieu.fr/~letouzey/scheme. - Many bug fixes. Modules - Added "Locate Module qualid" to get the full path of a module. - Module/Declare Module syntax made more uniform. - Added syntactic sugar "Declare Module Export/Import" and "Module Export/Import". - Added syntactic sugar "Module M(Export/Import X Y: T)" and "Module Type M(Export/Import X Y: T)" (only for interactive definitions) - Construct "with" generalized to module paths: T with (Definition|Module) M1.M2....Mn.l := l'. Notations - Option "format" aware of recursive notations. - Added insertion of spaces by default in recursive notations w/o separators. - No more automatic printing box in case of user-provided printing "format". - New notation "exists! x:A, P" for unique existence. - Notations for specific numerals now compatible with generic notations of numerals (e.g. "1" can be used to denote the unit of a group without hiding 1%nat) Libraries - New library on String and Ascii characters (contributed by L. Thery). - New library FSets+FMaps of finite sets and maps. - New library QArith on rational numbers. - Small extension of Zmin.V, new Zmax.v, new Zminmax.v. - Reworking and extension of the files on classical logic and description principles (possible incompatibilities) - Few other improvements in ZArith potentially exceptionally breaking the compatibility (useless hypothesys of Zgt_square_simpl and Zlt_square_simpl removed; fixed names mentioning letter O instead of digit 0; weaken premises in Z_lt_induction). - Restructuration of Eqdep_dec.v and Eqdep.v: more lemmas in Type. - Znumtheory now contains a gcd function that can compute within Coq. - More lemmas stated on Type in Wf.v, removal of redundant Acc_iter and Acc_iter2. - Change of the internal names of lemmas in OmegaLemmas. - Acc in Wf.v and clos_refl_trans in Relation_Operators.v now rely on the allowance for recursively non uniform parameters (possible source of incompatibilities: explicit pattern-matching on these types may require to remove the occurrence associated to their recursively non uniform parameter). - Coq.List.In_dec has been set transparent (this may exceptionally break proof scripts, set it locally opaque for compatibility). - More on permutations of lists in List.v and Permutation.v. - List.v has been much expanded. - New file SetoidList.v now contains results about lists seen with respect to a setoid equality. - Library NArith has been expanded, mostly with results coming from Intmap (for instance a bitwise xor), plus also a bridge between N and Bitvector. - Intmap has been reorganized. In particular its address type "addr" is now N. User contributions known to use Intmap have been adapted accordingly. If you're using this library please contact us. A wrapper FMapIntMap now presents Intmap as a particular implementation of FMaps. New developments are strongly encouraged to use either this wrapper or any other implementations of FMap instead of using directly this obsolete Intmap. Tools - New semantics for coqtop options ("-batch" expects option "-top dir" for loading vernac file that contains definitions). - Tool coq_makefile now removes custom targets that are file names in "make clean" - New environment variable COQREMOTEBROWSER to set the command invoked to start the remote browser both in Coq and coqide. Standard syntax: "%s" is the placeholder for the URL. Changes from V8.0beta to V8.0 ============================= Vernacular commands - New option "Set Printing All" to deactivate all high-level forms of printing (implicit arguments, coercions, destructing let, if-then-else, notations, projections) - "Functional Scheme" and "Functional Induction" extended to polymorphic types and dependent types - Notation now allows recursive patterns, hence recovering parts of the fonctionalities of pre-V8 Grammar/Syntax commands - Command "Print." discontinued. - Redundant syntax "Implicit Arguments On/Off" discontinued New syntax - Semantics change of the if-then-else construction in new syntax: "if c then t1 else t2" now stands for "match c with c1 _ ... _ => t1 | c2 _ ... _ => t2 end" with no dependency of t1 and t2 in the arguments of the constructors; this may cause incompatibilities for files translated using coq 8.0beta Interpretation scopes - Delimiting key %bool for bool_scope added - Import no more needed to activate argument scopes from a module Tactics and the tactic Language - Semantics of "assert" is now consistent with the reference manual - New tactics stepl and stepr for chaining transitivity steps - Tactic "replace ... with ... in" added - Intro patterns now supported in Ltac (parsed with prefix "ipattern:") Executables and tools - Added option -top to change the name of the toplevel module "Top" - Coqdoc updated to new syntax and now part of Coq sources - XML exportation tool now exports the structure of vernacular files (cf chapter 13 in the reference manual) User contributions - User contributions have been updated to the new syntax Bug fixes - Many bugs have been fixed (cf coq-bugs web page) Changes from V8.0beta old syntax to V8.0beta ============================================ New concrete syntax - A completely new syntax for terms - A more uniform syntax for tactics and the tactic language - A few syntactic changes for vernacular commands - A smart automatic translator translating V8.0 files in old syntax to files valid for V8.0 Syntax extensions - "Grammar" for terms disappears - "Grammar" for tactics becomes "Tactic Notation" - "Syntax" disappears - Introduction of a notion of interpretation scope allowing to use the same notations in various contexts without using specific delimiters (e.g the same expression "4<=3+x" is interpreted either in "nat", "positive", "N" (previously "entier"), "Z", "R", depending on which interpretation scope is currently open) [see documentation for details] - Notation now mandatorily requires a precedence and associativity (default was to set precedence to 1 and associativity to none) Revision of the standard library - Many lemmas and definitions names have been made more uniform mostly in Arith, NArith, ZArith and Reals (e.g : "times" -> "Pmult", "times_sym" -> "Pmult_comm", "Zle_Zmult_pos_right" -> "Zmult_le_compat_r", "SUPERIEUR" -> "Gt", "ZERO" -> "Z0") - Order and names of arguments of basic lemmas on nat, Z, positive and R have been made uniform. - Notions of Coq initial state are declared with (strict) implicit arguments - eq merged with eqT: old eq disappear, new eq (written =) is old eqT and new eqT is syntactic sugar for new eq (notation == is an alias for = and is written as it, exceptional source of incompatibilities) - Similarly, ex, ex2, all, identity are merged with exT, exT2, allT, identityT - Arithmetical notations for nat, positive, N, Z, R, without needing any backquote or double-backquotes delimiters. - In Lists: new concrete notations; argument of nil is now implicit - All changes in the library are taken in charge by the translator Semantical changes during translation - Recursive keyword set by default (and no longer needed) in Tactic Definition - Set Implicit Arguments is strict by default in new syntax - reductions in hypotheses of the form "... in H" now apply to the type also if H is a local definition - etc Gallina - New syntax of the form "Inductive bool : Set := true, false : bool." for enumerated types - Experimental syntax of the form p.(fst) for record projections (activable with option "Set Printing Projections" which is recognized by the translator) Known problems of the automatic translation - iso-latin-1 characters are no longer supported: move your files to 7-bits ASCII or unicode before translation (swith to unicode is automatically done if a file is loaded and saved again by coqide) - Renaming in ZArith: incompatibilities in Coq user contribs due to merging names INZ, from Reals, and inject_nat. - Renaming and new lemmas in ZArith: may clash with names used by users - Restructuration of ZArith: replace requirement of specific modules in ZArith by "Require Import ZArith_base" or "Require Import ZArith" - Some implicit arguments must be made explicit before translation: typically for "length nil", the implicit argument of length must be made explicit - Grammar rules, Infix notations and V7.4 Notations must be updated wrt the new scheme for syntactic extensions (see translator documentation) - Unsafe for annotation Cases when constructors coercions are used or when annotations are eta-reduced predicates Changes from V7.4 to V8.0beta old syntax ======================================== Logic - Set now predicative by default - New option -impredicative-set to set Set impredicative - The standard library doesn't need impredicativity of Set and is compatible with the classical axioms which contradict Set impredicativity Syntax for arithmetic - Notation "=" and "<>" in Z and R are no longer implicitly in Z or R (with possible introduction of a coercion), use ...=... or ...<>... instead - Locate applied to a simple string (e.g. "+") searches for all notations containing this string Vernacular commands - "Declare ML Module" now allows to import .cma files. This avoids to use a bunch of "Declare ML Module" statements when using several ML files. - "Set Printing Width n" added, allows to change the size of width printing. - "Implicit Variables Type x,y:t" (new syntax: "Implicit Types x y:t") assigns default types for binding variables. - Declarations of Hints and Notation now accept a "Local" flag not to be exported outside the current file even if not in section - "Print Scopes" prints all notations - New command "About name" for light printing of type, implicit arguments, etc. - New command "Admitted" to declare incompletely proven statement as axioms - New keyword "Conjecture" to declare an axiom intended to be provable - SearchAbout can now search for lemmas referring to more than one constant and on substrings of the name of the lemma - "Print Implicit" displays the implicit arguments of a constant - Locate now searches for all names having a given suffix - New command "Functional Scheme" for building an induction principle from a function defined by case analysis and fix. Commands - new coqtop/coqc option -dont-load-proofs not to load opaque proofs in memory Implicit arguments - Inductive in sections declared with implicits now "discharged" with implicits (like constants and variables) - Implicit Arguments flags are now synchronous with reset - New switch "Unset/Set Printing Implicits" (new syntax: "Unset/Set Printing Implicit") to globally control printing of implicits Grammar extensions - Many newly supported UTF-8 encoded unicode blocks - Greek letters (0380-03FF), Hebrew letters (U05D0-05EF), letter-like symbols (2100-214F, that includes double N,Z,Q,R), prime signs (from 2080-2089) and characters from many written languages are valid in identifiers - mathematical operators (2200-22FF), supplemental mathematical operators (2A00-2AFF), miscellaneous technical (2300-23FF that includes sqrt symbol), miscellaneous symbols (2600-26FF), arrows (2190-21FF and 2900-297F), invisible mathematical operators (from 2080-2089), ... are valid symbols Library - New file about the factorial function in Arith - An additional elimination Acc_iter for Acc, simplier than Acc_rect. This new elimination principle is used for definition well_founded_induction. - New library NArith on binary natural numbers - R is now of type Set - Restructuration in ZArith library - "true_sub" used in Zplus now a definition, not a local one (source of incompatibilities in proof referring to true_sub, may need extra Unfold) - Some lemmas about minus moved from fast_integer to Arith/Minus.v (le_minus, lt_mult_left) (theoretical source of incompatibilities) - Several lemmas moved from auxiliary.v and zarith_aux.v to fast_integer.v (theoretical source of incompatibilities) - Variables names of iff_trans changed (source of incompatibilities) - ZArith lemmas named OMEGA something or fast_ something, and lemma new_var are now out of ZArith (except OMEGA2) - Redundant ZArith lemmas have been renamed: for the following pairs, use the second name (Zle_Zmult_right2, Zle_mult_simpl), (OMEGA2, Zle_0_plus), (Zplus_assoc_l, Zplus_assoc), (Zmult_one, Zmult_1_n), (Zmult_assoc_l, Zmult_assoc), (Zmult_minus_distr, Zmult_Zminus_distr_l) (add_un_double_moins_un_xO, is_double_moins_un), (Rlt_monotony_rev,Rlt_monotony_contra) (source of incompatibilities) - Few minor changes (no more implicit arguments in Zmult_Zminus_distr_l and Zmult_Zminus_distr_r, lemmas moved from Zcomplements to other files) (rare source of incompatibilities) - New lemmas provided by users added Tactic language - Fail tactic now accepts a failure message - Idtac tactic now accepts a message - New primitive tactic "FreshId" (new syntax: "fresh") to generate new names - Debugger prints levels of calls Tactics - Replace can now replace proofs also - Fail levels are now decremented at "Match Context" blocks only and if the right-hand-side of "Match term With" are tactics, these tactics are never evaluated immediately and do not induce backtracking (in contrast with "Match Context") - Quantified names now avoid global names of the current module (like Intro names did) [source of rare incompatibilities: 2 changes in the set of user contribs] - NewDestruct/NewInduction accepts intro patterns as introduction names - NewDestruct/NewInduction now work for non-inductive type using option "using" - A NewInduction naming bug for inductive types with functional arguments (e.g. the accessibility predicate) has been fixed (source of incompatibilities) - Symmetry now applies to hypotheses too - Inversion now accept option "as [ ... ]" to name the hypotheses - Contradiction now looks also for contradictory hypotheses stating ~A and A (source of incompatibility) - "Contradiction c" try to find an hypothesis in context which contradicts the type of c - Ring applies to new library NArith (require file NArithRing) - Field now works on types in Set - Auto with reals now try to replace le by ge (Rge_le is no longer an immediate hint), resulting in shorter proofs - Instantiate now works in hyps (syntax : Instantiate in ...) - Some new tactics : EConstructor, ELeft, Eright, ESplit, EExists - New tactic "functional induction" to perform case analysis and induction following the definition of a function. - Clear now fails when trying to remove a local definition used by a constant appearing in the current goal Extraction (See details in plugins/extraction/CHANGES) - The old commands: (Recursive) Extraction Module M. are now: (Recursive) Extraction Library M. To use these commands, M should come from a library M.v - The other syntax Extraction & Recursive Extraction now accept module names as arguments. Bugs - see coq-bugs server for the complete list of fixed bugs Miscellaneous - Implicit parameters of inductive types definition now taken into account for infering other implicit arguments Incompatibilities - Persistence of true_sub (4 incompatibilities in Coq user contributions) - Variable names of some constants changed for a better uniformity (2 changes in Coq user contributions) - Naming of quantified names in goal now avoid global names (2 occurrences) - NewInduction naming for inductive types with functional arguments (no incompatibility in Coq user contributions) - Contradiction now solve more goals (source of 2 incompatibilities) - Merge of eq and eqT may exceptionally result in subgoals now solved automatically - Redundant pairs of ZArith lemmas may have different names: it may cause "Apply/Rewrite with" to fail if using the first name of a pair of redundant lemmas (this is solved by renaming the variables bound by "with"; 3 incompatibilities in Coq user contribs) - ML programs referring to constants from fast_integer.v must use "Coqlib.gen_constant_modules Coqlib.zarith_base_modules" instead Changes from V7.3.1 to V7.4 =========================== Symbolic notations - Introduction of a notion of scope gathering notations in a consistent set; a notation sets has been developped for nat, Z and R (undocumented) - New command "Notation" for declaring notations simultaneously for parsing and printing (see chap 10 of the reference manual) - Declarations with only implicit arguments now handled (e.g. the argument of nil can be set implicit; use !nil to refer to nil without arguments) - "Print Scope sc" and "Locate ntn" allows to know to what expression a notation is bound - New defensive strategy for printing or not implicit arguments to ensure re-type-checkability of the printed term - In Grammar command, the only predefined non-terminal entries are ident, global, constr and pattern (e.g. nvar, numarg disappears); the only allowed grammar types are constr and pattern; ast and ast list are no longer supported; some incompatibilities in Grammar: when a syntax is a initial segment of an other one, Grammar does not work, use Notation Library - Lemmas in Set from Compare_dec.v (le_lt_dec, ...) and Wf_nat.v (lt_wf_rec, ...) are now transparent. This may be source of incompatibilities. - Syntactic Definitions Fst, Snd, Ex, All, Ex2, AllT, ExT, ExT2, ProjS1, ProjS2, Error, Value and Except are turned to notations. They now must be applied (incompatibilities only in unrealistic cases). - More efficient versions of Zmult and times (30% faster) - Reals: the library is now divided in 6 parts (Rbase, Rfunctions, SeqSeries, Rtrigo, Ranalysis, Integration). New tactics: Sup and RCompute. See Reals.v for details. Modules - Beta version, see doc chap 2.5 for commands and chap 5 for theory Language - Inductive definitions now accept ">" in constructor types to declare the corresponding constructor as a coercion. - Idem for assumptions declarations and constants when the type is mentionned. - The "Coercion" and "Canonical Structure" keywords now accept the same syntax as "Definition", i.e. "hyps :=c (:t)?" or "hyps :t". - Theorem-like declaration now accepts the syntax "Theorem thm [x:t;...] : u". - Remark's and Fact's now definitively behave as Theorem and Lemma: when sections are closed, the full name of a Remark or a Fact has no longer a section part (source of incompatibilities) - Opaque Local's (i.e. built by tactics and ended by Qed), do not survive section closing any longer; as a side-effect, Opaque Local's now appear in the local context of proofs; their body is hidden though (source of incompatibilities); use one of Remark/Fact/Lemma/Theorem instead to simulate the old behaviour of Local (the section part of the name is not kept though) ML tactic and vernacular commands - "Grammar tactic" and "Grammar vernac" of type "ast" are no longer supported (only "Grammar tactic simple_tactic" of type "tactic" remains available). - Concrete syntax for ML written vernacular commands and tactics is now declared at ML level using camlp4 macros TACTIC EXTEND et VERNAC COMMAND EXTEND. - "Check n c" now "n:Check c", "Eval n ..." now "n:Eval ..." - "Proof with T" (* no documentation *) - SearchAbout id - prints all theorems which contain id in their type Tactic definitions - Static globalisation of identifiers and global references (source of incompatibilities, especially, Recursive keyword is required for mutually recursive definitions). - New evaluation semantics: no more partial evaluation at definition time; evaluation of all Tactic/Meta Definition, even producing terms, expect a proof context to be evaluated (especially "()" is no longer needed). - Debugger now shows the nesting level and the reasons of failure Tactics - Equality tactics (Rewrite, Reflexivity, Symmetry, Transitivity) now understand JM equality - Simpl and Change now apply to subterms also - "Simpl f" reduces subterms whose head constant is f - Double Induction now referring to hypotheses like "Intros until" - "Inversion" now applies also on quantified hypotheses (naming as for Intros until) - NewDestruct now accepts terms with missing hypotheses - NewDestruct and NewInduction now accept user-provided elimination scheme - NewDestruct and NewInduction now accept user-provided introduction names - Omega could solve goals such as ~`x=y` but failed when the hypothesis was unfolded to `x < y` -> False. This is fixed. In addition, it can also recognize 'False' in the hypothesis and use it to solve the goal. - Coercions now handled in "with" bindings - "Subst x" replaces all ocurrences of x by t in the goal and hypotheses when an hypothesis x=t or x:=t or t=x exists - Fresh names for Assert and Pose now based on collision-avoiding Intro naming strategy (exceptional source of incompatibilities) - LinearIntuition (* no documentation *) - Unfold expects a correct evaluable argument - Clear expects existing hypotheses Extraction (See details in plugins/extraction/CHANGES and README): - An experimental Scheme extraction is provided. - Concerning Ocaml, extracted code is now ensured to always type-check, thanks to automatic inserting of Obj.magic. - Experimental extraction of Coq new modules to Ocaml modules. Proof rendering in natural language - Export of theories to XML for publishing and rendering purposes now includes proof-trees (see http://www.cs.unibo.it/helm) Miscellaneous - Printing Coercion now used through the standard keywords Set/Add, Test, Print - "Print Term id" is an alias for "Print id" - New switch "Unset/Set Printing Symbols" to control printing of symbolic notations - Two new variants of implicit arguments are available - "Unset/Set Contextual Implicits" tells to consider implicit also the arguments inferable from the context (e.g. for nil or refl_eq) - "Unset/Set Strict Implicits" tells to consider implicit only the arguments that are inferable in any case (i.e. arguments that occurs as argument of rigid constants in the type of the remaining arguments; e.g. the witness of an existential is not strict since it can vanish when applied to a predicate which does not use its argument) Incompatibilities - "Grammar tactic ... : ast" and "Grammar vernac ... : ast" are no longer supported, use TACTIC EXTEND and VERNAC COMMAND EXTEND on the ML-side instead - Transparency of le_lt_dec and co (leads to some simplification in proofs; in some cases, incompatibilites is solved by declaring locally opaque the relevant constant) - Opaque Local do not now survive section closing (rename them into Remark/Lemma/... to get them still surviving the sections; this renaming allows also to solve incompatibilites related to now forbidden calls to the tactic Clear) - Remark and Fact have no longer (very) long names (use Local instead in case of name conflict) Bugs - Improved localisation of errors in Syntactic Definitions - Induction principle creation failure in presence of let-in fixed (#238) - Inversion bugs fixed (#212 and #220) - Omega bug related to Set fixed (#180) - Type-checking inefficiency of nested destructuring let-in fixed (#216) - Improved handling of let-in during holes resolution phase (#239) Efficiency - Implementation of a memory sharing strategy reducing memory requirements by an average ratio of 3. Changes from V7.3 to V7.3.1 =========================== Bug fixes - Corrupted Field tactic and Match Context tactic construction fixed - Checking of names already existing in Assert added (PR#182) - Invalid argument bug in Exact tactic solved (PR#183) - Colliding bound names bug fixed (PR#202) - Wrong non-recursivity test for Record fixed (PR#189) - Out of memory/seg fault bug related to parametric inductive fixed (PR#195) - Setoid_replace/Setoid_rewrite bug wrt "==" fixed Misc - Ocaml version >= 3.06 is needed to compile Coq from sources - Simplification of fresh names creation strategy for Assert, Pose and LetTac (PR#192) Changes from V7.2 to V7.3 ========================= Language - Slightly improved compilation of pattern-matching (slight source of incompatibilities) - Record's now accept anonymous fields "_" which does not build projections - Changes in the allowed elimination sorts for certain class of inductive definitions : an inductive definition without constructors of Sort Prop can be eliminated on sorts Set and Type A "singleton" inductive definition (one constructor with arguments in the sort Prop like conjunction of two propositions or equality) can be eliminated directly on sort Type (In V7.2, only the sorts Prop and Set were allowed) Tactics - New tactic "Rename x into y" for renaming hypotheses - New tactics "Pose x:=u" and "Pose u" to add definitions to local context - Pattern now working on partially applied subterms - Ring no longer applies irreversible congruence laws of mult but better applies congruence laws of plus (slight source of incompatibilities). - Field now accepts terms to be simplified as arguments (as for Ring). This extension has been also implemented using the toplevel tactic language. - Intuition does no longer unfold constants except "<->" and "~". It can be parameterized by a tactic. It also can introduce dependent product if needed (source of incompatibilities) - "Match Context" now matching more recent hypotheses first and failing only on user errors and Fail tactic (possible source of incompatibilities) - Tactic Definition's without arguments now allowed in Coq states - Better simplification and discrimination made by Inversion (source of incompatibilities) Bugs - "Intros H" now working like "Intro H" trying first to reduce if not a product - Forward dependencies in Cases now taken into account - Known bugs related to Inversion and let-in's fixed - Bug unexpected Delta with let-in now fixed Extraction (details in plugins/extraction/CHANGES or documentation) - Signatures of extracted terms are now mostly expunged from dummy arguments. - Haskell extraction is now operational (tested & debugged). Standard library - Some additions in [ZArith]: three files (Zcomplements.v, Zpower.v and Zlogarithms.v) moved from plugins/omega in order to be more visible, one Zsgn function, more induction principles (Wf_Z.v and tail of Zcomplements.v), one more general Euclid theorem - Peano_dec.v and Compare_dec.v now part of Arith.v Tools - new option -dump-glob to coqtop to dump globalizations (to be used by the new documentation tool coqdoc; see http://www.lri.fr/~filliatr/coqdoc) User Contributions - CongruenceClosure (congruence closure decision procedure) [Pierre Corbineau, ENS Cachan] - MapleMode (an interface to embed Maple simplification procedures over rational fractions in Coq) [David Delahaye, Micaela Mayero, Chalmers University] - Presburger: A formalization of Presburger's algorithm [Laurent Thery, INRIA Sophia Antipolis] - Chinese has been rewritten using Z from ZArith as datatype ZChinese is the new version, Chinese the obsolete one [Pierre Letouzey, LRI Orsay] Incompatibilities - Ring: exceptional incompatibilities (1 above 650 in submitted user contribs, leading to a simplification) - Intuition: does not unfold any definition except "<->" and "~" - Cases: removal of some extra Cases in configurations of the form "Cases ... of C _ => ... | _ D => ..." (effects on 2 definitions of submitted user contributions necessitating the removal of now superfluous proof steps in 3 different proofs) - Match Context, in case of incompatibilities because of a now non trapped error (e.g. Not_found or Failure), use instead tactic Fail to force Match Context trying the next clause - Inversion: better simplification and discrimination may occasionally lead to less subgoals and/or hypotheses and different naming of hypotheses - Unification done by Apply/Elim has been changed and may exceptionally lead to incompatible instantiations - Peano_dec.v and Compare_dec.v parts of Arith.v make Auto more powerful if these files were not already required (1 occurrence of this in submitted user contribs) Changes from V7.1 to V7.2 ========================= Language - Automatic insertion of patterns for local definitions in the type of the constructors of an inductive types (for compatibility with V6.3 let-in style) - Coercions allowed in Cases patterns - New declaration "Canonical Structure id = t : I" to help resolution of equations of the form (proj ?)=a; if proj(e)=a then a is canonically equipped with the remaining fields in e, i.e. ? is instantiated by e Tactics - New tactic "ClearBody H" to clear the body of definitions in local context - New tactic "Assert H := c" for forward reasoning - Slight improvement in naming strategy for NewInduction/NewDestruct - Intuition/Tauto do not perform useless unfolding and work up to conversion Extraction (details in plugins/extraction/CHANGES or documentation) - Syntax changes: there are no more options inside the extraction commands. New commands for customization and options have been introduced instead. - More optimizations on extracted code. - Extraction tests are now embedded in 14 user contributions. Standard library - In [Relations], Rstar.v and Newman.v now axiom-free. - In [Sets], Integers.v now based on nat - In [Arith], more lemmas in Min.v, new file Max.v, tail-recursive plus and mult added to Plus.v and Mult.v respectively - New directory [Sorting] with a proof of heapsort (dragged from 6.3.1 lib) - In [Reals], more lemmas in Rbase.v, new lemmas on square, square root and trigonometric functions (R_sqr.v - Rtrigo.v); a complementary approach and new theorems about continuity and derivability in Ranalysis.v; some properties in plane geometry such as translation, rotation or similarity in Rgeom.v; finite sums and Chasles property in Rsigma.v Bugs - Confusion between implicit args of locals and globals of same base name fixed - Various incompatibilities wrt inference of "?" in V6.3.1 fixed - Implicits in infix section variables bug fixed - Known coercions bugs fixed - Apply "universe anomaly" bug fixed - NatRing now working - "Discriminate 1", "Injection 1", "Simplify_eq 1" now working - NewInduction bugs with let-in and recursively dependent hypotheses fixed - Syntax [x:=t:T]u now allowed as mentioned in documentation - Bug with recursive inductive types involving let-in fixed - Known pattern-matching bugs fixed - Known Cases elimination predicate bugs fixed - Improved errors messages for pattern-matching and projections - Better error messages for ill-typed Cases expressions Incompatibilities - New naming strategy for NewInduction/NewDestruct may affect 7.1 compatibility - Extra parentheses may exceptionally be needed in tactic definitions. - Coq extensions written in Ocaml need to be updated (see dev/changements.txt for a description of the main changes in the interface files of V7.2) - New behaviour of Intuition/Tauto may exceptionally lead to incompatibilities ---------------------------------------------------------------------------- Changes from V6.3.1 and V7.0 to V7.1 ==================================== Notes: - items followed by (**) are important sources of incompatibilities - items followed by (*) may exceptionally be sources of incompatibilities - items followed by (+) have been introduced in version 7.0 Main novelties ============== References are to Coq V7.1 reference manual - New primitive let-in construct (see sections 1.2.8 and ) - Long names (see sections 2.6 and 2.7) - New high-level tactic language (see chapter 10) - Improved search facilities (see section 5.2) - New extraction algorithm managing the Type level (see chapter 17) - New rewriting tactic for arbitrary equalities (see chapter 19) - New tactic Field to decide equalities on commutative fields (see 7.11) - New tactic Fourier to solve linear inequalities on reals numbers (see 7.11) - New tactics for induction/case analysis in "natural" style (see 7.7) - Deep restructuration of the code (safer, simpler and more efficient) - Export of theories to XML for publishing and rendering purposes (see http://www.cs.unibo.it/helm) Details of changes ================== Language: new "let-in" construction ----------------------------------- - New construction for local definitions (let-in) with syntax [x:=u]t (*)(+) - Local definitions allowed in Record (a.k.a. record à la Randy Pollack) Language: long names -------------------- - Each construction has a unique absolute names built from a base name, the name of the module in which they are defined (Top if in coqtop), and possibly an arbitrary long sequence of directory (e.g. "Coq.Lists.PolyList.flat_map" where "Coq" means that "flat_map" is part of Coq standard library, "Lists" means it is defined in the Lists library and "PolyList" means it is in the file Polylist) (+) - Constructions can be referred by their base name, or, in case of conflict, by a "qualified" name, where the base name is prefixed by the module name (and possibly by a directory name, and so on). A fully qualified name is an absolute name which always refer to the construction it denotes (to preserve the visibility of all constructions, no conflict is allowed for an absolute name) (+) - Long names are available for modules with the possibility of using the directory name as a component of the module full name (with option -R to coqtop and coqc, or command Add LoadPath) (+) - Improved conflict resolution strategy (the Unix PATH model), allowing more constructions to be referred just by their base name Language: miscellaneous ----------------------- - The names of variables for Record projections _and_ for induction principles (e.g. sum_ind) is now based on the first letter of their type (main source of incompatibility) (**)(+) - Most typing errors have now a precise location in the source (+) - Slightly different mechanism to solve "?" (*)(+) - More arguments may be considered implicit at section closing (*)(+) - Bug with identifiers ended by a number greater than 2^30 fixed (+) - New visibility discipline for Remark, Fact and Local: Remark's and Fact's now survive at the end of section, but are only accessible using a qualified names as soon as their strength expires; Local's disappear and are moved into local definitions for each construction persistent at section closing Language: Cases --------------- - Cases no longer considers aliases inferable from dependencies in types (*)(+) - A redundant clause in Cases is now an error (*) Reduction --------- - New reduction flags "Zeta" and "Evar" in Eval Compute, for inlining of local definitions and instantiation of existential variables - Delta reduction flag does not perform Zeta and Evar reduction any more (*) - Constants declared as opaque (using Qed) can no longer become transparent (a constant intended to be alternatively opaque and transparent must be declared as transparent (using Defined)); a risk exists (until next Coq version) that Simpl and Hnf reduces opaque constants (*) New tactics ----------- - New set of tactics to deal with types equipped with specific equalities (a.k.a. Setoids, e.g. nat equipped with eq_nat) [by C. Renard] - New tactic Assert, similar to Cut but expected to be more user-friendly - New tactic NewDestruct and NewInduction intended to replace Elim and Induction, Case and Destruct in a more user-friendly way (see restrictions in the reference manual) - New tactic ROmega: an experimental alternative (based on reflexion) to Omega [by P. CrÃĐgut] - New tactic language Ltac (see reference manual) (+) - New versions of Tauto and Intuition, fully rewritten in the new Ltac language; they run faster and produce more compact proofs; Tauto is fully compatible but, in exchange of a better uniformity, Intuition is slightly weaker (then use Tauto instead) (**)(+) - New tactic Field to decide equalities on commutative fields (as a special case, it works on real numbers) (+) - New tactic Fourier to solve linear inequalities on reals numbers [by L. Pottier] (+) - New tactics dedicated to real numbers: DiscrR, SplitRmult, SplitAbsolu (+) Changes in existing tactics --------------------------- - Reduction tactics in local definitions apply only to the body - New syntax of the form "Compute in Type of H." to require a reduction on the types of local definitions - Inversion, Injection, Discriminate, ... apply also on the quantified premises of a goal (using the "Intros until" syntax) - Decompose has been fixed but hypotheses may get different names (*)(+) - Tauto now manages uniformly hypotheses and conclusions of the form "t=t" which all are considered equivalent to "True". Especially, Tauto now solves goals of the form "H : ~ t = t |- A". - The "Let" tactic has been renamed "LetTac" and is now based on the primitive "let-in" (+) - Elim can no longer be used with an elimination schema different from the one defined at definition time of the inductive type. To overload an elimination schema, use "Elim using " (*)(+) - Simpl no longer unfolds the recursive calls of a mutually defined fixpoint (*)(+) - Intro now fails if the hypothesis name already exists (*)(+) - "Require Prolog" is no longer needed (i.e. it is available by default) (*)(+) - Unfold now fails on a non unfoldable identifier (*)(+) - Unfold also applies on definitions of the local context - AutoRewrite now deals only with the main goal and it is the purpose of Hint Rewrite to deal with generated subgoals (+) - Redundant or incompatible instantiations in Apply ... with ... are now correctly managed (+) Efficiency ---------- - Excessive memory uses specific to V7.0 fixed - Sizes of .vo files vary a lot compared to V6.3 (from -30% to +300% depending on the developments) - An improved reduction strategy for lazy evaluation - A more economical mechanism to ensure logical consistency at the Type level; warning: this is experimental and may produce "universes" anomalies (please report) Concrete syntax of constructions -------------------------------- - Only identifiers starting with "_" or a letter, and followed by letters, digits, "_" or "'" are allowed (e.g. "$" and "@" are no longer allowed) (*) - A multiple binder like (a:A)(a,b:(P a))(Q a) is no longer parsed as (a:A)(a0:(P a))(b:(P a))(Q a0) but as (a:A)(a0:(P a))(b:(P a0))(Q a0) (*)(+) - A dedicated syntax has been introduced for Reals (e.g ``3+1/x``) (+) - Pretty-printing of Infix notations fixed. (+) Parsing and grammar extension ----------------------------- - More constraints when writing ast - "{...}" and the macros $LIST, $VAR, etc. now expect a metavariable (an identifier starting with $) (*) - identifiers should starts with a letter or "_" and be followed by letters, digits, "_" or "'" (other characters are still supported but it is not advised to use them) (*)(+) - Entry "command" in "Grammar" and quotations (<<...>> stuff) is renamed "constr" as in "Syntax" (+) - New syntax "[" sentence_1 ... sentence_n"]." to group sentences (useful for Time and to write grammar rules abbreviating several commands) (+) - The default parser for actions in the grammar rules (and for patterns in the pretty-printing rules) is now the one associated to the grammar (i.e. vernac, tactic or constr); no need then for quotations as in <:vernac:<...>>; to return an "ast", the grammar must be explicitly typed with tag ": ast" or ": ast list", or if a syntax rule, by using <<...>> in the patterns (expression inside these angle brackets are parsed as "ast"); for grammars other than vernac, tactic or constr, you may explicitly type the action with tags ": constr", ": tactic", or ":vernac" (**)(+) - Interpretation of names in Grammar rule is now based on long names, which allows to avoid problems (or sometimes tricks;) related to overloaded names (+) New commands ------------ - New commands "Print XML All", "Show XML Proof", ... to show or export theories to XML to be used with Helm's publishing and rendering tools (see http://www.cs.unibo.it/helm) (by Claudio Sacerdoti Coen) (+) - New commands to manually set implicit arguments (+) - "Implicits ident." to activate the implicit arguments mode just for ident - "Implicits ident [num1 num2 ...]." to explicitly give which arguments have to be considered as implicit - New SearchPattern/SearchRewrite (by Yves Bertot) (+) - New commands "Debug on"/"Debug off" to activate/deactivate the tactic language debugger (+) - New commands to map physical paths to logical paths (+) - Add LoadPath physical_dir as logical_dir - Add Rec LoadPath physical_dir as logical_dir Changes in existing commands ---------------------------- - Generalization of the usage of qualified identifiers in tactics and commands about globals, e.g. Decompose, Eval Delta; Hints Unfold, Transparent, Require - Require synchronous with Reset; Require's scope stops at Section ending (*) - For a module indirectly loaded by a "Require" but not exported, the command "Import module" turns the constructions defined in the module accessible by their short name, and activates the Grammar, Syntax, Hint, ... declared in the module (+) - The scope of the "Search" command can be restricted to some modules (+) - Final dot in command (full stop/period) must be followed by a blank (newline, tabulation or whitespace) (+) - Slight restriction of the syntax for Cbv Delta: if present, option [-myconst] must immediately follow the Delta keyword (*)(+) - SearchIsos currently not supported - Add ML Path is now implied by Add LoadPath (+) - New names for the following commands (+) AddPath -> Add LoadPath Print LoadPath -> Print LoadPath DelPath -> Remove LoadPath AddRecPath -> Add Rec LoadPath Print Path -> Print Coercion Paths Implicit Arguments On -> Set Implicit Arguments Implicit Arguments Off -> Unset Implicit Arguments Begin Silent -> Set Silent End Silent -> Unset Silent. Tools ----- - coqtop (+) - Two executables: coqtop.byte and coqtop.opt (if supported by the platform) - coqtop is a link to the more efficient executable (coqtop.opt if present) - option -full is obsolete (+) - do_Makefile renamed into coq_makefile (+) - New option -R to coqtop and coqc to map a physical directory to a logical one (+) - coqc no longer needs to create a temporary file - No more warning if no initialization file .coqrc exists Extraction ---------- - New algorithm for extraction able to deal with "Type" (+) (by J.-C. FilliÃĒtre and P. Letouzey) Standard library ---------------- - New library on maps on integers (IntMap, contributed by Jean Goubault) - New lemmas about integer numbers [ZArith] - New lemmas and a "natural" syntax for reals [Reals] (+) - Exc/Error/Value renamed into Option/Some/None (*) New user contributions ---------------------- - Constructive complex analysis and the Fundamental Theorem of Algebra [FTA] (Herman Geuvers, Freek Wiedijk, Jan Zwanenburg, Randy Pollack, Henk Barendregt, Nijmegen) - A new axiomatization of ZFC set theory [Functions_in_ZFC] (C. Simpson, Sophia-Antipolis) - Basic notions of graph theory [GRAPHS-BASICS] (Jean Duprat, Lyon) - A library for floating-point numbers [Float] (Laurent ThÃĐry, Sylvie Boldo, Sophia-Antipolis) - Formalisation of CTL and TCTL temporal logic [CtlTctl] (Carlos Daniel Luna,Montevideo) - Specification and verification of the Railroad Crossing Problem in CTL and TCTL [RailroadCrossing] (Carlos Daniel Luna,Montevideo) - P-automaton and the ABR algorithm [PAutomata] (Christine Paulin, Emmanuel Freund, Orsay) - Semantics of a subset of the C language [MiniC] (Eduardo GimÃĐnez, Emmanuel Ledinot, Suresnes) - Correctness proofs of the following imperative algorithms: Bresenham line drawing algorithm [Bresenham], MarchÃĐ's minimal edition distance algorithm [Diff] (Jean-Christophe FilliÃĒtre, Orsay) - Correctness proofs of Buchberger's algorithm [Buchberger] and RSA cryptographic algorithm [Rsa] (Laurent ThÃĐry, Sophia-Antipolis) - Correctness proof of Stalmarck tautology checker algorithm [Stalmarck] (Laurent ThÃĐry, Pierre Letouzey, Sophia-Antipolis) LocalWords: recommended coq-8.4pl4/config/0000755000175000017500000000000012365131026013063 5ustar stephstephcoq-8.4pl4/config/coq_config.mli0000644000175000017500000000537312326224777015722 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 && is_word_char c then ( ignore (it#nocopy#forward_char); step_to_end it ) else ( prerr_endline ("Word end at: "^(string_of_int it#offset)); it) in step_to_end it#copy let get_word_around (it:GText.iter) = let start = find_word_start it in let stop = find_word_end it in start,stop let rec complete_backward w (it:GText.iter) = prerr_endline "Complete backward..."; match it#backward_search w with | None -> (prerr_endline "backward_search failed";None) | Some (start,stop) -> prerr_endline ("complete_backward got a match:"^(string_of_int start#offset)^(string_of_int stop#offset)); if starts_word start then let ne = find_word_end stop in if ne#compare stop = 0 then complete_backward w start else Some (start,stop,ne) else complete_backward w start let rec complete_forward w (it:GText.iter) = prerr_endline "Complete forward..."; match it#forward_search w with | None -> None | Some (start,stop) -> if starts_word start then let ne = find_word_end stop in if ne#compare stop = 0 then complete_forward w stop else Some (stop,stop,ne) else complete_forward w stop let find_comment_end (start:GText.iter) = let rec find_nested_comment (search_start:GText.iter) (search_end:GText.iter) (comment_end:GText.iter) = match (search_start#forward_search ~limit:search_end "(*"),(comment_end#forward_search "*)") with | None,_ -> comment_end | Some _, None -> raise Not_found | Some (_,next_search_start),Some (next_search_end,next_comment_end) -> find_nested_comment next_search_start next_search_end next_comment_end in match start#forward_search "*)" with | None -> raise Not_found | Some (search_end,comment_end) -> find_nested_comment start search_end comment_end let rec find_string_end (start:GText.iter) = let dblquote = int_of_char '"' in let rec escaped_dblquote c = (c#char = dblquote) && not (escaped_dblquote c#backward_char) in match start#forward_search "\"" with | None -> raise Not_found | Some (stop,next_start) -> if escaped_dblquote stop#backward_char then find_string_end next_start else next_start let rec find_next_sentence (from:GText.iter) = match (from#forward_search ".") with | None -> raise Not_found | Some (non_vernac_search_end,next_sentence) -> match from#forward_search ~limit:non_vernac_search_end "(*",from#forward_search ~limit:non_vernac_search_end "\"" with | None,None -> if Glib.Unichar.isspace next_sentence#char || next_sentence#compare next_sentence#forward_char == 0 then next_sentence else find_next_sentence next_sentence | None,Some (_,string_search_start) -> find_next_sentence (find_string_end string_search_start) | Some (_,comment_search_start),None -> find_next_sentence (find_comment_end comment_search_start) | Some (_,comment_search_start),Some (_,string_search_start) -> find_next_sentence ( if comment_search_start#compare string_search_start < 0 then find_comment_end comment_search_start else find_string_end string_search_start) let find_nearest_forward (cursor:GText.iter) targets = let fold_targets acc target = match cursor#forward_search target,acc with | Some (t_start,_),Some nearest when (t_start#compare nearest < 0) -> Some t_start | Some (t_start,_),None -> Some t_start | _ -> acc in match List.fold_left fold_targets None targets with | None -> raise Not_found | Some nearest -> nearest let find_nearest_backward (cursor:GText.iter) targets = let fold_targets acc target = match cursor#backward_search target,acc with | Some (t_start,_),Some nearest when (t_start#compare nearest > 0) -> Some t_start | Some (t_start,_),None -> Some t_start | _ -> acc in match List.fold_left fold_targets None targets with | None -> raise Not_found | Some nearest -> nearest coq-8.4pl4/ide/coqide_main.ml40000644000175000017500000001134312326224777015264 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 in if level_is `ERROR then let () = GToolbox.message_box ~title:"Error" (header ^ msg) in Coqide.crash_save 1 else if level_is `CRITICAL then GToolbox.message_box ~title:"Error" (header ^ msg) else if level_is `DEBUG || Sys.os_type = "Win32" then Ideutils.prerr_endline msg (* no-op unless in debug mode *) else Printf.eprintf "%s\n" msg in let catch domain = ignore (Glib.Message.set_log_handler ~domain ~levels:all_levels handler) in List.iter catch ["GLib";"Gtk";"Gdk";"Pango"] let () = catch_gtk_messages () (* We anticipate a bit the argument parsing and look for -debug *) let early_set_debug () = Ideutils.debug := List.mem "-debug" (Array.to_list Sys.argv) (* On win32, we add the directory of coqide to the PATH at launch-time (this used to be done in a .bat script). *) let set_win32_path () = Unix.putenv "PATH" (Filename.dirname Sys.executable_name ^ ";" ^ (try Sys.getenv "PATH" with _ -> "")) (* On win32, in debug mode we duplicate stdout/stderr in a log file. *) let log_stdout_stderr () = let (name,chan) = Filename.open_temp_file "coqide_" ".log" in Coqide.logfile := Some name; let out_descr = Unix.descr_of_out_channel chan in Unix.set_close_on_exec out_descr; Unix.dup2 out_descr Unix.stdout; Unix.dup2 out_descr Unix.stderr (* We also provide specific kill and interrupt functions. *) IFDEF WIN32 THEN external win32_kill : int -> unit = "win32_kill" external win32_interrupt_all : unit -> unit = "win32_interrupt_all" external win32_hide_console : unit -> unit = "win32_hide_console" let () = set_win32_path (); Coq.killer := win32_kill; Coq.interrupter := (fun pid -> win32_interrupt_all ()); early_set_debug (); if !Ideutils.debug then log_stdout_stderr () else win32_hide_console () END IFDEF QUARTZ THEN let osx = GosxApplication.osxapplication () let _ = osx#connect#ns_application_open_file ~callback:(fun x -> Coqide.do_load x; true) in let _ = osx#connect#ns_application_block_termination ~callback:Coqide.forbid_quit_to_save in () END let () = (try let gtkrcdir = List.find (fun x -> Sys.file_exists (Filename.concat x "coqide-gtk2rc")) Minilib.xdg_config_dirs in GtkMain.Rc.add_default_file (Filename.concat gtkrcdir "coqide-gtk2rc"); with Not_found -> ()); (* Statup preferences *) begin try Preferences.load_pref () with e -> Ideutils.flash_info ("Could not load preferences ("^Printexc.to_string e^")."); end; (* GtkData.AccelGroup.set_default_mod_mask (Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]);*) let argl = Array.to_list Sys.argv in let argl = Coqide.read_coqide_args argl in let files = Coq.filter_coq_opts (List.tl argl) in let args = List.filter (fun x -> not (List.mem x files)) (List.tl argl) in Coq.check_connection args; Coqide.sup_args := args; Coqide.main files; if !Coq_config.with_geoproof then ignore (Thread.create Coqide.check_for_geoproof_input ()) IFDEF QUARTZ THEN let () = GtkosxApplication.Application.set_menu_bar osx#as_osxapplication (GtkMenu.MenuShell.cast (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar")#as_widget) in let () = GtkosxApplication.Application.insert_app_menu_item osx#as_osxapplication (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs")#as_widget 1 in let () = GtkosxApplication.Application.set_help_menu osx#as_osxapplication (Some (GtkMenu.MenuItem.cast (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help")#as_widget)) in osx#ready () END while true do try GtkThread.main () with | Sys.Break -> Ideutils.prerr_endline "Interrupted." | e -> Minilib.safe_prerr_endline ("CoqIde unexpected error:" ^ (Printexc.to_string e)); Coqide.crash_save 127 done coq-8.4pl4/ide/coq.png0000644000175000017500000001417512326224777013674 0ustar stephsteph‰PNG  IHDRBd2ĄæÃbKGDB‘ænČ%Ü pHYsÄÄ•+tIMEŨ7:Œ/u• IDATxÚí]yWyĸ}Ŋ{îÝŲ{WZIŧŌęķ|ČVl _2ķ°MA6‘ĮP€‰Ē(§pĐTRÁ8„J ĐĒBŽœ ÅaLąe|!Ëō!!Ë:­cĨ]iĨ―ĩšŧũåyÝÓÓÛģŧZ ­ ˜­§™™îíũ{ŋïþ^ øý@ø\üŧų†Pƒ&ÏĪėŋÕ@8ŨvĖ}`ÝŠøēŽöšeÉp‡!íeK!%ƒaÛlnÞÛ{üÔāh~Ûö=9Ķûb„Î!H{üŅ?­ŧšģaYŦmÜ&û:&Ūíė;–ÅÔoÛ4rp$ûģïnŲóöëÛßąm™PP 8Lų­‚h7Ū―$úW7\Ÿ$ãē kY§0‰ÉÏÅL ÅfÖĀū·š~ôßĸåãéÜ€ŽĚm0Ķ„ ýįß|ēcU}ôÁÅ{YaĻâhŠr.öPŸ™a"{b4ũâ—øŦ§>Þ  įaĮŽ<īĐ@Xsųēðĸ<~ĸDņ$4ëÖD‚ĐĄ@ Āx^ÂõņÐâås[/ė:ÜkZķåaÄŽéŒÉ€W]ķ4üõ‡ïڐāÂßģŽ$Ôī…š ú4É9|QАhŒ…Ú›››Œ­{š˜]%j_l@ýŋŋpĸĩI*>%u4OXáŌäQšĻšžoļ†Púné€"īļąvŅņīqühßÐÅŲCTSŒĸþå‡į5ęöãŽqģG„ŧúFš*û†OD”0đĮ’uŧfÅ-ÚÔˆŠÅĄ‹ˆKW. _ސø,köj䙥3‡BģÁÝaRÎȗ Á ī <Ū@Ð/?‚õ ŸķY WĪTžēÍL‰ $Wō!˜ÎųE€ų=‡ęų7ũŒYũUĀĀÕebR v†+ėOÝY[EÃēg3'|%;YΚo‘dY~ŋL Gļk;’lķHōD0ĘĮc0](>>žÍ(ÔÏiYķųĖŧG_ą >Đ.R+Ēsîïš(r,|š“ņ~Ū‹ŸĘD#GŋþóÃïCōÆCgrYÓī ģx‰€$Ŧųŋ?ÛrâížŅï‘Åũýē? ĶÃåcˆlÄÂ)NÆF eŌ Öu#Z- ĪsC_}öõcųœ•ņZ2’í­N ›–W`\ð|æF°l)óûôæWwžĸLY€ôĻ:鐎5ĩ-ņ(<&M rÓš•ÅÞūĄĄîáô€OG0äóVaˁž!i•š+*đ ŒĻ–āBŅā-{žZÜ>‡į&c 4ĒŪ·Í hÂäÚØtaéá˜Æ,A$ 4 ,mĶ’:Ąšd"ĸŌ›Įį5$ų’ÎĶųŪûÅIČWũôüÉkïpĀIĢŠT<&ËPąa˜ōå]‡OŽēQSCc2j€ Aš  I„ī@Rh!ÁŌ.QXZRƒĢ?nKDC—t4uļ‘*ƒs#ó•g·KS@ ĻfņBį/'B°%ģu §?õúÁūãWtÍoimˆ-Ð&…u€ˆ˜Q”ķ -Ņˆlģ ī>1DžŊ{(Ē…+ŧZ; TÖÛbã;[öwŋļãĀAfpĀ0€L@V›Ķ9ÎkbÆÕŠĒg ķÏmn[ŌFZsM„ 4€a9Û2ō2ĀQ‚”Ž―īŋwØ.Ę ‹ÍWö<öƒ-ŧHɧô8­ēŲŽ~pŠgŽĮéļāQψxÜr]å2ô)a(|rãíÚw]ų‘x˜W”")lIĪđ$ËĒ”’ĩCĖ“íËčSOß`æ―Ątũ%s“ËßėÚĸԏ^Ý=žÎ +& *‘(ĻŋKšŪë·^ŋ&šņoœgųDūhh–e [Jw’E“gžÛ6œÉæĖžCÅ|Ąā˜^§’6mŸDŸ*†xę‹Æn[ŧð1inf–‘°@–e[’‘HŽĄY1ķ5HÖMĸ‰ Ã4þõ§[_YĩxþÏūþî@:“/*ķõ+‘Č°5Mˆ/=úņšuWŪļž>Ž[IK­6Ø-§Âu—Ý;ÂŲÁąü·vũ|î՝'öėWzÆĀ4ˋSÛŨ-š\ēœcØôޙqCūōöáSGOŅþâŨ/ Č$•XL%Wƒ,ŌdČŊæĻĪ/ŒGúNė<Ō7æđČ4€1õlŪXŌĄí‰MW4'õûØÎ/‡%ã’y2ŠģNh%4iŦ;n]–šeíĒ#š·ĸÛÓ/ė>ÚÛïˆ[ŅS@â™AŨÝĸäÛɚøc™\ĄĨP4ڊEģeŒ Ņ–ĩ 09'—Â䀊ąšŒZýīg˜Ÿų“ ņmXŧ>Ķc+ŨÆ\ Å <Đž—ü{0-3RGÓĩ—·_šä‰ûvëûŋÚüÜ+;Ž)æåøfyJŅHgō2Éį• €BĸÐéĖHŠ°ļĨNoõ8I,Ĩ^ŽR%aGßxXāÖ<yāΚûïšæAaįo—–]SŌÃ,Ķa˜*Ģ f1Ûɖ:}íįîŋ1iæs/―þîAåŸd|žëôðLę$ĐÔxvėÄ`j_k]KCƜ‹˜DÏlu'Ū5ņHčĢw\}Ųų;ĪīkjðtĖĒĮS%ÅNffĶ†måĢ›nĶe‡ķžĩwŋĮ°_LÄ4þˆT”Ę*ŠÞß=žWBŒ–OHÓŅÎM#‚H|ë+Ÿ[ÓŽ{XÚ ‚VRū^@ UūÏX hhÄ2ŌRZþųŨßÚÞÖīH• âAɟéRĪZIS­b@æ™įÞ8|b(ŧ„–f]ú[LŸ{čÃĩ‹Ûk?.mĢÝÃĸäÅ$C ø]ĻD‹9Ô\é\ŧzé%ZÔÕNīģð9*čŸÉæ°uĮĄáh<)ŧæ7ĩiQ*+"‡!DöžÃƒđûŽTþ€üŌŋīĮÞp‡ŽÂÝĖ2Jj%+'X…ęŠęŦ€P5ōˆŠSIГÉZúųË;ûģó~+2ÓŌš 00<6ōßĸåÛ#ĐB/’+õDéB™õũ]Ų5Îļfy2ŠÛ`iĮÝÕ+éũ5•@˜Œ‚< ķ”†hkLÔ75$įĻSŲō ņ˜ ^―‘,öPÉzę5D^X oļyÍ$ͅΊWN€ÝÕĶ)ęhTŠË‹rý‰)(>imŒ‡įīÔ·Hú€ sa„ŨšŒ‡BĄ1"’šÜuą=ŒÐįÏm‰6$ÄfŦÖ3ų Éے›"ßĘWēÄð֙*JRåó1G—wĩ'U5-ę‰Kp.@xÁ(îî&n6k‚OÅp€Ðčķņö…QW—œ&Š ɝ ï― QĨXā9Žpdnk}TYĻŸú9!XBˆ‚2ŸUėˆˆ4fÖč+6­€īš1Qá9bTĒ)üˆÉ+' H[ęūhõž0Â5Ŋ!]ģQýâĐĢ­ž:æĩ&čąh$Z—/f–aïäýĮųWĩŌ\Ė° ĨU ŨÏKCF,ņ$1A,ŠkŅH( žtQ{c2ę ð'<Óy.ōpŲ*‰™8TS:FK;›ƒeÔģÂūŌĩ€Č•Ŧĩ ’õ>OwöŅ~ÃuŊs‚îžum4Öší<Ï™—ąŦ/ïŌÄŨŽę\B5^!@˗C58ĩ“ië­āũvŪ`ÚAqÆđAÄ+6h$įûĻ^Isf­đĄ6EęZsUÁß-Ŋ>3A:~ĩē+Ęģ>/˜b†ČĸzÏ1Q-suN@$âQý†kV\C°Ú|ώh°jAüækŊčœßZÓŽÂlšÂ$–ŠjSƒ1ÅZyēōĶe`bSüô2T“üíŸūôPG2"Ũģ-cn2—Þ#˜;Újk?ŧņý8Á\`‘Ã&§k“=90$1€Ãó^ TŲž) Ór2cĶ?}§Ï„ŧŨŊ­đtIëG ó]*ė%Oäč@ 0Ûņú„efA•aķpŲKTŦï[(ŒIrâŅÛÆ:~rțËī―%}Ķ <ēéƒÔļx3‡+“)ޕ&·šŪĘ[äų\óƒāø% Čr~ĢTe ƒĘžŽ›Ēb? 0™ÛũôHäƒRvúY@ī'þ|cӝ7ŽØDēpKŧū {rĨ@ŠÝō„ģ@äˆÎT xvûpú \0\Ņs \Ýz, ãÐąž ÁsA…f}š&VÜ|ýÚČCũ^·īk^ōĢ$óŨē”ąĘŒRĪ.|Å!ŧœõrZ&€á*fŸ~`+Âļ`؅#=@þBģ>•yœÓÖzôÁ5ŋĸŠŪ……qÛųųĖŽŦDŠĻ‚ÓŒĘäöļé15äY-åÂWÓÕrï‘A{`dlL%o ät€‚Hûŧ/~šiÝeóŊëÆ­đ•Ō’QO†đ*j’JÓAT‚1-$—~gō0ÂFđ8_ĄĪW?Øųķîģ,ËNũQ5‹MÄŠĨóBO=ņÐUÍĩÚýŌÎ,‡mĮK&―™ 1 îōûĀðû €Č ŌSÃcŲps]4Já*`Ĩ Ęi<Ëį·ïîSåˆqO}uRFÐg6ÝûÄÝkïŅdþĢŌ*6y -þ䊘„ŠþT’ĻÂDzAŠ ÖŅ“Đü7ŋũj"W4ē?|{vq{m3y@ð€Ą9ŒðęįÜ$DaóÖýÆčXjD™úŠ9™‹MkV_Šßwįڛ5™ŧOÚf 3tkäĶɧ‚'Œ.'ZÉõ‘ß'b<8šąũôõõôþø…w%D†]KBė}æęlāS#Ųüæ-ŧ3ĖU@8ķI •Óåô7š€D#áķ{ïX·üþ;Ŋ^YŸÐÚ ŽOT_ūtcŠēķ·’ĐŽYHÄ–.8áą$DR-sb`œ{ûĮŠ?ÚžĢðÎÞĢ#EÃQ“TcXĩd‚B홁ĘÞ—! ZnđîŠ_xhýÚšļčœ UuÃÄ Ë‰"Hä‰Āķ ŧ4ãæ$zNŽ{O―·Gė?ܗJĨģãĖ<Ū&<Š”áĻŠ#Ōž ”<‹Ķ•iõPyÝWoT@æåmŧӑpĻðØĶ›nŠRG•āČcũý hđ_l=TüŋWwDbœ™Įŧ{ÆLË*`ÓēĨiZĶš\^­öļōˆ2ëKÁg“Š ÄPdæÂóŋÚiŪX<7zï-ŦęY_™Š'oïHLdí;:\øæw6gRéŽÓQs•Û\Å­&›ó ï-ZŽ™0Óäm ķ”’ŸþÉk;nY·|UCH2ŦÝā. ÄþãKYYĘ=óÂ;F*íSÚūÏÓčŽŪ ïģ5Sœ+~@œļžFÆÆûû†Ō‡ëkęWúÏ[ŪݕCd&’{NķîxoTiú^eöN{ž@;(žĀÄ[9óC?ĮãÝÞI)eÆŽiīSZŽQ°­SĐuX0X0 Ĩr†˜HŽįøŌ–3éLnHFýĘö§<ĘN5ēá7°ĄE?į`v(Ī›ņhh’frę7Ė Ι\ØõîÁӊ#(ũdįqėéšņcþÜfŅÐX{™b„ė:WZd>Ņ; SéėļŌú)Ĩ ó%óģ}jӇį”Šâî6Ņ*―MĨâTû‚6Ô%–Gó; ĖĘãž4ŠŽūlyxŲËïÐĪŅFnG=ÃÛꗙFšŪi(įfũöKįÜ(@{xÓݝ!ÍūU°Ô“YîyŽl[pŒ°FzGgŧsŊˆj7üû­B<ôĮëkįwÍŲĻۅyIÄŽšd˜ĘŽ; ļYĻ°Æ‘ĩŨ\ڄōþ,}6Á8 ÄęUK"wþŅúé\ž“؁ŲÛŽ˜áeˆÛüIÄRŋzÍēđ—,혃RĢļũŽC íD"ôĩ'ŧ:ž=ŪۅšRýĢÔ C`Ï3‚Û& ˆ„DĻkÅŌțoė>^(ãwų‚ï ŨfŠūņŸïh›Ũü—!+ŨE`J Ē ‚Û:<Áx°ÛFÏT_—Ļ­­Ŧ7ķïØßÏĖÞ―áōbBÜvÃęØú Ũ?ēs7 8^$ Ą€@Ē\rM){îį„r’B›3Ŋ­~x(5tŽ·īZ#ĮÅĶ#HĄ}ęӟX+ØļƒØÖ―zÁ™ĄPzÁWĨv-‰p)ƒˆ™!nXwÝęUZPecÉED]mBÄõŧ5ÛĻ)ë&ÃŲ‘Į 0ˆý#`…KI`f2 #Ą’=ĩ*tA8ë*[Ú:KģA­hĀž˜y”ķ,;‚Ę-šRœ€l[j,ƒûŪU>rF"ĨtRÅí—Ķƒ™EÐV9y}wę–+rĢ܏˜YŸå„ //SGÓL*_@T\6ó9‚ Ķ,ČÛMwáŊ™!AB–*åš Gtk.text_view] Gtk.obj -> object inherit GText.view method undo : bool method redo : bool method clear_undo : unit end val undoable_view : ?buffer:GText.buffer -> ?editable:bool -> ?cursor_visible:bool -> ?justification:GtkEnums.justification -> ?wrap_mode:GtkEnums.wrap_mode -> ?border_width:int -> ?width:int -> ?height:int -> ?packing:(GObj.widget -> unit) -> ?show:bool -> unit -> undoable_view coq-8.4pl4/ide/coq_lex.mll0000644000175000017500000001532212326224777014537 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Hashtbl.add h s Keyword) one_word_commands; List.iter (fun s -> Hashtbl.add h s Declaration) one_word_declarations; List.iter (fun s -> Hashtbl.add h s ProofDeclaration) proof_declarations; List.iter (fun s -> Hashtbl.add h s Qed) proof_ends; List.iter (fun s -> Hashtbl.add h' s Keyword) constr_keywords; (fun initial id -> Hashtbl.find (if initial then h else h') id) exception Unterminated let here f lexbuf = f (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) } let space = [' ' '\n' '\r' '\t' '\012'] (* '\012' is form-feed *) let firstchar = ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255'] let identchar = ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] let ident = firstchar identchar* let undotted_sep = [ '{' '}' '-' '+' '*' ] let dot_sep = '.' (space | eof) let multiword_declaration = "Module" (space+ "Type")? | "Program" space+ ident | "Existing" space+ "Instance" "s"? | "Canonical" space+ "Structure" let locality = (space+ "Local")? let multiword_command = ("Uns" | "S")" et" (space+ ident)* | (("Open" | "Close") locality | "Bind" | " Delimit" ) space+ "Scope" | (("Reserved" space+)? "Notation" | "Infix") locality space+ | "Next" space+ "Obligation" | "Solve" space+ "Obligations" | "Require" space+ ("Import"|"Export")? | "Hint" locality space+ ident | "Reset" (space+ "Initial")? | "Tactic" space+ "Notation" | "Implicit" space+ "Type" "s"? | "Combined" space+ "Scheme" | "Extraction" space+ (("Language" space+ ("Ocaml"|"Haskell"|"Scheme"|"Toplevel"))| ("Library"|"Inline"|"NoInline"|"Blacklist")) | "Recursive" space+ "Extraction" (space+ "Library")? | ("Print"|"Reset") space+ "Extraction" space+ ("Inline"|"Blacklist") | "Extract" space+ (("Inlined" space+) "Constant"| "Inductive") | "Typeclasses" space+ ("eauto" | "Transparent" | "Opaque") | ("Generalizable" space+) ("All" | "No")? "Variable" "s"? (* At least still missing: "Inline" + decl, variants of "Identity Coercion", variants of Print, Add, ... *) rule coq_string = parse | "\"\"" { coq_string lexbuf } | "\"" { Lexing.lexeme_end lexbuf } | eof { Lexing.lexeme_end lexbuf } | _ { coq_string lexbuf } and comment = parse | "(*" { ignore (comment lexbuf); comment lexbuf } | "\"" { ignore (coq_string lexbuf); comment lexbuf } | "*)" { (true, Lexing.lexeme_start lexbuf + 2) } | eof { (false, Lexing.lexeme_end lexbuf) } | _ { comment lexbuf } and sentence initial stamp = parse | "(*" { let comm_start = Lexing.lexeme_start lexbuf in let trully_terminated,comm_end = comment lexbuf in stamp comm_start comm_end Comment; if not trully_terminated then raise Unterminated; (* A comment alone is a sentence. A comment in a sentence doesn't terminate the sentence. Note: comm_end is the first position _after_ the comment, as required when tagging a zone, hence the -1 to locate the ")" terminating the comment. *) if initial then comm_end - 1 else sentence false stamp lexbuf } | "\"" { let str_start = Lexing.lexeme_start lexbuf in let str_end = coq_string lexbuf in stamp str_start str_end String; sentence false stamp lexbuf } | multiword_declaration { if initial then here stamp lexbuf Declaration; sentence false stamp lexbuf } | multiword_command { if initial then here stamp lexbuf Keyword; sentence false stamp lexbuf } | ident as id { (try here stamp lexbuf (tag_of_ident initial id) with Not_found -> ()); sentence false stamp lexbuf } | ".." { (* We must have a particular rule for parsing "..", where no dot is a terminator, even if we have a blank afterwards (cf. for instance the syntax for recursive notation). This rule and the following one also allow to treat the "..." special case, where the third dot is a terminator. *) sentence false stamp lexbuf } | dot_sep { Lexing.lexeme_start lexbuf } (* The usual "." terminator *) | undotted_sep { (* Separators like { or } and bullets * - + are only active at the start of a sentence *) if initial then Lexing.lexeme_start lexbuf else sentence false stamp lexbuf } | space+ { (* Parsing spaces is the only situation preserving initiality *) sentence initial stamp lexbuf } | _ { (* Any other characters *) sentence false stamp lexbuf } | eof { raise Unterminated } { (** Parse a sentence in string [slice], tagging relevant parts with function [stamp], and returning the position of the first sentence delimitor (either "." or "{" or "}" or the end of a comment). It will raise [Unterminated] when no end of sentence is found. *) let delimit_sentence stamp slice = sentence true stamp (Lexing.from_string slice) } coq-8.4pl4/ide/project_file.ml40000644000175000017500000001725712326224777015473 0ustar stephstephtype target = | ML of string (* ML file : foo.ml -> (ML "foo.ml") *) | MLI of string (* MLI file : foo.mli -> (MLI "foo.mli") *) | ML4 of string (* ML4 file : foo.ml4 -> (ML4 "foo.ml4") *) | MLLIB of string (* MLLIB file : foo.mllib -> (MLLIB "foo.mllib") *) | MLPACK of string (* MLLIB file : foo.mlpack -> (MLLIB "foo.mlpack") *) | V of string (* V file : foo.v -> (V "foo") *) | Arg of string | Special of string * string * string (* file, dependencies, command *) | Subdir of string | Def of string * string (* X=foo -> Def ("X","foo") *) | Include of string | RInclude of string * string (* -R physicalpath logicalpath *) type install = | NoInstall | TraditionalInstall | UserInstall | UnspecInstall exception Parsing_error let rec parse_string = parser | [< '' ' | '\n' | '\t' >] -> "" | [< 'c; s >] -> (String.make 1 c)^(parse_string s) | [< >] -> "" and parse_string2 = parser | [< ''"' >] -> "" | [< 'c; s >] -> (String.make 1 c)^(parse_string2 s) and parse_skip_comment = parser | [< ''\n'; s >] -> s | [< 'c; s >] -> parse_skip_comment s | [< >] -> [< >] and parse_args = parser | [< '' ' | '\n' | '\t'; s >] -> parse_args s | [< ''#'; s >] -> parse_args (parse_skip_comment s) | [< ''"'; str = parse_string2; s >] -> ("" ^ str) :: parse_args s | [< 'c; str = parse_string; s >] -> ((String.make 1 c) ^ str) :: (parse_args s) | [< >] -> [] let parse f = let c = open_in f in let res = parse_args (Stream.of_channel c) in close_in c; res let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) l = function | [] -> opts,List.rev l | ("-h"|"--help") :: _ -> raise Parsing_error | ("-no-opt"|"-byte") :: r -> process_cmd_line orig_dir (project_file,makefile,install,false) l r | ("-full"|"-opt") :: r -> process_cmd_line orig_dir (project_file,makefile,install,true) l r | "-impredicative-set" :: r -> Minilib.safe_prerr_endline "Please now use \"-arg -impredicative-set\" instead of \"-impredicative-set\" alone to be more uniform."; process_cmd_line orig_dir opts (Arg "-impredicative-set" :: l) r | "-no-install" :: r -> Minilib.safe_prerr_endline "Option -no-install is deprecated. Use \"-install none\" instead"; process_cmd_line orig_dir (project_file,makefile,NoInstall,opt) l r | "-install" :: d :: r -> if install <> UnspecInstall then Minilib.safe_prerr_endline "Warning: -install sets more than once."; let install = match d with | "user" -> UserInstall | "none" -> NoInstall | "global" -> TraditionalInstall | _ -> Minilib.safe_prerr_endline (String.concat "" ["Warning: invalid option '"; d; "' passed to -install."]); install in process_cmd_line orig_dir (project_file,makefile,install,opt) l r | "-custom" :: com :: dependencies :: file :: r -> process_cmd_line orig_dir opts (Special (file,dependencies,com) :: l) r | "-I" :: d :: r -> process_cmd_line orig_dir opts ((Include (Minilib.correct_path d orig_dir)) :: l) r | "-R" :: p :: lp :: r -> process_cmd_line orig_dir opts (RInclude (Minilib.correct_path p orig_dir,lp) :: l) r | ("-I"|"-custom") :: _ -> raise Parsing_error | "-f" :: file :: r -> let file = Minilib.remove_path_dot (Minilib.correct_path file orig_dir) in let () = match project_file with | None -> () | Some _ -> Minilib.safe_prerr_endline "Warning: Several features will not work with multiple project files." in let (opts',l') = process_cmd_line (Filename.dirname file) (Some file,makefile,install,opt) l (parse file) in process_cmd_line orig_dir opts' l' r | ["-f"] -> raise Parsing_error | "-o" :: file :: r -> begin try let _ = String.index file '/' in raise Parsing_error with Not_found -> let () = match makefile with |None -> () |Some f -> Minilib.safe_prerr_endline ("Warning: Only one output file is genererated. "^f^" will not be.") in process_cmd_line orig_dir (project_file,Some file,install,opt) l r end | v :: "=" :: def :: r -> process_cmd_line orig_dir opts (Def (v,def) :: l) r | "-arg" :: a :: r -> process_cmd_line orig_dir opts (Arg a :: l) r | f :: r -> let f = Minilib.correct_path f orig_dir in process_cmd_line orig_dir opts (( if Filename.check_suffix f ".v" then V f else if (Filename.check_suffix f ".ml") then ML f else if (Filename.check_suffix f ".ml4") then ML4 f else if (Filename.check_suffix f ".mli") then MLI f else if (Filename.check_suffix f ".mllib") then MLLIB f else if (Filename.check_suffix f ".mlpack") then MLPACK f else Subdir f) :: l) r let rec post_canonize f = if Filename.basename f = Filename.current_dir_name then let dir = Filename.dirname f in if dir = Filename.current_dir_name then f else post_canonize dir else f (* Return: ((v,(mli,ml4,ml,mllib,mlpack),special,subdir),(i_inc,r_inc),(args,defs)) *) let split_arguments = let rec aux = function | V n :: r -> let (v,m,o,s),i,d = aux r in ((Minilib.remove_path_dot n::v,m,o,s),i,d) | ML n :: r -> let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in ((v,(mli,ml4,Minilib.remove_path_dot n::ml,mllib,mlpack),o,s),i,d) | MLI n :: r -> let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in ((v,(Minilib.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d) | ML4 n :: r -> let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in ((v,(mli,Minilib.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d) | MLLIB n :: r -> let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in ((v,(mli,ml4,ml,Minilib.remove_path_dot n::mllib,mlpack),o,s),i,d) | MLPACK n :: r -> let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in ((v,(mli,ml4,ml,mllib,Minilib.remove_path_dot n::mlpack),o,s),i,d) | Special (n,dep,c) :: r -> let (v,m,o,s),i,d = aux r in ((v,m,(n,dep,c)::o,s),i,d) | Subdir n :: r -> let (v,m,o,s),i,d = aux r in ((v,m,o,n::s),i,d) | Include p :: r -> let t,(i,r),d = aux r in (t,((Minilib.remove_path_dot (post_canonize p), Minilib.canonical_path_name p)::i,r),d) | RInclude (p,l) :: r -> let t,(i,r),d = aux r in (t,(i,(Minilib.remove_path_dot (post_canonize p),l, Minilib.canonical_path_name p)::r),d) | Def (v,def) :: r -> let t,i,(args,defs) = aux r in (t,i,(args,(v,def)::defs)) | Arg a :: r -> let t,i,(args,defs) = aux r in (t,i,(a::args,defs)) | [] -> ([],([],[],[],[],[]),[],[]),([],[]),([],[]) in aux let read_project_file f = split_arguments (snd (process_cmd_line (Filename.dirname f) (Some f, None, NoInstall, true) [] (parse f))) let args_from_project file project_files default_name = let is_f = Minilib.same_file file in let contains_file dir = List.exists (fun x -> is_f (Minilib.correct_path x dir)) in let build_cmd_line i_inc r_inc args = List.fold_right (fun (_,i) o -> "-I" :: i :: o) i_inc (List.fold_right (fun (_,l,p) o -> "-R" :: p :: l :: o) r_inc (List.fold_right (fun a o -> parse_args (Stream.of_string a) @ o) args [])) in try let (_,(_,(i_inc,r_inc),(args,_))) = List.find (fun (dir,((v_files,_,_,_),_,_)) -> contains_file dir v_files) project_files in build_cmd_line i_inc r_inc args with Not_found -> let rec find_project_file dir = try let ((v_files,_,_,_),(i_inc,r_inc),(args,_)) = read_project_file (Filename.concat dir default_name) in if contains_file dir v_files then build_cmd_line i_inc r_inc args else let newdir = Filename.dirname dir in Minilib.safe_prerr_endline newdir; if dir = newdir then [] else find_project_file newdir with Sys_error s -> let newdir = Filename.dirname dir in if dir = newdir then [] else find_project_file newdir in find_project_file (Filename.dirname file) coq-8.4pl4/ide/minilib.ml0000644000175000017500000001313312326224777014352 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* a | b::l -> it_list_f (i+1) (f i a b) l in it_list_f (* [list_chop i l] splits [l] into two lists [(l1,l2)] such that [l1++l2=l] and [l1] has length [i]. It raises [Failure] when [i] is negative or greater than the length of [l] *) let list_chop n l = let rec chop_aux i acc = function | tl when i=0 -> (List.rev acc, tl) | h::t -> chop_aux (pred i) (h::acc) t | [] -> failwith "list_chop" in chop_aux n [] l let list_map_i f = let rec map_i_rec i = function | [] -> [] | x::l -> let v = f i x in v :: map_i_rec (i+1) l in map_i_rec let list_index x = let rec index_x n = function | y::l -> if x = y then n else index_x (succ n) l | [] -> raise Not_found in index_x 1 let list_index0 x l = list_index x l - 1 let list_filter_i p = let rec filter_i_rec i = function | [] -> [] | x::l -> let l' = filter_i_rec (succ i) l in if p i x then x::l' else l' in filter_i_rec 0 let string_map f s = let l = String.length s in let r = String.create l in for i= 0 to (l - 1) do r.[i] <- f (s.[i]) done; r let subst_command_placeholder s t = Str.global_replace (Str.regexp_string "%s") t s (* Split the content of a variable such as $PATH in a list of directories. The separators are either ":" in unix or ";" in win32 *) let path_to_list = Str.split (Str.regexp "[:;]") (* On win32, the home directory is probably not in $HOME, but in some other environment variable *) let home = try Sys.getenv "HOME" with Not_found -> try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found -> try Sys.getenv "USERPROFILE" with Not_found -> Filename.current_dir_name let opt2list = function None -> [] | Some x -> [x] let (/) = Filename.concat let coqify d = d / "coq" let xdg_config_home = coqify (try Sys.getenv "XDG_CONFIG_HOME" with Not_found -> home / ".config") let relative_base = Filename.dirname (Filename.dirname Sys.executable_name) let xdg_config_dirs = let sys_dirs = try List.map coqify (path_to_list (Sys.getenv "XDG_CONFIG_DIRS")) with | Not_found when Sys.os_type = "Win32" -> [relative_base / "config"] | Not_found -> ["/etc/xdg/coq"] in xdg_config_home :: sys_dirs @ opt2list Coq_config.configdir let xdg_data_home = coqify (try Sys.getenv "XDG_DATA_HOME" with Not_found -> home / ".local" / "share") let xdg_data_dirs = let sys_dirs = try List.map coqify (path_to_list (Sys.getenv "XDG_DATA_DIRS")) with | Not_found when Sys.os_type = "Win32" -> [relative_base / "share"] | Not_found -> ["/usr/local/share/coq";"/usr/share/coq"] in xdg_data_home :: sys_dirs @ opt2list Coq_config.datadir let coqtop_path = ref "" (* On a Win32 application with no console, writing to stderr raise a Sys_error "bad file descriptor", hence the "try" below. Ideally, we should re-route message to a log file somewhere, or print in the response buffer. *) let safe_prerr_endline s = try prerr_endline s;flush stderr with _ -> () (* Hints to partially detects if two paths refer to the same repertory *) let rec remove_path_dot p = let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *) let n = String.length curdir in let l = String.length p in if l > n && String.sub p 0 n = curdir then let n' = let sl = String.length Filename.dir_sep in let i = ref n in while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in remove_path_dot (String.sub p n' (l - n')) else p let strip_path p = let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *) let n = String.length cwd in let l = String.length p in if l > n && String.sub p 0 n = cwd then let n' = let sl = String.length Filename.dir_sep in let i = ref n in while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in remove_path_dot (String.sub p n' (l - n')) else remove_path_dot p let canonical_path_name p = let current = Sys.getcwd () in try Sys.chdir p; let p' = Sys.getcwd () in Sys.chdir current; p' with Sys_error _ -> (* We give up to find a canonical name and just simplify it... *) strip_path p let correct_path f dir = if Filename.is_relative f then Filename.concat dir f else f (* checks if two file names refer to the same (existing) file by comparing their device and inode. It seems that under Windows, inode is always 0, so we cannot accurately check if *) (* Optimised for partial application (in case many candidates must be compared to f1). *) let same_file f1 = try let s1 = Unix.stat f1 in (fun f2 -> try let s2 = Unix.stat f2 in s1.Unix.st_dev = s2.Unix.st_dev && if Sys.os_type = "Win32" then f1 = f2 else s1.Unix.st_ino = s2.Unix.st_ino with Unix.Unix_error _ -> false) with Unix.Unix_error _ -> (fun _ -> false) coq-8.4pl4/ide/preferences.ml0000644000175000017500000005663212326224777015243 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Filename.concat Minilib.home ".coqiderc" let loaded_accel_file = try get_config_file "coqide.keys" with Not_found -> Filename.concat Minilib.home ".coqide.keys" let mod_to_str (m:Gdk.Tags.modifier) = match m with | `MOD1 -> "" | `MOD2 -> "" | `MOD3 -> "" | `MOD4 -> "" | `MOD5 -> "" | `CONTROL -> "" | `SHIFT -> "" | `HYPER -> "" | `META -> "" | `RELEASE -> "" | `SUPER -> "" | `BUTTON1| `BUTTON2| `BUTTON3| `BUTTON4| `BUTTON5| `LOCK -> "" let mod_list_to_str l = List.fold_left (fun s m -> (mod_to_str m)^s) "" l let str_to_mod_list s = snd (GtkData.AccelGroup.parse s) type project_behavior = Ignore_args | Append_args | Subst_args let string_of_project_behavior = function |Ignore_args -> "ignored" |Append_args -> "appended to arguments" |Subst_args -> "taken instead of arguments" let project_behavior_of_string s = if s = "taken instead of arguments" then Subst_args else if s = "appended to arguments" then Append_args else Ignore_args type inputenc = Elocale | Eutf8 | Emanual of string let string_of_inputenc = function |Elocale -> "LOCALE" |Eutf8 -> "UTF-8" |Emanual s -> s let inputenc_of_string s = (if s = "UTF-8" then Eutf8 else if s = "LOCALE" then Elocale else Emanual s) (** Hooks *) let refresh_font_hook = ref (fun () -> ()) let refresh_background_color_hook = ref (fun () -> ()) let refresh_toolbar_hook = ref (fun () -> ()) let auto_complete_hook = ref (fun x -> ()) let contextual_menus_on_goal_hook = ref (fun x -> ()) let resize_window_hook = ref (fun () -> ()) let refresh_tabs_hook = ref (fun () -> ()) type pref = { mutable cmd_coqtop : string option; mutable cmd_coqc : string; mutable cmd_make : string; mutable cmd_coqmakefile : string; mutable cmd_coqdoc : string; mutable global_auto_revert : bool; mutable global_auto_revert_delay : int; mutable auto_save : bool; mutable auto_save_delay : int; mutable auto_save_name : string * string; mutable read_project : project_behavior; mutable project_file_name : string; mutable encoding : inputenc; mutable automatic_tactics : string list; mutable cmd_print : string; mutable modifier_for_navigation : string; mutable modifier_for_templates : string; mutable modifier_for_tactics : string; mutable modifier_for_display : string; mutable modifiers_valid : string; mutable cmd_browse : string; mutable cmd_editor : string; mutable text_font : Pango.font_description; mutable doc_url : string; mutable library_url : string; mutable show_toolbar : bool; mutable contextual_menus_on_goal : bool; mutable window_width : int; mutable window_height :int; mutable query_window_width : int; mutable query_window_height : int; (* mutable use_utf8_notation : bool; *) mutable auto_complete : bool; mutable stop_before : bool; mutable vertical_tabs : bool; mutable opposite_tabs : bool; mutable background_color : string; mutable processing_color : string; mutable processed_color : string; } let use_default_doc_url = "(automatic)" let (current:pref ref) = ref { cmd_coqtop = None; cmd_coqc = "coqc"; cmd_make = "make"; cmd_coqmakefile = "coq_makefile -o makefile *.v"; cmd_coqdoc = "coqdoc -q -g"; cmd_print = "lpr"; global_auto_revert = false; global_auto_revert_delay = 10000; auto_save = true; auto_save_delay = 10000; auto_save_name = "#","#"; read_project = Ignore_args; project_file_name = "_CoqProject"; encoding = if Sys.os_type = "Win32" then Eutf8 else Elocale; automatic_tactics = ["trivial"; "tauto"; "auto"; "omega"; "auto with *"; "intuition" ]; modifier_for_navigation = ""; modifier_for_templates = ""; modifier_for_tactics = ""; modifier_for_display = ""; modifiers_valid = ""; cmd_browse = Flags.browser_cmd_fmt; cmd_editor = if Sys.os_type = "Win32" then "NOTEPAD %s" else "emacs %s"; (* text_font = Pango.Font.from_string "sans 12";*) text_font = Pango.Font.from_string (match Coq_config.gtk_platform with |`QUARTZ -> "Arial Unicode MS 11" |_ -> "Monospace 10"); doc_url = Coq_config.wwwrefman; library_url = Coq_config.wwwstdlib; show_toolbar = true; contextual_menus_on_goal = true; window_width = 800; window_height = 600; query_window_width = 600; query_window_height = 400; (* use_utf8_notation = false; *) auto_complete = false; stop_before = true; vertical_tabs = false; opposite_tabs = false; background_color = "cornsilk"; processed_color = "light green"; processing_color = "light blue"; } let save_pref () = if not (Sys.file_exists Minilib.xdg_config_home) then Unix.mkdir Minilib.xdg_config_home 0o700; let () = try GtkData.AccelMap.save accel_file with _ -> () in let p = !current in let add = Minilib.Stringmap.add in let (++) x f = f x in Minilib.Stringmap.empty ++ add "cmd_coqtop" (match p.cmd_coqtop with | None -> [] | Some v-> [v]) ++ add "cmd_coqc" [p.cmd_coqc] ++ add "cmd_make" [p.cmd_make] ++ add "cmd_coqmakefile" [p.cmd_coqmakefile] ++ add "cmd_coqdoc" [p.cmd_coqdoc] ++ add "global_auto_revert" [string_of_bool p.global_auto_revert] ++ add "global_auto_revert_delay" [string_of_int p.global_auto_revert_delay] ++ add "auto_save" [string_of_bool p.auto_save] ++ add "auto_save_delay" [string_of_int p.auto_save_delay] ++ add "auto_save_name" [fst p.auto_save_name; snd p.auto_save_name] ++ add "project_options" [string_of_project_behavior p.read_project] ++ add "project_file_name" [p.project_file_name] ++ add "encoding" [string_of_inputenc p.encoding] ++ add "automatic_tactics" p.automatic_tactics ++ add "cmd_print" [p.cmd_print] ++ add "modifier_for_navigation" [p.modifier_for_navigation] ++ add "modifier_for_templates" [p.modifier_for_templates] ++ add "modifier_for_tactics" [p.modifier_for_tactics] ++ add "modifier_for_display" [p.modifier_for_display] ++ add "modifiers_valid" [p.modifiers_valid] ++ add "cmd_browse" [p.cmd_browse] ++ add "cmd_editor" [p.cmd_editor] ++ add "text_font" [Pango.Font.to_string p.text_font] ++ add "doc_url" [p.doc_url] ++ add "library_url" [p.library_url] ++ add "show_toolbar" [string_of_bool p.show_toolbar] ++ add "contextual_menus_on_goal" [string_of_bool p.contextual_menus_on_goal] ++ add "window_height" [string_of_int p.window_height] ++ add "window_width" [string_of_int p.window_width] ++ add "query_window_height" [string_of_int p.query_window_height] ++ add "query_window_width" [string_of_int p.query_window_width] ++ add "auto_complete" [string_of_bool p.auto_complete] ++ add "stop_before" [string_of_bool p.stop_before] ++ add "vertical_tabs" [string_of_bool p.vertical_tabs] ++ add "opposite_tabs" [string_of_bool p.opposite_tabs] ++ add "background_color" [p.background_color] ++ add "processing_color" [p.processing_color] ++ add "processed_color" [p.processed_color] ++ Config_lexer.print_file pref_file let load_pref () = let () = try GtkData.AccelMap.load loaded_accel_file with _ -> () in let p = !current in let m = Config_lexer.load_file loaded_pref_file in let np = { p with cmd_coqc = p.cmd_coqc } in let set k f = try let v = Minilib.Stringmap.find k m in f v with _ -> () in let set_hd k f = set k (fun v -> f (List.hd v)) in let set_bool k f = set_hd k (fun v -> f (bool_of_string v)) in let set_int k f = set_hd k (fun v -> f (int_of_string v)) in let set_pair k f = set k (function [v1;v2] -> f v1 v2 | _ -> raise Exit) in let set_command_with_pair_compat k f = set k (function [v1;v2] -> f (v1^"%s"^v2) | [v] -> f v | _ -> raise Exit) in let set_option k f = set k (fun v -> f (match v with |[] -> None |h::_ -> Some h)) in set_option "cmd_coqtop" (fun v -> np.cmd_coqtop <- v); set_hd "cmd_coqc" (fun v -> np.cmd_coqc <- v); set_hd "cmd_make" (fun v -> np.cmd_make <- v); set_hd "cmd_coqmakefile" (fun v -> np.cmd_coqmakefile <- v); set_hd "cmd_coqdoc" (fun v -> np.cmd_coqdoc <- v); set_bool "global_auto_revert" (fun v -> np.global_auto_revert <- v); set_int "global_auto_revert_delay" (fun v -> np.global_auto_revert_delay <- v); set_bool "auto_save" (fun v -> np.auto_save <- v); set_int "auto_save_delay" (fun v -> np.auto_save_delay <- v); set_pair "auto_save_name" (fun v1 v2 -> np.auto_save_name <- (v1,v2)); set_hd "encoding" (fun v -> np.encoding <- (inputenc_of_string v)); set_hd "project_options" (fun v -> np.read_project <- (project_behavior_of_string v)); set_hd "project_file_name" (fun v -> np.project_file_name <- v); set "automatic_tactics" (fun v -> np.automatic_tactics <- v); set_hd "cmd_print" (fun v -> np.cmd_print <- v); set_hd "modifier_for_navigation" (fun v -> np.modifier_for_navigation <- v); set_hd "modifier_for_templates" (fun v -> np.modifier_for_templates <- v); set_hd "modifier_for_tactics" (fun v -> np.modifier_for_tactics <- v); set_hd "modifier_for_display" (fun v -> np.modifier_for_display <- v); set_hd "modifiers_valid" (fun v -> np.modifiers_valid <- v); set_command_with_pair_compat "cmd_browse" (fun v -> np.cmd_browse <- v); set_command_with_pair_compat "cmd_editor" (fun v -> np.cmd_editor <- v); set_hd "text_font" (fun v -> np.text_font <- Pango.Font.from_string v); set_hd "doc_url" (fun v -> if not (Flags.is_standard_doc_url v) && v <> use_default_doc_url && (* Extra hack to support links to last released doc version *) v <> Coq_config.wwwcoq ^ "doc" && v <> Coq_config.wwwcoq ^ "doc/" then (*prerr_endline ("Warning: Non-standard URL for Coq documentation in preference file: "^v);*) np.doc_url <- v); set_hd "library_url" (fun v -> np.library_url <- v); set_bool "show_toolbar" (fun v -> np.show_toolbar <- v); set_bool "contextual_menus_on_goal" (fun v -> np.contextual_menus_on_goal <- v); set_int "window_width" (fun v -> np.window_width <- v); set_int "window_height" (fun v -> np.window_height <- v); set_int "query_window_width" (fun v -> np.query_window_width <- v); set_int "query_window_height" (fun v -> np.query_window_height <- v); set_bool "auto_complete" (fun v -> np.auto_complete <- v); set_bool "stop_before" (fun v -> np.stop_before <- v); set_bool "vertical_tabs" (fun v -> np.vertical_tabs <- v); set_bool "opposite_tabs" (fun v -> np.opposite_tabs <- v); set_hd "background_color" (fun v -> np.background_color <- v); set_hd "processing_color" (fun v -> np.processing_color <- v); set_hd "processed_color" (fun v -> np.processed_color <- v); current := np (* Format.printf "in load_pref: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) let configure ?(apply=(fun () -> ())) () = let cmd_coqtop = string ~f:(fun s -> !current.cmd_coqtop <- if s = "AUTO" then None else Some s) " coqtop" (match !current.cmd_coqtop with |None -> "AUTO" | Some x -> x) in let cmd_coqc = string ~f:(fun s -> !current.cmd_coqc <- s) " coqc" !current.cmd_coqc in let cmd_make = string ~f:(fun s -> !current.cmd_make <- s) " make" !current.cmd_make in let cmd_coqmakefile = string ~f:(fun s -> !current.cmd_coqmakefile <- s) "coqmakefile" !current.cmd_coqmakefile in let cmd_coqdoc = string ~f:(fun s -> !current.cmd_coqdoc <- s) " coqdoc" !current.cmd_coqdoc in let cmd_print = string ~f:(fun s -> !current.cmd_print <- s) " Print ps" !current.cmd_print in let config_font = let box = GPack.hbox () in let w = GMisc.font_selection () in w#set_preview_text "Goal (∃n : nat, n â‰Ī 0)∧(∀x,y,z, x∈y⋃z↔x∈yâˆĻx∈z)."; box#pack ~expand:true w#coerce; ignore (w#misc#connect#realize ~callback:(fun () -> w#set_font_name (Pango.Font.to_string !current.text_font))); custom ~label:"Fonts for text" box (fun () -> let fd = w#font_name in !current.text_font <- (Pango.Font.from_string fd) ; (* Format.printf "in config_font: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) !refresh_font_hook ()) true in let config_color = let box = GPack.vbox () in let table = GPack.table ~row_spacings:5 ~col_spacings:5 ~border_width:2 ~packing:(box#pack ~expand:true) () in let background_label = GMisc.label ~text:"Background color" ~packing:(table#attach ~expand:`X ~left:0 ~top:0) () in let processed_label = GMisc.label ~text:"Background color of processed text" ~packing:(table#attach ~expand:`X ~left:0 ~top:1) () in let processing_label = GMisc.label ~text:"Background color of text being processed" ~packing:(table#attach ~expand:`X ~left:0 ~top:2) () in let () = background_label#set_xalign 0. in let () = processed_label#set_xalign 0. in let () = processing_label#set_xalign 0. in let background_button = GButton.color_button ~color:(Tags.color_of_string (!current.background_color)) ~packing:(table#attach ~left:1 ~top:0) () in let processed_button = GButton.color_button ~color:(Tags.get_processed_color ()) ~packing:(table#attach ~left:1 ~top:1) () in let processing_button = GButton.color_button ~color:(Tags.get_processing_color ()) ~packing:(table#attach ~left:1 ~top:2) () in let reset_button = GButton.button ~label:"Reset" ~packing:box#pack () in let reset_cb () = background_button#set_color (Tags.color_of_string "cornsilk"); processing_button#set_color (Tags.color_of_string "light blue"); processed_button#set_color (Tags.color_of_string "light green"); in let _ = reset_button#connect#clicked ~callback:reset_cb in let label = "Color configuration" in let callback () = !current.background_color <- Tags.string_of_color background_button#color; !current.processing_color <- Tags.string_of_color processing_button#color; !current.processed_color <- Tags.string_of_color processed_button#color; !refresh_background_color_hook (); Tags.set_processing_color processing_button#color; Tags.set_processed_color processed_button#color in custom ~label box callback true in (* let show_toolbar = bool ~f:(fun s -> !current.show_toolbar <- s; !show_toolbar s) "Show toolbar" !current.show_toolbar in let window_height = string ~f:(fun s -> !current.window_height <- (try int_of_string s with _ -> 600); !resize_window (); ) "Window height" (string_of_int !current.window_height) in let window_width = string ~f:(fun s -> !current.window_width <- (try int_of_string s with _ -> 800)) "Window width" (string_of_int !current.window_width) in *) let auto_complete = bool ~f:(fun s -> !current.auto_complete <- s; !auto_complete_hook s) "Auto Complete" !current.auto_complete in (* let use_utf8_notation = bool ~f:(fun b -> !current.use_utf8_notation <- b; ) "Use Unicode Notation: " !current.use_utf8_notation in *) (* let config_appearance = [show_toolbar; window_width; window_height] in *) let global_auto_revert = bool ~f:(fun s -> !current.global_auto_revert <- s) "Enable global auto revert" !current.global_auto_revert in let global_auto_revert_delay = string ~f:(fun s -> !current.global_auto_revert_delay <- (try int_of_string s with _ -> 10000)) "Global auto revert delay (ms)" (string_of_int !current.global_auto_revert_delay) in let auto_save = bool ~f:(fun s -> !current.auto_save <- s) "Enable auto save" !current.auto_save in let auto_save_delay = string ~f:(fun s -> !current.auto_save_delay <- (try int_of_string s with _ -> 10000)) "Auto save delay (ms)" (string_of_int !current.auto_save_delay) in let stop_before = bool ~f:(fun s -> !current.stop_before <- s) "Stop interpreting before the current point" !current.stop_before in let vertical_tabs = bool ~f:(fun s -> !current.vertical_tabs <- s; !refresh_tabs_hook ()) "Vertical tabs" !current.vertical_tabs in let opposite_tabs = bool ~f:(fun s -> !current.opposite_tabs <- s; !refresh_tabs_hook ()) "Tabs on opposite side" !current.opposite_tabs in let encodings = combo "File charset encoding " ~f:(fun s -> !current.encoding <- (inputenc_of_string s)) ~new_allowed: true ("UTF-8"::"LOCALE":: match !current.encoding with |Emanual s -> [s] |_ -> [] ) (string_of_inputenc !current.encoding) in let read_project = combo "Project file options are" ~f:(fun s -> !current.read_project <- project_behavior_of_string s) ~editable:false [string_of_project_behavior Subst_args; string_of_project_behavior Append_args; string_of_project_behavior Ignore_args] (string_of_project_behavior !current.read_project) in let project_file_name = string "Default name for project file" ~f:(fun s -> !current.project_file_name <- s) !current.project_file_name in let help_string = "restart to apply" in let the_valid_mod = str_to_mod_list !current.modifiers_valid in let modifier_for_tactics = modifiers ~allow:the_valid_mod ~f:(fun l -> !current.modifier_for_tactics <- mod_list_to_str l) ~help:help_string "Modifiers for Tactics Menu" (str_to_mod_list !current.modifier_for_tactics) in let modifier_for_templates = modifiers ~allow:the_valid_mod ~f:(fun l -> !current.modifier_for_templates <- mod_list_to_str l) ~help:help_string "Modifiers for Templates Menu" (str_to_mod_list !current.modifier_for_templates) in let modifier_for_navigation = modifiers ~allow:the_valid_mod ~f:(fun l -> !current.modifier_for_navigation <- mod_list_to_str l) ~help:help_string "Modifiers for Navigation Menu" (str_to_mod_list !current.modifier_for_navigation) in let modifier_for_display = modifiers ~allow:the_valid_mod ~f:(fun l -> !current.modifier_for_display <- mod_list_to_str l) ~help:help_string "Modifiers for Display Menu" (str_to_mod_list !current.modifier_for_display) in let modifiers_valid = modifiers ~f:(fun l -> !current.modifiers_valid <- mod_list_to_str l) "Allowed modifiers" the_valid_mod in let cmd_editor = let predefined = [ "emacs %s"; "vi %s"; "NOTEPAD %s" ] in combo ~help:"(%s for file name)" "External editor" ~f:(fun s -> !current.cmd_editor <- s) ~new_allowed: true (predefined@[if List.mem !current.cmd_editor predefined then "" else !current.cmd_editor]) !current.cmd_editor in let cmd_browse = let predefined = [ Coq_config.browser; "netscape -remote \"openURL(%s)\""; "mozilla -remote \"openURL(%s)\""; "firefox -remote \"openURL(%s,new-windows)\" || firefox %s &"; "seamonkey -remote \"openURL(%s)\" || seamonkey %s &" ] in combo ~help:"(%s for url)" "Browser" ~f:(fun s -> !current.cmd_browse <- s) ~new_allowed: true (predefined@[if List.mem !current.cmd_browse predefined then "" else !current.cmd_browse]) !current.cmd_browse in let doc_url = let predefined = [ "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["html";"refman";""]); Coq_config.wwwrefman; use_default_doc_url ] in combo "Manual URL" ~f:(fun s -> !current.doc_url <- s) ~new_allowed: true (predefined@[if List.mem !current.doc_url predefined then "" else !current.doc_url]) !current.doc_url in let library_url = let predefined = [ "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["html";"stdlib";""]); Coq_config.wwwstdlib ] in combo "Library URL" ~f:(fun s -> !current.library_url <- s) ~new_allowed: true (predefined@[if List.mem !current.library_url predefined then "" else !current.library_url]) !current.library_url in let automatic_tactics = strings ~f:(fun l -> !current.automatic_tactics <- l) ~add:(fun () -> [""]) "Wizard tactics to try in order" !current.automatic_tactics in let contextual_menus_on_goal = bool ~f:(fun s -> !current.contextual_menus_on_goal <- s; !contextual_menus_on_goal_hook s) "Contextual menus on goal" !current.contextual_menus_on_goal in let misc = [contextual_menus_on_goal;auto_complete;stop_before; vertical_tabs;opposite_tabs] in (* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!! (shame on Benjamin) *) let cmds = [Section("Fonts", Some `SELECT_FONT, [config_font]); Section("Colors", Some `SELECT_COLOR, [config_color]); Section("Files", Some `DIRECTORY, [global_auto_revert;global_auto_revert_delay; auto_save; auto_save_delay; (* auto_save_name*) encodings; ]); Section("Project", Some (`STOCK "gtk-page-setup"), [project_file_name;read_project; ]); (* Section("Appearance", config_appearance); *) Section("Externals", None, [cmd_coqtop;cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; cmd_print;cmd_editor;cmd_browse;doc_url;library_url]); Section("Tactics Wizard", None, [automatic_tactics]); Section("Shortcuts", Some `PREFERENCES, [modifiers_valid; modifier_for_tactics; modifier_for_templates; modifier_for_display; modifier_for_navigation]); Section("Misc", Some `ADD, misc)] in (* Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) let x = edit ~apply "Customizations" cmds in (* Format.printf "after edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) match x with | Return_apply | Return_ok -> save_pref () | Return_cancel -> () coq-8.4pl4/ide/command_windows.mli0000644000175000017500000000142612326224777016272 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Preferences.pref ref -> object method new_command : ?command:string -> ?term:string -> unit -> unit method frame : GBin.frame method refresh_font : unit -> unit method refresh_color : unit -> unit end coq-8.4pl4/ide/utf8_convert.mll0000644000175000017500000000243212326224777015531 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* s in let c = if Glib.Utf8.validate code then code else s in Buffer.add_string b c; entry lexbuf } | _ { let s = lexeme lexbuf in Buffer.add_string b s; entry lexbuf} | eof { let s = Buffer.contents b in Buffer.reset b ; s } { let f s = let lb = from_string s in Buffer.reset b; entry lb } coq-8.4pl4/ide/command_windows.ml0000644000175000017500000001212412326224777016116 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* i <> index) !views in let _ = toolbar#insert_button ~tooltip:"Delete Page" ~text:"Delete Page" ~icon:(Ideutils.stock_to_widget `DELETE) ~callback:remove_cb () in object(self) val frame = frame val new_page_menu = new_page_menu val notebook = notebook method frame = frame method new_command ?command ?term () = let frame = GBin.frame ~shadow_type:`ETCHED_OUT () in let _ = notebook#append_page frame#coerce in notebook#goto_page (notebook#page_num frame#coerce); let vbox = GPack.vbox ~homogeneous:false ~packing:frame#add () in let hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in let (combo,_) = GEdit.combo_box_entry_text ~strings:Coq_commands.state_preserving ~packing:hbox#pack () in let entry = GEdit.entry ~packing:(hbox#pack ~expand:true) () in entry#misc#set_can_default true; let r_bin = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:(vbox#pack ~fill:true ~expand:true) () in let ok_b = GButton.button ~label:"Ok" ~packing:(hbox#pack ~expand:false) () in let result = GText.view ~packing:r_bin#add () in let () = views := !views @ [result] in result#misc#modify_font !current.Preferences.text_font; let clr = Tags.color_of_string !current.Preferences.background_color in result#misc#modify_base [`NORMAL, `COLOR clr]; result#misc#set_can_focus true; (* false causes problems for selection *) result#set_editable false; let on_activate c () = if List.mem combo#entry#text Coq_commands.state_preserving then c () else result#buffer#set_text "Error: Not a state preserving command" in let callback () = let com = combo#entry#text in let phrase = if String.get com (String.length com - 1) = '.' then com ^ " " else com ^ " " ^ entry#text ^" . " in try result#buffer#set_text (match Coq.interp !coqtop ~raw:true 0 phrase with | Interface.Fail (l,str) -> ("Error while interpreting "^phrase^":\n"^str) | Interface.Good results -> ("Result for command " ^ phrase ^ ":\n" ^ results)) with e -> let s = Printexc.to_string e in assert (Glib.Utf8.validate s); result#buffer#set_text s in ignore (combo#entry#connect#activate ~callback:(on_activate callback)); ignore (ok_b#connect#clicked ~callback:(on_activate callback)); begin match command,term with | None,None -> () | Some c, None -> combo#entry#set_text c; | Some c, Some t -> combo#entry#set_text c; entry#set_text t | None , Some t -> entry#set_text t end; on_activate callback (); entry#misc#grab_focus (); entry#misc#grab_default (); ignore (entry#connect#activate ~callback); ignore (combo#entry#connect#activate ~callback); self#frame#misc#show () method refresh_font () = let iter view = view#misc#modify_font !current.Preferences.text_font in List.iter iter !views method refresh_color () = let clr = Tags.color_of_string !current.Preferences.background_color in let iter view = view#misc#modify_base [`NORMAL, `COLOR clr] in List.iter iter !views initializer ignore (new_page_menu#connect#clicked ~callback:self#new_command); (* ignore (window#event#connect#delete (fun _ -> window#misc#hide(); true));*) end coq-8.4pl4/ide/ideproof.ml0000644000175000017500000001360412326224777014541 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let iter = new GText.iter it in let start = iter#backward_to_tag_toggle (Some tag) in let stop = iter#forward_to_tag_toggle (Some tag) in match GdkEvent.get_type evt with | `BUTTON_PRESS -> let ev = GdkEvent.Button.cast evt in if (GdkEvent.Button.button ev) <> 3 then false else begin let ctxt_menu = GMenu.menu () in let factory = new GMenu.factory ctxt_menu in List.iter (fun (text,cmd) -> ignore (factory#add_item text ~callback:(sel_cb cmd))) menu_content; ctxt_menu#popup ~button:3 ~time:(GdkEvent.Button.time ev); true end | `MOTION_NOTIFY -> hover_cb start stop; false | _ -> false)) let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with | [] -> assert false | { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; } :: rem_goals -> let on_hover sel_start sel_stop = proof#buffer#remove_tag ~start:proof#buffer#start_iter ~stop:sel_start Tags.Proof.highlight; proof#buffer#remove_tag ~start:sel_stop ~stop:proof#buffer#end_iter Tags.Proof.highlight; proof#buffer#apply_tag ~start:sel_start ~stop:sel_stop Tags.Proof.highlight in let goals_cnt = List.length rem_goals + 1 in let head_str = Printf.sprintf "%d subgoal%s\n" goals_cnt (if 1 < goals_cnt then "" else "s") in let goal_str index total = Printf.sprintf "______________________________________(%d/%d)\n" index total in (* Insert current goal and its hypotheses *) let hyps_hints, goal_hints = match hints with | None -> [], [] | Some (hl, h) -> (hl, h) in let rec insert_hyp hints hs = match hs with | [] -> () | hyp :: hs -> let tags, rem_hints = match hints with | [] -> [], [] | hint :: hints -> let tag = proof#buffer#create_tag [] in let () = hook_tag_cb tag hint sel_cb on_hover in [tag], hints in let () = proof#buffer#insert ~tags (hyp ^ "\n") in insert_hyp rem_hints hs in let () = proof#buffer#insert head_str in let () = insert_hyp hyps_hints hyps in let () = let tags = Tags.Proof.goal :: if goal_hints <> [] then let tag = proof#buffer#create_tag [] in let () = hook_tag_cb tag goal_hints sel_cb on_hover in [tag] else [] in proof#buffer#insert (goal_str 1 goals_cnt); proof#buffer#insert ~tags cur_goal; proof#buffer#insert "\n" in (* Insert remaining goals (no hypotheses) *) let fold_goal i _ { Interface.goal_ccl = g } = proof#buffer#insert (goal_str i goals_cnt); proof#buffer#insert (g ^ "\n") in let () = Minilib.list_fold_left_i fold_goal 2 () rem_goals in ignore(proof#buffer#place_cursor ~where:(proof#buffer#end_iter#backward_to_tag_toggle (Some Tags.Proof.goal))); ignore(proof#scroll_to_mark ~use_align:true ~yalign:0.95 `INSERT) let mode_cesar (proof:GText.view) = function | [] -> assert false | { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; } :: _ -> proof#buffer#insert " *** Declarative Mode ***\n"; List.iter (fun hyp -> proof#buffer#insert (hyp^"\n")) hyps; proof#buffer#insert "______________________________________\n"; proof#buffer#insert ("thesis := \n "^cur_goal^"\n"); ignore (proof#scroll_to_iter (proof#buffer#get_iter_at_mark `INSERT)) let rec flatten = function | [] -> [] | (lg, rg) :: l -> let inner = flatten l in List.rev_append lg inner @ rg let display mode (view:GText.view) goals hints evars = let () = view#buffer#set_text "" in match goals with | None -> () (* No proof in progress *) | Some { Interface.fg_goals = []; Interface.bg_goals = bg } -> let bg = flatten (List.rev bg) in let evars = match evars with None -> [] | Some evs -> evs in begin match (bg, evars) with | [], [] -> view#buffer#insert "No more subgoals." | [], _ :: _ -> (* A proof has been finished, but not concluded *) view#buffer#insert "No more subgoals but non-instantiated existential variables:\n\n"; let iter evar = let msg = Printf.sprintf "%s\n" evar.Interface.evar_info in view#buffer#insert msg in List.iter iter evars | _, _ -> (* No foreground proofs, but still unfocused ones *) view#buffer#insert "This subproof is complete, but there are still unfocused goals:\n\n"; let iter goal = let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in view#buffer#insert msg in List.iter iter bg end | Some { Interface.fg_goals = fg } -> mode view fg hints coq-8.4pl4/ide/coq.ml0000644000175000017500000002567512326224777013527 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* " in try (* the following makes sense only when running with local layout *) let coqroot = Filename.concat (Filename.dirname Sys.executable_name) Filename.parent_dir_name in let ch = open_in (Filename.concat coqroot "revision") in let ver = input_line ch in let rev = input_line ch in (ver,rev) with _ -> (Coq_config.version,date) let short_version () = let (ver,date) = get_version_date () in Printf.sprintf "The Coq Proof Assistant, version %s (%s)\n" ver date let version () = let (ver,date) = get_version_date () in Printf.sprintf "The Coq Proof Assistant, version %s (%s)\ \nArchitecture %s running %s operating system\ \nGtk version is %s\ \nThis is %s (%s is the best one for this architecture and OS)\ \n" ver date Coq_config.arch Sys.os_type (let x,y,z = GMain.Main.version in Printf.sprintf "%d.%d.%d" x y z) (Filename.basename Sys.executable_name) Coq_config.best (** * Initial checks by launching test coqtop processes *) let rec read_all_lines in_chan = try let arg = input_line in_chan in let len = String.length arg in let arg = if arg.[len - 1] = '\r' then String.sub arg 0 (len - 1) else arg in arg::(read_all_lines in_chan) with End_of_file -> [] let fatal_error_popup msg = let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok ~message_type:`ERROR ~message:msg () in ignore (popup#run ()); exit 1 let final_info_popup small msg = if small then let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok ~message_type:`INFO ~message:msg () in let _ = popup#run () in exit 0 else let popup = GWindow.dialog () in let button = GButton.button ~label:"ok" ~packing:popup#action_area#add () in let scroll = GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ~packing:popup#vbox#add ~height:500 () in let _ = GMisc.label ~text:msg ~packing:scroll#add_with_viewport () in let _ = popup#connect#destroy ~callback:(fun _ -> exit 0) in let _ = button#connect#clicked ~callback:(fun _ -> exit 0) in let _ = popup#run () in exit 0 let connection_error cmd lines exn = fatal_error_popup ("Connection with coqtop failed!\n"^ "Command was: "^cmd^"\n"^ "Answer was: "^(String.concat "\n " lines)^"\n"^ "Exception was: "^Printexc.to_string exn) let display_coqtop_answer cmd lines = final_info_popup (List.length lines < 30) ("Coqtop exited\n"^ "Command was: "^cmd^"\n"^ "Answer was: "^(String.concat "\n " lines)) let check_remaining_opt arg = if arg <> "" && arg.[0] = '-' then fatal_error_popup ("Illegal option: "^arg) let rec filter_coq_opts args = let argstr = String.concat " " (List.map Filename.quote args) in let cmd = Filename.quote (coqtop_path ()) ^" -nois -filteropts " ^ argstr in let cmd = requote cmd in let filtered_args = ref [] in let errlines = ref [] in try let oc,ic,ec = Unix.open_process_full cmd (Unix.environment ()) in filtered_args := read_all_lines oc; errlines := read_all_lines ec; match Unix.close_process_full (oc,ic,ec) with | Unix.WEXITED 0 -> List.iter check_remaining_opt !filtered_args; !filtered_args | Unix.WEXITED 127 -> asks_for_coqtop args | _ -> display_coqtop_answer cmd (!filtered_args @ !errlines) with Sys_error _ -> asks_for_coqtop args | e -> connection_error cmd (!filtered_args @ !errlines) e and asks_for_coqtop args = let pb_mes = GWindow.message_dialog ~message:"Failed to load coqtop. Reset the preference to default ?" ~message_type:`QUESTION ~buttons:GWindow.Buttons.yes_no () in match pb_mes#run () with | `YES -> let () = !Preferences.current.Preferences.cmd_coqtop <- None in let () = custom_coqtop := None in let () = pb_mes#destroy () in filter_coq_opts args | `DELETE_EVENT | `NO -> let () = pb_mes#destroy () in let cmd_sel = GWindow.file_selection ~title:"Coqtop to execute (edit your preference then)" ~filename:(coqtop_path ()) ~urgency_hint:true () in match cmd_sel#run () with | `OK -> let () = custom_coqtop := (Some cmd_sel#filename) in let () = cmd_sel#destroy () in filter_coq_opts args | `CANCEL | `DELETE_EVENT | `HELP -> exit 0 exception WrongExitStatus of string let print_status = function | Unix.WEXITED n -> "WEXITED "^string_of_int n | Unix.WSIGNALED n -> "WSIGNALED "^string_of_int n | Unix.WSTOPPED n -> "WSTOPPED "^string_of_int n let check_connection args = let lines = ref [] in let argstr = String.concat " " (List.map Filename.quote args) in let cmd = Filename.quote (coqtop_path ()) ^ " -batch " ^ argstr in let cmd = requote cmd in try let ic = Unix.open_process_in cmd in lines := read_all_lines ic; match Unix.close_process_in ic with | Unix.WEXITED 0 -> () (* coqtop seems ok *) | st -> raise (WrongExitStatus (print_status st)) with e -> connection_error cmd !lines e (** * The structure describing a coqtop sub-process *) type coqtop = { pid : int; (* Unix process id *) cout : in_channel ; cin : out_channel ; sup_args : string list; } (** * Count of all active coqtops *) let toplvl_ctr = ref 0 let toplvl_ctr_mtx = Mutex.create () let coqtop_zombies () = Mutex.lock toplvl_ctr_mtx; let res = !toplvl_ctr in Mutex.unlock toplvl_ctr_mtx; res (** * Starting / signaling / ending a real coqtop sub-process *) (** We simulate a Unix.open_process that also returns the pid of the created process. Note: this uses Unix.create_process, which doesn't call bin/sh, so args shouldn't be quoted. The process cannot be terminated by a Unix.close_process, but rather by a kill of the pid. >--ide2top_w--[pipe]--ide2top_r--> coqide coqtop <--top2ide_r--[pipe]--top2ide_w--< Note: we use Unix.stderr in Unix.create_process to get debug messages from the coqtop's Ide_slave loop. NB: it's important to close coqide's descriptors (ide2top_w and top2ide_r) in coqtop. We do this indirectly via [Unix.set_close_on_exec]. This way, coqide has the only remaining copies of these descriptors, and closing them later will have visible effects in coqtop. Cf man 7 pipe : - If all file descriptors referring to the write end of a pipe have been closed, then an attempt to read(2) from the pipe will see end-of-file (read(2) will return 0). - If all file descriptors referring to the read end of a pipe have been closed, then a write(2) will cause a SIGPIPE signal to be generated for the calling process. If the calling process is ignoring this signal, then write(2) fails with the error EPIPE. Symmetrically, coqtop's descriptors (ide2top_r and top2ide_w) should be closed in coqide. *) let open_process_pid prog args = let (ide2top_r,ide2top_w) = Unix.pipe () in let (top2ide_r,top2ide_w) = Unix.pipe () in Unix.set_close_on_exec ide2top_w; Unix.set_close_on_exec top2ide_r; let pid = Unix.create_process prog args ide2top_r top2ide_w Unix.stderr in assert (pid <> 0); Unix.close ide2top_r; Unix.close top2ide_w; let oc = Unix.out_channel_of_descr ide2top_w in let ic = Unix.in_channel_of_descr top2ide_r in set_binary_mode_out oc true; set_binary_mode_in ic true; (pid,ic,oc) let spawn_coqtop sup_args = Mutex.lock toplvl_ctr_mtx; try let prog = coqtop_path () in let args = Array.of_list (prog :: "-ideslave" :: sup_args) in let (pid,ic,oc) = open_process_pid prog args in incr toplvl_ctr; Mutex.unlock toplvl_ctr_mtx; { pid = pid; cin = oc; cout = ic ; sup_args = sup_args } with e -> Mutex.unlock toplvl_ctr_mtx; raise e let respawn_coqtop coqtop = spawn_coqtop coqtop.sup_args let interrupter = ref (fun pid -> Unix.kill pid Sys.sigint) let killer = ref (fun pid -> Unix.kill pid Sys.sigkill) let break_coqtop coqtop = try !interrupter coqtop.pid with _ -> prerr_endline "Error while sending Ctrl-C" let kill_coqtop coqtop = let pid = coqtop.pid in begin try !killer pid with _ -> prerr_endline "Kill -9 failed. Process already terminated ?" end; try ignore (Unix.waitpid [] pid); Mutex.lock toplvl_ctr_mtx; decr toplvl_ctr; Mutex.unlock toplvl_ctr_mtx with _ -> prerr_endline "Error while waiting for child" (** * Calls to coqtop *) (** Cf [Ide_intf] for more details *) let p = Xml_parser.make () let () = Xml_parser.check_eof p false let eval_call coqtop (c:'a Ide_intf.call) = Xml_utils.print_xml coqtop.cin (Ide_intf.of_call c); flush coqtop.cin; let xml = Xml_parser.parse p (Xml_parser.SChannel coqtop.cout) in (Ide_intf.to_answer xml c : 'a Interface.value) let interp coqtop ?(raw=false) ?(verbose=true) i s = eval_call coqtop (Ide_intf.interp (i,raw,verbose,s)) let rewind coqtop i = eval_call coqtop (Ide_intf.rewind i) let inloadpath coqtop s = eval_call coqtop (Ide_intf.inloadpath s) let mkcases coqtop s = eval_call coqtop (Ide_intf.mkcases s) let status coqtop = eval_call coqtop (Ide_intf.status ()) let hints coqtop = eval_call coqtop (Ide_intf.hints ()) module PrintOpt = struct type t = string list let implicit = ["Printing"; "Implicit"] let coercions = ["Printing"; "Coercions"] let raw_matching = ["Printing"; "Matching"; "Synth"] let notations = ["Printing"; "Notations"] let all_basic = ["Printing"; "All"] let existential = ["Printing"; "Existential"; "Instances"] let universes = ["Printing"; "Universes"] let state_hack = Hashtbl.create 11 let _ = List.iter (fun opt -> Hashtbl.add state_hack opt false) [ implicit; coercions; raw_matching; notations; all_basic; existential; universes ] let set coqtop options = let () = List.iter (fun (name, v) -> Hashtbl.replace state_hack name v) options in let options = List.map (fun (name, v) -> (name, Interface.BoolValue v)) options in match eval_call coqtop (Ide_intf.set_options options) with | Interface.Good () -> () | _ -> raise (Failure "Cannot set options.") let enforce_hack coqtop = let elements = Hashtbl.fold (fun opt v acc -> (opt, v) :: acc) state_hack [] in set coqtop elements end let goals coqtop = let () = PrintOpt.enforce_hack coqtop in eval_call coqtop (Ide_intf.goals ()) let evars coqtop = let () = PrintOpt.enforce_hack coqtop in eval_call coqtop (Ide_intf.evars ()) coq-8.4pl4/ide/undo.ml0000644000175000017500000001234712326224777013702 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Delete (s,i,l) | Delete (s,i,l) -> Insert (s,i,l) class undoable_view (tv:[>Gtk.text_view] Gtk.obj) = let undo_lock = ref true in object(self) inherit GText.view tv as super val history = (Stack.create () : action Stack.t) val redo = (Queue.create () : action Queue.t) val nredo = (Stack.create () : action Stack.t) method private dump_debug = if false (* !debug *) then begin prerr_endline "==========Stack top============="; Stack.iter (fun e -> match e with | Insert(s,p,l) -> Printf.eprintf "Insert of '%s' at %d (length %d)\n" s p l | Delete(s,p,l) -> Printf.eprintf "Delete '%s' from %d (length %d)\n" s p l) history; Printf.eprintf "Stack size %d\n" (Stack.length history); prerr_endline "==========Stack Bottom=========="; prerr_endline "==========Queue start============="; Queue.iter (fun e -> match e with | Insert(s,p,l) -> Printf.eprintf "Insert of '%s' at %d (length %d)\n" s p l | Delete(s,p,l) -> Printf.eprintf "Delete '%s' from %d (length %d)\n" s p l) redo; Printf.eprintf "Stack size %d\n" (Queue.length redo); prerr_endline "==========Queue End==========" end method clear_undo = Stack.clear history; Stack.clear nredo; Queue.clear redo method undo = if !undo_lock then begin undo_lock := false; prerr_endline "UNDO"; try begin let r = match Stack.pop history with | Insert(s,p,l) as act -> let start = self#buffer#get_iter_at_char p in (self#buffer#delete_interactive ~start ~stop:(start#forward_chars l) ()) or (Stack.push act history; false) | Delete(s,p,l) as act -> let iter = self#buffer#get_iter_at_char p in (self#buffer#insert_interactive ~iter s) or (Stack.push act history; false) in if r then begin let act = Stack.pop history in Queue.push act redo; Stack.push act nredo end; undo_lock := true; r end with Stack.Empty -> undo_lock := true; false end else (prerr_endline "UNDO DISCARDED"; true) method redo = prerr_endline "REDO"; true initializer (* INCORRECT: is called even while undoing... ignore (self#buffer#connect#mark_set ~callback: (fun it tm -> if !undo_lock && not (Queue.is_empty redo) then begin Stack.iter (fun e -> Stack.push (neg e) history) nredo; Stack.clear nredo; Queue.iter (fun e -> Stack.push e history) redo; Queue.clear redo; end) ); *) ignore (self#buffer#connect#insert_text ~callback: (fun it s -> if !undo_lock && not (Queue.is_empty redo) then begin Stack.iter (fun e -> Stack.push (neg e) history) nredo; Stack.clear nredo; Queue.iter (fun e -> Stack.push e history) redo; Queue.clear redo; end; (* let pos = it#offset in if Stack.is_empty history or s=" " or s="\t" or s="\n" or (match Stack.top history with | Insert(old,opos,olen) -> opos + olen <> pos | _ -> true) then *) Stack.push (Insert(s,it#offset,Glib.Utf8.length s)) history (*else begin match Stack.pop history with | Insert(olds,offset,len) -> Stack.push (Insert(olds^s, offset, len+(Glib.Utf8.length s))) history | _ -> assert false end*); self#dump_debug )); ignore (self#buffer#connect#delete_range ~callback: (fun ~start ~stop -> if !undo_lock && not (Queue.is_empty redo) then begin Queue.iter (fun e -> Stack.push e history) redo; Queue.clear redo; end; let start_offset = start#offset in let stop_offset = stop#offset in let s = self#buffer#get_text ~start ~stop () in (* if Stack.is_empty history or (match Stack.top history with | Delete(old,opos,olen) -> olen=1 or opos <> start_offset | _ -> true ) then *) Stack.push (Delete(s, start_offset, stop_offset - start_offset )) history (* else begin match Stack.pop history with | Delete(olds,offset,len) -> Stack.push (Delete(olds^s, offset, len+(Glib.Utf8.length s))) history | _ -> assert false end*); self#dump_debug )) end let undoable_view ?(buffer:GText.buffer option) = GtkText.View.make_params [] ~cont:(GContainer.pack_container ~create: (fun pl -> let w = match buffer with | None -> GtkText.View.create [] | Some b -> GtkText.View.create_with_buffer b#as_buffer in Gobject.set_params w pl; ((new undoable_view w):undoable_view))) coq-8.4pl4/ide/coq_commands.ml0000644000175000017500000001701412326224777015374 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* "; "dependent rewrite <-"; "destruct"; "discriminate"; "do"; "double induction"; ]; [ "eapply"; "eauto"; "eauto with"; "eexact"; "elim"; "elim __ using"; "elim __ with"; "elimtype"; "exact"; "exists"; ]; [ "fail"; "field"; "first"; "firstorder"; "firstorder using"; "firstorder with"; "fix"; "fix __ with"; "fold"; "fold __ in"; "fourier"; "functional induction"; ]; [ "generalize"; "generalize dependent"; ]; [ "hnf"; ]; [ "idtac"; "induction"; "info"; "injection"; "instantiate (__:=__)"; "intro"; "intro after"; "intro __ after"; "intros"; "intros until"; "intuition"; "inversion"; "inversion __ in"; "inversion __ using"; "inversion __ using __ in"; "inversion__clear"; "inversion__clear __ in"; ]; [ "jp "; "jp"; ]; [ "lapply"; "lazy"; "lazy in"; "left"; ]; [ "move __ after"; ]; [ "omega"; ]; [ "pattern"; "pose"; "pose __:=__)"; "progress"; ]; [ "quote"; ]; [ "red"; "red in"; "refine"; "reflexivity"; "rename __ into"; "repeat"; "replace __ with"; "rewrite"; "rewrite __ in"; "rewrite <-"; "rewrite <- __ in"; "right"; "ring"; ]; [ "set"; "set (__:=__)"; "setoid__replace"; "setoid__rewrite"; "simpl"; "simpl __ in"; "simple destruct"; "simple induction"; "simple inversion"; "simplify__eq"; "solve"; "split"; (* "split__Rabs"; "split__Rmult"; *) "subst"; "symmetry"; "symmetry in"; ]; [ "tauto"; "transitivity"; "trivial"; "try"; ]; [ "unfold"; "unfold __ in"; ]; ] coq-8.4pl4/ide/ide_win32_stubs.c0000644000175000017500000000307512326224777015550 0ustar stephsteph#define _WIN32_WINNT 0x0501 /* Cf below, we restrict to */ #include #include #include /* Win32 emulation of kill -9 */ /* The pid returned by Unix.create_process is actually a pseudo-pid, made via a cast of the obtained HANDLE, (cf. win32unix/createprocess.c in the sources of ocaml). Since we're still in the caller process, we simply cast back to get an handle... The 0 is the exit code we want for the terminated process. */ CAMLprim value win32_kill(value pseudopid) { CAMLparam1(pseudopid); TerminateProcess((HANDLE)(Long_val(pseudopid)), 0); CAMLreturn(Val_unit); } /* Win32 emulation of a kill -2 (SIGINT) */ /* For simplicity, we signal all processes sharing a console with coqide. This shouldn't be an issue since currently at most one coqtop is busy at a given time. Earlier, we tried to be more precise via FreeConsole and AttachConsole before generating the Ctrl-C, but that wasn't working so well (see #2869). This code rely now on the fact that coqide is a console app, and that coqide itself ignores Ctrl-C. */ CAMLprim value win32_interrupt_all(value unit) { CAMLparam1(unit); GenerateConsoleCtrlEvent(CTRL_C_EVENT,0); CAMLreturn(Val_unit); } /* Get rid of the nasty console window (only if we created it) */ CAMLprim value win32_hide_console (value unit) { CAMLparam1(unit); DWORD pid; HWND hw = GetConsoleWindow(); if (hw != NULL) { GetWindowThreadProcessId(hw, &pid); if (pid == GetCurrentProcessId()) ShowWindow(hw, SW_HIDE); } CAMLreturn(Val_unit); } coq-8.4pl4/ide/undo_lablgtk_lt26.mli0000644000175000017500000000201112326224777016405 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* object inherit GText.view method undo : bool method redo : bool method clear_undo : unit end val undoable_view : ?buffer:GText.buffer -> ?editable:bool -> ?cursor_visible:bool -> ?justification:GtkEnums.justification -> ?wrap_mode:GtkEnums.wrap_mode -> ?border_width:int -> ?width:int -> ?height:int -> ?packing:(GObj.widget -> unit) -> ?show:bool -> unit -> undoable_view coq-8.4pl4/ide/undo_lablgtk_ge212.mli0000644000175000017500000000210512326224777016442 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Gtk.text_view] as 'a) Gtk.obj -> object inherit GText.view val obj : 'a Gtk.obj method undo : bool method redo : bool method clear_undo : unit end val undoable_view : ?buffer:GText.buffer -> ?editable:bool -> ?cursor_visible:bool -> ?justification:GtkEnums.justification -> ?wrap_mode:GtkEnums.wrap_mode -> ?accepts_tab:bool -> ?border_width:int -> ?width:int -> ?height:int -> ?packing:(GObj.widget -> unit) -> ?show:bool -> unit -> undoable_view coq-8.4pl4/ide/coq.ico0000644000175000017500000002607612326224777013665 0ustar stephsteph*@ (,(*€   &,........-( (0/&&D`mpqqqqqqqocE |™œbv˜ Ŋo–ŧlŠ’Ák‰Âj‰Âj‰Âj‰Âj‰Âj‰Âj‰Âk‰ÂkŠ‘Âf€…ģ#++p-  ƒĨŠ€Š·ØĐļÚĐļÚĐļÚĐļÚĐļÚĐļÚĐļÚĐļÚĐļÚĐļÚŠļÚu—ĄÉ#++4  ƒĨŦ€Š·Ų~ĐđÜ}ĐđÝ}ĐđÝ}ĐđÝ}ĐđÝ}ĐđÝ}ĐđÝ}ĐđÝ}ĐđÝ~ĐđÝĐļÛt– Ę!))5 …§­€Š·Ų~ĐđÜ|Đšß|Đŧā|Đŧā|Đŧā|Đŧā|Đŧā|Đŧā|Đŧß}ĐšÞĐļÛt— É"*+}1  ‰ŠŊtŠ·Ø~ĐđÜ|Đšß{Đžá{Đžâ{Đ―â{Đ―â{Đ―â{Đ―â|Đžā}ĐšÞĐļÛv™ĒÆ%./r* ‚žĢ-…ŽĩĀŠļÚ}ĐđÝ|Đŧā{Đ―âzĐūäzĐūäzĐūä{Đ―â|Đžā}ĐšÝĐļÚu–ķ%-.URej ‡ĐŪi‚ŦķÍ~ĐđÛ}ĐšÞ{ĐžázĐ―ãzĐŋåzĐūã{Đžá}Đšß~ĐđہĐīÓNad~ 2 g}ƒ‡ŦąŠŠ·Ũ~ĐđÜ}Đšß{ĐžázĐ―ã{Đžâ|Đŧß~Đđ܀ĐĩŨg‚‡­Ey–œ)†ŦģŦŠļŲ~ĐđÜ|Đŧā{Đžâ|Đžā}ĐšÞĐļÛxœĶĘ.9;ƒ0 BNS‡ĨĐ\‚ŦķŅĐđÛ}ĐšÞ|Đžá|Đžā~ĐđÝŠļÚmŒ’ūs' [nu…ŦēģŠļŲ~ĐđÝ|Đŧß|Đŧā~ĐđÝŠ·Údƒŧ t+  ĪŦ€Š·Ų~ĐđÝ}Đŧß|Đŧā~ĐđÝŠ·Úb|ŋ ƒ9u—Ģ…}ĐžÓ{Ļ―ŨzĻŋÚyĻĀÜzĻūŲ{Đ―Öq–ĨČ!*.žZ+ ,pšģ™v§ÆČu§ĮÍt§ĮŅt§ĮÔt§ĮŌu§ĮÍuĨÃÅG_oēT6+&   .NgwmuĨÃ―u§ĮËt§ĮÐt§ĮÔs§ĮÖt§ĮÔt§ĮÐu§ĮËpœļĀ"-3Ŧ‘ vhd\R?- " >CXfqržšēu§ĮĘt§ĮÏt§ĮÔs§ĮŨs§ČŲs§ĮŨt§ĮÔt§ĮÏu§ĮĘm˜ģŋh‘Š·e‹ĢŊ`ƒ™ŦYy§BYgŸ%19•€iK0  ; ',^Rn€Žržŧļu§ĮĘt§ĮÏt§ĮÓs§ĮŨs§ČŲsĻÉÛs§ČŲs§ĮÖt§ĮŌt§ĮÎu§ÆÉo™īĀk“Žūv§ÆÅv§ÆČvĻÆÅtĄūĀb‡ž·;P\§ŒiD!   :#-3]Ql}Žn˜ąŊuĨÃÄu§ĮĘt§ĮÏt§ĮÓs§ĮŨs§ČŲsĻÉÜsĻÉÜsĻČÛs§ČØs§ĮÕt§ĮŌt§ĮÍtĪÂÆ^~’šb†œ·uĶÅÅu§ĮËu§ĮËu§ĮÉsĢĀÄdŠĒ·2CNĢ ~N(  )/HRm~„k“Ŧ­vĶÅÃu§ÆÉu§ĮĖt§ĮÏt§ĮÓs§ĮŨs§ČŲsĻÉÛsĻÉÝsĻÉÞsĻÉÜsĻČÚs§ĮŨt§ĮÔt§ĮÐu§ĮĖpžšÁI`oŽj’Š°v§ÆČu§ĮĖt§ĮÎu§ĮĖv§ĮÉpœļŋ;O[Ŧ€P  MfvTo™ēĪuĶÅÄu§ÆĘu§ĮĖu§ĮÏt§ĮŅt§ĮÔs§ĮŨs§ČŲs§ÉÜsĻÉÞsĻÉÞsĻÉÞsĻÉÝsĻÉÛs§ČØt§ĮÕt§ĮŌu§ĮÍv§ÆČ[zĨBVc…vĨÃ―u§ĮĘt§ĮÏt§ĮÐt§ĮÏu§ĮĖtĢĀÃG`oŽ „G ]zŒ1vĢŋĒv§ĮČu§ĮĖu§ĮÎt§ĮÐt§ĮŌt§ĮÔs§ĮÖs§ČŲs§ÉÜsĻÉÝsĻÉÞsĐĘÞsĻÉÞsĻÉÜsĻČÚs§ČØt§ĮÔt§ĮÐu§ĮĖvĶÅÃD[iš(16kuĒŋąu§ÆÉu§ĮÎt§ĮŅt§ĮŌt§ĮÐu§ĮĖoœļĀ4FQĐm8*49xĒžPwĻÆūu§ĮËt§ĮÏt§ĮŅt§ĮÓs§ĮÕs§ČŨs§ČŲsĻÉÛsĻÉÝsĻÉÞsĐĘÞsĐĘÞsĻÉÝsĻÉÛs§ČŲs§ČŨt§ĮÔt§ĮÏu§ĮËošĩū&17—!(,ts ―ēu§ÆÉu§ĮÎt§ĮŌt§ĮÕt§ĮÓt§ĮÏu§ĮĘo›ķ―#(—\""(+{ ļ,zĐĮĢv§ÆĮu§ĮËt§ĮÎt§ĮÐt§ĮÓs§ĮÖs§ČŲsĻČÛsĻÉÝsĻÉÞsĐĘÞsĻÉÝsĻÉÜsĻČÚs§ČŲs§ČŨt§ĮÔt§ĮÏu§ÆËk•ŊĀ )/Đ(3:•s ―šu§ĮĘu§ĮÏt§ĮŌs§ĮÖs§ĮÕt§ĮŌu§ĮÍv§ÆČKev­ z83>EzĒŧ9{ĐƖwĻĮÂv§ĮÉu§ĮĖt§ĮÏt§ĮÓs§ĮÖs§ČŲsĻÉÛsĻÉÝsĻÉÝsĻÉÜsĻČÚs§ČØs§ČŲs§ČØs§ĮÕt§ĮŅu§ĮÍrĄŋÅSpƒž^•šuĶÅĮu§ĮÍt§ĮŅs§ĮÕs§ČØs§ĮÖt§ĮÓt§ĮÏu§ĮËl—ąž!,2–Q:JUpĪ}Ķŋ^zĻÆ wĻÆÄu§ĮĘu§ĮÎt§ĮÓs§ĮÖs§ČŲsĻÉÛsĻÉÜsĻČÚs§ČŨt§ĮÕs§ČŨs§ČŲs§ČØs§ĮÔt§ĮŅu§ĮĖv§ÆĮuĶÅČu§ĮÍt§ĮŅs§ĮÕs§ČØsĻČÚs§ČØt§ĮÕt§ĮŅu§ĮÍuĶÄÅE]lŽi, 4@Hs”Š&zĶÂ{xĻĮšu§ĮĘu§ĮÎt§ĮÓs§ĮÖs§ČŲsĻČÚs§ČŨt§ĮÔt§ĮŅt§ĮÔs§ČŨs§ČŲs§ČŨs§ĮÔt§ĮÐu§ĮÎu§ĮÍt§ĮŅs§ĮÕs§ČŲsĻČÚsĻČÛs§ČŲs§ĮÖt§ĮÓu§ĮÏu§ĮÉgĶķ ;XpzĢ―RxĻÆŊu§ĮÉu§ĮÎt§ĮÓs§ĮÖs§ĮŨt§ĮÔt§ĮÐu§ĮÍt§ĮÏt§ĮÔs§ĮŨs§ČŲs§ČØs§ĮÔt§ĮŌt§ĮŌs§ĮÕs§ČØsĻÉÛsĻÉÜsĻÉÜsĻÉŲs§ĮŨt§ĮÓt§ĮÐu§ĮËqžšū(-’K@Q\ xĒŧYwĻÆžu§ĮËt§ĮÏt§ĮÓt§ĮÔt§ĮÐu§ĮĖv§ÆÉu§ĮĖt§ĮÐt§ĮÔs§ČŨs§ČŲs§ČŨs§ĮÕs§ĮÕs§ČØs§ČÛsĻÉÜsĻÉÝsĻÉÜsĻČÚs§ČØt§ĮÔt§ĮŅu§ĮĖtĢÁÅ6HTXQftzĶÂv§ÆÆu§ĮĖt§ĮÐt§ĮÐu§ĮĖuĪÂÂgĨīw§ÆÄu§ĮĖt§ĮÐt§ĮÔs§ČŨsĻÉŲs§ČØs§ČŲsĻÉÛsĻÉÜsĻÉÞsĻÉÞsĻÉÝsĻČÛs§ČØs§ĮÕt§ĮŌu§ĮÍv§ÆĮOk}Ļ e%p•ŽAxĻÆšu§ÆËt§ĮÏt§ĮÎu§ÆĘh‘Šļ6GR‘s ―ķv§ÆĘt§ĮÎt§ĮŌs§ĮÖs§ČŲsĻČÚs§ČÛsĻÉÜsĻÉÞsĐĘÞsĻÉÞsĻÉÝsĻČÛs§ČØs§ĮÕt§ĮŌu§ĮÍv§ÆĮSr…Ū l+ _}"y§ÄĢv§ÆÉt§ĮÎu§ĮÍv§ÆČ\~“Ū$*ul”Ūv§ÆČu§ĮĖt§ĮŅt§ĮÕs§ČØsĻČÛsĻÉÜsĻÉÞsĐĘÞsĐĘÞsĻÉÞsĻÉÝsĻÉÛs§ČŲs§ĮÖt§ĮÓt§ĮÎu§ÆÉa†īp. EYeuĄ―ˆv§ÆČu§ĮÍu§ĮÍv§ÆĮSr…§ dc…›|v§ÆÄu§ĮĖt§ĮÐt§ĮÔs§ČŨsĻÉÚsĻÉÜsĻÉÞsĐĘÞsĐĘÞsĻÉÞsĻÉÝsĻÉÛs§ČŲs§ĮÖt§ĮÓt§ĮÎu§ÆĘb‡Ÿĩq. 9HQtžšƒv§ÆĮu§ĮÍu§ĮĖuĨÄÆHapŸXUpWw§Å―u§ĮĘt§ĮÏt§ĮÓs§ĮÖs§ČŲsĻÉÛsĻÉÝsĻÉÞsĻÉÞsĻÉÞsĻÉÝsĻÉÛs§ČŲs§ĮÖt§ĮÓt§ĮÎu§ÆĘcˆ īm+ 6EOsžđŒv§ÆČu§ĮÍu§ĮĖtĪÃÆ@VdšQ6CK2y§ÃĒv§ÆÉu§ĮÎt§ĮŌs§ĮÕs§ČŲsĻÉÛsĻÉÜsĻÉÝsĻÉÝsĻÉÝsĻÉÜsĻÉÛs§ČŲs§ĮÖt§ĮÓt§ĮÎu§ÆÉcˆŸ°d% 5FQ-s žĄv§ÆÉt§ÆÎu§ĮĖtĨÃÆAWe—LxĒžpwĻĮÄu§ĮĖt§ĮÐt§ĮÔs§ČŨsĻÉÚsĻČÛsĻČÛsĻČÛsĻČÛsĻÉÛsĻÉÚs§ČØs§ĮÕt§ĮŌu§ĮÍv§ÆČZ|Ī UCWdTtĒūīu§ÆĘt§ÆÎu§ĮĖtĪÂÄ:MY‘FmĨ4yĻÆŽu§ÆĘt§ĮÎt§ĮŌs§ĮÖs§ČØs§ČØs§ČØs§ČØs§ČØs§ČØs§ČŨs§ĮŨt§ĮÔt§ĮŅu§ĮĖuĶÄÅKfvŒ= Ldr>pšĩv§ÆÅu§ĮÍt§ĮÏu§ĮËrĄūÁ)5<DQgt|§Âlv§ĮÆu§ĮĖt§ĮÐt§ĮÓt§ĮÕt§ĮÕt§ĮÖt§ĮÖt§ĮÖt§ĮÕt§ĮÔt§ĮÔt§ĮŌt§ĮÏu§ĮĘtĒŋš2AKg'  #m”Ž‚v§ÆÅu§ĮĖt§ĮÐt§ĮÐu§ĮËrĄūÁ'4;ŒD]v…{ĐĮžv§ĮČu§ĮÍt§ĮÏt§ĮŅt§ĮŌt§ĮŌt§ĮŌt§ĮŌt§ĮŅt§ĮŅt§ĮÏu§ĮÎu§ĮĖvĶÄĀc†œ‡ 2 3$)Ot ŧŦu§ÆÉt§ĮÎt§ĮŌt§ĮÐu§ĮËrĄūÁ'3:H  wŸ·ByĻÆĪv§ÆĮu§ĮËu§ĮÍu§ĮÎu§ĮÎu§ĮÎu§ĮÎu§ĮÍu§ĮĖu§ĮËu§ÆÉv§ÅÁg‹Ē„(4<<o™ĩ1eĶkD]n{6GRŠx§Å―u§ÆĘt§ĮÏoŠÉÛrĻČÔu§ĮËrĄūÁ&29‘U8* r•Ž/{ĐƏxĻĮŋv§ĮČu§ĮÉu§ĮÉu§ĮÉu§ĮÉu§ÆČv§ÆĮwĻĮÁuĒūĪg‹Ēn%*(v ž3yŦË°t§ČŨqĒÂÔuĻÉŌu§ĮÎt§ĮŌoŠÉÝsĻČÓu§ĮËrĄūÁ%17•'3G1@W{ ^A  g‡›|ĢžL|Ļňx§ÅŸx§ÄĄxĶÃĄxĶÃĄwĪĀ“v š~iŠŸVG\i-#( Qn€RtĨĮŅvŠÍãuŠĖât§ČÕs§ĮÔsĻĮÕt§ĮÐu§ĮËrĄūÁ+8?›WvĨÄbˆ―Ø0?TĄo4\p|_x‡Wn}SiwSiv@NW  .-;Pec‰šÐo ËįtĻËáuĻČÔyŠÉÖzŦĘÕuĻĮÐu§ĮËr ūĀ;L_Īa‡ŧŲh“Čč^ēŲ#.>ĒW% #I`…za…đĘh’Čįi•Čęo ČßuĻČÖ{ŽĘØ{ŽĘÔwĐČÐu§ĮĘm—ēđ.M`f…ī2lÆ‡hČĮh‘ČÜh’Čäh’Čįh’Čįh’Čįh‘ČâgĮÔc„ļŸE[}M Udo fŦ+f†ŧYgŠŋ{fŠŋ‹e‰―Œeˆ―‹b‚īrXrœL-6C #*/7EW3AS 0=N .;L %, ĸĸĸĸĸĀĸĸĸĸĸĀĸĸĸĸĸĀĸĸĸĸĸĀĸ€ĸĸĀĸĸĸĀĸĸĸĀĸ€ĸĸĀĸ€ĸĸĀĸ€ĸĸĀĸĀĸĸĀĸĀĸĸĀĸāĸĸĀĸðĸĸĀĸðĸĸĀĸðĸĸĀĸðĸĸĀĸðĸĸĀĸðĸĸĀĸāĸĀĸ€ĸĀþĸĀø?ĀðĀā@Āā@ĀāĀðĀüĀĸĀĸ€ĀĸĀĀĸāĀĸāĀĸā@Āĸā`Āĸā`Āĸā`ĀĸāpĀĸāpĀĸĀxĀĸ€xĀĸ€|Āĸ~?Āü?ĸĀþĸĸĀþĸĸĀüĸĸĀøĸĸĀðĸĸĀāĸĸĀāĸĸĀāĸĸĀāĸĸĀāĸĸĀðĸĸĀðĸĸĀøĸĸĀüĸĸĀþĸĸĀĸ?ĸĸĀĸņĸĸĸĀĸĸĸĸĸĀĸĸĸĸĸĀcoq-8.4pl4/ide/mac_default_accel_map0000644000175000017500000005545512326224777016565 0ustar stephsteph; coqide GtkAccelMap rc-file -*- scheme -*- ; this file is an automated accelerator map dump ; ; (gtk_accel_path "/Templates/Template Read Module" "") ; (gtk_accel_path "/Tactics/Tactic pattern" "") (gtk_accel_path "/Templates/Definition" "d") ; (gtk_accel_path "/Templates/Template Program Lemma" "") (gtk_accel_path "/Templates/Lemma" "l") ; (gtk_accel_path "/Templates/Template Fact" "") (gtk_accel_path "/Tactics/auto" "a") ; (gtk_accel_path "/Tactics/Tactic fold" "") ; (gtk_accel_path "/Help/About Coq" "") ; (gtk_accel_path "/Templates/Template Add Ring A Aplus Amult Aone Azero Ainv Aeq T [ c1 ... cn ]. " "") ; (gtk_accel_path "/Templates/Template Hypothesis" "") ; (gtk_accel_path "/Tactics/Tactic repeat" "") ; (gtk_accel_path "/Templates/Template Unset Extraction Optimize" "") ; (gtk_accel_path "/Templates/Template Add Printing Constructor" "") ; (gtk_accel_path "/Windows/Detach View" "") ; (gtk_accel_path "/Tactics/Tactic inversion" "") ; (gtk_accel_path "/Templates/Template Write State" "") ; (gtk_accel_path "/Export/Export to" "") (gtk_accel_path "/Tactics/auto with *" "asterisk") ; (gtk_accel_path "/Tactics/Tactic inversion--clear" "") ; (gtk_accel_path "/Templates/Template Implicit Arguments" "") (gtk_accel_path "/Edit/Find backwards" "b") ; (gtk_accel_path "/Edit/Copy" "c") ; (gtk_accel_path "/Tactics/Tactic inversion -- using" "") (gtk_accel_path "/View/Previous tab" "Left") ; (gtk_accel_path "/Tactics/Tactic change -- in" "") ; (gtk_accel_path "/Tactics/Tactic jp" "") ; (gtk_accel_path "/Tactics/Tactic red" "") ; (gtk_accel_path "/Templates/Template Coercion" "") ; (gtk_accel_path "/Templates/Template CoFixpoint" "") ; (gtk_accel_path "/Tactics/Tactic intros until" "") ; (gtk_accel_path "/Templates/Template Derive Dependent Inversion" "") ; (gtk_accel_path "/Tactics/Tactic eapply" "") ; (gtk_accel_path "/View/View" "") ; (gtk_accel_path "/Tactics/Tactic change" "") ; (gtk_accel_path "/Tactics/Tactic firstorder using" "") ; (gtk_accel_path "/Tactics/Tactic decompose sum" "") ; (gtk_accel_path "/Tactics/Tactic cut" "") ; (gtk_accel_path "/Templates/Template Remove Printing Let" "") ; (gtk_accel_path "/Templates/Template Structure" "") ; (gtk_accel_path "/Tactics/Tactic compute in" "") ; (gtk_accel_path "/Queries/Locate" "") ; (gtk_accel_path "/Templates/Template Save." "") ; (gtk_accel_path "/Templates/Template Canonical Structure" "") ; (gtk_accel_path "/Tactics/Tactic compare" "") ; (gtk_accel_path "/Templates/Template Next Obligation" "") (gtk_accel_path "/View/Display notations" "n") ; (gtk_accel_path "/Tactics/Tactic fail" "") ; (gtk_accel_path "/Tactics/Tactic left" "") (gtk_accel_path "/Edit/Undo" "u") (gtk_accel_path "/Tactics/eauto with *" "ampersand") ; (gtk_accel_path "/Templates/Template Infix" "") ; (gtk_accel_path "/Tactics/Tactic functional induction" "") ; (gtk_accel_path "/Tactics/Tactic clear" "") ; (gtk_accel_path "/Templates/Template End Silent." "") ; (gtk_accel_path "/Tactics/Tactic intros" "") ; (gtk_accel_path "/Tactics/Tactic constructor -- with" "") ; (gtk_accel_path "/Tactics/Tactic destruct" "") ; (gtk_accel_path "/Tactics/Tactic intro after" "") ; (gtk_accel_path "/Tactics/Tactic abstract" "") ; (gtk_accel_path "/Queries/About" "F5") ; (gtk_accel_path "/Templates/Template CoInductive" "") ; (gtk_accel_path "/Templates/Template Unset Hyps--limit" "") ; (gtk_accel_path "/Export/Ps" "") ; (gtk_accel_path "/Tactics/Tactic elim" "") ; (gtk_accel_path "/Templates/Template Transparent" "") ; (gtk_accel_path "/Tactics/Tactic assert (--:--)" "") ; (gtk_accel_path "/Templates/Template Add Rec LoadPath" "") ; (gtk_accel_path "/Templates/Template Extract Constant" "") ; (gtk_accel_path "/Tactics/Tactic compute" "") ; (gtk_accel_path "/Compile/Next error" "F7") ; (gtk_accel_path "/Templates/Template Add ML Path" "") ; (gtk_accel_path "/Templates/Template Test Printing Wildcard" "") ; (gtk_accel_path "/Templates/Template Set Implicit Arguments" "") ; (gtk_accel_path "/Templates/Template Test Printing Let" "") ; (gtk_accel_path "/Windows/Windows" "") ; (gtk_accel_path "/Templates/Template Defined." "") (gtk_accel_path "/Templates/match" "c") ; (gtk_accel_path "/Tactics/Tactic set (--:=--)" "") ; (gtk_accel_path "/Templates/Template Test Printing If" "") ; (gtk_accel_path "/Compile/Make" "F6") ; (gtk_accel_path "/Templates/Template Module Type" "") ; (gtk_accel_path "/Tactics/Tactic apply -- with" "") ; (gtk_accel_path "/File/Save as" "") ; (gtk_accel_path "/Templates/Template Remove Printing Constructor" "") ; (gtk_accel_path "/Templates/Template Set Hyps--limit" "") ; (gtk_accel_path "/Templates/Template Global Variable" "") ; (gtk_accel_path "/Tactics/Tactic trivial" "") ; (gtk_accel_path "/Templates/Template Add Setoid" "") ; (gtk_accel_path "/Templates/Template Proof." "") ; (gtk_accel_path "/Templates/Template Load Verbose" "") ; (gtk_accel_path "/Compile/Compile buffer" "") ; (gtk_accel_path "/Queries/Print" "F4") ; (gtk_accel_path "/Templates/Template Obligations Tactic" "") ; (gtk_accel_path "/Tactics/Tactic cbv" "") ; (gtk_accel_path "/Tactics/Tactic first" "") ; (gtk_accel_path "/Tactics/Tactic case" "") ; (gtk_accel_path "/Templates/Template Hint Constructors" "") ; (gtk_accel_path "/Templates/Template Add Abstract Ring A Aplus Amult Aone Azero Ainv Aeq T." "") ; (gtk_accel_path "/Templates/Template Coercion Local" "") ; (gtk_accel_path "/View/Show Query Pane" "Escape") ; (gtk_accel_path "/Templates/Template Add Relation" "") ; (gtk_accel_path "/Tactics/Tactic inversion--clear -- in" "") ; (gtk_accel_path "/Templates/Template Definition" "") ; (gtk_accel_path "/Templates/Template Add Rec ML Path" "") ; (gtk_accel_path "/Tactics/Tactic apply" "") ; (gtk_accel_path "/Export/Latex" "") ; (gtk_accel_path "/Tactics/Tactic inversion -- using -- in" "") ; (gtk_accel_path "/Tactics/Tactic generalize" "") ; (gtk_accel_path "/Templates/Template Reset Extraction Inline" "") (gtk_accel_path "/Navigation/Hide" "h") ; (gtk_accel_path "/File/Close buffer" "w") ; (gtk_accel_path "/Tactics/Tactic induction" "") ; (gtk_accel_path "/Tactics/Tactic eauto with" "") (gtk_accel_path "/View/Display raw matching expressions" "m") (gtk_accel_path "/Navigation/Backward" "Up") ; (gtk_accel_path "/Tactics/Tactic u" "") ; (gtk_accel_path "/Templates/Templates" "") ; (gtk_accel_path "/Tactics/Tactic p" "") ; (gtk_accel_path "/Tactics/Tactic lapply" "") ; (gtk_accel_path "/Tactics/Tactic t" "") ; (gtk_accel_path "/Tactics/Tactic s" "") ; (gtk_accel_path "/Tactics/Tactic r" "") ; (gtk_accel_path "/Tactics/Tactic case -- with" "") ; (gtk_accel_path "/Tactics/Tactic eexact" "") ; (gtk_accel_path "/Queries/Check" "F3") ; (gtk_accel_path "/Tactics/Tactic omega" "") ; (gtk_accel_path "/File/New" "n") ; (gtk_accel_path "/Tactics/Tactic l" "") ; (gtk_accel_path "/Tactics/Tactic intro" "") ; (gtk_accel_path "/Tactics/Tactic j" "") ; (gtk_accel_path "/Tactics/Tactic i" "") ; (gtk_accel_path "/Tactics/Tactic e" "") ; (gtk_accel_path "/Tactics/Tactic g" "") ; (gtk_accel_path "/Tactics/Tactic f" "") ; (gtk_accel_path "/Tactics/Tactic d" "") ; (gtk_accel_path "/Tactics/Tactic c" "") (gtk_accel_path "/File/Rehighlight" "l") ; (gtk_accel_path "/Tactics/Tactic simple inversion" "") ; (gtk_accel_path "/Tactics/Tactic a" "") ; (gtk_accel_path "/Templates/Template Mutual Inductive" "") ; (gtk_accel_path "/Templates/Template Extraction NoInline" "") (gtk_accel_path "/Templates/Theorem" "t") ; (gtk_accel_path "/Templates/Template Derive Dependent Inversion--clear" "") ; (gtk_accel_path "/Tactics/Tactic unfold" "") ; (gtk_accel_path "/Tactics/Try Tactics" "") ; (gtk_accel_path "/Tactics/Tactic red in" "") ; (gtk_accel_path "/Tactics/Tactic rewrite <- -- in" "") ; (gtk_accel_path "/Templates/Template Hint Extern" "") ; (gtk_accel_path "/Templates/Template Unfocus" "") ; (gtk_accel_path "/Tactics/Tactic dependent inversion--clear" "") ; (gtk_accel_path "/Help/Browse Coq Library" "") ; (gtk_accel_path "/Tactics/Tactic lazy" "") ; (gtk_accel_path "/Templates/Template Scheme" "") (gtk_accel_path "/Tactics/tauto" "p") ; (gtk_accel_path "/Tactics/Tactic cutrewrite" "") ; (gtk_accel_path "/Tactics/Tactic contradiction" "") ; (gtk_accel_path "/Templates/Template Set Printing Wildcard" "") ; (gtk_accel_path "/Templates/Template Add LoadPath" "") (gtk_accel_path "/Navigation/Previous" "less") ; (gtk_accel_path "/Templates/Template Require" "") ; (gtk_accel_path "/Tactics/Tactic simpl" "") ; (gtk_accel_path "/Templates/Template Require Import" "") ; (gtk_accel_path "/Templates/Template Add Abstract Semi Ring A Aplus Amult Aone Azero Aeq T." "") (gtk_accel_path "/Navigation/Forward" "Down") ; (gtk_accel_path "/Tactics/Tactic rename -- into" "") ; (gtk_accel_path "/Compile/Compile" "") ; (gtk_accel_path "/File/Save all" "") ; (gtk_accel_path "/Tactics/Tactic fix" "") ; (gtk_accel_path "/Templates/Template Parameter" "") ; (gtk_accel_path "/Tactics/Tactic assert" "") ; (gtk_accel_path "/Tactics/Tactic do" "") ; (gtk_accel_path "/Tactics/Tactic ring" "") ; (gtk_accel_path "/Export/Pdf" "") ; (gtk_accel_path "/Tactics/Tactic quote" "") ; (gtk_accel_path "/Tactics/Tactic symmetry in" "") ; (gtk_accel_path "/Help/Help" "") (gtk_accel_path "/Templates/Inductive" "i") ; (gtk_accel_path "/Edit/Clear Undo Stack" "") ; (gtk_accel_path "/Tactics/Tactic intro -- after" "") ; (gtk_accel_path "/Templates/Template Syntax" "") ; (gtk_accel_path "/Tactics/Tactic idtac" "") ; (gtk_accel_path "/Tactics/Tactic fold -- in" "") ; (gtk_accel_path "/Templates/Template Program Definition" "") (gtk_accel_path "/Tactics/Wizard" "dollar") ; (gtk_accel_path "/Templates/Template Hint Resolve" "") ; (gtk_accel_path "/Templates/Template Set Extraction Optimize" "") ; (gtk_accel_path "/File/Revert all buffers" "") ; (gtk_accel_path "/Tactics/Tactic subst" "") ; (gtk_accel_path "/Tactics/Tactic autorewrite" "") ; (gtk_accel_path "/Tactics/Tactic pose" "") ; (gtk_accel_path "/Tactics/Tactic simplify--eq" "") ; (gtk_accel_path "/Tactics/Tactic clearbody" "") ; (gtk_accel_path "/Tactics/Tactic eauto" "") ; (gtk_accel_path "/Templates/Template Grammar" "") ; (gtk_accel_path "/Tactics/Tactic exact" "") ; (gtk_accel_path "/Templates/Template Unset Implicit Arguments" "") ; (gtk_accel_path "/Templates/Template Extract Inductive" "") (gtk_accel_path "/View/Display implicit arguments" "i") ; (gtk_accel_path "/Tactics/Tactic symmetry" "") ; (gtk_accel_path "/Templates/Template Add Printing Let" "") ; (gtk_accel_path "/Help/Help for keyword" "h") ; (gtk_accel_path "/File/Save" "s") ; (gtk_accel_path "/Compile/Make makefile" "") ; (gtk_accel_path "/Templates/Template Remove LoadPath" "") (gtk_accel_path "/Navigation/Interrupt" "Break") (gtk_accel_path "/Navigation/End" "End") ; (gtk_accel_path "/Templates/Template Add Morphism" "") ; (gtk_accel_path "/Tactics/Tactic field" "") ; (gtk_accel_path "/Templates/Template Axiom" "") ; (gtk_accel_path "/Tactics/Tactic solve" "") ; (gtk_accel_path "/Tactics/Tactic casetype" "") ; (gtk_accel_path "/Tactics/Tactic cbv in" "") ; (gtk_accel_path "/Templates/Template Load" "") ; (gtk_accel_path "/Tactics/Tactic fourier" "") ; (gtk_accel_path "/Templates/Template Goal" "") ; (gtk_accel_path "/Tactics/Tactic exists" "") ; (gtk_accel_path "/Tactics/Tactic decompose record" "") (gtk_accel_path "/Navigation/Go to" "Right") ; (gtk_accel_path "/Templates/Template Remark" "") ; (gtk_accel_path "/Templates/Template Set Undo" "") ; (gtk_accel_path "/Templates/Template Inductive" "") (gtk_accel_path "/Edit/Preferences" "VoidSymbol") ; (gtk_accel_path "/Export/Html" "") ; (gtk_accel_path "/Templates/Template Extraction Inline" "") ; (gtk_accel_path "/Tactics/Tactic absurd" "") (gtk_accel_path "/Tactics/intuition" "i") ; (gtk_accel_path "/Tactics/Tactic simple induction" "") ; (gtk_accel_path "/Queries/Queries" "") ; (gtk_accel_path "/Tactics/Tactic rewrite -- in" "") ; (gtk_accel_path "/Templates/Template Hint Rewrite" "") ; (gtk_accel_path "/Templates/Template Add Semi Ring A Aplus Amult Aone Azero Aeq T [ c1 ... cn ]." "") ; (gtk_accel_path "/Navigation/Navigation" "") ; (gtk_accel_path "/Help/Browse Coq Manual" "") ; (gtk_accel_path "/Tactics/Tactic transitivity" "") ; (gtk_accel_path "/Tactics/Tactic auto" "") ; (gtk_accel_path "/Tactics/Tactic dependent inversion -- with" "") ; (gtk_accel_path "/Tactics/Tactic assumption" "") ; (gtk_accel_path "/Templates/Template Notation" "") ; (gtk_accel_path "/Edit/Cut" "x") ; (gtk_accel_path "/Templates/Template Theorem" "") ; (gtk_accel_path "/Templates/Template Unset Printing Wildcard" "") ; (gtk_accel_path "/Tactics/Tactic constructor" "") ; (gtk_accel_path "/Templates/Template Identity Coercion" "") ; (gtk_accel_path "/Queries/Whelp Locate" "") (gtk_accel_path "/View/Display all low-level contents" "l") ; (gtk_accel_path "/Tactics/Tactic right" "") ; (gtk_accel_path "/Tactics/Tactic elim -- with" "") ; (gtk_accel_path "/Tactics/Tactic cofix" "") ; (gtk_accel_path "/Templates/Template Restore State" "") ; (gtk_accel_path "/Templates/Template Lemma" "") ; (gtk_accel_path "/Tactics/Tactic refine" "") ; (gtk_accel_path "/Templates/Template Section" "") ; (gtk_accel_path "/Tactics/Tactic assert (--:=--)" "") ; (gtk_accel_path "/Edit/Find in buffer" "f") ; (gtk_accel_path "/Tactics/Tactic progress" "") ; (gtk_accel_path "/Templates/Template Add Printing If" "") ; (gtk_accel_path "/Templates/Template Chapter" "") (gtk_accel_path "/File/Print..." "p") ; (gtk_accel_path "/Templates/Template Record" "") ; (gtk_accel_path "/Tactics/Tactic info" "") ; (gtk_accel_path "/Tactics/Tactic firstorder with" "") ; (gtk_accel_path "/Templates/Template Hint Unfold" "") ; (gtk_accel_path "/Templates/Template Set Silent." "") ; (gtk_accel_path "/Templates/Template Program Theorem" "") ; (gtk_accel_path "/Templates/Template Declare ML Module" "") ; (gtk_accel_path "/Tactics/Tactic lazy in" "") ; (gtk_accel_path "/Tactics/Tactic unfold -- in" "") ; (gtk_accel_path "/Edit/Paste" "v") ; (gtk_accel_path "/Templates/Template Remove Printing If" "") ; (gtk_accel_path "/Tactics/Tactic intuition" "") ; (gtk_accel_path "/Queries/SearchAbout" "F2") ; (gtk_accel_path "/Tactics/Tactic dependent rewrite ->" "") ; (gtk_accel_path "/Templates/Template Module" "") ; (gtk_accel_path "/Templates/Template Unset Extraction AutoInline" "") (gtk_accel_path "/Templates/Scheme" "s") ; (gtk_accel_path "/Templates/Template V" "") ; (gtk_accel_path "/Templates/Template Variable" "") ; (gtk_accel_path "/Tactics/Tactic decide equality" "") ; (gtk_accel_path "/Tactics/Tactic instantiate (--:=--)" "") ; (gtk_accel_path "/Templates/Template Syntactic Definition" "") ; (gtk_accel_path "/Templates/Template Set Extraction AutoInline" "") ; (gtk_accel_path "/Templates/Template Unset Undo" "") ; (gtk_accel_path "/Tactics/Tactic dependent inversion" "") ; (gtk_accel_path "/Templates/Template Add Field" "") ; (gtk_accel_path "/Tactics/Tactic setoid--rewrite" "") ; (gtk_accel_path "/Templates/Template Require Export" "") ; (gtk_accel_path "/Tactics/Tactic rewrite <-" "") (gtk_accel_path "/Tactics/omega" "o") ; (gtk_accel_path "/Tactics/Tactic split" "") ; (gtk_accel_path "/File/Quit" "q") (gtk_accel_path "/View/Display existential variable instances" "e") (gtk_accel_path "/Navigation/Start" "Home") ; (gtk_accel_path "/Tactics/Tactic dependent rewrite <-" "") ; (gtk_accel_path "/Templates/Template U" "") ; (gtk_accel_path "/Templates/Template Variables" "") ; (gtk_accel_path "/Templates/Template S" "") ; (gtk_accel_path "/Tactics/Tactic move -- after" "") ; (gtk_accel_path "/Templates/Template Unset Silent." "") ; (gtk_accel_path "/Templates/Template Local" "") ; (gtk_accel_path "/Templates/Template T" "") ; (gtk_accel_path "/Tactics/Tactic reflexivity" "") ; (gtk_accel_path "/Templates/Template R" "") ; (gtk_accel_path "/Templates/Template Time" "") ; (gtk_accel_path "/Templates/Template P" "") ; (gtk_accel_path "/Tactics/Tactic decompose" "") ; (gtk_accel_path "/Templates/Template N" "") ; (gtk_accel_path "/Templates/Template Eval" "") ; (gtk_accel_path "/Tactics/Tactic congruence" "") ; (gtk_accel_path "/Templates/Template O" "") ; (gtk_accel_path "/Templates/Template E" "") ; (gtk_accel_path "/Templates/Template I" "") ; (gtk_accel_path "/Templates/Template H" "") ; (gtk_accel_path "/Templates/Template Extraction Language" "") ; (gtk_accel_path "/Templates/Template M" "") ; (gtk_accel_path "/Templates/Template Derive Inversion" "") ; (gtk_accel_path "/Tactics/Tactic double induction" "") ; (gtk_accel_path "/Templates/Template L" "") ; (gtk_accel_path "/Templates/Template Derive Inversion--clear" "") (gtk_accel_path "/View/Display universe levels" "u") ; (gtk_accel_path "/Templates/Template G" "") ; (gtk_accel_path "/Templates/Template F" "") ; (gtk_accel_path "/Tactics/Tactic dependent inversion--clear -- with" "") ; (gtk_accel_path "/Templates/Template D" "") ; (gtk_accel_path "/Edit/Edit" "") ; (gtk_accel_path "/Tactics/Tactic firstorder" "") ; (gtk_accel_path "/Templates/Template C" "") (gtk_accel_path "/Tactics/simpl" "s") ; (gtk_accel_path "/Tactics/Tactic replace -- with" "") ; (gtk_accel_path "/Templates/Template A" "") ; (gtk_accel_path "/Templates/Template Remove Printing Record" "") ; (gtk_accel_path "/Templates/Template Qed." "") ; (gtk_accel_path "/Templates/Template Program Fixpoint" "") (gtk_accel_path "/View/Display coercions" "c") ; (gtk_accel_path "/Tactics/Tactic hnf" "") ; (gtk_accel_path "/Tactics/Tactic injection" "") ; (gtk_accel_path "/Tactics/Tactic rewrite" "") ; (gtk_accel_path "/Templates/Template Opaque" "") ; (gtk_accel_path "/Templates/Template Focus" "") ; (gtk_accel_path "/Templates/Template Ltac" "") ; (gtk_accel_path "/Tactics/Tactic simple destruct" "") (gtk_accel_path "/View/Display all basic low-level contents" "a") ; (gtk_accel_path "/Tactics/Tactic jp " "") ; (gtk_accel_path "/Templates/Template Test Printing Synth" "") ; (gtk_accel_path "/Tactics/Tactic set" "") ; (gtk_accel_path "/Edit/External editor" "") ; (gtk_accel_path "/View/Show Toolbar" "") (gtk_accel_path "/Edit/Complete Word" "slash") ; (gtk_accel_path "/Tactics/Tactic try" "") (gtk_accel_path "/Templates/Fixpoint" "f") ; (gtk_accel_path "/Tactics/Tactic discriminate" "") (gtk_accel_path "/Navigation/Next" "greater") ; (gtk_accel_path "/Tactics/Tactic elimtype" "") ; (gtk_accel_path "/Templates/Template End" "") ; (gtk_accel_path "/Templates/Template Fixpoint" "") (gtk_accel_path "/View/Next tab" "Right") ; (gtk_accel_path "/File/File" "") ; (gtk_accel_path "/Tactics/Tactic setoid--replace" "") ; (gtk_accel_path "/Tactics/Tactic generalize dependent" "") (gtk_accel_path "/Tactics/trivial" "v") ; (gtk_accel_path "/Tactics/Tactic fix -- with" "") ; (gtk_accel_path "/Tactics/Tactic pose --:=--)" "") ; (gtk_accel_path "/Tactics/Tactic auto with" "") ; (gtk_accel_path "/Templates/Template Add Printing Record" "") ; (gtk_accel_path "/Tactics/Tactic inversion -- in" "") (gtk_accel_path "/Tactics/eauto" "e") ; (gtk_accel_path "/File/Open" "o") ; (gtk_accel_path "/Tactics/Tactic elim -- using" "") ; (gtk_accel_path "/Templates/Template Hint" "") ; (gtk_accel_path "/Tactics/Tactic tauto" "") ; (gtk_accel_path "/Export/Dvi" "") ; (gtk_accel_path "/Tactics/Tactic simpl -- in" "") ; (gtk_accel_path "/Templates/Template Hint Immediate" "") coq-8.4pl4/ide/tags.ml0000644000175000017500000000605012326224777013665 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (*

    \n")) in let () = (List.iter (fun x -> Buffer.add_string b ("\n")) l) in let () = Buffer.add_string b"\n" in b in let () = List.iter (fun b -> Buffer.add_buffer res_buf (tactic_item b)) li in res_buf let init () = let theui = Printf.sprintf " %s %s %s " (if Coq_config.gtk_platform <> `QUARTZ then "" else "") (Buffer.contents (list_items "Tactic" Coq_commands.tactics)) (Buffer.contents (list_items "Template" Coq_commands.commands)) in ignore (ui_m#add_ui_from_string theui); coq-8.4pl4/ide/utils/0000755000175000017500000000000012326224777013534 5ustar stephstephcoq-8.4pl4/ide/utils/editable_cells.ml0000644000175000017500000000667012326224777017032 0ustar stephstephopen GTree open Gobject let create l = let hbox = GPack.hbox () in let scw = GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ~packing:(hbox#pack ~expand:true) () in let columns = new GTree.column_list in let command_col = columns#add Data.string in let coq_col = columns#add Data.string in let store = GTree.list_store columns in (* populate the store *) let _ = List.iter (fun (x,y) -> let row = store#append () in store#set ~row ~column:command_col x; store#set ~row ~column:coq_col y) l in let view = GTree.view ~model:store ~packing:scw#add_with_viewport () in (* Alternate colors for the rows *) view#set_rules_hint true; let renderer_comm = GTree.cell_renderer_text [`EDITABLE true] in ignore (renderer_comm#connect#edited ~callback:(fun (path:Gtk.tree_path) (s:string) -> store#set ~row:(store#get_iter path) ~column:command_col s)); let first = GTree.view_column ~title:"Coq Command to try" ~renderer:(renderer_comm,["text",command_col]) () in ignore (view#append_column first); let renderer_coq = GTree.cell_renderer_text [`EDITABLE true] in ignore(renderer_coq#connect#edited ~callback:(fun (path:Gtk.tree_path) (s:string) -> store#set ~row:(store#get_iter path) ~column:coq_col s)); let second = GTree.view_column ~title:"Coq Command to insert" ~renderer:(renderer_coq,["text",coq_col]) () in ignore (view#append_column second); let vbox = GPack.button_box `VERTICAL ~packing:hbox#pack ~layout:`SPREAD () in let up = GButton.button ~stock:`GO_UP ~label:"Up" ~packing:(vbox#pack ~expand:true ~fill:false) () in let down = GButton.button ~stock:`GO_DOWN ~label:"Down" ~packing:(vbox#pack ~expand:true ~fill:false) () in let add = GButton.button ~stock:`ADD ~label:"Add" ~packing:(vbox#pack ~expand:true ~fill:false) () in let remove = GButton.button ~stock:`REMOVE ~label:"Remove" ~packing:(vbox#pack ~expand:true ~fill:false) () in ignore (add#connect#clicked ~callback:(fun b -> let n = store#append () in view#selection#select_iter n)); ignore (remove#connect#clicked ~callback:(fun b -> match view#selection#get_selected_rows with | [] -> () | path::_ -> let iter = store#get_iter path in ignore (store#remove iter); )); ignore (up#connect#clicked ~callback:(fun b -> match view#selection#get_selected_rows with | [] -> () | path::_ -> let iter = store#get_iter path in ignore (GtkTree.TreePath.prev path); let upiter = store#get_iter path in ignore (store#swap iter upiter); )); ignore (down#connect#clicked ~callback:(fun b -> match view#selection#get_selected_rows with | [] -> () | path::_ -> let iter = store#get_iter path in GtkTree.TreePath.next path; try let upiter = store#get_iter path in ignore (store#swap iter upiter) with _ -> () )); let get_data () = let start_path = GtkTree.TreePath.from_string "0" in let start_iter = store#get_iter start_path in let rec all acc = let new_acc = (store#get ~row:start_iter ~column:command_col, store#get ~row:start_iter ~column:coq_col)::acc in if store#iter_next start_iter then all new_acc else List.rev new_acc in all [] in (hbox,get_data) coq-8.4pl4/ide/utils/okey.mli0000644000175000017500000001202012326224777015201 0ustar stephsteph(*********************************************************************************) (* Cameleon *) (* *) (* Copyright (C) 2005 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. *) (* *) (* This program is free software; you can redistribute it and/or modify *) (* it under the terms of the GNU Library General Public License as *) (* published by the Free Software Foundation; either version 2 of the *) (* License, or any later version. *) (* *) (* This program is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Library General Public License for more details. *) (* *) (* You should have received a copy of the GNU Library General Public *) (* License along with this program; if not, write to the Free Software *) (* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) (* 02111-1307 USA *) (* *) (* Contact: Maxence.Guesdon@inria.fr *) (* *) (*********************************************************************************) (** Okey interface. Once the lib is compiled and installed, you can use it by referencing it with the [Okey] module. You must add [okey.cmo] or [okey.cmx] on the commande line when you link. *) type modifier = Gdk.Tags.modifier (** Set the default modifier list. The first default value is [[]].*) val set_default_modifiers : modifier list -> unit (** Set the default modifier mask. The first default value is [[`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK]]. The mask defines the modifiers not taken into account when looking for the handler of a key press event. *) val set_default_mask : modifier list -> unit (** [add widget key callback] associates the [callback] function to the event "key_press" with the given [key] for the given [widget]. @param remove when true, the previous handlers for the given key and modifier list are not kept. @param cond this function is a guard: the [callback] function is not called if the [cond] function returns [false]. The default [cond] function always returns [true]. @param mods the list of modifiers. If not given, the default modifiers are used. You can set the default modifiers with function {!Okey.set_default_modifiers}. @param mask the list of modifiers which must not be taken into account to trigger the given handler. [mods] and [mask] must not have common modifiers. If not given, the default mask is used. You can set the default modifiers mask with function {!Okey.set_default_mask}. *) val add : < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; event : GObj.event_ops; get_oid : int; .. > -> ?cond: (unit -> bool) -> ?mods: modifier list -> ?mask: modifier list -> Gdk.keysym -> (unit -> unit) -> unit (** It calls {!Okey.add} for each given key.*) val add_list : < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; event : GObj.event_ops; get_oid : int; .. > -> ?cond: (unit -> bool) -> ?mods: modifier list -> ?mask: modifier list -> Gdk.keysym list -> (unit -> unit) -> unit (** Like {!Okey.add} but the previous handlers for the given modifiers and key are not kept.*) val set : < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; event : GObj.event_ops; get_oid : int; .. > -> ?cond: (unit -> bool) -> ?mods: modifier list -> ?mask: modifier list -> Gdk.keysym -> (unit -> unit) -> unit (** It calls {!Okey.set} for each given key.*) val set_list : < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; event : GObj.event_ops; get_oid : int; .. > -> ?cond: (unit -> bool) -> ?mods: modifier list -> ?mask: modifier list -> Gdk.keysym list -> (unit -> unit) -> unit (** Remove the handlers associated to the given widget. This is automatically done when a widget is destroyed but you can do it yourself. *) val remove_widget : < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; event : GObj.event_ops; get_oid : int; .. > -> unit -> unit coq-8.4pl4/ide/utils/config_file.mli0000644000175000017500000003556712326224777016523 0ustar stephsteph(*********************************************************************************) (* Cameleon *) (* *) (* Copyright (C) 2005 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. *) (* *) (* This program is free software; you can redistribute it and/or modify *) (* it under the terms of the GNU Library General Public License as *) (* published by the Free Software Foundation; either version 2 of the *) (* License, or any later version. *) (* *) (* This program is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Library General Public License for more details. *) (* *) (* You should have received a copy of the GNU Library General Public *) (* License along with this program; if not, write to the Free Software *) (* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) (* 02111-1307 USA *) (* *) (* Contact: Maxence.Guesdon@inria.fr *) (* *) (*********************************************************************************) (** This module implements a mechanism to handle configuration files. A configuration file is defined as a set of [variable = value] lines, where value can be a simple string (types int, string, bool...), a list of values between brackets (lists) or parentheses (tuples), or a set of [variable = value] lines between braces. The configuration file is automatically loaded and saved, and configuration parameters are manipulated inside the program as easily as references. Object implementation by Jean-Baptiste Rouquier. *) (** {1:lowlevelinterface Low level interface} *) (** Skip this section on a first reading... *) (** The type of cp freshly parsed from configuration file, not yet wrapped in their proper type. *) module Raw : sig type cp = | String of string (** base types, reproducing the tokens of Genlex *) | Int of int | Float of float | List of cp list (** compound types *) | Tuple of cp list | Section of (string * cp) list (** A parser. *) val of_string : string -> cp (** Used to print the values into a log file for instance. *) val to_channel : out_channel -> cp -> unit end (** A type used to specialize polymorphics classes and define new classes. {!Config_file.predefinedwrappers} are provided. *) type 'a wrappers = { to_raw : 'a -> Raw.cp; of_raw : Raw.cp -> 'a; } (** An exception raised by {!Config_file.cp.set_raw} when the argument doesn't have a suitable {!Config_file.Raw.cp} type. The function explains the problem and flush the output.*) exception Wrong_type of (out_channel -> unit) (* (\** {2 Miscellaneous functions} *\) *) (* val bool_of_string : string -> bool *) (** {1 High level interface} *) (** {2 The two main classes} *) (** A Configuration Parameter, in short cp, ie a value we can store in and read from a configuration file. *) class type ['a] cp = object (** {1 Accessing methods} *) method get : 'a method set : 'a -> unit method get_default : 'a method get_help : string method get_name : string list (** Resets to the default value. *) method reset : unit (** {1 Miscellaneous} *) (** All the hooks are executed each time the method set is called, just after setting the new value.*) method add_hook : ('a -> 'a -> unit) -> unit (** Used to generate command line arguments in {!Config_file.group.command_line_args} *) method set_short_name : string -> unit (** [None] if no optional short_name was provided during object creation and [set_short_name] was never called.*) method get_short_name : string option (** {1 Methods for internal use} *) method get_formatted : Format.formatter -> unit method get_default_formatted : Format.formatter -> unit method get_help_formatted : Format.formatter -> unit method get_spec : Arg.spec method set_raw : Raw.cp -> unit end (** Unification over all possible ['a cp]: contains the main methods of ['a cp] except the methods using the type ['a]. A [group] manipulates only [groupable_cp] for homogeneity. *) type groupable_cp = < get_name : string list; get_short_name : string option; get_help : string; get_formatted : Format.formatter -> unit; get_default_formatted : Format.formatter -> unit; get_help_formatted : Format.formatter -> unit; get_spec : Arg.spec; reset : unit; set_raw : Raw.cp -> unit; > (** Raised in case a name is already used. See {!Config_file.group.add} *) exception Double_name (** An exception possibly raised if we want to check that every cp is defined in a configuration file. See {!Config_file.group.read}. *) exception Missing_cp of groupable_cp (** A group of cps, that can be loaded and saved, or used to generate command line arguments. The basic usage is to have only one group and one configuration file, but this mechanism allows to have more, for instance to have another smaller group for the options to pass on the command line. *) class group : object (** Adds a cp to the group. Note that the type ['a] must be lost to allow cps of different types to belong to the same group. @raise Double_name if [cp#get_name] is already used. *) (* method add : 'a cp -> 'a cp *) method add : 'a cp -> unit (**[write filename] saves all the cps into the configuration file [filename].*) method write : ?with_help:bool -> string -> unit (** [read filename] reads [filename] and stores the values it specifies into the cps belonging to this group. The file is created (and not read) if it doesn't exists. In the default behaviour, no warning is issued if not all cps are updated or if some values of [filename] aren't used. If [obsoletes] is specified, then prints in this file all the values that are in [filename] but not in this group. Those cps are likely to be erroneous or obsolete. Opens this file only if there is something to write in it. If [no_default] is [true], then raises [Missing_cp foo] if the cp [foo] isn't defined in [filename] but belongs to this group. [on_type_error groupable_cp value output filename in_channel] is called if the file doesn't give suitable value (string instead of int for instance, or a string not belonging to the expected enumeration) for the cp [groupable_cp]. [value] is the value read from the file, [output] is the argument of {!Config_file.Wrong_type}, [filename] is the same argument as the one given to read, and [in_channel] refers to [filename] to allow a function to close it if needed. Default behaviour is to print an error message and call [exit 1]. *) method read : ?obsoletes:string -> ?no_default:bool -> ?on_type_error : (groupable_cp -> Raw.cp -> (out_channel -> unit) -> string -> in_channel -> unit) -> string -> unit (** Interface with module Arg. @param section_separator the string used to concatenate the name of a cp, to get the command line option name. ["-"] is a good default. @return a list that can be used with [Arg.parse] and [Arg.usage].*) method command_line_args : section_separator:string -> (string * Arg.spec * string) list end (** {2 Predefined cp classes} *) (** The last three non-optional arguments are always [name] (of type string list), [default_value] and [help] (of type string). [name] is the path to the cp: [["section";"subsection"; ...; "foo"]]. It can consists of a single element but must not be empty. [short_name] will be added a "-" and used in {!Config_file.group.command_line_args}. [group], if provided, adds the freshly defined option to it (something like [initializer group#add self]). [help] needs not contain newlines, it will be automatically truncated where needed. It is mandatory but can be [""]. *) class int_cp : ?group:group -> string list -> ?short_name:string -> int -> string -> [int] cp class float_cp : ?group:group -> string list -> ?short_name:string -> float -> string -> [float] cp class bool_cp : ?group:group -> string list -> ?short_name:string -> bool -> string -> [bool] cp class string_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> [string] cp class ['a] list_cp : 'a wrappers -> ?group:group -> string list -> ?short_name:string -> 'a list -> string -> ['a list] cp class ['a] option_cp : 'a wrappers -> ?group:group -> string list -> ?short_name:string -> 'a option -> string -> ['a option] cp class ['a] enumeration_cp : (string * 'a) list -> ?group:group -> string list -> ?short_name:string -> 'a -> string -> ['a] cp class ['a, 'b] tuple2_cp : 'a wrappers -> 'b wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b -> string -> ['a * 'b] cp class ['a, 'b, 'c] tuple3_cp : 'a wrappers -> 'b wrappers -> 'c wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b * 'c -> string -> ['a * 'b * 'c] cp class ['a, 'b, 'c, 'd] tuple4_cp : 'a wrappers -> 'b wrappers -> 'c wrappers -> 'd wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b * 'c * 'd -> string -> ['a * 'b * 'c * 'd] cp class string2_cp : ?group:group -> string list -> ?short_name:string -> string * string -> string -> [string, string] tuple2_cp (* class color_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp *) class font_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp class filename_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp (** {2:predefinedwrappers Predefined wrappers} *) val int_wrappers : int wrappers val float_wrappers : float wrappers val bool_wrappers : bool wrappers val string_wrappers : string wrappers val list_wrappers : 'a wrappers -> 'a list wrappers val option_wrappers : 'a wrappers -> 'a option wrappers (** If you have a [type suit = Spades | Hearts | Diamond | Clubs], then {[enumeration_wrappers ["spades",Spades; "hearts",Hearts; "diamond",Diamond; "clubs",Clubs]]} will allow you to use cp of this type. For sum types with not only constant constructors, you will need to define your own cp class. *) val enumeration_wrappers : (string * 'a) list -> 'a wrappers val tuple2_wrappers : 'a wrappers -> 'b wrappers -> ('a * 'b) wrappers val tuple3_wrappers : 'a wrappers -> 'b wrappers -> 'c wrappers -> ('a * 'b * 'c) wrappers val tuple4_wrappers : 'a wrappers -> 'b wrappers -> 'c wrappers -> 'd wrappers -> ('a * 'b * 'c * 'd) wrappers (** {2 Defining new cp classes} *) (** To define a new cp class, you just have to provide an implementation for the wrappers between your type [foo] and the type [Raw.cp]. Once you have your wrappers [w], write {[class foo_cp = [foo] cp_custom_type w]} For further details, have a look at the commented .ml file, section "predefined cp classes". *) class ['a] cp_custom_type : 'a wrappers -> ?group:group -> string list -> ?short_name:string -> 'a -> string -> ['a] cp (** {1 Backward compatibility} Deprecated. All the functions from the module Options are available, except: - [prune_file]: use [group#write ?obsoletes:"foo.ml"]. - [smalllist_to_value], [smalllist_option]: use lists or tuples. - [get_class]. - [class_hook]: hooks are local to a cp. If you want hooks global to a class, define a new class that inherit from {!Config_file.cp_custom_type}. - [set_simple_option], [get_simple_option], [simple_options], [simple_args]: use {!Config_file.group.write}. - [set_option_hook]: use {!Config_file.cp.add_hook}. - [set_string_wrappers]: define a new class with {!Config_file.cp_custom_type}. The old configurations files are readable by this module. *) (**/**) type 'a option_class type 'a option_record type options_file val create_options_file : string -> options_file val set_options_file : options_file -> string -> unit val load : options_file -> unit val append : options_file -> string -> unit val save : options_file -> unit val save_with_help : options_file -> unit (* val define_option : options_file -> *) (* string list -> string -> 'a option_class -> 'a -> 'a option_record *) val option_hook : 'a option_record -> (unit -> unit) -> unit val string_option : string option_class val color_option : string option_class val font_option : string option_class val int_option : int option_class val bool_option : bool option_class val float_option : float option_class val string2_option : (string * string) option_class val option_option : 'a option_class -> 'a option option_class val list_option : 'a option_class -> 'a list option_class val sum_option : (string * 'a) list -> 'a option_class val tuple2_option : 'a option_class * 'b option_class -> ('a * 'b) option_class val tuple3_option : 'a option_class * 'b option_class * 'c option_class -> ('a * 'b * 'c) option_class val tuple4_option : 'a option_class * 'b option_class * 'c option_class * 'd option_class -> ('a * 'b * 'c * 'd) option_class val ( !! ) : 'a option_record -> 'a val ( =:= ) : 'a option_record -> 'a -> unit val shortname : 'a option_record -> string val get_help : 'a option_record -> string type option_value = Module of option_module | StringValue of string | IntValue of int | FloatValue of float | List of option_value list | SmallList of option_value list and option_module = (string * option_value) list val define_option_class : string -> (option_value -> 'a) -> ('a -> option_value) -> 'a option_class val to_value : 'a option_class -> 'a -> option_value val from_value : 'a option_class -> option_value -> 'a val value_to_string : option_value -> string val string_to_value : string -> option_value val value_to_int : option_value -> int val int_to_value : int -> option_value val bool_of_string : string -> bool val value_to_bool : option_value -> bool val bool_to_value : bool -> option_value val value_to_float : option_value -> float val float_to_value : float -> option_value val value_to_string2 : option_value -> string * string val string2_to_value : string * string -> option_value val value_to_list : (option_value -> 'a) -> option_value -> 'a list val list_to_value : ('a -> option_value) -> 'a list -> option_value coq-8.4pl4/ide/utils/configwin_messages.ml0000644000175000017500000000476312326224777017752 0ustar stephsteph(*********************************************************************************) (* Cameleon *) (* *) (* Copyright (C) 2005 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. *) (* *) (* This program is free software; you can redistribute it and/or modify *) (* it under the terms of the GNU Library General Public License as *) (* published by the Free Software Foundation; either version 2 of the *) (* License, or any later version. *) (* *) (* This program is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Library General Public License for more details. *) (* *) (* You should have received a copy of the GNU Library General Public *) (* License along with this program; if not, write to the Free Software *) (* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) (* 02111-1307 USA *) (* *) (* Contact: Maxence.Guesdon@inria.fr *) (* *) (*********************************************************************************) (** Module containing the messages of Configwin.*) let software = "Configwin";; let version = "1.2";; let html_config = "Configwin bindings configurator for html parameters" let home = Minilib.home let mCapture = "Capture";; let mType_key = "Type key" ;; let mAdd = "Add";; let mRemove = "Remove";; let mUp = "Up";; let mEdit = "Edit";; let mOk = "Ok";; let mCancel = "Cancel";; let mApply = "Apply";; let mValue = "Value" let mKey = "Key" let shortcuts = "Shortcuts" let html_end = "End with" let html_begin = "Begin with" coq-8.4pl4/ide/utils/config_file.ml0000644000175000017500000007050412326224777016340 0ustar stephsteph(*********************************************************************************) (* Cameleon *) (* *) (* Copyright (C) 2005 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. *) (* *) (* This program is free software; you can redistribute it and/or modify *) (* it under the terms of the GNU Library General Public License as *) (* published by the Free Software Foundation; either version 2 of the *) (* License, or any later version. *) (* *) (* This program is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Library General Public License for more details. *) (* *) (* You should have received a copy of the GNU Library General Public *) (* License along with this program; if not, write to the Free Software *) (* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) (* 02111-1307 USA *) (* *) (* Contact: Maxence.Guesdon@inria.fr *) (* *) (*********************************************************************************) (* TODO *) (* section comments *) (* better obsoletes: no "{}", line cuts *) (* possible improvements: *) (* use lex/yacc instead of genlex to be more robust, efficient, allow arrays and other types, read comments. *) (* description and help, level (beginner/advanced/...) for each cp *) (* find an option from its name and group *) (* class hooks *) (* get the sections of a group / of a file *) (* read file format from inifiles and ConfigParser *) (* Read the mli before reading this file! *) (* ******************************************************************************** *) (* ******************************** misc utilities ******************************** *) (* ******************************************************************************** *) (* This code is intended to be usable without any dependencies. *) (* pipeline style, see for instance Raw.of_channel. *) let (|>) x f = f x (* as List.assoc, but applies f to the element matching [key] and returns the list where this element has been replaced by the result of f. *) let rec list_assoc_remove key f = function | [] -> raise Not_found | (key',value) as elt :: tail -> if key <> key' then elt :: list_assoc_remove key f tail else match f value with | None -> tail | Some a -> (key',a) :: tail (* reminiscent of String.concat. Same as [Queue.iter f1 queue] but calls [f2 ()] between each calls to f1. Does not call f2 before the first call nor after the last call to f2. Could be more efficient with a richer module interface of Queue. *) let queue_iter_between f1 f2 queue = (* let f flag elt = if flag then f2 (); (f1 elt:unit); true in *) let f flag elt = if flag then f2 (); f1 elt; true in ignore (Queue.fold f false queue) let list_iter_between f1 f2 = function [] -> () | a::[] -> f1 a | a::tail -> f1 a; List.iter (fun elt -> (f2 ():unit); f1 elt) tail (* | a::tail -> f1 a; List.iter (fun elt -> f2 (); f1 elt) tail *) (* !! types ??? *) (* to ensure that strings will be parsed correctly by Genlex. It's more comfortable not to have quotes around the string, but sometimes it's necessary. *) exception Unsafe_string let safe_string s = if s = "" then "\"\"" else if ( try match s.[0] with | 'a'..'z' | 'A'..'Z' -> for i = 1 to String.length s - 1 do match s.[i] with 'a'..'z' | 'A'..'Z' | '_' | '0'..'9' -> () | _ -> raise Unsafe_string done; false | _ -> try string_of_int (int_of_string s) <> s || string_of_float (float_of_string s) <> s with Failure "int_of_string" | Failure "float_of_string" -> true with Unsafe_string -> true) then Printf.sprintf "\"%s\"" (String.escaped s) else s (* ******************************************************************************** *) (* ************************************* core ************************************* *) (* ******************************************************************************** *) module Raw = struct type cp = | String of string | Int of int | Float of float | List of cp list | Tuple of cp list | Section of (string * cp) list (* code generated by camlp4 pa_o.cmo pa_op.cmo pr_o.cmo -- -o config_file_parser.ml -impl config_file_parser.ml4 Unreadable on purpose, edit the file config_file_parser.ml4 rather than editing this (huge) lines. Then manually copy-paste here the content of config_file_parser.ml. Could be one day rewritten with ocamllex/yacc to be more robust, efficient, allow arrays, read comments...*) module Parse = struct let lexer = Genlex.make_lexer ["="; "{"; "}"; "["; "]"; ";"; "("; ")"; ","] let rec file l (strm__ : _ Stream.t) = match try Some (ident strm__) with Stream.Failure -> None with Some id -> begin match Stream.peek strm__ with Some (Genlex.Kwd "=") -> Stream.junk strm__; let v = try value strm__ with Stream.Failure -> raise (Stream.Error "") in begin try file ((id, v) :: l) strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> raise (Stream.Error "") end | _ -> List.rev l and value (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Kwd "{") -> Stream.junk strm__; let v = try file [] strm__ with Stream.Failure -> raise (Stream.Error "") in begin match Stream.peek strm__ with Some (Genlex.Kwd "}") -> Stream.junk strm__; Section v | _ -> raise (Stream.Error "") end | Some (Genlex.Ident s) -> Stream.junk strm__; String s | Some (Genlex.String s) -> Stream.junk strm__; String s | Some (Genlex.Int i) -> Stream.junk strm__; Int i | Some (Genlex.Float f) -> Stream.junk strm__; Float f | Some (Genlex.Char c) -> Stream.junk strm__; String (String.make 1 c) | Some (Genlex.Kwd "[") -> Stream.junk strm__; let v = try list [] strm__ with Stream.Failure -> raise (Stream.Error "") in List v | Some (Genlex.Kwd "(") -> Stream.junk strm__; let v = try list [] strm__ with Stream.Failure -> raise (Stream.Error "") in Tuple v | _ -> raise Stream.Failure and ident (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Ident s) -> Stream.junk strm__; s | Some (Genlex.String s) -> Stream.junk strm__; s | _ -> raise Stream.Failure and list l (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Kwd ";") -> Stream.junk strm__; begin try list l strm__ with Stream.Failure -> raise (Stream.Error "") end | Some (Genlex.Kwd ",") -> Stream.junk strm__; begin try list l strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> match try Some (value strm__) with Stream.Failure -> None with Some v -> begin try list (v :: l) strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> match Stream.peek strm__ with Some (Genlex.Kwd "]") -> Stream.junk strm__; List.rev l | Some (Genlex.Kwd ")") -> Stream.junk strm__; List.rev l | _ -> raise Stream.Failure end open Format (* formating convention: the caller has to open the box, close it and flush the output *) (* remarks on Format: set_margin impose un appel ā set_max_indent sprintf et bprintf sont flushées ā chaque appel*) (* pretty print a Raw.cp *) let rec save formatter = function | String s -> fprintf formatter "%s" (safe_string s) (* How can I cut lines and *) | Int i -> fprintf formatter "%d" i (* print backslashes just before the \n? *) | Float f -> fprintf formatter "%g" f | List l -> fprintf formatter "[@["; list_iter_between (fun v -> fprintf formatter "@["; save formatter v; fprintf formatter "@]") (fun () -> fprintf formatter ";@ ") l; fprintf formatter "@]]" | Tuple l -> fprintf formatter "(@["; list_iter_between (fun v -> fprintf formatter "@["; save formatter v; fprintf formatter "@]") (fun () -> fprintf formatter ",@ ") l; fprintf formatter "@])" | Section l -> fprintf formatter "{@;<0 2>@["; list_iter_between (fun (name,value) -> fprintf formatter "@[%s =@ @[" name; save formatter value; fprintf formatter "@]@]";) (fun () -> fprintf formatter "@;<2 0>") l; fprintf formatter "@]}" (* let to_string r = save str_formatter r; flush_str_formatter () *) let to_channel out_channel r = let f = formatter_of_out_channel out_channel in fprintf f "@["; save f r; fprintf f "@]@?" let of_string s = s |> Stream.of_string |> Parse.lexer |> Parse.value let of_channel in_channel = let result = in_channel |> Stream.of_channel |> Parse.lexer |> Parse.file [] in close_in in_channel; result end (* print the given string in a way compatible with Format. Truncate the lines when needed, indent the newlines.*) let print_help formatter = String.iter (function | ' ' -> Format.pp_print_space formatter () | '\n' -> Format.pp_force_newline formatter () | c -> Format.pp_print_char formatter c) type 'a wrappers = { to_raw : 'a -> Raw.cp; of_raw : Raw.cp -> 'a} class type ['a] cp = object (* method private to_raw = wrappers.to_raw *) (* method private of_raw = wrappers.of_raw *) (* method private set_string s = s |> Raw.of_string |> self#of_raw |> self#set *) method add_hook : ('a -> 'a -> unit) -> unit method get : 'a method get_default : 'a method set : 'a -> unit method reset : unit method get_formatted : Format.formatter -> unit method get_default_formatted : Format.formatter -> unit method get_help_formatted : Format.formatter -> unit method get_name : string list method get_short_name : string option method set_short_name : string -> unit method get_help : string method get_spec : Arg.spec method set_raw : Raw.cp -> unit end type groupable_cp = < get_name : string list; get_short_name : string option; get_help : string; get_formatted : Format.formatter -> unit; get_default_formatted : Format.formatter -> unit; get_help_formatted : Format.formatter -> unit; get_spec : Arg.spec; reset : unit; set_raw : Raw.cp -> unit; > exception Double_name exception Missing_cp of groupable_cp exception Wrong_type of (out_channel -> unit) (* Two exceptions to stop the iteration on queues. *) exception Found exception Found_cp of groupable_cp (* The data structure to store the cps. It's a tree, each node is a section, and a queue of sons with their name. Each leaf contains a cp. *) type 'a nametree = | Immediate of 'a | Subsection of ((string * 'a nametree) Queue.t) (* this Queue must be nonempty for group.read.choose *) class group = object (self) val mutable cps = Queue.create () (* hold all the added cps, in a nametree. *) method add : 'a. 'a cp -> unit = fun original_cp -> let cp = (original_cp :> groupable_cp) in (* function called when we reach the end of the list cp#get_name. *) let add_immediate name cp queue = Queue.iter (fun (name',_) -> if name = name' then raise Double_name) queue; Queue.push (name, Immediate cp) queue in (* adds the cp with name [first_name::last_name] in section [section]. *) let rec add_in_section section first_name last_name cp queue = let sub_add = match last_name with (* what to do once we have find the correct section *) | [] -> add_immediate first_name | middle_name :: last_name -> add_in_section first_name middle_name last_name in try Queue.iter (function | name, Subsection subsection when name = section -> sub_add cp subsection; raise Found | _ -> ()) queue; let sub_queue = Queue.create () in sub_add cp sub_queue; Queue.push (section, Subsection sub_queue) queue with Found -> () in (match cp#get_name with | [] -> failwith "empty name" | first_name :: [] -> add_immediate first_name cp cps | first_name :: middle_name :: last_name -> add_in_section first_name middle_name last_name cp cps) method write ?(with_help=true) filename = let out_channel = open_out filename in let formatter = Format.formatter_of_out_channel out_channel in let print = Format.fprintf formatter in print "@["; let rec save_queue formatter = queue_iter_between (fun (name,nametree) -> save_nametree name nametree) (Format.pp_print_cut formatter) and save_nametree name = function | Immediate cp -> if with_help && cp#get_help <> "" then (print "@[(* "; cp#get_help_formatted formatter; print "@ *)@]@,"); Format.fprintf formatter "@[%s =@ @[" (safe_string name); cp#get_formatted formatter; print "@]@]" | Subsection queue -> Format.fprintf formatter "%s = {@;<0 2>@[" (safe_string name); save_queue formatter queue; print "@]@,}" in save_queue formatter cps; print "@]@."; close_out out_channel method read ?obsoletes ?(no_default=false) ?(on_type_error = fun groupable_cp raw_cp output filename in_channel -> close_in in_channel; Printf.eprintf "Type error while loading configuration parameter %s from file %s.\n%!" (String.concat "." groupable_cp#get_name) filename; output stderr; exit 1) filename = (* [filename] is created if it doesn't exist. In this case there is no need to read it. *) match Sys.file_exists filename with false -> self#write filename | true -> let in_channel = open_in filename in (* what to do when a cp is missing: *) let missing cp default = if no_default then raise (Missing_cp cp) else default in (* returns a cp contained in the nametree queue, which must be nonempty *) let choose queue = let rec iter q = Queue.iter (function | _, Immediate cp -> raise (Found_cp cp) | _, Subsection q -> iter q) q in try iter queue; failwith "choose" with Found_cp cp -> cp in (* [set_and_remove raw_cps nametree] sets the cp of [nametree] to their value defined in [raw_cps] and returns the remaining raw_cps. *) let set_cp cp value = try cp#set_raw value with Wrong_type output -> on_type_error cp value output filename in_channel in let rec set_and_remove raw_cps = function | name, Immediate cp -> (try list_assoc_remove name (fun value -> set_cp cp value; None) raw_cps with Not_found -> missing cp raw_cps) | name, Subsection queue -> (try list_assoc_remove name (function | Raw.Section l -> (match remainings l queue with | [] -> None | l -> Some (Raw.Section l)) | r -> missing (choose queue) (Some r)) raw_cps with Not_found -> missing (choose queue) raw_cps) and remainings raw_cps queue = Queue.fold set_and_remove raw_cps queue in let remainings = remainings (Raw.of_channel in_channel) cps in (* Handling of cps defined in filename but not belonging to self. *) if remainings <> [] then match obsoletes with | Some filename -> let out_channel = open_out filename in (* open_out_gen [Open_wronly; Open_creat; Open_append; Open_text] 0o666 filename in *) let formatter = Format.formatter_of_out_channel out_channel in Format.fprintf formatter "@["; Raw.save formatter (Raw.Section remainings); Format.fprintf formatter "@]@."; close_out out_channel | None -> () method command_line_args ~section_separator = let print = Format.fprintf Format.str_formatter in (* shortcut *) let result = ref [] in let push x = result := x :: !result in let rec iter = function | _, Immediate cp -> let key = "-" ^ String.concat section_separator cp#get_name in let spec = cp#get_spec in let doc = ( print "@["; Format.pp_print_as Format.str_formatter (String.length key +3) ""; if cp#get_help <> "" then (print "@,@["; cp#get_help_formatted Format.str_formatter; print "@]@ ") else print "@,"; print "@[@[current:@;<1 2>@["; cp#get_formatted Format.str_formatter; print "@]@],@ @[default:@;<1 2>@["; cp#get_default_formatted Format.str_formatter; print "@]@]@]@]"; Format.flush_str_formatter ()) in (match cp#get_short_name with | None -> () | Some short_name -> push ("-" ^ short_name,spec,"")); push (key,spec,doc) | _, Subsection queue -> Queue.iter iter queue in Queue.iter iter cps; List.rev !result end (* Given wrappers for the type 'a, cp_custom_type defines a class 'a cp. *) class ['a] cp_custom_type wrappers ?group:(group:group option) name ?short_name default help = object (self) method private to_raw = wrappers.to_raw method private of_raw = wrappers.of_raw val mutable value = default (* output *) method get = value method get_default = default method get_formatted formatter = self#get |> self#to_raw |> Raw.save formatter method get_default_formatted formatter = self#get_default |> self#to_raw |> Raw.save formatter (* input *) method set v = let v' = value in value <- v; self#exec_hooks v' v method set_raw v = self#of_raw v |> self#set method private set_string s = s |> Raw.of_string |> self#of_raw |> self#set method reset = self#set self#get_default (* name *) val mutable shortname = short_name method get_name = name method get_short_name = shortname method set_short_name s = shortname <- Some s (* help *) method get_help = help method get_help_formatted formatter = print_help formatter self#get_help method get_spec = Arg.String self#set_string (* hooks *) val mutable hooks = [] method add_hook f = hooks <- (f:'a->'a->unit) :: hooks method private exec_hooks v' v = List.iter (fun f -> f v' v) hooks initializer match group with Some g -> g#add (self :> 'a cp) | None -> () end (* ******************************************************************************** *) (* ****************************** predefined classes ****************************** *) (* ******************************************************************************** *) let int_wrappers = { to_raw = (fun v -> Raw.Int v); of_raw = function | Raw.Int v -> v | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan "Raw.Int expected, got %a\n%!" Raw.to_channel r))} class int_cp ?group name ?short_name default help = object (self) inherit [int] cp_custom_type int_wrappers ?group name ?short_name default help method get_spec = Arg.Int self#set end let float_wrappers = { to_raw = (fun v -> Raw.Float v); of_raw = function | Raw.Float v -> v | Raw.Int v -> float v | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan "Raw.Float expected, got %a\n%!" Raw.to_channel r)) } class float_cp ?group name ?short_name default help = object (self) inherit [float] cp_custom_type float_wrappers ?group name ?short_name default help method get_spec = Arg.Float self#set end (* The Pervasives version is too restrictive *) let bool_of_string s = match String.lowercase s with | "false" | "no" | "n" | "0" -> false (* "0" and "1" aren't used. *) | "true" | "yes" | "y" | "1" -> true | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan "Raw.Bool expected, got %s\n%!" r)) let bool_wrappers = { to_raw = (fun v -> Raw.String (string_of_bool v)); of_raw = function | Raw.String v -> bool_of_string v | Raw.Int v -> v <> 0 | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan "Raw.Bool expected, got %a\n%!" Raw.to_channel r)) } class bool_cp ?group name ?short_name default help = object (self) inherit [bool] cp_custom_type bool_wrappers ?group name ?short_name default help method get_spec = Arg.Bool self#set end let string_wrappers = { to_raw = (fun v -> Raw.String v); of_raw = function | Raw.String v -> v | Raw.Int v -> string_of_int v | Raw.Float v -> string_of_float v | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan "Raw.String expected, got %a\n%!" Raw.to_channel r)) } class string_cp ?group name ?short_name default help = object (self) inherit [string] cp_custom_type string_wrappers ?group name ?short_name default help method private of_string s = s method get_spec = Arg.String self#set end let list_wrappers wrappers = { to_raw = (fun l -> Raw.List (List.map wrappers.to_raw l)); of_raw = function | Raw.List l -> List.map wrappers.of_raw l | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan "Raw.List expected, got %a\n%!" Raw.to_channel r)) } class ['a] list_cp wrappers = ['a list] cp_custom_type (list_wrappers wrappers) let option_wrappers wrappers = { to_raw = (function | Some v -> wrappers.to_raw v | None -> Raw.String ""); of_raw = function | Raw.String s as v -> ( if s = "" || s = "None" then None else if String.length s >= 5 && String.sub s 0 5 = "Some " then Some (wrappers.of_raw (Raw.String (String.sub s 5 (String.length s -5)))) else Some (wrappers.of_raw v)) | r -> Some (wrappers.of_raw r)} class ['a] option_cp wrappers = ['a option] cp_custom_type (option_wrappers wrappers) let enumeration_wrappers enum = let switched = List.map (fun (string,cons) -> cons,string) enum in {to_raw = (fun v -> Raw.String (List.assq v switched)); of_raw = function | Raw.String s -> (try List.assoc s enum with Not_found -> failwith (Printf.sprintf "%s isn't a known constructor" s)) | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan "Raw enumeration expected, got %a\n%!" Raw.to_channel r)) } class ['a] enumeration_cp enum ?group name ?short_name default help = object (self) inherit ['a] cp_custom_type (enumeration_wrappers enum) ?group name ?short_name default help method get_spec = Arg.Symbol (List.map fst enum, (fun s -> self#set (List.assoc s enum))) end let tuple2_wrappers wrapa wrapb = { to_raw = (fun (a,b) -> Raw.Tuple [wrapa.to_raw a; wrapb.to_raw b]); of_raw = function | Raw.Tuple [a;b] -> wrapa.of_raw a, wrapb.of_raw b | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan "Raw.Tuple 2 expected, got %a\n%!" Raw.to_channel r)) } class ['a, 'b] tuple2_cp wrapa wrapb = ['a*'b] cp_custom_type (tuple2_wrappers wrapa wrapb) let tuple3_wrappers wrapa wrapb wrapc = { to_raw = (fun (a,b,c) -> Raw.Tuple[wrapa.to_raw a; wrapb.to_raw b; wrapc.to_raw c]); of_raw = function | Raw.Tuple [a;b;c] -> wrapa.of_raw a, wrapb.of_raw b, wrapc.of_raw c | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan "Raw.Tuple 3 expected, got %a\n%!" Raw.to_channel r)) } class ['a,'b,'c] tuple3_cp wrapa wrapb wrapc = ['a*'b*'c] cp_custom_type (tuple3_wrappers wrapa wrapb wrapc) let tuple4_wrappers wrapa wrapb wrapc wrapd = { to_raw=(fun (a,b,c,d)->Raw.Tuple[wrapa.to_raw a;wrapb.to_raw b;wrapc.to_raw c;wrapd.to_raw d]); of_raw = function | Raw.Tuple [a;b;c;d] -> wrapa.of_raw a, wrapb.of_raw b, wrapc.of_raw c, wrapd.of_raw d | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan "Raw.Tuple 4 expected, got %a\n%!" Raw.to_channel r)) } class ['a,'b,'c,'d] tuple4_cp wrapa wrapb wrapc wrapd = ['a*'b*'c*'d] cp_custom_type (tuple4_wrappers wrapa wrapb wrapc wrapd) class string2_cp = [string,string] tuple2_cp string_wrappers string_wrappers (* class color_cp = string_cp *) class font_cp = string_cp class filename_cp = string_cp (* ******************************************************************************** *) (******************** Backward compatibility with module Flags.****************** *) (* ******************************************************************************** *) type 'a option_class = 'a wrappers type 'a option_record = 'a cp type options_file = {mutable filename:string; group:group} let create_options_file filename = {filename = filename; group = new group} let set_options_file options_file filename = options_file.filename <- filename let load {filename=f; group = g} = g#read f let append {group=g} filename = g#read filename let save {filename=f; group = g} = g#write ~with_help:false f let save_with_help {filename=f; group = g} = g#write ~with_help:true f let define_option {group=group} name help option_class default = (new cp_custom_type option_class ~group name default help) let option_hook cp f = cp#add_hook (fun _ _ -> f ()) let string_option = string_wrappers let color_option = string_wrappers let font_option = string_wrappers let int_option = int_wrappers let bool_option = bool_wrappers let float_option = float_wrappers let string2_option = tuple2_wrappers string_wrappers string_wrappers let option_option = option_wrappers let list_option = list_wrappers let sum_option = enumeration_wrappers let tuple2_option (a,b) = tuple2_wrappers a b let tuple3_option (a,b,c) = tuple3_wrappers a b c let tuple4_option (a,b,c,d) = tuple4_wrappers a b c d let ( !! ) cp = cp#get let ( =:= ) cp value = cp#set value let shortname cp = String.concat ":" cp#get_name let get_help cp = cp#get_help type option_value = Module of option_module | StringValue of string | IntValue of int | FloatValue of float | List of option_value list | SmallList of option_value list and option_module = (string * option_value) list let rec value_to_raw = function | Module a -> Raw.Section (List.map (fun (name,value) -> name, value_to_raw value) a) | StringValue a -> Raw.String a | IntValue a -> Raw.Int a | FloatValue a -> Raw.Float a | List a -> Raw.List (List.map value_to_raw a) | SmallList a -> Raw.Tuple (List.map value_to_raw a) let rec raw_to_value = function | Raw.String a -> StringValue a | Raw.Int a -> IntValue a | Raw.Float a -> FloatValue a | Raw.List a -> List (List.map raw_to_value a) | Raw.Tuple a -> SmallList (List.map raw_to_value a) | Raw.Section a -> Module (List.map (fun (name,value) -> name, raw_to_value value) a) let define_option_class _ of_option_value to_option_value = {to_raw = (fun a -> a |> to_option_value |> value_to_raw); of_raw = (fun a -> a |> raw_to_value |> of_option_value)} let to_value {to_raw = to_raw} a = a |> to_raw |> raw_to_value let from_value {of_raw = of_raw} a = a |> value_to_raw |> of_raw let of_value_w wrappers a = a |> value_to_raw |> wrappers.of_raw let to_value_w wrappers a = a |> wrappers.to_raw |> raw_to_value (* fancy indentation when finishing this stub code, not good style :-) *) let value_to_string : option_value -> string = of_value_w string_option let string_to_value = to_value_w string_option let value_to_int = of_value_w int_option let int_to_value = to_value_w int_option let value_to_bool = of_value_w bool_option let bool_to_value = to_value_w bool_option let value_to_float = of_value_w float_option let float_to_value = to_value_w float_option let value_to_string2 = of_value_w string2_option let string2_to_value = to_value_w string2_option let value_to_list of_value = let wrapper = define_option_class "" of_value (fun _ -> failwith "value_to_list") in of_value_w (list_option wrapper) let list_to_value to_value = let wrapper = define_option_class "" (fun _ -> failwith "value_to_list") to_value in to_value_w (list_option wrapper) coq-8.4pl4/ide/utils/configwin_keys.ml0000644000175000017500000034230012326224777017106 0ustar stephsteph(*********************************************************************************) (* Cameleon *) (* *) (* Copyright (C) 2005 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. *) (* *) (* This program is free software; you can redistribute it and/or modify *) (* it under the terms of the GNU Library General Public License as *) (* published by the Free Software Foundation; either version 2 of the *) (* License, or any later version. *) (* *) (* This program is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Library General Public License for more details. *) (* *) (* You should have received a copy of the GNU Library General Public *) (* License along with this program; if not, write to the Free Software *) (* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) (* 02111-1307 USA *) (* *) (* Contact: Maxence.Guesdon@inria.fr *) (* *) (*********************************************************************************) (** Key codes Ce fichier provient de X11/keysymdef.h les noms des symboles deviennent : XK_ -> xk_ Thanks to Fabrice Le Fessant. *) let xk_VoidSymbol = 0xFFFFFF (** void symbol *) (** TTY Functions, cleverly chosen to map to ascii, for convenience of programming, but could have been arbitrary (at the cost of lookup tables in client code. *) let xk_BackSpace = 0xFF08 (** back space, back char *) let xk_Tab = 0xFF09 let xk_Linefeed = 0xFF0A (** Linefeed, LF *) let xk_Clear = 0xFF0B let xk_Return = 0xFF0D (** Return, enter *) let xk_Pause = 0xFF13 (** Pause, hold *) let xk_Scroll_Lock = 0xFF14 let xk_Sys_Req = 0xFF15 let xk_Escape = 0xFF1B let xk_Delete = 0xFFFF (** Delete, rubout *) (** International & multi-key character composition *) let xk_Multi_key = 0xFF20 (** Multi-key character compose *) (** Japanese keyboard support *) let xk_Kanji = 0xFF21 (** Kanji, Kanji convert *) let xk_Muhenkan = 0xFF22 (** Cancel Conversion *) let xk_Henkan_Mode = 0xFF23 (** Start/Stop Conversion *) let xk_Henkan = 0xFF23 (** Alias for Henkan_Mode *) let xk_Romaji = 0xFF24 (** to Romaji *) let xk_Hiragana = 0xFF25 (** to Hiragana *) let xk_Katakana = 0xFF26 (** to Katakana *) let xk_Hiragana_Katakana = 0xFF27 (** Hiragana/Katakana toggle *) let xk_Zenkaku = 0xFF28 (** to Zenkaku *) let xk_Hankaku = 0xFF29 (** to Hankaku *) let xk_Zenkaku_Hankaku = 0xFF2A (** Zenkaku/Hankaku toggle *) let xk_Touroku = 0xFF2B (** Add to Dictionary *) let xk_Massyo = 0xFF2C (** Delete from Dictionary *) let xk_Kana_Lock = 0xFF2D (** Kana Lock *) let xk_Kana_Shift = 0xFF2E (** Kana Shift *) let xk_Eisu_Shift = 0xFF2F (** Alphanumeric Shift *) let xk_Eisu_toggle = 0xFF30 (** Alphanumeric toggle *) (** = 0xFF31 thru = 0xFF3F are under xk_KOREAN *) (** Cursor control & motion *) let xk_Home = 0xFF50 let xk_Left = 0xFF51 (** Move left, left arrow *) let xk_Up = 0xFF52 (** Move up, up arrow *) let xk_Right = 0xFF53 (** Move right, right arrow *) let xk_Down = 0xFF54 (** Move down, down arrow *) let xk_Prior = 0xFF55 (** Prior, previous *) let xk_Page_Up = 0xFF55 let xk_Next = 0xFF56 (** Next *) let xk_Page_Down = 0xFF56 let xk_End = 0xFF57 (** EOL *) let xk_Begin = 0xFF58 (** BOL *) (** Misc Functions *) let xk_Select = 0xFF60 (** Select, mark *) let xk_Print = 0xFF61 let xk_Execute = 0xFF62 (** Execute, run, do *) let xk_Insert = 0xFF63 (** Insert, insert here *) let xk_Undo = 0xFF65 (** Undo, oops *) let xk_Redo = 0xFF66 (** redo, again *) let xk_Menu = 0xFF67 let xk_Find = 0xFF68 (** Find, search *) let xk_Cancel = 0xFF69 (** Cancel, stop, abort, exit *) let xk_Help = 0xFF6A (** Help *) let xk_Break = 0xFF6B let xk_Mode_switch = 0xFF7E (** Character set switch *) let xk_script_switch = 0xFF7E (** Alias for mode_switch *) let xk_Num_Lock = 0xFF7F (** Keypad Functions, keypad numbers cleverly chosen to map to ascii *) let xk_KP_Space = 0xFF80 (** space *) let xk_KP_Tab = 0xFF89 let xk_KP_Enter = 0xFF8D (** enter *) let xk_KP_F1 = 0xFF91 (** PF1, KP_A, ... *) let xk_KP_F2 = 0xFF92 let xk_KP_F3 = 0xFF93 let xk_KP_F4 = 0xFF94 let xk_KP_Home = 0xFF95 let xk_KP_Left = 0xFF96 let xk_KP_Up = 0xFF97 let xk_KP_Right = 0xFF98 let xk_KP_Down = 0xFF99 let xk_KP_Prior = 0xFF9A let xk_KP_Page_Up = 0xFF9A let xk_KP_Next = 0xFF9B let xk_KP_Page_Down = 0xFF9B let xk_KP_End = 0xFF9C let xk_KP_Begin = 0xFF9D let xk_KP_Insert = 0xFF9E let xk_KP_Delete = 0xFF9F let xk_KP_Equal = 0xFFBD (** equals *) let xk_KP_Multiply = 0xFFAA let xk_KP_Add = 0xFFAB let xk_KP_Separator = 0xFFAC (** separator, often comma *) let xk_KP_Subtract = 0xFFAD let xk_KP_Decimal = 0xFFAE let xk_KP_Divide = 0xFFAF let xk_KP_0 = 0xFFB0 let xk_KP_1 = 0xFFB1 let xk_KP_2 = 0xFFB2 let xk_KP_3 = 0xFFB3 let xk_KP_4 = 0xFFB4 let xk_KP_5 = 0xFFB5 let xk_KP_6 = 0xFFB6 let xk_KP_7 = 0xFFB7 let xk_KP_8 = 0xFFB8 let xk_KP_9 = 0xFFB9 (* * Auxilliary Functions; note the duplicate definitions for left and right * function keys; Sun keyboards and a few other manufactures have such * function key groups on the left and/or right sides of the keyboard. * We've not found a keyboard with more than 35 function keys total. *) let xk_F1 = 0xFFBE let xk_F2 = 0xFFBF let xk_F3 = 0xFFC0 let xk_F4 = 0xFFC1 let xk_F5 = 0xFFC2 let xk_F6 = 0xFFC3 let xk_F7 = 0xFFC4 let xk_F8 = 0xFFC5 let xk_F9 = 0xFFC6 let xk_F10 = 0xFFC7 let xk_F11 = 0xFFC8 let xk_L1 = 0xFFC8 let xk_F12 = 0xFFC9 let xk_L2 = 0xFFC9 let xk_F13 = 0xFFCA let xk_L3 = 0xFFCA let xk_F14 = 0xFFCB let xk_L4 = 0xFFCB let xk_F15 = 0xFFCC let xk_L5 = 0xFFCC let xk_F16 = 0xFFCD let xk_L6 = 0xFFCD let xk_F17 = 0xFFCE let xk_L7 = 0xFFCE let xk_F18 = 0xFFCF let xk_L8 = 0xFFCF let xk_F19 = 0xFFD0 let xk_L9 = 0xFFD0 let xk_F20 = 0xFFD1 let xk_L10 = 0xFFD1 let xk_F21 = 0xFFD2 let xk_R1 = 0xFFD2 let xk_F22 = 0xFFD3 let xk_R2 = 0xFFD3 let xk_F23 = 0xFFD4 let xk_R3 = 0xFFD4 let xk_F24 = 0xFFD5 let xk_R4 = 0xFFD5 let xk_F25 = 0xFFD6 let xk_R5 = 0xFFD6 let xk_F26 = 0xFFD7 let xk_R6 = 0xFFD7 let xk_F27 = 0xFFD8 let xk_R7 = 0xFFD8 let xk_F28 = 0xFFD9 let xk_R8 = 0xFFD9 let xk_F29 = 0xFFDA let xk_R9 = 0xFFDA let xk_F30 = 0xFFDB let xk_R10 = 0xFFDB let xk_F31 = 0xFFDC let xk_R11 = 0xFFDC let xk_F32 = 0xFFDD let xk_R12 = 0xFFDD let xk_F33 = 0xFFDE let xk_R13 = 0xFFDE let xk_F34 = 0xFFDF let xk_R14 = 0xFFDF let xk_F35 = 0xFFE0 let xk_R15 = 0xFFE0 (** Modifiers *) let xk_Shift_L = 0xFFE1 (** Left shift *) let xk_Shift_R = 0xFFE2 (** Right shift *) let xk_Control_L = 0xFFE3 (** Left control *) let xk_Control_R = 0xFFE4 (** Right control *) let xk_Caps_Lock = 0xFFE5 (** Caps lock *) let xk_Shift_Lock = 0xFFE6 (** Shift lock *) let xk_Meta_L = 0xFFE7 (** Left meta *) let xk_Meta_R = 0xFFE8 (** Right meta *) let xk_Alt_L = 0xFFE9 (** Left alt *) let xk_Alt_R = 0xFFEA (** Right alt *) let xk_Super_L = 0xFFEB (** Left super *) let xk_Super_R = 0xFFEC (** Right super *) let xk_Hyper_L = 0xFFED (** Left hyper *) let xk_Hyper_R = 0xFFEE (** Right hyper *) (* * ISO 9995 Function and Modifier Keys * Byte 3 = = 0xFE *) let xk_ISO_Lock = 0xFE01 let xk_ISO_Level2_Latch = 0xFE02 let xk_ISO_Level3_Shift = 0xFE03 let xk_ISO_Level3_Latch = 0xFE04 let xk_ISO_Level3_Lock = 0xFE05 let xk_ISO_Group_Shift = 0xFF7E (** Alias for mode_switch *) let xk_ISO_Group_Latch = 0xFE06 let xk_ISO_Group_Lock = 0xFE07 let xk_ISO_Next_Group = 0xFE08 let xk_ISO_Next_Group_Lock = 0xFE09 let xk_ISO_Prev_Group = 0xFE0A let xk_ISO_Prev_Group_Lock = 0xFE0B let xk_ISO_First_Group = 0xFE0C let xk_ISO_First_Group_Lock = 0xFE0D let xk_ISO_Last_Group = 0xFE0E let xk_ISO_Last_Group_Lock = 0xFE0F let xk_ISO_Left_Tab = 0xFE20 let xk_ISO_Move_Line_Up = 0xFE21 let xk_ISO_Move_Line_Down = 0xFE22 let xk_ISO_Partial_Line_Up = 0xFE23 let xk_ISO_Partial_Line_Down = 0xFE24 let xk_ISO_Partial_Space_Left = 0xFE25 let xk_ISO_Partial_Space_Right = 0xFE26 let xk_ISO_Set_Margin_Left = 0xFE27 let xk_ISO_Set_Margin_Right = 0xFE28 let xk_ISO_Release_Margin_Left = 0xFE29 let xk_ISO_Release_Margin_Right = 0xFE2A let xk_ISO_Release_Both_Margins = 0xFE2B let xk_ISO_Fast_Cursor_Left = 0xFE2C let xk_ISO_Fast_Cursor_Right = 0xFE2D let xk_ISO_Fast_Cursor_Up = 0xFE2E let xk_ISO_Fast_Cursor_Down = 0xFE2F let xk_ISO_Continuous_Underline = 0xFE30 let xk_ISO_Discontinuous_Underline = 0xFE31 let xk_ISO_Emphasize = 0xFE32 let xk_ISO_Center_Object = 0xFE33 let xk_ISO_Enter = 0xFE34 let xk_dead_grave = 0xFE50 let xk_dead_acute = 0xFE51 let xk_dead_circumflex = 0xFE52 let xk_dead_tilde = 0xFE53 let xk_dead_macron = 0xFE54 let xk_dead_breve = 0xFE55 let xk_dead_abovedot = 0xFE56 let xk_dead_diaeresis = 0xFE57 let xk_dead_abovering = 0xFE58 let xk_dead_doubleacute = 0xFE59 let xk_dead_caron = 0xFE5A let xk_dead_cedilla = 0xFE5B let xk_dead_ogonek = 0xFE5C let xk_dead_iota = 0xFE5D let xk_dead_voiced_sound = 0xFE5E let xk_dead_semivoiced_sound = 0xFE5F let xk_dead_belowdot = 0xFE60 let xk_First_Virtual_Screen = 0xFED0 let xk_Prev_Virtual_Screen = 0xFED1 let xk_Next_Virtual_Screen = 0xFED2 let xk_Last_Virtual_Screen = 0xFED4 let xk_Terminate_Server = 0xFED5 let xk_AccessX_Enable = 0xFE70 let xk_AccessX_Feedback_Enable = 0xFE71 let xk_RepeatKeys_Enable = 0xFE72 let xk_SlowKeys_Enable = 0xFE73 let xk_BounceKeys_Enable = 0xFE74 let xk_StickyKeys_Enable = 0xFE75 let xk_MouseKeys_Enable = 0xFE76 let xk_MouseKeys_Accel_Enable = 0xFE77 let xk_Overlay1_Enable = 0xFE78 let xk_Overlay2_Enable = 0xFE79 let xk_AudibleBell_Enable = 0xFE7A let xk_Pointer_Left = 0xFEE0 let xk_Pointer_Right = 0xFEE1 let xk_Pointer_Up = 0xFEE2 let xk_Pointer_Down = 0xFEE3 let xk_Pointer_UpLeft = 0xFEE4 let xk_Pointer_UpRight = 0xFEE5 let xk_Pointer_DownLeft = 0xFEE6 let xk_Pointer_DownRight = 0xFEE7 let xk_Pointer_Button_Dflt = 0xFEE8 let xk_Pointer_Button1 = 0xFEE9 let xk_Pointer_Button2 = 0xFEEA let xk_Pointer_Button3 = 0xFEEB let xk_Pointer_Button4 = 0xFEEC let xk_Pointer_Button5 = 0xFEED let xk_Pointer_DblClick_Dflt = 0xFEEE let xk_Pointer_DblClick1 = 0xFEEF let xk_Pointer_DblClick2 = 0xFEF0 let xk_Pointer_DblClick3 = 0xFEF1 let xk_Pointer_DblClick4 = 0xFEF2 let xk_Pointer_DblClick5 = 0xFEF3 let xk_Pointer_Drag_Dflt = 0xFEF4 let xk_Pointer_Drag1 = 0xFEF5 let xk_Pointer_Drag2 = 0xFEF6 let xk_Pointer_Drag3 = 0xFEF7 let xk_Pointer_Drag4 = 0xFEF8 let xk_Pointer_Drag5 = 0xFEFD let xk_Pointer_EnableKeys = 0xFEF9 let xk_Pointer_Accelerate = 0xFEFA let xk_Pointer_DfltBtnNext = 0xFEFB let xk_Pointer_DfltBtnPrev = 0xFEFC (* * 3270 Terminal Keys * Byte 3 = = 0xFD *) let xk_3270_Duplicate = 0xFD01 let xk_3270_FieldMark = 0xFD02 let xk_3270_Right2 = 0xFD03 let xk_3270_Left2 = 0xFD04 let xk_3270_BackTab = 0xFD05 let xk_3270_EraseEOF = 0xFD06 let xk_3270_EraseInput = 0xFD07 let xk_3270_Reset = 0xFD08 let xk_3270_Quit = 0xFD09 let xk_3270_PA1 = 0xFD0A let xk_3270_PA2 = 0xFD0B let xk_3270_PA3 = 0xFD0C let xk_3270_Test = 0xFD0D let xk_3270_Attn = 0xFD0E let xk_3270_CursorBlink = 0xFD0F let xk_3270_AltCursor = 0xFD10 let xk_3270_KeyClick = 0xFD11 let xk_3270_Jump = 0xFD12 let xk_3270_Ident = 0xFD13 let xk_3270_Rule = 0xFD14 let xk_3270_Copy = 0xFD15 let xk_3270_Play = 0xFD16 let xk_3270_Setup = 0xFD17 let xk_3270_Record = 0xFD18 let xk_3270_ChangeScreen = 0xFD19 let xk_3270_DeleteWord = 0xFD1A let xk_3270_ExSelect = 0xFD1B let xk_3270_CursorSelect = 0xFD1C let xk_3270_PrintScreen = 0xFD1D let xk_3270_Enter = 0xFD1E (* * Latin 1 * Byte 3 = 0 *) let xk_space = 0x020 let xk_exclam = 0x021 let xk_quotedbl = 0x022 let xk_numbersign = 0x023 let xk_dollar = 0x024 let xk_percent = 0x025 let xk_ampersand = 0x026 let xk_apostrophe = 0x027 let xk_quoteright = 0x027 (** deprecated *) let xk_parenleft = 0x028 let xk_parenright = 0x029 let xk_asterisk = 0x02a let xk_plus = 0x02b let xk_comma = 0x02c let xk_minus = 0x02d let xk_period = 0x02e let xk_slash = 0x02f let xk_0 = 0x030 let xk_1 = 0x031 let xk_2 = 0x032 let xk_3 = 0x033 let xk_4 = 0x034 let xk_5 = 0x035 let xk_6 = 0x036 let xk_7 = 0x037 let xk_8 = 0x038 let xk_9 = 0x039 let xk_colon = 0x03a let xk_semicolon = 0x03b let xk_less = 0x03c let xk_equal = 0x03d let xk_greater = 0x03e let xk_question = 0x03f let xk_at = 0x040 let xk_A = 0x041 let xk_B = 0x042 let xk_C = 0x043 let xk_D = 0x044 let xk_E = 0x045 let xk_F = 0x046 let xk_G = 0x047 let xk_H = 0x048 let xk_I = 0x049 let xk_J = 0x04a let xk_K = 0x04b let xk_L = 0x04c let xk_M = 0x04d let xk_N = 0x04e let xk_O = 0x04f let xk_P = 0x050 let xk_Q = 0x051 let xk_R = 0x052 let xk_S = 0x053 let xk_T = 0x054 let xk_U = 0x055 let xk_V = 0x056 let xk_W = 0x057 let xk_X = 0x058 let xk_Y = 0x059 let xk_Z = 0x05a let xk_bracketleft = 0x05b let xk_backslash = 0x05c let xk_bracketright = 0x05d let xk_asciicircum = 0x05e let xk_underscore = 0x05f let xk_grave = 0x060 let xk_quoteleft = 0x060 (** deprecated *) let xk_a = 0x061 let xk_b = 0x062 let xk_c = 0x063 let xk_d = 0x064 let xk_e = 0x065 let xk_f = 0x066 let xk_g = 0x067 let xk_h = 0x068 let xk_i = 0x069 let xk_j = 0x06a let xk_k = 0x06b let xk_l = 0x06c let xk_m = 0x06d let xk_n = 0x06e let xk_o = 0x06f let xk_p = 0x070 let xk_q = 0x071 let xk_r = 0x072 let xk_s = 0x073 let xk_t = 0x074 let xk_u = 0x075 let xk_v = 0x076 let xk_w = 0x077 let xk_x = 0x078 let xk_y = 0x079 let xk_z = 0x07a let xk_braceleft = 0x07b let xk_bar = 0x07c let xk_braceright = 0x07d let xk_asciitilde = 0x07e let xk_nobreakspace = 0x0a0 let xk_exclamdown = 0x0a1 let xk_cent = 0x0a2 let xk_sterling = 0x0a3 let xk_currency = 0x0a4 let xk_yen = 0x0a5 let xk_brokenbar = 0x0a6 let xk_section = 0x0a7 let xk_diaeresis = 0x0a8 let xk_copyright = 0x0a9 let xk_ordfeminine = 0x0aa let xk_guillemotleft = 0x0ab (** left angle quotation mark *) let xk_notsign = 0x0ac let xk_hyphen = 0x0ad let xk_registered = 0x0ae let xk_macron = 0x0af let xk_degree = 0x0b0 let xk_plusminus = 0x0b1 let xk_twosuperior = 0x0b2 let xk_threesuperior = 0x0b3 let xk_acute = 0x0b4 let xk_mu = 0x0b5 let xk_paragraph = 0x0b6 let xk_periodcentered = 0x0b7 let xk_cedilla = 0x0b8 let xk_onesuperior = 0x0b9 let xk_masculine = 0x0ba let xk_guillemotright = 0x0bb (** right angle quotation mark *) let xk_onequarter = 0x0bc let xk_onehalf = 0x0bd let xk_threequarters = 0x0be let xk_questiondown = 0x0bf let xk_Agrave = 0x0c0 let xk_Aacute = 0x0c1 let xk_Acircumflex = 0x0c2 let xk_Atilde = 0x0c3 let xk_Adiaeresis = 0x0c4 let xk_Aring = 0x0c5 let xk_AE = 0x0c6 let xk_Ccedilla = 0x0c7 let xk_Egrave = 0x0c8 let xk_Eacute = 0x0c9 let xk_Ecircumflex = 0x0ca let xk_Ediaeresis = 0x0cb let xk_Igrave = 0x0cc let xk_Iacute = 0x0cd let xk_Icircumflex = 0x0ce let xk_Idiaeresis = 0x0cf let xk_ETH = 0x0d0 let xk_Eth = 0x0d0 (** deprecated *) let xk_Ntilde = 0x0d1 let xk_Ograve = 0x0d2 let xk_Oacute = 0x0d3 let xk_Ocircumflex = 0x0d4 let xk_Otilde = 0x0d5 let xk_Odiaeresis = 0x0d6 let xk_multiply = 0x0d7 let xk_Ooblique = 0x0d8 let xk_Ugrave = 0x0d9 let xk_Uacute = 0x0da let xk_Ucircumflex = 0x0db let xk_Udiaeresis = 0x0dc let xk_Yacute = 0x0dd let xk_THORN = 0x0de let xk_Thorn = 0x0de (** deprecated *) let xk_ssharp = 0x0df let xk_agrave = 0x0e0 let xk_aacute = 0x0e1 let xk_acircumflex = 0x0e2 let xk_atilde = 0x0e3 let xk_adiaeresis = 0x0e4 let xk_aring = 0x0e5 let xk_ae = 0x0e6 let xk_ccedilla = 0x0e7 let xk_egrave = 0x0e8 let xk_eacute = 0x0e9 let xk_ecircumflex = 0x0ea let xk_ediaeresis = 0x0eb let xk_igrave = 0x0ec let xk_iacute = 0x0ed let xk_icircumflex = 0x0ee let xk_idiaeresis = 0x0ef let xk_eth = 0x0f0 let xk_ntilde = 0x0f1 let xk_ograve = 0x0f2 let xk_oacute = 0x0f3 let xk_ocircumflex = 0x0f4 let xk_otilde = 0x0f5 let xk_odiaeresis = 0x0f6 let xk_division = 0x0f7 let xk_oslash = 0x0f8 let xk_ugrave = 0x0f9 let xk_uacute = 0x0fa let xk_ucircumflex = 0x0fb let xk_udiaeresis = 0x0fc let xk_yacute = 0x0fd let xk_thorn = 0x0fe let xk_ydiaeresis = 0x0ff (* * Latin 2 * Byte 3 = 1 *) let xk_Aogonek = 0x1a1 let xk_breve = 0x1a2 let xk_Lstroke = 0x1a3 let xk_Lcaron = 0x1a5 let xk_Sacute = 0x1a6 let xk_Scaron = 0x1a9 let xk_Scedilla = 0x1aa let xk_Tcaron = 0x1ab let xk_Zacute = 0x1ac let xk_Zcaron = 0x1ae let xk_Zabovedot = 0x1af let xk_aogonek = 0x1b1 let xk_ogonek = 0x1b2 let xk_lstroke = 0x1b3 let xk_lcaron = 0x1b5 let xk_sacute = 0x1b6 let xk_caron = 0x1b7 let xk_scaron = 0x1b9 let xk_scedilla = 0x1ba let xk_tcaron = 0x1bb let xk_zacute = 0x1bc let xk_doubleacute = 0x1bd let xk_zcaron = 0x1be let xk_zabovedot = 0x1bf let xk_Racute = 0x1c0 let xk_Abreve = 0x1c3 let xk_Lacute = 0x1c5 let xk_Cacute = 0x1c6 let xk_Ccaron = 0x1c8 let xk_Eogonek = 0x1ca let xk_Ecaron = 0x1cc let xk_Dcaron = 0x1cf let xk_Dstroke = 0x1d0 let xk_Nacute = 0x1d1 let xk_Ncaron = 0x1d2 let xk_Odoubleacute = 0x1d5 let xk_Rcaron = 0x1d8 let xk_Uring = 0x1d9 let xk_Udoubleacute = 0x1db let xk_Tcedilla = 0x1de let xk_racute = 0x1e0 let xk_abreve = 0x1e3 let xk_lacute = 0x1e5 let xk_cacute = 0x1e6 let xk_ccaron = 0x1e8 let xk_eogonek = 0x1ea let xk_ecaron = 0x1ec let xk_dcaron = 0x1ef let xk_dstroke = 0x1f0 let xk_nacute = 0x1f1 let xk_ncaron = 0x1f2 let xk_odoubleacute = 0x1f5 let xk_udoubleacute = 0x1fb let xk_rcaron = 0x1f8 let xk_uring = 0x1f9 let xk_tcedilla = 0x1fe let xk_abovedot = 0x1ff (* * Latin 3 * Byte 3 = 2 *) let xk_Hstroke = 0x2a1 let xk_Hcircumflex = 0x2a6 let xk_Iabovedot = 0x2a9 let xk_Gbreve = 0x2ab let xk_Jcircumflex = 0x2ac let xk_hstroke = 0x2b1 let xk_hcircumflex = 0x2b6 let xk_idotless = 0x2b9 let xk_gbreve = 0x2bb let xk_jcircumflex = 0x2bc let xk_Cabovedot = 0x2c5 let xk_Ccircumflex = 0x2c6 let xk_Gabovedot = 0x2d5 let xk_Gcircumflex = 0x2d8 let xk_Ubreve = 0x2dd let xk_Scircumflex = 0x2de let xk_cabovedot = 0x2e5 let xk_ccircumflex = 0x2e6 let xk_gabovedot = 0x2f5 let xk_gcircumflex = 0x2f8 let xk_ubreve = 0x2fd let xk_scircumflex = 0x2fe (* * Latin 4 * Byte 3 = 3 *) let xk_kra = 0x3a2 let xk_kappa = 0x3a2 (** deprecated *) let xk_Rcedilla = 0x3a3 let xk_Itilde = 0x3a5 let xk_Lcedilla = 0x3a6 let xk_Emacron = 0x3aa let xk_Gcedilla = 0x3ab let xk_Tslash = 0x3ac let xk_rcedilla = 0x3b3 let xk_itilde = 0x3b5 let xk_lcedilla = 0x3b6 let xk_emacron = 0x3ba let xk_gcedilla = 0x3bb let xk_tslash = 0x3bc let xk_ENG = 0x3bd let xk_eng = 0x3bf let xk_Amacron = 0x3c0 let xk_Iogonek = 0x3c7 let xk_Eabovedot = 0x3cc let xk_Imacron = 0x3cf let xk_Ncedilla = 0x3d1 let xk_Omacron = 0x3d2 let xk_Kcedilla = 0x3d3 let xk_Uogonek = 0x3d9 let xk_Utilde = 0x3dd let xk_Umacron = 0x3de let xk_amacron = 0x3e0 let xk_iogonek = 0x3e7 let xk_eabovedot = 0x3ec let xk_imacron = 0x3ef let xk_ncedilla = 0x3f1 let xk_omacron = 0x3f2 let xk_kcedilla = 0x3f3 let xk_uogonek = 0x3f9 let xk_utilde = 0x3fd let xk_umacron = 0x3fe (* * Katakana * Byte 3 = 4 *) let xk_overline = 0x47e let xk_kana_fullstop = 0x4a1 let xk_kana_openingbracket = 0x4a2 let xk_kana_closingbracket = 0x4a3 let xk_kana_comma = 0x4a4 let xk_kana_conjunctive = 0x4a5 let xk_kana_middledot = 0x4a5 (** deprecated *) let xk_kana_WO = 0x4a6 let xk_kana_a = 0x4a7 let xk_kana_i = 0x4a8 let xk_kana_u = 0x4a9 let xk_kana_e = 0x4aa let xk_kana_o = 0x4ab let xk_kana_ya = 0x4ac let xk_kana_yu = 0x4ad let xk_kana_yo = 0x4ae let xk_kana_tsu = 0x4af let xk_kana_tu = 0x4af (** deprecated *) let xk_prolongedsound = 0x4b0 let xk_kana_A = 0x4b1 let xk_kana_I = 0x4b2 let xk_kana_U = 0x4b3 let xk_kana_E = 0x4b4 let xk_kana_O = 0x4b5 let xk_kana_KA = 0x4b6 let xk_kana_KI = 0x4b7 let xk_kana_KU = 0x4b8 let xk_kana_KE = 0x4b9 let xk_kana_KO = 0x4ba let xk_kana_SA = 0x4bb let xk_kana_SHI = 0x4bc let xk_kana_SU = 0x4bd let xk_kana_SE = 0x4be let xk_kana_SO = 0x4bf let xk_kana_TA = 0x4c0 let xk_kana_CHI = 0x4c1 let xk_kana_TI = 0x4c1 (** deprecated *) let xk_kana_TSU = 0x4c2 let xk_kana_TU = 0x4c2 (** deprecated *) let xk_kana_TE = 0x4c3 let xk_kana_TO = 0x4c4 let xk_kana_NA = 0x4c5 let xk_kana_NI = 0x4c6 let xk_kana_NU = 0x4c7 let xk_kana_NE = 0x4c8 let xk_kana_NO = 0x4c9 let xk_kana_HA = 0x4ca let xk_kana_HI = 0x4cb let xk_kana_FU = 0x4cc let xk_kana_HU = 0x4cc (** deprecated *) let xk_kana_HE = 0x4cd let xk_kana_HO = 0x4ce let xk_kana_MA = 0x4cf let xk_kana_MI = 0x4d0 let xk_kana_MU = 0x4d1 let xk_kana_ME = 0x4d2 let xk_kana_MO = 0x4d3 let xk_kana_YA = 0x4d4 let xk_kana_YU = 0x4d5 let xk_kana_YO = 0x4d6 let xk_kana_RA = 0x4d7 let xk_kana_RI = 0x4d8 let xk_kana_RU = 0x4d9 let xk_kana_RE = 0x4da let xk_kana_RO = 0x4db let xk_kana_WA = 0x4dc let xk_kana_N = 0x4dd let xk_voicedsound = 0x4de let xk_semivoicedsound = 0x4df let xk_kana_switch = 0xFF7E (** Alias for mode_switch *) (* * Arabic * Byte 3 = 5 *) let xk_Arabic_comma = 0x5ac let xk_Arabic_semicolon = 0x5bb let xk_Arabic_question_mark = 0x5bf let xk_Arabic_hamza = 0x5c1 let xk_Arabic_maddaonalef = 0x5c2 let xk_Arabic_hamzaonalef = 0x5c3 let xk_Arabic_hamzaonwaw = 0x5c4 let xk_Arabic_hamzaunderalef = 0x5c5 let xk_Arabic_hamzaonyeh = 0x5c6 let xk_Arabic_alef = 0x5c7 let xk_Arabic_beh = 0x5c8 let xk_Arabic_tehmarbuta = 0x5c9 let xk_Arabic_teh = 0x5ca let xk_Arabic_theh = 0x5cb let xk_Arabic_jeem = 0x5cc let xk_Arabic_hah = 0x5cd let xk_Arabic_khah = 0x5ce let xk_Arabic_dal = 0x5cf let xk_Arabic_thal = 0x5d0 let xk_Arabic_ra = 0x5d1 let xk_Arabic_zain = 0x5d2 let xk_Arabic_seen = 0x5d3 let xk_Arabic_sheen = 0x5d4 let xk_Arabic_sad = 0x5d5 let xk_Arabic_dad = 0x5d6 let xk_Arabic_tah = 0x5d7 let xk_Arabic_zah = 0x5d8 let xk_Arabic_ain = 0x5d9 let xk_Arabic_ghain = 0x5da let xk_Arabic_tatweel = 0x5e0 let xk_Arabic_feh = 0x5e1 let xk_Arabic_qaf = 0x5e2 let xk_Arabic_kaf = 0x5e3 let xk_Arabic_lam = 0x5e4 let xk_Arabic_meem = 0x5e5 let xk_Arabic_noon = 0x5e6 let xk_Arabic_ha = 0x5e7 let xk_Arabic_heh = 0x5e7 (** deprecated *) let xk_Arabic_waw = 0x5e8 let xk_Arabic_alefmaksura = 0x5e9 let xk_Arabic_yeh = 0x5ea let xk_Arabic_fathatan = 0x5eb let xk_Arabic_dammatan = 0x5ec let xk_Arabic_kasratan = 0x5ed let xk_Arabic_fatha = 0x5ee let xk_Arabic_damma = 0x5ef let xk_Arabic_kasra = 0x5f0 let xk_Arabic_shadda = 0x5f1 let xk_Arabic_sukun = 0x5f2 let xk_Arabic_switch = 0xFF7E (** Alias for mode_switch *) (* * Cyrillic * Byte 3 = 6 *) let xk_Serbian_dje = 0x6a1 let xk_Macedonia_gje = 0x6a2 let xk_Cyrillic_io = 0x6a3 let xk_Ukrainian_ie = 0x6a4 let xk_Ukranian_je = 0x6a4 (** deprecated *) let xk_Macedonia_dse = 0x6a5 let xk_Ukrainian_i = 0x6a6 let xk_Ukranian_i = 0x6a6 (** deprecated *) let xk_Ukrainian_yi = 0x6a7 let xk_Ukranian_yi = 0x6a7 (** deprecated *) let xk_Cyrillic_je = 0x6a8 let xk_Serbian_je = 0x6a8 (** deprecated *) let xk_Cyrillic_lje = 0x6a9 let xk_Serbian_lje = 0x6a9 (** deprecated *) let xk_Cyrillic_nje = 0x6aa let xk_Serbian_nje = 0x6aa (** deprecated *) let xk_Serbian_tshe = 0x6ab let xk_Macedonia_kje = 0x6ac let xk_Byelorussian_shortu = 0x6ae let xk_Cyrillic_dzhe = 0x6af let xk_Serbian_dze = 0x6af (** deprecated *) let xk_numerosign = 0x6b0 let xk_Serbian_DJE = 0x6b1 let xk_Macedonia_GJE = 0x6b2 let xk_Cyrillic_IO = 0x6b3 let xk_Ukrainian_IE = 0x6b4 let xk_Ukranian_JE = 0x6b4 (** deprecated *) let xk_Macedonia_DSE = 0x6b5 let xk_Ukrainian_I = 0x6b6 let xk_Ukranian_I = 0x6b6 (** deprecated *) let xk_Ukrainian_YI = 0x6b7 let xk_Ukranian_YI = 0x6b7 (** deprecated *) let xk_Cyrillic_JE = 0x6b8 let xk_Serbian_JE = 0x6b8 (** deprecated *) let xk_Cyrillic_LJE = 0x6b9 let xk_Serbian_LJE = 0x6b9 (** deprecated *) let xk_Cyrillic_NJE = 0x6ba let xk_Serbian_NJE = 0x6ba (** deprecated *) let xk_Serbian_TSHE = 0x6bb let xk_Macedonia_KJE = 0x6bc let xk_Byelorussian_SHORTU = 0x6be let xk_Cyrillic_DZHE = 0x6bf let xk_Serbian_DZE = 0x6bf (** deprecated *) let xk_Cyrillic_yu = 0x6c0 let xk_Cyrillic_a = 0x6c1 let xk_Cyrillic_be = 0x6c2 let xk_Cyrillic_tse = 0x6c3 let xk_Cyrillic_de = 0x6c4 let xk_Cyrillic_ie = 0x6c5 let xk_Cyrillic_ef = 0x6c6 let xk_Cyrillic_ghe = 0x6c7 let xk_Cyrillic_ha = 0x6c8 let xk_Cyrillic_i = 0x6c9 let xk_Cyrillic_shorti = 0x6ca let xk_Cyrillic_ka = 0x6cb let xk_Cyrillic_el = 0x6cc let xk_Cyrillic_em = 0x6cd let xk_Cyrillic_en = 0x6ce let xk_Cyrillic_o = 0x6cf let xk_Cyrillic_pe = 0x6d0 let xk_Cyrillic_ya = 0x6d1 let xk_Cyrillic_er = 0x6d2 let xk_Cyrillic_es = 0x6d3 let xk_Cyrillic_te = 0x6d4 let xk_Cyrillic_u = 0x6d5 let xk_Cyrillic_zhe = 0x6d6 let xk_Cyrillic_ve = 0x6d7 let xk_Cyrillic_softsign = 0x6d8 let xk_Cyrillic_yeru = 0x6d9 let xk_Cyrillic_ze = 0x6da let xk_Cyrillic_sha = 0x6db let xk_Cyrillic_e = 0x6dc let xk_Cyrillic_shcha = 0x6dd let xk_Cyrillic_che = 0x6de let xk_Cyrillic_hardsign = 0x6df let xk_Cyrillic_YU = 0x6e0 let xk_Cyrillic_A = 0x6e1 let xk_Cyrillic_BE = 0x6e2 let xk_Cyrillic_TSE = 0x6e3 let xk_Cyrillic_DE = 0x6e4 let xk_Cyrillic_IE = 0x6e5 let xk_Cyrillic_EF = 0x6e6 let xk_Cyrillic_GHE = 0x6e7 let xk_Cyrillic_HA = 0x6e8 let xk_Cyrillic_I = 0x6e9 let xk_Cyrillic_SHORTI = 0x6ea let xk_Cyrillic_KA = 0x6eb let xk_Cyrillic_EL = 0x6ec let xk_Cyrillic_EM = 0x6ed let xk_Cyrillic_EN = 0x6ee let xk_Cyrillic_O = 0x6ef let xk_Cyrillic_PE = 0x6f0 let xk_Cyrillic_YA = 0x6f1 let xk_Cyrillic_ER = 0x6f2 let xk_Cyrillic_ES = 0x6f3 let xk_Cyrillic_TE = 0x6f4 let xk_Cyrillic_U = 0x6f5 let xk_Cyrillic_ZHE = 0x6f6 let xk_Cyrillic_VE = 0x6f7 let xk_Cyrillic_SOFTSIGN = 0x6f8 let xk_Cyrillic_YERU = 0x6f9 let xk_Cyrillic_ZE = 0x6fa let xk_Cyrillic_SHA = 0x6fb let xk_Cyrillic_E = 0x6fc let xk_Cyrillic_SHCHA = 0x6fd let xk_Cyrillic_CHE = 0x6fe let xk_Cyrillic_HARDSIGN = 0x6ff (* * Greek * Byte 3 = 7 *) let xk_Greek_ALPHAaccent = 0x7a1 let xk_Greek_EPSILONaccent = 0x7a2 let xk_Greek_ETAaccent = 0x7a3 let xk_Greek_IOTAaccent = 0x7a4 let xk_Greek_IOTAdiaeresis = 0x7a5 let xk_Greek_OMICRONaccent = 0x7a7 let xk_Greek_UPSILONaccent = 0x7a8 let xk_Greek_UPSILONdieresis = 0x7a9 let xk_Greek_OMEGAaccent = 0x7ab let xk_Greek_accentdieresis = 0x7ae let xk_Greek_horizbar = 0x7af let xk_Greek_alphaaccent = 0x7b1 let xk_Greek_epsilonaccent = 0x7b2 let xk_Greek_etaaccent = 0x7b3 let xk_Greek_iotaaccent = 0x7b4 let xk_Greek_iotadieresis = 0x7b5 let xk_Greek_iotaaccentdieresis = 0x7b6 let xk_Greek_omicronaccent = 0x7b7 let xk_Greek_upsilonaccent = 0x7b8 let xk_Greek_upsilondieresis = 0x7b9 let xk_Greek_upsilonaccentdieresis = 0x7ba let xk_Greek_omegaaccent = 0x7bb let xk_Greek_ALPHA = 0x7c1 let xk_Greek_BETA = 0x7c2 let xk_Greek_GAMMA = 0x7c3 let xk_Greek_DELTA = 0x7c4 let xk_Greek_EPSILON = 0x7c5 let xk_Greek_ZETA = 0x7c6 let xk_Greek_ETA = 0x7c7 let xk_Greek_THETA = 0x7c8 let xk_Greek_IOTA = 0x7c9 let xk_Greek_KAPPA = 0x7ca let xk_Greek_LAMDA = 0x7cb let xk_Greek_LAMBDA = 0x7cb let xk_Greek_MU = 0x7cc let xk_Greek_NU = 0x7cd let xk_Greek_XI = 0x7ce let xk_Greek_OMICRON = 0x7cf let xk_Greek_PI = 0x7d0 let xk_Greek_RHO = 0x7d1 let xk_Greek_SIGMA = 0x7d2 let xk_Greek_TAU = 0x7d4 let xk_Greek_UPSILON = 0x7d5 let xk_Greek_PHI = 0x7d6 let xk_Greek_CHI = 0x7d7 let xk_Greek_PSI = 0x7d8 let xk_Greek_OMEGA = 0x7d9 let xk_Greek_alpha = 0x7e1 let xk_Greek_beta = 0x7e2 let xk_Greek_gamma = 0x7e3 let xk_Greek_delta = 0x7e4 let xk_Greek_epsilon = 0x7e5 let xk_Greek_zeta = 0x7e6 let xk_Greek_eta = 0x7e7 let xk_Greek_theta = 0x7e8 let xk_Greek_iota = 0x7e9 let xk_Greek_kappa = 0x7ea let xk_Greek_lamda = 0x7eb let xk_Greek_lambda = 0x7eb let xk_Greek_mu = 0x7ec let xk_Greek_nu = 0x7ed let xk_Greek_xi = 0x7ee let xk_Greek_omicron = 0x7ef let xk_Greek_pi = 0x7f0 let xk_Greek_rho = 0x7f1 let xk_Greek_sigma = 0x7f2 let xk_Greek_finalsmallsigma = 0x7f3 let xk_Greek_tau = 0x7f4 let xk_Greek_upsilon = 0x7f5 let xk_Greek_phi = 0x7f6 let xk_Greek_chi = 0x7f7 let xk_Greek_psi = 0x7f8 let xk_Greek_omega = 0x7f9 let xk_Greek_switch = 0xFF7E (** Alias for mode_switch *) (* * Technical * Byte 3 = 8 *) let xk_leftradical = 0x8a1 let xk_topleftradical = 0x8a2 let xk_horizconnector = 0x8a3 let xk_topintegral = 0x8a4 let xk_botintegral = 0x8a5 let xk_vertconnector = 0x8a6 let xk_topleftsqbracket = 0x8a7 let xk_botleftsqbracket = 0x8a8 let xk_toprightsqbracket = 0x8a9 let xk_botrightsqbracket = 0x8aa let xk_topleftparens = 0x8ab let xk_botleftparens = 0x8ac let xk_toprightparens = 0x8ad let xk_botrightparens = 0x8ae let xk_leftmiddlecurlybrace = 0x8af let xk_rightmiddlecurlybrace = 0x8b0 let xk_topleftsummation = 0x8b1 let xk_botleftsummation = 0x8b2 let xk_topvertsummationconnector = 0x8b3 let xk_botvertsummationconnector = 0x8b4 let xk_toprightsummation = 0x8b5 let xk_botrightsummation = 0x8b6 let xk_rightmiddlesummation = 0x8b7 let xk_lessthanequal = 0x8bc let xk_notequal = 0x8bd let xk_greaterthanequal = 0x8be let xk_integral = 0x8bf let xk_therefore = 0x8c0 let xk_variation = 0x8c1 let xk_infinity = 0x8c2 let xk_nabla = 0x8c5 let xk_approximate = 0x8c8 let xk_similarequal = 0x8c9 let xk_ifonlyif = 0x8cd let xk_implies = 0x8ce let xk_identical = 0x8cf let xk_radical = 0x8d6 let xk_includedin = 0x8da let xk_includes = 0x8db let xk_intersection = 0x8dc let xk_union = 0x8dd let xk_logicaland = 0x8de let xk_logicalor = 0x8df let xk_partialderivative = 0x8ef let xk_function = 0x8f6 let xk_leftarrow = 0x8fb let xk_uparrow = 0x8fc let xk_rightarrow = 0x8fd let xk_downarrow = 0x8fe (* * Special * Byte 3 = 9 *) let xk_blank = 0x9df let xk_soliddiamond = 0x9e0 let xk_checkerboard = 0x9e1 let xk_ht = 0x9e2 let xk_ff = 0x9e3 let xk_cr = 0x9e4 let xk_lf = 0x9e5 let xk_nl = 0x9e8 let xk_vt = 0x9e9 let xk_lowrightcorner = 0x9ea let xk_uprightcorner = 0x9eb let xk_upleftcorner = 0x9ec let xk_lowleftcorner = 0x9ed let xk_crossinglines = 0x9ee let xk_horizlinescan1 = 0x9ef let xk_horizlinescan3 = 0x9f0 let xk_horizlinescan5 = 0x9f1 let xk_horizlinescan7 = 0x9f2 let xk_horizlinescan9 = 0x9f3 let xk_leftt = 0x9f4 let xk_rightt = 0x9f5 let xk_bott = 0x9f6 let xk_topt = 0x9f7 let xk_vertbar = 0x9f8 (* * Publishing * Byte 3 = a *) let xk_emspace = 0xaa1 let xk_enspace = 0xaa2 let xk_em3space = 0xaa3 let xk_em4space = 0xaa4 let xk_digitspace = 0xaa5 let xk_punctspace = 0xaa6 let xk_thinspace = 0xaa7 let xk_hairspace = 0xaa8 let xk_emdash = 0xaa9 let xk_endash = 0xaaa let xk_signifblank = 0xaac let xk_ellipsis = 0xaae let xk_doubbaselinedot = 0xaaf let xk_onethird = 0xab0 let xk_twothirds = 0xab1 let xk_onefifth = 0xab2 let xk_twofifths = 0xab3 let xk_threefifths = 0xab4 let xk_fourfifths = 0xab5 let xk_onesixth = 0xab6 let xk_fivesixths = 0xab7 let xk_careof = 0xab8 let xk_figdash = 0xabb let xk_leftanglebracket = 0xabc let xk_decimalpoint = 0xabd let xk_rightanglebracket = 0xabe let xk_marker = 0xabf let xk_oneeighth = 0xac3 let xk_threeeighths = 0xac4 let xk_fiveeighths = 0xac5 let xk_seveneighths = 0xac6 let xk_trademark = 0xac9 let xk_signaturemark = 0xaca let xk_trademarkincircle = 0xacb let xk_leftopentriangle = 0xacc let xk_rightopentriangle = 0xacd let xk_emopencircle = 0xace let xk_emopenrectangle = 0xacf let xk_leftsinglequotemark = 0xad0 let xk_rightsinglequotemark = 0xad1 let xk_leftdoublequotemark = 0xad2 let xk_rightdoublequotemark = 0xad3 let xk_prescription = 0xad4 let xk_minutes = 0xad6 let xk_seconds = 0xad7 let xk_latincross = 0xad9 let xk_hexagram = 0xada let xk_filledrectbullet = 0xadb let xk_filledlefttribullet = 0xadc let xk_filledrighttribullet = 0xadd let xk_emfilledcircle = 0xade let xk_emfilledrect = 0xadf let xk_enopencircbullet = 0xae0 let xk_enopensquarebullet = 0xae1 let xk_openrectbullet = 0xae2 let xk_opentribulletup = 0xae3 let xk_opentribulletdown = 0xae4 let xk_openstar = 0xae5 let xk_enfilledcircbullet = 0xae6 let xk_enfilledsqbullet = 0xae7 let xk_filledtribulletup = 0xae8 let xk_filledtribulletdown = 0xae9 let xk_leftpointer = 0xaea let xk_rightpointer = 0xaeb let xk_club = 0xaec let xk_diamond = 0xaed let xk_heart = 0xaee let xk_maltesecross = 0xaf0 let xk_dagger = 0xaf1 let xk_doubledagger = 0xaf2 let xk_checkmark = 0xaf3 let xk_ballotcross = 0xaf4 let xk_musicalsharp = 0xaf5 let xk_musicalflat = 0xaf6 let xk_malesymbol = 0xaf7 let xk_femalesymbol = 0xaf8 let xk_telephone = 0xaf9 let xk_telephonerecorder = 0xafa let xk_phonographcopyright = 0xafb let xk_caret = 0xafc let xk_singlelowquotemark = 0xafd let xk_doublelowquotemark = 0xafe let xk_cursor = 0xaff (* * APL * Byte 3 = b *) let xk_leftcaret = 0xba3 let xk_rightcaret = 0xba6 let xk_downcaret = 0xba8 let xk_upcaret = 0xba9 let xk_overbar = 0xbc0 let xk_downtack = 0xbc2 let xk_upshoe = 0xbc3 let xk_downstile = 0xbc4 let xk_underbar = 0xbc6 let xk_jot = 0xbca let xk_quad = 0xbcc let xk_uptack = 0xbce let xk_circle = 0xbcf let xk_upstile = 0xbd3 let xk_downshoe = 0xbd6 let xk_rightshoe = 0xbd8 let xk_leftshoe = 0xbda let xk_lefttack = 0xbdc let xk_righttack = 0xbfc (* * Hebrew * Byte 3 = c *) let xk_hebrew_doublelowline = 0xcdf let xk_hebrew_aleph = 0xce0 let xk_hebrew_bet = 0xce1 let xk_hebrew_beth = 0xce1 (** deprecated *) let xk_hebrew_gimel = 0xce2 let xk_hebrew_gimmel = 0xce2 (** deprecated *) let xk_hebrew_dalet = 0xce3 let xk_hebrew_daleth = 0xce3 (** deprecated *) let xk_hebrew_he = 0xce4 let xk_hebrew_waw = 0xce5 let xk_hebrew_zain = 0xce6 let xk_hebrew_zayin = 0xce6 (** deprecated *) let xk_hebrew_chet = 0xce7 let xk_hebrew_het = 0xce7 (** deprecated *) let xk_hebrew_tet = 0xce8 let xk_hebrew_teth = 0xce8 (** deprecated *) let xk_hebrew_yod = 0xce9 let xk_hebrew_finalkaph = 0xcea let xk_hebrew_kaph = 0xceb let xk_hebrew_lamed = 0xcec let xk_hebrew_finalmem = 0xced let xk_hebrew_mem = 0xcee let xk_hebrew_finalnun = 0xcef let xk_hebrew_nun = 0xcf0 let xk_hebrew_samech = 0xcf1 let xk_hebrew_samekh = 0xcf1 (** deprecated *) let xk_hebrew_ayin = 0xcf2 let xk_hebrew_finalpe = 0xcf3 let xk_hebrew_pe = 0xcf4 let xk_hebrew_finalzade = 0xcf5 let xk_hebrew_finalzadi = 0xcf5 (** deprecated *) let xk_hebrew_zade = 0xcf6 let xk_hebrew_zadi = 0xcf6 (** deprecated *) let xk_hebrew_qoph = 0xcf7 let xk_hebrew_kuf = 0xcf7 (** deprecated *) let xk_hebrew_resh = 0xcf8 let xk_hebrew_shin = 0xcf9 let xk_hebrew_taw = 0xcfa let xk_hebrew_taf = 0xcfa (** deprecated *) let xk_Hebrew_switch = 0xFF7E (** Alias for mode_switch *) (* * Thai * Byte 3 = d *) let xk_Thai_kokai = 0xda1 let xk_Thai_khokhai = 0xda2 let xk_Thai_khokhuat = 0xda3 let xk_Thai_khokhwai = 0xda4 let xk_Thai_khokhon = 0xda5 let xk_Thai_khorakhang = 0xda6 let xk_Thai_ngongu = 0xda7 let xk_Thai_chochan = 0xda8 let xk_Thai_choching = 0xda9 let xk_Thai_chochang = 0xdaa let xk_Thai_soso = 0xdab let xk_Thai_chochoe = 0xdac let xk_Thai_yoying = 0xdad let xk_Thai_dochada = 0xdae let xk_Thai_topatak = 0xdaf let xk_Thai_thothan = 0xdb0 let xk_Thai_thonangmontho = 0xdb1 let xk_Thai_thophuthao = 0xdb2 let xk_Thai_nonen = 0xdb3 let xk_Thai_dodek = 0xdb4 let xk_Thai_totao = 0xdb5 let xk_Thai_thothung = 0xdb6 let xk_Thai_thothahan = 0xdb7 let xk_Thai_thothong = 0xdb8 let xk_Thai_nonu = 0xdb9 let xk_Thai_bobaimai = 0xdba let xk_Thai_popla = 0xdbb let xk_Thai_phophung = 0xdbc let xk_Thai_fofa = 0xdbd let xk_Thai_phophan = 0xdbe let xk_Thai_fofan = 0xdbf let xk_Thai_phosamphao = 0xdc0 let xk_Thai_moma = 0xdc1 let xk_Thai_yoyak = 0xdc2 let xk_Thai_rorua = 0xdc3 let xk_Thai_ru = 0xdc4 let xk_Thai_loling = 0xdc5 let xk_Thai_lu = 0xdc6 let xk_Thai_wowaen = 0xdc7 let xk_Thai_sosala = 0xdc8 let xk_Thai_sorusi = 0xdc9 let xk_Thai_sosua = 0xdca let xk_Thai_hohip = 0xdcb let xk_Thai_lochula = 0xdcc let xk_Thai_oang = 0xdcd let xk_Thai_honokhuk = 0xdce let xk_Thai_paiyannoi = 0xdcf let xk_Thai_saraa = 0xdd0 let xk_Thai_maihanakat = 0xdd1 let xk_Thai_saraaa = 0xdd2 let xk_Thai_saraam = 0xdd3 let xk_Thai_sarai = 0xdd4 let xk_Thai_saraii = 0xdd5 let xk_Thai_saraue = 0xdd6 let xk_Thai_sarauee = 0xdd7 let xk_Thai_sarau = 0xdd8 let xk_Thai_sarauu = 0xdd9 let xk_Thai_phinthu = 0xdda let xk_Thai_maihanakat_maitho = 0xdde let xk_Thai_baht = 0xddf let xk_Thai_sarae = 0xde0 let xk_Thai_saraae = 0xde1 let xk_Thai_sarao = 0xde2 let xk_Thai_saraaimaimuan = 0xde3 let xk_Thai_saraaimaimalai = 0xde4 let xk_Thai_lakkhangyao = 0xde5 let xk_Thai_maiyamok = 0xde6 let xk_Thai_maitaikhu = 0xde7 let xk_Thai_maiek = 0xde8 let xk_Thai_maitho = 0xde9 let xk_Thai_maitri = 0xdea let xk_Thai_maichattawa = 0xdeb let xk_Thai_thanthakhat = 0xdec let xk_Thai_nikhahit = 0xded let xk_Thai_leksun = 0xdf0 let xk_Thai_leknung = 0xdf1 let xk_Thai_leksong = 0xdf2 let xk_Thai_leksam = 0xdf3 let xk_Thai_leksi = 0xdf4 let xk_Thai_lekha = 0xdf5 let xk_Thai_lekhok = 0xdf6 let xk_Thai_lekchet = 0xdf7 let xk_Thai_lekpaet = 0xdf8 let xk_Thai_lekkao = 0xdf9 (* * Korean * Byte 3 = e *) let xk_Hangul = 0xff31 (** Hangul start/stop(toggle) *) let xk_Hangul_Start = 0xff32 (** Hangul start *) let xk_Hangul_End = 0xff33 (** Hangul end, English start *) let xk_Hangul_Hanja = 0xff34 (** Start Hangul->Hanja Conversion *) let xk_Hangul_Jamo = 0xff35 (** Hangul Jamo mode *) let xk_Hangul_Romaja = 0xff36 (** Hangul Romaja mode *) let xk_Hangul_Codeinput = 0xff37 (** Hangul code input mode *) let xk_Hangul_Jeonja = 0xff38 (** Jeonja mode *) let xk_Hangul_Banja = 0xff39 (** Banja mode *) let xk_Hangul_PreHanja = 0xff3a (** Pre Hanja conversion *) let xk_Hangul_PostHanja = 0xff3b (** Post Hanja conversion *) let xk_Hangul_SingleCandidate = 0xff3c (** Single candidate *) let xk_Hangul_MultipleCandidate = 0xff3d (** Multiple candidate *) let xk_Hangul_PreviousCandidate = 0xff3e (** Previous candidate *) let xk_Hangul_Special = 0xff3f (** Special symbols *) let xk_Hangul_switch = 0xFF7E (** Alias for mode_switch *) (** Hangul Consonant Characters *) let xk_Hangul_Kiyeog = 0xea1 let xk_Hangul_SsangKiyeog = 0xea2 let xk_Hangul_KiyeogSios = 0xea3 let xk_Hangul_Nieun = 0xea4 let xk_Hangul_NieunJieuj = 0xea5 let xk_Hangul_NieunHieuh = 0xea6 let xk_Hangul_Dikeud = 0xea7 let xk_Hangul_SsangDikeud = 0xea8 let xk_Hangul_Rieul = 0xea9 let xk_Hangul_RieulKiyeog = 0xeaa let xk_Hangul_RieulMieum = 0xeab let xk_Hangul_RieulPieub = 0xeac let xk_Hangul_RieulSios = 0xead let xk_Hangul_RieulTieut = 0xeae let xk_Hangul_RieulPhieuf = 0xeaf let xk_Hangul_RieulHieuh = 0xeb0 let xk_Hangul_Mieum = 0xeb1 let xk_Hangul_Pieub = 0xeb2 let xk_Hangul_SsangPieub = 0xeb3 let xk_Hangul_PieubSios = 0xeb4 let xk_Hangul_Sios = 0xeb5 let xk_Hangul_SsangSios = 0xeb6 let xk_Hangul_Ieung = 0xeb7 let xk_Hangul_Jieuj = 0xeb8 let xk_Hangul_SsangJieuj = 0xeb9 let xk_Hangul_Cieuc = 0xeba let xk_Hangul_Khieuq = 0xebb let xk_Hangul_Tieut = 0xebc let xk_Hangul_Phieuf = 0xebd let xk_Hangul_Hieuh = 0xebe (** Hangul Vowel Characters *) let xk_Hangul_A = 0xebf let xk_Hangul_AE = 0xec0 let xk_Hangul_YA = 0xec1 let xk_Hangul_YAE = 0xec2 let xk_Hangul_EO = 0xec3 let xk_Hangul_E = 0xec4 let xk_Hangul_YEO = 0xec5 let xk_Hangul_YE = 0xec6 let xk_Hangul_O = 0xec7 let xk_Hangul_WA = 0xec8 let xk_Hangul_WAE = 0xec9 let xk_Hangul_OE = 0xeca let xk_Hangul_YO = 0xecb let xk_Hangul_U = 0xecc let xk_Hangul_WEO = 0xecd let xk_Hangul_WE = 0xece let xk_Hangul_WI = 0xecf let xk_Hangul_YU = 0xed0 let xk_Hangul_EU = 0xed1 let xk_Hangul_YI = 0xed2 let xk_Hangul_I = 0xed3 (** Hangul syllable-final (JongSeong) Characters *) let xk_Hangul_J_Kiyeog = 0xed4 let xk_Hangul_J_SsangKiyeog = 0xed5 let xk_Hangul_J_KiyeogSios = 0xed6 let xk_Hangul_J_Nieun = 0xed7 let xk_Hangul_J_NieunJieuj = 0xed8 let xk_Hangul_J_NieunHieuh = 0xed9 let xk_Hangul_J_Dikeud = 0xeda let xk_Hangul_J_Rieul = 0xedb let xk_Hangul_J_RieulKiyeog = 0xedc let xk_Hangul_J_RieulMieum = 0xedd let xk_Hangul_J_RieulPieub = 0xede let xk_Hangul_J_RieulSios = 0xedf let xk_Hangul_J_RieulTieut = 0xee0 let xk_Hangul_J_RieulPhieuf = 0xee1 let xk_Hangul_J_RieulHieuh = 0xee2 let xk_Hangul_J_Mieum = 0xee3 let xk_Hangul_J_Pieub = 0xee4 let xk_Hangul_J_PieubSios = 0xee5 let xk_Hangul_J_Sios = 0xee6 let xk_Hangul_J_SsangSios = 0xee7 let xk_Hangul_J_Ieung = 0xee8 let xk_Hangul_J_Jieuj = 0xee9 let xk_Hangul_J_Cieuc = 0xeea let xk_Hangul_J_Khieuq = 0xeeb let xk_Hangul_J_Tieut = 0xeec let xk_Hangul_J_Phieuf = 0xeed let xk_Hangul_J_Hieuh = 0xeee (** Ancient Hangul Consonant Characters *) let xk_Hangul_RieulYeorinHieuh = 0xeef let xk_Hangul_SunkyeongeumMieum = 0xef0 let xk_Hangul_SunkyeongeumPieub = 0xef1 let xk_Hangul_PanSios = 0xef2 let xk_Hangul_KkogjiDalrinIeung = 0xef3 let xk_Hangul_SunkyeongeumPhieuf = 0xef4 let xk_Hangul_YeorinHieuh = 0xef5 (** Ancient Hangul Vowel Characters *) let xk_Hangul_AraeA = 0xef6 let xk_Hangul_AraeAE = 0xef7 (** Ancient Hangul syllable-final (JongSeong) Characters *) let xk_Hangul_J_PanSios = 0xef8 let xk_Hangul_J_KkogjiDalrinIeung = 0xef9 let xk_Hangul_J_YeorinHieuh = 0xefa (** Korean currency symbol *) let xk_Korean_Won = 0xeff let name_to_keysym = [ "VoidSymbol",0xFFFFFF; "BackSpace",0xFF08; "Tab",0xFF09; "Linefeed",0xFF0A; "Clear",0xFF0B; "Return",0xFF0D; "Pause",0xFF13; "Scroll_Lock",0xFF14; "Sys_Req",0xFF15; "Escape",0xFF1B; "Delete",0xFFFF; "Multi_key",0xFF20; "Kanji",0xFF21; "Muhenkan",0xFF22; "Henkan_Mode",0xFF23; "Henkan",0xFF23; "Romaji",0xFF24; "Hiragana",0xFF25; "Katakana",0xFF26; "Hiragana_Katakana",0xFF27; "Zenkaku",0xFF28; "Hankaku",0xFF29; "Zenkaku_Hankaku",0xFF2A; "Touroku",0xFF2B; "Massyo",0xFF2C; "Kana_Lock",0xFF2D; "Kana_Shift",0xFF2E; "Eisu_Shift",0xFF2F; "Eisu_toggle",0xFF30; "Home",0xFF50; "Left",0xFF51; "Up",0xFF52; "Right",0xFF53; "Down",0xFF54; "Prior",0xFF55; "Page_Up",0xFF55; "Next",0xFF56; "Page_Down",0xFF56; "End",0xFF57; "Begin",0xFF58; "Select",0xFF60; "Print",0xFF61; "Execute",0xFF62; "Insert",0xFF63; "Undo",0xFF65; "Redo",0xFF66; "Menu",0xFF67; "Find",0xFF68; "Cancel",0xFF69; "Help",0xFF6A; "Break",0xFF6B; "Mode_switch",0xFF7E; "script_switch",0xFF7E; "Num_Lock",0xFF7F; "KP_Space",0xFF80; "KP_Tab",0xFF89; "KP_Enter",0xFF8D; "KP_F1",0xFF91; "KP_F2",0xFF92; "KP_F3",0xFF93; "KP_F4",0xFF94; "KP_Home",0xFF95; "KP_Left",0xFF96; "KP_Up",0xFF97; "KP_Right",0xFF98; "KP_Down",0xFF99; "KP_Prior",0xFF9A; "KP_Page_Up",0xFF9A; "KP_Next",0xFF9B; "KP_Page_Down",0xFF9B; "KP_End",0xFF9C; "KP_Begin",0xFF9D; "KP_Insert",0xFF9E; "KP_Delete",0xFF9F; "KP_Equal",0xFFBD; "KP_Multiply",0xFFAA; "KP_Add",0xFFAB; "KP_Separator",0xFFAC; "KP_Subtract",0xFFAD; "KP_Decimal",0xFFAE; "KP_Divide",0xFFAF; "KP_0",0xFFB0; "KP_1",0xFFB1; "KP_2",0xFFB2; "KP_3",0xFFB3; "KP_4",0xFFB4; "KP_5",0xFFB5; "KP_6",0xFFB6; "KP_7",0xFFB7; "KP_8",0xFFB8; "KP_9",0xFFB9; "F1",0xFFBE; "F2",0xFFBF; "F3",0xFFC0; "F4",0xFFC1; "F5",0xFFC2; "F6",0xFFC3; "F7",0xFFC4; "F8",0xFFC5; "F9",0xFFC6; "F10",0xFFC7; "F11",0xFFC8; "L1",0xFFC8; "F12",0xFFC9; "L2",0xFFC9; "F13",0xFFCA; "L3",0xFFCA; "F14",0xFFCB; "L4",0xFFCB; "F15",0xFFCC; "L5",0xFFCC; "F16",0xFFCD; "L6",0xFFCD; "F17",0xFFCE; "L7",0xFFCE; "F18",0xFFCF; "L8",0xFFCF; "F19",0xFFD0; "L9",0xFFD0; "F20",0xFFD1; "L10",0xFFD1; "F21",0xFFD2; "R1",0xFFD2; "F22",0xFFD3; "R2",0xFFD3; "F23",0xFFD4; "R3",0xFFD4; "F24",0xFFD5; "R4",0xFFD5; "F25",0xFFD6; "R5",0xFFD6; "F26",0xFFD7; "R6",0xFFD7; "F27",0xFFD8; "R7",0xFFD8; "F28",0xFFD9; "R8",0xFFD9; "F29",0xFFDA; "R9",0xFFDA; "F30",0xFFDB; "R10",0xFFDB; "F31",0xFFDC; "R11",0xFFDC; "F32",0xFFDD; "R12",0xFFDD; "F33",0xFFDE; "R13",0xFFDE; "F34",0xFFDF; "R14",0xFFDF; "F35",0xFFE0; "R15",0xFFE0; "Shift_L",0xFFE1; "Shift_R",0xFFE2; "Control_L",0xFFE3; "Control_R",0xFFE4; "Caps_Lock",0xFFE5; "Shift_Lock",0xFFE6; "Meta_L",0xFFE7; "Meta_R",0xFFE8; "Alt_L",0xFFE9; "Alt_R",0xFFEA; "Super_L",0xFFEB; "Super_R",0xFFEC; "Hyper_L",0xFFED; "Hyper_R",0xFFEE; "ISO_Lock",0xFE01; "ISO_Level2_Latch",0xFE02; "ISO_Level3_Shift",0xFE03; "ISO_Level3_Latch",0xFE04; "ISO_Level3_Lock",0xFE05; "ISO_Group_Shift",0xFF7E; "ISO_Group_Latch",0xFE06; "ISO_Group_Lock",0xFE07; "ISO_Next_Group",0xFE08; "ISO_Next_Group_Lock",0xFE09; "ISO_Prev_Group",0xFE0A; "ISO_Prev_Group_Lock",0xFE0B; "ISO_First_Group",0xFE0C; "ISO_First_Group_Lock",0xFE0D; "ISO_Last_Group",0xFE0E; "ISO_Last_Group_Lock",0xFE0F; "ISO_Left_Tab",0xFE20; "ISO_Move_Line_Up",0xFE21; "ISO_Move_Line_Down",0xFE22; "ISO_Partial_Line_Up",0xFE23; "ISO_Partial_Line_Down",0xFE24; "ISO_Partial_Space_Left",0xFE25; "ISO_Partial_Space_Right",0xFE26; "ISO_Set_Margin_Left",0xFE27; "ISO_Set_Margin_Right",0xFE28; "ISO_Release_Margin_Left",0xFE29; "ISO_Release_Margin_Right",0xFE2A; "ISO_Release_Both_Margins",0xFE2B; "ISO_Fast_Cursor_Left",0xFE2C; "ISO_Fast_Cursor_Right",0xFE2D; "ISO_Fast_Cursor_Up",0xFE2E; "ISO_Fast_Cursor_Down",0xFE2F; "ISO_Continuous_Underline",0xFE30; "ISO_Discontinuous_Underline",0xFE31; "ISO_Emphasize",0xFE32; "ISO_Center_Object",0xFE33; "ISO_Enter",0xFE34; "dead_grave",0xFE50; "dead_acute",0xFE51; "dead_circumflex",0xFE52; "dead_tilde",0xFE53; "dead_macron",0xFE54; "dead_breve",0xFE55; "dead_abovedot",0xFE56; "dead_diaeresis",0xFE57; "dead_abovering",0xFE58; "dead_doubleacute",0xFE59; "dead_caron",0xFE5A; "dead_cedilla",0xFE5B; "dead_ogonek",0xFE5C; "dead_iota",0xFE5D; "dead_voiced_sound",0xFE5E; "dead_semivoiced_sound",0xFE5F; "dead_belowdot",0xFE60; "First_Virtual_Screen",0xFED0; "Prev_Virtual_Screen",0xFED1; "Next_Virtual_Screen",0xFED2; "Last_Virtual_Screen",0xFED4; "Terminate_Server",0xFED5; "AccessX_Enable",0xFE70; "AccessX_Feedback_Enable",0xFE71; "RepeatKeys_Enable",0xFE72; "SlowKeys_Enable",0xFE73; "BounceKeys_Enable",0xFE74; "StickyKeys_Enable",0xFE75; "MouseKeys_Enable",0xFE76; "MouseKeys_Accel_Enable",0xFE77; "Overlay1_Enable",0xFE78; "Overlay2_Enable",0xFE79; "AudibleBell_Enable",0xFE7A; "Pointer_Left",0xFEE0; "Pointer_Right",0xFEE1; "Pointer_Up",0xFEE2; "Pointer_Down",0xFEE3; "Pointer_UpLeft",0xFEE4; "Pointer_UpRight",0xFEE5; "Pointer_DownLeft",0xFEE6; "Pointer_DownRight",0xFEE7; "Pointer_Button_Dflt",0xFEE8; "Pointer_Button1",0xFEE9; "Pointer_Button2",0xFEEA; "Pointer_Button3",0xFEEB; "Pointer_Button4",0xFEEC; "Pointer_Button5",0xFEED; "Pointer_DblClick_Dflt",0xFEEE; "Pointer_DblClick1",0xFEEF; "Pointer_DblClick2",0xFEF0; "Pointer_DblClick3",0xFEF1; "Pointer_DblClick4",0xFEF2; "Pointer_DblClick5",0xFEF3; "Pointer_Drag_Dflt",0xFEF4; "Pointer_Drag1",0xFEF5; "Pointer_Drag2",0xFEF6; "Pointer_Drag3",0xFEF7; "Pointer_Drag4",0xFEF8; "Pointer_Drag5",0xFEFD; "Pointer_EnableKeys",0xFEF9; "Pointer_Accelerate",0xFEFA; "Pointer_DfltBtnNext",0xFEFB; "Pointer_DfltBtnPrev",0xFEFC; "3270_Duplicate",0xFD01; "3270_FieldMark",0xFD02; "3270_Right2",0xFD03; "3270_Left2",0xFD04; "3270_BackTab",0xFD05; "3270_EraseEOF",0xFD06; "3270_EraseInput",0xFD07; "3270_Reset",0xFD08; "3270_Quit",0xFD09; "3270_PA1",0xFD0A; "3270_PA2",0xFD0B; "3270_PA3",0xFD0C; "3270_Test",0xFD0D; "3270_Attn",0xFD0E; "3270_CursorBlink",0xFD0F; "3270_AltCursor",0xFD10; "3270_KeyClick",0xFD11; "3270_Jump",0xFD12; "3270_Ident",0xFD13; "3270_Rule",0xFD14; "3270_Copy",0xFD15; "3270_Play",0xFD16; "3270_Setup",0xFD17; "3270_Record",0xFD18; "3270_ChangeScreen",0xFD19; "3270_DeleteWord",0xFD1A; "3270_ExSelect",0xFD1B; "3270_CursorSelect",0xFD1C; "3270_PrintScreen",0xFD1D; "3270_Enter",0xFD1E; "space",0x020; "exclam",0x021; "quotedbl",0x022; "numbersign",0x023; "dollar",0x024; "percent",0x025; "ampersand",0x026; "apostrophe",0x027; "quoteright",0x027; "parenleft",0x028; "parenright",0x029; "asterisk",0x02a; "plus",0x02b; "comma",0x02c; "minus",0x02d; "period",0x02e; "slash",0x02f; "0",0x030; "1",0x031; "2",0x032; "3",0x033; "4",0x034; "5",0x035; "6",0x036; "7",0x037; "8",0x038; "9",0x039; "colon",0x03a; "semicolon",0x03b; "less",0x03c; "equal",0x03d; "greater",0x03e; "question",0x03f; "at",0x040; "A",0x041; "B",0x042; "C",0x043; "D",0x044; "E",0x045; "F",0x046; "G",0x047; "H",0x048; "I",0x049; "J",0x04a; "K",0x04b; "L",0x04c; "M",0x04d; "N",0x04e; "O",0x04f; "P",0x050; "Q",0x051; "R",0x052; "S",0x053; "T",0x054; "U",0x055; "V",0x056; "W",0x057; "X",0x058; "Y",0x059; "Z",0x05a; "bracketleft",0x05b; "backslash",0x05c; "bracketright",0x05d; "asciicircum",0x05e; "underscore",0x05f; "grave",0x060; "quoteleft",0x060; "a",0x061; "b",0x062; "c",0x063; "d",0x064; "e",0x065; "f",0x066; "g",0x067; "h",0x068; "i",0x069; "j",0x06a; "k",0x06b; "l",0x06c; "m",0x06d; "n",0x06e; "o",0x06f; "p",0x070; "q",0x071; "r",0x072; "s",0x073; "t",0x074; "u",0x075; "v",0x076; "w",0x077; "x",0x078; "y",0x079; "z",0x07a; "braceleft",0x07b; "bar",0x07c; "braceright",0x07d; "asciitilde",0x07e; "nobreakspace",0x0a0; "exclamdown",0x0a1; "cent",0x0a2; "sterling",0x0a3; "currency",0x0a4; "yen",0x0a5; "brokenbar",0x0a6; "section",0x0a7; "diaeresis",0x0a8; "copyright",0x0a9; "ordfeminine",0x0aa; "guillemotleft",0x0ab; "notsign",0x0ac; "hyphen",0x0ad; "registered",0x0ae; "macron",0x0af; "degree",0x0b0; "plusminus",0x0b1; "twosuperior",0x0b2; "threesuperior",0x0b3; "acute",0x0b4; "mu",0x0b5; "paragraph",0x0b6; "periodcentered",0x0b7; "cedilla",0x0b8; "onesuperior",0x0b9; "masculine",0x0ba; "guillemotright",0x0bb; "onequarter",0x0bc; "onehalf",0x0bd; "threequarters",0x0be; "questiondown",0x0bf; "Agrave",0x0c0; "Aacute",0x0c1; "Acircumflex",0x0c2; "Atilde",0x0c3; "Adiaeresis",0x0c4; "Aring",0x0c5; "AE",0x0c6; "Ccedilla",0x0c7; "Egrave",0x0c8; "Eacute",0x0c9; "Ecircumflex",0x0ca; "Ediaeresis",0x0cb; "Igrave",0x0cc; "Iacute",0x0cd; "Icircumflex",0x0ce; "Idiaeresis",0x0cf; "ETH",0x0d0; "Eth",0x0d0; "Ntilde",0x0d1; "Ograve",0x0d2; "Oacute",0x0d3; "Ocircumflex",0x0d4; "Otilde",0x0d5; "Odiaeresis",0x0d6; "multiply",0x0d7; "Ooblique",0x0d8; "Ugrave",0x0d9; "Uacute",0x0da; "Ucircumflex",0x0db; "Udiaeresis",0x0dc; "Yacute",0x0dd; "THORN",0x0de; "Thorn",0x0de; "ssharp",0x0df; "agrave",0x0e0; "aacute",0x0e1; "acircumflex",0x0e2; "atilde",0x0e3; "adiaeresis",0x0e4; "aring",0x0e5; "ae",0x0e6; "ccedilla",0x0e7; "egrave",0x0e8; "eacute",0x0e9; "ecircumflex",0x0ea; "ediaeresis",0x0eb; "igrave",0x0ec; "iacute",0x0ed; "icircumflex",0x0ee; "idiaeresis",0x0ef; "eth",0x0f0; "ntilde",0x0f1; "ograve",0x0f2; "oacute",0x0f3; "ocircumflex",0x0f4; "otilde",0x0f5; "odiaeresis",0x0f6; "division",0x0f7; "oslash",0x0f8; "ugrave",0x0f9; "uacute",0x0fa; "ucircumflex",0x0fb; "udiaeresis",0x0fc; "yacute",0x0fd; "thorn",0x0fe; "ydiaeresis",0x0ff; "Aogonek",0x1a1; "breve",0x1a2; "Lstroke",0x1a3; "Lcaron",0x1a5; "Sacute",0x1a6; "Scaron",0x1a9; "Scedilla",0x1aa; "Tcaron",0x1ab; "Zacute",0x1ac; "Zcaron",0x1ae; "Zabovedot",0x1af; "aogonek",0x1b1; "ogonek",0x1b2; "lstroke",0x1b3; "lcaron",0x1b5; "sacute",0x1b6; "caron",0x1b7; "scaron",0x1b9; "scedilla",0x1ba; "tcaron",0x1bb; "zacute",0x1bc; "doubleacute",0x1bd; "zcaron",0x1be; "zabovedot",0x1bf; "Racute",0x1c0; "Abreve",0x1c3; "Lacute",0x1c5; "Cacute",0x1c6; "Ccaron",0x1c8; "Eogonek",0x1ca; "Ecaron",0x1cc; "Dcaron",0x1cf; "Dstroke",0x1d0; "Nacute",0x1d1; "Ncaron",0x1d2; "Odoubleacute",0x1d5; "Rcaron",0x1d8; "Uring",0x1d9; "Udoubleacute",0x1db; "Tcedilla",0x1de; "racute",0x1e0; "abreve",0x1e3; "lacute",0x1e5; "cacute",0x1e6; "ccaron",0x1e8; "eogonek",0x1ea; "ecaron",0x1ec; "dcaron",0x1ef; "dstroke",0x1f0; "nacute",0x1f1; "ncaron",0x1f2; "odoubleacute",0x1f5; "udoubleacute",0x1fb; "rcaron",0x1f8; "uring",0x1f9; "tcedilla",0x1fe; "abovedot",0x1ff; "Hstroke",0x2a1; "Hcircumflex",0x2a6; "Iabovedot",0x2a9; "Gbreve",0x2ab; "Jcircumflex",0x2ac; "hstroke",0x2b1; "hcircumflex",0x2b6; "idotless",0x2b9; "gbreve",0x2bb; "jcircumflex",0x2bc; "Cabovedot",0x2c5; "Ccircumflex",0x2c6; "Gabovedot",0x2d5; "Gcircumflex",0x2d8; "Ubreve",0x2dd; "Scircumflex",0x2de; "cabovedot",0x2e5; "ccircumflex",0x2e6; "gabovedot",0x2f5; "gcircumflex",0x2f8; "ubreve",0x2fd; "scircumflex",0x2fe; "kra",0x3a2; "kappa",0x3a2; "Rcedilla",0x3a3; "Itilde",0x3a5; "Lcedilla",0x3a6; "Emacron",0x3aa; "Gcedilla",0x3ab; "Tslash",0x3ac; "rcedilla",0x3b3; "itilde",0x3b5; "lcedilla",0x3b6; "emacron",0x3ba; "gcedilla",0x3bb; "tslash",0x3bc; "ENG",0x3bd; "eng",0x3bf; "Amacron",0x3c0; "Iogonek",0x3c7; "Eabovedot",0x3cc; "Imacron",0x3cf; "Ncedilla",0x3d1; "Omacron",0x3d2; "Kcedilla",0x3d3; "Uogonek",0x3d9; "Utilde",0x3dd; "Umacron",0x3de; "amacron",0x3e0; "iogonek",0x3e7; "eabovedot",0x3ec; "imacron",0x3ef; "ncedilla",0x3f1; "omacron",0x3f2; "kcedilla",0x3f3; "uogonek",0x3f9; "utilde",0x3fd; "umacron",0x3fe; "overline",0x47e; "kana_fullstop",0x4a1; "kana_openingbracket",0x4a2; "kana_closingbracket",0x4a3; "kana_comma",0x4a4; "kana_conjunctive",0x4a5; "kana_middledot",0x4a5; "kana_WO",0x4a6; "kana_a",0x4a7; "kana_i",0x4a8; "kana_u",0x4a9; "kana_e",0x4aa; "kana_o",0x4ab; "kana_ya",0x4ac; "kana_yu",0x4ad; "kana_yo",0x4ae; "kana_tsu",0x4af; "kana_tu",0x4af; "prolongedsound",0x4b0; "kana_A",0x4b1; "kana_I",0x4b2; "kana_U",0x4b3; "kana_E",0x4b4; "kana_O",0x4b5; "kana_KA",0x4b6; "kana_KI",0x4b7; "kana_KU",0x4b8; "kana_KE",0x4b9; "kana_KO",0x4ba; "kana_SA",0x4bb; "kana_SHI",0x4bc; "kana_SU",0x4bd; "kana_SE",0x4be; "kana_SO",0x4bf; "kana_TA",0x4c0; "kana_CHI",0x4c1; "kana_TI",0x4c1; "kana_TSU",0x4c2; "kana_TU",0x4c2; "kana_TE",0x4c3; "kana_TO",0x4c4; "kana_NA",0x4c5; "kana_NI",0x4c6; "kana_NU",0x4c7; "kana_NE",0x4c8; "kana_NO",0x4c9; "kana_HA",0x4ca; "kana_HI",0x4cb; "kana_FU",0x4cc; "kana_HU",0x4cc; "kana_HE",0x4cd; "kana_HO",0x4ce; "kana_MA",0x4cf; "kana_MI",0x4d0; "kana_MU",0x4d1; "kana_ME",0x4d2; "kana_MO",0x4d3; "kana_YA",0x4d4; "kana_YU",0x4d5; "kana_YO",0x4d6; "kana_RA",0x4d7; "kana_RI",0x4d8; "kana_RU",0x4d9; "kana_RE",0x4da; "kana_RO",0x4db; "kana_WA",0x4dc; "kana_N",0x4dd; "voicedsound",0x4de; "semivoicedsound",0x4df; "kana_switch",0xFF7E; "Arabic_comma",0x5ac; "Arabic_semicolon",0x5bb; "Arabic_question_mark",0x5bf; "Arabic_hamza",0x5c1; "Arabic_maddaonalef",0x5c2; "Arabic_hamzaonalef",0x5c3; "Arabic_hamzaonwaw",0x5c4; "Arabic_hamzaunderalef",0x5c5; "Arabic_hamzaonyeh",0x5c6; "Arabic_alef",0x5c7; "Arabic_beh",0x5c8; "Arabic_tehmarbuta",0x5c9; "Arabic_teh",0x5ca; "Arabic_theh",0x5cb; "Arabic_jeem",0x5cc; "Arabic_hah",0x5cd; "Arabic_khah",0x5ce; "Arabic_dal",0x5cf; "Arabic_thal",0x5d0; "Arabic_ra",0x5d1; "Arabic_zain",0x5d2; "Arabic_seen",0x5d3; "Arabic_sheen",0x5d4; "Arabic_sad",0x5d5; "Arabic_dad",0x5d6; "Arabic_tah",0x5d7; "Arabic_zah",0x5d8; "Arabic_ain",0x5d9; "Arabic_ghain",0x5da; "Arabic_tatweel",0x5e0; "Arabic_feh",0x5e1; "Arabic_qaf",0x5e2; "Arabic_kaf",0x5e3; "Arabic_lam",0x5e4; "Arabic_meem",0x5e5; "Arabic_noon",0x5e6; "Arabic_ha",0x5e7; "Arabic_heh",0x5e7; "Arabic_waw",0x5e8; "Arabic_alefmaksura",0x5e9; "Arabic_yeh",0x5ea; "Arabic_fathatan",0x5eb; "Arabic_dammatan",0x5ec; "Arabic_kasratan",0x5ed; "Arabic_fatha",0x5ee; "Arabic_damma",0x5ef; "Arabic_kasra",0x5f0; "Arabic_shadda",0x5f1; "Arabic_sukun",0x5f2; "Arabic_switch",0xFF7E; "Serbian_dje",0x6a1; "Macedonia_gje",0x6a2; "Cyrillic_io",0x6a3; "Ukrainian_ie",0x6a4; "Ukranian_je",0x6a4; "Macedonia_dse",0x6a5; "Ukrainian_i",0x6a6; "Ukranian_i",0x6a6; "Ukrainian_yi",0x6a7; "Ukranian_yi",0x6a7; "Cyrillic_je",0x6a8; "Serbian_je",0x6a8; "Cyrillic_lje",0x6a9; "Serbian_lje",0x6a9; "Cyrillic_nje",0x6aa; "Serbian_nje",0x6aa; "Serbian_tshe",0x6ab; "Macedonia_kje",0x6ac; "Byelorussian_shortu",0x6ae; "Cyrillic_dzhe",0x6af; "Serbian_dze",0x6af; "numerosign",0x6b0; "Serbian_DJE",0x6b1; "Macedonia_GJE",0x6b2; "Cyrillic_IO",0x6b3; "Ukrainian_IE",0x6b4; "Ukranian_JE",0x6b4; "Macedonia_DSE",0x6b5; "Ukrainian_I",0x6b6; "Ukranian_I",0x6b6; "Ukrainian_YI",0x6b7; "Ukranian_YI",0x6b7; "Cyrillic_JE",0x6b8; "Serbian_JE",0x6b8; "Cyrillic_LJE",0x6b9; "Serbian_LJE",0x6b9; "Cyrillic_NJE",0x6ba; "Serbian_NJE",0x6ba; "Serbian_TSHE",0x6bb; "Macedonia_KJE",0x6bc; "Byelorussian_SHORTU",0x6be; "Cyrillic_DZHE",0x6bf; "Serbian_DZE",0x6bf; "Cyrillic_yu",0x6c0; "Cyrillic_a",0x6c1; "Cyrillic_be",0x6c2; "Cyrillic_tse",0x6c3; "Cyrillic_de",0x6c4; "Cyrillic_ie",0x6c5; "Cyrillic_ef",0x6c6; "Cyrillic_ghe",0x6c7; "Cyrillic_ha",0x6c8; "Cyrillic_i",0x6c9; "Cyrillic_shorti",0x6ca; "Cyrillic_ka",0x6cb; "Cyrillic_el",0x6cc; "Cyrillic_em",0x6cd; "Cyrillic_en",0x6ce; "Cyrillic_o",0x6cf; "Cyrillic_pe",0x6d0; "Cyrillic_ya",0x6d1; "Cyrillic_er",0x6d2; "Cyrillic_es",0x6d3; "Cyrillic_te",0x6d4; "Cyrillic_u",0x6d5; "Cyrillic_zhe",0x6d6; "Cyrillic_ve",0x6d7; "Cyrillic_softsign",0x6d8; "Cyrillic_yeru",0x6d9; "Cyrillic_ze",0x6da; "Cyrillic_sha",0x6db; "Cyrillic_e",0x6dc; "Cyrillic_shcha",0x6dd; "Cyrillic_che",0x6de; "Cyrillic_hardsign",0x6df; "Cyrillic_YU",0x6e0; "Cyrillic_A",0x6e1; "Cyrillic_BE",0x6e2; "Cyrillic_TSE",0x6e3; "Cyrillic_DE",0x6e4; "Cyrillic_IE",0x6e5; "Cyrillic_EF",0x6e6; "Cyrillic_GHE",0x6e7; "Cyrillic_HA",0x6e8; "Cyrillic_I",0x6e9; "Cyrillic_SHORTI",0x6ea; "Cyrillic_KA",0x6eb; "Cyrillic_EL",0x6ec; "Cyrillic_EM",0x6ed; "Cyrillic_EN",0x6ee; "Cyrillic_O",0x6ef; "Cyrillic_PE",0x6f0; "Cyrillic_YA",0x6f1; "Cyrillic_ER",0x6f2; "Cyrillic_ES",0x6f3; "Cyrillic_TE",0x6f4; "Cyrillic_U",0x6f5; "Cyrillic_ZHE",0x6f6; "Cyrillic_VE",0x6f7; "Cyrillic_SOFTSIGN",0x6f8; "Cyrillic_YERU",0x6f9; "Cyrillic_ZE",0x6fa; "Cyrillic_SHA",0x6fb; "Cyrillic_E",0x6fc; "Cyrillic_SHCHA",0x6fd; "Cyrillic_CHE",0x6fe; "Cyrillic_HARDSIGN",0x6ff; "Greek_ALPHAaccent",0x7a1; "Greek_EPSILONaccent",0x7a2; "Greek_ETAaccent",0x7a3; "Greek_IOTAaccent",0x7a4; "Greek_IOTAdiaeresis",0x7a5; "Greek_OMICRONaccent",0x7a7; "Greek_UPSILONaccent",0x7a8; "Greek_UPSILONdieresis",0x7a9; "Greek_OMEGAaccent",0x7ab; "Greek_accentdieresis",0x7ae; "Greek_horizbar",0x7af; "Greek_alphaaccent",0x7b1; "Greek_epsilonaccent",0x7b2; "Greek_etaaccent",0x7b3; "Greek_iotaaccent",0x7b4; "Greek_iotadieresis",0x7b5; "Greek_iotaaccentdieresis",0x7b6; "Greek_omicronaccent",0x7b7; "Greek_upsilonaccent",0x7b8; "Greek_upsilondieresis",0x7b9; "Greek_upsilonaccentdieresis",0x7ba; "Greek_omegaaccent",0x7bb; "Greek_ALPHA",0x7c1; "Greek_BETA",0x7c2; "Greek_GAMMA",0x7c3; "Greek_DELTA",0x7c4; "Greek_EPSILON",0x7c5; "Greek_ZETA",0x7c6; "Greek_ETA",0x7c7; "Greek_THETA",0x7c8; "Greek_IOTA",0x7c9; "Greek_KAPPA",0x7ca; "Greek_LAMDA",0x7cb; "Greek_LAMBDA",0x7cb; "Greek_MU",0x7cc; "Greek_NU",0x7cd; "Greek_XI",0x7ce; "Greek_OMICRON",0x7cf; "Greek_PI",0x7d0; "Greek_RHO",0x7d1; "Greek_SIGMA",0x7d2; "Greek_TAU",0x7d4; "Greek_UPSILON",0x7d5; "Greek_PHI",0x7d6; "Greek_CHI",0x7d7; "Greek_PSI",0x7d8; "Greek_OMEGA",0x7d9; "Greek_alpha",0x7e1; "Greek_beta",0x7e2; "Greek_gamma",0x7e3; "Greek_delta",0x7e4; "Greek_epsilon",0x7e5; "Greek_zeta",0x7e6; "Greek_eta",0x7e7; "Greek_theta",0x7e8; "Greek_iota",0x7e9; "Greek_kappa",0x7ea; "Greek_lamda",0x7eb; "Greek_lambda",0x7eb; "Greek_mu",0x7ec; "Greek_nu",0x7ed; "Greek_xi",0x7ee; "Greek_omicron",0x7ef; "Greek_pi",0x7f0; "Greek_rho",0x7f1; "Greek_sigma",0x7f2; "Greek_finalsmallsigma",0x7f3; "Greek_tau",0x7f4; "Greek_upsilon",0x7f5; "Greek_phi",0x7f6; "Greek_chi",0x7f7; "Greek_psi",0x7f8; "Greek_omega",0x7f9; "Greek_switch",0xFF7E; "leftradical",0x8a1; "topleftradical",0x8a2; "horizconnector",0x8a3; "topintegral",0x8a4; "botintegral",0x8a5; "vertconnector",0x8a6; "topleftsqbracket",0x8a7; "botleftsqbracket",0x8a8; "toprightsqbracket",0x8a9; "botrightsqbracket",0x8aa; "topleftparens",0x8ab; "botleftparens",0x8ac; "toprightparens",0x8ad; "botrightparens",0x8ae; "leftmiddlecurlybrace",0x8af; "rightmiddlecurlybrace",0x8b0; "topleftsummation",0x8b1; "botleftsummation",0x8b2; "topvertsummationconnector",0x8b3; "botvertsummationconnector",0x8b4; "toprightsummation",0x8b5; "botrightsummation",0x8b6; "rightmiddlesummation",0x8b7; "lessthanequal",0x8bc; "notequal",0x8bd; "greaterthanequal",0x8be; "integral",0x8bf; "therefore",0x8c0; "variation",0x8c1; "infinity",0x8c2; "nabla",0x8c5; "approximate",0x8c8; "similarequal",0x8c9; "ifonlyif",0x8cd; "implies",0x8ce; "identical",0x8cf; "radical",0x8d6; "includedin",0x8da; "includes",0x8db; "intersection",0x8dc; "union",0x8dd; "logicaland",0x8de; "logicalor",0x8df; "partialderivative",0x8ef; "function",0x8f6; "leftarrow",0x8fb; "uparrow",0x8fc; "rightarrow",0x8fd; "downarrow",0x8fe; "blank",0x9df; "soliddiamond",0x9e0; "checkerboard",0x9e1; "ht",0x9e2; "ff",0x9e3; "cr",0x9e4; "lf",0x9e5; "nl",0x9e8; "vt",0x9e9; "lowrightcorner",0x9ea; "uprightcorner",0x9eb; "upleftcorner",0x9ec; "lowleftcorner",0x9ed; "crossinglines",0x9ee; "horizlinescan1",0x9ef; "horizlinescan3",0x9f0; "horizlinescan5",0x9f1; "horizlinescan7",0x9f2; "horizlinescan9",0x9f3; "leftt",0x9f4; "rightt",0x9f5; "bott",0x9f6; "topt",0x9f7; "vertbar",0x9f8; "emspace",0xaa1; "enspace",0xaa2; "em3space",0xaa3; "em4space",0xaa4; "digitspace",0xaa5; "punctspace",0xaa6; "thinspace",0xaa7; "hairspace",0xaa8; "emdash",0xaa9; "endash",0xaaa; "signifblank",0xaac; "ellipsis",0xaae; "doubbaselinedot",0xaaf; "onethird",0xab0; "twothirds",0xab1; "onefifth",0xab2; "twofifths",0xab3; "threefifths",0xab4; "fourfifths",0xab5; "onesixth",0xab6; "fivesixths",0xab7; "careof",0xab8; "figdash",0xabb; "leftanglebracket",0xabc; "decimalpoint",0xabd; "rightanglebracket",0xabe; "marker",0xabf; "oneeighth",0xac3; "threeeighths",0xac4; "fiveeighths",0xac5; "seveneighths",0xac6; "trademark",0xac9; "signaturemark",0xaca; "trademarkincircle",0xacb; "leftopentriangle",0xacc; "rightopentriangle",0xacd; "emopencircle",0xace; "emopenrectangle",0xacf; "leftsinglequotemark",0xad0; "rightsinglequotemark",0xad1; "leftdoublequotemark",0xad2; "rightdoublequotemark",0xad3; "prescription",0xad4; "minutes",0xad6; "seconds",0xad7; "latincross",0xad9; "hexagram",0xada; "filledrectbullet",0xadb; "filledlefttribullet",0xadc; "filledrighttribullet",0xadd; "emfilledcircle",0xade; "emfilledrect",0xadf; "enopencircbullet",0xae0; "enopensquarebullet",0xae1; "openrectbullet",0xae2; "opentribulletup",0xae3; "opentribulletdown",0xae4; "openstar",0xae5; "enfilledcircbullet",0xae6; "enfilledsqbullet",0xae7; "filledtribulletup",0xae8; "filledtribulletdown",0xae9; "leftpointer",0xaea; "rightpointer",0xaeb; "club",0xaec; "diamond",0xaed; "heart",0xaee; "maltesecross",0xaf0; "dagger",0xaf1; "doubledagger",0xaf2; "checkmark",0xaf3; "ballotcross",0xaf4; "musicalsharp",0xaf5; "musicalflat",0xaf6; "malesymbol",0xaf7; "femalesymbol",0xaf8; "telephone",0xaf9; "telephonerecorder",0xafa; "phonographcopyright",0xafb; "caret",0xafc; "singlelowquotemark",0xafd; "doublelowquotemark",0xafe; "cursor",0xaff; "leftcaret",0xba3; "rightcaret",0xba6; "downcaret",0xba8; "upcaret",0xba9; "overbar",0xbc0; "downtack",0xbc2; "upshoe",0xbc3; "downstile",0xbc4; "underbar",0xbc6; "jot",0xbca; "quad",0xbcc; "uptack",0xbce; "circle",0xbcf; "upstile",0xbd3; "downshoe",0xbd6; "rightshoe",0xbd8; "leftshoe",0xbda; "lefttack",0xbdc; "righttack",0xbfc; "hebrew_doublelowline",0xcdf; "hebrew_aleph",0xce0; "hebrew_bet",0xce1; "hebrew_beth",0xce1; "hebrew_gimel",0xce2; "hebrew_gimmel",0xce2; "hebrew_dalet",0xce3; "hebrew_daleth",0xce3; "hebrew_he",0xce4; "hebrew_waw",0xce5; "hebrew_zain",0xce6; "hebrew_zayin",0xce6; "hebrew_chet",0xce7; "hebrew_het",0xce7; "hebrew_tet",0xce8; "hebrew_teth",0xce8; "hebrew_yod",0xce9; "hebrew_finalkaph",0xcea; "hebrew_kaph",0xceb; "hebrew_lamed",0xcec; "hebrew_finalmem",0xced; "hebrew_mem",0xcee; "hebrew_finalnun",0xcef; "hebrew_nun",0xcf0; "hebrew_samech",0xcf1; "hebrew_samekh",0xcf1; "hebrew_ayin",0xcf2; "hebrew_finalpe",0xcf3; "hebrew_pe",0xcf4; "hebrew_finalzade",0xcf5; "hebrew_finalzadi",0xcf5; "hebrew_zade",0xcf6; "hebrew_zadi",0xcf6; "hebrew_qoph",0xcf7; "hebrew_kuf",0xcf7; "hebrew_resh",0xcf8; "hebrew_shin",0xcf9; "hebrew_taw",0xcfa; "hebrew_taf",0xcfa; "Hebrew_switch",0xFF7E; "Thai_kokai",0xda1; "Thai_khokhai",0xda2; "Thai_khokhuat",0xda3; "Thai_khokhwai",0xda4; "Thai_khokhon",0xda5; "Thai_khorakhang",0xda6; "Thai_ngongu",0xda7; "Thai_chochan",0xda8; "Thai_choching",0xda9; "Thai_chochang",0xdaa; "Thai_soso",0xdab; "Thai_chochoe",0xdac; "Thai_yoying",0xdad; "Thai_dochada",0xdae; "Thai_topatak",0xdaf; "Thai_thothan",0xdb0; "Thai_thonangmontho",0xdb1; "Thai_thophuthao",0xdb2; "Thai_nonen",0xdb3; "Thai_dodek",0xdb4; "Thai_totao",0xdb5; "Thai_thothung",0xdb6; "Thai_thothahan",0xdb7; "Thai_thothong",0xdb8; "Thai_nonu",0xdb9; "Thai_bobaimai",0xdba; "Thai_popla",0xdbb; "Thai_phophung",0xdbc; "Thai_fofa",0xdbd; "Thai_phophan",0xdbe; "Thai_fofan",0xdbf; "Thai_phosamphao",0xdc0; "Thai_moma",0xdc1; "Thai_yoyak",0xdc2; "Thai_rorua",0xdc3; "Thai_ru",0xdc4; "Thai_loling",0xdc5; "Thai_lu",0xdc6; "Thai_wowaen",0xdc7; "Thai_sosala",0xdc8; "Thai_sorusi",0xdc9; "Thai_sosua",0xdca; "Thai_hohip",0xdcb; "Thai_lochula",0xdcc; "Thai_oang",0xdcd; "Thai_honokhuk",0xdce; "Thai_paiyannoi",0xdcf; "Thai_saraa",0xdd0; "Thai_maihanakat",0xdd1; "Thai_saraaa",0xdd2; "Thai_saraam",0xdd3; "Thai_sarai",0xdd4; "Thai_saraii",0xdd5; "Thai_saraue",0xdd6; "Thai_sarauee",0xdd7; "Thai_sarau",0xdd8; "Thai_sarauu",0xdd9; "Thai_phinthu",0xdda; "Thai_maihanakat_maitho",0xdde; "Thai_baht",0xddf; "Thai_sarae",0xde0; "Thai_saraae",0xde1; "Thai_sarao",0xde2; "Thai_saraaimaimuan",0xde3; "Thai_saraaimaimalai",0xde4; "Thai_lakkhangyao",0xde5; "Thai_maiyamok",0xde6; "Thai_maitaikhu",0xde7; "Thai_maiek",0xde8; "Thai_maitho",0xde9; "Thai_maitri",0xdea; "Thai_maichattawa",0xdeb; "Thai_thanthakhat",0xdec; "Thai_nikhahit",0xded; "Thai_leksun",0xdf0; "Thai_leknung",0xdf1; "Thai_leksong",0xdf2; "Thai_leksam",0xdf3; "Thai_leksi",0xdf4; "Thai_lekha",0xdf5; "Thai_lekhok",0xdf6; "Thai_lekchet",0xdf7; "Thai_lekpaet",0xdf8; "Thai_lekkao",0xdf9; "Hangul",0xff31; "Hangul_Start",0xff32; "Hangul_End",0xff33; "Hangul_Hanja",0xff34; "Hangul_Jamo",0xff35; "Hangul_Romaja",0xff36; "Hangul_Codeinput",0xff37; "Hangul_Jeonja",0xff38; "Hangul_Banja",0xff39; "Hangul_PreHanja",0xff3a; "Hangul_PostHanja",0xff3b; "Hangul_SingleCandidate",0xff3c; "Hangul_MultipleCandidate",0xff3d; "Hangul_PreviousCandidate",0xff3e; "Hangul_Special",0xff3f; "Hangul_switch",0xFF7E; "Hangul_Kiyeog",0xea1; "Hangul_SsangKiyeog",0xea2; "Hangul_KiyeogSios",0xea3; "Hangul_Nieun",0xea4; "Hangul_NieunJieuj",0xea5; "Hangul_NieunHieuh",0xea6; "Hangul_Dikeud",0xea7; "Hangul_SsangDikeud",0xea8; "Hangul_Rieul",0xea9; "Hangul_RieulKiyeog",0xeaa; "Hangul_RieulMieum",0xeab; "Hangul_RieulPieub",0xeac; "Hangul_RieulSios",0xead; "Hangul_RieulTieut",0xeae; "Hangul_RieulPhieuf",0xeaf; "Hangul_RieulHieuh",0xeb0; "Hangul_Mieum",0xeb1; "Hangul_Pieub",0xeb2; "Hangul_SsangPieub",0xeb3; "Hangul_PieubSios",0xeb4; "Hangul_Sios",0xeb5; "Hangul_SsangSios",0xeb6; "Hangul_Ieung",0xeb7; "Hangul_Jieuj",0xeb8; "Hangul_SsangJieuj",0xeb9; "Hangul_Cieuc",0xeba; "Hangul_Khieuq",0xebb; "Hangul_Tieut",0xebc; "Hangul_Phieuf",0xebd; "Hangul_Hieuh",0xebe; "Hangul_A",0xebf; "Hangul_AE",0xec0; "Hangul_YA",0xec1; "Hangul_YAE",0xec2; "Hangul_EO",0xec3; "Hangul_E",0xec4; "Hangul_YEO",0xec5; "Hangul_YE",0xec6; "Hangul_O",0xec7; "Hangul_WA",0xec8; "Hangul_WAE",0xec9; "Hangul_OE",0xeca; "Hangul_YO",0xecb; "Hangul_U",0xecc; "Hangul_WEO",0xecd; "Hangul_WE",0xece; "Hangul_WI",0xecf; "Hangul_YU",0xed0; "Hangul_EU",0xed1; "Hangul_YI",0xed2; "Hangul_I",0xed3; "Hangul_J_Kiyeog",0xed4; "Hangul_J_SsangKiyeog",0xed5; "Hangul_J_KiyeogSios",0xed6; "Hangul_J_Nieun",0xed7; "Hangul_J_NieunJieuj",0xed8; "Hangul_J_NieunHieuh",0xed9; "Hangul_J_Dikeud",0xeda; "Hangul_J_Rieul",0xedb; "Hangul_J_RieulKiyeog",0xedc; "Hangul_J_RieulMieum",0xedd; "Hangul_J_RieulPieub",0xede; "Hangul_J_RieulSios",0xedf; "Hangul_J_RieulTieut",0xee0; "Hangul_J_RieulPhieuf",0xee1; "Hangul_J_RieulHieuh",0xee2; "Hangul_J_Mieum",0xee3; "Hangul_J_Pieub",0xee4; "Hangul_J_PieubSios",0xee5; "Hangul_J_Sios",0xee6; "Hangul_J_SsangSios",0xee7; "Hangul_J_Ieung",0xee8; "Hangul_J_Jieuj",0xee9; "Hangul_J_Cieuc",0xeea; "Hangul_J_Khieuq",0xeeb; "Hangul_J_Tieut",0xeec; "Hangul_J_Phieuf",0xeed; "Hangul_J_Hieuh",0xeee; "Hangul_RieulYeorinHieuh",0xeef; "Hangul_SunkyeongeumMieum",0xef0; "Hangul_SunkyeongeumPieub",0xef1; "Hangul_PanSios",0xef2; "Hangul_KkogjiDalrinIeung",0xef3; "Hangul_SunkyeongeumPhieuf",0xef4; "Hangul_YeorinHieuh",0xef5; "Hangul_AraeA",0xef6; "Hangul_AraeAE",0xef7; "Hangul_J_PanSios",0xef8; "Hangul_J_KkogjiDalrinIeung",0xef9; "Hangul_J_YeorinHieuh",0xefa; "Korean_Won",0xeff; ] let keysym_to_name = [ 0xFFFFFF,"VoidSymbol"; 0xFF08,"BackSpace"; 0xFF09,"Tab"; 0xFF0A,"Linefeed"; 0xFF0B,"Clear"; 0xFF0D,"Return"; 0xFF13,"Pause"; 0xFF14,"Scroll_Lock"; 0xFF15,"Sys_Req"; 0xFF1B,"Escape"; 0xFFFF,"Delete"; 0xFF20,"Multi_key"; 0xFF21,"Kanji"; 0xFF22,"Muhenkan"; 0xFF23,"Henkan_Mode"; 0xFF23,"Henkan"; 0xFF24,"Romaji"; 0xFF25,"Hiragana"; 0xFF26,"Katakana"; 0xFF27,"Hiragana_Katakana"; 0xFF28,"Zenkaku"; 0xFF29,"Hankaku"; 0xFF2A,"Zenkaku_Hankaku"; 0xFF2B,"Touroku"; 0xFF2C,"Massyo"; 0xFF2D,"Kana_Lock"; 0xFF2E,"Kana_Shift"; 0xFF2F,"Eisu_Shift"; 0xFF30,"Eisu_toggle"; 0xFF50,"Home"; 0xFF51,"Left"; 0xFF52,"Up"; 0xFF53,"Right"; 0xFF54,"Down"; 0xFF55,"Prior"; 0xFF55,"Page_Up"; 0xFF56,"Next"; 0xFF56,"Page_Down"; 0xFF57,"End"; 0xFF58,"Begin"; 0xFF60,"Select"; 0xFF61,"Print"; 0xFF62,"Execute"; 0xFF63,"Insert"; 0xFF65,"Undo"; 0xFF66,"Redo"; 0xFF67,"Menu"; 0xFF68,"Find"; 0xFF69,"Cancel"; 0xFF6A,"Help"; 0xFF6B,"Break"; 0xFF7E,"Mode_switch"; 0xFF7E,"script_switch"; 0xFF7F,"Num_Lock"; 0xFF80,"KP_Space"; 0xFF89,"KP_Tab"; 0xFF8D,"KP_Enter"; 0xFF91,"KP_F1"; 0xFF92,"KP_F2"; 0xFF93,"KP_F3"; 0xFF94,"KP_F4"; 0xFF95,"KP_Home"; 0xFF96,"KP_Left"; 0xFF97,"KP_Up"; 0xFF98,"KP_Right"; 0xFF99,"KP_Down"; 0xFF9A,"KP_Prior"; 0xFF9A,"KP_Page_Up"; 0xFF9B,"KP_Next"; 0xFF9B,"KP_Page_Down"; 0xFF9C,"KP_End"; 0xFF9D,"KP_Begin"; 0xFF9E,"KP_Insert"; 0xFF9F,"KP_Delete"; 0xFFBD,"KP_Equal"; 0xFFAA,"KP_Multiply"; 0xFFAB,"KP_Add"; 0xFFAC,"KP_Separator"; 0xFFAD,"KP_Subtract"; 0xFFAE,"KP_Decimal"; 0xFFAF,"KP_Divide"; 0xFFB0,"KP_0"; 0xFFB1,"KP_1"; 0xFFB2,"KP_2"; 0xFFB3,"KP_3"; 0xFFB4,"KP_4"; 0xFFB5,"KP_5"; 0xFFB6,"KP_6"; 0xFFB7,"KP_7"; 0xFFB8,"KP_8"; 0xFFB9,"KP_9"; 0xFFBE,"F1"; 0xFFBF,"F2"; 0xFFC0,"F3"; 0xFFC1,"F4"; 0xFFC2,"F5"; 0xFFC3,"F6"; 0xFFC4,"F7"; 0xFFC5,"F8"; 0xFFC6,"F9"; 0xFFC7,"F10"; 0xFFC8,"F11"; 0xFFC8,"L1"; 0xFFC9,"F12"; 0xFFC9,"L2"; 0xFFCA,"F13"; 0xFFCA,"L3"; 0xFFCB,"F14"; 0xFFCB,"L4"; 0xFFCC,"F15"; 0xFFCC,"L5"; 0xFFCD,"F16"; 0xFFCD,"L6"; 0xFFCE,"F17"; 0xFFCE,"L7"; 0xFFCF,"F18"; 0xFFCF,"L8"; 0xFFD0,"F19"; 0xFFD0,"L9"; 0xFFD1,"F20"; 0xFFD1,"L10"; 0xFFD2,"F21"; 0xFFD2,"R1"; 0xFFD3,"F22"; 0xFFD3,"R2"; 0xFFD4,"F23"; 0xFFD4,"R3"; 0xFFD5,"F24"; 0xFFD5,"R4"; 0xFFD6,"F25"; 0xFFD6,"R5"; 0xFFD7,"F26"; 0xFFD7,"R6"; 0xFFD8,"F27"; 0xFFD8,"R7"; 0xFFD9,"F28"; 0xFFD9,"R8"; 0xFFDA,"F29"; 0xFFDA,"R9"; 0xFFDB,"F30"; 0xFFDB,"R10"; 0xFFDC,"F31"; 0xFFDC,"R11"; 0xFFDD,"F32"; 0xFFDD,"R12"; 0xFFDE,"F33"; 0xFFDE,"R13"; 0xFFDF,"F34"; 0xFFDF,"R14"; 0xFFE0,"F35"; 0xFFE0,"R15"; 0xFFE1,"Shift_L"; 0xFFE2,"Shift_R"; 0xFFE3,"Control_L"; 0xFFE4,"Control_R"; 0xFFE5,"Caps_Lock"; 0xFFE6,"Shift_Lock"; 0xFFE7,"Meta_L"; 0xFFE8,"Meta_R"; 0xFFE9,"Alt_L"; 0xFFEA,"Alt_R"; 0xFFEB,"Super_L"; 0xFFEC,"Super_R"; 0xFFED,"Hyper_L"; 0xFFEE,"Hyper_R"; 0xFE01,"ISO_Lock"; 0xFE02,"ISO_Level2_Latch"; 0xFE03,"ISO_Level3_Shift"; 0xFE04,"ISO_Level3_Latch"; 0xFE05,"ISO_Level3_Lock"; 0xFF7E,"ISO_Group_Shift"; 0xFE06,"ISO_Group_Latch"; 0xFE07,"ISO_Group_Lock"; 0xFE08,"ISO_Next_Group"; 0xFE09,"ISO_Next_Group_Lock"; 0xFE0A,"ISO_Prev_Group"; 0xFE0B,"ISO_Prev_Group_Lock"; 0xFE0C,"ISO_First_Group"; 0xFE0D,"ISO_First_Group_Lock"; 0xFE0E,"ISO_Last_Group"; 0xFE0F,"ISO_Last_Group_Lock"; 0xFE20,"ISO_Left_Tab"; 0xFE21,"ISO_Move_Line_Up"; 0xFE22,"ISO_Move_Line_Down"; 0xFE23,"ISO_Partial_Line_Up"; 0xFE24,"ISO_Partial_Line_Down"; 0xFE25,"ISO_Partial_Space_Left"; 0xFE26,"ISO_Partial_Space_Right"; 0xFE27,"ISO_Set_Margin_Left"; 0xFE28,"ISO_Set_Margin_Right"; 0xFE29,"ISO_Release_Margin_Left"; 0xFE2A,"ISO_Release_Margin_Right"; 0xFE2B,"ISO_Release_Both_Margins"; 0xFE2C,"ISO_Fast_Cursor_Left"; 0xFE2D,"ISO_Fast_Cursor_Right"; 0xFE2E,"ISO_Fast_Cursor_Up"; 0xFE2F,"ISO_Fast_Cursor_Down"; 0xFE30,"ISO_Continuous_Underline"; 0xFE31,"ISO_Discontinuous_Underline"; 0xFE32,"ISO_Emphasize"; 0xFE33,"ISO_Center_Object"; 0xFE34,"ISO_Enter"; 0xFE50,"dead_grave"; 0xFE51,"dead_acute"; 0xFE52,"dead_circumflex"; 0xFE53,"dead_tilde"; 0xFE54,"dead_macron"; 0xFE55,"dead_breve"; 0xFE56,"dead_abovedot"; 0xFE57,"dead_diaeresis"; 0xFE58,"dead_abovering"; 0xFE59,"dead_doubleacute"; 0xFE5A,"dead_caron"; 0xFE5B,"dead_cedilla"; 0xFE5C,"dead_ogonek"; 0xFE5D,"dead_iota"; 0xFE5E,"dead_voiced_sound"; 0xFE5F,"dead_semivoiced_sound"; 0xFE60,"dead_belowdot"; 0xFED0,"First_Virtual_Screen"; 0xFED1,"Prev_Virtual_Screen"; 0xFED2,"Next_Virtual_Screen"; 0xFED4,"Last_Virtual_Screen"; 0xFED5,"Terminate_Server"; 0xFE70,"AccessX_Enable"; 0xFE71,"AccessX_Feedback_Enable"; 0xFE72,"RepeatKeys_Enable"; 0xFE73,"SlowKeys_Enable"; 0xFE74,"BounceKeys_Enable"; 0xFE75,"StickyKeys_Enable"; 0xFE76,"MouseKeys_Enable"; 0xFE77,"MouseKeys_Accel_Enable"; 0xFE78,"Overlay1_Enable"; 0xFE79,"Overlay2_Enable"; 0xFE7A,"AudibleBell_Enable"; 0xFEE0,"Pointer_Left"; 0xFEE1,"Pointer_Right"; 0xFEE2,"Pointer_Up"; 0xFEE3,"Pointer_Down"; 0xFEE4,"Pointer_UpLeft"; 0xFEE5,"Pointer_UpRight"; 0xFEE6,"Pointer_DownLeft"; 0xFEE7,"Pointer_DownRight"; 0xFEE8,"Pointer_Button_Dflt"; 0xFEE9,"Pointer_Button1"; 0xFEEA,"Pointer_Button2"; 0xFEEB,"Pointer_Button3"; 0xFEEC,"Pointer_Button4"; 0xFEED,"Pointer_Button5"; 0xFEEE,"Pointer_DblClick_Dflt"; 0xFEEF,"Pointer_DblClick1"; 0xFEF0,"Pointer_DblClick2"; 0xFEF1,"Pointer_DblClick3"; 0xFEF2,"Pointer_DblClick4"; 0xFEF3,"Pointer_DblClick5"; 0xFEF4,"Pointer_Drag_Dflt"; 0xFEF5,"Pointer_Drag1"; 0xFEF6,"Pointer_Drag2"; 0xFEF7,"Pointer_Drag3"; 0xFEF8,"Pointer_Drag4"; 0xFEFD,"Pointer_Drag5"; 0xFEF9,"Pointer_EnableKeys"; 0xFEFA,"Pointer_Accelerate"; 0xFEFB,"Pointer_DfltBtnNext"; 0xFEFC,"Pointer_DfltBtnPrev"; 0xFD01,"3270_Duplicate"; 0xFD02,"3270_FieldMark"; 0xFD03,"3270_Right2"; 0xFD04,"3270_Left2"; 0xFD05,"3270_BackTab"; 0xFD06,"3270_EraseEOF"; 0xFD07,"3270_EraseInput"; 0xFD08,"3270_Reset"; 0xFD09,"3270_Quit"; 0xFD0A,"3270_PA1"; 0xFD0B,"3270_PA2"; 0xFD0C,"3270_PA3"; 0xFD0D,"3270_Test"; 0xFD0E,"3270_Attn"; 0xFD0F,"3270_CursorBlink"; 0xFD10,"3270_AltCursor"; 0xFD11,"3270_KeyClick"; 0xFD12,"3270_Jump"; 0xFD13,"3270_Ident"; 0xFD14,"3270_Rule"; 0xFD15,"3270_Copy"; 0xFD16,"3270_Play"; 0xFD17,"3270_Setup"; 0xFD18,"3270_Record"; 0xFD19,"3270_ChangeScreen"; 0xFD1A,"3270_DeleteWord"; 0xFD1B,"3270_ExSelect"; 0xFD1C,"3270_CursorSelect"; 0xFD1D,"3270_PrintScreen"; 0xFD1E,"3270_Enter"; 0x020,"space"; 0x021,"exclam"; 0x022,"quotedbl"; 0x023,"numbersign"; 0x024,"dollar"; 0x025,"percent"; 0x026,"ampersand"; 0x027,"apostrophe"; 0x027,"quoteright"; 0x028,"parenleft"; 0x029,"parenright"; 0x02a,"asterisk"; 0x02b,"plus"; 0x02c,"comma"; 0x02d,"minus"; 0x02e,"period"; 0x02f,"slash"; 0x030,"0"; 0x031,"1"; 0x032,"2"; 0x033,"3"; 0x034,"4"; 0x035,"5"; 0x036,"6"; 0x037,"7"; 0x038,"8"; 0x039,"9"; 0x03a,"colon"; 0x03b,"semicolon"; 0x03c,"less"; 0x03d,"equal"; 0x03e,"greater"; 0x03f,"question"; 0x040,"at"; 0x041,"A"; 0x042,"B"; 0x043,"C"; 0x044,"D"; 0x045,"E"; 0x046,"F"; 0x047,"G"; 0x048,"H"; 0x049,"I"; 0x04a,"J"; 0x04b,"K"; 0x04c,"L"; 0x04d,"M"; 0x04e,"N"; 0x04f,"O"; 0x050,"P"; 0x051,"Q"; 0x052,"R"; 0x053,"S"; 0x054,"T"; 0x055,"U"; 0x056,"V"; 0x057,"W"; 0x058,"X"; 0x059,"Y"; 0x05a,"Z"; 0x05b,"bracketleft"; 0x05c,"backslash"; 0x05d,"bracketright"; 0x05e,"asciicircum"; 0x05f,"underscore"; 0x060,"grave"; 0x060,"quoteleft"; 0x061,"a"; 0x062,"b"; 0x063,"c"; 0x064,"d"; 0x065,"e"; 0x066,"f"; 0x067,"g"; 0x068,"h"; 0x069,"i"; 0x06a,"j"; 0x06b,"k"; 0x06c,"l"; 0x06d,"m"; 0x06e,"n"; 0x06f,"o"; 0x070,"p"; 0x071,"q"; 0x072,"r"; 0x073,"s"; 0x074,"t"; 0x075,"u"; 0x076,"v"; 0x077,"w"; 0x078,"x"; 0x079,"y"; 0x07a,"z"; 0x07b,"braceleft"; 0x07c,"bar"; 0x07d,"braceright"; 0x07e,"asciitilde"; 0x0a0,"nobreakspace"; 0x0a1,"exclamdown"; 0x0a2,"cent"; 0x0a3,"sterling"; 0x0a4,"currency"; 0x0a5,"yen"; 0x0a6,"brokenbar"; 0x0a7,"section"; 0x0a8,"diaeresis"; 0x0a9,"copyright"; 0x0aa,"ordfeminine"; 0x0ab,"guillemotleft"; 0x0ac,"notsign"; 0x0ad,"hyphen"; 0x0ae,"registered"; 0x0af,"macron"; 0x0b0,"degree"; 0x0b1,"plusminus"; 0x0b2,"twosuperior"; 0x0b3,"threesuperior"; 0x0b4,"acute"; 0x0b5,"mu"; 0x0b6,"paragraph"; 0x0b7,"periodcentered"; 0x0b8,"cedilla"; 0x0b9,"onesuperior"; 0x0ba,"masculine"; 0x0bb,"guillemotright"; 0x0bc,"onequarter"; 0x0bd,"onehalf"; 0x0be,"threequarters"; 0x0bf,"questiondown"; 0x0c0,"Agrave"; 0x0c1,"Aacute"; 0x0c2,"Acircumflex"; 0x0c3,"Atilde"; 0x0c4,"Adiaeresis"; 0x0c5,"Aring"; 0x0c6,"AE"; 0x0c7,"Ccedilla"; 0x0c8,"Egrave"; 0x0c9,"Eacute"; 0x0ca,"Ecircumflex"; 0x0cb,"Ediaeresis"; 0x0cc,"Igrave"; 0x0cd,"Iacute"; 0x0ce,"Icircumflex"; 0x0cf,"Idiaeresis"; 0x0d0,"ETH"; 0x0d0,"Eth"; 0x0d1,"Ntilde"; 0x0d2,"Ograve"; 0x0d3,"Oacute"; 0x0d4,"Ocircumflex"; 0x0d5,"Otilde"; 0x0d6,"Odiaeresis"; 0x0d7,"multiply"; 0x0d8,"Ooblique"; 0x0d9,"Ugrave"; 0x0da,"Uacute"; 0x0db,"Ucircumflex"; 0x0dc,"Udiaeresis"; 0x0dd,"Yacute"; 0x0de,"THORN"; 0x0de,"Thorn"; 0x0df,"ssharp"; 0x0e0,"agrave"; 0x0e1,"aacute"; 0x0e2,"acircumflex"; 0x0e3,"atilde"; 0x0e4,"adiaeresis"; 0x0e5,"aring"; 0x0e6,"ae"; 0x0e7,"ccedilla"; 0x0e8,"egrave"; 0x0e9,"eacute"; 0x0ea,"ecircumflex"; 0x0eb,"ediaeresis"; 0x0ec,"igrave"; 0x0ed,"iacute"; 0x0ee,"icircumflex"; 0x0ef,"idiaeresis"; 0x0f0,"eth"; 0x0f1,"ntilde"; 0x0f2,"ograve"; 0x0f3,"oacute"; 0x0f4,"ocircumflex"; 0x0f5,"otilde"; 0x0f6,"odiaeresis"; 0x0f7,"division"; 0x0f8,"oslash"; 0x0f9,"ugrave"; 0x0fa,"uacute"; 0x0fb,"ucircumflex"; 0x0fc,"udiaeresis"; 0x0fd,"yacute"; 0x0fe,"thorn"; 0x0ff,"ydiaeresis"; 0x1a1,"Aogonek"; 0x1a2,"breve"; 0x1a3,"Lstroke"; 0x1a5,"Lcaron"; 0x1a6,"Sacute"; 0x1a9,"Scaron"; 0x1aa,"Scedilla"; 0x1ab,"Tcaron"; 0x1ac,"Zacute"; 0x1ae,"Zcaron"; 0x1af,"Zabovedot"; 0x1b1,"aogonek"; 0x1b2,"ogonek"; 0x1b3,"lstroke"; 0x1b5,"lcaron"; 0x1b6,"sacute"; 0x1b7,"caron"; 0x1b9,"scaron"; 0x1ba,"scedilla"; 0x1bb,"tcaron"; 0x1bc,"zacute"; 0x1bd,"doubleacute"; 0x1be,"zcaron"; 0x1bf,"zabovedot"; 0x1c0,"Racute"; 0x1c3,"Abreve"; 0x1c5,"Lacute"; 0x1c6,"Cacute"; 0x1c8,"Ccaron"; 0x1ca,"Eogonek"; 0x1cc,"Ecaron"; 0x1cf,"Dcaron"; 0x1d0,"Dstroke"; 0x1d1,"Nacute"; 0x1d2,"Ncaron"; 0x1d5,"Odoubleacute"; 0x1d8,"Rcaron"; 0x1d9,"Uring"; 0x1db,"Udoubleacute"; 0x1de,"Tcedilla"; 0x1e0,"racute"; 0x1e3,"abreve"; 0x1e5,"lacute"; 0x1e6,"cacute"; 0x1e8,"ccaron"; 0x1ea,"eogonek"; 0x1ec,"ecaron"; 0x1ef,"dcaron"; 0x1f0,"dstroke"; 0x1f1,"nacute"; 0x1f2,"ncaron"; 0x1f5,"odoubleacute"; 0x1fb,"udoubleacute"; 0x1f8,"rcaron"; 0x1f9,"uring"; 0x1fe,"tcedilla"; 0x1ff,"abovedot"; 0x2a1,"Hstroke"; 0x2a6,"Hcircumflex"; 0x2a9,"Iabovedot"; 0x2ab,"Gbreve"; 0x2ac,"Jcircumflex"; 0x2b1,"hstroke"; 0x2b6,"hcircumflex"; 0x2b9,"idotless"; 0x2bb,"gbreve"; 0x2bc,"jcircumflex"; 0x2c5,"Cabovedot"; 0x2c6,"Ccircumflex"; 0x2d5,"Gabovedot"; 0x2d8,"Gcircumflex"; 0x2dd,"Ubreve"; 0x2de,"Scircumflex"; 0x2e5,"cabovedot"; 0x2e6,"ccircumflex"; 0x2f5,"gabovedot"; 0x2f8,"gcircumflex"; 0x2fd,"ubreve"; 0x2fe,"scircumflex"; 0x3a2,"kra"; 0x3a2,"kappa"; 0x3a3,"Rcedilla"; 0x3a5,"Itilde"; 0x3a6,"Lcedilla"; 0x3aa,"Emacron"; 0x3ab,"Gcedilla"; 0x3ac,"Tslash"; 0x3b3,"rcedilla"; 0x3b5,"itilde"; 0x3b6,"lcedilla"; 0x3ba,"emacron"; 0x3bb,"gcedilla"; 0x3bc,"tslash"; 0x3bd,"ENG"; 0x3bf,"eng"; 0x3c0,"Amacron"; 0x3c7,"Iogonek"; 0x3cc,"Eabovedot"; 0x3cf,"Imacron"; 0x3d1,"Ncedilla"; 0x3d2,"Omacron"; 0x3d3,"Kcedilla"; 0x3d9,"Uogonek"; 0x3dd,"Utilde"; 0x3de,"Umacron"; 0x3e0,"amacron"; 0x3e7,"iogonek"; 0x3ec,"eabovedot"; 0x3ef,"imacron"; 0x3f1,"ncedilla"; 0x3f2,"omacron"; 0x3f3,"kcedilla"; 0x3f9,"uogonek"; 0x3fd,"utilde"; 0x3fe,"umacron"; 0x47e,"overline"; 0x4a1,"kana_fullstop"; 0x4a2,"kana_openingbracket"; 0x4a3,"kana_closingbracket"; 0x4a4,"kana_comma"; 0x4a5,"kana_conjunctive"; 0x4a5,"kana_middledot"; 0x4a6,"kana_WO"; 0x4a7,"kana_a"; 0x4a8,"kana_i"; 0x4a9,"kana_u"; 0x4aa,"kana_e"; 0x4ab,"kana_o"; 0x4ac,"kana_ya"; 0x4ad,"kana_yu"; 0x4ae,"kana_yo"; 0x4af,"kana_tsu"; 0x4af,"kana_tu"; 0x4b0,"prolongedsound"; 0x4b1,"kana_A"; 0x4b2,"kana_I"; 0x4b3,"kana_U"; 0x4b4,"kana_E"; 0x4b5,"kana_O"; 0x4b6,"kana_KA"; 0x4b7,"kana_KI"; 0x4b8,"kana_KU"; 0x4b9,"kana_KE"; 0x4ba,"kana_KO"; 0x4bb,"kana_SA"; 0x4bc,"kana_SHI"; 0x4bd,"kana_SU"; 0x4be,"kana_SE"; 0x4bf,"kana_SO"; 0x4c0,"kana_TA"; 0x4c1,"kana_CHI"; 0x4c1,"kana_TI"; 0x4c2,"kana_TSU"; 0x4c2,"kana_TU"; 0x4c3,"kana_TE"; 0x4c4,"kana_TO"; 0x4c5,"kana_NA"; 0x4c6,"kana_NI"; 0x4c7,"kana_NU"; 0x4c8,"kana_NE"; 0x4c9,"kana_NO"; 0x4ca,"kana_HA"; 0x4cb,"kana_HI"; 0x4cc,"kana_FU"; 0x4cc,"kana_HU"; 0x4cd,"kana_HE"; 0x4ce,"kana_HO"; 0x4cf,"kana_MA"; 0x4d0,"kana_MI"; 0x4d1,"kana_MU"; 0x4d2,"kana_ME"; 0x4d3,"kana_MO"; 0x4d4,"kana_YA"; 0x4d5,"kana_YU"; 0x4d6,"kana_YO"; 0x4d7,"kana_RA"; 0x4d8,"kana_RI"; 0x4d9,"kana_RU"; 0x4da,"kana_RE"; 0x4db,"kana_RO"; 0x4dc,"kana_WA"; 0x4dd,"kana_N"; 0x4de,"voicedsound"; 0x4df,"semivoicedsound"; 0xFF7E,"kana_switch"; 0x5ac,"Arabic_comma"; 0x5bb,"Arabic_semicolon"; 0x5bf,"Arabic_question_mark"; 0x5c1,"Arabic_hamza"; 0x5c2,"Arabic_maddaonalef"; 0x5c3,"Arabic_hamzaonalef"; 0x5c4,"Arabic_hamzaonwaw"; 0x5c5,"Arabic_hamzaunderalef"; 0x5c6,"Arabic_hamzaonyeh"; 0x5c7,"Arabic_alef"; 0x5c8,"Arabic_beh"; 0x5c9,"Arabic_tehmarbuta"; 0x5ca,"Arabic_teh"; 0x5cb,"Arabic_theh"; 0x5cc,"Arabic_jeem"; 0x5cd,"Arabic_hah"; 0x5ce,"Arabic_khah"; 0x5cf,"Arabic_dal"; 0x5d0,"Arabic_thal"; 0x5d1,"Arabic_ra"; 0x5d2,"Arabic_zain"; 0x5d3,"Arabic_seen"; 0x5d4,"Arabic_sheen"; 0x5d5,"Arabic_sad"; 0x5d6,"Arabic_dad"; 0x5d7,"Arabic_tah"; 0x5d8,"Arabic_zah"; 0x5d9,"Arabic_ain"; 0x5da,"Arabic_ghain"; 0x5e0,"Arabic_tatweel"; 0x5e1,"Arabic_feh"; 0x5e2,"Arabic_qaf"; 0x5e3,"Arabic_kaf"; 0x5e4,"Arabic_lam"; 0x5e5,"Arabic_meem"; 0x5e6,"Arabic_noon"; 0x5e7,"Arabic_ha"; 0x5e7,"Arabic_heh"; 0x5e8,"Arabic_waw"; 0x5e9,"Arabic_alefmaksura"; 0x5ea,"Arabic_yeh"; 0x5eb,"Arabic_fathatan"; 0x5ec,"Arabic_dammatan"; 0x5ed,"Arabic_kasratan"; 0x5ee,"Arabic_fatha"; 0x5ef,"Arabic_damma"; 0x5f0,"Arabic_kasra"; 0x5f1,"Arabic_shadda"; 0x5f2,"Arabic_sukun"; 0xFF7E,"Arabic_switch"; 0x6a1,"Serbian_dje"; 0x6a2,"Macedonia_gje"; 0x6a3,"Cyrillic_io"; 0x6a4,"Ukrainian_ie"; 0x6a4,"Ukranian_je"; 0x6a5,"Macedonia_dse"; 0x6a6,"Ukrainian_i"; 0x6a6,"Ukranian_i"; 0x6a7,"Ukrainian_yi"; 0x6a7,"Ukranian_yi"; 0x6a8,"Cyrillic_je"; 0x6a8,"Serbian_je"; 0x6a9,"Cyrillic_lje"; 0x6a9,"Serbian_lje"; 0x6aa,"Cyrillic_nje"; 0x6aa,"Serbian_nje"; 0x6ab,"Serbian_tshe"; 0x6ac,"Macedonia_kje"; 0x6ae,"Byelorussian_shortu"; 0x6af,"Cyrillic_dzhe"; 0x6af,"Serbian_dze"; 0x6b0,"numerosign"; 0x6b1,"Serbian_DJE"; 0x6b2,"Macedonia_GJE"; 0x6b3,"Cyrillic_IO"; 0x6b4,"Ukrainian_IE"; 0x6b4,"Ukranian_JE"; 0x6b5,"Macedonia_DSE"; 0x6b6,"Ukrainian_I"; 0x6b6,"Ukranian_I"; 0x6b7,"Ukrainian_YI"; 0x6b7,"Ukranian_YI"; 0x6b8,"Cyrillic_JE"; 0x6b8,"Serbian_JE"; 0x6b9,"Cyrillic_LJE"; 0x6b9,"Serbian_LJE"; 0x6ba,"Cyrillic_NJE"; 0x6ba,"Serbian_NJE"; 0x6bb,"Serbian_TSHE"; 0x6bc,"Macedonia_KJE"; 0x6be,"Byelorussian_SHORTU"; 0x6bf,"Cyrillic_DZHE"; 0x6bf,"Serbian_DZE"; 0x6c0,"Cyrillic_yu"; 0x6c1,"Cyrillic_a"; 0x6c2,"Cyrillic_be"; 0x6c3,"Cyrillic_tse"; 0x6c4,"Cyrillic_de"; 0x6c5,"Cyrillic_ie"; 0x6c6,"Cyrillic_ef"; 0x6c7,"Cyrillic_ghe"; 0x6c8,"Cyrillic_ha"; 0x6c9,"Cyrillic_i"; 0x6ca,"Cyrillic_shorti"; 0x6cb,"Cyrillic_ka"; 0x6cc,"Cyrillic_el"; 0x6cd,"Cyrillic_em"; 0x6ce,"Cyrillic_en"; 0x6cf,"Cyrillic_o"; 0x6d0,"Cyrillic_pe"; 0x6d1,"Cyrillic_ya"; 0x6d2,"Cyrillic_er"; 0x6d3,"Cyrillic_es"; 0x6d4,"Cyrillic_te"; 0x6d5,"Cyrillic_u"; 0x6d6,"Cyrillic_zhe"; 0x6d7,"Cyrillic_ve"; 0x6d8,"Cyrillic_softsign"; 0x6d9,"Cyrillic_yeru"; 0x6da,"Cyrillic_ze"; 0x6db,"Cyrillic_sha"; 0x6dc,"Cyrillic_e"; 0x6dd,"Cyrillic_shcha"; 0x6de,"Cyrillic_che"; 0x6df,"Cyrillic_hardsign"; 0x6e0,"Cyrillic_YU"; 0x6e1,"Cyrillic_A"; 0x6e2,"Cyrillic_BE"; 0x6e3,"Cyrillic_TSE"; 0x6e4,"Cyrillic_DE"; 0x6e5,"Cyrillic_IE"; 0x6e6,"Cyrillic_EF"; 0x6e7,"Cyrillic_GHE"; 0x6e8,"Cyrillic_HA"; 0x6e9,"Cyrillic_I"; 0x6ea,"Cyrillic_SHORTI"; 0x6eb,"Cyrillic_KA"; 0x6ec,"Cyrillic_EL"; 0x6ed,"Cyrillic_EM"; 0x6ee,"Cyrillic_EN"; 0x6ef,"Cyrillic_O"; 0x6f0,"Cyrillic_PE"; 0x6f1,"Cyrillic_YA"; 0x6f2,"Cyrillic_ER"; 0x6f3,"Cyrillic_ES"; 0x6f4,"Cyrillic_TE"; 0x6f5,"Cyrillic_U"; 0x6f6,"Cyrillic_ZHE"; 0x6f7,"Cyrillic_VE"; 0x6f8,"Cyrillic_SOFTSIGN"; 0x6f9,"Cyrillic_YERU"; 0x6fa,"Cyrillic_ZE"; 0x6fb,"Cyrillic_SHA"; 0x6fc,"Cyrillic_E"; 0x6fd,"Cyrillic_SHCHA"; 0x6fe,"Cyrillic_CHE"; 0x6ff,"Cyrillic_HARDSIGN"; 0x7a1,"Greek_ALPHAaccent"; 0x7a2,"Greek_EPSILONaccent"; 0x7a3,"Greek_ETAaccent"; 0x7a4,"Greek_IOTAaccent"; 0x7a5,"Greek_IOTAdiaeresis"; 0x7a7,"Greek_OMICRONaccent"; 0x7a8,"Greek_UPSILONaccent"; 0x7a9,"Greek_UPSILONdieresis"; 0x7ab,"Greek_OMEGAaccent"; 0x7ae,"Greek_accentdieresis"; 0x7af,"Greek_horizbar"; 0x7b1,"Greek_alphaaccent"; 0x7b2,"Greek_epsilonaccent"; 0x7b3,"Greek_etaaccent"; 0x7b4,"Greek_iotaaccent"; 0x7b5,"Greek_iotadieresis"; 0x7b6,"Greek_iotaaccentdieresis"; 0x7b7,"Greek_omicronaccent"; 0x7b8,"Greek_upsilonaccent"; 0x7b9,"Greek_upsilondieresis"; 0x7ba,"Greek_upsilonaccentdieresis"; 0x7bb,"Greek_omegaaccent"; 0x7c1,"Greek_ALPHA"; 0x7c2,"Greek_BETA"; 0x7c3,"Greek_GAMMA"; 0x7c4,"Greek_DELTA"; 0x7c5,"Greek_EPSILON"; 0x7c6,"Greek_ZETA"; 0x7c7,"Greek_ETA"; 0x7c8,"Greek_THETA"; 0x7c9,"Greek_IOTA"; 0x7ca,"Greek_KAPPA"; 0x7cb,"Greek_LAMDA"; 0x7cb,"Greek_LAMBDA"; 0x7cc,"Greek_MU"; 0x7cd,"Greek_NU"; 0x7ce,"Greek_XI"; 0x7cf,"Greek_OMICRON"; 0x7d0,"Greek_PI"; 0x7d1,"Greek_RHO"; 0x7d2,"Greek_SIGMA"; 0x7d4,"Greek_TAU"; 0x7d5,"Greek_UPSILON"; 0x7d6,"Greek_PHI"; 0x7d7,"Greek_CHI"; 0x7d8,"Greek_PSI"; 0x7d9,"Greek_OMEGA"; 0x7e1,"Greek_alpha"; 0x7e2,"Greek_beta"; 0x7e3,"Greek_gamma"; 0x7e4,"Greek_delta"; 0x7e5,"Greek_epsilon"; 0x7e6,"Greek_zeta"; 0x7e7,"Greek_eta"; 0x7e8,"Greek_theta"; 0x7e9,"Greek_iota"; 0x7ea,"Greek_kappa"; 0x7eb,"Greek_lamda"; 0x7eb,"Greek_lambda"; 0x7ec,"Greek_mu"; 0x7ed,"Greek_nu"; 0x7ee,"Greek_xi"; 0x7ef,"Greek_omicron"; 0x7f0,"Greek_pi"; 0x7f1,"Greek_rho"; 0x7f2,"Greek_sigma"; 0x7f3,"Greek_finalsmallsigma"; 0x7f4,"Greek_tau"; 0x7f5,"Greek_upsilon"; 0x7f6,"Greek_phi"; 0x7f7,"Greek_chi"; 0x7f8,"Greek_psi"; 0x7f9,"Greek_omega"; 0xFF7E,"Greek_switch"; 0x8a1,"leftradical"; 0x8a2,"topleftradical"; 0x8a3,"horizconnector"; 0x8a4,"topintegral"; 0x8a5,"botintegral"; 0x8a6,"vertconnector"; 0x8a7,"topleftsqbracket"; 0x8a8,"botleftsqbracket"; 0x8a9,"toprightsqbracket"; 0x8aa,"botrightsqbracket"; 0x8ab,"topleftparens"; 0x8ac,"botleftparens"; 0x8ad,"toprightparens"; 0x8ae,"botrightparens"; 0x8af,"leftmiddlecurlybrace"; 0x8b0,"rightmiddlecurlybrace"; 0x8b1,"topleftsummation"; 0x8b2,"botleftsummation"; 0x8b3,"topvertsummationconnector"; 0x8b4,"botvertsummationconnector"; 0x8b5,"toprightsummation"; 0x8b6,"botrightsummation"; 0x8b7,"rightmiddlesummation"; 0x8bc,"lessthanequal"; 0x8bd,"notequal"; 0x8be,"greaterthanequal"; 0x8bf,"integral"; 0x8c0,"therefore"; 0x8c1,"variation"; 0x8c2,"infinity"; 0x8c5,"nabla"; 0x8c8,"approximate"; 0x8c9,"similarequal"; 0x8cd,"ifonlyif"; 0x8ce,"implies"; 0x8cf,"identical"; 0x8d6,"radical"; 0x8da,"includedin"; 0x8db,"includes"; 0x8dc,"intersection"; 0x8dd,"union"; 0x8de,"logicaland"; 0x8df,"logicalor"; 0x8ef,"partialderivative"; 0x8f6,"function"; 0x8fb,"leftarrow"; 0x8fc,"uparrow"; 0x8fd,"rightarrow"; 0x8fe,"downarrow"; 0x9df,"blank"; 0x9e0,"soliddiamond"; 0x9e1,"checkerboard"; 0x9e2,"ht"; 0x9e3,"ff"; 0x9e4,"cr"; 0x9e5,"lf"; 0x9e8,"nl"; 0x9e9,"vt"; 0x9ea,"lowrightcorner"; 0x9eb,"uprightcorner"; 0x9ec,"upleftcorner"; 0x9ed,"lowleftcorner"; 0x9ee,"crossinglines"; 0x9ef,"horizlinescan1"; 0x9f0,"horizlinescan3"; 0x9f1,"horizlinescan5"; 0x9f2,"horizlinescan7"; 0x9f3,"horizlinescan9"; 0x9f4,"leftt"; 0x9f5,"rightt"; 0x9f6,"bott"; 0x9f7,"topt"; 0x9f8,"vertbar"; 0xaa1,"emspace"; 0xaa2,"enspace"; 0xaa3,"em3space"; 0xaa4,"em4space"; 0xaa5,"digitspace"; 0xaa6,"punctspace"; 0xaa7,"thinspace"; 0xaa8,"hairspace"; 0xaa9,"emdash"; 0xaaa,"endash"; 0xaac,"signifblank"; 0xaae,"ellipsis"; 0xaaf,"doubbaselinedot"; 0xab0,"onethird"; 0xab1,"twothirds"; 0xab2,"onefifth"; 0xab3,"twofifths"; 0xab4,"threefifths"; 0xab5,"fourfifths"; 0xab6,"onesixth"; 0xab7,"fivesixths"; 0xab8,"careof"; 0xabb,"figdash"; 0xabc,"leftanglebracket"; 0xabd,"decimalpoint"; 0xabe,"rightanglebracket"; 0xabf,"marker"; 0xac3,"oneeighth"; 0xac4,"threeeighths"; 0xac5,"fiveeighths"; 0xac6,"seveneighths"; 0xac9,"trademark"; 0xaca,"signaturemark"; 0xacb,"trademarkincircle"; 0xacc,"leftopentriangle"; 0xacd,"rightopentriangle"; 0xace,"emopencircle"; 0xacf,"emopenrectangle"; 0xad0,"leftsinglequotemark"; 0xad1,"rightsinglequotemark"; 0xad2,"leftdoublequotemark"; 0xad3,"rightdoublequotemark"; 0xad4,"prescription"; 0xad6,"minutes"; 0xad7,"seconds"; 0xad9,"latincross"; 0xada,"hexagram"; 0xadb,"filledrectbullet"; 0xadc,"filledlefttribullet"; 0xadd,"filledrighttribullet"; 0xade,"emfilledcircle"; 0xadf,"emfilledrect"; 0xae0,"enopencircbullet"; 0xae1,"enopensquarebullet"; 0xae2,"openrectbullet"; 0xae3,"opentribulletup"; 0xae4,"opentribulletdown"; 0xae5,"openstar"; 0xae6,"enfilledcircbullet"; 0xae7,"enfilledsqbullet"; 0xae8,"filledtribulletup"; 0xae9,"filledtribulletdown"; 0xaea,"leftpointer"; 0xaeb,"rightpointer"; 0xaec,"club"; 0xaed,"diamond"; 0xaee,"heart"; 0xaf0,"maltesecross"; 0xaf1,"dagger"; 0xaf2,"doubledagger"; 0xaf3,"checkmark"; 0xaf4,"ballotcross"; 0xaf5,"musicalsharp"; 0xaf6,"musicalflat"; 0xaf7,"malesymbol"; 0xaf8,"femalesymbol"; 0xaf9,"telephone"; 0xafa,"telephonerecorder"; 0xafb,"phonographcopyright"; 0xafc,"caret"; 0xafd,"singlelowquotemark"; 0xafe,"doublelowquotemark"; 0xaff,"cursor"; 0xba3,"leftcaret"; 0xba6,"rightcaret"; 0xba8,"downcaret"; 0xba9,"upcaret"; 0xbc0,"overbar"; 0xbc2,"downtack"; 0xbc3,"upshoe"; 0xbc4,"downstile"; 0xbc6,"underbar"; 0xbca,"jot"; 0xbcc,"quad"; 0xbce,"uptack"; 0xbcf,"circle"; 0xbd3,"upstile"; 0xbd6,"downshoe"; 0xbd8,"rightshoe"; 0xbda,"leftshoe"; 0xbdc,"lefttack"; 0xbfc,"righttack"; 0xcdf,"hebrew_doublelowline"; 0xce0,"hebrew_aleph"; 0xce1,"hebrew_bet"; 0xce1,"hebrew_beth"; 0xce2,"hebrew_gimel"; 0xce2,"hebrew_gimmel"; 0xce3,"hebrew_dalet"; 0xce3,"hebrew_daleth"; 0xce4,"hebrew_he"; 0xce5,"hebrew_waw"; 0xce6,"hebrew_zain"; 0xce6,"hebrew_zayin"; 0xce7,"hebrew_chet"; 0xce7,"hebrew_het"; 0xce8,"hebrew_tet"; 0xce8,"hebrew_teth"; 0xce9,"hebrew_yod"; 0xcea,"hebrew_finalkaph"; 0xceb,"hebrew_kaph"; 0xcec,"hebrew_lamed"; 0xced,"hebrew_finalmem"; 0xcee,"hebrew_mem"; 0xcef,"hebrew_finalnun"; 0xcf0,"hebrew_nun"; 0xcf1,"hebrew_samech"; 0xcf1,"hebrew_samekh"; 0xcf2,"hebrew_ayin"; 0xcf3,"hebrew_finalpe"; 0xcf4,"hebrew_pe"; 0xcf5,"hebrew_finalzade"; 0xcf5,"hebrew_finalzadi"; 0xcf6,"hebrew_zade"; 0xcf6,"hebrew_zadi"; 0xcf7,"hebrew_qoph"; 0xcf7,"hebrew_kuf"; 0xcf8,"hebrew_resh"; 0xcf9,"hebrew_shin"; 0xcfa,"hebrew_taw"; 0xcfa,"hebrew_taf"; 0xFF7E,"Hebrew_switch"; 0xda1,"Thai_kokai"; 0xda2,"Thai_khokhai"; 0xda3,"Thai_khokhuat"; 0xda4,"Thai_khokhwai"; 0xda5,"Thai_khokhon"; 0xda6,"Thai_khorakhang"; 0xda7,"Thai_ngongu"; 0xda8,"Thai_chochan"; 0xda9,"Thai_choching"; 0xdaa,"Thai_chochang"; 0xdab,"Thai_soso"; 0xdac,"Thai_chochoe"; 0xdad,"Thai_yoying"; 0xdae,"Thai_dochada"; 0xdaf,"Thai_topatak"; 0xdb0,"Thai_thothan"; 0xdb1,"Thai_thonangmontho"; 0xdb2,"Thai_thophuthao"; 0xdb3,"Thai_nonen"; 0xdb4,"Thai_dodek"; 0xdb5,"Thai_totao"; 0xdb6,"Thai_thothung"; 0xdb7,"Thai_thothahan"; 0xdb8,"Thai_thothong"; 0xdb9,"Thai_nonu"; 0xdba,"Thai_bobaimai"; 0xdbb,"Thai_popla"; 0xdbc,"Thai_phophung"; 0xdbd,"Thai_fofa"; 0xdbe,"Thai_phophan"; 0xdbf,"Thai_fofan"; 0xdc0,"Thai_phosamphao"; 0xdc1,"Thai_moma"; 0xdc2,"Thai_yoyak"; 0xdc3,"Thai_rorua"; 0xdc4,"Thai_ru"; 0xdc5,"Thai_loling"; 0xdc6,"Thai_lu"; 0xdc7,"Thai_wowaen"; 0xdc8,"Thai_sosala"; 0xdc9,"Thai_sorusi"; 0xdca,"Thai_sosua"; 0xdcb,"Thai_hohip"; 0xdcc,"Thai_lochula"; 0xdcd,"Thai_oang"; 0xdce,"Thai_honokhuk"; 0xdcf,"Thai_paiyannoi"; 0xdd0,"Thai_saraa"; 0xdd1,"Thai_maihanakat"; 0xdd2,"Thai_saraaa"; 0xdd3,"Thai_saraam"; 0xdd4,"Thai_sarai"; 0xdd5,"Thai_saraii"; 0xdd6,"Thai_saraue"; 0xdd7,"Thai_sarauee"; 0xdd8,"Thai_sarau"; 0xdd9,"Thai_sarauu"; 0xdda,"Thai_phinthu"; 0xdde,"Thai_maihanakat_maitho"; 0xddf,"Thai_baht"; 0xde0,"Thai_sarae"; 0xde1,"Thai_saraae"; 0xde2,"Thai_sarao"; 0xde3,"Thai_saraaimaimuan"; 0xde4,"Thai_saraaimaimalai"; 0xde5,"Thai_lakkhangyao"; 0xde6,"Thai_maiyamok"; 0xde7,"Thai_maitaikhu"; 0xde8,"Thai_maiek"; 0xde9,"Thai_maitho"; 0xdea,"Thai_maitri"; 0xdeb,"Thai_maichattawa"; 0xdec,"Thai_thanthakhat"; 0xded,"Thai_nikhahit"; 0xdf0,"Thai_leksun"; 0xdf1,"Thai_leknung"; 0xdf2,"Thai_leksong"; 0xdf3,"Thai_leksam"; 0xdf4,"Thai_leksi"; 0xdf5,"Thai_lekha"; 0xdf6,"Thai_lekhok"; 0xdf7,"Thai_lekchet"; 0xdf8,"Thai_lekpaet"; 0xdf9,"Thai_lekkao"; 0xff31,"Hangul"; 0xff32,"Hangul_Start"; 0xff33,"Hangul_End"; 0xff34,"Hangul_Hanja"; 0xff35,"Hangul_Jamo"; 0xff36,"Hangul_Romaja"; 0xff37,"Hangul_Codeinput"; 0xff38,"Hangul_Jeonja"; 0xff39,"Hangul_Banja"; 0xff3a,"Hangul_PreHanja"; 0xff3b,"Hangul_PostHanja"; 0xff3c,"Hangul_SingleCandidate"; 0xff3d,"Hangul_MultipleCandidate"; 0xff3e,"Hangul_PreviousCandidate"; 0xff3f,"Hangul_Special"; 0xFF7E,"Hangul_switch"; 0xea1,"Hangul_Kiyeog"; 0xea2,"Hangul_SsangKiyeog"; 0xea3,"Hangul_KiyeogSios"; 0xea4,"Hangul_Nieun"; 0xea5,"Hangul_NieunJieuj"; 0xea6,"Hangul_NieunHieuh"; 0xea7,"Hangul_Dikeud"; 0xea8,"Hangul_SsangDikeud"; 0xea9,"Hangul_Rieul"; 0xeaa,"Hangul_RieulKiyeog"; 0xeab,"Hangul_RieulMieum"; 0xeac,"Hangul_RieulPieub"; 0xead,"Hangul_RieulSios"; 0xeae,"Hangul_RieulTieut"; 0xeaf,"Hangul_RieulPhieuf"; 0xeb0,"Hangul_RieulHieuh"; 0xeb1,"Hangul_Mieum"; 0xeb2,"Hangul_Pieub"; 0xeb3,"Hangul_SsangPieub"; 0xeb4,"Hangul_PieubSios"; 0xeb5,"Hangul_Sios"; 0xeb6,"Hangul_SsangSios"; 0xeb7,"Hangul_Ieung"; 0xeb8,"Hangul_Jieuj"; 0xeb9,"Hangul_SsangJieuj"; 0xeba,"Hangul_Cieuc"; 0xebb,"Hangul_Khieuq"; 0xebc,"Hangul_Tieut"; 0xebd,"Hangul_Phieuf"; 0xebe,"Hangul_Hieuh"; 0xebf,"Hangul_A"; 0xec0,"Hangul_AE"; 0xec1,"Hangul_YA"; 0xec2,"Hangul_YAE"; 0xec3,"Hangul_EO"; 0xec4,"Hangul_E"; 0xec5,"Hangul_YEO"; 0xec6,"Hangul_YE"; 0xec7,"Hangul_O"; 0xec8,"Hangul_WA"; 0xec9,"Hangul_WAE"; 0xeca,"Hangul_OE"; 0xecb,"Hangul_YO"; 0xecc,"Hangul_U"; 0xecd,"Hangul_WEO"; 0xece,"Hangul_WE"; 0xecf,"Hangul_WI"; 0xed0,"Hangul_YU"; 0xed1,"Hangul_EU"; 0xed2,"Hangul_YI"; 0xed3,"Hangul_I"; 0xed4,"Hangul_J_Kiyeog"; 0xed5,"Hangul_J_SsangKiyeog"; 0xed6,"Hangul_J_KiyeogSios"; 0xed7,"Hangul_J_Nieun"; 0xed8,"Hangul_J_NieunJieuj"; 0xed9,"Hangul_J_NieunHieuh"; 0xeda,"Hangul_J_Dikeud"; 0xedb,"Hangul_J_Rieul"; 0xedc,"Hangul_J_RieulKiyeog"; 0xedd,"Hangul_J_RieulMieum"; 0xede,"Hangul_J_RieulPieub"; 0xedf,"Hangul_J_RieulSios"; 0xee0,"Hangul_J_RieulTieut"; 0xee1,"Hangul_J_RieulPhieuf"; 0xee2,"Hangul_J_RieulHieuh"; 0xee3,"Hangul_J_Mieum"; 0xee4,"Hangul_J_Pieub"; 0xee5,"Hangul_J_PieubSios"; 0xee6,"Hangul_J_Sios"; 0xee7,"Hangul_J_SsangSios"; 0xee8,"Hangul_J_Ieung"; 0xee9,"Hangul_J_Jieuj"; 0xeea,"Hangul_J_Cieuc"; 0xeeb,"Hangul_J_Khieuq"; 0xeec,"Hangul_J_Tieut"; 0xeed,"Hangul_J_Phieuf"; 0xeee,"Hangul_J_Hieuh"; 0xeef,"Hangul_RieulYeorinHieuh"; 0xef0,"Hangul_SunkyeongeumMieum"; 0xef1,"Hangul_SunkyeongeumPieub"; 0xef2,"Hangul_PanSios"; 0xef3,"Hangul_KkogjiDalrinIeung"; 0xef4,"Hangul_SunkyeongeumPhieuf"; 0xef5,"Hangul_YeorinHieuh"; 0xef6,"Hangul_AraeA"; 0xef7,"Hangul_AraeAE"; 0xef8,"Hangul_J_PanSios"; 0xef9,"Hangul_J_KkogjiDalrinIeung"; 0xefa,"Hangul_J_YeorinHieuh"; 0xeff,"Korean_Won"; ] coq-8.4pl4/ide/utils/configwin_ihm.ml0000644000175000017500000012714712326224777016722 0ustar stephsteph(*********************************************************************************) (* Cameleon *) (* *) (* Copyright (C) 2005 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. *) (* *) (* This program is free software; you can redistribute it and/or modify *) (* it under the terms of the GNU Library General Public License as *) (* published by the Free Software Foundation; either version 2 of the *) (* License, or any later version. *) (* *) (* This program is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Library General Public License for more details. *) (* *) (* You should have received a copy of the GNU Library General Public *) (* License along with this program; if not, write to the Free Software *) (* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) (* 02111-1307 USA *) (* *) (* Contact: Maxence.Guesdon@inria.fr *) (* *) (*********************************************************************************) (** This module contains the gui functions of Configwin.*) open Configwin_types module O = Config_file class type widget = object method box : GObj.widget method apply : unit -> unit end let file_html_config = Filename.concat Configwin_messages.home ".configwin_html" let debug = false let dbg = if debug then prerr_endline else (fun _ -> ()) (** Return the config group for the html config file, and the option for bindings. *) let html_config_file_and_option () = let ini = new O.group in let bindings = new O.list_cp Configwin_types.htmlbinding_cp_wrapper ~group: ini ["bindings"] ~short_name: "bd" [ { html_key = Configwin_types.string_to_key "A-b" ; html_begin = ""; html_end = "" ; } ; { html_key = Configwin_types.string_to_key "A-i" ; html_begin = ""; html_end = "" ; } ] "" in ini#read file_html_config ; (ini, bindings) (** This variable contains the last directory where the user selected a file.*) let last_dir = ref "";; (** This function allows the user to select a file and returns the selected file name. An optional function allows to change the behaviour of the ok button. A VOIR : mutli-selection ? *) let select_files ?dir ?(fok : (string -> unit) option) the_title = let files = ref ([] : string list) in let fs = GWindow.file_selection ~modal:true ~title: the_title () in (* we set the previous directory, if no directory is given *) ( match dir with None -> if !last_dir <> "" then let _ = fs#set_filename !last_dir in () else () | Some dir -> let _ = fs#set_filename !last_dir in () ); let _ = fs # connect#destroy ~callback: GMain.Main.quit in let _ = fs # ok_button # connect#clicked ~callback: (match fok with None -> (fun () -> files := [fs#filename] ; fs#destroy ()) | Some f -> (fun () -> f fs#filename) ) in let _ = fs # cancel_button # connect#clicked ~callback:fs#destroy in fs # show (); GMain.Main.main (); match !files with | [] -> [] | [""] -> [] | l -> (* we keep the directory in last_dir *) last_dir := Filename.dirname (List.hd l); l ;; (** Make the user select a date. *) let select_date title (day,mon,year) = let v_opt = ref None in let window = GWindow.dialog ~modal:true ~title () in let hbox = GPack.hbox ~border_width:10 ~packing:window#vbox#add () in let cal = GMisc.calendar ~packing: (hbox#pack ~expand: true) () in cal#select_month ~month: mon ~year: year ; cal#select_day day; let bbox = window#action_area in let bok = GButton.button ~label: Configwin_messages.mOk ~packing:(bbox#pack ~expand:true ~padding:4) () in let bcancel = GButton.button ~label: Configwin_messages.mCancel ~packing:(bbox#pack ~expand:true ~padding:4) () in ignore (bok#connect#clicked ~callback: (fun () -> v_opt := Some (cal#date); window#destroy ())); ignore(bcancel#connect#clicked ~callback: window#destroy); bok#grab_default (); ignore(window#connect#destroy ~callback: GMain.Main.quit); window#set_position `CENTER; window#show (); GMain.Main.main (); !v_opt (** This class builds a frame with a clist and two buttons : one to add items and one to remove the selected items. The class takes in parameter a function used to add items and a string list ref which is used to store the content of the clist. At last, a title for the frame is also in parameter, so that each instance of the class creates a frame. *) class ['a] list_selection_box (listref : 'a list ref) titles_opt help_opt f_edit_opt f_strings f_color (eq : 'a -> 'a -> bool) add_function title editable (tt:GData.tooltips) = let _ = dbg "list_selection_box" in let wev = GBin.event_box () in let wf = GBin.frame ~label: title ~packing: wev#add () in let hbox = GPack.hbox ~packing: wf#add () in (* the scroll window and the clist *) let wscroll = GBin.scrolled_window ~vpolicy: `AUTOMATIC ~hpolicy: `AUTOMATIC ~packing: (hbox#pack ~expand: true) () in let wlist = match titles_opt with None -> GList.clist ~selection_mode: `MULTIPLE ~titles_show: false ~packing: wscroll#add () | Some l -> GList.clist ~selection_mode: `MULTIPLE ~titles: l ~titles_show: true ~packing: wscroll#add () in let _ = match help_opt with None -> () | Some help -> tt#set_tip ~text: help ~privat: help wev#coerce in (* the vbox for the buttons *) let vbox_buttons = GPack.vbox () in let _ = if editable then let _ = hbox#pack ~expand: false vbox_buttons#coerce in () else () in let _ = dbg "list_selection_box: wb_add" in let wb_add = GButton.button ~label: Configwin_messages.mAdd ~packing: (vbox_buttons#pack ~expand:false ~padding:2) () in let wb_edit = GButton.button ~label: Configwin_messages.mEdit () in let _ = match f_edit_opt with None -> () | Some _ -> vbox_buttons#pack ~expand:false ~padding:2 wb_edit#coerce in let wb_up = GButton.button ~label: Configwin_messages.mUp ~packing: (vbox_buttons#pack ~expand:false ~padding:2) () in let wb_remove = GButton.button ~label: Configwin_messages.mRemove ~packing: (vbox_buttons#pack ~expand:false ~padding:2) () in let _ = dbg "list_selection_box: object(self)" in object (self) (** the list of selected rows *) val mutable list_select = [] (** This method returns the frame created. *) method box = wev method update l = (* set the new list in the provided listref *) listref := l; (* insert the elements in the clist *) wlist#freeze (); wlist#clear (); List.iter (fun ele -> ignore (wlist#append (f_strings ele)); match f_color ele with None -> () | Some c -> try wlist#set_row ~foreground: (`NAME c) (wlist#rows - 1) with _ -> () ) !listref; (match titles_opt with None -> wlist#columns_autosize () | Some _ -> GToolbox.autosize_clist wlist); wlist#thaw (); (* the list of selectd elements is now empty *) list_select <- [] (** Move up the selected rows. *) method up_selected = let rec iter n selrows l = match selrows with [] -> (l, []) | m :: qrows -> match l with [] -> ([],[]) | [_] -> (l,[]) | e1 :: e2 :: q when m = n + 1 -> let newl, newrows = iter (n+1) qrows (e1 :: q) in (e2 :: newl, n :: newrows) | e1 :: q -> let newl, newrows = iter (n+1) selrows q in (e1 :: newl, newrows) in let sorted_select = List.sort compare list_select in let new_list, new_rows = iter 0 sorted_select !listref in self#update new_list; List.iter (fun n -> wlist#select n 0) new_rows (** Make the user edit the first selected row. *) method edit_selected f_edit = let sorted_select = List.sort compare list_select in match sorted_select with [] -> () | n :: _ -> try let ele = List.nth !listref n in let ele2 = f_edit ele in let rec iter m = function [] -> [] | e :: q -> if n = m then ele2 :: q else e :: (iter (m+1) q) in self#update (iter 0 !listref); wlist#select n 0 with Not_found -> () initializer (** create the functions called when the buttons are clicked *) let f_add () = (* get the files to add with the function provided *) let l = add_function () in (* remove from the list the ones which are already in the listref, using the eq predicate *) let l2 = List.fold_left (fun acc -> fun ele -> if List.exists (eq ele) acc then acc else acc @ [ele]) !listref l in self#update l2 in let f_remove () = (* remove the selected items from the listref and the clist *) let rec iter n = function [] -> [] | h :: q -> if List.mem n list_select then iter (n+1) q else h :: (iter (n+1) q) in let new_list = iter 0 !listref in self#update new_list in let _ = dbg "list_selection_box: connecting wb_add" in (* connect the functions to the buttons *) ignore (wb_add#connect#clicked ~callback:f_add); let _ = dbg "list_selection_box: connecting wb_remove" in ignore (wb_remove#connect#clicked ~callback:f_remove); let _ = dbg "list_selection_box: connecting wb_up" in ignore (wb_up#connect#clicked ~callback:(fun () -> self#up_selected)); ( match f_edit_opt with None -> () | Some f -> let _ = dbg "list_selection_box: connecting wb_edit" in ignore (wb_edit#connect#clicked ~callback:(fun () -> self#edit_selected f)) ); (* connect the selection and deselection of items in the clist *) let f_select ~row ~column ~event = try list_select <- row :: list_select with Failure _ -> () in let f_unselect ~row ~column ~event = try let new_list_select = List.filter (fun n -> n <> row) list_select in list_select <- new_list_select with Failure _ -> () in (* connect the select and deselect events *) let _ = dbg "list_selection_box: connecting select_row" in ignore(wlist#connect#select_row ~callback:f_select); let _ = dbg "list_selection_box: connecting unselect_row" in ignore(wlist#connect#unselect_row ~callback:f_unselect); (* initialize the clist with the listref *) self#update !listref end;; (** This class is used to build a box for a string parameter.*) class string_param_box param (tt:GData.tooltips) = let _ = dbg "string_param_box" in let hbox = GPack.hbox () in let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in let _wl = GMisc.label ~text: param.string_label ~packing: wev#add () in let we = GEdit.entry ~editable: param.string_editable ~packing: (hbox#pack ~expand: param.string_expand ~padding: 2) () in let _ = match param.string_help with None -> () | Some help -> tt#set_tip ~text: help ~privat: help wev#coerce in let _ = we#set_text (param.string_to_string param.string_value) in object (self) (** This method returns the main box ready to be packed. *) method box = hbox#coerce (** This method applies the new value of the parameter. *) method apply = let new_value = param.string_of_string we#text in if new_value <> param.string_value then let _ = param.string_f_apply new_value in param.string_value <- new_value else () end ;; (** This class is used to build a box for a combo parameter.*) class combo_param_box param (tt:GData.tooltips) = let _ = dbg "combo_param_box" in let hbox = GPack.hbox () in let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in let _wl = GMisc.label ~text: param.combo_label ~packing: wev#add () in let _ = match param.combo_help with None -> () | Some help -> tt#set_tip ~text: help ~privat: help wev#coerce in let get_value = if not param.combo_new_allowed then let wc = GEdit.combo_box_text ~strings: param.combo_choices ?active:(let rec aux i = function |[] -> None |h::_ when h = param.combo_value -> Some i |_::t -> aux (succ i) t in aux 0 param.combo_choices) ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2) () in fun () -> match GEdit.text_combo_get_active wc with |None -> "" |Some s -> s else let (wc,_) = GEdit.combo_box_entry_text ~strings: param.combo_choices ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2) () in let _ = wc#entry#set_editable param.combo_editable in let _ = wc#entry#set_text param.combo_value in fun () -> wc#entry#text in object (self) (** This method returns the main box ready to be packed. *) method box = hbox#coerce (** This method applies the new value of the parameter. *) method apply = let new_value = get_value () in if new_value <> param.combo_value then let _ = param.combo_f_apply new_value in param.combo_value <- new_value else () end ;; (** Class used to pack a custom box. *) class custom_param_box param (tt:GData.tooltips) = let _ = dbg "custom_param_box" in let top = match param.custom_framed with None -> param.custom_box#coerce | Some l -> let wf = GBin.frame ~label: l () in wf#add param.custom_box#coerce; wf#coerce in object (self) method box = top method apply = param.custom_f_apply () end (** This class is used to build a box for a color parameter.*) class color_param_box param (tt:GData.tooltips) = let _ = dbg "color_param_box" in let v = ref param.color_value in let hbox = GPack.hbox () in let wb = GButton.button ~label: param.color_label ~packing: (hbox#pack ~expand: false ~padding: 2) () in let w_test = GMisc.arrow ~kind: `RIGHT ~shadow: `OUT ~width: 20 ~height: 20 ~packing: (hbox#pack ~expand: false ~padding: 2 ) () in let we = GEdit.entry ~editable: param.color_editable ~packing: (hbox#pack ~expand: param.color_expand ~padding: 2) () in let _ = match param.color_help with None -> () | Some help -> tt#set_tip ~text: help ~privat: help wb#coerce in let set_color s = let style = w_test#misc#style#copy in ( try style#set_fg [ (`NORMAL, `NAME s) ; ] with _ -> () ); w_test#misc#set_style style; in let _ = set_color !v in let _ = we#set_text !v in let f_sel () = let dialog = GWindow.color_selection_dialog ~title: param.color_label ~modal: true ~show: true () in let wb_ok = dialog#ok_button in let wb_cancel = dialog#cancel_button in let _ = dialog#connect#destroy ~callback:GMain.Main.quit in let _ = wb_ok#connect#clicked ~callback:(fun () -> (* let color = dialog#colorsel#color in let r = (Gdk.Color.red color) in let g = (Gdk.Color.green color)in let b = (Gdk.Color.blue color) in let s = Printf.sprintf "#%4X%4X%4X" r g b in let _ = for i = 1 to (String.length s) - 1 do if s.[i] = ' ' then s.[i] <- '0' done in we#set_text s ; *) dialog#destroy () ) in let _ = wb_cancel#connect#clicked ~callback:dialog#destroy in GMain.Main.main () in let _ = if param.color_editable then ignore (wb#connect#clicked ~callback:f_sel) in object (self) (** This method returns the main box ready to be packed. *) method box = hbox#coerce (** This method applies the new value of the parameter. *) method apply = let new_value = we#text in if new_value <> param.color_value then let _ = param.color_f_apply new_value in param.color_value <- new_value else () initializer ignore (we#connect#changed ~callback:(fun () -> set_color we#text)); end ;; (** This class is used to build a box for a font parameter.*) class font_param_box param (tt:GData.tooltips) = let _ = dbg "font_param_box" in let v = ref param.font_value in let hbox = GPack.hbox () in let wb = GButton.button ~label: param.font_label ~packing: (hbox#pack ~expand: false ~padding: 2) () in let we = GEdit.entry ~editable: false ~packing: (hbox#pack ~expand: param.font_expand ~padding: 2) () in let _ = match param.font_help with None -> () | Some help -> tt#set_tip ~text: help ~privat: help wb#coerce in let set_entry_font font_opt = match font_opt with None -> () | Some s -> let style = we#misc#style#copy in ( try let font = Gdk.Font.load_fontset s in style#set_font font with _ -> () ); we#misc#set_style style in let _ = set_entry_font (Some !v) in let _ = we#set_text !v in let f_sel () = let dialog = GWindow.font_selection_dialog ~title: param.font_label ~modal: true ~show: true () in dialog#selection#set_font_name !v; let wb_ok = dialog#ok_button in let wb_cancel = dialog#cancel_button in let _ = dialog#connect#destroy ~callback:GMain.Main.quit in let _ = wb_ok#connect#clicked ~callback:(fun () -> let font = dialog#selection#font_name in we#set_text font ; set_entry_font (Some font); dialog#destroy () ) in let _ = wb_cancel#connect#clicked ~callback:dialog#destroy in GMain.Main.main () in let _ = if param.font_editable then ignore (wb#connect#clicked ~callback:f_sel) in object (self) (** This method returns the main box ready to be packed. *) method box = hbox#coerce (** This method applies the new value of the parameter. *) method apply = let new_value = we#text in if new_value <> param.font_value then let _ = param.font_f_apply new_value in param.font_value <- new_value else () end ;; (** This class is used to build a box for a text parameter.*) class text_param_box param (tt:GData.tooltips) = let _ = dbg "text_param_box" in let wf = GBin.frame ~label: param.string_label ~height: 100 () in let wev = GBin.event_box ~packing: wf#add () in let wscroll = GBin.scrolled_window ~vpolicy: `AUTOMATIC ~hpolicy: `AUTOMATIC ~packing: wev#add () in let wview = GText.view ~editable: param.string_editable ~packing: wscroll#add () in let _ = match param.string_help with None -> () | Some help -> tt#set_tip ~text: help ~privat: help wev#coerce in let _ = dbg "text_param_box: buffer creation" in let buffer = GText.buffer () in let _ = wview#set_buffer buffer in let _ = buffer#insert (param.string_to_string param.string_value) in let _ = dbg "text_param_box: object(self)" in object (self) val wview = wview (** This method returns the main box ready to be packed. *) method box = wf#coerce (** This method applies the new value of the parameter. *) method apply = let v = param.string_of_string (buffer#get_text ()) in if v <> param.string_value then ( dbg "apply new value !"; let _ = param.string_f_apply v in param.string_value <- v ) else () end ;; (** This class is used to build a box a html parameter. *) class html_param_box param (tt:GData.tooltips) = let _ = dbg "html_param_box" in object (self) inherit text_param_box param tt method private exec html_start html_end () = let (i1,i2) = wview#buffer#selection_bounds in let s = i1#get_text ~stop: i2 in match s with "" -> wview#buffer#insert (html_start^html_end) | _ -> ignore (wview#buffer#insert ~iter: i2 html_end); ignore (wview#buffer#insert ~iter: i1 html_start); wview#buffer#place_cursor ~where: i2 initializer dbg "html_param_box:initializer"; let (_,html_bindings) = html_config_file_and_option () in dbg "html_param_box:connecting key press events"; let add_shortcut hb = let (mods, k) = hb.html_key in Okey.add wview ~mods k (self#exec hb.html_begin hb.html_end) in List.iter add_shortcut html_bindings#get; dbg "html_param_box:end" end (** This class is used to build a box for a boolean parameter.*) class bool_param_box param (tt:GData.tooltips) = let _ = dbg "bool_param_box" in let wchk = GButton.check_button ~label: param.bool_label () in let _ = match param.bool_help with None -> () | Some help -> tt#set_tip ~text: help ~privat: help wchk#coerce in let _ = wchk#set_active param.bool_value in let _ = wchk#misc#set_sensitive param.bool_editable in object (self) (** This method returns the check button ready to be packed. *) method box = wchk#coerce (** This method applies the new value of the parameter. *) method apply = let new_value = wchk#active in if new_value <> param.bool_value then let _ = param.bool_f_apply new_value in param.bool_value <- new_value else () end ;; (** This class is used to build a box for a file name parameter.*) class filename_param_box param (tt:GData.tooltips) = let _ = dbg "filename_param_box" in let hbox = GPack.hbox () in let wb = GButton.button ~label: param.string_label ~packing: (hbox#pack ~expand: false ~padding: 2) () in let we = GEdit.entry ~editable: param.string_editable ~packing: (hbox#pack ~expand: param.string_expand ~padding: 2) () in let _ = match param.string_help with None -> () | Some help -> tt#set_tip ~text: help ~privat: help wb#coerce in let _ = we#set_text (param.string_to_string param.string_value) in let f_click () = match select_files param.string_label with [] -> () | f :: _ -> we#set_text f in let _ = if param.string_editable then let _ = wb#connect#clicked ~callback:f_click in () else () in object (self) (** This method returns the main box ready to be packed. *) method box = hbox#coerce (** This method applies the new value of the parameter. *) method apply = let new_value = param.string_of_string we#text in if new_value <> param.string_value then let _ = param.string_f_apply new_value in param.string_value <- new_value else () end ;; (** This class is used to build a box for a hot key parameter.*) class hotkey_param_box param (tt:GData.tooltips) = let _ = dbg "hotkey_param_box" in let hbox = GPack.hbox () in let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in let _wl = GMisc.label ~text: param.hk_label ~packing: wev#add () in let we = GEdit.entry ~editable: false ~packing: (hbox#pack ~expand: param.hk_expand ~padding: 2) () in let value = ref param.hk_value in let _ = match param.hk_help with None -> () | Some help -> tt#set_tip ~text: help ~privat: help wev#coerce in let _ = we#set_text (Configwin_types.key_to_string param.hk_value) in let mods_we_dont_care = [`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK] in let capture ev = let key = GdkEvent.Key.keyval ev in let modifiers = GdkEvent.Key.state ev in let mods = List.filter (fun m -> not (List.mem m mods_we_dont_care)) modifiers in value := (mods, key); we#set_text (Glib.Convert.locale_to_utf8 (Configwin_types.key_to_string !value)); false in let _ = if param.hk_editable then ignore (we#event#connect#key_press ~callback:capture) else () in object (self) (** This method returns the main box ready to be packed. *) method box = hbox#coerce (** This method applies the new value of the parameter. *) method apply = let new_value = !value in if new_value <> param.hk_value then let _ = param.hk_f_apply new_value in param.hk_value <- new_value else () end ;; class modifiers_param_box param = let hbox = GPack.hbox () in let wev = GBin.event_box ~packing: (hbox#pack ~expand:true ~fill:true ~padding: 2) () in let _wl = GMisc.label ~text: param.md_label ~packing: wev#add () in let value = ref param.md_value in let _ = List.map (fun modifier -> let but = GButton.toggle_button ~label:(Configwin_types.modifiers_to_string [modifier]) ~active:(List.mem modifier param.md_value) ~packing:(hbox#pack ~expand:false) () in ignore (but#connect#toggled ~callback:(fun _ -> if but#active then value := modifier::!value else value := List.filter ((<>) modifier) !value))) param.md_allow in let _ = match param.md_help with None -> () | Some help -> let tooltips = GData.tooltips () in ignore (hbox#connect#destroy ~callback: tooltips#destroy); tooltips#set_tip wev#coerce ~text: help ~privat: help in object (self) (** This method returns the main box ready to be packed. *) method box = hbox#coerce (** This method applies the new value of the parameter. *) method apply = let new_value = !value in if new_value <> param.md_value then let _ = param.md_f_apply new_value in param.md_value <- new_value else () end ;; (** This class is used to build a box for a date parameter.*) class date_param_box param (tt:GData.tooltips) = let _ = dbg "date_param_box" in let v = ref param.date_value in let hbox = GPack.hbox () in let wb = GButton.button ~label: param.date_label ~packing: (hbox#pack ~expand: false ~padding: 2) () in let we = GEdit.entry ~editable: false ~packing: (hbox#pack ~expand: param.date_expand ~padding: 2) () in let _ = match param.date_help with None -> () | Some help -> tt#set_tip ~text: help ~privat: help wb#coerce in let _ = we#set_text (param.date_f_string param.date_value) in let f_click () = match select_date param.date_label !v with None -> () | Some (y,m,d) -> v := (d,m,y) ; we#set_text (param.date_f_string (d,m,y)) in let _ = if param.date_editable then let _ = wb#connect#clicked ~callback:f_click in () else () in object (self) (** This method returns the main box ready to be packed. *) method box = hbox#coerce (** This method applies the new value of the parameter. *) method apply = if !v <> param.date_value then let _ = param.date_f_apply !v in param.date_value <- !v else () end ;; (** This class is used to build a box for a parameter whose values are a list.*) class ['a] list_param_box (param : 'a list_param) (tt:GData.tooltips) = let _ = dbg "list_param_box" in let listref = ref param.list_value in let frame_selection = new list_selection_box listref param.list_titles param.list_help param.list_f_edit param.list_strings param.list_color param.list_eq param.list_f_add param.list_label param.list_editable tt in object (self) (** This method returns the main box ready to be packed. *) method box = frame_selection#box#coerce (** This method applies the new value of the parameter. *) method apply = param.list_f_apply !listref ; param.list_value <- !listref end ;; (** This class creates a configuration box from a configuration structure *) class configuration_box (tt : GData.tooltips) conf_struct = let main_box = GPack.hbox () in let columns = new GTree.column_list in let icon_col = columns#add GtkStock.conv in let label_col = columns#add Gobject.Data.string in let box_col = columns#add Gobject.Data.caml in let () = columns#lock () in let pane = GPack.paned `HORIZONTAL ~packing:main_box#add () in (* Tree view part *) let scroll = GBin.scrolled_window ~hpolicy:`NEVER ~packing:pane#pack1 () in let tree = GTree.tree_store columns in let view = GTree.view ~model:tree ~headers_visible:false ~packing:scroll#add_with_viewport () in let selection = view#selection in let _ = selection#set_mode `SINGLE in let menu_box = GPack.vbox ~packing:pane#pack2 () in let renderer = (GTree.cell_renderer_pixbuf [], ["stock-id", icon_col]) in let col = GTree.view_column ~renderer () in let _ = view#append_column col in let renderer = (GTree.cell_renderer_text [], ["text", label_col]) in let col = GTree.view_column ~renderer () in let _ = view#append_column col in let make_param (main_box : #GPack.box) = function | String_param p -> let box = new string_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Combo_param p -> let box = new combo_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Text_param p -> let box = new text_param_box p tt in let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in box | Bool_param p -> let box = new bool_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Filename_param p -> let box = new filename_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | List_param f -> let box = f tt in let _ = main_box#pack ~expand: true ~padding: 2 box#box in box | Custom_param p -> let box = new custom_param_box p tt in let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in box | Color_param p -> let box = new color_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Font_param p -> let box = new font_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Date_param p -> let box = new date_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Hotkey_param p -> let box = new hotkey_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Modifiers_param p -> let box = new modifiers_param_box p in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Html_param p -> let box = new html_param_box p tt in let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in box in let set_icon iter = function | None -> () | Some icon -> tree#set iter icon_col icon in (* Populate the tree *) let rec make_tree iter conf_struct = (* box is not shown at first *) let box = GPack.vbox ~packing:(menu_box#pack ~expand:true) ~show:false () in let new_iter = match iter with | None -> tree#append () | Some parent -> tree#append ~parent () in match conf_struct with | Section (label, icon, param_list) -> let params = List.map (make_param box) param_list in let widget = object method box = box#coerce method apply () = List.iter (fun param -> param#apply) params end in let () = tree#set new_iter label_col label in let () = set_icon new_iter icon in let () = tree#set new_iter box_col widget in () | Section_list (label, icon, struct_list) -> let widget = object (* Section_list does not contain any effect widget, so we do not have to apply anything. *) method apply () = () method box = box#coerce end in let () = tree#set new_iter label_col label in let () = set_icon new_iter icon in let () = tree#set new_iter box_col widget in List.iter (make_tree (Some new_iter)) struct_list in let () = List.iter (make_tree None) conf_struct in (* Dealing with signals *) let current_prop : widget option ref = ref None in let select_iter iter = let () = match !current_prop with | None -> () | Some box -> box#box#misc#hide () in let box = tree#get ~row:iter ~column:box_col in let () = box#box#misc#show () in current_prop := Some box in let when_selected () = let rows = selection#get_selected_rows in match rows with | [] -> () | row :: _ -> let iter = tree#get_iter row in select_iter iter in (* Focus on a box when selected *) let _ = selection#connect#changed ~callback:when_selected in let _ = match tree#get_iter_first with | None -> () | Some iter -> select_iter iter in object method box = main_box method apply = let foreach _ iter = let widget = tree#get ~row:iter ~column:box_col in widget#apply(); false in tree#foreach foreach end (** Create a vbox with the list of given configuration structure list, and the given list of buttons (defined by their label and callback). Before calling the callback of a button, the [apply] function of each parameter is called. *) let tabbed_box conf_struct_list buttons tooltips = let param_box = new configuration_box tooltips conf_struct_list in let f_apply () = param_box#apply in let hbox_buttons = GPack.hbox ~packing: (param_box#box#pack ~expand: false ~padding: 4) () in let rec iter_buttons ?(grab=false) = function [] -> () | (label, callb) :: q -> let b = GButton.button ~label: label ~packing:(hbox_buttons#pack ~expand:true ~fill: true ~padding:4) () in ignore (b#connect#clicked ~callback: (fun () -> f_apply (); callb ())); (* If it's the first button then give it the focus *) if grab then b#grab_default (); iter_buttons q in iter_buttons ~grab: true buttons; param_box#box (** This function takes a configuration structure list and creates a window to configure the various parameters. *) let edit ?(with_apply=true) ?(apply=(fun () -> ())) title ?width ?height conf_struct = let dialog = GWindow.dialog ~position:`CENTER ~modal: true ~title: title ?height ?width () in let tooltips = GData.tooltips () in let config_box = new configuration_box tooltips conf_struct in let _ = dialog#vbox#add config_box#box#coerce in if with_apply then dialog#add_button Configwin_messages.mApply `APPLY; dialog#add_button Configwin_messages.mOk `OK; dialog#add_button Configwin_messages.mCancel `CANCEL; let destroy () = tooltips#destroy () ; dialog#destroy (); in let rec iter rep = try match dialog#run () with | `APPLY -> config_box#apply; iter Return_apply | `OK -> config_box#apply; destroy (); Return_ok | _ -> destroy (); rep with Failure s -> GToolbox.message_box ~title:"Error" s; iter rep | e -> GToolbox.message_box ~title:"Error" (Printexc.to_string e); iter rep in iter Return_cancel (** Create a vbox with the list of given parameters. *) let box param_list tt = let main_box = GPack.vbox () in let f parameter = match parameter with String_param p -> let box = new string_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Combo_param p -> let box = new combo_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Text_param p -> let box = new text_param_box p tt in let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in box | Bool_param p -> let box = new bool_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Filename_param p -> let box = new filename_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | List_param f -> let box = f tt in let _ = main_box#pack ~expand: true ~padding: 2 box#box in box | Custom_param p -> let box = new custom_param_box p tt in let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in box | Color_param p -> let box = new color_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Font_param p -> let box = new font_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Date_param p -> let box = new date_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Hotkey_param p -> let box = new hotkey_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Modifiers_param p -> let box = new modifiers_param_box p in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Html_param p -> let box = new html_param_box p tt in let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in box in let list_param_box = List.map f param_list in let f_apply () = List.iter (fun param_box -> param_box#apply) list_param_box in (main_box, f_apply) (** This function takes a list of parameter specifications and creates a window to configure the various parameters.*) let simple_edit ?(with_apply=true) ?(apply=(fun () -> ())) title ?width ?height param_list = let dialog = GWindow.dialog ~modal: true ~title: title ?height ?width () in let tooltips = GData.tooltips () in if with_apply then dialog#add_button Configwin_messages.mApply `APPLY; dialog#add_button Configwin_messages.mOk `OK; dialog#add_button Configwin_messages.mCancel `CANCEL; let (box, f_apply) = box param_list tooltips in dialog#vbox#pack ~expand: true ~fill: true box#coerce; let destroy () = tooltips#destroy () ; dialog#destroy (); in let rec iter rep = try match dialog#run () with | `APPLY -> f_apply (); apply (); iter Return_apply | `OK -> f_apply () ; destroy () ; Return_ok | _ -> destroy (); rep with Failure s -> GToolbox.message_box ~title:"Error" s; iter rep | e -> GToolbox.message_box ~title:"Error" (Printexc.to_string e); iter rep in iter Return_cancel let edit_string l s = match GToolbox.input_string ~title: l ~text: s Configwin_messages.mValue with None -> s | Some s2 -> s2 (** Create a string param. *) let string ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = String_param { string_label = label ; string_help = help ; string_value = v ; string_editable = editable ; string_f_apply = f ; string_expand = expand ; string_to_string = (fun x -> x) ; string_of_string = (fun x -> x) ; } (** Create a bool param. *) let bool ?(editable=true) ?help ?(f=(fun _ -> ())) label v = Bool_param { bool_label = label ; bool_help = help ; bool_value = v ; bool_editable = editable ; bool_f_apply = f ; } (** Create a list param. *) let list ?(editable=true) ?help ?(f=(fun (_:'a list) -> ())) ?(eq=Pervasives.(=)) ?(edit:('a -> 'a) option) ?(add=(fun () -> ([] : 'a list))) ?titles ?(color=(fun (_:'a) -> (None : string option))) label (f_strings : 'a -> string list) v = List_param (fun tt -> new list_param_box { list_label = label ; list_help = help ; list_value = v ; list_editable = editable ; list_titles = titles; list_eq = eq ; list_strings = f_strings ; list_color = color ; list_f_edit = edit ; list_f_add = add ; list_f_apply = f ; } tt ) (** Create a strings param. *) let strings ?(editable=true) ?help ?(f=(fun _ -> ())) ?(eq=Pervasives.(=)) ?(add=(fun () -> [])) label v = list ~editable ?help ~f ~eq ~edit: (edit_string label) ~add label (fun s -> [s]) v (** Create a color param. *) let color ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = Color_param { color_label = label ; color_help = help ; color_value = v ; color_editable = editable ; color_f_apply = f ; color_expand = expand ; } (** Create a font param. *) let font ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = Font_param { font_label = label ; font_help = help ; font_value = v ; font_editable = editable ; font_f_apply = f ; font_expand = expand ; } (** Create a combo param. *) let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) ?(new_allowed=false) ?(blank_allowed=false) label choices v = Combo_param { combo_label = label ; combo_help = help ; combo_value = v ; combo_editable = editable ; combo_choices = choices ; combo_new_allowed = new_allowed ; combo_blank_allowed = blank_allowed ; combo_f_apply = f ; combo_expand = expand ; } (** Create a text param. *) let text ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = Text_param { string_label = label ; string_help = help ; string_value = v ; string_editable = editable ; string_f_apply = f ; string_expand = expand ; string_to_string = (fun x -> x) ; string_of_string = (fun x -> x) ; } (** Create a html param. *) let html ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = Html_param { string_label = label ; string_help = help ; string_value = v ; string_editable = editable ; string_f_apply = f ; string_expand = expand ; string_to_string = (fun x -> x) ; string_of_string = (fun x -> x) ; } (** Create a filename param. *) let filename ?(editable=true) ?(expand=true)?help ?(f=(fun _ -> ())) label v = Filename_param { string_label = label ; string_help = help ; string_value = v ; string_editable = editable ; string_f_apply = f ; string_expand = expand ; string_to_string = (fun x -> x) ; string_of_string = (fun x -> x) ; } (** Create a filenames param.*) let filenames ?(editable=true) ?help ?(f=(fun _ -> ())) ?(eq=Pervasives.(=)) label v = let add () = select_files label in list ~editable ?help ~f ~eq ~add label (fun s -> [Glib.Convert.locale_to_utf8 s]) v (** Create a date param. *) let date ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) ?(f_string=(fun(d,m,y)-> Printf.sprintf "%d/%d/%d" y (m+1) d)) label v = Date_param { date_label = label ; date_help = help ; date_value = v ; date_editable = editable ; date_f_string = f_string ; date_f_apply = f ; date_expand = expand ; } (** Create a hot key param. *) let hotkey ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = Hotkey_param { hk_label = label ; hk_help = help ; hk_value = v ; hk_editable = editable ; hk_f_apply = f ; hk_expand = expand ; } let modifiers ?(editable=true) ?(expand=true) ?help ?(allow=[`CONTROL;`SHIFT;`LOCK;`MOD1;`MOD2;`MOD3;`MOD4;`MOD5]) ?(f=(fun _ -> ())) label v = Modifiers_param { md_label = label ; md_help = help ; md_value = v ; md_editable = editable ; md_f_apply = f ; md_expand = expand ; md_allow = allow ; } (** Create a custom param.*) let custom ?label box f expand = Custom_param { custom_box = box ; custom_f_apply = f ; custom_expand = expand ; custom_framed = label ; } coq-8.4pl4/ide/utils/configwin.ml0000644000175000017500000000712212326224777016053 0ustar stephsteph(*********************************************************************************) (* Cameleon *) (* *) (* Copyright (C) 2005 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. *) (* *) (* This program is free software; you can redistribute it and/or modify *) (* it under the terms of the GNU Library General Public License as *) (* published by the Free Software Foundation; either version 2 of the *) (* License, or any later version. *) (* *) (* This program is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Library General Public License for more details. *) (* *) (* You should have received a copy of the GNU Library General Public *) (* License along with this program; if not, write to the Free Software *) (* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) (* 02111-1307 USA *) (* *) (* Contact: Maxence.Guesdon@inria.fr *) (* *) (*********************************************************************************) type parameter_kind = Configwin_types.parameter_kind type configuration_structure = Configwin_types.configuration_structure = Section of string * GtkStock.id option * parameter_kind list | Section_list of string * GtkStock.id option * configuration_structure list type return_button = Configwin_types.return_button = Return_apply | Return_ok | Return_cancel let string_to_key = Configwin_types.string_to_key let key_to_string = Configwin_types.key_to_string let key_cp_wrapper = Configwin_types.key_cp_wrapper class key_cp = Configwin_types.key_cp let string = Configwin_ihm.string let text = Configwin_ihm.text let strings = Configwin_ihm.strings let list = Configwin_ihm.list let bool = Configwin_ihm.bool let filename = Configwin_ihm.filename let filenames = Configwin_ihm.filenames let color = Configwin_ihm.color let font = Configwin_ihm.font let combo = Configwin_ihm.combo let custom = Configwin_ihm.custom let date = Configwin_ihm.date let hotkey = Configwin_ihm.hotkey let modifiers = Configwin_ihm.modifiers let html = Configwin_ihm.html let edit ?(apply=(fun () -> ())) title ?width ?height conf_struct_list = Configwin_ihm.edit ~with_apply: true ~apply title ?width ?height conf_struct_list let get = Configwin_ihm.edit ~with_apply: false ~apply: (fun () -> ()) let simple_edit ?(apply=(fun () -> ())) title ?width ?height param_list = Configwin_ihm.simple_edit ~with_apply: true ~apply title ?width ?height param_list let simple_get = Configwin_ihm.simple_edit ~with_apply: false ~apply: (fun () -> ()) let box = Configwin_ihm.box let tabbed_box = Configwin_ihm.tabbed_box coq-8.4pl4/ide/utils/configwin_types.ml0000644000175000017500000002716612326224777017311 0ustar stephsteph(*********************************************************************************) (* Cameleon *) (* *) (* Copyright (C) 2005 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. *) (* *) (* This program is free software; you can redistribute it and/or modify *) (* it under the terms of the GNU Library General Public License as *) (* published by the Free Software Foundation; either version 2 of the *) (* License, or any later version. *) (* *) (* This program is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Library General Public License for more details. *) (* *) (* You should have received a copy of the GNU Library General Public *) (* License along with this program; if not, write to the Free Software *) (* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) (* 02111-1307 USA *) (* *) (* Contact: Maxence.Guesdon@inria.fr *) (* *) (*********************************************************************************) (** This module contains the types used in Configwin. *) open Config_file let name_to_keysym = ("Button1", Configwin_keys.xk_Pointer_Button1) :: ("Button2", Configwin_keys.xk_Pointer_Button2) :: ("Button3", Configwin_keys.xk_Pointer_Button3) :: ("Button4", Configwin_keys.xk_Pointer_Button4) :: ("Button5", Configwin_keys.xk_Pointer_Button5) :: Configwin_keys.name_to_keysym let string_to_key s = let mask = ref [] in let key = try let pos = String.rindex s '-' in for i = 0 to pos - 1 do let m = match s.[i] with 'C' -> `CONTROL | 'S' -> `SHIFT | 'L' -> `LOCK | 'M' -> `MOD1 | 'A' -> `MOD1 | '1' -> `MOD1 | '2' -> `MOD2 | '3' -> `MOD3 | '4' -> `MOD4 | '5' -> `MOD5 | _ -> prerr_endline s; raise Not_found in mask := m :: !mask done; String.sub s (pos+1) (String.length s - pos - 1) with _ -> s in try !mask, List.assoc key name_to_keysym with e -> prerr_endline s; raise e let key_to_string (m, k) = let s = List.assoc k Configwin_keys.keysym_to_name in match m with [] -> s | _ -> let rec iter m s = match m with [] -> s | c :: m -> iter m (( match c with `CONTROL -> "C" | `SHIFT -> "S" | `LOCK -> "L" | `MOD1 -> "A" | `MOD2 -> "2" | `MOD3 -> "3" | `MOD4 -> "4" | `MOD5 -> "5" | _ -> raise Not_found ) ^ s) in iter m ("-" ^ s) let modifiers_to_string m = let rec iter m s = match m with [] -> s | c :: m -> iter m (( match c with `CONTROL -> "" | `SHIFT -> "" | `LOCK -> "" | `MOD1 -> "" | `MOD2 -> "" | `MOD3 -> "" | `MOD4 -> "" | `MOD5 -> "" | _ -> raise Not_found ) ^ s) in iter m "" let value_to_key v = match v with Raw.String s -> string_to_key s | _ -> prerr_endline "value_to_key"; raise Not_found let key_to_value k = Raw.String (key_to_string k) let key_cp_wrapper = { to_raw = key_to_value ; of_raw = value_to_key ; } (** A class to define key options, with the {!Config_file} module. *) class key_cp = [(Gdk.Tags.modifier list * int)] Config_file.cp_custom_type key_cp_wrapper (** This type represents a string or filename parameter, or any other type, depending on the given conversion functions. *) type 'a string_param = { string_label : string; (** the label of the parameter *) mutable string_value : 'a; (** the current value of the parameter *) string_editable : bool ; (** indicates if the value can be changed *) string_f_apply : ('a -> unit) ; (** the function to call to apply the new value of the parameter *) string_help : string option ; (** optional help string *) string_expand : bool ; (** expand or not *) string_to_string : 'a -> string ; string_of_string : string -> 'a ; } ;; (** This type represents a boolean parameter. *) type bool_param = { bool_label : string; (** the label of the parameter *) mutable bool_value : bool; (** the current value of the parameter *) bool_editable : bool ; (** indicates if the value can be changed *) bool_f_apply : (bool -> unit) ; (** the function to call to apply the new value of the parameter *) bool_help : string option ; (** optional help string *) } ;; (** This type represents a parameter whose value is a list of ['a]. *) type 'a list_param = { list_label : string; (** the label of the parameter *) mutable list_value : 'a list; (** the current value of the parameter *) list_titles : string list option; (** the titles of columns, if they must be displayed *) list_f_edit : ('a -> 'a) option; (** optional edition function *) list_eq : ('a -> 'a -> bool) ; (** the comparison function used to get list without doubles *) list_strings : ('a -> string list); (** the function to get a string list from a ['a]. *) list_color : ('a -> string option) ; (** a function to get the optional color of an element *) list_editable : bool ; (** indicates if the value can be changed *) list_f_add : unit -> 'a list ; (** the function to call to add list *) list_f_apply : ('a list -> unit) ; (** the function to call to apply the new value of the parameter *) list_help : string option ; (** optional help string *) } ;; type combo_param = { combo_label : string ; mutable combo_value : string ; combo_choices : string list ; combo_editable : bool ; combo_blank_allowed : bool ; combo_new_allowed : bool ; combo_f_apply : (string -> unit); combo_help : string option ; (** optional help string *) combo_expand : bool ; (** expand the entry widget or not *) } ;; type custom_param = { custom_box : GPack.box ; custom_f_apply : (unit -> unit) ; custom_expand : bool ; custom_framed : string option ; (** optional label for an optional frame *) } ;; type color_param = { color_label : string; (** the label of the parameter *) mutable color_value : string; (** the current value of the parameter *) color_editable : bool ; (** indicates if the value can be changed *) color_f_apply : (string -> unit) ; (** the function to call to apply the new value of the parameter *) color_help : string option ; (** optional help string *) color_expand : bool ; (** expand the entry widget or not *) } ;; type date_param = { date_label : string ; (** the label of the parameter *) mutable date_value : int * int * int ; (** day, month, year *) date_editable : bool ; (** indicates if the value can be changed *) date_f_string : (int * int * int) -> string ; (** the function used to display the current value (day, month, year) *) date_f_apply : ((int * int * int) -> unit) ; (** the function to call to apply the new value (day, month, year) of the parameter *) date_help : string option ; (** optional help string *) date_expand : bool ; (** expand the entry widget or not *) } ;; type font_param = { font_label : string ; (** the label of the parameter *) mutable font_value : string ; (** the font name *) font_editable : bool ; (** indicates if the value can be changed *) font_f_apply : (string -> unit) ; (** the function to call to apply the new value of the parameter *) font_help : string option ; (** optional help string *) font_expand : bool ; (** expand the entry widget or not *) } ;; type hotkey_param = { hk_label : string ; (** the label of the parameter *) mutable hk_value : (Gdk.Tags.modifier list * int) ; (** The value, as a list of modifiers and a key code *) hk_editable : bool ; (** indicates if the value can be changed *) hk_f_apply : ((Gdk.Tags.modifier list * int) -> unit) ; (** the function to call to apply the new value of the paramter *) hk_help : string option ; (** optional help string *) hk_expand : bool ; (** expand or not *) } type modifiers_param = { md_label : string ; (** the label of the parameter *) mutable md_value : Gdk.Tags.modifier list ; (** The value, as a list of modifiers and a key code *) md_editable : bool ; (** indicates if the value can be changed *) md_f_apply : Gdk.Tags.modifier list -> unit ; (** the function to call to apply the new value of the paramter *) md_help : string option ; (** optional help string *) md_expand : bool ; (** expand or not *) md_allow : Gdk.Tags.modifier list } (** This type represents the different kinds of parameters. *) type parameter_kind = String_param of string string_param | List_param of (GData.tooltips -> ) | Filename_param of string string_param | Bool_param of bool_param | Text_param of string string_param | Combo_param of combo_param | Custom_param of custom_param | Color_param of color_param | Date_param of date_param | Font_param of font_param | Hotkey_param of hotkey_param | Modifiers_param of modifiers_param | Html_param of string string_param ;; (** This type represents the structure of the configuration window. *) type configuration_structure = | Section of string * GtkStock.id option * parameter_kind list (** label of the section, icon, parameters *) | Section_list of string * GtkStock.id option * configuration_structure list (** label of the section, list of the sub sections *) ;; (** To indicate what button was pushed by the user when the window is closed. *) type return_button = Return_apply (** The user clicked on Apply at least once before closing the window with Cancel or the window manager. *) | Return_ok (** The user closed the window with the ok button. *) | Return_cancel (** The user closed the window with the cancel button or the window manager but never clicked on the apply button.*) (** {2 Bindings in the html editor} *) type html_binding = { mutable html_key : (Gdk.Tags.modifier list * int) ; mutable html_begin : string ; mutable html_end : string ; } let htmlbinding_cp_wrapper = let w = Config_file.tuple3_wrappers key_cp_wrapper Config_file.string_wrappers Config_file.string_wrappers in { to_raw = (fun v -> w.to_raw (v.html_key, v.html_begin, v.html_end)) ; of_raw = (fun r -> let (k,b,e) = w.of_raw r in { html_key = k ; html_begin = b ; html_end = e } ) ; } class htmlbinding_cp = [html_binding] Config_file.option_cp htmlbinding_cp_wrapper coq-8.4pl4/ide/utils/configwin.mli0000644000175000017500000003355112326224777016231 0ustar stephsteph(*********************************************************************************) (* Cameleon *) (* *) (* Copyright (C) 2005 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. *) (* *) (* This program is free software; you can redistribute it and/or modify *) (* it under the terms of the GNU Library General Public License as *) (* published by the Free Software Foundation; either version 2 of the *) (* License, or any later version. *) (* *) (* This program is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Library General Public License for more details. *) (* *) (* You should have received a copy of the GNU Library General Public *) (* License along with this program; if not, write to the Free Software *) (* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) (* 02111-1307 USA *) (* *) (* Contact: Maxence.Guesdon@inria.fr *) (* *) (*********************************************************************************) (** This module is the interface of the Configwin library. *) (** {2 Types} *) (** This type represents the different kinds of parameters. *) type parameter_kind;; (** This type represents the structure of the configuration window. *) type configuration_structure = | Section of string * GtkStock.id option * parameter_kind list (** label of the section, icon, parameters *) | Section_list of string * GtkStock.id option * configuration_structure list (** label of the section, icon, list of the sub sections *) ;; (** To indicate what button pushed the user when the window is closed. *) type return_button = Return_apply (** The user clicked on Apply at least once before closing the window with Cancel or the window manager. *) | Return_ok (** The user closed the window with the ok button. *) | Return_cancel (** The user closed the window with the cancel button or the window manager but never clicked on the apply button.*) (** {2 The key option class (to use with the {!Config_file} library)} *) val string_to_key : string -> Gdk.Tags.modifier list * int val key_to_string : Gdk.Tags.modifier list * int -> string val key_cp_wrapper : (Gdk.Tags.modifier list * int) Config_file.wrappers class key_cp : ?group:Config_file.group -> string list -> ?short_name:string -> Gdk.Tags.modifier list * int -> string -> [Gdk.Tags.modifier list * int] Config_file.cp_custom_type (** {2 Functions to create parameters} *) (** [string label value] creates a string parameter. @param editable indicate if the value is editable (default is [true]). @param expand indicate if the entry widget must expand or not (default is [true]). @param help an optional help message. @param f the function called to apply the value (default function does nothing). *) val string : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: (string -> unit) -> string -> string -> parameter_kind (** [bool label value] creates a boolean parameter. @param editable indicate if the value is editable (default is [true]). @param help an optional help message. @param f the function called to apply the value (default function does nothing). *) val bool : ?editable: bool -> ?help: string -> ?f: (bool -> unit) -> string -> bool -> parameter_kind (** [strings label value] creates a string list parameter. @param editable indicate if the value is editable (default is [true]). @param help an optional help message. @param f the function called to apply the value (default function does nothing). @param add the function returning a list of strings when the user wants to add strings (default returns an empty list). @param eq the comparison function, used not to have doubles in list. Default is [Pervasives.(=)]. If you want to allow doubles in the list, give a function always returning false. *) val strings : ?editable: bool -> ?help: string -> ?f: (string list -> unit) -> ?eq: (string -> string -> bool) -> ?add: (unit -> string list) -> string -> string list -> parameter_kind (** [list label f_strings value] creates a list parameter. [f_strings] is a function taking a value and returning a list of strings to display it. The list length should be the same for any value, and the same as the titles list length. The [value] is the initial list. @param editable indicate if the value is editable (default is [true]). @param help an optional help message. @param f the function called to apply the value (default function does nothing). @param eq the comparison function, used not to have doubles in list. Default is [Pervasives.(=)]. If you want to allow doubles in the list, give a function always returning false. @param edit an optional function to use to edit an element of the list. The function returns an element, no matter if element was changed or not. When this function is given, a "Edit" button appears next to the list. @param add the function returning a list of values when the user wants to add values (default returns an empty list). @param titles an optional list of titles for the list. If the [f_strings] function returns a list with more than one element, then you must give a list of titles. @param color an optional function returning the optional color for a given element. This color is used to display the element in the list. The default function returns no color for any element. *) val list : ?editable: bool -> ?help: string -> ?f: ('a list -> unit) -> ?eq: ('a -> 'a -> bool) -> ?edit: ('a -> 'a) -> ?add: (unit -> 'a list) -> ?titles: string list -> ?color: ('a -> string option) -> string -> ('a -> string list) -> 'a list -> parameter_kind (** [color label value] creates a color parameter. @param editable indicate if the value is editable (default is [true]). @param expand indicate if the entry widget must expand or not (default is [true]). @param help an optional help message. @param f the function called to apply the value (default function does nothing). *) val color : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: (string -> unit) -> string -> string -> parameter_kind (** [font label value] creates a font parameter. @param editable indicate if the value is editable (default is [true]). @param expand indicate if the entry widget must expand or not (default is [true]). @param help an optional help message. @param f the function called to apply the value (default function does nothing). *) val font : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: (string -> unit) -> string -> string -> parameter_kind (** [combo label choices value] creates a combo parameter. @param editable indicate if the value is editable (default is [true]). @param expand indicate if the entry widget must expand or not (default is [true]). @param help an optional help message. @param f the function called to apply the value (default function does nothing). @param new_allowed indicate if a entry not in the list of choices is accepted (default is [false]). @param blank_allowed indicate if the empty selection [""] is accepted (default is [false]). *) val combo : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: (string -> unit) -> ?new_allowed: bool -> ?blank_allowed: bool -> string -> string list -> string -> parameter_kind (** [text label value] creates a text parameter. @param editable indicate if the value is editable (default is [true]). @param expand indicate if the box for the text must expand or not (default is [true]). @param help an optional help message. @param f the function called to apply the value (default function does nothing). *) val text : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: (string -> unit) -> string -> string -> parameter_kind (** Same as {!Configwin.text} but html bindings are available in the text widget. Use the [configwin_html_config] utility to edit your bindings. *) val html : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: (string -> unit) -> string -> string -> parameter_kind (** [filename label value] creates a filename parameter. @param editable indicate if the value is editable (default is [true]). @param expand indicate if the entry widget must expand or not (default is [true]). @param help an optional help message. @param f the function called to apply the value (default function does nothing). *) val filename : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: (string -> unit) -> string -> string -> parameter_kind (** [filenames label value] creates a filename list parameter. @param editable indicate if the value is editable (default is [true]). @param help an optional help message. @param f the function called to apply the value (default function does nothing). @param eq the comparison function, used not to have doubles in list. Default is [Pervasives.(=)]. If you want to allow doubles in the list, give a function always returning false. *) val filenames : ?editable: bool -> ?help: string -> ?f: (string list -> unit) -> ?eq: (string -> string -> bool) -> string -> string list -> parameter_kind (** [date label value] creates a date parameter. @param editable indicate if the value is editable (default is [true]). @param expand indicate if the entry widget must expand or not (default is [true]). @param help an optional help message. @param f the function called to apply the value (default function does nothing). @param f_string the function used to display the date as a string. The parameter is a tupe [(day,month,year)], where [month] is between [0] and [11]. The default function creates the string [year/month/day]. *) val date : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: ((int * int * int) -> unit) -> ?f_string: ((int * int * int -> string)) -> string -> (int * int * int) -> parameter_kind (** [hotkey label value] creates a hot key parameter. A hot key is defined by a list of modifiers and a key code. @param editable indicate if the value is editable (default is [true]). @param expand indicate if the entry widget must expand or not (default is [true]). @param help an optional help message. @param f the function called to apply the value (default function does nothing). *) val hotkey : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: ((Gdk.Tags.modifier list * int) -> unit) -> string -> (Gdk.Tags.modifier list * int) -> parameter_kind val modifiers : ?editable: bool -> ?expand: bool -> ?help: string -> ?allow:(Gdk.Tags.modifier list) -> ?f: (Gdk.Tags.modifier list -> unit) -> string -> Gdk.Tags.modifier list -> parameter_kind (** [custom box f expand] creates a custom parameter, with the given [box], the [f] function is called when the user wants to apply his changes, and [expand] indicates if the box must expand in its father. @param label if a value is specified, a the box is packed into a frame. *) val custom : ?label: string -> GPack.box -> (unit -> unit) -> bool -> parameter_kind (** {2 Functions creating configuration windows and boxes} *) (** This function takes a configuration structure and creates a window to configure the various parameters. @param apply this function is called when the apply button is clicked, after giving new values to parameters. *) val edit : ?apply: (unit -> unit) -> string -> ?width:int -> ?height:int -> configuration_structure list -> return_button (** This function takes a configuration structure and creates a window used to get the various parameters from the user. It is the same window as edit but there is no apply button.*) val get : string -> ?width:int -> ?height:int -> configuration_structure list -> return_button (** This function takes a list of parameter specifications and creates a window to configure the various parameters. @param apply this function is called when the apply button is clicked, after giving new values to parameters.*) val simple_edit : ?apply: (unit -> unit) -> string -> ?width:int -> ?height:int -> parameter_kind list -> return_button (** This function takes a list of parameter specifications and creates a window to configure the various parameters, without Apply button.*) val simple_get : string -> ?width:int -> ?height:int -> parameter_kind list -> return_button (** Create a [GPack.box] with the list of given parameters, Return the box and the function to call to apply new values to parameters. *) val box : parameter_kind list -> GData.tooltips -> GPack.box * (unit -> unit) (** Create a [GPack.box] with the list of given configuration structure list, and the given list of buttons (defined by their label and callback). Before calling the callback of a button, the [apply] function of each parameter is called. *) val tabbed_box : configuration_structure list -> (string * (unit -> unit)) list -> GData.tooltips -> GPack.box coq-8.4pl4/ide/utils/okey.ml0000644000175000017500000001423512326224777015042 0ustar stephsteph(*********************************************************************************) (* Cameleon *) (* *) (* Copyright (C) 2005 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. *) (* *) (* This program is free software; you can redistribute it and/or modify *) (* it under the terms of the GNU Library General Public License as *) (* published by the Free Software Foundation; either version 2 of the *) (* License, or any later version. *) (* *) (* This program is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Library General Public License for more details. *) (* *) (* You should have received a copy of the GNU Library General Public *) (* License along with this program; if not, write to the Free Software *) (* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) (* 02111-1307 USA *) (* *) (* Contact: Maxence.Guesdon@inria.fr *) (* *) (*********************************************************************************) type modifier = Gdk.Tags.modifier type handler = { cond : (unit -> bool) ; cback : (unit -> unit) ; } type handler_spec = int * int * Gdk.keysym (** mods * mask * key *) let int_of_modifier = function `SHIFT -> 1 | `LOCK -> 2 | `CONTROL -> 4 | `MOD1 -> 8 | `MOD2 -> 16 | `MOD3 -> 32 | `MOD4 -> 64 | `MOD5 -> 128 | `BUTTON1 -> 256 | `BUTTON2 -> 512 | `BUTTON3 -> 1024 | `BUTTON4 -> 2048 | `BUTTON5 -> 4096 | `HYPER -> 1 lsl 22 | `META -> 1 lsl 20 | `RELEASE -> 1 lsl 30 | `SUPER -> 1 lsl 21 let print_modifier l = List.iter (fun m -> print_string (((function `SHIFT -> "SHIFT" | `LOCK -> "LOCK" | `CONTROL -> "CONTROL" | `MOD1 -> "MOD1" | `MOD2 -> "MOD2" | `MOD3 -> "MOD3" | `MOD4 -> "MOD4" | `MOD5 -> "MOD5" | `BUTTON1 -> "B1" | `BUTTON2 -> "B2" | `BUTTON3 -> "B3" | `BUTTON4 -> "B4" | `BUTTON5 -> "B5" | `HYPER -> "HYPER" | `META -> "META" | `RELEASE -> "" | `SUPER -> "SUPER") m)^" ") ) l; print_newline () let int_of_modifiers l = List.fold_left (fun acc -> fun m -> acc + (int_of_modifier m)) 0 l module H = struct type t = handler_spec * handler let equal (m,k) (mods, mask, key) = (k = key) && ((m land mask) = mods) let filter_with_mask mods mask key l = List.filter (fun a -> (fst a) <> (mods, mask, key)) l let find_handlers mods key l = List.map snd (List.filter (fun ((m,ma,k),_) -> equal (mods,key) (m,ma,k)) l ) end let (table : (int, H.t list ref) Hashtbl.t) = Hashtbl.create 13 let key_press w ev = let key = GdkEvent.Key.keyval ev in let modifiers = GdkEvent.Key.state ev in try let (r : H.t list ref) = Hashtbl.find table (Oo.id w) in let l = H.find_handlers (int_of_modifiers modifiers) key !r in match l with [] -> false | _ -> List.iter (fun h -> if h.cond () then try h.cback () with e -> prerr_endline (Printexc.to_string e) else () ) l; true with Not_found -> false let associate_key_press w = ignore ((w#event#connect#key_press ~callback: (key_press w)) : GtkSignal.id) let default_modifiers = ref ([] : modifier list) let default_mask = ref ([`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK] : modifier list) let set_default_modifiers l = default_modifiers := l let set_default_mask l = default_mask := l let remove_widget (w : < event : GObj.event_ops ; ..>) () = try let r = Hashtbl.find table (Oo.id w) in r := [] with Not_found -> () let add1 ?(remove=false) w ?(cond=(fun () -> true)) ?(mods= !default_modifiers) ?(mask= !default_mask) k callback = let r = try Hashtbl.find table (Oo.id w) with Not_found -> let r = ref [] in Hashtbl.add table (Oo.id w) r; ignore (w#connect#destroy ~callback: (remove_widget w)); associate_key_press w; r in let n_mods = int_of_modifiers mods in let n_mask = lnot (int_of_modifiers mask) in let new_h = { cond = cond ; cback = callback } in if remove then ( let l = H.filter_with_mask n_mods n_mask k !r in r := ((n_mods, n_mask, k), new_h) :: l ) else r := ((n_mods, n_mask, k), new_h) :: !r let add w ?(cond=(fun () -> true)) ?(mods= !default_modifiers) ?(mask= !default_mask) k callback = add1 w ~cond ~mods ~mask k callback let add_list w ?(cond=(fun () -> true)) ?(mods= !default_modifiers) ?(mask= !default_mask) k_list callback = List.iter (fun k -> add w ~cond ~mods ~mask k callback) k_list let set w ?(cond=(fun () -> true)) ?(mods= !default_modifiers) ?(mask= !default_mask) k callback = add1 ~remove: true w ~cond ~mods ~mask k callback let set_list w ?(cond=(fun () -> true)) ?(mods= !default_modifiers) ?(mask= !default_mask) k_list callback = List.iter (fun k -> set w ~cond ~mods ~mask k callback) k_list coq-8.4pl4/ide/FAQ0000644000175000017500000000571412326224777012735 0ustar stephsteph CoqIde FAQ Q0) What is CoqIde? R0: A powerfull graphical interface for Coq. See http://coq.inria.fr. for more informations. Q1) How to enable Emacs keybindings? R1: Insert gtk-key-theme-name = "Emacs" in your "coqide-gtk2rc" file. It should be in $XDG_CONFIG_DIRS/coq dir. This is done by default. Q2) How to enable antialiased fonts? R2) Set the GDK_USE_XFT variable to 1. This is by default with Gtk >= 2.2. If some of your fonts are not available, set GDK_USE_XFT to 0. Q4) How to use those Forall and Exists pretty symbols? R4) Thanks to the Notation features in Coq, you just need to insert these lines in your Coq Buffer : ====================================================================== Notation "∀ x : t, P" := (forall x:t, P) (at level 200, x ident). Notation "∃ x : t, P" := (exists x:t, P) (at level 200, x ident). ====================================================================== Copy/Paste of these lines from this file will not work outside of CoqIde. You need to load a file containing these lines or to enter the "∀" using an input method (see Q5). To try it just use "Require utf8" from inside CoqIde. To enable these notations automatically start coqide with coqide -l utf8 In the ide subdir of Coq library, you will find a sample utf8.v with some pretty simple notations. Q5) How to define an input method for non ASCII symbols? R5)-First solution : type "2200" to enter a forall in the script widow. 2200 is the hexadecimal code for forall in unicode charts and is encoded as "∀" in UTF-8. 2203 is for exists. See http://www.unicode.org for more codes. -Second solution : rebind "a" to forall and "e" to exists. Under X11, you need to use something like xmodmap -e "keycode 24 = a A F13 F13" xmodmap -e "keycode 26 = e E F14 F14" and then to add bind "F13" {"insert-at-cursor" ("∀")} bind "F14" {"insert-at-cursor" ("∃")} to your "binding "text"" section in coqiderc-gtk2rc. The strange ("∀") argument is the UTF-8 encoding for 0x2200. You can compute these encodings using the lablgtk2 toplevel with Glib.Utf8.from_unichar 0x2200;; Further symbols can be bound on higher Fxx keys or on even on other keys you do not need . Q6) How to customize the shortcuts for menus? R6) Two solutions are offered: - Edit $XDG_CONFIG_HOME/coq/coqide.keys by hand or - Add "gtk-can-change-accels = 1" in your coqide-gtk2rc file. Then from CoqIde, you may select a menu entry and press the desired shortcut. Q7) What encoding should I use? What is this \x{iiii} in my file? R7) The encoding option is related to the way files are saved. Keep it as UTF-8 until it becomes important for you to exchange files with non UTF-8 aware applications. If you choose something else than UTF-8, then missing characters will be encoded by \x{....} or \x{........} where each dot is an hex. digit. The number between braces is the hexadecimal UNICODE index for the missing character. coq-8.4pl4/ide/preferences.mli0000644000175000017500000000512012326224777015376 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val load_pref : unit -> unit val current : pref ref val configure : ?apply:(unit -> unit) -> unit -> unit (* Hooks *) val refresh_font_hook : (unit -> unit) ref val refresh_background_color_hook : (unit -> unit) ref val refresh_toolbar_hook : (unit -> unit) ref val resize_window_hook : (unit -> unit) ref val refresh_tabs_hook : (unit -> unit) ref val use_default_doc_url : string coq-8.4pl4/ide/tags.mli0000644000175000017500000000264412326224777014043 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* "] will fail instead of returning only the A element. You can turn off this check by setting [check_eof] to [false] {i (by default, check_eof is true)}. *) val check_eof : t -> bool -> unit (** Once the parser is configurated, you can run the parser on a any kind of xml document source to parse its contents into an Xml data structure. *) val parse : t -> source -> xml coq-8.4pl4/lib/segmenttree.mli0000644000175000017500000000130212326224777015422 0ustar stephsteph(** This module is a very simple implementation of "segment trees". A segment tree of type ['a t] represents a mapping from a union of disjoint segments to some values of type 'a. *) (** A mapping from a union of disjoint segments to some values of type ['a]. *) type 'a t (** [make [(i1, j1), v1; (i2, j2), v2; ...]] creates a mapping that associates to every integer [x] the value [v1] if [i1 <= x <= j1], [v2] if [i2 <= x <= j2], and so one. Precondition: the segments must be sorted. *) val make : ((int * int) * 'a) list -> 'a t (** [lookup k t] looks for an image for key [k] in the interval tree [t]. Raise [Not_found] if it fails. *) val lookup : int -> 'a t -> 'a coq-8.4pl4/lib/tries.mli0000644000175000017500000000101312326224777014225 0ustar stephsteph module Make : functor (X : Set.OrderedType) -> functor (Y : Map.OrderedType) -> sig type t val empty : t (** Work on labels, not on paths. *) val map : t -> Y.t -> t val xtract : t -> X.t list val dom : t -> Y.t list val in_dom : t -> Y.t -> bool (** Work on paths, not on labels. *) val add : t -> Y.t list * X.t -> t val rmv : t -> Y.t list * X.t -> t val app : ((Y.t list * X.t) -> unit) -> t -> unit val to_list : t -> (Y.t list * X.t) list end coq-8.4pl4/lib/bigint.mli0000644000175000017500000000260512326224777014363 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bigint val to_string : bigint -> string val of_int : int -> bigint val to_int : bigint -> int (** May raise a Failure on oversized numbers *) val zero : bigint val one : bigint val two : bigint val div2_with_rest : bigint -> bigint * bool (** true=odd; false=even *) val add_1 : bigint -> bigint val sub_1 : bigint -> bigint val mult_2 : bigint -> bigint val add : bigint -> bigint -> bigint val sub : bigint -> bigint -> bigint val mult : bigint -> bigint -> bigint val euclid : bigint -> bigint -> bigint * bigint val less_than : bigint -> bigint -> bool val equal : bigint -> bigint -> bool val is_strictly_pos : bigint -> bool val is_strictly_neg : bigint -> bool val is_pos_or_zero : bigint -> bool val is_neg_or_zero : bigint -> bool val neg : bigint -> bigint val pow : bigint -> int -> bigint coq-8.4pl4/lib/xml_parser.ml0000644000175000017500000001511412326224777015111 0ustar stephsteph(* * Xml Light, an small Xml parser/printer with DTD support. * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com) * Copyright (C) 2003 Jacques Garrigue * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open Printf type xml = | Element of (string * (string * string) list * xml list) | PCData of string type error_pos = { eline : int; eline_start : int; emin : int; emax : int; } type error_msg = | UnterminatedComment | UnterminatedString | UnterminatedEntity | IdentExpected | CloseExpected | NodeExpected | AttributeNameExpected | AttributeValueExpected | EndOfTagExpected of string | EOFExpected | Empty type error = error_msg * error_pos exception Error of error exception File_not_found of string type t = { mutable check_eof : bool; mutable concat_pcdata : bool; } type source = | SFile of string | SChannel of in_channel | SString of string | SLexbuf of Lexing.lexbuf type state = { source : Lexing.lexbuf; stack : Xml_lexer.token Stack.t; xparser : t; } exception Internal_error of error_msg exception NoMoreData let xml_error = ref (fun _ -> assert false) let file_not_found = ref (fun _ -> assert false) let is_blank s = let len = String.length s in let break = ref true in let i = ref 0 in while !break && !i < len do let c = s.[!i] in (* no '\r' because we replaced them in the lexer *) if c = ' ' || c = '\n' || c = '\t' then incr i else break := false done; !i = len let _raises e f = xml_error := e; file_not_found := f let make () = { check_eof = true; concat_pcdata = true; } let check_eof p v = p.check_eof <- v let concat_pcdata p v = p.concat_pcdata <- v let pop s = try Stack.pop s.stack with Stack.Empty -> Xml_lexer.token s.source let push t s = Stack.push t s.stack let canonicalize l = let has_elt = List.exists (function Element _ -> true | _ -> false) l in if has_elt then List.filter (function PCData s -> not (is_blank s) | _ -> true) l else l let rec read_node s = match pop s with | Xml_lexer.PCData s -> PCData s | Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, []) | Xml_lexer.Tag (tag, attr, false) -> let elements = read_elems tag s in Element (tag, attr, canonicalize elements) | t -> push t s; raise NoMoreData and read_elems tag s = let elems = ref [] in (try while true do let node = read_node s in match node, !elems with | PCData c , (PCData c2) :: q -> elems := PCData (c2 ^ c) :: q | _, l -> elems := node :: l done with NoMoreData -> ()); match pop s with | Xml_lexer.Endtag s when s = tag -> List.rev !elems | t -> raise (Internal_error (EndOfTagExpected tag)) let rec read_xml s = let node = read_node s in match node with | Element _ -> node | PCData c -> if is_blank c then read_xml s else raise (Xml_lexer.Error Xml_lexer.ENodeExpected) let convert = function | Xml_lexer.EUnterminatedComment -> UnterminatedComment | Xml_lexer.EUnterminatedString -> UnterminatedString | Xml_lexer.EIdentExpected -> IdentExpected | Xml_lexer.ECloseExpected -> CloseExpected | Xml_lexer.ENodeExpected -> NodeExpected | Xml_lexer.EAttributeNameExpected -> AttributeNameExpected | Xml_lexer.EAttributeValueExpected -> AttributeValueExpected | Xml_lexer.EUnterminatedEntity -> UnterminatedEntity let error_of_exn stk = function | NoMoreData when Stack.pop stk = Xml_lexer.Eof -> Empty | NoMoreData -> NodeExpected | Internal_error e -> e | Xml_lexer.Error e -> convert e | e -> raise e let do_parse xparser source = let stk = Stack.create() in try Xml_lexer.init source; let s = { source = source; xparser = xparser; stack = stk } in let x = read_xml s in if xparser.check_eof && pop s <> Xml_lexer.Eof then raise (Internal_error EOFExpected); Xml_lexer.close source; x with e when e <> Sys.Break -> Xml_lexer.close source; raise (!xml_error (error_of_exn stk e) source) let parse p = function | SChannel ch -> do_parse p (Lexing.from_channel ch) | SString str -> do_parse p (Lexing.from_string str) | SLexbuf lex -> do_parse p lex | SFile fname -> let ch = (try open_in fname with Sys_error _ -> raise (!file_not_found fname)) in try let x = do_parse p (Lexing.from_channel ch) in close_in ch; x with reraise -> close_in ch; raise reraise let error_msg = function | UnterminatedComment -> "Unterminated comment" | UnterminatedString -> "Unterminated string" | UnterminatedEntity -> "Unterminated entity" | IdentExpected -> "Ident expected" | CloseExpected -> "Element close expected" | NodeExpected -> "Xml node expected" | AttributeNameExpected -> "Attribute name expected" | AttributeValueExpected -> "Attribute value expected" | EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag | EOFExpected -> "End of file expected" | Empty -> "Empty" let error (msg,pos) = if pos.emin = pos.emax then sprintf "%s line %d character %d" (error_msg msg) pos.eline (pos.emin - pos.eline_start) else sprintf "%s line %d characters %d-%d" (error_msg msg) pos.eline (pos.emin - pos.eline_start) (pos.emax - pos.eline_start) let line e = e.eline let range e = e.emin - e.eline_start , e.emax - e.eline_start let abs_range e = e.emin , e.emax let pos source = let line, lstart, min, max = Xml_lexer.pos source in { eline = line; eline_start = lstart; emin = min; emax = max; } let () = _raises (fun x p -> (* local cast : Xml.error_msg -> error_msg *) Error (x, pos p)) (fun f -> File_not_found f) coq-8.4pl4/lib/flags.mli0000644000175000017500000000535712326224777014212 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool val version_less_or_equal : compat_version -> bool val pr_version : compat_version -> string val beautify : bool ref val make_beautify : bool -> unit val do_beautify : unit -> bool val beautify_file : bool ref val make_silent : bool -> unit val is_silent : unit -> bool val is_verbose : unit -> bool val silently : ('a -> 'b) -> 'a -> 'b val verbosely : ('a -> 'b) -> 'a -> 'b val if_silent : ('a -> unit) -> 'a -> unit val if_verbose : ('a -> unit) -> 'a -> unit val make_auto_intros : bool -> unit val is_auto_intros : unit -> bool val make_warn : bool -> unit val if_warn : ('a -> unit) -> 'a -> unit val hash_cons_proofs : bool ref (** Temporary activate an option (to activate option [o] on [f x y z], use [with_option o (f x y) z]) *) val with_option : bool ref -> ('a -> 'b) -> 'a -> 'b (** Temporary deactivate an option *) val without_option : bool ref -> ('a -> 'b) -> 'a -> 'b (** If [None], no limit *) val set_print_hyps_limit : int option -> unit val print_hyps_limit : unit -> int option val add_unsafe : string -> unit val is_unsafe : string -> bool (** Options for external tools *) (** Returns string format for default browser to use from Coq or CoqIDE *) val browser_cmd_fmt : string val is_standard_doc_url : string -> bool (** Substitute %s in the first chain by the second chain *) val subst_command_placeholder : string -> string -> string (** Options for specifying where coq librairies reside *) val coqlib_spec : bool ref val coqlib : string ref (** Options for specifying where OCaml binaries reside *) val camlbin_spec : bool ref val camlbin : string ref val camlp4bin_spec : bool ref val camlp4bin : string ref (** Level of inlining during a functor application *) val set_inline_level : int -> unit val get_inline_level : unit -> int val default_inline_level : int coq-8.4pl4/lib/unionfind.mli0000644000175000017500000000363712326224777015106 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t (** Add (in place) an element in the partition, or do nothing if the element is already in the partition. *) val add : elt -> t -> unit (** Find the canonical representative of an element. Raise [not_found] if the element isn't known yet. *) val find : elt -> t -> elt (** Merge (in place) the equivalence classes of two elements. This will add the elements in the partition if necessary. *) val union : elt -> elt -> t -> unit (** Merge (in place) the equivalence classes of many elements. *) val union_set : set -> t -> unit (** Listing the different components of the partition *) val partition : t -> set list end module Make : functor (S:Set.S) -> functor (M:Map.S with type key = S.elt) -> PartitionSig with type elt = S.elt and type set = S.t coq-8.4pl4/lib/bigint.ml0000644000175000017500000003712612326224777014220 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let rec aux j l n = if j=size then l else aux (j+1) (string_of_int (n mod 10) :: l) (n/10) in String.concat "" (aux 0 [] n) (* The base is 10^size *) let base = let rec exp10 = function 0 -> 1 | n -> 10 * exp10 (n-1) in exp10 size (******************************************************************) (* First, we represent all numbers by int arrays. Later, we will optimize the particular case of small integers *) (******************************************************************) module ArrayInt = struct (* Basic numbers *) let zero = [||] let neg_one = [|-1|] (* An array is canonical when - it is empty - it is [|-1|] - its first bloc is in [-base;-1[U]0;base[ and the other blocs are in [0;base[. *) let canonical n = let ok x = (0 <= x && x < base) in let rec ok_tail k = (k = 0) || (ok n.(k) && ok_tail (k-1)) in let ok_init x = (-base <= x && x < base && x <> -1 && x <> 0) in (n = [||]) || (n = [|-1|]) || (ok_init n.(0) && ok_tail (Array.length n - 1)) (* [normalize_pos] : removing initial blocks of 0 *) let normalize_pos n = let k = ref 0 in while !k < Array.length n & n.(!k) = 0 do incr k done; Array.sub n !k (Array.length n - !k) (* [normalize_neg] : avoid (-1) as first bloc. input: an array with -1 as first bloc and other blocs in [0;base[ output: a canonical array *) let normalize_neg n = let k = ref 1 in while !k < Array.length n & n.(!k) = base - 1 do incr k done; let n' = Array.sub n !k (Array.length n - !k) in if Array.length n' = 0 then [|-1|] else (n'.(0) <- n'.(0) - base; n') (* [normalize] : avoid 0 and (-1) as first bloc. input: an array with first bloc in [-base;base[ and others in [0;base[ output: a canonical array *) let rec normalize n = if Array.length n = 0 then n else if n.(0) = -1 then normalize_neg n else if n.(0) = 0 then normalize_pos n else n (* Opposite (expects and returns canonical arrays) *) let neg m = if m = zero then zero else let n = Array.copy m in let i = ref (Array.length m - 1) in while !i > 0 & n.(!i) = 0 do decr i done; if !i = 0 then begin n.(0) <- - n.(0); (* n.(0) cannot be 0 since m is canonical *) if n.(0) = -1 then normalize_neg n else if n.(0) = base then (n.(0) <- 0; Array.append [| 1 |] n) else n end else begin (* here n.(!i) <> 0, hence 0 < base - n.(!i) < base for n canonical *) n.(!i) <- base - n.(!i); decr i; while !i > 0 do n.(!i) <- base - 1 - n.(!i); decr i done; (* since -base <= n.(0) <= base-1, hence -base <= -n.(0)-1 <= base-1 *) n.(0) <- - n.(0) - 1; (* since m is canonical, m.(0)<>0 hence n.(0)<>-1, and m=-1 is already handled above, so here m.(0)<>-1 hence n.(0)<>0 *) n end let push_carry r j = let j = ref j in while !j > 0 & r.(!j) < 0 do r.(!j) <- r.(!j) + base; decr j; r.(!j) <- r.(!j) - 1 done; while !j > 0 & r.(!j) >= base do r.(!j) <- r.(!j) - base; decr j; r.(!j) <- r.(!j) + 1 done; (* here r.(0) could be in [-2*base;2*base-1] *) if r.(0) >= base then (r.(0) <- r.(0) - base; Array.append [| 1 |] r) else if r.(0) < -base then (r.(0) <- r.(0) + 2*base; Array.append [| -2 |] r) else normalize r (* in case r.(0) is 0 or -1 *) let add_to r a j = if a = zero then r else begin for i = Array.length r - 1 downto j+1 do r.(i) <- r.(i) + a.(i-j); if r.(i) >= base then (r.(i) <- r.(i) - base; r.(i-1) <- r.(i-1) + 1) done; r.(j) <- r.(j) + a.(0); push_carry r j end let add n m = let d = Array.length n - Array.length m in if d > 0 then add_to (Array.copy n) m d else add_to (Array.copy m) n (-d) let sub_to r a j = if a = zero then r else begin for i = Array.length r - 1 downto j+1 do r.(i) <- r.(i) - a.(i-j); if r.(i) < 0 then (r.(i) <- r.(i) + base; r.(i-1) <- r.(i-1) - 1) done; r.(j) <- r.(j) - a.(0); push_carry r j end let sub n m = let d = Array.length n - Array.length m in if d >= 0 then sub_to (Array.copy n) m d else let r = neg m in add_to r n (Array.length r - Array.length n) let rec mult m n = if m = zero or n = zero then zero else let l = Array.length m + Array.length n in let r = Array.create l 0 in for i = Array.length m - 1 downto 0 do for j = Array.length n - 1 downto 0 do let p = m.(i) * n.(j) + r.(i+j+1) in let (q,s) = if p < 0 then (p + 1) / base - 1, (p + 1) mod base + base - 1 else p / base, p mod base in r.(i+j+1) <- s; if q <> 0 then r.(i+j) <- r.(i+j) + q; done done; normalize r (* Comparisons *) let is_strictly_neg n = n<>[||] && n.(0) < 0 let is_strictly_pos n = n<>[||] && n.(0) > 0 let is_neg_or_zero n = n=[||] or n.(0) < 0 let is_pos_or_zero n = n=[||] or n.(0) > 0 let rec less_than_same_size m n i j = i < Array.length m && (m.(i) < n.(j) or (m.(i) = n.(j) && less_than_same_size m n (i+1) (j+1))) let less_than m n = if is_strictly_neg m then is_pos_or_zero n or Array.length m > Array.length n or (Array.length m = Array.length n && less_than_same_size m n 0 0) else is_strictly_pos n && (Array.length m < Array.length n or (Array.length m = Array.length n && less_than_same_size m n 0 0)) (* For this equality test it is critical that n and m are canonical *) let equal m n = (m = n) let less_than_shift_pos k m n = (Array.length m - k < Array.length n) or (Array.length m - k = Array.length n && less_than_same_size m n k 0) let rec can_divide k m d i = (i = Array.length d) or (m.(k+i) > d.(i)) or (m.(k+i) = d.(i) && can_divide k m d (i+1)) (* For two big nums m and d and a small number q, computes m - d * q * base^(|m|-|d|-k) in-place (in m). Both m d and q are positive. *) let sub_mult m d q k = if q <> 0 then for i = Array.length d - 1 downto 0 do let v = d.(i) * q in m.(k+i) <- m.(k+i) - v mod base; if m.(k+i) < 0 then (m.(k+i) <- m.(k+i) + base; m.(k+i-1) <- m.(k+i-1) -1); if v >= base then begin m.(k+i-1) <- m.(k+i-1) - v / base; let j = ref (i-1) in while m.(k + !j) < 0 do (* result is positive, hence !j remains >= 0 *) m.(k + !j) <- m.(k + !j) + base; decr j; m.(k + !j) <- m.(k + !j) -1 done end done (** Euclid division m/d = (q,r) This is the "Floor" variant, as with ocaml's / (but not as ocaml's Big_int.quomod_big_int). We have sign r = sign m *) let euclid m d = let isnegm, m = if is_strictly_neg m then (-1),neg m else 1,Array.copy m in let isnegd, d = if is_strictly_neg d then (-1),neg d else 1,d in if d = zero then raise Division_by_zero; let q,r = if less_than m d then (zero,m) else let ql = Array.length m - Array.length d in let q = Array.create (ql+1) 0 in let i = ref 0 in while not (less_than_shift_pos !i m d) do if m.(!i)=0 then incr i else if can_divide !i m d 0 then begin let v = if Array.length d > 1 && d.(0) <> m.(!i) then (m.(!i) * base + m.(!i+1)) / (d.(0) * base + d.(1) + 1) else m.(!i) / d.(0) in q.(!i) <- q.(!i) + v; sub_mult m d v !i end else begin let v = (m.(!i) * base + m.(!i+1)) / (d.(0) + 1) in q.(!i) <- q.(!i) + v / base; sub_mult m d (v / base) !i; q.(!i+1) <- q.(!i+1) + v mod base; if q.(!i+1) >= base then (q.(!i+1) <- q.(!i+1)-base; q.(!i) <- q.(!i)+1); sub_mult m d (v mod base) (!i+1) end done; (normalize q, normalize m) in (if isnegd * isnegm = -1 then neg q else q), (if isnegm = -1 then neg r else r) (* Parsing/printing ordinary 10-based numbers *) let of_string s = let len = String.length s in let isneg = len > 1 & s.[0] = '-' in let d = ref (if isneg then 1 else 0) in while !d < len && s.[!d] = '0' do incr d done; if !d = len then zero else let r = (len - !d) mod size in let h = String.sub s (!d) r in let e = if h<>"" then 1 else 0 in let l = (len - !d) / size in let a = Array.create (l + e) 0 in if e=1 then a.(0) <- int_of_string h; for i=1 to l do a.(i+e-1) <- int_of_string (String.sub s ((i-1)*size + !d + r) size) done; if isneg then neg a else a let to_string_pos sgn n = if Array.length n = 0 then "0" else sgn ^ String.concat "" (string_of_int n.(0) :: List.map format_size (List.tl (Array.to_list n))) let to_string n = if is_strictly_neg n then to_string_pos "-" (neg n) else to_string_pos "" n end (******************************************************************) (* Optimized operations on (unbounded) integer numbers *) (* integers smaller than base are represented as machine integers *) (******************************************************************) open ArrayInt type bigint = Obj.t (* Since base is the largest power of 10 such that base*base <= max_int, we have max_int < 100*base*base : any int can be represented by at most three blocs *) let small n = (-base <= n) && (n < base) let mkarray n = (* n isn't small, this case is handled separately below *) let lo = n mod base and hi = n / base in let t = if small hi then [|hi;lo|] else [|hi/base;hi mod base;lo|] in for i = Array.length t -1 downto 1 do if t.(i) < 0 then (t.(i) <- t.(i) + base; t.(i-1) <- t.(i-1) -1) done; t let ints_of_int n = if n = 0 then [| |] else if small n then [| n |] else mkarray n let of_int n = if small n then Obj.repr n else Obj.repr (mkarray n) let of_ints n = let n = normalize n in (* TODO: using normalize here seems redundant now *) if n = zero then Obj.repr 0 else if Array.length n = 1 then Obj.repr n.(0) else Obj.repr n let coerce_to_int = (Obj.magic : Obj.t -> int) let coerce_to_ints = (Obj.magic : Obj.t -> int array) let to_ints n = if Obj.is_int n then ints_of_int (coerce_to_int n) else coerce_to_ints n let int_of_ints = let maxi = mkarray max_int and mini = mkarray min_int in fun t -> let l = Array.length t in if (l > 3) || (l = 3 && (less_than maxi t || less_than t mini)) then failwith "Bigint.to_int: too large"; let sum = ref 0 in let pow = ref 1 in for i = l-1 downto 0 do sum := !sum + t.(i) * !pow; pow := !pow*base; done; !sum let to_int n = if Obj.is_int n then coerce_to_int n else int_of_ints (coerce_to_ints n) let app_pair f (m, n) = (f m, f n) let add m n = if Obj.is_int m & Obj.is_int n then of_int (coerce_to_int m + coerce_to_int n) else of_ints (add (to_ints m) (to_ints n)) let sub m n = if Obj.is_int m & Obj.is_int n then of_int (coerce_to_int m - coerce_to_int n) else of_ints (sub (to_ints m) (to_ints n)) let mult m n = if Obj.is_int m & Obj.is_int n then of_int (coerce_to_int m * coerce_to_int n) else of_ints (mult (to_ints m) (to_ints n)) let euclid m n = if Obj.is_int m & Obj.is_int n then app_pair of_int (coerce_to_int m / coerce_to_int n, coerce_to_int m mod coerce_to_int n) else app_pair of_ints (euclid (to_ints m) (to_ints n)) let less_than m n = if Obj.is_int m & Obj.is_int n then coerce_to_int m < coerce_to_int n else less_than (to_ints m) (to_ints n) let neg n = if Obj.is_int n then of_int (- (coerce_to_int n)) else of_ints (neg (to_ints n)) let of_string m = of_ints (of_string m) let to_string m = to_string (to_ints m) let zero = of_int 0 let one = of_int 1 let two = of_int 2 let sub_1 n = sub n one let add_1 n = add n one let mult_2 n = add n n let div2_with_rest n = let (q,b) = euclid n two in (q, b = one) let is_strictly_neg n = is_strictly_neg (to_ints n) let is_strictly_pos n = is_strictly_pos (to_ints n) let is_neg_or_zero n = is_neg_or_zero (to_ints n) let is_pos_or_zero n = is_pos_or_zero (to_ints n) let equal m n = (m = n) (* spiwack: computes n^m *) (* The basic idea of the algorithm is that n^(2m) = (n^2)^m *) (* In practice the algorithm performs : k*n^0 = k k*n^(2m) = k*(n*n)^m k*n^(2m+1) = (n*k)*(n*n)^m *) let pow = let rec pow_aux odd_rest n m = (* odd_rest is the k from above *) if m<=0 then odd_rest else let quo = m lsr 1 (* i.e. m/2 *) and odd = (m land 1) <> 0 in pow_aux (if odd then mult n odd_rest else odd_rest) (mult n n) quo in pow_aux one (** Testing suite w.r.t. OCaml's Big_int *) (* module B = struct open Big_int let zero = zero_big_int let to_string = string_of_big_int let of_string = big_int_of_string let add = add_big_int let opp = minus_big_int let sub = sub_big_int let mul = mult_big_int let abs = abs_big_int let sign = sign_big_int let euclid n m = let n' = abs n and m' = abs m in let q',r' = quomod_big_int n' m' in (if sign (mul n m) < 0 && sign q' <> 0 then opp q' else q'), (if sign n < 0 then opp r' else r') end let check () = let roots = [ 1; 100; base; 100*base; base*base ] in let rands = [ 1234; 5678; 12345678; 987654321 ] in let nums = (List.flatten (List.map (fun x -> [x-1;x;x+1]) roots)) @ rands in let numbers = List.map string_of_int nums @ List.map (fun n -> string_of_int (-n)) nums in let i = ref 0 in let compare op x y n n' = incr i; let s = Printf.sprintf "%30s" (to_string n) in let s' = Printf.sprintf "%30s" (B.to_string n') in if s <> s' then Printf.printf "%s%s%s: %s <> %s\n" x op y s s' in let test x y = let n = of_string x and m = of_string y in let n' = B.of_string x and m' = B.of_string y in let a = add n m and a' = B.add n' m' in let s = sub n m and s' = B.sub n' m' in let p = mult n m and p' = B.mul n' m' in let q,r = try euclid n m with Division_by_zero -> zero,zero and q',r' = try B.euclid n' m' with Division_by_zero -> B.zero, B.zero in compare "+" x y a a'; compare "-" x y s s'; compare "*" x y p p'; compare "/" x y q q'; compare "%" x y r r' in List.iter (fun a -> List.iter (test a) numbers) numbers; Printf.printf "%i tests done\n" !i *) coq-8.4pl4/lib/envars.ml0000644000175000017500000001036612326224777014237 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let coqlib = match Coq_config.coqlib with | Some coqlib -> coqlib | None -> coqroot in if Sys.file_exists (coqlib//file) then coqlib else Util.error "cannot guess a path for Coq libraries; please use -coqlib option") let coqlib () = if !Flags.coqlib_spec then !Flags.coqlib else (if !Flags.boot then coqroot else guess_coqlib ()) let docdir () = reldir (if Coq_config.arch = "win32" then ["doc"] else ["share";"doc";"coq"]) "html" (fun () -> Coq_config.docdir) let path_to_list p = let sep = if Sys.os_type = "Win32" then ';' else ':' in Util.split_string_at sep p let xdg_data_home = (System.getenv_else "XDG_DATA_HOME" (System.home//".local/share"))//"coq" let xdg_config_home = (System.getenv_else "XDG_CONFIG_HOME" (System.home//".config"))//"coq" let xdg_data_dirs = (try List.map (fun dir -> dir//"coq") (path_to_list (Sys.getenv "XDG_DATA_DIRS")) with Not_found -> ["/usr/local/share/coq";"/usr/share/coq"]) @ (match Coq_config.datadir with |None -> [] |Some datadir -> [datadir]) let xdg_dirs = let dirs = xdg_data_home :: xdg_data_dirs in List.rev (List.filter Sys.file_exists dirs) let coqpath = try let path = Sys.getenv "COQPATH" in List.rev (List.filter Sys.file_exists (path_to_list path)) with Not_found -> [] let rec which l f = match l with | [] -> raise Not_found | p :: tl -> if Sys.file_exists (p//f) then p else which tl f let guess_camlbin () = let path = Sys.getenv "PATH" in (* may raise Not_found *) let lpath = path_to_list path in which lpath (exe "ocamlc") let guess_camlp4bin () = let path = Sys.getenv "PATH" in (* may raise Not_found *) let lpath = path_to_list path in which lpath (exe Coq_config.camlp4) let camlbin () = if !Flags.camlbin_spec then !Flags.camlbin else if !Flags.boot then Coq_config.camlbin else try guess_camlbin () with e when e <> Sys.Break -> Coq_config.camlbin let camllib () = if !Flags.boot then Coq_config.camllib else let camlbin = camlbin () in let com = (camlbin//"ocamlc") ^ " -where" in let _,res = System.run_command (fun x -> x) (fun _ -> ()) com in Util.strip res let camlp4bin () = if !Flags.camlp4bin_spec then !Flags.camlp4bin else if !Flags.boot then Coq_config.camlp4bin else try guess_camlp4bin () with e when e <> Sys.Break -> let cb = camlbin () in if Sys.file_exists (cb//(exe Coq_config.camlp4)) then cb else Coq_config.camlp4bin let camlp4lib () = if !Flags.boot then Coq_config.camlp4lib else let camlp4bin = camlp4bin () in let com = (camlp4bin//Coq_config.camlp4) ^ " -where" in let ex,res = System.run_command (fun x -> x) (fun _ -> ()) com in match ex with |Unix.WEXITED 0 -> Util.strip res |_ -> "/dev/null" coq-8.4pl4/lib/xml_lexer.mli0000644000175000017500000000256112326224777015107 0ustar stephsteph(* * Xml Light, an small Xml parser/printer with DTD support. * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com) * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) type error = | EUnterminatedComment | EUnterminatedString | EIdentExpected | ECloseExpected | ENodeExpected | EAttributeNameExpected | EAttributeValueExpected | EUnterminatedEntity exception Error of error type token = | Tag of string * (string * string) list * bool | PCData of string | Endtag of string | Eof type pos = int * int * int * int val init : Lexing.lexbuf -> unit val close : Lexing.lexbuf -> unit val token : Lexing.lexbuf -> token val pos : Lexing.lexbuf -> pos val restore : pos -> unitcoq-8.4pl4/lib/gmap.ml0000644000175000017500000001063112326224777013660 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | _ -> false let height = function Empty -> 0 | Node(_,_,_,_,h) -> h let create l x d r = let hl = height l and hr = height r in Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) let bal l x d r = let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in if hl > hr + 2 then begin match l with Empty -> invalid_arg "Map.bal" | Node(ll, lv, ld, lr, _) -> if height ll >= height lr then create ll lv ld (create lr x d r) else begin match lr with Empty -> invalid_arg "Map.bal" | Node(lrl, lrv, lrd, lrr, _)-> create (create ll lv ld lrl) lrv lrd (create lrr x d r) end end else if hr > hl + 2 then begin match r with Empty -> invalid_arg "Map.bal" | Node(rl, rv, rd, rr, _) -> if height rr >= height rl then create (create l x d rl) rv rd rr else begin match rl with Empty -> invalid_arg "Map.bal" | Node(rll, rlv, rld, rlr, _) -> create (create l x d rll) rlv rld (create rlr rv rd rr) end end else Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) let rec add x data = function Empty -> Node(Empty, x, data, Empty, 1) | Node(l, v, d, r, h) -> let c = Pervasives.compare x v in if c = 0 then Node(l, x, data, r, h) else if c < 0 then bal (add x data l) v d r else bal l v d (add x data r) let rec find x = function Empty -> raise Not_found | Node(l, v, d, r, _) -> let c = Pervasives.compare x v in if c = 0 then d else find x (if c < 0 then l else r) let rec mem x = function Empty -> false | Node(l, v, d, r, _) -> let c = Pervasives.compare x v in c = 0 || mem x (if c < 0 then l else r) let rec min_binding = function Empty -> raise Not_found | Node(Empty, x, d, r, _) -> (x, d) | Node(l, x, d, r, _) -> min_binding l let rec remove_min_binding = function Empty -> invalid_arg "Map.remove_min_elt" | Node(Empty, x, d, r, _) -> r | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r let merge t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (_, _) -> let (x, d) = min_binding t2 in bal t1 x d (remove_min_binding t2) let rec remove x = function Empty -> Empty | Node(l, v, d, r, h) -> let c = Pervasives.compare x v in if c = 0 then merge l r else if c < 0 then bal (remove x l) v d r else bal l v d (remove x r) let rec iter f = function Empty -> () | Node(l, v, d, r, _) -> iter f l; f v d; iter f r let rec map f = function Empty -> Empty | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h) (* Maintien de fold_right par compatibilité (changé en fold_left dans ocaml-3.09.0) *) let rec fold f m accu = match m with Empty -> accu | Node(l, v, d, r, _) -> fold f l (f v d (fold f r accu)) (* Added with respect to ocaml standard library. *) let dom m = fold (fun x _ acc -> x::acc) m [] let rng m = fold (fun _ y acc -> y::acc) m [] let to_list m = fold (fun x y acc -> (x,y)::acc) m [] coq-8.4pl4/lib/fmap.mli0000644000175000017500000000104712326224777014031 0ustar stephsteph module Make : functor (X : Map.OrderedType) -> sig type key = X.t type 'a t val empty : 'a t val is_empty : 'a t -> bool val add : key -> 'a -> 'a t -> 'a t val find : key -> 'a t -> 'a val remove : key -> 'a t -> 'a t val mem : key -> 'a t -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val map : ('a -> 'b) -> 'a t -> 'b t val fold : (key -> 'a -> 'c -> 'c) -> 'a t -> 'c -> 'c (** Additions with respect to ocaml standard library. *) val dom : 'a t -> key list val rng : 'a t -> 'a list val to_list : 'a t -> (key * 'a) list end coq-8.4pl4/lib/pp_control.ml0000644000175000017500000000514012326224777015112 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* pp_global_params -> unit * set the parameters of a formatter *) let set_gp ft gp = Format.pp_set_margin ft gp.margin ; Format.pp_set_max_indent ft gp.max_indent ; Format.pp_set_max_boxes ft gp.max_depth ; Format.pp_set_ellipsis_text ft gp.ellipsis let set_dflt_gp ft = set_gp ft dflt_gp let get_gp ft = { margin = Format.pp_get_margin ft (); max_indent = Format.pp_get_max_indent ft (); max_depth = Format.pp_get_max_boxes ft (); ellipsis = Format.pp_get_ellipsis_text ft () } (* with_fp : 'a pp_formatter_params -> Format.formatter * returns of formatter for given formatter functions *) let with_fp chan out_function flush_function = let ft = Format.make_formatter out_function flush_function in Format.pp_set_formatter_out_channel ft chan; ft (* Output on a channel ch *) let with_output_to ch = let ft = with_fp ch (output ch) (fun () -> flush ch) in set_gp ft deep_gp; ft let std_ft = ref Format.std_formatter let _ = set_dflt_gp !std_ft let err_ft = ref Format.err_formatter let _ = set_gp !err_ft deep_gp let deep_ft = ref (with_output_to stdout) let _ = set_gp !deep_ft deep_gp (* For parametrization through vernacular *) let default = Format.pp_get_max_boxes !std_ft () let default_margin = Format.pp_get_margin !std_ft () let get_depth_boxes () = Some (Format.pp_get_max_boxes !std_ft ()) let set_depth_boxes v = Format.pp_set_max_boxes !std_ft (match v with None -> default | Some v -> v) let get_margin () = Some (Format.pp_get_margin !std_ft ()) let set_margin v = let v = match v with None -> default_margin | Some v -> v in Format.pp_set_margin !std_ft v; Format.pp_set_margin !deep_ft v coq-8.4pl4/lib/profile.ml0000644000175000017500000005667112326224777014412 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* e::l let magic = 1249 let merge_profile filename (curr_table, curr_outside, curr_total as new_data) = let (old_table, old_outside, old_total) = try let c = open_in filename in if input_binary_int c <> magic then Printf.printf "Incompatible recording file: %s\n" filename; let old_data = input_value c in close_in c; old_data with Sys_error msg -> (Printf.printf "Unable to open %s: %s\n" filename msg; new_data) in let updated_data = let updated_table = List.fold_right ajoute_to_list curr_table old_table in ajoute curr_outside old_outside; ajoute curr_total old_total; (updated_table, old_outside, old_total) in begin (try let c = open_out_gen [Open_creat;Open_wronly;Open_trunc;Open_binary] 0o644 filename in output_binary_int c magic; output_value c updated_data; close_out c with Sys_error _ -> Printf.printf "Unable to create recording file"); updated_data end (************************************************) (* Compute a rough estimation of time overheads *) (* Time and space are not measured in the same way *) (* Byte allocation is an exact number and for long runs, the total number of allocated bytes may exceed the maximum integer capacity (2^31 on 32-bits architectures); therefore, allocation is measured by small steps, total allocations are computed by adding elementary measures and carries are controled from step to step *) (* Unix measure of time is approximative and shoitt delays are often unperceivable; therefore, total times are measured in one (big) step to avoid rounding errors and to get the best possible approximation. Note: Sys.time is the same as: Unix.(let x = times () in x.tms_utime +. x.tms_stime) *) (* ---------- start profile for f1 overheadA| ... ---------- [1w1] 1st call to get_time for f1 overheadB| ... ---------- start f1 real 1 | ... ---------- start profile for 1st call to f2 inside f1 overheadA| ... ---------- [2w1] 1st call to get_time for 1st f2 overheadB| ... ---------- start 1st f2 real 2 | ... ---------- end 1st f2 overheadC| ... ---------- [2w1] 2nd call to get_time for 1st f2 overheadD| ... ---------- end profile for 1st f2 real 1 | ... ---------- start profile for 2nd call to f2 inside f1 overheadA| ... ---------- [2'w1] 1st call to get_time for 2nd f2 overheadB| ... ---------- start 2nd f2 real 2' | ... ---------- end 2nd f2 overheadC| ... ---------- [2'w2] 2nd call to get_time for 2nd f2 overheadD| ... ---------- end profile for f2 real 1 | ... ---------- end f1 overheadC| ... ---------- [1w1'] 2nd call to get_time for f1 overheadD| ... ---------- end profile for f1 When profiling f2, overheadB + overheadC should be subtracted from measure and overheadA + overheadB + overheadC + overheadD should be subtracted from the amount for f1 Then the relevant overheads are : "overheadB + overheadC" to be subtracted to the measure of f as many time as f is called and "overheadA + overheadB + overheadC + overheadD" to be subtracted to the measure of f as many time as f calls a profiled function (itself included) *) let dummy_last_alloc = ref 0.0 let dummy_spent_alloc () = let now = get_alloc () in let before = !last_alloc in last_alloc := now; now -. before let dummy_f x = x let dummy_stack = ref [create_record ()] let dummy_ov = 0 let loops = 10000 let time_overhead_A_D () = let e = create_record () in let before = get_time () in for i=1 to loops do (* This is a copy of profile1 for overhead estimation *) let dw = dummy_spent_alloc () in match !dummy_stack with [] -> assert false | p::_ -> ajoute_ownalloc p dw; ajoute_totalloc p dw; e.owncount <- e.owncount + 1; if not (p==e) then stack := e::!stack; let totalloc0 = e.totalloc in let intcount0 = e.intcount in let dt = get_time () - 1 in e.tottime <- dt + dummy_ov; e.owntime <- e.owntime + e.tottime; ajoute_ownalloc p dw; ajoute_totalloc p dw; p.owntime <- p.owntime - e.tottime; ajoute_totalloc p (e.totalloc-.totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; if not (p==e) then (match !dummy_stack with [] -> assert false | _::s -> stack := s); dummy_last_alloc := get_alloc () done; let after = get_time () in let beforeloop = get_time () in for i=1 to loops do () done; let afterloop = get_time () in float_of_int ((after - before) - (afterloop - beforeloop)) /. float_of_int loops let time_overhead_B_C () = let dummy_x = 0 in let before = get_time () in for i=1 to loops do try dummy_last_alloc := get_alloc (); let _r = dummy_f dummy_x in let _dw = dummy_spent_alloc () in let _dt = get_time () in () with e when e <> Sys.Break -> assert false done; let after = get_time () in let beforeloop = get_time () in for i=1 to loops do () done; let afterloop = get_time () in float_of_int ((after - before) - (afterloop - beforeloop)) /. float_of_int loops let compute_alloc lo = lo /. (float_of_int word_length) (************************************************) (* End a profiling session and print the result *) let format_profile (table, outside, total) = print_newline (); Printf.printf "%-23s %9s %9s %10s %10s %10s\n" "Function name" "Own time" "Tot. time" "Own alloc" "Tot. alloc" "Calls "; let l = Sort.list (fun (_,{tottime=p}) (_,{tottime=p'}) -> p > p') table in List.iter (fun (name,e) -> Printf.printf "%-23s %9.2f %9.2f %10.0f %10.0f %6d %6d\n" name (float_of_time e.owntime) (float_of_time e.tottime) (compute_alloc e.ownalloc) (compute_alloc e.totalloc) e.owncount e.intcount) l; Printf.printf "%-23s %9.2f %9.2f %10.0f %10.0f %6d\n" "others" (float_of_time outside.owntime) (float_of_time outside.tottime) (compute_alloc outside.ownalloc) (compute_alloc outside.totalloc) outside.intcount; (* Here, own contains overhead time/alloc *) Printf.printf "%-23s %9.2f %9.2f %10.0f %10.0f\n" "Est. overhead/total" (float_of_time total.owntime) (float_of_time total.tottime) (compute_alloc total.ownalloc) (compute_alloc total.totalloc); Printf.printf "Time in seconds and allocation in words (1 word = %d bytes)\n" word_length let recording_file = ref "" let set_recording s = recording_file := s let adjust_time ov_bc ov_ad e = let bc_imm = float_of_int e.owncount *. ov_bc in let ad_imm = float_of_int e.immcount *. ov_ad in let abcd_all = float_of_int e.intcount *. (ov_ad +. ov_bc) in {e with tottime = e.tottime - int_of_float (abcd_all +. bc_imm); owntime = e.owntime - int_of_float (ad_imm +. bc_imm) } let close_profile print = let dw = spent_alloc () in let t = get_time () in match !stack with | [outside] -> outside.tottime <- outside.tottime + t; outside.owntime <- outside.owntime + t; ajoute_ownalloc outside dw; ajoute_totalloc outside dw; if !prof_table <> [] then begin let ov_bc = time_overhead_B_C () (* B+C overhead *) in let ov_ad = time_overhead_A_D () (* A+D overhead *) in let adjust (n,e) = (n, adjust_time ov_bc ov_ad e) in let adjtable = List.map adjust !prof_table in let adjoutside = adjust_time ov_bc ov_ad outside in let totalloc = !last_alloc -. !init_alloc in let total = create_record () in total.tottime <- outside.tottime; total.totalloc <- totalloc; (* We compute estimations of overhead, put into "own" fields *) total.owntime <- outside.tottime - adjoutside.tottime; total.ownalloc <- totalloc -. outside.totalloc; let current_data = (adjtable, adjoutside, total) in let updated_data = match !recording_file with | "" -> current_data | name -> merge_profile !recording_file current_data in if print then format_profile updated_data; init_profile () end | _ -> failwith "Inconsistency" let print_profile () = close_profile true let declare_profile name = if name = "___outside___" or name = "___total___" then failwith ("Error: "^name^" is a reserved keyword"); let e = create_record () in prof_table := (name,e)::!prof_table; e (* Default initialisation, may be overriden *) let _ = init_profile () (******************************) (* Entry points for profiling *) let profile1 e f a = let dw = spent_alloc () in match !stack with [] -> assert false | p::_ -> (* We add spent alloc since last measure to current caller own/total alloc *) ajoute_ownalloc p dw; ajoute_totalloc p dw; e.owncount <- e.owncount + 1; if not (p==e) then stack := e::!stack; let totalloc0 = e.totalloc in let intcount0 = e.intcount in let t = get_time () in try last_alloc := get_alloc (); let r = f a in let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; ajoute_ownalloc e dw; ajoute_totalloc e dw; p.owntime <- p.owntime - dt; ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; ajoute_ownalloc e dw; ajoute_totalloc e dw; p.owntime <- p.owntime - dt; ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); raise reraise let profile2 e f a b = let dw = spent_alloc () in match !stack with [] -> assert false | p::_ -> (* We add spent alloc since last measure to current caller own/total alloc *) ajoute_ownalloc p dw; ajoute_totalloc p dw; e.owncount <- e.owncount + 1; if not (p==e) then stack := e::!stack; let totalloc0 = e.totalloc in let intcount0 = e.intcount in let t = get_time () in try last_alloc := get_alloc (); let r = f a b in let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; ajoute_ownalloc e dw; ajoute_totalloc e dw; p.owntime <- p.owntime - dt; ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; ajoute_ownalloc e dw; ajoute_totalloc e dw; p.owntime <- p.owntime - dt; ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); raise reraise let profile3 e f a b c = let dw = spent_alloc () in match !stack with [] -> assert false | p::_ -> (* We add spent alloc since last measure to current caller own/total alloc *) ajoute_ownalloc p dw; ajoute_totalloc p dw; e.owncount <- e.owncount + 1; if not (p==e) then stack := e::!stack; let totalloc0 = e.totalloc in let intcount0 = e.intcount in let t = get_time () in try last_alloc := get_alloc (); let r = f a b c in let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; ajoute_ownalloc e dw; ajoute_totalloc e dw; p.owntime <- p.owntime - dt; ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; ajoute_ownalloc e dw; ajoute_totalloc e dw; p.owntime <- p.owntime - dt; ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); raise reraise let profile4 e f a b c d = let dw = spent_alloc () in match !stack with [] -> assert false | p::_ -> (* We add spent alloc since last measure to current caller own/total alloc *) ajoute_ownalloc p dw; ajoute_totalloc p dw; e.owncount <- e.owncount + 1; if not (p==e) then stack := e::!stack; let totalloc0 = e.totalloc in let intcount0 = e.intcount in let t = get_time () in try last_alloc := get_alloc (); let r = f a b c d in let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; ajoute_ownalloc e dw; ajoute_totalloc e dw; p.owntime <- p.owntime - dt; ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; ajoute_ownalloc e dw; ajoute_totalloc e dw; p.owntime <- p.owntime - dt; ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); raise reraise let profile5 e f a b c d g = let dw = spent_alloc () in match !stack with [] -> assert false | p::_ -> (* We add spent alloc since last measure to current caller own/total alloc *) ajoute_ownalloc p dw; ajoute_totalloc p dw; e.owncount <- e.owncount + 1; if not (p==e) then stack := e::!stack; let totalloc0 = e.totalloc in let intcount0 = e.intcount in let t = get_time () in try last_alloc := get_alloc (); let r = f a b c d g in let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; ajoute_ownalloc e dw; ajoute_totalloc e dw; p.owntime <- p.owntime - dt; ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; ajoute_ownalloc e dw; ajoute_totalloc e dw; p.owntime <- p.owntime - dt; ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); raise reraise let profile6 e f a b c d g h = let dw = spent_alloc () in match !stack with [] -> assert false | p::_ -> (* We add spent alloc since last measure to current caller own/total alloc *) ajoute_ownalloc p dw; ajoute_totalloc p dw; e.owncount <- e.owncount + 1; if not (p==e) then stack := e::!stack; let totalloc0 = e.totalloc in let intcount0 = e.intcount in let t = get_time () in try last_alloc := get_alloc (); let r = f a b c d g h in let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; ajoute_ownalloc e dw; ajoute_totalloc e dw; p.owntime <- p.owntime - dt; ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; ajoute_ownalloc e dw; ajoute_totalloc e dw; p.owntime <- p.owntime - dt; ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); raise reraise let profile7 e f a b c d g h i = let dw = spent_alloc () in match !stack with [] -> assert false | p::_ -> (* We add spent alloc since last measure to current caller own/total alloc *) ajoute_ownalloc p dw; ajoute_totalloc p dw; e.owncount <- e.owncount + 1; if not (p==e) then stack := e::!stack; let totalloc0 = e.totalloc in let intcount0 = e.intcount in let t = get_time () in try last_alloc := get_alloc (); let r = f a b c d g h i in let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; ajoute_ownalloc e dw; ajoute_totalloc e dw; p.owntime <- p.owntime - dt; ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; ajoute_ownalloc e dw; ajoute_totalloc e dw; p.owntime <- p.owntime - dt; ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); raise reraise (* Some utilities to compute the logical and physical sizes and depth of ML objects *) let c = ref 0 let s = ref 0 let b = ref 0 let m = ref 0 let rec obj_stats d t = if Obj.is_int t then m := max d !m else if Obj.tag t >= Obj.no_scan_tag then if Obj.tag t = Obj.string_tag then (c := !c + Obj.size t; b := !b + 1; m := max d !m) else if Obj.tag t = Obj.double_tag then (s := !s + 2; b := !b + 1; m := max d !m) else if Obj.tag t = Obj.double_array_tag then (s := !s + 2 * Obj.size t; b := !b + 1; m := max d !m) else (b := !b + 1; m := max d !m) else let n = Obj.size t in s := !s + n; b := !b + 1; block_stats (d + 1) (n - 1) t and block_stats d i t = if i >= 0 then (obj_stats d (Obj.field t i); block_stats d (i-1) t) let obj_stats a = c := 0; s:= 0; b:= 0; m:= 0; obj_stats 0 (Obj.repr a); (!c, !s + !b, !m) module H = Hashtbl.Make( struct type t = Obj.t let equal = (==) let hash o = Hashtbl.hash (Obj.magic o : int) end) let tbl = H.create 13 let rec obj_shared_size s t = if Obj.is_int t then s else if H.mem tbl t then s else begin H.add tbl t (); let n = Obj.size t in if Obj.tag t >= Obj.no_scan_tag then if Obj.tag t = Obj.string_tag then (c := !c + n; s + 1) else if Obj.tag t = Obj.double_tag then s + 3 else if Obj.tag t = Obj.double_array_tag then s + 2 * n + 1 else s + 1 else block_shared_size (s + n + 1) (n - 1) t end and block_shared_size s i t = if i < 0 then s else block_shared_size (obj_shared_size s (Obj.field t i)) (i-1) t let obj_shared_size a = H.clear tbl; c := 0; let s = obj_shared_size 0 (Obj.repr a) in (!c, s) let print_logical_stats a = let (c, s, d) = obj_stats a in Printf.printf "Expanded size: %10d (str: %8d) Depth: %6d\n" (s+c) c d let print_stats a = let (c1, s, d) = obj_stats a in let (c2, o) = obj_shared_size a in Printf.printf "Size: %8d (str: %8d) (exp: %10d) Depth: %6d\n" (o + c2) c2 (s + c1) d (* let _ = Gc.set { (Gc.get()) with Gc.verbose = 13 } *) coq-8.4pl4/lib/hashcons.ml0000644000175000017500000001406612326224777014550 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t1)*(t2->t2)*...). * [hash_sub u x] is a function that hash-cons the sub-structures of x using * the hash-consing functions u provides. * [equal] is a comparison function. It is allowed to use physical equality * on the sub-terms hash-consed by the hash_sub function. * [hash] is the hash function given to the Hashtbl.Make function * * Note that this module type coerces to the argument of Hashtbl.Make. *) module type Comp = sig type t type u val hash_sub : u -> t -> t val equal : t -> t -> bool val hash : t -> int end (* The output is a function f such that * [f ()] has the side-effect of creating (internally) a hash-table of the * hash-consed objects. The result is a function taking the sub-hashcons * functions and an object, and hashcons it. It does not really make sense * to call f() with different sub-hcons functions. That's why we use the * wrappers simple_hcons, recursive_hcons, ... The latter just take as * argument the sub-hcons functions (the tables are created at that moment), * and returns the hcons function for t. *) module type S = sig type t type u val f : unit -> (u -> t -> t) end module Make(X:Comp) = struct type t = X.t type u = X.u (* We create the type of hashtables for t, with our comparison fun. * An invariant is that the table never contains two entries equals * w.r.t (=), although the equality on keys is X.equal. This is * granted since we hcons the subterms before looking up in the table. *) module Htbl = Hashtbl.Make( struct type t=X.t type u=X.u let hash=X.hash let equal x1 x2 = (*incr comparaison;*) X.equal x1 x2 end) (* The table is created when () is applied. * Hashconsing is then very simple: * 1- hashcons the subterms using hash_sub and u * 2- look up in the table, if we do not get a hit, we add it *) let f () = let tab = Htbl.create 97 in (fun u x -> let y = X.hash_sub u x in (* incr acces;*) try let r = Htbl.find tab y in(* incr succes;*) r with Not_found -> Htbl.add tab y y; y) end (* A few usefull wrappers: * takes as argument the function f above and build a function of type * u -> t -> t that creates a fresh table each time it is applied to the * sub-hcons functions. *) (* For non-recursive types it is quite easy. *) let simple_hcons h u = h () u (* For a recursive type T, we write the module of sig Comp with u equals * to (T -> T) * u0 * The first component will be used to hash-cons the recursive subterms * The second one to hashcons the other sub-structures. * We just have to take the fixpoint of h *) let recursive_hcons h u = let hc = h () in let rec hrec x = hc (hrec,u) x in hrec (* If the structure may contain loops, use this one. *) let recursive_loop_hcons h u = let hc = h () in let rec hrec visited x = if List.memq x visited then x else hc (hrec (x::visited),u) x in hrec [] (* For 2 mutually recursive types *) let recursive2_hcons h1 h2 u1 u2 = let hc1 = h1 () in let hc2 = h2 () in let rec hrec1 x = hc1 (hrec1,hrec2,u1) x and hrec2 x = hc2 (hrec1,hrec2,u2) x in (hrec1,hrec2) (* A set of global hashcons functions *) let hashcons_resets = ref [] let init() = List.iter (fun f -> f()) !hashcons_resets (* [register_hcons h u] registers the hcons function h, result of the above * wrappers. It returns another hcons function that always uses the same * table, which can be reinitialized by init() *) let register_hcons h u = let hf = ref (h u) in let reset() = hf := h u in hashcons_resets := reset :: !hashcons_resets; (fun x -> !hf x) (* Basic hashcons modules for string and obj. Integers do not need be hashconsed. *) (* string *) module Hstring = Make( struct type t = string type u = unit let hash_sub () s =(* incr accesstr;*) s let equal s1 s2 =(* incr comparaisonstr; if*) s1=s2(* then (incr successtr; true) else false*) let hash = Hashtbl.hash end) (* Obj.t *) exception NotEq (* From CAMLLIB/caml/mlvalues.h *) let no_scan_tag = 251 let tuple_p obj = Obj.is_block obj & (Obj.tag obj < no_scan_tag) let comp_obj o1 o2 = if tuple_p o1 & tuple_p o2 then let n1 = Obj.size o1 and n2 = Obj.size o2 in if n1=n2 then try for i = 0 to pred n1 do if not (Obj.field o1 i == Obj.field o2 i) then raise NotEq done; true with NotEq -> false else false else o1=o2 let hash_obj hrec o = begin if tuple_p o then let n = Obj.size o in for i = 0 to pred n do Obj.set_field o i (hrec (Obj.field o i)) done end; o module Hobj = Make( struct type t = Obj.t type u = (Obj.t -> Obj.t) * unit let hash_sub (hrec,_) = hash_obj hrec let equal = comp_obj let hash = Hashtbl.hash end) (* Hashconsing functions for string and obj. Always use the same * global tables. The latter can be reinitialized with init() *) (* string : string -> string *) (* obj : Obj.t -> Obj.t *) let string = register_hcons (simple_hcons Hstring.f) () let obj = register_hcons (recursive_hcons Hobj.f) () (* The unsafe polymorphic hashconsing function *) let magic_hash (c : 'a) = init(); let r = obj (Obj.repr c) in init(); (Obj.magic r : 'a) coq-8.4pl4/lib/store.ml0000644000175000017500000000330212326224777014065 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t ; get : t -> 'a option } val embed : unit -> 'a etype end (* We use a dynamic "name" allocator. But if we needed to serialise stores, we might want something static to avoid troubles with plugins order. *) let next = let count = ref 0 in fun () -> let n = !count in incr count; n type t = Obj.t Util.Intmap.t module Field = struct type 'a field = { set : 'a -> t -> t ; get : t -> 'a option ; remove : t -> t } type 'a t = 'a field end open Field let empty = Util.Intmap.empty let field () = let fid = next () in let set a s = Util.Intmap.add fid (Obj.repr a) s in let get s = try Some (Obj.obj (Util.Intmap.find fid s)) with Not_found -> None in let remove s = Util.Intmap.remove fid s in { set = set ; get = get ; remove = remove } coq-8.4pl4/lib/gmapl.mli0000644000175000017500000000166512326224777014214 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ('a,'b) t -> bool val iter : ('a -> 'b list -> unit) -> ('a,'b) t -> unit val map : ('b list -> 'c list) -> ('a,'b) t -> ('a,'c) t val fold : ('a -> 'b list -> 'c -> 'c) -> ('a,'b) t -> 'c -> 'c val add : 'a -> 'b -> ('a,'b) t -> ('a,'b) t val find : 'a -> ('a,'b) t -> 'b list val remove : 'a -> 'b -> ('a,'b) t -> ('a,'b) t coq-8.4pl4/lib/errors.mli0000644000175000017500000000370712326224777014427 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Pp.std_ppcmds) -> unit (** The standard exception printer *) val print : exn -> Pp.std_ppcmds (** Same as [print], except that the "Please report" part of an anomaly isn't printed (used in Ltac debugging). *) val print_no_report : exn -> Pp.std_ppcmds (** Same as [print], except that anomalies are not printed but re-raised (used for the Fail command) *) val print_no_anomaly : exn -> Pp.std_ppcmds (** Critical exceptions shouldn't be catched and ignored by mistake by inner functions during a [vernacinterp]. They should be handled only in [Toplevel.do_vernac] (or Ideslave), to be displayed to the user. Typical example: [Sys.Break]. In the 8.4 branch, for maximal compatibility, anomalies are not considered as critical... *) val noncritical : exn -> bool coq-8.4pl4/lib/unicodetable.ml0000644000175000017500000016631412326224777015404 0ustar stephsteph (** Unicode tables generated from Camomile. *) (* Letter, Uppercase *) let lu = [ (0x00041,0x0005A); (0x000C0,0x000D6); (0x000D8,0x000DE); (0x00100,0x00100); (0x00102,0x00102); (0x00104,0x00104); (0x00106,0x00106); (0x00108,0x00108); (0x0010A,0x0010A); (0x0010C,0x0010C); (0x0010E,0x0010E); (0x00110,0x00110); (0x00112,0x00112); (0x00114,0x00114); (0x00116,0x00116); (0x00118,0x00118); (0x0011A,0x0011A); (0x0011C,0x0011C); (0x0011E,0x0011E); (0x00120,0x00120); (0x00122,0x00122); (0x00124,0x00124); (0x00126,0x00126); (0x00128,0x00128); (0x0012A,0x0012A); (0x0012C,0x0012C); (0x0012E,0x0012E); (0x00130,0x00130); (0x00132,0x00132); (0x00134,0x00134); (0x00136,0x00136); (0x00139,0x00139); (0x0013B,0x0013B); (0x0013D,0x0013D); (0x0013F,0x0013F); (0x00141,0x00141); (0x00143,0x00143); (0x00145,0x00145); (0x00147,0x00147); (0x0014A,0x0014A); (0x0014C,0x0014C); (0x0014E,0x0014E); (0x00150,0x00150); (0x00152,0x00152); (0x00154,0x00154); (0x00156,0x00156); (0x00158,0x00158); (0x0015A,0x0015A); (0x0015C,0x0015C); (0x0015E,0x0015E); (0x00160,0x00160); (0x00162,0x00162); (0x00164,0x00164); (0x00166,0x00166); (0x00168,0x00168); (0x0016A,0x0016A); (0x0016C,0x0016C); (0x0016E,0x0016E); (0x00170,0x00170); (0x00172,0x00172); (0x00174,0x00174); (0x00176,0x00176); (0x00178,0x00179); (0x0017B,0x0017B); (0x0017D,0x0017D); (0x00181,0x00182); (0x00184,0x00184); (0x00186,0x00187); (0x00189,0x0018B); (0x0018E,0x00191); (0x00193,0x00194); (0x00196,0x00198); (0x0019C,0x0019D); (0x0019F,0x001A0); (0x001A2,0x001A2); (0x001A4,0x001A4); (0x001A6,0x001A7); (0x001A9,0x001A9); (0x001AC,0x001AC); (0x001AE,0x001AF); (0x001B1,0x001B3); (0x001B5,0x001B5); (0x001B7,0x001B8); (0x001BC,0x001BC); (0x001C4,0x001C4); (0x001C7,0x001C7); (0x001CA,0x001CA); (0x001CD,0x001CD); (0x001CF,0x001CF); (0x001D1,0x001D1); (0x001D3,0x001D3); (0x001D5,0x001D5); (0x001D7,0x001D7); (0x001D9,0x001D9); (0x001DB,0x001DB); (0x001DE,0x001DE); (0x001E0,0x001E0); (0x001E2,0x001E2); (0x001E4,0x001E4); (0x001E6,0x001E6); (0x001E8,0x001E8); (0x001EA,0x001EA); (0x001EC,0x001EC); (0x001EE,0x001EE); (0x001F1,0x001F1); (0x001F4,0x001F4); (0x001F6,0x001F8); (0x001FA,0x001FA); (0x001FC,0x001FC); (0x001FE,0x001FE); (0x00200,0x00200); (0x00202,0x00202); (0x00204,0x00204); (0x00206,0x00206); (0x00208,0x00208); (0x0020A,0x0020A); (0x0020C,0x0020C); (0x0020E,0x0020E); (0x00210,0x00210); (0x00212,0x00212); (0x00214,0x00214); (0x00216,0x00216); (0x00218,0x00218); (0x0021A,0x0021A); (0x0021C,0x0021C); (0x0021E,0x0021E); (0x00220,0x00220); (0x00222,0x00222); (0x00224,0x00224); (0x00226,0x00226); (0x00228,0x00228); (0x0022A,0x0022A); (0x0022C,0x0022C); (0x0022E,0x0022E); (0x00230,0x00230); (0x00232,0x00232); (0x00386,0x00386); (0x00388,0x0038A); (0x0038C,0x0038C); (0x0038E,0x0038F); (0x00391,0x003A1); (0x003A3,0x003AB); (0x003D2,0x003D4); (0x003D8,0x003D8); (0x003DA,0x003DA); (0x003DC,0x003DC); (0x003DE,0x003DE); (0x003E0,0x003E0); (0x003E2,0x003E2); (0x003E4,0x003E4); (0x003E6,0x003E6); (0x003E8,0x003E8); (0x003EA,0x003EA); (0x003EC,0x003EC); (0x003EE,0x003EE); (0x003F4,0x003F4); (0x00400,0x0042F); (0x00460,0x00460); (0x00462,0x00462); (0x00464,0x00464); (0x00466,0x00466); (0x00468,0x00468); (0x0046A,0x0046A); (0x0046C,0x0046C); (0x0046E,0x0046E); (0x00470,0x00470); (0x00472,0x00472); (0x00474,0x00474); (0x00476,0x00476); (0x00478,0x00478); (0x0047A,0x0047A); (0x0047C,0x0047C); (0x0047E,0x0047E); (0x00480,0x00480); (0x0048A,0x0048A); (0x0048C,0x0048C); (0x0048E,0x0048E); (0x00490,0x00490); (0x00492,0x00492); (0x00494,0x00494); (0x00496,0x00496); (0x00498,0x00498); (0x0049A,0x0049A); (0x0049C,0x0049C); (0x0049E,0x0049E); (0x004A0,0x004A0); (0x004A2,0x004A2); (0x004A4,0x004A4); (0x004A6,0x004A6); (0x004A8,0x004A8); (0x004AA,0x004AA); (0x004AC,0x004AC); (0x004AE,0x004AE); (0x004B0,0x004B0); (0x004B2,0x004B2); (0x004B4,0x004B4); (0x004B6,0x004B6); (0x004B8,0x004B8); (0x004BA,0x004BA); (0x004BC,0x004BC); (0x004BE,0x004BE); (0x004C0,0x004C1); (0x004C3,0x004C3); (0x004C5,0x004C5); (0x004C7,0x004C7); (0x004C9,0x004C9); (0x004CB,0x004CB); (0x004CD,0x004CD); (0x004D0,0x004D0); (0x004D2,0x004D2); (0x004D4,0x004D4); (0x004D6,0x004D6); (0x004D8,0x004D8); (0x004DA,0x004DA); (0x004DC,0x004DC); (0x004DE,0x004DE); (0x004E0,0x004E0); (0x004E2,0x004E2); (0x004E4,0x004E4); (0x004E6,0x004E6); (0x004E8,0x004E8); (0x004EA,0x004EA); (0x004EC,0x004EC); (0x004EE,0x004EE); (0x004F0,0x004F0); (0x004F2,0x004F2); (0x004F4,0x004F4); (0x004F8,0x004F8); (0x00500,0x00500); (0x00502,0x00502); (0x00504,0x00504); (0x00506,0x00506); (0x00508,0x00508); (0x0050A,0x0050A); (0x0050C,0x0050C); (0x0050E,0x0050E); (0x00531,0x00556); (0x010A0,0x010C5); (0x01E00,0x01E00); (0x01E02,0x01E02); (0x01E04,0x01E04); (0x01E06,0x01E06); (0x01E08,0x01E08); (0x01E0A,0x01E0A); (0x01E0C,0x01E0C); (0x01E0E,0x01E0E); (0x01E10,0x01E10); (0x01E12,0x01E12); (0x01E14,0x01E14); (0x01E16,0x01E16); (0x01E18,0x01E18); (0x01E1A,0x01E1A); (0x01E1C,0x01E1C); (0x01E1E,0x01E1E); (0x01E20,0x01E20); (0x01E22,0x01E22); (0x01E24,0x01E24); (0x01E26,0x01E26); (0x01E28,0x01E28); (0x01E2A,0x01E2A); (0x01E2C,0x01E2C); (0x01E2E,0x01E2E); (0x01E30,0x01E30); (0x01E32,0x01E32); (0x01E34,0x01E34); (0x01E36,0x01E36); (0x01E38,0x01E38); (0x01E3A,0x01E3A); (0x01E3C,0x01E3C); (0x01E3E,0x01E3E); (0x01E40,0x01E40); (0x01E42,0x01E42); (0x01E44,0x01E44); (0x01E46,0x01E46); (0x01E48,0x01E48); (0x01E4A,0x01E4A); (0x01E4C,0x01E4C); (0x01E4E,0x01E4E); (0x01E50,0x01E50); (0x01E52,0x01E52); (0x01E54,0x01E54); (0x01E56,0x01E56); (0x01E58,0x01E58); (0x01E5A,0x01E5A); (0x01E5C,0x01E5C); (0x01E5E,0x01E5E); (0x01E60,0x01E60); (0x01E62,0x01E62); (0x01E64,0x01E64); (0x01E66,0x01E66); (0x01E68,0x01E68); (0x01E6A,0x01E6A); (0x01E6C,0x01E6C); (0x01E6E,0x01E6E); (0x01E70,0x01E70); (0x01E72,0x01E72); (0x01E74,0x01E74); (0x01E76,0x01E76); (0x01E78,0x01E78); (0x01E7A,0x01E7A); (0x01E7C,0x01E7C); (0x01E7E,0x01E7E); (0x01E80,0x01E80); (0x01E82,0x01E82); (0x01E84,0x01E84); (0x01E86,0x01E86); (0x01E88,0x01E88); (0x01E8A,0x01E8A); (0x01E8C,0x01E8C); (0x01E8E,0x01E8E); (0x01E90,0x01E90); (0x01E92,0x01E92); (0x01E94,0x01E94); (0x01EA0,0x01EA0); (0x01EA2,0x01EA2); (0x01EA4,0x01EA4); (0x01EA6,0x01EA6); (0x01EA8,0x01EA8); (0x01EAA,0x01EAA); (0x01EAC,0x01EAC); (0x01EAE,0x01EAE); (0x01EB0,0x01EB0); (0x01EB2,0x01EB2); (0x01EB4,0x01EB4); (0x01EB6,0x01EB6); (0x01EB8,0x01EB8); (0x01EBA,0x01EBA); (0x01EBC,0x01EBC); (0x01EBE,0x01EBE); (0x01EC0,0x01EC0); (0x01EC2,0x01EC2); (0x01EC4,0x01EC4); (0x01EC6,0x01EC6); (0x01EC8,0x01EC8); (0x01ECA,0x01ECA); (0x01ECC,0x01ECC); (0x01ECE,0x01ECE); (0x01ED0,0x01ED0); (0x01ED2,0x01ED2); (0x01ED4,0x01ED4); (0x01ED6,0x01ED6); (0x01ED8,0x01ED8); (0x01EDA,0x01EDA); (0x01EDC,0x01EDC); (0x01EDE,0x01EDE); (0x01EE0,0x01EE0); (0x01EE2,0x01EE2); (0x01EE4,0x01EE4); (0x01EE6,0x01EE6); (0x01EE8,0x01EE8); (0x01EEA,0x01EEA); (0x01EEC,0x01EEC); (0x01EEE,0x01EEE); (0x01EF0,0x01EF0); (0x01EF2,0x01EF2); (0x01EF4,0x01EF4); (0x01EF6,0x01EF6); (0x01EF8,0x01EF8); (0x01F08,0x01F0F); (0x01F18,0x01F1D); (0x01F28,0x01F2F); (0x01F38,0x01F3F); (0x01F48,0x01F4D); (0x01F59,0x01F59); (0x01F5B,0x01F5B); (0x01F5D,0x01F5D); (0x01F5F,0x01F5F); (0x01F68,0x01F6F); (0x01FB8,0x01FBB); (0x01FC8,0x01FCB); (0x01FD8,0x01FDB); (0x01FE8,0x01FEC); (0x01FF8,0x01FFB); (0x02102,0x02102); (0x02107,0x02107); (0x0210B,0x0210D); (0x02110,0x02112); (0x02115,0x02115); (0x02119,0x0211D); (0x02124,0x02124); (0x02126,0x02126); (0x02128,0x02128); (0x0212A,0x0212D); (0x02130,0x02131); (0x02133,0x02133); (0x0213E,0x0213F); (0x02145,0x02145); (0x0FF21,0x0FF3A); (0x10400,0x10425); (0x1D400,0x1D419); (0x1D434,0x1D44D); (0x1D468,0x1D481); (0x1D49C,0x1D49C); (0x1D49E,0x1D49F); (0x1D4A2,0x1D4A2); (0x1D4A5,0x1D4A6); (0x1D4A9,0x1D4AC); (0x1D4AE,0x1D4B5); (0x1D4D0,0x1D4E9); (0x1D504,0x1D505); (0x1D507,0x1D50A); (0x1D50D,0x1D514); (0x1D516,0x1D51C); (0x1D538,0x1D539); (0x1D53B,0x1D53E); (0x1D540,0x1D544); (0x1D546,0x1D546); (0x1D54A,0x1D550); (0x1D56C,0x1D585); (0x1D5A0,0x1D5B9); (0x1D5D4,0x1D5ED); (0x1D608,0x1D621); (0x1D63C,0x1D655); (0x1D670,0x1D689); (0x1D6A8,0x1D6C0); (0x1D6E2,0x1D6FA); (0x1D71C,0x1D734); (0x1D756,0x1D76E); (0x1D790,0x1D7A8) ] (* Letter, Lowercase *) let ll = [ (0x00061,0x0007A); (0x000AA,0x000AA); (0x000B5,0x000B5); (0x000BA,0x000BA); (0x000DF,0x000F6); (0x000F8,0x000FF); (0x00101,0x00101); (0x00103,0x00103); (0x00105,0x00105); (0x00107,0x00107); (0x00109,0x00109); (0x0010B,0x0010B); (0x0010D,0x0010D); (0x0010F,0x0010F); (0x00111,0x00111); (0x00113,0x00113); (0x00115,0x00115); (0x00117,0x00117); (0x00119,0x00119); (0x0011B,0x0011B); (0x0011D,0x0011D); (0x0011F,0x0011F); (0x00121,0x00121); (0x00123,0x00123); (0x00125,0x00125); (0x00127,0x00127); (0x00129,0x00129); (0x0012B,0x0012B); (0x0012D,0x0012D); (0x0012F,0x0012F); (0x00131,0x00131); (0x00133,0x00133); (0x00135,0x00135); (0x00137,0x00138); (0x0013A,0x0013A); (0x0013C,0x0013C); (0x0013E,0x0013E); (0x00140,0x00140); (0x00142,0x00142); (0x00144,0x00144); (0x00146,0x00146); (0x00148,0x00149); (0x0014B,0x0014B); (0x0014D,0x0014D); (0x0014F,0x0014F); (0x00151,0x00151); (0x00153,0x00153); (0x00155,0x00155); (0x00157,0x00157); (0x00159,0x00159); (0x0015B,0x0015B); (0x0015D,0x0015D); (0x0015F,0x0015F); (0x00161,0x00161); (0x00163,0x00163); (0x00165,0x00165); (0x00167,0x00167); (0x00169,0x00169); (0x0016B,0x0016B); (0x0016D,0x0016D); (0x0016F,0x0016F); (0x00171,0x00171); (0x00173,0x00173); (0x00175,0x00175); (0x00177,0x00177); (0x0017A,0x0017A); (0x0017C,0x0017C); (0x0017E,0x00180); (0x00183,0x00183); (0x00185,0x00185); (0x00188,0x00188); (0x0018C,0x0018D); (0x00192,0x00192); (0x00195,0x00195); (0x00199,0x0019B); (0x0019E,0x0019E); (0x001A1,0x001A1); (0x001A3,0x001A3); (0x001A5,0x001A5); (0x001A8,0x001A8); (0x001AA,0x001AB); (0x001AD,0x001AD); (0x001B0,0x001B0); (0x001B4,0x001B4); (0x001B6,0x001B6); (0x001B9,0x001BA); (0x001BD,0x001BF); (0x001C6,0x001C6); (0x001C9,0x001C9); (0x001CC,0x001CC); (0x001CE,0x001CE); (0x001D0,0x001D0); (0x001D2,0x001D2); (0x001D4,0x001D4); (0x001D6,0x001D6); (0x001D8,0x001D8); (0x001DA,0x001DA); (0x001DC,0x001DD); (0x001DF,0x001DF); (0x001E1,0x001E1); (0x001E3,0x001E3); (0x001E5,0x001E5); (0x001E7,0x001E7); (0x001E9,0x001E9); (0x001EB,0x001EB); (0x001ED,0x001ED); (0x001EF,0x001F0); (0x001F3,0x001F3); (0x001F5,0x001F5); (0x001F9,0x001F9); (0x001FB,0x001FB); (0x001FD,0x001FD); (0x001FF,0x001FF); (0x00201,0x00201); (0x00203,0x00203); (0x00205,0x00205); (0x00207,0x00207); (0x00209,0x00209); (0x0020B,0x0020B); (0x0020D,0x0020D); (0x0020F,0x0020F); (0x00211,0x00211); (0x00213,0x00213); (0x00215,0x00215); (0x00217,0x00217); (0x00219,0x00219); (0x0021B,0x0021B); (0x0021D,0x0021D); (0x0021F,0x0021F); (0x00223,0x00223); (0x00225,0x00225); (0x00227,0x00227); (0x00229,0x00229); (0x0022B,0x0022B); (0x0022D,0x0022D); (0x0022F,0x0022F); (0x00231,0x00231); (0x00233,0x00233); (0x00250,0x002AD); (0x00390,0x00390); (0x003AC,0x003CE); (0x003D0,0x003D1); (0x003D5,0x003D7); (0x003D9,0x003D9); (0x003DB,0x003DB); (0x003DD,0x003DD); (0x003DF,0x003DF); (0x003E1,0x003E1); (0x003E3,0x003E3); (0x003E5,0x003E5); (0x003E7,0x003E7); (0x003E9,0x003E9); (0x003EB,0x003EB); (0x003ED,0x003ED); (0x003EF,0x003F3); (0x003F5,0x003F5); (0x00430,0x0045F); (0x00461,0x00461); (0x00463,0x00463); (0x00465,0x00465); (0x00467,0x00467); (0x00469,0x00469); (0x0046B,0x0046B); (0x0046D,0x0046D); (0x0046F,0x0046F); (0x00471,0x00471); (0x00473,0x00473); (0x00475,0x00475); (0x00477,0x00477); (0x00479,0x00479); (0x0047B,0x0047B); (0x0047D,0x0047D); (0x0047F,0x0047F); (0x00481,0x00481); (0x0048B,0x0048B); (0x0048D,0x0048D); (0x0048F,0x0048F); (0x00491,0x00491); (0x00493,0x00493); (0x00495,0x00495); (0x00497,0x00497); (0x00499,0x00499); (0x0049B,0x0049B); (0x0049D,0x0049D); (0x0049F,0x0049F); (0x004A1,0x004A1); (0x004A3,0x004A3); (0x004A5,0x004A5); (0x004A7,0x004A7); (0x004A9,0x004A9); (0x004AB,0x004AB); (0x004AD,0x004AD); (0x004AF,0x004AF); (0x004B1,0x004B1); (0x004B3,0x004B3); (0x004B5,0x004B5); (0x004B7,0x004B7); (0x004B9,0x004B9); (0x004BB,0x004BB); (0x004BD,0x004BD); (0x004BF,0x004BF); (0x004C2,0x004C2); (0x004C4,0x004C4); (0x004C6,0x004C6); (0x004C8,0x004C8); (0x004CA,0x004CA); (0x004CC,0x004CC); (0x004CE,0x004CE); (0x004D1,0x004D1); (0x004D3,0x004D3); (0x004D5,0x004D5); (0x004D7,0x004D7); (0x004D9,0x004D9); (0x004DB,0x004DB); (0x004DD,0x004DD); (0x004DF,0x004DF); (0x004E1,0x004E1); (0x004E3,0x004E3); (0x004E5,0x004E5); (0x004E7,0x004E7); (0x004E9,0x004E9); (0x004EB,0x004EB); (0x004ED,0x004ED); (0x004EF,0x004EF); (0x004F1,0x004F1); (0x004F3,0x004F3); (0x004F5,0x004F5); (0x004F9,0x004F9); (0x00501,0x00501); (0x00503,0x00503); (0x00505,0x00505); (0x00507,0x00507); (0x00509,0x00509); (0x0050B,0x0050B); (0x0050D,0x0050D); (0x0050F,0x0050F); (0x00561,0x00587); (0x01E01,0x01E01); (0x01E03,0x01E03); (0x01E05,0x01E05); (0x01E07,0x01E07); (0x01E09,0x01E09); (0x01E0B,0x01E0B); (0x01E0D,0x01E0D); (0x01E0F,0x01E0F); (0x01E11,0x01E11); (0x01E13,0x01E13); (0x01E15,0x01E15); (0x01E17,0x01E17); (0x01E19,0x01E19); (0x01E1B,0x01E1B); (0x01E1D,0x01E1D); (0x01E1F,0x01E1F); (0x01E21,0x01E21); (0x01E23,0x01E23); (0x01E25,0x01E25); (0x01E27,0x01E27); (0x01E29,0x01E29); (0x01E2B,0x01E2B); (0x01E2D,0x01E2D); (0x01E2F,0x01E2F); (0x01E31,0x01E31); (0x01E33,0x01E33); (0x01E35,0x01E35); (0x01E37,0x01E37); (0x01E39,0x01E39); (0x01E3B,0x01E3B); (0x01E3D,0x01E3D); (0x01E3F,0x01E3F); (0x01E41,0x01E41); (0x01E43,0x01E43); (0x01E45,0x01E45); (0x01E47,0x01E47); (0x01E49,0x01E49); (0x01E4B,0x01E4B); (0x01E4D,0x01E4D); (0x01E4F,0x01E4F); (0x01E51,0x01E51); (0x01E53,0x01E53); (0x01E55,0x01E55); (0x01E57,0x01E57); (0x01E59,0x01E59); (0x01E5B,0x01E5B); (0x01E5D,0x01E5D); (0x01E5F,0x01E5F); (0x01E61,0x01E61); (0x01E63,0x01E63); (0x01E65,0x01E65); (0x01E67,0x01E67); (0x01E69,0x01E69); (0x01E6B,0x01E6B); (0x01E6D,0x01E6D); (0x01E6F,0x01E6F); (0x01E71,0x01E71); (0x01E73,0x01E73); (0x01E75,0x01E75); (0x01E77,0x01E77); (0x01E79,0x01E79); (0x01E7B,0x01E7B); (0x01E7D,0x01E7D); (0x01E7F,0x01E7F); (0x01E81,0x01E81); (0x01E83,0x01E83); (0x01E85,0x01E85); (0x01E87,0x01E87); (0x01E89,0x01E89); (0x01E8B,0x01E8B); (0x01E8D,0x01E8D); (0x01E8F,0x01E8F); (0x01E91,0x01E91); (0x01E93,0x01E93); (0x01E95,0x01E9B); (0x01EA1,0x01EA1); (0x01EA3,0x01EA3); (0x01EA5,0x01EA5); (0x01EA7,0x01EA7); (0x01EA9,0x01EA9); (0x01EAB,0x01EAB); (0x01EAD,0x01EAD); (0x01EAF,0x01EAF); (0x01EB1,0x01EB1); (0x01EB3,0x01EB3); (0x01EB5,0x01EB5); (0x01EB7,0x01EB7); (0x01EB9,0x01EB9); (0x01EBB,0x01EBB); (0x01EBD,0x01EBD); (0x01EBF,0x01EBF); (0x01EC1,0x01EC1); (0x01EC3,0x01EC3); (0x01EC5,0x01EC5); (0x01EC7,0x01EC7); (0x01EC9,0x01EC9); (0x01ECB,0x01ECB); (0x01ECD,0x01ECD); (0x01ECF,0x01ECF); (0x01ED1,0x01ED1); (0x01ED3,0x01ED3); (0x01ED5,0x01ED5); (0x01ED7,0x01ED7); (0x01ED9,0x01ED9); (0x01EDB,0x01EDB); (0x01EDD,0x01EDD); (0x01EDF,0x01EDF); (0x01EE1,0x01EE1); (0x01EE3,0x01EE3); (0x01EE5,0x01EE5); (0x01EE7,0x01EE7); (0x01EE9,0x01EE9); (0x01EEB,0x01EEB); (0x01EED,0x01EED); (0x01EEF,0x01EEF); (0x01EF1,0x01EF1); (0x01EF3,0x01EF3); (0x01EF5,0x01EF5); (0x01EF7,0x01EF7); (0x01EF9,0x01EF9); (0x01F00,0x01F07); (0x01F10,0x01F15); (0x01F20,0x01F27); (0x01F30,0x01F37); (0x01F40,0x01F45); (0x01F50,0x01F57); (0x01F60,0x01F67); (0x01F70,0x01F7D); (0x01F80,0x01F87); (0x01F90,0x01F97); (0x01FA0,0x01FA7); (0x01FB0,0x01FB4); (0x01FB6,0x01FB7); (0x01FBE,0x01FBE); (0x01FC2,0x01FC4); (0x01FC6,0x01FC7); (0x01FD0,0x01FD3); (0x01FD6,0x01FD7); (0x01FE0,0x01FE7); (0x01FF2,0x01FF4); (0x01FF6,0x01FF7); (0x02071,0x02071); (0x0207F,0x0207F); (0x0210A,0x0210A); (0x0210E,0x0210F); (0x02113,0x02113); (0x0212F,0x0212F); (0x02134,0x02134); (0x02139,0x02139); (0x0213D,0x0213D); (0x02146,0x02149); (0x0FB00,0x0FB06); (0x0FB13,0x0FB17); (0x0FF41,0x0FF5A); (0x10428,0x1044D); (0x1D41A,0x1D433); (0x1D44E,0x1D454); (0x1D456,0x1D467); (0x1D482,0x1D49B); (0x1D4B6,0x1D4B9); (0x1D4BB,0x1D4BB); (0x1D4BD,0x1D4C0); (0x1D4C2,0x1D4C3); (0x1D4C5,0x1D4CF); (0x1D4EA,0x1D503); (0x1D51E,0x1D537); (0x1D552,0x1D56B); (0x1D586,0x1D59F); (0x1D5BA,0x1D5D3); (0x1D5EE,0x1D607); (0x1D622,0x1D63B); (0x1D656,0x1D66F); (0x1D68A,0x1D6A3); (0x1D6C2,0x1D6DA); (0x1D6DC,0x1D6E1); (0x1D6FC,0x1D714); (0x1D716,0x1D71B); (0x1D736,0x1D74E); (0x1D750,0x1D755); (0x1D770,0x1D788); (0x1D78A,0x1D78F); (0x1D7AA,0x1D7C2); (0x1D7C4,0x1D7C9) ] (* Letter, Titlecase *) let lt = [ (0x001C5,0x001C5); (0x001C8,0x001C8); (0x001CB,0x001CB); (0x001F2,0x001F2); (0x01F88,0x01F8F); (0x01F98,0x01F9F); (0x01FA8,0x01FAF); (0x01FBC,0x01FBC); (0x01FCC,0x01FCC); (0x01FFC,0x01FFC) ] (* Mark, Non-Spacing *) let mn = [ (0x00300,0x0034F); (0x00360,0x0036F); (0x00483,0x00486); (0x00591,0x005A1); (0x005A3,0x005B9); (0x005BB,0x005BD); (0x005BF,0x005BF); (0x005C1,0x005C2); (0x005C4,0x005C4); (0x0064B,0x00655); (0x00670,0x00670); (0x006D6,0x006DC); (0x006DF,0x006E4); (0x006E7,0x006E8); (0x006EA,0x006ED); (0x00711,0x00711); (0x00730,0x0074A); (0x007A6,0x007B0); (0x00901,0x00902); (0x0093C,0x0093C); (0x00941,0x00948); (0x0094D,0x0094D); (0x00951,0x00954); (0x00962,0x00963); (0x00981,0x00981); (0x009BC,0x009BC); (0x009C1,0x009C4); (0x009CD,0x009CD); (0x009E2,0x009E3); (0x00A02,0x00A02); (0x00A3C,0x00A3C); (0x00A41,0x00A42); (0x00A47,0x00A48); (0x00A4B,0x00A4D); (0x00A70,0x00A71); (0x00A81,0x00A82); (0x00ABC,0x00ABC); (0x00AC1,0x00AC5); (0x00AC7,0x00AC8); (0x00ACD,0x00ACD); (0x00B01,0x00B01); (0x00B3C,0x00B3C); (0x00B3F,0x00B3F); (0x00B41,0x00B43); (0x00B4D,0x00B4D); (0x00B56,0x00B56); (0x00B82,0x00B82); (0x00BC0,0x00BC0); (0x00BCD,0x00BCD); (0x00C3E,0x00C40); (0x00C46,0x00C48); (0x00C4A,0x00C4D); (0x00C55,0x00C56); (0x00CBF,0x00CBF); (0x00CC6,0x00CC6); (0x00CCC,0x00CCD); (0x00D41,0x00D43); (0x00D4D,0x00D4D); (0x00DCA,0x00DCA); (0x00DD2,0x00DD4); (0x00DD6,0x00DD6); (0x00E31,0x00E31); (0x00E34,0x00E3A); (0x00E47,0x00E4E); (0x00EB1,0x00EB1); (0x00EB4,0x00EB9); (0x00EBB,0x00EBC); (0x00EC8,0x00ECD); (0x00F18,0x00F19); (0x00F35,0x00F35); (0x00F37,0x00F37); (0x00F39,0x00F39); (0x00F71,0x00F7E); (0x00F80,0x00F84); (0x00F86,0x00F87); (0x00F90,0x00F97); (0x00F99,0x00FBC); (0x00FC6,0x00FC6); (0x0102D,0x01030); (0x01032,0x01032); (0x01036,0x01037); (0x01039,0x01039); (0x01058,0x01059); (0x01712,0x01714); (0x01732,0x01734); (0x01752,0x01753); (0x01772,0x01773); (0x017B7,0x017BD); (0x017C6,0x017C6); (0x017C9,0x017D3); (0x0180B,0x0180D); (0x018A9,0x018A9); (0x020D0,0x020DC); (0x020E1,0x020E1); (0x020E5,0x020EA); (0x0302A,0x0302F); (0x03099,0x0309A); (0x0FB1E,0x0FB1E); (0x0FE00,0x0FE0F); (0x0FE20,0x0FE23); (0x1D167,0x1D169); (0x1D17B,0x1D182); (0x1D185,0x1D18B); (0x1D1AA,0x1D1AD) ] (* Mark, Spacing Combining *) let mc = [ (0x00903,0x00903); (0x0093E,0x00940); (0x00949,0x0094C); (0x00982,0x00983); (0x009BE,0x009C0); (0x009C7,0x009C8); (0x009CB,0x009CC); (0x009D7,0x009D7); (0x00A3E,0x00A40); (0x00A83,0x00A83); (0x00ABE,0x00AC0); (0x00AC9,0x00AC9); (0x00ACB,0x00ACC); (0x00B02,0x00B03); (0x00B3E,0x00B3E); (0x00B40,0x00B40); (0x00B47,0x00B48); (0x00B4B,0x00B4C); (0x00B57,0x00B57); (0x00BBE,0x00BBF); (0x00BC1,0x00BC2); (0x00BC6,0x00BC8); (0x00BCA,0x00BCC); (0x00BD7,0x00BD7); (0x00C01,0x00C03); (0x00C41,0x00C44); (0x00C82,0x00C83); (0x00CBE,0x00CBE); (0x00CC0,0x00CC4); (0x00CC7,0x00CC8); (0x00CCA,0x00CCB); (0x00CD5,0x00CD6); (0x00D02,0x00D03); (0x00D3E,0x00D40); (0x00D46,0x00D48); (0x00D4A,0x00D4C); (0x00D57,0x00D57); (0x00D82,0x00D83); (0x00DCF,0x00DD1); (0x00DD8,0x00DDF); (0x00DF2,0x00DF3); (0x00F3E,0x00F3F); (0x00F7F,0x00F7F); (0x0102C,0x0102C); (0x01031,0x01031); (0x01038,0x01038); (0x01056,0x01057); (0x017B4,0x017B6); (0x017BE,0x017C5); (0x017C7,0x017C8); (0x1D165,0x1D166); (0x1D16D,0x1D172) ] (* Mark, Enclosing *) let me = [ (0x00488,0x00489); (0x006DE,0x006DE); (0x020DD,0x020E0); (0x020E2,0x020E4) ] (* Number, Decimal Digit *) let nd = [ (0x00030,0x00039); (0x00660,0x00669); (0x006F0,0x006F9); (0x00966,0x0096F); (0x009E6,0x009EF); (0x00A66,0x00A6F); (0x00AE6,0x00AEF); (0x00B66,0x00B6F); (0x00BE7,0x00BEF); (0x00C66,0x00C6F); (0x00CE6,0x00CEF); (0x00D66,0x00D6F); (0x00E50,0x00E59); (0x00ED0,0x00ED9); (0x00F20,0x00F29); (0x01040,0x01049); (0x01369,0x01371); (0x017E0,0x017E9); (0x01810,0x01819); (0x0FF10,0x0FF19); (0x1D7CE,0x1D7FF) ] (* Number, Letter *) let nl = [ (0x016EE,0x016F0); (0x02160,0x02183); (0x03007,0x03007); (0x03021,0x03029); (0x03038,0x0303A); (0x1034A,0x1034A) ] (* Number, Other *) let no = [ (0x000B2,0x000B3); (0x000B9,0x000B9); (0x000BC,0x000BE); (0x009F4,0x009F9); (0x00BF0,0x00BF2); (0x00F2A,0x00F33); (0x01372,0x0137C); (0x02070,0x02070); (0x02074,0x02079); (0x02080,0x02089); (0x02153,0x0215F); (0x02460,0x0249B); (0x024EA,0x024FE); (0x02776,0x02793); (0x03192,0x03195); (0x03220,0x03229); (0x03251,0x0325F); (0x03280,0x03289); (0x032B1,0x032BF); (0x10320,0x10323) ] (* Separator, Space *) let zs = [ (0x00020,0x00020); (0x000A0,0x000A0); (0x01680,0x01680); (0x02000,0x0200B); (0x0202F,0x0202F); (0x0205F,0x0205F); (0x03000,0x03000) ] (* Separator, Line *) let zl = [ (0x02028,0x02028) ] (* Separator, Paragraph *) let zp = [ (0x02029,0x02029) ] (* Other, Control *) let cc = [ (0x00000,0x0001F); (0x0007F,0x0009F) ] (* Other, Format *) let cf = [ (0x006DD,0x006DD); (0x0070F,0x0070F); (0x0180E,0x0180E); (0x0200C,0x0200F); (0x0202A,0x0202E); (0x02060,0x02063); (0x0206A,0x0206F); (0x0FEFF,0x0FEFF); (0x0FFF9,0x0FFFB); (0x1D173,0x1D17A); (0xE0001,0xE0001); (0xE0020,0xE007F) ] (* Other, Surrogate *) let cs = [ (0x0D800,0x0DEFE); (0x0DFFF,0x0DFFF) ] (* Other, Private Use *) let co = [ (0x0E000,0x0F8FF) ] (* Other, Not Assigned *) let cn = [ (0x00221,0x00221); (0x00234,0x0024F); (0x002AE,0x002AF); (0x002EF,0x002FF); (0x00350,0x0035F); (0x00370,0x00373); (0x00376,0x00379); (0x0037B,0x0037D); (0x0037F,0x00383); (0x0038B,0x0038B); (0x0038D,0x0038D); (0x003A2,0x003A2); (0x003CF,0x003CF); (0x003F7,0x003FF); (0x00487,0x00487); (0x004CF,0x004CF); (0x004F6,0x004F7); (0x004FA,0x004FF); (0x00510,0x00530); (0x00557,0x00558); (0x00560,0x00560); (0x00588,0x00588); (0x0058B,0x00590); (0x005A2,0x005A2); (0x005BA,0x005BA); (0x005C5,0x005CF); (0x005EB,0x005EF); (0x005F5,0x0060B); (0x0060D,0x0061A); (0x0061C,0x0061E); (0x00620,0x00620); (0x0063B,0x0063F); (0x00656,0x0065F); (0x006EE,0x006EF); (0x006FF,0x006FF); (0x0070E,0x0070E); (0x0072D,0x0072F); (0x0074B,0x0077F); (0x007B2,0x00900); (0x00904,0x00904); (0x0093A,0x0093B); (0x0094E,0x0094F); (0x00955,0x00957); (0x00971,0x00980); (0x00984,0x00984); (0x0098D,0x0098E); (0x00991,0x00992); (0x009A9,0x009A9); (0x009B1,0x009B1); (0x009B3,0x009B5); (0x009BA,0x009BB); (0x009BD,0x009BD); (0x009C5,0x009C6); (0x009C9,0x009CA); (0x009CE,0x009D6); (0x009D8,0x009DB); (0x009DE,0x009DE); (0x009E4,0x009E5); (0x009FB,0x00A01); (0x00A03,0x00A04); (0x00A0B,0x00A0E); (0x00A11,0x00A12); (0x00A29,0x00A29); (0x00A31,0x00A31); (0x00A34,0x00A34); (0x00A37,0x00A37); (0x00A3A,0x00A3B); (0x00A3D,0x00A3D); (0x00A43,0x00A46); (0x00A49,0x00A4A); (0x00A4E,0x00A58); (0x00A5D,0x00A5D); (0x00A5F,0x00A65); (0x00A75,0x00A80); (0x00A84,0x00A84); (0x00A8C,0x00A8C); (0x00A8E,0x00A8E); (0x00A92,0x00A92); (0x00AA9,0x00AA9); (0x00AB1,0x00AB1); (0x00AB4,0x00AB4); (0x00ABA,0x00ABB); (0x00AC6,0x00AC6); (0x00ACA,0x00ACA); (0x00ACE,0x00ACF); (0x00AD1,0x00ADF); (0x00AE1,0x00AE5); (0x00AF0,0x00B00); (0x00B04,0x00B04); (0x00B0D,0x00B0E); (0x00B11,0x00B12); (0x00B29,0x00B29); (0x00B31,0x00B31); (0x00B34,0x00B35); (0x00B3A,0x00B3B); (0x00B44,0x00B46); (0x00B49,0x00B4A); (0x00B4E,0x00B55); (0x00B58,0x00B5B); (0x00B5E,0x00B5E); (0x00B62,0x00B65); (0x00B71,0x00B81); (0x00B84,0x00B84); (0x00B8B,0x00B8D); (0x00B91,0x00B91); (0x00B96,0x00B98); (0x00B9B,0x00B9B); (0x00B9D,0x00B9D); (0x00BA0,0x00BA2); (0x00BA5,0x00BA7); (0x00BAB,0x00BAD); (0x00BB6,0x00BB6); (0x00BBA,0x00BBD); (0x00BC3,0x00BC5); (0x00BC9,0x00BC9); (0x00BCE,0x00BD6); (0x00BD8,0x00BE6); (0x00BF3,0x00C00); (0x00C04,0x00C04); (0x00C0D,0x00C0D); (0x00C11,0x00C11); (0x00C29,0x00C29); (0x00C34,0x00C34); (0x00C3A,0x00C3D); (0x00C45,0x00C45); (0x00C49,0x00C49); (0x00C4E,0x00C54); (0x00C57,0x00C5F); (0x00C62,0x00C65); (0x00C70,0x00C81); (0x00C84,0x00C84); (0x00C8D,0x00C8D); (0x00C91,0x00C91); (0x00CA9,0x00CA9); (0x00CB4,0x00CB4); (0x00CBA,0x00CBD); (0x00CC5,0x00CC5); (0x00CC9,0x00CC9); (0x00CCE,0x00CD4); (0x00CD7,0x00CDD); (0x00CDF,0x00CDF); (0x00CE2,0x00CE5); (0x00CF0,0x00D01); (0x00D04,0x00D04); (0x00D0D,0x00D0D); (0x00D11,0x00D11); (0x00D29,0x00D29); (0x00D3A,0x00D3D); (0x00D44,0x00D45); (0x00D49,0x00D49); (0x00D4E,0x00D56); (0x00D58,0x00D5F); (0x00D62,0x00D65); (0x00D70,0x00D81); (0x00D84,0x00D84); (0x00D97,0x00D99); (0x00DB2,0x00DB2); (0x00DBC,0x00DBC); (0x00DBE,0x00DBF); (0x00DC7,0x00DC9); (0x00DCB,0x00DCE); (0x00DD5,0x00DD5); (0x00DD7,0x00DD7); (0x00DE0,0x00DF1); (0x00DF5,0x00E00); (0x00E3B,0x00E3E); (0x00E5C,0x00E80); (0x00E83,0x00E83); (0x00E85,0x00E86); (0x00E89,0x00E89); (0x00E8B,0x00E8C); (0x00E8E,0x00E93); (0x00E98,0x00E98); (0x00EA0,0x00EA0); (0x00EA4,0x00EA4); (0x00EA6,0x00EA6); (0x00EA8,0x00EA9); (0x00EAC,0x00EAC); (0x00EBA,0x00EBA); (0x00EBE,0x00EBF); (0x00EC5,0x00EC5); (0x00EC7,0x00EC7); (0x00ECE,0x00ECF); (0x00EDA,0x00EDB); (0x00EDE,0x00EFF); (0x00F48,0x00F48); (0x00F6B,0x00F70); (0x00F8C,0x00F8F); (0x00F98,0x00F98); (0x00FBD,0x00FBD); (0x00FCD,0x00FCE); (0x00FD0,0x00FFF); (0x01022,0x01022); (0x01028,0x01028); (0x0102B,0x0102B); (0x01033,0x01035); (0x0103A,0x0103F); (0x0105A,0x0109F); (0x010C6,0x010CF); (0x010F9,0x010FA); (0x010FC,0x010FF); (0x0115A,0x0115E); (0x011A3,0x011A7); (0x011FA,0x011FF); (0x01207,0x01207); (0x01247,0x01247); (0x01249,0x01249); (0x0124E,0x0124F); (0x01257,0x01257); (0x01259,0x01259); (0x0125E,0x0125F); (0x01287,0x01287); (0x01289,0x01289); (0x0128E,0x0128F); (0x012AF,0x012AF); (0x012B1,0x012B1); (0x012B6,0x012B7); (0x012BF,0x012BF); (0x012C1,0x012C1); (0x012C6,0x012C7); (0x012CF,0x012CF); (0x012D7,0x012D7); (0x012EF,0x012EF); (0x0130F,0x0130F); (0x01311,0x01311); (0x01316,0x01317); (0x0131F,0x0131F); (0x01347,0x01347); (0x0135B,0x01360); (0x0137D,0x0139F); (0x013F5,0x01400); (0x01677,0x0167F); (0x0169D,0x0169F); (0x016F1,0x016FF); (0x0170D,0x0170D); (0x01715,0x0171F); (0x01737,0x0173F); (0x01754,0x0175F); (0x0176D,0x0176D); (0x01771,0x01771); (0x01774,0x0177F); (0x017DD,0x017DF); (0x017EA,0x017FF); (0x0180F,0x0180F); (0x0181A,0x0181F); (0x01878,0x0187F); (0x018AA,0x01DFF); (0x01E9C,0x01E9F); (0x01EFA,0x01EFF); (0x01F16,0x01F17); (0x01F1E,0x01F1F); (0x01F46,0x01F47); (0x01F4E,0x01F4F); (0x01F58,0x01F58); (0x01F5A,0x01F5A); (0x01F5C,0x01F5C); (0x01F5E,0x01F5E); (0x01F7E,0x01F7F); (0x01FB5,0x01FB5); (0x01FC5,0x01FC5); (0x01FD4,0x01FD5); (0x01FDC,0x01FDC); (0x01FF0,0x01FF1); (0x01FF5,0x01FF5); (0x01FFF,0x01FFF); (0x02053,0x02056); (0x02058,0x0205E); (0x02064,0x02069); (0x02072,0x02073); (0x0208F,0x0209F); (0x020B2,0x020CF); (0x020EB,0x020FF); (0x0213B,0x0213C); (0x0214C,0x02152); (0x02184,0x0218F); (0x023CF,0x023FF); (0x02427,0x0243F); (0x0244B,0x0245F); (0x024FF,0x024FF); (0x02614,0x02615); (0x02618,0x02618); (0x0267E,0x0267F); (0x0268A,0x02700); (0x02705,0x02705); (0x0270A,0x0270B); (0x02728,0x02728); (0x0274C,0x0274C); (0x0274E,0x0274E); (0x02753,0x02755); (0x02757,0x02757); (0x0275F,0x02760); (0x02795,0x02797); (0x027B0,0x027B0); (0x027BF,0x027CF); (0x027EC,0x027EF); (0x02B00,0x02E7F); (0x02E9A,0x02E9A); (0x02EF4,0x02EFF); (0x02FD6,0x02FEF); (0x02FFC,0x02FFF); (0x03040,0x03040); (0x03097,0x03098); (0x03100,0x03104); (0x0312D,0x03130); (0x0318F,0x0318F); (0x031B8,0x031EF); (0x0321D,0x0321F); (0x03244,0x03250); (0x0327C,0x0327E); (0x032CC,0x032CF); (0x032FF,0x032FF); (0x03377,0x0337A); (0x033DE,0x033DF); (0x033FF,0x033FF); (0x04DB6,0x04DFF); (0x09FA6,0x09FFF); (0x0A48D,0x0A48F); (0x0A4C7,0x0ABFF); (0x0D7A4,0x0D7FF); (0x0DEFF,0x0DFFE); (0x0FA2E,0x0FA2F); (0x0FA6B,0x0FAFF); (0x0FB07,0x0FB12); (0x0FB18,0x0FB1C); (0x0FB37,0x0FB37); (0x0FB3D,0x0FB3D); (0x0FB3F,0x0FB3F); (0x0FB42,0x0FB42); (0x0FB45,0x0FB45); (0x0FBB2,0x0FBD2); (0x0FD40,0x0FD4F); (0x0FD90,0x0FD91); (0x0FDC8,0x0FDEF); (0x0FDFD,0x0FDFF); (0x0FE10,0x0FE1F); (0x0FE24,0x0FE2F); (0x0FE47,0x0FE48); (0x0FE53,0x0FE53); (0x0FE67,0x0FE67); (0x0FE6C,0x0FE6F); (0x0FE75,0x0FE75); (0x0FEFD,0x0FEFE); (0x0FF00,0x0FF00); (0x0FFBF,0x0FFC1); (0x0FFC8,0x0FFC9); (0x0FFD0,0x0FFD1); (0x0FFD8,0x0FFD9); (0x0FFDD,0x0FFDF); (0x0FFE7,0x0FFE7); (0x0FFEF,0x0FFF8); (0x0FFFE,0x102FF); (0x1031F,0x1031F); (0x10324,0x1032F); (0x1034B,0x103FF); (0x10426,0x10427); (0x1044E,0x1CFFF); (0x1D0F6,0x1D0FF); (0x1D127,0x1D129); (0x1D1DE,0x1D3FF); (0x1D455,0x1D455); (0x1D49D,0x1D49D); (0x1D4A0,0x1D4A1); (0x1D4A3,0x1D4A4); (0x1D4A7,0x1D4A8); (0x1D4AD,0x1D4AD); (0x1D4BA,0x1D4BA); (0x1D4BC,0x1D4BC); (0x1D4C1,0x1D4C1); (0x1D4C4,0x1D4C4); (0x1D506,0x1D506); (0x1D50B,0x1D50C); (0x1D515,0x1D515); (0x1D51D,0x1D51D); (0x1D53A,0x1D53A); (0x1D53F,0x1D53F); (0x1D545,0x1D545); (0x1D547,0x1D549); (0x1D551,0x1D551); (0x1D6A4,0x1D6A7); (0x1D7CA,0x1D7CD); (0x1D800,0x1FFFF); (0x2A6D7,0x2F7FF); (0x2FA1E,0xE0000); (0xE0002,0xE001F); (0xE0080,0x7FFFFFFF) ] (* Letter, Modifier *) let lm = [ (0x002B0,0x002B8); (0x002BB,0x002C1); (0x002D0,0x002D1); (0x002E0,0x002E4); (0x002EE,0x002EE); (0x0037A,0x0037A); (0x00559,0x00559); (0x00640,0x00640); (0x006E5,0x006E6); (0x00E46,0x00E46); (0x00EC6,0x00EC6); (0x017D7,0x017D7); (0x01843,0x01843); (0x03005,0x03005); (0x03031,0x03035); (0x0303B,0x0303B); (0x0309D,0x0309E); (0x030FC,0x030FE); (0x0FF70,0x0FF70); (0x0FF9E,0x0FF9F) ] (* Letter, Other *) let lo = [ (0x001BB,0x001BB); (0x001C0,0x001C3); (0x005D0,0x005EA); (0x005F0,0x005F2); (0x00621,0x0063A); (0x00641,0x0064A); (0x0066E,0x0066F); (0x00671,0x006D3); (0x006D5,0x006D5); (0x006FA,0x006FC); (0x00710,0x00710); (0x00712,0x0072C); (0x00780,0x007A5); (0x007B1,0x007B1); (0x00905,0x00939); (0x0093D,0x0093D); (0x00950,0x00950); (0x00958,0x00961); (0x00985,0x0098C); (0x0098F,0x00990); (0x00993,0x009A8); (0x009AA,0x009B0); (0x009B2,0x009B2); (0x009B6,0x009B9); (0x009DC,0x009DD); (0x009DF,0x009E1); (0x009F0,0x009F1); (0x00A05,0x00A0A); (0x00A0F,0x00A10); (0x00A13,0x00A28); (0x00A2A,0x00A30); (0x00A32,0x00A33); (0x00A35,0x00A36); (0x00A38,0x00A39); (0x00A59,0x00A5C); (0x00A5E,0x00A5E); (0x00A72,0x00A74); (0x00A85,0x00A8B); (0x00A8D,0x00A8D); (0x00A8F,0x00A91); (0x00A93,0x00AA8); (0x00AAA,0x00AB0); (0x00AB2,0x00AB3); (0x00AB5,0x00AB9); (0x00ABD,0x00ABD); (0x00AD0,0x00AD0); (0x00AE0,0x00AE0); (0x00B05,0x00B0C); (0x00B0F,0x00B10); (0x00B13,0x00B28); (0x00B2A,0x00B30); (0x00B32,0x00B33); (0x00B36,0x00B39); (0x00B3D,0x00B3D); (0x00B5C,0x00B5D); (0x00B5F,0x00B61); (0x00B83,0x00B83); (0x00B85,0x00B8A); (0x00B8E,0x00B90); (0x00B92,0x00B95); (0x00B99,0x00B9A); (0x00B9C,0x00B9C); (0x00B9E,0x00B9F); (0x00BA3,0x00BA4); (0x00BA8,0x00BAA); (0x00BAE,0x00BB5); (0x00BB7,0x00BB9); (0x00C05,0x00C0C); (0x00C0E,0x00C10); (0x00C12,0x00C28); (0x00C2A,0x00C33); (0x00C35,0x00C39); (0x00C60,0x00C61); (0x00C85,0x00C8C); (0x00C8E,0x00C90); (0x00C92,0x00CA8); (0x00CAA,0x00CB3); (0x00CB5,0x00CB9); (0x00CDE,0x00CDE); (0x00CE0,0x00CE1); (0x00D05,0x00D0C); (0x00D0E,0x00D10); (0x00D12,0x00D28); (0x00D2A,0x00D39); (0x00D60,0x00D61); (0x00D85,0x00D96); (0x00D9A,0x00DB1); (0x00DB3,0x00DBB); (0x00DBD,0x00DBD); (0x00DC0,0x00DC6); (0x00E01,0x00E30); (0x00E32,0x00E33); (0x00E40,0x00E45); (0x00E81,0x00E82); (0x00E84,0x00E84); (0x00E87,0x00E88); (0x00E8A,0x00E8A); (0x00E8D,0x00E8D); (0x00E94,0x00E97); (0x00E99,0x00E9F); (0x00EA1,0x00EA3); (0x00EA5,0x00EA5); (0x00EA7,0x00EA7); (0x00EAA,0x00EAB); (0x00EAD,0x00EB0); (0x00EB2,0x00EB3); (0x00EBD,0x00EBD); (0x00EC0,0x00EC4); (0x00EDC,0x00EDD); (0x00F00,0x00F00); (0x00F40,0x00F47); (0x00F49,0x00F6A); (0x00F88,0x00F8B); (0x01000,0x01021); (0x01023,0x01027); (0x01029,0x0102A); (0x01050,0x01055); (0x010D0,0x010F8); (0x01100,0x01159); (0x0115F,0x011A2); (0x011A8,0x011F9); (0x01200,0x01206); (0x01208,0x01246); (0x01248,0x01248); (0x0124A,0x0124D); (0x01250,0x01256); (0x01258,0x01258); (0x0125A,0x0125D); (0x01260,0x01286); (0x01288,0x01288); (0x0128A,0x0128D); (0x01290,0x012AE); (0x012B0,0x012B0); (0x012B2,0x012B5); (0x012B8,0x012BE); (0x012C0,0x012C0); (0x012C2,0x012C5); (0x012C8,0x012CE); (0x012D0,0x012D6); (0x012D8,0x012EE); (0x012F0,0x0130E); (0x01310,0x01310); (0x01312,0x01315); (0x01318,0x0131E); (0x01320,0x01346); (0x01348,0x0135A); (0x013A0,0x013F4); (0x01401,0x0166C); (0x0166F,0x01676); (0x01681,0x0169A); (0x016A0,0x016EA); (0x01700,0x0170C); (0x0170E,0x01711); (0x01720,0x01731); (0x01740,0x01751); (0x01760,0x0176C); (0x0176E,0x01770); (0x01780,0x017B3); (0x017DC,0x017DC); (0x01820,0x01842); (0x01844,0x01877); (0x01880,0x018A8); (0x02135,0x02138); (0x03006,0x03006); (0x0303C,0x0303C); (0x03041,0x03096); (0x0309F,0x0309F); (0x030A1,0x030FA); (0x030FF,0x030FF); (0x03105,0x0312C); (0x03131,0x0318E); (0x031A0,0x031B7); (0x031F0,0x031FF); (0x03400,0x04DB5); (0x04E00,0x09FA5); (0x0A000,0x0A48C); (0x0AC00,0x0D7A3); (0x0F900,0x0FA2D); (0x0FA30,0x0FA6A); (0x0FB1D,0x0FB1D); (0x0FB1F,0x0FB28); (0x0FB2A,0x0FB36); (0x0FB38,0x0FB3C); (0x0FB3E,0x0FB3E); (0x0FB40,0x0FB41); (0x0FB43,0x0FB44); (0x0FB46,0x0FBB1); (0x0FBD3,0x0FD3D); (0x0FD50,0x0FD8F); (0x0FD92,0x0FDC7); (0x0FDF0,0x0FDFB); (0x0FE70,0x0FE74); (0x0FE76,0x0FEFC); (0x0FF66,0x0FF6F); (0x0FF71,0x0FF9D); (0x0FFA0,0x0FFBE); (0x0FFC2,0x0FFC7); (0x0FFCA,0x0FFCF); (0x0FFD2,0x0FFD7); (0x0FFDA,0x0FFDC); (0x10300,0x1031E); (0x10330,0x10349); (0x20000,0x2A6D6); (0x2F800,0x2FA1D) ] (* Punctuation, Connector *) let pc = [ (0x0005F,0x0005F); (0x0203F,0x02040); (0x030FB,0x030FB); (0x0FE33,0x0FE34); (0x0FE4D,0x0FE4F); (0x0FF3F,0x0FF3F); (0x0FF65,0x0FF65) ] (* Punctuation, Dash *) let pd = [ (0x0002D,0x0002D); (0x000AD,0x000AD); (0x0058A,0x0058A); (0x01806,0x01806); (0x02010,0x02015); (0x0301C,0x0301C); (0x03030,0x03030); (0x030A0,0x030A0); (0x0FE31,0x0FE32); (0x0FE58,0x0FE58); (0x0FE63,0x0FE63); (0x0FF0D,0x0FF0D) ] (* Punctuation, Open *) let ps = [ (0x00028,0x00028); (0x0005B,0x0005B); (0x0007B,0x0007B); (0x00F3A,0x00F3A); (0x00F3C,0x00F3C); (0x0169B,0x0169B); (0x0201A,0x0201A); (0x0201E,0x0201E); (0x02045,0x02045); (0x0207D,0x0207D); (0x0208D,0x0208D); (0x02329,0x02329); (0x023B4,0x023B4); (0x02768,0x02768); (0x0276A,0x0276A); (0x0276C,0x0276C); (0x0276E,0x0276E); (0x02770,0x02770); (0x02772,0x02772); (0x02774,0x02774); (0x027E6,0x027E6); (0x027E8,0x027E8); (0x027EA,0x027EA); (0x02983,0x02983); (0x02985,0x02985); (0x02987,0x02987); (0x02989,0x02989); (0x0298B,0x0298B); (0x0298D,0x0298D); (0x0298F,0x0298F); (0x02991,0x02991); (0x02993,0x02993); (0x02995,0x02995); (0x02997,0x02997); (0x029D8,0x029D8); (0x029DA,0x029DA); (0x029FC,0x029FC); (0x03008,0x03008); (0x0300A,0x0300A); (0x0300C,0x0300C); (0x0300E,0x0300E); (0x03010,0x03010); (0x03014,0x03014); (0x03016,0x03016); (0x03018,0x03018); (0x0301A,0x0301A); (0x0301D,0x0301D); (0x0FD3E,0x0FD3E); (0x0FE35,0x0FE35); (0x0FE37,0x0FE37); (0x0FE39,0x0FE39); (0x0FE3B,0x0FE3B); (0x0FE3D,0x0FE3D); (0x0FE3F,0x0FE3F); (0x0FE41,0x0FE41); (0x0FE43,0x0FE43); (0x0FE59,0x0FE59); (0x0FE5B,0x0FE5B); (0x0FE5D,0x0FE5D); (0x0FF08,0x0FF08); (0x0FF3B,0x0FF3B); (0x0FF5B,0x0FF5B); (0x0FF5F,0x0FF5F); (0x0FF62,0x0FF62) ] (* Punctuation, Close *) let pe = [ (0x00029,0x00029); (0x0005D,0x0005D); (0x0007D,0x0007D); (0x00F3B,0x00F3B); (0x00F3D,0x00F3D); (0x0169C,0x0169C); (0x02046,0x02046); (0x0207E,0x0207E); (0x0208E,0x0208E); (0x0232A,0x0232A); (0x023B5,0x023B5); (0x02769,0x02769); (0x0276B,0x0276B); (0x0276D,0x0276D); (0x0276F,0x0276F); (0x02771,0x02771); (0x02773,0x02773); (0x02775,0x02775); (0x027E7,0x027E7); (0x027E9,0x027E9); (0x027EB,0x027EB); (0x02984,0x02984); (0x02986,0x02986); (0x02988,0x02988); (0x0298A,0x0298A); (0x0298C,0x0298C); (0x0298E,0x0298E); (0x02990,0x02990); (0x02992,0x02992); (0x02994,0x02994); (0x02996,0x02996); (0x02998,0x02998); (0x029D9,0x029D9); (0x029DB,0x029DB); (0x029FD,0x029FD); (0x03009,0x03009); (0x0300B,0x0300B); (0x0300D,0x0300D); (0x0300F,0x0300F); (0x03011,0x03011); (0x03015,0x03015); (0x03017,0x03017); (0x03019,0x03019); (0x0301B,0x0301B); (0x0301E,0x0301F); (0x0FD3F,0x0FD3F); (0x0FE36,0x0FE36); (0x0FE38,0x0FE38); (0x0FE3A,0x0FE3A); (0x0FE3C,0x0FE3C); (0x0FE3E,0x0FE3E); (0x0FE40,0x0FE40); (0x0FE42,0x0FE42); (0x0FE44,0x0FE44); (0x0FE5A,0x0FE5A); (0x0FE5C,0x0FE5C); (0x0FE5E,0x0FE5E); (0x0FF09,0x0FF09); (0x0FF3D,0x0FF3D); (0x0FF5D,0x0FF5D); (0x0FF60,0x0FF60); (0x0FF63,0x0FF63) ] (* Punctuation, Initial quote *) let pi = [ (0x000AB,0x000AB); (0x02018,0x02018); (0x0201B,0x0201C); (0x0201F,0x0201F); (0x02039,0x02039) ] (* Punctuation, Final quote *) let pf = [ (0x000BB,0x000BB); (0x02019,0x02019); (0x0201D,0x0201D); (0x0203A,0x0203A) ] (* Punctuation, Other *) let po = [ (0x00021,0x00023); (0x00025,0x00027); (0x0002A,0x0002A); (0x0002C,0x0002C); (0x0002E,0x0002F); (0x0003A,0x0003B); (0x0003F,0x00040); (0x0005C,0x0005C); (0x000A1,0x000A1); (0x000B7,0x000B7); (0x000BF,0x000BF); (0x0037E,0x0037E); (0x00387,0x00387); (0x0055A,0x0055F); (0x00589,0x00589); (0x005BE,0x005BE); (0x005C0,0x005C0); (0x005C3,0x005C3); (0x005F3,0x005F4); (0x0060C,0x0060C); (0x0061B,0x0061B); (0x0061F,0x0061F); (0x0066A,0x0066D); (0x006D4,0x006D4); (0x00700,0x0070D); (0x00964,0x00965); (0x00970,0x00970); (0x00DF4,0x00DF4); (0x00E4F,0x00E4F); (0x00E5A,0x00E5B); (0x00F04,0x00F12); (0x00F85,0x00F85); (0x0104A,0x0104F); (0x010FB,0x010FB); (0x01361,0x01368); (0x0166D,0x0166E); (0x016EB,0x016ED); (0x01735,0x01736); (0x017D4,0x017D6); (0x017D8,0x017DA); (0x01800,0x01805); (0x01807,0x0180A); (0x02016,0x02017); (0x02020,0x02027); (0x02030,0x02038); (0x0203B,0x0203E); (0x02041,0x02043); (0x02047,0x02051); (0x02057,0x02057); (0x023B6,0x023B6); (0x03001,0x03003); (0x0303D,0x0303D); (0x0FE30,0x0FE30); (0x0FE45,0x0FE46); (0x0FE49,0x0FE4C); (0x0FE50,0x0FE52); (0x0FE54,0x0FE57); (0x0FE5F,0x0FE61); (0x0FE68,0x0FE68); (0x0FE6A,0x0FE6B); (0x0FF01,0x0FF03); (0x0FF05,0x0FF07); (0x0FF0A,0x0FF0A); (0x0FF0C,0x0FF0C); (0x0FF0E,0x0FF0F); (0x0FF1A,0x0FF1B); (0x0FF1F,0x0FF20); (0x0FF3C,0x0FF3C); (0x0FF61,0x0FF61); (0x0FF64,0x0FF64) ] (* Symbol, Math *) let sm = [ (0x0002B,0x0002B); (0x0003C,0x0003E); (0x0007C,0x0007C); (0x0007E,0x0007E); (0x000AC,0x000AC); (0x000B1,0x000B1); (0x000D7,0x000D7); (0x000F7,0x000F7); (0x003F6,0x003F6); (0x02044,0x02044); (0x02052,0x02052); (0x0207A,0x0207C); (0x0208A,0x0208C); (0x02140,0x02144); (0x0214B,0x0214B); (0x02190,0x02194); (0x0219A,0x0219B); (0x021A0,0x021A0); (0x021A3,0x021A3); (0x021A6,0x021A6); (0x021AE,0x021AE); (0x021CE,0x021CF); (0x021D2,0x021D2); (0x021D4,0x021D4); (0x021F4,0x022FF); (0x02308,0x0230B); (0x02320,0x02321); (0x0237C,0x0237C); (0x0239B,0x023B3); (0x025B7,0x025B7); (0x025C1,0x025C1); (0x025F8,0x025FF); (0x0266F,0x0266F); (0x027D0,0x027E5); (0x027F0,0x027FF); (0x02900,0x02982); (0x02999,0x029D7); (0x029DC,0x029FB); (0x029FE,0x02AFF); (0x0FB29,0x0FB29); (0x0FE62,0x0FE62); (0x0FE64,0x0FE66); (0x0FF0B,0x0FF0B); (0x0FF1C,0x0FF1E); (0x0FF5C,0x0FF5C); (0x0FF5E,0x0FF5E); (0x0FFE2,0x0FFE2); (0x0FFE9,0x0FFEC); (0x1D6C1,0x1D6C1); (0x1D6DB,0x1D6DB); (0x1D6FB,0x1D6FB); (0x1D715,0x1D715); (0x1D735,0x1D735); (0x1D74F,0x1D74F); (0x1D76F,0x1D76F); (0x1D789,0x1D789); (0x1D7A9,0x1D7A9); (0x1D7C3,0x1D7C3) ] (* Symbol, Currency *) let sc = [ (0x00024,0x00024); (0x000A2,0x000A5); (0x009F2,0x009F3); (0x00E3F,0x00E3F); (0x017DB,0x017DB); (0x020A0,0x020B1); (0x0FDFC,0x0FDFC); (0x0FE69,0x0FE69); (0x0FF04,0x0FF04); (0x0FFE0,0x0FFE1); (0x0FFE5,0x0FFE6) ] (* Symbol, Modifier *) let sk = [ (0x0005E,0x0005E); (0x00060,0x00060); (0x000A8,0x000A8); (0x000AF,0x000AF); (0x000B4,0x000B4); (0x000B8,0x000B8); (0x002B9,0x002BA); (0x002C2,0x002CF); (0x002D2,0x002DF); (0x002E5,0x002ED); (0x00374,0x00375); (0x00384,0x00385); (0x01FBD,0x01FBD); (0x01FBF,0x01FC1); (0x01FCD,0x01FCF); (0x01FDD,0x01FDF); (0x01FED,0x01FEF); (0x01FFD,0x01FFE); (0x0309B,0x0309C); (0x0FF3E,0x0FF3E); (0x0FF40,0x0FF40); (0x0FFE3,0x0FFE3) ] (* Symbol, Other *) let so = [ (0x000A6,0x000A7); (0x000A9,0x000A9); (0x000AE,0x000AE); (0x000B0,0x000B0); (0x000B6,0x000B6); (0x00482,0x00482); (0x006E9,0x006E9); (0x006FD,0x006FE); (0x009FA,0x009FA); (0x00B70,0x00B70); (0x00F01,0x00F03); (0x00F13,0x00F17); (0x00F1A,0x00F1F); (0x00F34,0x00F34); (0x00F36,0x00F36); (0x00F38,0x00F38); (0x00FBE,0x00FC5); (0x00FC7,0x00FCC); (0x00FCF,0x00FCF); (0x02100,0x02101); (0x02103,0x02106); (0x02108,0x02109); (0x02114,0x02114); (0x02116,0x02118); (0x0211E,0x02123); (0x02125,0x02125); (0x02127,0x02127); (0x02129,0x02129); (0x0212E,0x0212E); (0x02132,0x02132); (0x0213A,0x0213A); (0x0214A,0x0214A); (0x02195,0x02199); (0x0219C,0x0219F); (0x021A1,0x021A2); (0x021A4,0x021A5); (0x021A7,0x021AD); (0x021AF,0x021CD); (0x021D0,0x021D1); (0x021D3,0x021D3); (0x021D5,0x021F3); (0x02300,0x02307); (0x0230C,0x0231F); (0x02322,0x02328); (0x0232B,0x0237B); (0x0237D,0x0239A); (0x023B7,0x023CE); (0x02400,0x02426); (0x02440,0x0244A); (0x0249C,0x024E9); (0x02500,0x025B6); (0x025B8,0x025C0); (0x025C2,0x025F7); (0x02600,0x02613); (0x02616,0x02617); (0x02619,0x0266E); (0x02670,0x0267D); (0x02680,0x02689); (0x02701,0x02704); (0x02706,0x02709); (0x0270C,0x02727); (0x02729,0x0274B); (0x0274D,0x0274D); (0x0274F,0x02752); (0x02756,0x02756); (0x02758,0x0275E); (0x02761,0x02767); (0x02794,0x02794); (0x02798,0x027AF); (0x027B1,0x027BE); (0x02800,0x028FF); (0x02E80,0x02E99); (0x02E9B,0x02EF3); (0x02F00,0x02FD5); (0x02FF0,0x02FFB); (0x03004,0x03004); (0x03012,0x03013); (0x03020,0x03020); (0x03036,0x03037); (0x0303E,0x0303F); (0x03190,0x03191); (0x03196,0x0319F); (0x03200,0x0321C); (0x0322A,0x03243); (0x03260,0x0327B); (0x0327F,0x0327F); (0x0328A,0x032B0); (0x032C0,0x032CB); (0x032D0,0x032FE); (0x03300,0x03376); (0x0337B,0x033DD); (0x033E0,0x033FE); (0x0A490,0x0A4C6); (0x0FFE4,0x0FFE4); (0x0FFE8,0x0FFE8); (0x0FFED,0x0FFEE); (0x0FFFC,0x0FFFD); (0x1D000,0x1D0F5); (0x1D100,0x1D126); (0x1D12A,0x1D164); (0x1D16A,0x1D16C); (0x1D183,0x1D184); (0x1D18C,0x1D1A9); (0x1D1AE,0x1D1DD) ] (* Conversion to lower case. *) let to_lower = [ (0x00041,0x0005A), `Delta (32); (0x000C0,0x000D6), `Delta (32); (0x000D8,0x000DE), `Delta (32); (0x00100,0x00100), `Abs (0x00101); (0x00102,0x00102), `Abs (0x00103); (0x00104,0x00104), `Abs (0x00105); (0x00106,0x00106), `Abs (0x00107); (0x00108,0x00108), `Abs (0x00109); (0x0010A,0x0010A), `Abs (0x0010B); (0x0010C,0x0010C), `Abs (0x0010D); (0x0010E,0x0010E), `Abs (0x0010F); (0x00110,0x00110), `Abs (0x00111); (0x00112,0x00112), `Abs (0x00113); (0x00114,0x00114), `Abs (0x00115); (0x00116,0x00116), `Abs (0x00117); (0x00118,0x00118), `Abs (0x00119); (0x0011A,0x0011A), `Abs (0x0011B); (0x0011C,0x0011C), `Abs (0x0011D); (0x0011E,0x0011E), `Abs (0x0011F); (0x00120,0x00120), `Abs (0x00121); (0x00122,0x00122), `Abs (0x00123); (0x00124,0x00124), `Abs (0x00125); (0x00126,0x00126), `Abs (0x00127); (0x00128,0x00128), `Abs (0x00129); (0x0012A,0x0012A), `Abs (0x0012B); (0x0012C,0x0012C), `Abs (0x0012D); (0x0012E,0x0012E), `Abs (0x0012F); (0x00130,0x00130), `Abs (0x00069); (0x00132,0x00132), `Abs (0x00133); (0x00134,0x00134), `Abs (0x00135); (0x00136,0x00136), `Abs (0x00137); (0x00139,0x00139), `Abs (0x0013A); (0x0013B,0x0013B), `Abs (0x0013C); (0x0013D,0x0013D), `Abs (0x0013E); (0x0013F,0x0013F), `Abs (0x00140); (0x00141,0x00141), `Abs (0x00142); (0x00143,0x00143), `Abs (0x00144); (0x00145,0x00145), `Abs (0x00146); (0x00147,0x00147), `Abs (0x00148); (0x0014A,0x0014A), `Abs (0x0014B); (0x0014C,0x0014C), `Abs (0x0014D); (0x0014E,0x0014E), `Abs (0x0014F); (0x00150,0x00150), `Abs (0x00151); (0x00152,0x00152), `Abs (0x00153); (0x00154,0x00154), `Abs (0x00155); (0x00156,0x00156), `Abs (0x00157); (0x00158,0x00158), `Abs (0x00159); (0x0015A,0x0015A), `Abs (0x0015B); (0x0015C,0x0015C), `Abs (0x0015D); (0x0015E,0x0015E), `Abs (0x0015F); (0x00160,0x00160), `Abs (0x00161); (0x00162,0x00162), `Abs (0x00163); (0x00164,0x00164), `Abs (0x00165); (0x00166,0x00166), `Abs (0x00167); (0x00168,0x00168), `Abs (0x00169); (0x0016A,0x0016A), `Abs (0x0016B); (0x0016C,0x0016C), `Abs (0x0016D); (0x0016E,0x0016E), `Abs (0x0016F); (0x00170,0x00170), `Abs (0x00171); (0x00172,0x00172), `Abs (0x00173); (0x00174,0x00174), `Abs (0x00175); (0x00176,0x00176), `Abs (0x00177); (0x00178,0x00178), `Abs (0x000FF); (0x00179,0x00179), `Abs (0x0017A); (0x0017B,0x0017B), `Abs (0x0017C); (0x0017D,0x0017D), `Abs (0x0017E); (0x00181,0x00181), `Abs (0x00253); (0x00182,0x00182), `Abs (0x00183); (0x00184,0x00184), `Abs (0x00185); (0x00186,0x00186), `Abs (0x00254); (0x00187,0x00187), `Abs (0x00188); (0x00189,0x0018A), `Delta (205); (0x0018B,0x0018B), `Abs (0x0018C); (0x0018E,0x0018E), `Abs (0x001DD); (0x0018F,0x0018F), `Abs (0x00259); (0x00190,0x00190), `Abs (0x0025B); (0x00191,0x00191), `Abs (0x00192); (0x00193,0x00193), `Abs (0x00260); (0x00194,0x00194), `Abs (0x00263); (0x00196,0x00196), `Abs (0x00269); (0x00197,0x00197), `Abs (0x00268); (0x00198,0x00198), `Abs (0x00199); (0x0019C,0x0019C), `Abs (0x0026F); (0x0019D,0x0019D), `Abs (0x00272); (0x0019F,0x0019F), `Abs (0x00275); (0x001A0,0x001A0), `Abs (0x001A1); (0x001A2,0x001A2), `Abs (0x001A3); (0x001A4,0x001A4), `Abs (0x001A5); (0x001A6,0x001A6), `Abs (0x00280); (0x001A7,0x001A7), `Abs (0x001A8); (0x001A9,0x001A9), `Abs (0x00283); (0x001AC,0x001AC), `Abs (0x001AD); (0x001AE,0x001AE), `Abs (0x00288); (0x001AF,0x001AF), `Abs (0x001B0); (0x001B1,0x001B2), `Delta (217); (0x001B3,0x001B3), `Abs (0x001B4); (0x001B5,0x001B5), `Abs (0x001B6); (0x001B7,0x001B7), `Abs (0x00292); (0x001B8,0x001B8), `Abs (0x001B9); (0x001BC,0x001BC), `Abs (0x001BD); (0x001C4,0x001C4), `Abs (0x001C6); (0x001C7,0x001C7), `Abs (0x001C9); (0x001CA,0x001CA), `Abs (0x001CC); (0x001CD,0x001CD), `Abs (0x001CE); (0x001CF,0x001CF), `Abs (0x001D0); (0x001D1,0x001D1), `Abs (0x001D2); (0x001D3,0x001D3), `Abs (0x001D4); (0x001D5,0x001D5), `Abs (0x001D6); (0x001D7,0x001D7), `Abs (0x001D8); (0x001D9,0x001D9), `Abs (0x001DA); (0x001DB,0x001DB), `Abs (0x001DC); (0x001DE,0x001DE), `Abs (0x001DF); (0x001E0,0x001E0), `Abs (0x001E1); (0x001E2,0x001E2), `Abs (0x001E3); (0x001E4,0x001E4), `Abs (0x001E5); (0x001E6,0x001E6), `Abs (0x001E7); (0x001E8,0x001E8), `Abs (0x001E9); (0x001EA,0x001EA), `Abs (0x001EB); (0x001EC,0x001EC), `Abs (0x001ED); (0x001EE,0x001EE), `Abs (0x001EF); (0x001F1,0x001F1), `Abs (0x001F3); (0x001F4,0x001F4), `Abs (0x001F5); (0x001F6,0x001F6), `Abs (0x00195); (0x001F7,0x001F7), `Abs (0x001BF); (0x001F8,0x001F8), `Abs (0x001F9); (0x001FA,0x001FA), `Abs (0x001FB); (0x001FC,0x001FC), `Abs (0x001FD); (0x001FE,0x001FE), `Abs (0x001FF); (0x00200,0x00200), `Abs (0x00201); (0x00202,0x00202), `Abs (0x00203); (0x00204,0x00204), `Abs (0x00205); (0x00206,0x00206), `Abs (0x00207); (0x00208,0x00208), `Abs (0x00209); (0x0020A,0x0020A), `Abs (0x0020B); (0x0020C,0x0020C), `Abs (0x0020D); (0x0020E,0x0020E), `Abs (0x0020F); (0x00210,0x00210), `Abs (0x00211); (0x00212,0x00212), `Abs (0x00213); (0x00214,0x00214), `Abs (0x00215); (0x00216,0x00216), `Abs (0x00217); (0x00218,0x00218), `Abs (0x00219); (0x0021A,0x0021A), `Abs (0x0021B); (0x0021C,0x0021C), `Abs (0x0021D); (0x0021E,0x0021E), `Abs (0x0021F); (0x00220,0x00220), `Abs (0x0019E); (0x00222,0x00222), `Abs (0x00223); (0x00224,0x00224), `Abs (0x00225); (0x00226,0x00226), `Abs (0x00227); (0x00228,0x00228), `Abs (0x00229); (0x0022A,0x0022A), `Abs (0x0022B); (0x0022C,0x0022C), `Abs (0x0022D); (0x0022E,0x0022E), `Abs (0x0022F); (0x00230,0x00230), `Abs (0x00231); (0x00232,0x00232), `Abs (0x00233); (0x00386,0x00386), `Abs (0x003AC); (0x00388,0x0038A), `Delta (37); (0x0038C,0x0038C), `Abs (0x003CC); (0x0038E,0x0038F), `Delta (63); (0x00391,0x003A1), `Delta (32); (0x003A3,0x003AB), `Delta (32); (0x003D8,0x003D8), `Abs (0x003D9); (0x003DA,0x003DA), `Abs (0x003DB); (0x003DC,0x003DC), `Abs (0x003DD); (0x003DE,0x003DE), `Abs (0x003DF); (0x003E0,0x003E0), `Abs (0x003E1); (0x003E2,0x003E2), `Abs (0x003E3); (0x003E4,0x003E4), `Abs (0x003E5); (0x003E6,0x003E6), `Abs (0x003E7); (0x003E8,0x003E8), `Abs (0x003E9); (0x003EA,0x003EA), `Abs (0x003EB); (0x003EC,0x003EC), `Abs (0x003ED); (0x003EE,0x003EE), `Abs (0x003EF); (0x003F4,0x003F4), `Abs (0x003B8); (0x00400,0x0040F), `Delta (80); (0x00410,0x0042F), `Delta (32); (0x00460,0x00460), `Abs (0x00461); (0x00462,0x00462), `Abs (0x00463); (0x00464,0x00464), `Abs (0x00465); (0x00466,0x00466), `Abs (0x00467); (0x00468,0x00468), `Abs (0x00469); (0x0046A,0x0046A), `Abs (0x0046B); (0x0046C,0x0046C), `Abs (0x0046D); (0x0046E,0x0046E), `Abs (0x0046F); (0x00470,0x00470), `Abs (0x00471); (0x00472,0x00472), `Abs (0x00473); (0x00474,0x00474), `Abs (0x00475); (0x00476,0x00476), `Abs (0x00477); (0x00478,0x00478), `Abs (0x00479); (0x0047A,0x0047A), `Abs (0x0047B); (0x0047C,0x0047C), `Abs (0x0047D); (0x0047E,0x0047E), `Abs (0x0047F); (0x00480,0x00480), `Abs (0x00481); (0x0048A,0x0048A), `Abs (0x0048B); (0x0048C,0x0048C), `Abs (0x0048D); (0x0048E,0x0048E), `Abs (0x0048F); (0x00490,0x00490), `Abs (0x00491); (0x00492,0x00492), `Abs (0x00493); (0x00494,0x00494), `Abs (0x00495); (0x00496,0x00496), `Abs (0x00497); (0x00498,0x00498), `Abs (0x00499); (0x0049A,0x0049A), `Abs (0x0049B); (0x0049C,0x0049C), `Abs (0x0049D); (0x0049E,0x0049E), `Abs (0x0049F); (0x004A0,0x004A0), `Abs (0x004A1); (0x004A2,0x004A2), `Abs (0x004A3); (0x004A4,0x004A4), `Abs (0x004A5); (0x004A6,0x004A6), `Abs (0x004A7); (0x004A8,0x004A8), `Abs (0x004A9); (0x004AA,0x004AA), `Abs (0x004AB); (0x004AC,0x004AC), `Abs (0x004AD); (0x004AE,0x004AE), `Abs (0x004AF); (0x004B0,0x004B0), `Abs (0x004B1); (0x004B2,0x004B2), `Abs (0x004B3); (0x004B4,0x004B4), `Abs (0x004B5); (0x004B6,0x004B6), `Abs (0x004B7); (0x004B8,0x004B8), `Abs (0x004B9); (0x004BA,0x004BA), `Abs (0x004BB); (0x004BC,0x004BC), `Abs (0x004BD); (0x004BE,0x004BE), `Abs (0x004BF); (0x004C1,0x004C1), `Abs (0x004C2); (0x004C3,0x004C3), `Abs (0x004C4); (0x004C5,0x004C5), `Abs (0x004C6); (0x004C7,0x004C7), `Abs (0x004C8); (0x004C9,0x004C9), `Abs (0x004CA); (0x004CB,0x004CB), `Abs (0x004CC); (0x004CD,0x004CD), `Abs (0x004CE); (0x004D0,0x004D0), `Abs (0x004D1); (0x004D2,0x004D2), `Abs (0x004D3); (0x004D4,0x004D4), `Abs (0x004D5); (0x004D6,0x004D6), `Abs (0x004D7); (0x004D8,0x004D8), `Abs (0x004D9); (0x004DA,0x004DA), `Abs (0x004DB); (0x004DC,0x004DC), `Abs (0x004DD); (0x004DE,0x004DE), `Abs (0x004DF); (0x004E0,0x004E0), `Abs (0x004E1); (0x004E2,0x004E2), `Abs (0x004E3); (0x004E4,0x004E4), `Abs (0x004E5); (0x004E6,0x004E6), `Abs (0x004E7); (0x004E8,0x004E8), `Abs (0x004E9); (0x004EA,0x004EA), `Abs (0x004EB); (0x004EC,0x004EC), `Abs (0x004ED); (0x004EE,0x004EE), `Abs (0x004EF); (0x004F0,0x004F0), `Abs (0x004F1); (0x004F2,0x004F2), `Abs (0x004F3); (0x004F4,0x004F4), `Abs (0x004F5); (0x004F8,0x004F8), `Abs (0x004F9); (0x00500,0x00500), `Abs (0x00501); (0x00502,0x00502), `Abs (0x00503); (0x00504,0x00504), `Abs (0x00505); (0x00506,0x00506), `Abs (0x00507); (0x00508,0x00508), `Abs (0x00509); (0x0050A,0x0050A), `Abs (0x0050B); (0x0050C,0x0050C), `Abs (0x0050D); (0x0050E,0x0050E), `Abs (0x0050F); (0x00531,0x00556), `Delta (48); (0x01E00,0x01E00), `Abs (0x01E01); (0x01E02,0x01E02), `Abs (0x01E03); (0x01E04,0x01E04), `Abs (0x01E05); (0x01E06,0x01E06), `Abs (0x01E07); (0x01E08,0x01E08), `Abs (0x01E09); (0x01E0A,0x01E0A), `Abs (0x01E0B); (0x01E0C,0x01E0C), `Abs (0x01E0D); (0x01E0E,0x01E0E), `Abs (0x01E0F); (0x01E10,0x01E10), `Abs (0x01E11); (0x01E12,0x01E12), `Abs (0x01E13); (0x01E14,0x01E14), `Abs (0x01E15); (0x01E16,0x01E16), `Abs (0x01E17); (0x01E18,0x01E18), `Abs (0x01E19); (0x01E1A,0x01E1A), `Abs (0x01E1B); (0x01E1C,0x01E1C), `Abs (0x01E1D); (0x01E1E,0x01E1E), `Abs (0x01E1F); (0x01E20,0x01E20), `Abs (0x01E21); (0x01E22,0x01E22), `Abs (0x01E23); (0x01E24,0x01E24), `Abs (0x01E25); (0x01E26,0x01E26), `Abs (0x01E27); (0x01E28,0x01E28), `Abs (0x01E29); (0x01E2A,0x01E2A), `Abs (0x01E2B); (0x01E2C,0x01E2C), `Abs (0x01E2D); (0x01E2E,0x01E2E), `Abs (0x01E2F); (0x01E30,0x01E30), `Abs (0x01E31); (0x01E32,0x01E32), `Abs (0x01E33); (0x01E34,0x01E34), `Abs (0x01E35); (0x01E36,0x01E36), `Abs (0x01E37); (0x01E38,0x01E38), `Abs (0x01E39); (0x01E3A,0x01E3A), `Abs (0x01E3B); (0x01E3C,0x01E3C), `Abs (0x01E3D); (0x01E3E,0x01E3E), `Abs (0x01E3F); (0x01E40,0x01E40), `Abs (0x01E41); (0x01E42,0x01E42), `Abs (0x01E43); (0x01E44,0x01E44), `Abs (0x01E45); (0x01E46,0x01E46), `Abs (0x01E47); (0x01E48,0x01E48), `Abs (0x01E49); (0x01E4A,0x01E4A), `Abs (0x01E4B); (0x01E4C,0x01E4C), `Abs (0x01E4D); (0x01E4E,0x01E4E), `Abs (0x01E4F); (0x01E50,0x01E50), `Abs (0x01E51); (0x01E52,0x01E52), `Abs (0x01E53); (0x01E54,0x01E54), `Abs (0x01E55); (0x01E56,0x01E56), `Abs (0x01E57); (0x01E58,0x01E58), `Abs (0x01E59); (0x01E5A,0x01E5A), `Abs (0x01E5B); (0x01E5C,0x01E5C), `Abs (0x01E5D); (0x01E5E,0x01E5E), `Abs (0x01E5F); (0x01E60,0x01E60), `Abs (0x01E61); (0x01E62,0x01E62), `Abs (0x01E63); (0x01E64,0x01E64), `Abs (0x01E65); (0x01E66,0x01E66), `Abs (0x01E67); (0x01E68,0x01E68), `Abs (0x01E69); (0x01E6A,0x01E6A), `Abs (0x01E6B); (0x01E6C,0x01E6C), `Abs (0x01E6D); (0x01E6E,0x01E6E), `Abs (0x01E6F); (0x01E70,0x01E70), `Abs (0x01E71); (0x01E72,0x01E72), `Abs (0x01E73); (0x01E74,0x01E74), `Abs (0x01E75); (0x01E76,0x01E76), `Abs (0x01E77); (0x01E78,0x01E78), `Abs (0x01E79); (0x01E7A,0x01E7A), `Abs (0x01E7B); (0x01E7C,0x01E7C), `Abs (0x01E7D); (0x01E7E,0x01E7E), `Abs (0x01E7F); (0x01E80,0x01E80), `Abs (0x01E81); (0x01E82,0x01E82), `Abs (0x01E83); (0x01E84,0x01E84), `Abs (0x01E85); (0x01E86,0x01E86), `Abs (0x01E87); (0x01E88,0x01E88), `Abs (0x01E89); (0x01E8A,0x01E8A), `Abs (0x01E8B); (0x01E8C,0x01E8C), `Abs (0x01E8D); (0x01E8E,0x01E8E), `Abs (0x01E8F); (0x01E90,0x01E90), `Abs (0x01E91); (0x01E92,0x01E92), `Abs (0x01E93); (0x01E94,0x01E94), `Abs (0x01E95); (0x01EA0,0x01EA0), `Abs (0x01EA1); (0x01EA2,0x01EA2), `Abs (0x01EA3); (0x01EA4,0x01EA4), `Abs (0x01EA5); (0x01EA6,0x01EA6), `Abs (0x01EA7); (0x01EA8,0x01EA8), `Abs (0x01EA9); (0x01EAA,0x01EAA), `Abs (0x01EAB); (0x01EAC,0x01EAC), `Abs (0x01EAD); (0x01EAE,0x01EAE), `Abs (0x01EAF); (0x01EB0,0x01EB0), `Abs (0x01EB1); (0x01EB2,0x01EB2), `Abs (0x01EB3); (0x01EB4,0x01EB4), `Abs (0x01EB5); (0x01EB6,0x01EB6), `Abs (0x01EB7); (0x01EB8,0x01EB8), `Abs (0x01EB9); (0x01EBA,0x01EBA), `Abs (0x01EBB); (0x01EBC,0x01EBC), `Abs (0x01EBD); (0x01EBE,0x01EBE), `Abs (0x01EBF); (0x01EC0,0x01EC0), `Abs (0x01EC1); (0x01EC2,0x01EC2), `Abs (0x01EC3); (0x01EC4,0x01EC4), `Abs (0x01EC5); (0x01EC6,0x01EC6), `Abs (0x01EC7); (0x01EC8,0x01EC8), `Abs (0x01EC9); (0x01ECA,0x01ECA), `Abs (0x01ECB); (0x01ECC,0x01ECC), `Abs (0x01ECD); (0x01ECE,0x01ECE), `Abs (0x01ECF); (0x01ED0,0x01ED0), `Abs (0x01ED1); (0x01ED2,0x01ED2), `Abs (0x01ED3); (0x01ED4,0x01ED4), `Abs (0x01ED5); (0x01ED6,0x01ED6), `Abs (0x01ED7); (0x01ED8,0x01ED8), `Abs (0x01ED9); (0x01EDA,0x01EDA), `Abs (0x01EDB); (0x01EDC,0x01EDC), `Abs (0x01EDD); (0x01EDE,0x01EDE), `Abs (0x01EDF); (0x01EE0,0x01EE0), `Abs (0x01EE1); (0x01EE2,0x01EE2), `Abs (0x01EE3); (0x01EE4,0x01EE4), `Abs (0x01EE5); (0x01EE6,0x01EE6), `Abs (0x01EE7); (0x01EE8,0x01EE8), `Abs (0x01EE9); (0x01EEA,0x01EEA), `Abs (0x01EEB); (0x01EEC,0x01EEC), `Abs (0x01EED); (0x01EEE,0x01EEE), `Abs (0x01EEF); (0x01EF0,0x01EF0), `Abs (0x01EF1); (0x01EF2,0x01EF2), `Abs (0x01EF3); (0x01EF4,0x01EF4), `Abs (0x01EF5); (0x01EF6,0x01EF6), `Abs (0x01EF7); (0x01EF8,0x01EF8), `Abs (0x01EF9); (0x01F08,0x01F0F), `Delta (-8); (0x01F18,0x01F1D), `Delta (-8); (0x01F28,0x01F2F), `Delta (-8); (0x01F38,0x01F3F), `Delta (-8); (0x01F48,0x01F4D), `Delta (-8); (0x01F59,0x01F59), `Abs (0x01F51); (0x01F5B,0x01F5B), `Abs (0x01F53); (0x01F5D,0x01F5D), `Abs (0x01F55); (0x01F5F,0x01F5F), `Abs (0x01F57); (0x01F68,0x01F6F), `Delta (-8); (0x01FB8,0x01FB9), `Delta (-8); (0x01FBA,0x01FBB), `Delta (-74); (0x01FC8,0x01FCB), `Delta (-86); (0x01FD8,0x01FD9), `Delta (-8); (0x01FDA,0x01FDB), `Delta (-100); (0x01FE8,0x01FE9), `Delta (-8); (0x01FEA,0x01FEB), `Delta (-112); (0x01FEC,0x01FEC), `Abs (0x01FE5); (0x01FF8,0x01FF9), `Delta (-128); (0x01FFA,0x01FFB), `Delta (-126); (0x02126,0x02126), `Abs (0x003C9); (0x0212A,0x0212A), `Abs (0x0006B); (0x0212B,0x0212B), `Abs (0x000E5); (0x0FF21,0x0FF3A), `Delta (32); (0x10400,0x10425), `Delta (40); (0x001C5,0x001C5), `Abs (0x001C6); (0x001C8,0x001C8), `Abs (0x001C9); (0x001CB,0x001CB), `Abs (0x001CC); (0x001F2,0x001F2), `Abs (0x001F3); (0x01F88,0x01F8F), `Delta (-8); (0x01F98,0x01F9F), `Delta (-8); (0x01FA8,0x01FAF), `Delta (-8); (0x01FBC,0x01FBC), `Abs (0x01FB3); (0x01FCC,0x01FCC), `Abs (0x01FC3); (0x01FFC,0x01FFC), `Abs (0x01FF3); (0x02160,0x0216F), `Delta (16) ] coq-8.4pl4/lib/fmap.ml0000644000175000017500000000743512326224777013667 0ustar stephsteph module Make = functor (X:Map.OrderedType) -> struct type key = X.t type 'a t = Empty | Node of 'a t * key * 'a * 'a t * int let empty = Empty let is_empty = function Empty -> true | _ -> false let height = function Empty -> 0 | Node(_,_,_,_,h) -> h let create l x d r = let hl = height l and hr = height r in Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) let bal l x d r = let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in if hl > hr + 2 then begin match l with Empty -> invalid_arg "Map.bal" | Node(ll, lv, ld, lr, _) -> if height ll >= height lr then create ll lv ld (create lr x d r) else begin match lr with Empty -> invalid_arg "Map.bal" | Node(lrl, lrv, lrd, lrr, _)-> create (create ll lv ld lrl) lrv lrd (create lrr x d r) end end else if hr > hl + 2 then begin match r with Empty -> invalid_arg "Map.bal" | Node(rl, rv, rd, rr, _) -> if height rr >= height rl then create (create l x d rl) rv rd rr else begin match rl with Empty -> invalid_arg "Map.bal" | Node(rll, rlv, rld, rlr, _) -> create (create l x d rll) rlv rld (create rlr rv rd rr) end end else Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) let rec add x data = function Empty -> Node(Empty, x, data, Empty, 1) | Node(l, v, d, r, h) -> let c = X.compare x v in if c = 0 then Node(l, x, data, r, h) else if c < 0 then bal (add x data l) v d r else bal l v d (add x data r) let rec find x = function Empty -> raise Not_found | Node(l, v, d, r, _) -> let c = X.compare x v in if c = 0 then d else find x (if c < 0 then l else r) let rec mem x = function Empty -> false | Node(l, v, d, r, _) -> let c = X.compare x v in c = 0 || mem x (if c < 0 then l else r) let rec min_binding = function Empty -> raise Not_found | Node(Empty, x, d, r, _) -> (x, d) | Node(l, x, d, r, _) -> min_binding l let rec remove_min_binding = function Empty -> invalid_arg "Map.remove_min_elt" | Node(Empty, x, d, r, _) -> r | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r let merge t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (_, _) -> let (x, d) = min_binding t2 in bal t1 x d (remove_min_binding t2) let rec remove x = function Empty -> Empty | Node(l, v, d, r, h) -> let c = X.compare x v in if c = 0 then merge l r else if c < 0 then bal (remove x l) v d r else bal l v d (remove x r) let rec iter f = function Empty -> () | Node(l, v, d, r, _) -> iter f l; f v d; iter f r let rec map f = function Empty -> Empty | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h) (* Maintien de fold_right par compatibilitÃĐ (changÃĐ en fold_left dans ocaml-3.09.0) *) let rec fold f m accu = match m with Empty -> accu | Node(l, v, d, r, _) -> fold f l (f v d (fold f r accu)) (* Added with respect to ocaml standard library. *) let dom m = fold (fun x _ acc -> x::acc) m [] let rng m = fold (fun _ y acc -> y::acc) m [] let to_list m = fold (fun x y acc -> (x,y)::acc) m [] end coq-8.4pl4/lib/tries.ml0000644000175000017500000000455112326224777014066 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* functor (Y : Map.OrderedType) -> struct module T_dom = Fset.Make(X) module T_codom = Fmap.Make(Y) type t = Node of T_dom.t * t T_codom.t let codom_to_list m = T_codom.fold (fun x y l -> (x,y)::l) m [] let codom_rng m = T_codom.fold (fun _ y acc -> y::acc) m [] let codom_dom m = T_codom.fold (fun x _ acc -> x::acc) m [] let empty = Node (T_dom.empty, T_codom.empty) let map (Node (_,m)) lbl = T_codom.find lbl m let xtract (Node (hereset,_)) = T_dom.elements hereset let dom (Node (_,m)) = codom_dom m let in_dom (Node (_,m)) lbl = T_codom.mem lbl m let is_empty_node (Node(a,b)) = (T_dom.elements a = []) & (codom_to_list b = []) let assure_arc m lbl = if T_codom.mem lbl m then m else T_codom.add lbl (Node (T_dom.empty,T_codom.empty)) m let cleanse_arcs (Node (hereset,m)) = let l = codom_rng m in Node(hereset, if List.for_all is_empty_node l then T_codom.empty else m) let rec at_path f (Node (hereset,m)) = function | [] -> cleanse_arcs (Node(f hereset,m)) | h::t -> let m = assure_arc m h in cleanse_arcs (Node(hereset, T_codom.add h (at_path f (T_codom.find h m) t) m)) let add tm (path,v) = at_path (fun hereset -> T_dom.add v hereset) tm path let rmv tm (path,v) = at_path (fun hereset -> T_dom.remove v hereset) tm path let app f tlm = let rec apprec pfx (Node(hereset,m)) = let path = List.rev pfx in T_dom.iter (fun v -> f(path,v)) hereset; T_codom.iter (fun l tm -> apprec (l::pfx) tm) m in apprec [] tlm let to_list tlm = let rec torec pfx (Node(hereset,m)) = let path = List.rev pfx in List.flatten((List.map (fun v -> (path,v)) (T_dom.elements hereset)):: (List.map (fun (l,tm) -> torec (l::pfx) tm) (codom_to_list m))) in torec [] tlm end coq-8.4pl4/lib/dnet.ml0000644000175000017500000002311712326224777013671 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'b) -> 'a t -> 'b t val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val fold2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a val compare : unit t -> unit t -> int val terminal : 'a t -> bool val choose : ('a -> 'b) -> 'a t -> 'b end module type S = sig type t type ident type meta type 'a structure module Idset : Set.S with type elt=ident type 'a pattern = | Term of 'a | Meta of meta type term_pattern = ('a structure) pattern as 'a val empty : t val add : t -> term_pattern -> ident -> t val find_all : t -> Idset.t val fold_pattern : ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a val find_match : term_pattern -> t -> Idset.t val inter : t -> t -> t val union : t -> t -> t val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t end module Make = functor (T:Datatype) -> functor (Ident:Set.OrderedType) -> functor (Meta:Set.OrderedType) -> struct type ident = Ident.t type meta = Meta.t type 'a pattern = | Term of 'a | Meta of meta type 'a structure = 'a T.t module Idset = Set.Make(Ident) module Mmap = Map.Make(Meta) module Tmap = Map.Make(struct type t = unit structure let compare = T.compare end) type term_pattern = term_pattern structure pattern type idset = Idset.t (* we store identifiers at the leaf of the dnet *) type node = | Node of t structure | Terminal of t structure * idset (* at each node, we have a bunch of nodes (actually a map between the bare node and a subnet) and a bunch of metavariables *) and t = Nodes of node Tmap.t * idset Mmap.t let empty : t = Nodes (Tmap.empty, Mmap.empty) (* the head of a data is of type unit structure *) let head w = T.map (fun c -> ()) w (* given a node of the net and a word, returns the subnet with the same head as the word (with the rest of the nodes) *) let split l (w:'a structure) : node * node Tmap.t = let elt : node = Tmap.find (head w) l in (elt, Tmap.remove (head w) l) let select l w = Tmap.find (head w) l let rec add (Nodes (t,m):t) (w:term_pattern) (id:ident) : t = match w with Term w -> ( try let (n,tl) = split t w in let new_node = match n with | Terminal (e,is) -> Terminal (e,Idset.add id is) | Node e -> Node (T.map2 (fun t p -> add t p id) e w) in Nodes ((Tmap.add (head w) new_node tl), m) with Not_found -> let new_content = T.map (fun p -> add empty p id) w in let new_node = if T.terminal w then Terminal (new_content, Idset.singleton id) else Node new_content in Nodes ((Tmap.add (head w) new_node t), m) ) | Meta i -> let m = try Mmap.add i (Idset.add id (Mmap.find i m)) m with Not_found -> Mmap.add i (Idset.singleton id) m in Nodes (t, m) let add t w id = add t w id let rec find_all (Nodes (t,m)) : idset = Idset.union (Mmap.fold (fun _ -> Idset.union) m Idset.empty) (Tmap.fold ( fun _ n acc -> let s2 = match n with | Terminal (_,is) -> is | Node e -> T.choose find_all e in Idset.union acc s2 ) t Idset.empty) (* (\* optimization hack: Not_found is catched in fold_pattern *\) *) (* let fast_inter s1 s2 = *) (* if Idset.is_empty s1 || Idset.is_empty s2 then raise Not_found *) (* else Idset.inter s1 s2 *) (* let option_any2 f s1 s2 = match s1,s2 with *) (* | Some s1, Some s2 -> f s1 s2 *) (* | (Some s, _ | _, Some s) -> s *) (* | _ -> raise Not_found *) (* let fold_pattern ?(complete=true) f acc pat dn = *) (* let deferred = ref [] in *) (* let leafs,metas = ref None, ref None in *) (* let leaf s = leafs := match !leafs with *) (* | None -> Some s *) (* | Some s' -> Some (fast_inter s s') in *) (* let meta s = metas := match !metas with *) (* | None -> Some s *) (* | Some s' -> Some (Idset.union s s') in *) (* let defer c = deferred := c::!deferred in *) (* let rec fp_rec (p:term_pattern) (Nodes(t,m) as dn:t) = *) (* Mmap.iter (fun _ -> meta) m; (\* TODO: gÃĐrer patterns nonlin ici *\) *) (* match p with *) (* | Meta m -> defer (m,dn) *) (* | Term w -> *) (* try match select t w with *) (* | Terminal (_,is) -> leaf is *) (* | Node e -> *) (* if complete then T.fold2 (fun _ -> fp_rec) () w e else *) (* if T.fold2 *) (* (fun b p dn -> match p with *) (* | Term _ -> fp_rec p dn; false *) (* | Meta _ -> b *) (* ) true w e *) (* then T.choose (T.choose fp_rec w) e *) (* with Not_found -> *) (* if Mmap.is_empty m then raise Not_found else () *) (* in try *) (* fp_rec pat dn; *) (* (try Some (option_any2 Idset.union !leafs !metas) with Not_found -> None), *) (* List.fold_left (fun acc (m,dn) -> f m dn acc) acc !deferred *) (* with Not_found -> None,acc *) (* Sets with a neutral element for inter *) module OSet (S:Set.S) = struct type t = S.t option let union s1 s2 = match s1,s2 with | (None, _ | _, None) -> None | Some a, Some b -> Some (S.union a b) let inter s1 s2 = match s1,s2 with | (None, a | a, None) -> a | Some a, Some b -> Some (S.inter a b) let is_empty = function | None -> false | Some s -> S.is_empty s (* optimization hack: Not_found is catched in fold_pattern *) let fast_inter s1 s2 = if is_empty s1 || is_empty s2 then raise Not_found else let r = inter s1 s2 in if is_empty r then raise Not_found else r let full = None let empty = Some S.empty end module OIdset = OSet(Idset) let fold_pattern ?(complete=true) f acc pat dn = let deferred = ref [] in let defer c = deferred := c::!deferred in let rec fp_rec metas p (Nodes(t,m) as dn:t) = (* TODO gÃĐrer les dnets non-linÃĐaires *) let metas = Mmap.fold (fun _ -> Idset.union) m metas in match p with | Meta m -> defer (metas,m,dn); OIdset.full | Term w -> let curm = Mmap.fold (fun _ -> Idset.union) m Idset.empty in try match select t w with | Terminal (_,is) -> Some (Idset.union curm is) | Node e -> let ids = if complete then T.fold2 (fun acc w e -> OIdset.fast_inter acc (fp_rec metas w e) ) OIdset.full w e else let (all_metas, res) = T.fold2 (fun (b,acc) w e -> match w with | Term _ -> false, OIdset.fast_inter acc (fp_rec metas w e) | Meta _ -> b, acc ) (true,OIdset.full) w e in if all_metas then T.choose (T.choose (fp_rec metas) w) e else res in OIdset.union ids (Some curm) with Not_found -> if Idset.is_empty metas then raise Not_found else Some curm in let cand = try fp_rec Idset.empty pat dn with Not_found -> OIdset.empty in let res = List.fold_left f acc !deferred in cand, res (* intersection of two dnets. keep only the common pairs *) let rec inter (t1:t) (t2:t) : t = let inter_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t = Nodes (Tmap.fold ( fun k e acc -> try Tmap.add k (f e (Tmap.find k t2)) acc with Not_found -> acc ) t1 Tmap.empty, Mmap.fold ( fun m s acc -> try Mmap.add m (Idset.inter s (Mmap.find m m2)) acc with Not_found -> acc ) m1 Mmap.empty ) in inter_map (fun n1 n2 -> match n1,n2 with | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.inter s1 s2) | Node e1, Node e2 -> Node (T.map2 inter e1 e2) | _ -> assert false ) t1 t2 let rec union (t1:t) (t2:t) : t = let union_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t = Nodes (Tmap.fold ( fun k e acc -> try Tmap.add k (f e (Tmap.find k acc)) acc with Not_found -> Tmap.add k e acc ) t1 t2, Mmap.fold ( fun m s acc -> try Mmap.add m (Idset.inter s (Mmap.find m acc)) acc with Not_found -> Mmap.add m s acc ) m1 m2 ) in union_map (fun n1 n2 -> match n1,n2 with | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.union s1 s2) | Node e1, Node e2 -> Node (T.map2 union e1 e2) | _ -> assert false ) t1 t2 let find_match (p:term_pattern) (t:t) : idset = let metas = ref Mmap.empty in let (mset,lset) = fold_pattern ~complete:false (fun acc (mset,m,t) -> let all = OIdset.fast_inter acc (Some(let t = try inter t (Mmap.find m !metas) with Not_found -> t in metas := Mmap.add m t !metas; find_all t)) in OIdset.union (Some mset) all ) None p t in Option.get (OIdset.inter mset lset) let fold_pattern f acc p dn = fold_pattern ~complete:true f acc p dn let idset_map f is = Idset.fold (fun e acc -> Idset.add (f e) acc) is Idset.empty let tmap_map f g m = Tmap.fold (fun k e acc -> Tmap.add (f k) (g e) acc) m Tmap.empty let rec map sidset sterm (Nodes (t,m)) : t = let snode = function | Terminal (e,is) -> Terminal (e,idset_map sidset is) | Node e -> Node (T.map (map sidset sterm) e) in Nodes (tmap_map sterm snode t, Mmap.map (idset_map sidset) m) end coq-8.4pl4/lib/dnet.mli0000644000175000017500000001062212326224777014037 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* | Leaf | Node of btree * btree | Node of 'a * 'a *) (** datatype you want to build a dnet on *) module type Datatype = sig (** parametric datatype. ['a] is morally the recursive argument *) type 'a t (** non-recursive mapping of subterms *) val map : ('a -> 'b) -> 'a t -> 'b t val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t (** non-recursive folding of subterms *) val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val fold2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a (** comparison of constructors *) val compare : unit t -> unit t -> int (** for each constructor, is it not-parametric on 'a? *) val terminal : 'a t -> bool (** [choose f w] applies f on ONE of the subterms of w *) val choose : ('a -> 'b) -> 'a t -> 'b end module type S = sig type t (** provided identifier type *) type ident (** provided metavariable type *) type meta (** provided parametrized datastructure *) type 'a structure (** returned sets of solutions *) module Idset : Set.S with type elt=ident (** a pattern is a term where each node can be a unification variable *) type 'a pattern = | Term of 'a | Meta of meta type term_pattern = 'a structure pattern as 'a val empty : t (** [add t w i] adds a new association (w,i) in t. *) val add : t -> term_pattern -> ident -> t (** [find_all t] returns all identifiers contained in t. *) val find_all : t -> Idset.t (** [fold_pattern f acc p dn] folds f on each meta of p, passing the meta and the sub-dnet under it. The result includes: - Some set if identifiers were gathered on the leafs of the term - None if the pattern contains no leaf (only Metas at the leafs). *) val fold_pattern : ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a (** [find_match p t] returns identifiers of all terms matching p in t. *) val find_match : term_pattern -> t -> Idset.t (** set operations on dnets *) val inter : t -> t -> t val union : t -> t -> t (** apply a function on each identifier and node of terms in a dnet *) val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t end module Make : functor (T:Datatype) -> functor (Ident:Set.OrderedType) -> functor (Meta:Set.OrderedType) -> S with type ident = Ident.t and type meta = Meta.t and type 'a structure = 'a T.t coq-8.4pl4/lib/heap.mli0000644000175000017500000000302512326224777014021 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t -> int end module type S =sig (** Type of functional heaps *) type t (** Type of elements *) type elt (** The empty heap *) val empty : t (** [add x h] returns a new heap containing the elements of [h], plus [x]; complexity {% $ %}O(log(n)){% $ %} *) val add : elt -> t -> t (** [maximum h] returns the maximum element of [h]; raises [EmptyHeap] when [h] is empty; complexity {% $ %}O(1){% $ %} *) val maximum : t -> elt (** [remove h] returns a new heap containing the elements of [h], except the maximum of [h]; raises [EmptyHeap] when [h] is empty; complexity {% $ %}O(log(n)){% $ %} *) val remove : t -> t (** usual iterators and combinators; elements are presented in arbitrary order *) val iter : (elt -> unit) -> t -> unit val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a end exception EmptyHeap (** {6 Functional implementation. } *) module Functional(X: Ordered) : S with type elt=X.t coq-8.4pl4/lib/xml_utils.ml0000644000175000017500000001407112326224777014756 0ustar stephsteph(* * Xml Light, an small Xml parser/printer with DTD support. * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com) * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) open Printf open Xml_parser exception Not_element of xml exception Not_pcdata of xml exception No_attribute of string let default_parser = Xml_parser.make() let parse (p:Xml_parser.t) (source:Xml_parser.source) = (* local cast Xml.xml -> xml *) (Obj.magic Xml_parser.parse p source : xml) let parse_in ch = parse default_parser (Xml_parser.SChannel ch) let parse_string str = parse default_parser (Xml_parser.SString str) let parse_file f = parse default_parser (Xml_parser.SFile f) let tag = function | Element (tag,_,_) -> tag | x -> raise (Not_element x) let pcdata = function | PCData text -> text | x -> raise (Not_pcdata x) let attribs = function | Element (_,attr,_) -> attr | x -> raise (Not_element x) let attrib x att = match x with | Element (_,attr,_) -> (try let att = String.lowercase att in snd (List.find (fun (n,_) -> String.lowercase n = att) attr) with Not_found -> raise (No_attribute att)) | x -> raise (Not_element x) let children = function | Element (_,_,clist) -> clist | x -> raise (Not_element x) (*let enum = function | Element (_,_,clist) -> List.to_enum clist | x -> raise (Not_element x) *) let iter f = function | Element (_,_,clist) -> List.iter f clist | x -> raise (Not_element x) let map f = function | Element (_,_,clist) -> List.map f clist | x -> raise (Not_element x) let fold f v = function | Element (_,_,clist) -> List.fold_left f v clist | x -> raise (Not_element x) let tmp = Buffer.create 200 let buffer_pcdata text = let l = String.length text in for p = 0 to l-1 do match text.[p] with | '>' -> Buffer.add_string tmp ">" | '<' -> Buffer.add_string tmp "<" | '&' -> if p < l-1 && text.[p+1] = '#' then Buffer.add_char tmp '&' else Buffer.add_string tmp "&" | '\'' -> Buffer.add_string tmp "'" | '"' -> Buffer.add_string tmp """ | c -> Buffer.add_char tmp c done let print_pcdata chan text = let l = String.length text in for p = 0 to l-1 do match text.[p] with | '>' -> Printf.fprintf chan ">" | '<' -> Printf.fprintf chan "<" | '&' -> if p < l-1 && text.[p+1] = '#' then Printf.fprintf chan "&" else Printf.fprintf chan "&" | '\'' -> Printf.fprintf chan "'" | '"' -> Printf.fprintf chan """ | c -> Printf.fprintf chan "%c" c done let buffer_attr (n,v) = Buffer.add_char tmp ' '; Buffer.add_string tmp n; Buffer.add_string tmp "=\""; let l = String.length v in for p = 0 to l-1 do match v.[p] with | '\\' -> Buffer.add_string tmp "\\\\" | '"' -> Buffer.add_string tmp "\\\"" | c -> Buffer.add_char tmp c done; Buffer.add_char tmp '"' let rec print_attr chan (n, v) = Printf.fprintf chan " %s=\"" n; let l = String.length v in for p = 0 to l-1 do match v.[p] with | '\\' -> Printf.fprintf chan "\\\\" | '"' -> Printf.fprintf chan "\\\"" | c -> Printf.fprintf chan "%c" c done; Printf.fprintf chan "\"" let print_attrs chan l = List.iter (print_attr chan) l let rec print_xml chan = function | Element (tag, alist, []) -> Printf.fprintf chan "<%s%a/>" tag print_attrs alist; | Element (tag, alist, l) -> Printf.fprintf chan "<%s%a>%a" tag print_attrs alist (fun chan -> List.iter (print_xml chan)) l tag | PCData text -> print_pcdata chan text let to_string x = let pcdata = ref false in let rec loop = function | Element (tag,alist,[]) -> Buffer.add_char tmp '<'; Buffer.add_string tmp tag; List.iter buffer_attr alist; Buffer.add_string tmp "/>"; pcdata := false; | Element (tag,alist,l) -> Buffer.add_char tmp '<'; Buffer.add_string tmp tag; List.iter buffer_attr alist; Buffer.add_char tmp '>'; pcdata := false; List.iter loop l; Buffer.add_string tmp "'; pcdata := false; | PCData text -> if !pcdata then Buffer.add_char tmp ' '; buffer_pcdata text; pcdata := true; in Buffer.reset tmp; loop x; let s = Buffer.contents tmp in Buffer.reset tmp; s let to_string_fmt x = let rec loop ?(newl=false) tab = function | Element (tag,alist,[]) -> Buffer.add_string tmp tab; Buffer.add_char tmp '<'; Buffer.add_string tmp tag; List.iter buffer_attr alist; Buffer.add_string tmp "/>"; if newl then Buffer.add_char tmp '\n'; | Element (tag,alist,[PCData text]) -> Buffer.add_string tmp tab; Buffer.add_char tmp '<'; Buffer.add_string tmp tag; List.iter buffer_attr alist; Buffer.add_string tmp ">"; buffer_pcdata text; Buffer.add_string tmp "'; if newl then Buffer.add_char tmp '\n'; | Element (tag,alist,l) -> Buffer.add_string tmp tab; Buffer.add_char tmp '<'; Buffer.add_string tmp tag; List.iter buffer_attr alist; Buffer.add_string tmp ">\n"; List.iter (loop ~newl:true (tab^" ")) l; Buffer.add_string tmp tab; Buffer.add_string tmp "'; if newl then Buffer.add_char tmp '\n'; | PCData text -> buffer_pcdata text; if newl then Buffer.add_char tmp '\n'; in Buffer.reset tmp; loop "" x; let s = Buffer.contents tmp in Buffer.reset tmp; s coq-8.4pl4/lib/predicate.mli0000644000175000017500000000534712326224777015055 0ustar stephsteph (** Module [Pred]: sets over infinite ordered types with complement. *) (** This module implements the set data structure, given a total ordering function over the set elements. All operations over sets are purely applicative (no side-effects). The implementation uses the Set library. *) module type OrderedType = sig type t val compare: t -> t -> int end (** The input signature of the functor [Pred.Make]. [t] is the type of the set elements. [compare] is a total ordering function over the set elements. This is a two-argument function [f] such that [f e1 e2] is zero if the elements [e1] and [e2] are equal, [f e1 e2] is strictly negative if [e1] is smaller than [e2], and [f e1 e2] is strictly positive if [e1] is greater than [e2]. Example: a suitable ordering function is the generic structural comparison function [compare]. *) module type S = sig type elt (** The type of the set elements. *) type t (** The type of sets. *) val empty: t (** The empty set. *) val full: t (** The whole type. *) val is_empty: t -> bool (** Test whether a set is empty or not. *) val is_full: t -> bool (** Test whether a set contains the whole type or not. *) val mem: elt -> t -> bool (** [mem x s] tests whether [x] belongs to the set [s]. *) val singleton: elt -> t (** [singleton x] returns the one-element set containing only [x]. *) val add: elt -> t -> t (** [add x s] returns a set containing all elements of [s], plus [x]. If [x] was already in [s], [s] is returned unchanged. *) val remove: elt -> t -> t (** [remove x s] returns a set containing all elements of [s], except [x]. If [x] was not in [s], [s] is returned unchanged. *) val union: t -> t -> t val inter: t -> t -> t val diff: t -> t -> t val complement: t -> t (** Union, intersection, difference and set complement. *) val equal: t -> t -> bool (** [equal s1 s2] tests whether the sets [s1] and [s2] are equal, that is, contain equal elements. *) val subset: t -> t -> bool (** [subset s1 s2] tests whether the set [s1] is a subset of the set [s2]. *) val elements: t -> bool * elt list (** Gives a finite representation of the predicate: if the boolean is false, then the predicate is given in extension. if it is true, then the complement is given *) end module Make(Ord: OrderedType): (S with type elt = Ord.t) (** Functor building an implementation of the set structure given a totally ordered type. *) coq-8.4pl4/lib/fset.ml0000644000175000017500000001623712326224777013705 0ustar stephstephmodule Make = functor (X : Set.OrderedType) -> struct type elt = X.t type t = Empty | Node of t * elt * t * int (* Sets are represented by balanced binary trees (the heights of the children differ by at most 2 *) let height = function Empty -> 0 | Node(_, _, _, h) -> h (* Creates a new node with left son l, value x and right son r. l and r must be balanced and | height l - height r | <= 2. Inline expansion of height for better speed. *) let create l x r = let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1)) (* Same as create, but performs one step of rebalancing if necessary. Assumes l and r balanced. Inline expansion of create for better speed in the most frequent case where no rebalancing is required. *) let bal l x r = let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in if hl > hr + 2 then begin match l with Empty -> invalid_arg "Set.bal" | Node(ll, lv, lr, _) -> if height ll >= height lr then create ll lv (create lr x r) else begin match lr with Empty -> invalid_arg "Set.bal" | Node(lrl, lrv, lrr, _)-> create (create ll lv lrl) lrv (create lrr x r) end end else if hr > hl + 2 then begin match r with Empty -> invalid_arg "Set.bal" | Node(rl, rv, rr, _) -> if height rr >= height rl then create (create l x rl) rv rr else begin match rl with Empty -> invalid_arg "Set.bal" | Node(rll, rlv, rlr, _) -> create (create l x rll) rlv (create rlr rv rr) end end else Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1)) (* Same as bal, but repeat rebalancing until the final result is balanced. *) let rec join l x r = match bal l x r with Empty -> invalid_arg "Set.join" | Node(l', x', r', _) as t' -> let d = height l' - height r' in if d < -2 or d > 2 then join l' x' r' else t' (* Merge two trees l and r into one. All elements of l must precede the elements of r. Assumes | height l - height r | <= 2. *) let rec merge t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> bal l1 v1 (bal (merge r1 l2) v2 r2) (* Same as merge, but does not assume anything about l and r. *) let rec concat t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> join l1 v1 (join (concat r1 l2) v2 r2) (* Splitting *) let rec split x = function Empty -> (Empty, None, Empty) | Node(l, v, r, _) -> let c = X.compare x v in if c = 0 then (l, Some v, r) else if c < 0 then let (ll, vl, rl) = split x l in (ll, vl, join rl v r) else let (lr, vr, rr) = split x r in (join l v lr, vr, rr) (* Implementation of the set operations *) let empty = Empty let is_empty = function Empty -> true | _ -> false let rec mem x = function Empty -> false | Node(l, v, r, _) -> let c = X.compare x v in c = 0 || mem x (if c < 0 then l else r) let rec add x = function Empty -> Node(Empty, x, Empty, 1) | Node(l, v, r, _) as t -> let c = X.compare x v in if c = 0 then t else if c < 0 then bal (add x l) v r else bal l v (add x r) let singleton x = Node(Empty, x, Empty, 1) let rec remove x = function Empty -> Empty | Node(l, v, r, _) -> let c = X.compare x v in if c = 0 then merge l r else if c < 0 then bal (remove x l) v r else bal l v (remove x r) let rec union s1 s2 = match (s1, s2) with (Empty, t2) -> t2 | (t1, Empty) -> t1 | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> if h1 >= h2 then if h2 = 1 then add v2 s1 else begin let (l2, _, r2) = split v1 s2 in join (union l1 l2) v1 (union r1 r2) end else if h1 = 1 then add v1 s2 else begin let (l1, _, r1) = split v2 s1 in join (union l1 l2) v2 (union r1 r2) end let rec inter s1 s2 = match (s1, s2) with (Empty, t2) -> Empty | (t1, Empty) -> Empty | (Node(l1, v1, r1, _), t2) -> match split v1 t2 with (l2, None, r2) -> concat (inter l1 l2) (inter r1 r2) | (l2, Some _, r2) -> join (inter l1 l2) v1 (inter r1 r2) let rec diff s1 s2 = match (s1, s2) with (Empty, t2) -> Empty | (t1, Empty) -> t1 | (Node(l1, v1, r1, _), t2) -> match split v1 t2 with (l2, None, r2) -> join (diff l1 l2) v1 (diff r1 r2) | (l2, Some _, r2) -> concat (diff l1 l2) (diff r1 r2) let rec compare_aux l1 l2 = match (l1, l2) with ([], []) -> 0 | ([], _) -> -1 | (_, []) -> 1 | (Empty :: t1, Empty :: t2) -> compare_aux t1 t2 | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) -> let c = compare v1 v2 in if c <> 0 then c else compare_aux (r1::t1) (r2::t2) | (Node(l1, v1, r1, _) :: t1, t2) -> compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2 | (t1, Node(l2, v2, r2, _) :: t2) -> compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2) let compare s1 s2 = compare_aux [s1] [s2] let equal s1 s2 = compare s1 s2 = 0 let rec subset s1 s2 = match (s1, s2) with Empty, _ -> true | _, Empty -> false | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) -> let c = X.compare v1 v2 in if c = 0 then subset l1 l2 && subset r1 r2 else if c < 0 then subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2 else subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2 let rec iter f = function Empty -> () | Node(l, v, r, _) -> iter f l; f v; iter f r let rec fold f s accu = match s with Empty -> accu | Node(l, v, r, _) -> fold f l (f v (fold f r accu)) let rec cardinal = function Empty -> 0 | Node(l, v, r, _) -> cardinal l + 1 + cardinal r let rec elements_aux accu = function Empty -> accu | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l let elements s = elements_aux [] s let rec min_elt = function Empty -> raise Not_found | Node(Empty, v, r, _) -> v | Node(l, v, r, _) -> min_elt l let rec max_elt = function Empty -> raise Not_found | Node(l, v, Empty, _) -> v | Node(l, v, r, _) -> max_elt r let choose = min_elt end coq-8.4pl4/lib/dyn.mli0000644000175000017500000000122012326224777013671 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ('a -> t) * (t -> 'a) val tag : t -> string coq-8.4pl4/lib/xml_utils.mli0000644000175000017500000000664412326224777015136 0ustar stephsteph(* * Xml Light, an small Xml parser/printer with DTD support. * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com) * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) (** Xml Light Xml Light is a minimal Xml parser & printer for OCaml. It provide few functions to parse a basic Xml document into an OCaml data structure and to print back the data structures to an Xml document. Xml Light has also support for {b DTD} (Document Type Definition). {i (c)Copyright 2002-2003 Nicolas Cannasse} *) open Xml_parser (** {6 Xml Functions} *) exception Not_element of xml exception Not_pcdata of xml exception No_attribute of string (** [tag xdata] returns the tag value of the xml node. Raise {!Xml.Not_element} if the xml is not an element *) val tag : xml -> string (** [pcdata xdata] returns the PCData value of the xml node. Raise {!Xml.Not_pcdata} if the xml is not a PCData *) val pcdata : xml -> string (** [attribs xdata] returns the attribute list of the xml node. First string if the attribute name, second string is attribute value. Raise {!Xml.Not_element} if the xml is not an element *) val attribs : xml -> (string * string) list (** [attrib xdata "href"] returns the value of the ["href"] attribute of the xml node (attribute matching is case-insensitive). Raise {!Xml.No_attribute} if the attribute does not exists in the node's attribute list Raise {!Xml.Not_element} if the xml is not an element *) val attrib : xml -> string -> string (** [children xdata] returns the children list of the xml node Raise {!Xml.Not_element} if the xml is not an element *) val children : xml -> xml list (*** [enum xdata] returns the children enumeration of the xml node Raise {!Xml.Not_element} if the xml is not an element *) (* val enum : xml -> xml Enum.t *) (** [iter f xdata] calls f on all children of the xml node. Raise {!Xml.Not_element} if the xml is not an element *) val iter : (xml -> unit) -> xml -> unit (** [map f xdata] is equivalent to [List.map f (Xml.children xdata)] Raise {!Xml.Not_element} if the xml is not an element *) val map : (xml -> 'a) -> xml -> 'a list (** [fold f init xdata] is equivalent to [List.fold_left f init (Xml.children xdata)] Raise {!Xml.Not_element} if the xml is not an element *) val fold : ('a -> xml -> 'a) -> 'a -> xml -> 'a (** {6 Xml Printing} *) (** Print the xml data structure to a channel into a compact xml string (without any user-readable formating ). *) val print_xml : out_channel -> xml -> unit (** Print the xml data structure into a compact xml string (without any user-readable formating ). *) val to_string : xml -> string (** Print the xml data structure into an user-readable string with tabs and lines break between different nodes. *) val to_string_fmt : xml -> string coq-8.4pl4/lib/util.ml0000644000175000017500000012161512326224777013716 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* = 'a' && c <= 'z') or (c >= 'A' && c <= 'Z') let is_digit c = (c >= '0' && c <= '9') let is_ident_tail c = is_letter c or is_digit c or c = '\'' or c = '_' let is_blank = function | ' ' | '\r' | '\t' | '\n' -> true | _ -> false (* Strings *) let explode s = let rec explode_rec n = if n >= String.length s then [] else String.make 1 (String.get s n) :: explode_rec (succ n) in explode_rec 0 let implode sl = String.concat "" sl let strip s = let n = String.length s in let rec lstrip_rec i = if i < n && is_blank s.[i] then lstrip_rec (i+1) else i in let rec rstrip_rec i = if i >= 0 && is_blank s.[i] then rstrip_rec (i-1) else i in let a = lstrip_rec 0 and b = rstrip_rec (n-1) in String.sub s a (b-a+1) let drop_simple_quotes s = let n = String.length s in if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' then String.sub s 1 (n-2) else s (* substring searching... *) (* gdzie = where, co = what *) (* gdzie=gdzie(string) gl=gdzie(length) gi=gdzie(index) *) let rec is_sub gdzie gl gi co cl ci = (ci>=cl) || ((String.unsafe_get gdzie gi = String.unsafe_get co ci) && (is_sub gdzie gl (gi+1) co cl (ci+1))) let rec raw_str_index i gdzie l c co cl = (* First adapt to ocaml 3.11 new semantics of index_from *) if (i+cl > l) then raise Not_found; (* Then proceed as in ocaml < 3.11 *) let i' = String.index_from gdzie i c in if (i'+cl <= l) && (is_sub gdzie l i' co cl 0) then i' else raw_str_index (i'+1) gdzie l c co cl let string_index_from gdzie i co = if co="" then i else raw_str_index i gdzie (String.length gdzie) (String.unsafe_get co 0) co (String.length co) let string_string_contains ~where ~what = try let _ = string_index_from where 0 what in true with Not_found -> false let plural n s = if n<>1 then s^"s" else s let ordinal n = let s = match n mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th" in string_of_int n ^ s (* string parsing *) let split_string_at c s = let len = String.length s in let rec split n = try let pos = String.index_from s n c in let dir = String.sub s n (pos-n) in dir :: split (succ pos) with | Not_found -> [String.sub s n (len-n)] in if len = 0 then [] else split 0 let parse_loadpath s = let l = split_string_at '/' s in if List.mem "" l then invalid_arg "parse_loadpath: find an empty dir in loadpath"; l module Stringset = Set.Make(struct type t = string let compare = compare end) module Stringmap = Map.Make(struct type t = string let compare = compare end) type utf8_status = UnicodeLetter | UnicodeIdentPart | UnicodeSymbol exception UnsupportedUtf8 (* The following table stores classes of Unicode characters that are used by the lexer. There are 3 different classes so 2 bits are allocated for each character. We only use 16 bits over the 31 bits to simplify the masking process. (This choice seems to be a good trade-off between speed and space after some benchmarks.) *) (* A 256ko table, initially filled with zeros. *) let table = Array.create (1 lsl 17) 0 (* Associate a 2-bit pattern to each status at position [i]. Only the 3 lowest bits of [i] are taken into account to define the position of the pattern in the word. Notice that pattern "00" means "undefined". *) let mask i = function | UnicodeLetter -> 1 lsl ((i land 7) lsl 1) (* 01 *) | UnicodeIdentPart -> 2 lsl ((i land 7) lsl 1) (* 10 *) | UnicodeSymbol -> 3 lsl ((i land 7) lsl 1) (* 11 *) (* Helper to reset 2 bits in a word. *) let reset_mask i = lnot (3 lsl ((i land 7) lsl 1)) (* Initialize the lookup table from a list of segments, assigning a status to every character of each segment. The order of these assignments is relevant: it is possible to assign status [s] to a segment [(c1, c2)] and later assign [s'] to [c] even if [c] is between [c1] and [c2]. *) let mk_lookup_table_from_unicode_tables_for status tables = List.iter (List.iter (fun (c1, c2) -> for i = c1 to c2 do table.(i lsr 3) <- (table.(i lsr 3) land (reset_mask i)) lor (mask i status) done)) tables (* Look up into the table and interpret the found pattern. *) let lookup x = let v = (table.(x lsr 3) lsr ((x land 7) lsl 1)) land 3 in if v = 1 then UnicodeLetter else if v = 2 then UnicodeIdentPart else if v = 3 then UnicodeSymbol else raise UnsupportedUtf8 (* [classify_unicode] discriminates between 3 different kinds of symbols based on the standard unicode classification (extracted from Camomile). *) let classify_unicode = let single c = [ (c, c) ] in (* General tables. *) mk_lookup_table_from_unicode_tables_for UnicodeSymbol [ Unicodetable.sm; (* Symbol, maths. *) Unicodetable.sc; (* Symbol, currency. *) Unicodetable.so; (* Symbol, modifier. *) Unicodetable.pd; (* Punctation, dash. *) Unicodetable.pc; (* Punctation, connector. *) Unicodetable.pe; (* Punctation, open. *) Unicodetable.ps; (* Punctation, close. *) Unicodetable.pi; (* Punctation, initial quote. *) Unicodetable.pf; (* Punctation, final quote. *) Unicodetable.po; (* Punctation, other. *) ]; mk_lookup_table_from_unicode_tables_for UnicodeLetter [ Unicodetable.lu; (* Letter, uppercase. *) Unicodetable.ll; (* Letter, lowercase. *) Unicodetable.lt; (* Letter, titlecase. *) Unicodetable.lo; (* Letter, others. *) ]; mk_lookup_table_from_unicode_tables_for UnicodeIdentPart [ Unicodetable.nd; (* Number, decimal digits. *) Unicodetable.nl; (* Number, letter. *) Unicodetable.no; (* Number, other. *) ]; (* Exceptions (from a previous version of this function). *) mk_lookup_table_from_unicode_tables_for UnicodeSymbol [ single 0x000B2; (* Squared. *) single 0x0002E; (* Dot. *) ]; mk_lookup_table_from_unicode_tables_for UnicodeLetter [ single 0x005F; (* Underscore. *) single 0x00A0; (* Non breaking space. *) ]; mk_lookup_table_from_unicode_tables_for UnicodeIdentPart [ single 0x0027; (* Special space. *) ]; (* Lookup *) lookup exception End_of_input let utf8_of_unicode n = if n < 128 then String.make 1 (Char.chr n) else if n < 2048 then let s = String.make 2 (Char.chr (128 + n mod 64)) in begin s.[0] <- Char.chr (192 + n / 64); s end else if n < 65536 then let s = String.make 3 (Char.chr (128 + n mod 64)) in begin s.[1] <- Char.chr (128 + (n / 64) mod 64); s.[0] <- Char.chr (224 + n / 4096); s end else let s = String.make 4 (Char.chr (128 + n mod 64)) in begin s.[2] <- Char.chr (128 + (n / 64) mod 64); s.[1] <- Char.chr (128 + (n / 4096) mod 64); s.[0] <- Char.chr (240 + n / 262144); s end let next_utf8 s i = let err () = invalid_arg "utf8" in let l = String.length s - i in if l = 0 then raise End_of_input else let a = Char.code s.[i] in if a <= 0x7F then 1, a else if a land 0x40 = 0 or l = 1 then err () else let b = Char.code s.[i+1] in if b land 0xC0 <> 0x80 then err () else if a land 0x20 = 0 then 2, (a land 0x1F) lsl 6 + (b land 0x3F) else if l = 2 then err () else let c = Char.code s.[i+2] in if c land 0xC0 <> 0x80 then err () else if a land 0x10 = 0 then 3, (a land 0x0F) lsl 12 + (b land 0x3F) lsl 6 + (c land 0x3F) else if l = 3 then err () else let d = Char.code s.[i+3] in if d land 0xC0 <> 0x80 then err () else if a land 0x08 = 0 then 4, (a land 0x07) lsl 18 + (b land 0x3F) lsl 12 + (c land 0x3F) lsl 6 + (d land 0x3F) else err () (* Check the well-formedness of an identifier *) let check_initial handle j n s = match classify_unicode n with | UnicodeLetter -> () | _ -> let c = String.sub s 0 j in handle ("Invalid character '"^c^"' at beginning of identifier \""^s^"\".") let check_trailing handle i j n s = match classify_unicode n with | UnicodeLetter | UnicodeIdentPart -> () | _ -> let c = String.sub s i j in handle ("Invalid character '"^c^"' in identifier \""^s^"\".") let check_ident_gen handle s = let i = ref 0 in if s <> ".." then try let j, n = next_utf8 s 0 in check_initial handle j n s; i := !i + j; try while true do let j, n = next_utf8 s !i in check_trailing handle !i j n s; i := !i + j done with End_of_input -> () with | End_of_input -> error "The empty string is not an identifier." | UnsupportedUtf8 -> error (s^": unsupported character in utf8 sequence.") | Invalid_argument _ -> error (s^": invalid utf8 sequence.") let check_ident_soft = check_ident_gen warning let check_ident = check_ident_gen error let lowercase_unicode = let tree = Segmenttree.make Unicodetable.to_lower in fun unicode -> try match Segmenttree.lookup unicode tree with | `Abs c -> c | `Delta d -> unicode + d with Not_found -> unicode let lowercase_first_char_utf8 s = assert (s <> ""); let j, n = next_utf8 s 0 in utf8_of_unicode (lowercase_unicode n) (** For extraction, we need to encode unicode character into ascii ones *) let ascii_of_ident s = let check_ascii s = let ok = ref true in String.iter (fun c -> if Char.code c >= 128 then ok := false) s; !ok in if check_ascii s then s else let i = ref 0 and out = ref "" in begin try while true do let j, n = next_utf8 s !i in out := if n >= 128 then Printf.sprintf "%s__U%04x_" !out n else Printf.sprintf "%s%c" !out s.[!i]; i := !i + j done with End_of_input -> () end; !out (* Lists *) let rec list_compare cmp l1 l2 = match l1,l2 with [], [] -> 0 | _::_, [] -> 1 | [], _::_ -> -1 | x1::l1, x2::l2 -> (match cmp x1 x2 with | 0 -> list_compare cmp l1 l2 | c -> c) let rec list_equal cmp l1 l2 = match l1, l2 with | [], [] -> true | x1 :: l1, x2 :: l2 -> cmp x1 x2 && list_equal cmp l1 l2 | _ -> false let list_intersect l1 l2 = List.filter (fun x -> List.mem x l2) l1 let list_union l1 l2 = let rec urec = function | [] -> l2 | a::l -> if List.mem a l2 then urec l else a::urec l in urec l1 let list_unionq l1 l2 = let rec urec = function | [] -> l2 | a::l -> if List.memq a l2 then urec l else a::urec l in urec l1 let list_subtract l1 l2 = if l2 = [] then l1 else List.filter (fun x -> not (List.mem x l2)) l1 let list_subtractq l1 l2 = if l2 = [] then l1 else List.filter (fun x -> not (List.memq x l2)) l1 let list_tabulate f len = let rec tabrec n = if n = len then [] else (f n)::(tabrec (n+1)) in tabrec 0 let list_addn n v = let rec aux n l = if n = 0 then l else aux (pred n) (v::l) in if n < 0 then invalid_arg "list_addn" else aux n let list_make n v = list_addn n v [] let list_assign l n e = let rec assrec stk = function | ((h::t), 0) -> List.rev_append stk (e::t) | ((h::t), n) -> assrec (h::stk) (t, n-1) | ([], _) -> failwith "list_assign" in assrec [] (l,n) let rec list_smartmap f l = match l with [] -> l | h::tl -> let h' = f h and tl' = list_smartmap f tl in if h'==h && tl'==tl then l else h'::tl' let list_map_left f = (* ensures the order in case of side-effects *) let rec map_rec = function | [] -> [] | x::l -> let v = f x in v :: map_rec l in map_rec let list_map_i f = let rec map_i_rec i = function | [] -> [] | x::l -> let v = f i x in v :: map_i_rec (i+1) l in map_i_rec let list_map2_i f i l1 l2 = let rec map_i i = function | ([], []) -> [] | ((h1::t1), (h2::t2)) -> let v = f i h1 h2 in v :: map_i (succ i) (t1,t2) | (_, _) -> invalid_arg "map2_i" in map_i i (l1,l2) let list_map3 f l1 l2 l3 = let rec map = function | ([], [], []) -> [] | ((h1::t1), (h2::t2), (h3::t3)) -> let v = f h1 h2 h3 in v::map (t1,t2,t3) | (_, _, _) -> invalid_arg "map3" in map (l1,l2,l3) let list_map4 f l1 l2 l3 l4 = let rec map = function | ([], [], [], []) -> [] | ((h1::t1), (h2::t2), (h3::t3), (h4::t4)) -> let v = f h1 h2 h3 h4 in v::map (t1,t2,t3,t4) | (_, _, _, _) -> invalid_arg "map4" in map (l1,l2,l3,l4) let list_map_to_array f l = Array.of_list (List.map f l) let rec list_smartfilter f l = match l with [] -> l | h::tl -> let tl' = list_smartfilter f tl in if f h then if tl' == tl then l else h :: tl' else tl' let list_index_f f x = let rec index_x n = function | y::l -> if f x y then n else index_x (succ n) l | [] -> raise Not_found in index_x 1 let list_index0_f f x l = list_index_f f x l - 1 let list_index x = let rec index_x n = function | y::l -> if x = y then n else index_x (succ n) l | [] -> raise Not_found in index_x 1 let list_index0 x l = list_index x l - 1 let list_unique_index x = let rec index_x n = function | y::l -> if x = y then if List.mem x l then raise Not_found else n else index_x (succ n) l | [] -> raise Not_found in index_x 1 let list_fold_right_i f i l = let rec it_list_f i l a = match l with | [] -> a | b::l -> f (i-1) b (it_list_f (i-1) l a) in it_list_f (List.length l + i) l let list_fold_left_i f = let rec it_list_f i a = function | [] -> a | b::l -> it_list_f (i+1) (f i a b) l in it_list_f let rec list_fold_left3 f accu l1 l2 l3 = match (l1, l2, l3) with ([], [], []) -> accu | (a1::l1, a2::l2, a3::l3) -> list_fold_left3 f (f accu a1 a2 a3) l1 l2 l3 | (_, _, _) -> invalid_arg "list_fold_left3" (* [list_fold_right_and_left f [a1;...;an] hd = f (f (... (f (f hd an [an-1;...;a1]) an-1 [an-2;...;a1]) ...) a2 [a1]) a1 []] *) let rec list_fold_right_and_left f l hd = let rec aux tl = function | [] -> hd | a::l -> let hd = aux (a::tl) l in f hd a tl in aux [] l let list_iter3 f l1 l2 l3 = let rec iter = function | ([], [], []) -> () | ((h1::t1), (h2::t2), (h3::t3)) -> f h1 h2 h3; iter (t1,t2,t3) | (_, _, _) -> invalid_arg "map3" in iter (l1,l2,l3) let list_iter_i f l = list_fold_left_i (fun i _ x -> f i x) 0 () l let list_for_all_i p = let rec for_all_p i = function | [] -> true | a::l -> p i a && for_all_p (i+1) l in for_all_p let list_except x l = List.filter (fun y -> not (x = y)) l let list_remove = list_except (* Alias *) let rec list_remove_first a = function | b::l when a = b -> l | b::l -> b::list_remove_first a l | [] -> raise Not_found let rec list_remove_assoc_in_triple x = function | [] -> [] | (y,_,_ as z)::l -> if x = y then l else z::list_remove_assoc_in_triple x l let rec list_assoc_snd_in_triple x = function [] -> raise Not_found | (a,b,_)::l -> if compare a x = 0 then b else list_assoc_snd_in_triple x l let list_add_set x l = if List.mem x l then l else x::l let list_eq_set l1 l2 = let rec aux l1 = function | [] -> l1 = [] | a::l2 -> aux (list_remove_first a l1) l2 in try aux l1 l2 with Not_found -> false let list_for_all2eq f l1 l2 = try List.for_all2 f l1 l2 with Invalid_argument _ -> false let list_filter_i p = let rec filter_i_rec i = function | [] -> [] | x::l -> let l' = filter_i_rec (succ i) l in if p i x then x::l' else l' in filter_i_rec 0 let rec list_sep_last = function | [] -> failwith "sep_last" | hd::[] -> (hd,[]) | hd::tl -> let (l,tl) = list_sep_last tl in (l,hd::tl) let list_try_find_i f = let rec try_find_f n = function | [] -> failwith "try_find_i" | h::t -> try f n h with Failure _ -> try_find_f (n+1) t in try_find_f let list_try_find f = let rec try_find_f = function | [] -> failwith "try_find" | h::t -> try f h with Failure _ -> try_find_f t in try_find_f let list_uniquize l = let visited = Hashtbl.create 23 in let rec aux acc = function | h::t -> if Hashtbl.mem visited h then aux acc t else begin Hashtbl.add visited h h; aux (h::acc) t end | [] -> List.rev acc in aux [] l let rec list_distinct l = let visited = Hashtbl.create 23 in let rec loop = function | h::t -> if Hashtbl.mem visited h then false else begin Hashtbl.add visited h h; loop t end | [] -> true in loop l let rec list_merge_uniq cmp l1 l2 = match l1, l2 with | [], l2 -> l2 | l1, [] -> l1 | h1 :: t1, h2 :: t2 -> let c = cmp h1 h2 in if c = 0 then h1 :: list_merge_uniq cmp t1 t2 else if c <= 0 then h1 :: list_merge_uniq cmp t1 l2 else h2 :: list_merge_uniq cmp l1 t2 let rec list_duplicates = function | [] -> [] | x::l -> let l' = list_duplicates l in if List.mem x l then list_add_set x l' else l' let rec list_filter2 f = function | [], [] as p -> p | d::dp, l::lp -> let (dp',lp' as p) = list_filter2 f (dp,lp) in if f d l then d::dp', l::lp' else p | _ -> invalid_arg "list_filter2" let rec list_map_filter f = function | [] -> [] | x::l -> let l' = list_map_filter f l in match f x with None -> l' | Some y -> y::l' let list_map_filter_i f = let rec aux i = function | [] -> [] | x::l -> let l' = aux (succ i) l in match f i x with None -> l' | Some y -> y::l' in aux 0 let list_filter_along f filter l = snd (list_filter2 (fun b c -> f b) (filter,l)) let list_filter_with filter l = list_filter_along (fun x -> x) filter l let list_subset l1 l2 = let t2 = Hashtbl.create 151 in List.iter (fun x -> Hashtbl.add t2 x ()) l2; let rec look = function | [] -> true | x::ll -> try Hashtbl.find t2 x; look ll with Not_found -> false in look l1 (* [list_chop i l] splits [l] into two lists [(l1,l2)] such that [l1++l2=l] and [l1] has length [i]. It raises [Failure] when [i] is negative or greater than the length of [l] *) let list_chop n l = let rec chop_aux i acc = function | tl when i=0 -> (List.rev acc, tl) | h::t -> chop_aux (pred i) (h::acc) t | [] -> failwith "list_chop" in chop_aux n [] l (* [list_split_when p l] splits [l] into two lists [(l1,a::l2)] such that [l1++(a::l2)=l], [p a=true] and [p b = false] for every element [b] of [l1]. If there is no such [a], then it returns [(l,[])] instead *) let list_split_when p = let rec split_when_loop x y = match y with | [] -> (List.rev x,[]) | (a::l) -> if (p a) then (List.rev x,y) else split_when_loop (a::x) l in split_when_loop [] (* [list_split_by p l] splits [l] into two lists [(l1,l2)] such that elements of [l1] satisfy [p] and elements of [l2] do not; order is preserved *) let list_split_by p = let rec split_by_loop = function | [] -> ([],[]) | a::l -> let (l1,l2) = split_by_loop l in if p a then (a::l1,l2) else (l1,a::l2) in split_by_loop let rec list_split3 = function | [] -> ([], [], []) | (x,y,z)::l -> let (rx, ry, rz) = list_split3 l in (x::rx, y::ry, z::rz) let rec list_insert_in_class f a = function | [] -> [[a]] | (b::_ as l)::classes when f a b -> (a::l)::classes | l::classes -> l :: list_insert_in_class f a classes let list_partition_by f l = List.fold_right (list_insert_in_class f) l [] let list_firstn n l = let rec aux acc = function | (0, l) -> List.rev acc | (n, (h::t)) -> aux (h::acc) (pred n, t) | _ -> failwith "firstn" in aux [] (n,l) let rec list_last = function | [] -> failwith "list_last" | [x] -> x | _ :: l -> list_last l let list_lastn n l = let len = List.length l in let rec aux m l = if m = n then l else aux (m - 1) (List.tl l) in if len < n then failwith "lastn" else aux len l let rec list_skipn n l = match n,l with | 0, _ -> l | _, [] -> failwith "list_skipn" | n, _::l -> list_skipn (pred n) l let rec list_skipn_at_least n l = try list_skipn n l with Failure _ -> [] let list_prefix_of prefl l = let rec prefrec = function | (h1::t1, h2::t2) -> h1 = h2 && prefrec (t1,t2) | ([], _) -> true | (_, _) -> false in prefrec (prefl,l) let list_drop_prefix p l = (* if l=p++t then return t else l *) let rec list_drop_prefix_rec = function | ([], tl) -> Some tl | (_, []) -> None | (h1::tp, h2::tl) -> if h1 = h2 then list_drop_prefix_rec (tp,tl) else None in match list_drop_prefix_rec (p,l) with | Some r -> r | None -> l let list_map_append f l = List.flatten (List.map f l) let list_join_map = list_map_append (* Alias *) let list_map_append2 f l1 l2 = List.flatten (List.map2 f l1 l2) let list_share_tails l1 l2 = let rec shr_rev acc = function | ((x1::l1), (x2::l2)) when x1 == x2 -> shr_rev (x1::acc) (l1,l2) | (l1,l2) -> (List.rev l1, List.rev l2, acc) in shr_rev [] (List.rev l1, List.rev l2) let rec list_fold_map f e = function | [] -> (e,[]) | h::t -> let e',h' = f e h in let e'',t' = list_fold_map f e' t in e'',h'::t' (* (* tail-recursive version of the above function *) let list_fold_map f e l = let g (e,b') h = let (e',h') = f e h in (e',h'::b') in let (e',lrev) = List.fold_left g (e,[]) l in (e',List.rev lrev) *) (* The same, based on fold_right, with the effect accumulated on the right *) let list_fold_map' f l e = List.fold_right (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) l ([],e) let list_map_assoc f = List.map (fun (x,a) -> (x,f a)) let rec list_assoc_f f a = function | (x, e) :: xs -> if f a x then e else list_assoc_f f a xs | [] -> raise Not_found (* Specification: - =p= is set equality (double inclusion) - f such that \forall l acc, (f l acc) =p= append (f l []) acc - let g = fun x -> f x [] in - union_map f l acc =p= append (flatten (map g l)) acc *) let list_union_map f l acc = List.fold_left (fun x y -> f y x) acc l (* A generic cartesian product: for any operator (**), [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]], and so on if there are more elements in the lists. *) let rec list_cartesian op l1 l2 = list_map_append (fun x -> List.map (op x) l2) l1 (* [list_cartesians] is an n-ary cartesian product: it iterates [list_cartesian] over a list of lists. *) let list_cartesians op init ll = List.fold_right (list_cartesian op) ll [init] (* list_combinations [[a;b];[c;d]] gives [[a;c];[a;d];[b;c];[b;d]] *) let list_combinations l = list_cartesians (fun x l -> x::l) [] l let rec list_combine3 x y z = match x, y, z with | [], [], [] -> [] | (x :: xs), (y :: ys), (z :: zs) -> (x, y, z) :: list_combine3 xs ys zs | _, _, _ -> raise (Invalid_argument "list_combine3") (* Keep only those products that do not return None *) let rec list_cartesian_filter op l1 l2 = list_map_append (fun x -> list_map_filter (op x) l2) l1 (* Keep only those products that do not return None *) let rec list_cartesians_filter op init ll = List.fold_right (list_cartesian_filter op) ll [init] (* Drop the last element of a list *) let rec list_drop_last = function [] -> assert false | hd :: [] -> [] | hd :: tl -> hd :: list_drop_last tl (* Factorize lists of pairs according to the left argument *) let rec list_factorize_left = function | (a,b)::l -> let al,l' = list_split_by (fun (a',b) -> a=a') l in (a,(b::List.map snd al)) :: list_factorize_left l' | [] -> [] (* Arrays *) let array_compare item_cmp v1 v2 = let c = compare (Array.length v1) (Array.length v2) in if c<>0 then c else let rec cmp = function -1 -> 0 | i -> let c' = item_cmp v1.(i) v2.(i) in if c'<>0 then c' else cmp (i-1) in cmp (Array.length v1 - 1) let array_equal cmp t1 t2 = Array.length t1 = Array.length t2 && let rec aux i = (i = Array.length t1) || (cmp t1.(i) t2.(i) && aux (i + 1)) in aux 0 let array_exists f v = let rec exrec = function | -1 -> false | n -> (f v.(n)) || (exrec (n-1)) in exrec ((Array.length v)-1) let array_for_all f v = let rec allrec = function | -1 -> true | n -> (f v.(n)) && (allrec (n-1)) in allrec ((Array.length v)-1) let array_for_all2 f v1 v2 = let rec allrec = function | -1 -> true | n -> (f v1.(n) v2.(n)) && (allrec (n-1)) in let lv1 = Array.length v1 in lv1 = Array.length v2 && allrec (pred lv1) let array_for_all3 f v1 v2 v3 = let rec allrec = function | -1 -> true | n -> (f v1.(n) v2.(n) v3.(n)) && (allrec (n-1)) in let lv1 = Array.length v1 in lv1 = Array.length v2 && lv1 = Array.length v3 && allrec (pred lv1) let array_for_all4 f v1 v2 v3 v4 = let rec allrec = function | -1 -> true | n -> (f v1.(n) v2.(n) v3.(n) v4.(n)) && (allrec (n-1)) in let lv1 = Array.length v1 in lv1 = Array.length v2 && lv1 = Array.length v3 && lv1 = Array.length v4 && allrec (pred lv1) let array_for_all_i f i v = let rec allrec i n = n = Array.length v || f i v.(n) && allrec (i+1) (n+1) in allrec i 0 exception Found of int let array_find_i (pred: int -> 'a -> bool) (arr: 'a array) : int option = try for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done; None with Found i -> Some i let array_hd v = match Array.length v with | 0 -> failwith "array_hd" | _ -> v.(0) let array_tl v = match Array.length v with | 0 -> failwith "array_tl" | n -> Array.sub v 1 (pred n) let array_last v = match Array.length v with | 0 -> failwith "array_last" | n -> v.(pred n) let array_cons e v = Array.append [|e|] v let array_rev t = let n=Array.length t in if n <=0 then () else let tmp=ref t.(0) in for i=0 to pred (n/2) do tmp:=t.((pred n)-i); t.((pred n)-i)<- t.(i); t.(i)<- !tmp done let array_fold_right_i f v a = let rec fold a n = if n=0 then a else let k = n-1 in fold (f k v.(k) a) k in fold a (Array.length v) let array_fold_left_i f v a = let n = Array.length a in let rec fold i v = if i = n then v else fold (succ i) (f i v a.(i)) in fold 0 v let array_fold_right2 f v1 v2 a = let lv1 = Array.length v1 in let rec fold a n = if n=0 then a else let k = n-1 in fold (f v1.(k) v2.(k) a) k in if Array.length v2 <> lv1 then invalid_arg "array_fold_right2"; fold a lv1 let array_fold_left2 f a v1 v2 = let lv1 = Array.length v1 in let rec fold a n = if n >= lv1 then a else fold (f a v1.(n) v2.(n)) (succ n) in if Array.length v2 <> lv1 then invalid_arg "array_fold_left2"; fold a 0 let array_fold_left2_i f a v1 v2 = let lv1 = Array.length v1 in let rec fold a n = if n >= lv1 then a else fold (f n a v1.(n) v2.(n)) (succ n) in if Array.length v2 <> lv1 then invalid_arg "array_fold_left2"; fold a 0 let array_fold_left3 f a v1 v2 v3 = let lv1 = Array.length v1 in let rec fold a n = if n >= lv1 then a else fold (f a v1.(n) v2.(n) v3.(n)) (succ n) in if Array.length v2 <> lv1 || Array.length v3 <> lv1 then invalid_arg "array_fold_left2"; fold a 0 let array_fold_left_from n f a v = let rec fold a n = if n >= Array.length v then a else fold (f a v.(n)) (succ n) in fold a n let array_fold_right_from n f v a = let rec fold n = if n >= Array.length v then a else f v.(n) (fold (succ n)) in fold n let array_app_tl v l = if Array.length v = 0 then invalid_arg "array_app_tl"; array_fold_right_from 1 (fun e l -> e::l) v l let array_list_of_tl v = if Array.length v = 0 then invalid_arg "array_list_of_tl"; array_fold_right_from 1 (fun e l -> e::l) v [] let array_map_to_list f v = List.map f (Array.to_list v) let array_chop n v = let vlen = Array.length v in if n > vlen then failwith "array_chop"; (Array.sub v 0 n, Array.sub v n (vlen-n)) exception Local of int (* If none of the elements is changed by f we return ar itself. The for loop looks for the first such an element. If found it is temporarily stored in a ref and the new array is produced, but f is not re-applied to elements that are already checked *) let array_smartmap f ar = let ar_size = Array.length ar in let aux = ref None in try for i = 0 to ar_size-1 do let a = ar.(i) in let a' = f a in if a != a' then (* pointer (in)equality *) begin aux := Some a'; raise (Local i) end done; ar with Local i -> let copy j = if j a' | None -> failwith "Error" else f (ar.(j)) in Array.init ar_size copy let array_map2 f v1 v2 = if Array.length v1 <> Array.length v2 then invalid_arg "array_map2"; if Array.length v1 == 0 then [| |] else begin let res = Array.create (Array.length v1) (f v1.(0) v2.(0)) in for i = 1 to pred (Array.length v1) do res.(i) <- f v1.(i) v2.(i) done; res end let array_map2_i f v1 v2 = if Array.length v1 <> Array.length v2 then invalid_arg "array_map2"; if Array.length v1 == 0 then [| |] else begin let res = Array.create (Array.length v1) (f 0 v1.(0) v2.(0)) in for i = 1 to pred (Array.length v1) do res.(i) <- f i v1.(i) v2.(i) done; res end let array_map3 f v1 v2 v3 = if Array.length v1 <> Array.length v2 || Array.length v1 <> Array.length v3 then invalid_arg "array_map3"; if Array.length v1 == 0 then [| |] else begin let res = Array.create (Array.length v1) (f v1.(0) v2.(0) v3.(0)) in for i = 1 to pred (Array.length v1) do res.(i) <- f v1.(i) v2.(i) v3.(i) done; res end let array_map_left f a = (* Ocaml does not guarantee Array.map is LR *) let l = Array.length a in (* (even if so), then we rewrite it *) if l = 0 then [||] else begin let r = Array.create l (f a.(0)) in for i = 1 to l - 1 do r.(i) <- f a.(i) done; r end let array_map_left_pair f a g b = let l = Array.length a in if l = 0 then [||],[||] else begin let r = Array.create l (f a.(0)) in let s = Array.create l (g b.(0)) in for i = 1 to l - 1 do r.(i) <- f a.(i); s.(i) <- g b.(i) done; r, s end let array_iter2 f v1 v2 = let n = Array.length v1 in if Array.length v2 <> n then invalid_arg "array_iter2" else for i = 0 to n - 1 do f v1.(i) v2.(i) done let pure_functional = false let array_fold_map' f v e = if pure_functional then let (l,e) = Array.fold_right (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) v ([],e) in (Array.of_list l,e) else let e' = ref e in let v' = Array.map (fun x -> let (y,e) = f x !e' in e' := e; y) v in (v',!e') let array_fold_map f e v = let e' = ref e in let v' = Array.map (fun x -> let (e,y) = f !e' x in e' := e; y) v in (!e',v') let array_fold_map2' f v1 v2 e = let e' = ref e in let v' = array_map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2 in (v',!e') let array_distinct v = let visited = Hashtbl.create 23 in try Array.iter (fun x -> if Hashtbl.mem visited x then raise Exit else Hashtbl.add visited x x) v; true with Exit -> false let array_union_map f a acc = Array.fold_left (fun x y -> f y x) acc a let array_rev_to_list a = let rec tolist i res = if i >= Array.length a then res else tolist (i+1) (a.(i) :: res) in tolist 0 [] let array_filter_along f filter v = Array.of_list (list_filter_along f filter (Array.to_list v)) let array_filter_with filter v = Array.of_list (list_filter_with filter (Array.to_list v)) (* Stream *) let stream_nth n st = try List.nth (Stream.npeek (n+1) st) n with Failure _ -> raise Stream.Failure let stream_njunk n st = for i = 1 to n do Stream.junk st done (* Matrices *) let matrix_transpose mat = List.fold_right (List.map2 (fun p c -> p::c)) mat (if mat = [] then [] else List.map (fun _ -> []) (List.hd mat)) (* Functions *) let identity x = x let compose f g x = f (g x) let const x _ = x let iterate f = let rec iterate_f n x = if n <= 0 then x else iterate_f (pred n) (f x) in iterate_f let repeat n f x = for i = 1 to n do f x done let iterate_for a b f x = let rec iterate i v = if i > b then v else iterate (succ i) (f i v) in iterate a x (* Delayed computations *) type 'a delayed = unit -> 'a let delayed_force f = f () (* Misc *) type ('a,'b) union = Inl of 'a | Inr of 'b module Intset = Set.Make(struct type t = int let compare = compare end) module Intmap = Map.Make(struct type t = int let compare = compare end) let intmap_in_dom x m = try let _ = Intmap.find x m in true with Not_found -> false let intmap_to_list m = Intmap.fold (fun n v l -> (n,v)::l) m [] let intmap_inv m b = Intmap.fold (fun n v l -> if v = b then n::l else l) m [] let interval n m = let rec interval_n (l,m) = if n > m then l else interval_n (m::l,pred m) in interval_n ([],m) let map_succeed f = let rec map_f = function | [] -> [] | h::t -> try (let x = f h in x :: map_f t) with Failure _ -> map_f t in map_f (* Pretty-printing *) let pr_spc = spc let pr_fnl = fnl let pr_int = int let pr_str = str let pr_comma () = str "," ++ spc () let pr_semicolon () = str ";" ++ spc () let pr_bar () = str "|" ++ spc () let pr_arg pr x = spc () ++ pr x let pr_opt pr = function None -> mt () | Some x -> pr_arg pr x let pr_opt_no_spc pr = function None -> mt () | Some x -> pr x let nth n = str (ordinal n) (* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *) let rec prlist elem l = match l with | [] -> mt () | h::t -> Stream.lapp (fun () -> elem h) (prlist elem t) (* unlike all other functions below, [prlist] works lazily. if a strict behavior is needed, use [prlist_strict] instead. evaluation is done from left to right. *) let rec prlist_strict elem l = match l with | [] -> mt () | h::t -> let e = elem h in let r = prlist_strict elem t in e++r (* [prlist_with_sep sep pr [a ; ... ; c]] outputs [pr a ++ sep() ++ ... ++ sep() ++ pr c] *) let rec prlist_with_sep sep elem l = match l with | [] -> mt () | [h] -> elem h | h::t -> let e = elem h and s = sep() and r = prlist_with_sep sep elem t in e ++ s ++ r (* Print sequence of objects separated by space (unless an element is empty) *) let rec pr_sequence elem = function | [] -> mt () | [h] -> elem h | h::t -> let e = elem h and r = pr_sequence elem t in if e = mt () then r else e ++ spc () ++ r (* [pr_enum pr [a ; b ; ... ; c]] outputs [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c] *) let pr_enum pr l = let c,l' = list_sep_last l in prlist_with_sep pr_comma pr l' ++ (if l'<>[] then str " and" ++ spc () else mt()) ++ pr c let pr_vertical_list pr = function | [] -> str "none" ++ fnl () | l -> fnl () ++ str " " ++ hov 0 (prlist_with_sep pr_fnl pr l) ++ fnl () (* [prvecti_with_sep sep pr [|a0 ; ... ; an|]] outputs [pr 0 a0 ++ sep() ++ ... ++ sep() ++ pr n an] *) let prvecti_with_sep sep elem v = let rec pr i = if i = 0 then elem 0 v.(0) else let r = pr (i-1) and s = sep () and e = elem i v.(i) in r ++ s ++ e in let n = Array.length v in if n = 0 then mt () else pr (n - 1) (* [prvecti pr [|a0 ; ... ; an|]] outputs [pr 0 a0 ++ ... ++ pr n an] *) let prvecti elem v = prvecti_with_sep mt elem v (* [prvect_with_sep sep pr [|a ; ... ; c|]] outputs [pr a ++ sep() ++ ... ++ sep() ++ pr c] *) let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v (* [prvect pr [|a ; ... ; c|]] outputs [pr a ++ ... ++ pr c] *) let prvect elem v = prvect_with_sep mt elem v let pr_located pr (loc,x) = if Flags.do_beautify() && loc<>dummy_loc then let (b,e) = unloc loc in comment b ++ pr x ++ comment e else pr x let surround p = hov 1 (str"(" ++ p ++ str")") (*s Memoization *) let memo1_eq eq f = let m = ref None in fun x -> match !m with Some(x',y') when eq x x' -> y' | _ -> let y = f x in m := Some(x,y); y let memo1_1 f = memo1_eq (==) f let memo1_2 f = let f' = memo1_eq (fun (x,y) (x',y') -> x==x' && y==y') (fun (x,y) -> f x y) in (fun x y -> f'(x,y)) (* Memorizes the last n distinct calls to f. Since there is no hash, Efficient only for small n. *) let memon_eq eq n f = let cache = ref [] in (* the cache: a stack *) let m = ref 0 in (* usage of the cache *) let rec find x = function | (x',y')::l when eq x x' -> y', l (* cell is moved to the top *) | [] -> (* we assume n>0, so creating one memo cell is OK *) incr m; (f x, []) | [_] when !m>=n -> f x,[] (* cache is full: dispose of last cell *) | p::l (* not(eq x (fst p)) *) -> let (y,l') = find x l in (y, p::l') in (fun x -> let (y,l) = find x !cache in cache := (x,y)::l; y) (*s Size of ocaml values. *) module Size = struct (*s Pointers already visited are stored in a hash-table, where comparisons are done using physical equality. *) module H = Hashtbl.Make( struct type t = Obj.t let equal = (==) let hash o = Hashtbl.hash (Obj.magic o : int) end) let node_table = (H.create 257 : unit H.t) let in_table o = try H.find node_table o; true with Not_found -> false let add_in_table o = H.add node_table o () let reset_table () = H.clear node_table (*s Objects are traversed recursively, as soon as their tags are less than [no_scan_tag]. [count] records the numbers of words already visited. *) let size_of_double = Obj.size (Obj.repr 1.0) let count = ref 0 let rec traverse t = if not (in_table t) then begin add_in_table t; if Obj.is_block t then begin let n = Obj.size t in let tag = Obj.tag t in if tag < Obj.no_scan_tag then begin count := !count + 1 + n; for i = 0 to n - 1 do let f = Obj.field t i in if Obj.is_block f then traverse f done end else if tag = Obj.string_tag then count := !count + 1 + n else if tag = Obj.double_tag then count := !count + size_of_double else if tag = Obj.double_array_tag then count := !count + 1 + size_of_double * n else incr count end end (*s Sizes of objects in words and in bytes. The size in bytes is computed system-independently according to [Sys.word_size]. *) let size_w o = reset_table (); count := 0; traverse (Obj.repr o); !count let size_b o = (size_w o) * (Sys.word_size / 8) let size_kb o = (size_w o) / (8192 / Sys.word_size) end let size_w = Size.size_w let size_b = Size.size_b let size_kb = Size.size_kb (*s Total size of the allocated ocaml heap. *) let heap_size () = let stat = Gc.stat () and control = Gc.get () in let max_words_total = stat.Gc.heap_words + control.Gc.minor_heap_size in (max_words_total * (Sys.word_size / 8)) let heap_size_kb () = (heap_size () + 1023) / 1024 (*s interruption *) let interrupt = ref false let check_for_interrupt () = if !interrupt then begin interrupt := false; raise Sys.Break end coq-8.4pl4/lib/option.mli0000644000175000017500000001032312326224777014413 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool exception IsNone (** [get x] returns [y] where [x] is [Some y]. It raises IsNone if [x] equals [None]. *) val get : 'a option -> 'a (** [make x] returns [Some x]. *) val make : 'a -> 'a option (** [init b x] returns [Some x] if [b] is [true] and [None] otherwise. *) val init : bool -> 'a -> 'a option (** [flatten x] is [Some y] if [x] is [Some (Some y)] and [None] otherwise. *) val flatten : 'a option option -> 'a option (** {6 "Iterators"} ***) (** [iter f x] executes [f y] if [x] equals [Some y]. It does nothing otherwise. *) val iter : ('a -> unit) -> 'a option -> unit exception Heterogeneous (** [iter2 f x y] executes [f z w] if [x] equals [Some z] and [y] equals [Some w]. It does nothing if both [x] and [y] are [None]. And raises [Heterogeneous] otherwise. *) val iter2 : ('a -> 'b -> unit) -> 'a option -> 'b option -> unit (** [map f x] is [None] if [x] is [None] and [Some (f y)] if [x] is [Some y]. *) val map : ('a -> 'b) -> 'a option -> 'b option (** [smartmap f x] does the same as [map f x] except that it tries to share some memory. *) val smartmap : ('a -> 'a) -> 'a option -> 'a option (** [fold_left f a x] is [f a y] if [x] is [Some y], and [a] otherwise. *) val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a option -> 'b (** [fold_left2 f a x y] is [f z w] if [x] is [Some z] and [y] is [Some w]. It is [a] if both [x] and [y] are [None]. Otherwise it raises [Heterogeneous]. *) val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b option -> 'c option -> 'a (** [fold_right f x a] is [f y a] if [x] is [Some y], and [a] otherwise. *) val fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b (** [fold_map f a x] is [a, f y] if [x] is [Some y], and [a] otherwise. *) val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b option -> 'a * 'c option (** [cata e f x] is [e] if [x] is [None] and [f a] if [x] is [Some a] *) val cata : ('a -> 'b) -> 'b -> 'a option -> 'b (** {6 More Specific Operations} ***) (** [default a x] is [y] if [x] is [Some y] and [a] otherwise. *) val default : 'a -> 'a option -> 'a (** [lift] is the same as {!map}. *) val lift : ('a -> 'b) -> 'a option -> 'b option (** [lift_right f a x] is [Some (f a y)] if [x] is [Some y], and [None] otherwise. *) val lift_right : ('a -> 'b -> 'c) -> 'a -> 'b option -> 'c option (** [lift_left f x a] is [Some (f y a)] if [x] is [Some y], and [None] otherwise. *) val lift_left : ('a -> 'b -> 'c) -> 'a option -> 'b -> 'c option (** [lift2 f x y] is [Some (f z w)] if [x] equals [Some z] and [y] equals [Some w]. It is [None] otherwise. *) val lift2 : ('a -> 'b -> 'c) -> 'a option -> 'b option -> 'c option (** {6 Operations with Lists} *) module List : sig (** [List.cons x l] equals [y::l] if [x] is [Some y] and [l] otherwise. *) val cons : 'a option -> 'a list -> 'a list (** [List.flatten l] is the list of all the [y]s such that [l] contains [Some y] (in the same order). *) val flatten : 'a option list -> 'a list end (** {6 Miscelaneous Primitives} *) module Misc : sig (** [Misc.compare f x y] lifts the equality predicate [f] to option types. That is, if both [x] and [y] are [None] then it returns [true], if they are bothe [Some _] then [f] is called. Otherwise it returns [false]. *) val compare : ('a -> 'a -> bool) -> 'a option -> 'a option -> bool end coq-8.4pl4/lib/segmenttree.ml0000644000175000017500000001050112326224777015252 0ustar stephsteph(** This module is a very simple implementation of "segment trees". A segment tree of type ['a t] represents a mapping from a union of disjoint segments to some values of type 'a. *) (** Misc. functions. *) let list_iteri f l = let rec loop i = function | [] -> () | x :: xs -> f i x; loop (i + 1) xs in loop 0 l let log2 x = log x /. log 2. let log2n x = int_of_float (ceil (log2 (float_of_int x))) (** We focus on integers but this module can be generalized. *) type elt = int (** A value of type [domain] is interpreted differently given its position in the tree. On internal nodes, a domain represents the set of integers which are _not_ in the set of keys handled by the tree. On leaves, a domain represents the st of integers which are in the set of keys. *) type domain = (** On internal nodes, a domain [Interval (a, b)] represents the interval [a + 1; b - 1]. On leaves, it represents [a; b]. We always have [a] <= [b]. *) | Interval of elt * elt (** On internal node or root, a domain [Universe] represents all the integers. When the tree is not a trivial root, [Universe] has no interpretation on leaves. (The lookup function should never reach the leaves.) *) | Universe (** We use an array to store the almost complete tree. This array contains at least one element. *) type 'a t = (domain * 'a option) array (** The root is the first item of the array. *) (** Standard layout for left child. *) let left_child i = 2 * i + 1 (** Standard layout for right child. *) let right_child i = 2 * i + 2 (** Extract the annotation of a node, be it internal or a leaf. *) let value_of i t = match t.(i) with (_, Some x) -> x | _ -> raise Not_found (** Initialize the array to store [n] leaves. *) let create n init = Array.make (1 lsl (log2n n + 1) - 1) init (** Make a complete interval tree from a list of disjoint segments. Precondition : the segments must be sorted. *) let make segments = let nsegments = List.length segments in let tree = create nsegments (Universe, None) in let leaves_offset = (1 lsl (log2n nsegments)) - 1 in (** The algorithm proceeds in two steps using an intermediate tree to store minimum and maximum of each subtree as annotation of the node. *) (** We start from leaves: the last level of the tree is initialized with the given segments... *) list_iteri (fun i ((start, stop), value) -> let k = leaves_offset + i in let i = Interval (start, stop) in tree.(k) <- (i, Some i)) segments; (** ... the remaining leaves are initialized with neutral information. *) for k = leaves_offset + nsegments to Array.length tree -1 do tree.(k) <- (Universe, Some Universe) done; (** We traverse the tree bottom-up and compute the interval and annotation associated to each node from the annotations of its children. *) for k = leaves_offset - 1 downto 0 do let node, annotation = match value_of (left_child k) tree, value_of (right_child k) tree with | Interval (left_min, left_max), Interval (right_min, right_max) -> (Interval (left_max, right_min), Interval (left_min, right_max)) | Interval (min, max), Universe -> (Interval (max, max), Interval (min, max)) | Universe, Universe -> Universe, Universe | Universe, _ -> assert false in tree.(k) <- (node, Some annotation) done; (** Finally, annotation are replaced with the image related to each leaf. *) let final_tree = Array.mapi (fun i (segment, value) -> (segment, None)) tree in list_iteri (fun i ((start, stop), value) -> final_tree.(leaves_offset + i) <- (Interval (start, stop), Some value)) segments; final_tree (** [lookup k t] looks for an image for key [k] in the interval tree [t]. Raise [Not_found] if it fails. *) let lookup k t = let i = ref 0 in while (snd t.(!i) = None) do match fst t.(!i) with | Interval (start, stop) -> if k <= start then i := left_child !i else if k >= stop then i:= right_child !i else raise Not_found | Universe -> raise Not_found done; match fst t.(!i) with | Interval (start, stop) -> if k >= start && k <= stop then match snd t.(!i) with | Some v -> v | None -> assert false else raise Not_found | Universe -> assert false coq-8.4pl4/lib/doc.tex0000644000175000017500000000021712326224777013670 0ustar stephsteph \newpage \section*{Utility libraries} \ocwsection \label{lib} This chapter describes the various utility libraries used in the code of \Coq. coq-8.4pl4/lib/heap.ml0000644000175000017500000001047212326224777013654 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t -> int end module type S =sig (* Type of functional heaps *) type t (* Type of elements *) type elt (* The empty heap *) val empty : t (* [add x h] returns a new heap containing the elements of [h], plus [x]; complexity $O(log(n))$ *) val add : elt -> t -> t (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] when [h] is empty; complexity $O(1)$ *) val maximum : t -> elt (* [remove h] returns a new heap containing the elements of [h], except the maximum of [h]; raises [EmptyHeap] when [h] is empty; complexity $O(log(n))$ *) val remove : t -> t (* usual iterators and combinators; elements are presented in arbitrary order *) val iter : (elt -> unit) -> t -> unit val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a end exception EmptyHeap (*s Functional implementation *) module Functional(X : Ordered) = struct (* Heaps are encoded as complete binary trees, i.e., binary trees which are full expect, may be, on the bottom level where it is filled from the left. These trees also enjoy the heap property, namely the value of any node is greater or equal than those of its left and right subtrees. There are 4 kinds of complete binary trees, denoted by 4 constructors: [FFF] for a full binary tree (and thus 2 full subtrees); [PPF] for a partial tree with a partial left subtree and a full right subtree; [PFF] for a partial tree with a full left subtree and a full right subtree (but of different heights); and [PFP] for a partial tree with a full left subtree and a partial right subtree. *) type t = | Empty | FFF of t * X.t * t (* full (full, full) *) | PPF of t * X.t * t (* partial (partial, full) *) | PFF of t * X.t * t (* partial (full, full) *) | PFP of t * X.t * t (* partial (full, partial) *) type elt = X.t let empty = Empty (* smart constructors for insertion *) let p_f l x r = match l with | Empty | FFF _ -> PFF (l, x, r) | _ -> PPF (l, x, r) let pf_ l x = function | Empty | FFF _ as r -> FFF (l, x, r) | r -> PFP (l, x, r) let rec add x = function | Empty -> FFF (Empty, x, Empty) (* insertion to the left *) | FFF (l, y, r) | PPF (l, y, r) -> if X.compare x y > 0 then p_f (add y l) x r else p_f (add x l) y r (* insertion to the right *) | PFF (l, y, r) | PFP (l, y, r) -> if X.compare x y > 0 then pf_ l x (add y r) else pf_ l y (add x r) let maximum = function | Empty -> raise EmptyHeap | FFF (_, x, _) | PPF (_, x, _) | PFF (_, x, _) | PFP (_, x, _) -> x (* smart constructors for removal; note that they are different from the ones for insertion! *) let p_f l x r = match l with | Empty | FFF _ -> FFF (l, x, r) | _ -> PPF (l, x, r) let pf_ l x = function | Empty | FFF _ as r -> PFF (l, x, r) | r -> PFP (l, x, r) let rec remove = function | Empty -> raise EmptyHeap | FFF (Empty, _, Empty) -> Empty | PFF (l, _, Empty) -> l (* remove on the left *) | PPF (l, x, r) | PFF (l, x, r) -> let xl = maximum l in let xr = maximum r in let l' = remove l in if X.compare xl xr >= 0 then p_f l' xl r else p_f l' xr (add xl (remove r)) (* remove on the right *) | FFF (l, x, r) | PFP (l, x, r) -> let xl = maximum l in let xr = maximum r in let r' = remove r in if X.compare xl xr > 0 then pf_ (add xr (remove l)) xl r' else pf_ l xr r' let rec iter f = function | Empty -> () | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> iter f l; f x; iter f r let rec fold f h x0 = match h with | Empty -> x0 | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> fold f l (fold f r (f x x0)) end coq-8.4pl4/lib/lib.mllib0000644000175000017500000000035112326224777014167 0ustar stephstephXml_lexer Xml_parser Xml_utils Pp_control Pp Compat Flags Segmenttree Unicodetable Util Errors Bigint Hashcons Dyn System Envars Gmap Fset Fmap Tries Gmapl Profile Explore Predicate Rtree Heap Option Dnet Store Unionfind Hashtbl_alt coq-8.4pl4/lib/profile.mli0000644000175000017500000001134612326224777014551 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val print_profile : unit -> unit val reset_profile : unit -> unit val init_profile : unit -> unit val declare_profile : string -> profile_key val profile1 : profile_key -> ('a -> 'b) -> 'a -> 'b val profile2 : profile_key -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c val profile3 : profile_key -> ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd val profile4 : profile_key -> ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e val profile5 : profile_key -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f val profile6 : profile_key -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g val profile7 : profile_key -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h (** Some utilities to compute the logical and physical sizes and depth of ML objects *) (** Print logical size (in words) and depth of its argument This function does not disturb the heap *) val print_logical_stats : 'a -> unit (** Print physical size, logical size (in words) and depth of its argument This function allocates itself a lot (the same order of magnitude as the physical size of its argument) *) val print_stats : 'a -> unit (** Return logical size (first for strings, then for not strings), (in words) and depth of its argument This function allocates itself a lot *) val obj_stats : 'a -> int * int * int (** Return physical size of its argument (string part and rest) This function allocates itself a lot *) val obj_shared_size : 'a -> int * int coq-8.4pl4/lib/hashtbl_alt.mli0000644000175000017500000000333212326224777015372 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t -> bool end module type S = sig type elt (* [may_add_and_get key constr] uses [key] to look for [constr] in the hash table [H]. If [constr] is in [H], returns the specific representation that is stored in [H]. Otherwise, [constr] is stored in [H] and will be used as the canonical representation of this value in the future. *) val may_add_and_get : int -> elt -> elt end module Make (E : Hashtype) : S with type elt = E.t module Combine : sig val combine : int -> int -> int val combinesmall : int -> int -> int val combine3 : int -> int -> int -> int val combine4 : int -> int -> int -> int -> int end coq-8.4pl4/lib/pp_control.mli0000644000175000017500000000242412326224777015265 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* pp_global_params -> unit val set_dflt_gp : Format.formatter -> unit val get_gp : Format.formatter -> pp_global_params (** {6 Output functions of pretty-printing. } *) val with_output_to : out_channel -> Format.formatter val std_ft : Format.formatter ref val err_ft : Format.formatter ref val deep_ft : Format.formatter ref (** {6 For parametrization through vernacular. } *) val set_depth_boxes : int option -> unit val get_depth_boxes : unit -> int option val set_margin : int option -> unit val get_margin : unit -> int option coq-8.4pl4/lib/rtree.mli0000644000175000017500000000606212326224777014231 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a t array -> 'a t (** Build mutually recursive trees: X_1 = f_1(X_1,..,X_n) ... X_n = f_n(X_1,..,X_n) is obtained by the following pseudo-code let vx = mk_rec_calls n in let [|x_1;..;x_n|] = mk_rec[|f_1(vx.(0),..,vx.(n-1);..;f_n(vx.(0),..,vx.(n-1))|] First example: build rec X = a(X,Y) and Y = b(X,Y,Y) let [|vx;vy|] = mk_rec_calls 2 in let [|x;y|] = mk_rec [|mk_node a [|vx;vy|]; mk_node b [|vx;vy;vy|]|] Another example: nested recursive trees rec Y = b(rec X = a(X,Y),Y,Y) let [|vy|] = mk_rec_calls 1 in let [|vx|] = mk_rec_calls 1 in let [|x|] = mk_rec[|mk_node a vx;lift 1 vy|] let [|y|] = mk_rec[|mk_node b x;vy;vy|] (note the lift to avoid *) val mk_rec_calls : int -> 'a t array val mk_rec : 'a t array -> 'a t array (** [lift k t] increases of [k] the free parameters of [t]. Needed to avoid captures when a tree appears under [mk_rec] *) val lift : int -> 'a t -> 'a t val is_node : 'a t -> bool (** Destructors (recursive calls are expanded) *) val dest_node : 'a t -> 'a * 'a t array (** dest_param is not needed for closed trees (i.e. with no free variable) *) val dest_param : 'a t -> int * int (** Tells if a tree has an infinite branch *) val is_infinite : 'a t -> bool (** [compare_rtree f t1 t2] compares t1 t2 (top-down). f is called on each node: if the result is negative then the traversal ends on false, it is is positive then deeper nodes are not examined, and the traversal continues on respective siblings, and if it is 0, then the traversal continues on sons, pairwise. In this latter case, if the nodes do not have the same number of sons, then the traversal ends on false. In case of loop, the traversal is successful and it resumes on siblings. *) val compare_rtree : ('a t -> 'b t -> int) -> 'a t -> 'b t -> bool val eq_rtree : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** Iterators *) val map : ('a -> 'b) -> 'a t -> 'b t (** [(smartmap f t) == t] if [(f a) ==a ] for all nodes *) val smartmap : ('a -> 'a) -> 'a t -> 'a t val fold : (bool -> 'a t -> ('a t -> 'b) -> 'b) -> 'a t -> 'b val fold2 : (bool -> 'a t -> 'b -> ('a t -> 'b -> 'c) -> 'c) -> 'a t -> 'b -> 'c (** A rather simple minded pretty-printer *) val pp_tree : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds coq-8.4pl4/lib/errors.ml0000644000175000017500000000544412326224777014256 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bottom e | h::stk' -> try h e with | Unhandled -> print_gen bottom stk' e | any -> print_gen bottom stk' any (** Only anomalies should reach the bottom of the handler stack. In usual situation, the [handle_stack] is treated as it if was always non-empty with [print_anomaly] as its bottom handler. *) let where s = if !Flags.debug then str ("in "^s^":") ++ spc () else mt () let raw_anomaly e = match e with | Util.Anomaly (s,pps) -> where s ++ pps ++ str "." | Assert_failure _ | Match_failure _ -> str (Printexc.to_string e ^ ".") | _ -> str ("Uncaught exception " ^ Printexc.to_string e ^ ".") let print_anomaly askreport e = if askreport then hov 0 (str "Anomaly: " ++ raw_anomaly e ++ spc () ++ str "Please report.") else hov 0 (raw_anomaly e) (** The standard exception printer *) let print e = print_gen (print_anomaly true) !handle_stack e (** Same as [print], except that the "Please report" part of an anomaly isn't printed (used in Ltac debugging). *) let print_no_report e = print_gen (print_anomaly false) !handle_stack e (** Same as [print], except that anomalies are not printed but re-raised (used for the Fail command) *) let print_no_anomaly e = print_gen (fun e -> raise e) !handle_stack e (** Predefined handlers **) let _ = register_handler begin function | Util.UserError(s,pps) -> hov 0 (str "Error: " ++ where s ++ pps) | _ -> raise Unhandled end (** Critical exceptions shouldn't be catched and ignored by mistake by inner functions during a [vernacinterp]. They should be handled only at the very end of interp, to be displayed to the user. *) (** NB: in the 8.4 branch, for maximal compatibility, anomalies are considered non-critical *) let noncritical = function | Sys.Break | Out_of_memory | Stack_overflow -> false | _ -> true coq-8.4pl4/lib/flags.ml0000644000175000017500000001064612326224777014036 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* o := old; raise reraise let without_option o f x = let old = !o in o:=false; try let r = f x in o := old; r with reraise -> o := old; raise reraise let boot = ref false let batch_mode = ref false let debug = ref false let print_emacs = ref false let term_quality = ref false let xml_export = ref false type load_proofs = Force | Lazy | Dont let load_proofs = ref Lazy let raw_print = ref false let record_print = ref true (* Compatibility mode *) (* Current means no particular compatibility consideration. For correct comparisons, this constructor should remain the last one. *) type compat_version = V8_2 | V8_3 | Current let compat_version = ref Current let version_strictly_greater v = !compat_version > v let version_less_or_equal v = not (version_strictly_greater v) let pr_version = function | V8_2 -> "8.2" | V8_3 -> "8.3" | Current -> "current" (* Translate *) let beautify = ref false let make_beautify f = beautify := f let do_beautify () = !beautify let beautify_file = ref false (* Silent / Verbose *) let silent = ref false let make_silent flag = silent := flag; () let is_silent () = !silent let is_verbose () = not !silent let silently f x = with_option silent f x let verbosely f x = without_option silent f x let if_silent f x = if !silent then f x let if_verbose f x = if not !silent then f x let auto_intros = ref true let make_auto_intros flag = auto_intros := flag let is_auto_intros () = version_strictly_greater V8_2 && !auto_intros let hash_cons_proofs = ref true let warn = ref true let make_warn flag = warn := flag; () let if_warn f x = if !warn then f x (* The number of printed hypothesis in a goal *) let print_hyps_limit = ref (None : int option) let set_print_hyps_limit n = print_hyps_limit := n let print_hyps_limit () = !print_hyps_limit (* A list of the areas of the system where "unsafe" operation * has been requested *) module Stringset = Set.Make(struct type t = string let compare = compare end) let unsafe_set = ref Stringset.empty let add_unsafe s = unsafe_set := Stringset.add s !unsafe_set let is_unsafe s = Stringset.mem s !unsafe_set (* Flags for external tools *) let subst_command_placeholder s t = let buff = Buffer.create (String.length s + String.length t) in let i = ref 0 in while (!i < String.length s) do if s.[!i] = '%' & !i+1 < String.length s & s.[!i+1] = 's' then (Buffer.add_string buff t;incr i) else Buffer.add_char buff s.[!i]; incr i done; Buffer.contents buff let browser_cmd_fmt = try let coq_netscape_remote_var = "COQREMOTEBROWSER" in Sys.getenv coq_netscape_remote_var with Not_found -> Coq_config.browser let is_standard_doc_url url = let wwwcompatprefix = "http://www.lix.polytechnique.fr/coq/" in let n = String.length Coq_config.wwwcoq in let n' = String.length Coq_config.wwwrefman in url = Coq_config.localwwwrefman || url = Coq_config.wwwrefman || url = wwwcompatprefix ^ String.sub Coq_config.wwwrefman n (n'-n) (* same as in System, but copied here because of dependencies *) let canonical_path_name p = let current = Sys.getcwd () in Sys.chdir p; let result = Sys.getcwd () in Sys.chdir current; result (* Options for changing coqlib *) let coqlib_spec = ref false let coqlib = ref ( (* same as Envars.coqroot, but copied here because of dependencies *) Filename.dirname (canonical_path_name (Filename.dirname Sys.executable_name)) ) (* Options for changing camlbin (used by coqmktop) *) let camlbin_spec = ref false let camlbin = ref Coq_config.camlbin (* Options for changing camlp4bin (used by coqmktop) *) let camlp4bin_spec = ref false let camlp4bin = ref Coq_config.camlp4bin (* Level of inlining during a functor application *) let default_inline_level = 100 let inline_level = ref default_inline_level let set_inline_level = (:=) inline_level let get_inline_level () = !inline_level coq-8.4pl4/lib/system.mli0000644000175000017500000000550212326224777014432 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string val exclude_search_in_dirname : string -> unit val all_subdirs : unix_path:string -> (physical_path * string list) list val is_in_path : load_path -> string -> bool val is_in_system_path : string -> bool val where_in_path : ?warn:bool -> load_path -> string -> physical_path * string val physical_path_of_string : string -> physical_path val string_of_physical_path : physical_path -> string val make_suffix : string -> string -> string val file_readable_p : string -> bool val expand_path_macros : string -> string val getenv_else : string -> string -> string val home : string val exists_dir : string -> bool val find_file_in_path : ?warn:bool -> load_path -> string -> physical_path * string (** {6 I/O functions } *) (** Generic input and output functions, parameterized by a magic number and a suffix. The intern functions raise the exception [Bad_magic_number] when the check fails, with the full file name. *) val marshal_out : out_channel -> 'a -> unit val marshal_in : string -> in_channel -> 'a exception Bad_magic_number of string val raw_extern_intern : int -> string -> (string -> string * out_channel) * (string -> in_channel) val extern_intern : ?warn:bool -> int -> string -> (string -> 'a -> unit) * (load_path -> string -> 'a) val with_magic_number_check : ('a -> 'b) -> 'a -> 'b (** {6 Sending/receiving once with external executable } *) val connect : (out_channel -> unit) -> (in_channel -> 'a) -> string -> 'a (** {6 Executing commands } *) (** [run_command converter f com] launches command [com], and returns the contents of stdout and stderr that have been processed with [converter]; the processed contents of stdout and stderr is also passed to [f] *) val run_command : (string -> string) -> (string -> unit) -> string -> Unix.process_status * string (** {6 Time stamps.} *) type time val get_time : unit -> time val time_difference : time -> time -> float (** in seconds *) val fmt_time_difference : time -> time -> Pp.std_ppcmds coq-8.4pl4/lib/predicate.ml0000644000175000017500000000565312326224777014704 0ustar stephsteph(************************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License. *) (* *) (************************************************************************) (* Sets over ordered types *) module type OrderedType = sig type t val compare: t -> t -> int end module type S = sig type elt type t val empty: t val full: t val is_empty: t -> bool val is_full: t -> bool val mem: elt -> t -> bool val singleton: elt -> t val add: elt -> t -> t val remove: elt -> t -> t val union: t -> t -> t val inter: t -> t -> t val diff: t -> t -> t val complement: t -> t val equal: t -> t -> bool val subset: t -> t -> bool val elements: t -> bool * elt list end module Make(Ord: OrderedType) = struct module EltSet = Set.Make(Ord) (* when bool is false, the denoted set is the complement of the given set *) type elt = Ord.t type t = bool * EltSet.t let elements (b,s) = (b, EltSet.elements s) let empty = (false,EltSet.empty) let full = (true,EltSet.empty) (* assumes the set is infinite *) let is_empty (b,s) = not b & EltSet.is_empty s let is_full (b,s) = b & EltSet.is_empty s let mem x (b,s) = if b then not (EltSet.mem x s) else EltSet.mem x s let singleton x = (false,EltSet.singleton x) let add x (b,s) = if b then (b,EltSet.remove x s) else (b,EltSet.add x s) let remove x (b,s) = if b then (b,EltSet.add x s) else (b,EltSet.remove x s) let complement (b,s) = (not b, s) let union s1 s2 = match (s1,s2) with ((false,p1),(false,p2)) -> (false,EltSet.union p1 p2) | ((true,n1),(true,n2)) -> (true,EltSet.inter n1 n2) | ((false,p1),(true,n2)) -> (true,EltSet.diff n2 p1) | ((true,n1),(false,p2)) -> (true,EltSet.diff n1 p2) let inter s1 s2 = complement (union (complement s1) (complement s2)) let diff s1 s2 = inter s1 (complement s2) let subset s1 s2 = match (s1,s2) with ((false,p1),(false,p2)) -> EltSet.subset p1 p2 | ((true,n1),(true,n2)) -> EltSet.subset n2 n1 | ((false,p1),(true,n2)) -> EltSet.is_empty (EltSet.inter p1 n2) | ((true,_),(false,_)) -> false let equal (b1,s1) (b2,s2) = b1=b2 & EltSet.equal s1 s2 end coq-8.4pl4/lib/gmap.mli0000644000175000017500000000226412326224777014034 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool val add : 'a -> 'b -> ('a,'b) t -> ('a,'b) t val find : 'a -> ('a,'b) t -> 'b val remove : 'a -> ('a,'b) t -> ('a,'b) t val mem : 'a -> ('a,'b) t -> bool val iter : ('a -> 'b -> unit) -> ('a,'b) t -> unit val map : ('b -> 'c) -> ('a,'b) t -> ('a,'c) t val fold : ('a -> 'b -> 'c -> 'c) -> ('a,'b) t -> 'c -> 'c (** Additions with respect to ocaml standard library. *) val dom : ('a,'b) t -> 'a list val rng : ('a,'b) t -> 'b list val to_list : ('a,'b) t -> ('a * 'b) list coq-8.4pl4/lib/pp.mli0000644000175000017500000000735712326224777013537 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val make_pp_nonemacs:unit -> unit (** Pretty-printers. *) type ppcmd type std_ppcmds = ppcmd Stream.t (** {6 Formatting commands. } *) val str : string -> std_ppcmds val stras : int * string -> std_ppcmds val brk : int * int -> std_ppcmds val tbrk : int * int -> std_ppcmds val tab : unit -> std_ppcmds val fnl : unit -> std_ppcmds val pifb : unit -> std_ppcmds val ws : int -> std_ppcmds val mt : unit -> std_ppcmds val ismt : std_ppcmds -> bool val comment : int -> std_ppcmds val comments : ((int * int) * string) list ref (** {6 Concatenation. } *) val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds (** {6 Evaluation. } *) val eval_ppcmds : std_ppcmds -> std_ppcmds (** {6 Derived commands. } *) val spc : unit -> std_ppcmds val cut : unit -> std_ppcmds val align : unit -> std_ppcmds val int : int -> std_ppcmds val real : float -> std_ppcmds val bool : bool -> std_ppcmds val qstring : string -> std_ppcmds val qs : string -> std_ppcmds val quote : std_ppcmds -> std_ppcmds val strbrk : string -> std_ppcmds val xmlescape : ppcmd -> ppcmd (** {6 Boxing commands. } *) val h : int -> std_ppcmds -> std_ppcmds val v : int -> std_ppcmds -> std_ppcmds val hv : int -> std_ppcmds -> std_ppcmds val hov : int -> std_ppcmds -> std_ppcmds val t : std_ppcmds -> std_ppcmds (** {6 Opening and closing of boxes. } *) val hb : int -> std_ppcmds val vb : int -> std_ppcmds val hvb : int -> std_ppcmds val hovb : int -> std_ppcmds val tb : unit -> std_ppcmds val close : unit -> std_ppcmds val tclose : unit -> std_ppcmds (** {6 Pretty-printing functions {% \emph{%}without flush{% }%}. } *) val pp_with : Format.formatter -> std_ppcmds -> unit val ppnl_with : Format.formatter -> std_ppcmds -> unit val warning_with : Format.formatter -> string -> unit val warn_with : Format.formatter -> std_ppcmds -> unit val pp_flush_with : Format.formatter -> unit -> unit val set_warning_function : (Format.formatter -> std_ppcmds -> unit) -> unit (** {6 Pretty-printing functions {% \emph{%}with flush{% }%}. } *) val msg_with : Format.formatter -> std_ppcmds -> unit val msgnl_with : Format.formatter -> std_ppcmds -> unit (** {6 ... } *) (** The following functions are instances of the previous ones on [std_ft] and [err_ft]. *) (** {6 Pretty-printing functions {% \emph{%}without flush{% }%} on [stdout] and [stderr]. } *) val pp : std_ppcmds -> unit val ppnl : std_ppcmds -> unit val pperr : std_ppcmds -> unit val pperrnl : std_ppcmds -> unit val message : string -> unit (** = pPNL *) val warning : string -> unit val warn : std_ppcmds -> unit val pp_flush : unit -> unit val flush_all: unit -> unit (** {6 Pretty-printing functions {% \emph{%}with flush{% }%} on [stdout] and [stderr]. } *) val msg : std_ppcmds -> unit val msgnl : std_ppcmds -> unit val msgerr : std_ppcmds -> unit val msgerrnl : std_ppcmds -> unit val msg_warning : std_ppcmds -> unit val msg_warn : string -> unit (** Same specific display in emacs as warning, but without the "Warning:" **) val msg_debug : std_ppcmds -> unit val string_of_ppcmds : std_ppcmds -> string coq-8.4pl4/lib/envars.mli0000644000175000017500000000177012326224777014407 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string val docdir : unit -> string val coqbin : string val coqroot : string (* coqpath is stored in reverse order, since that is the order it * gets added to the searc path *) val xdg_config_home : string val xdg_dirs : string list val coqpath : string list val camlbin : unit -> string val camlp4bin : unit -> string val camllib : unit -> string val camlp4lib : unit -> string coq-8.4pl4/pretyping/0000755000175000017500000000000012365131025013636 5ustar stephstephcoq-8.4pl4/pretyping/indrec.ml0000644000175000017500000004657212326224777015470 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (n, c, Termops.refresh_universes t)) mib.mind_params_ctxt in if not (List.mem kind (elim_sorts specif)) then raise (RecursionSchemeError (NotAllowedCaseAnalysis (false, Termops.new_sort_in_family kind, ind))); let ndepar = mip.mind_nrealargs_ctxt + 1 in (* Pas génant car env ne sert pas ā typer mais juste ā renommer les Anonym *) (* mais pas trčs joli ... (mais manque get_sort_of ā ce niveau) *) let env' = push_rel_context lnamespar env in let indf = make_ind_family(ind, Termops.extended_rel_list 0 lnamespar) in let constrs = get_constructors env indf in let rec add_branch env k = if k = Array.length mip.mind_consnames then let nbprod = k+1 in let indf' = lift_inductive_family nbprod indf in let arsign,_ = get_arity env indf' in let depind = build_dependent_inductive env indf' in let deparsign = (Anonymous,None,depind)::arsign in let ci = make_case_info env ind RegularStyle in let pbody = appvect (mkRel (ndepar + nbprod), if dep then Termops.extended_rel_vect 0 deparsign else Termops.extended_rel_vect 1 arsign) in let p = it_mkLambda_or_LetIn_name env' ((if dep then mkLambda_name env' else mkLambda) (Anonymous,depind,pbody)) arsign in it_mkLambda_or_LetIn_name env' (mkCase (ci, lift ndepar p, mkRel 1, Termops.rel_vect ndepar k)) deparsign else let cs = lift_constructor (k+1) constrs.(k) in let t = build_branch_type env dep (mkRel (k+1)) cs in mkLambda_string "f" t (add_branch (push_rel (Anonymous, None, t) env) (k+1)) in let typP = make_arity env' dep indf (Termops.new_sort_in_family kind) in it_mkLambda_or_LetIn_name env (mkLambda_string "P" typP (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar (* check if the type depends recursively on one of the inductive scheme *) (**********************************************************************) (* Building the recursive elimination *) (* Christine Paulin, 1996 *) (* * t is the type of the constructor co and recargs is the information on * the recursive calls. (It is assumed to be in form given by the user). * build the type of the corresponding branch of the recurrence principle * assuming f has this type, branch_rec gives also the term * [x1]..[xk](f xi (F xi) ...) to be put in the corresponding branch of * the case operation * FPvect gives for each inductive definition if we want an elimination * on it with which predicate and which recursive function. *) let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = let make_prod = make_prod_dep dep in let nparams = List.length vargs in let process_pos env depK pk = let rec prec env i sign p = let p',largs = whd_betadeltaiota_nolet_stack env sigma p in match kind_of_term p' with | Prod (n,t,c) -> let d = (n,None,t) in make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c) | LetIn (n,b,t,c) -> let d = (n,Some b,t) in mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c) | Ind (_,_) -> let realargs = list_skipn nparams largs in let base = applist (lift i pk,realargs) in if depK then Reduction.beta_appvect base [|applist (mkRel (i+1), Termops.extended_rel_list 0 sign)|] else base | _ -> assert false in prec env 0 [] in let rec process_constr env i c recargs nhyps li = if nhyps > 0 then match kind_of_term c with | Prod (n,t,c_0) -> let (optionpos,rest) = match recargs with | [] -> None,[] | ra::rest -> (match dest_recarg ra with | Mrec (_,j) when is_rec -> (depPvect.(j),rest) | Imbr _ -> Flags.if_warn msg_warning (str "Ignoring recursive call"); (None,rest) | _ -> (None, rest)) in (match optionpos with | None -> make_prod env (n,t, process_constr (push_rel (n,None,t) env) (i+1) c_0 rest (nhyps-1) (i::li)) | Some(dep',p) -> let nP = lift (i+1+decP) p in let env' = push_rel (n,None,t) env in let t_0 = process_pos env' dep' nP (lift 1 t) in make_prod_dep (dep or dep') env (n,t, mkArrow t_0 (process_constr (push_rel (Anonymous,None,t_0) env') (i+2) (lift 1 c_0) rest (nhyps-1) (i::li)))) | LetIn (n,b,t,c_0) -> mkLetIn (n,b,t, process_constr (push_rel (n,Some b,t) env) (i+1) c_0 recargs (nhyps-1) li) | _ -> assert false else if dep then let realargs = List.map (fun k -> mkRel (i-k)) (List.rev li) in let params = List.map (lift i) vargs in let co = applist (mkConstruct cs.cs_cstr,params@realargs) in Reduction.beta_appvect c [|co|] else c in let nhyps = List.length cs.cs_args in let nP = match depPvect.(tyi) with | Some(_,p) -> lift (nhyps+decP) p | _ -> assert false in let base = appvect (nP,cs.cs_concl_realargs) in let c = it_mkProd_or_LetIn base cs.cs_args in process_constr env 0 c recargs nhyps [] let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = let process_pos env fk = let rec prec env i hyps p = let p',largs = whd_betadeltaiota_nolet_stack env sigma p in match kind_of_term p' with | Prod (n,t,c) -> let d = (n,None,t) in mkLambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c) | LetIn (n,b,t,c) -> let d = (n,Some b,t) in mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c) | Ind _ -> let realargs = list_skipn nparrec largs and arg = appvect (mkRel (i+1), Termops.extended_rel_vect 0 hyps) in applist(lift i fk,realargs@[arg]) | _ -> assert false in prec env 0 [] in (* ici, cstrprods est la liste des produits du constructeur instantié *) let rec process_constr env i f = function | (n,None,t as d)::cprest, recarg::rest -> let optionpos = match dest_recarg recarg with | Norec -> None | Imbr _ -> None | Mrec (_,i) -> fvect.(i) in (match optionpos with | None -> mkLambda_name env (n,t,process_constr (push_rel d env) (i+1) (whd_beta Evd.empty (applist (lift 1 f, [(mkRel 1)]))) (cprest,rest)) | Some(_,f_0) -> let nF = lift (i+1+decF) f_0 in let env' = push_rel d env in let arg = process_pos env' nF (lift 1 t) in mkLambda_name env (n,t,process_constr env' (i+1) (whd_beta Evd.empty (applist (lift 1 f, [(mkRel 1); arg]))) (cprest,rest))) | (n,Some c,t as d)::cprest, rest -> mkLetIn (n,c,t, process_constr (push_rel d env) (i+1) (lift 1 f) (cprest,rest)) | [],[] -> f | _,[] | [],_ -> anomaly "process_constr" in process_constr env 0 f (List.rev cstr.cs_args, recargs) (* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k variables *) let context_chop k ctx = let rec chop_aux acc = function | (0, l2) -> (List.rev acc, l2) | (n, ((_,Some _,_ as h)::t)) -> chop_aux (h::acc) (n, t) | (n, (h::t)) -> chop_aux (h::acc) (pred n, t) | (_, []) -> failwith "context_chop" in chop_aux [] (k,ctx) (* Main function *) let mis_make_indrec env sigma listdepkind mib = let nparams = mib.mind_nparams in let nparrec = mib. mind_nparams_rec in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let nrec = List.length listdepkind in let depPvec = Array.create mib.mind_ntypes (None : (bool * constr) option) in let _ = let rec assign k = function | [] -> () | (indi,mibi,mipi,dep,_)::rest -> (Array.set depPvec (snd indi) (Some(dep,mkRel k)); assign (k-1) rest) in assign nrec listdepkind in let recargsvec = Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in (* recarg information for non recursive parameters *) let rec recargparn l n = if n = 0 then l else recargparn (mk_norec::l) (n-1) in let recargpar = recargparn [] (nparams-nparrec) in let make_one_rec p = let makefix nbconstruct = let rec mrec i ln ltyp ldef = function | (indi,mibi,mipi,dep,_)::rest -> let tyi = snd indi in let nctyi = Array.length mipi.mind_consnames in (* nb constructeurs du type*) (* arity in the context of the fixpoint, i.e. P1..P_nrec f1..f_nbconstruct *) let args = Termops.extended_rel_list (nrec+nbconstruct) lnamesparrec in let indf = make_ind_family(indi,args) in let arsign,_ = get_arity env indf in let depind = build_dependent_inductive env indf in let deparsign = (Anonymous,None,depind)::arsign in let nonrecpar = rel_context_length lnonparrec in let larsign = rel_context_length deparsign in let ndepar = larsign - nonrecpar in let dect = larsign+nrec+nbconstruct in (* constructors in context of the Cases expr, i.e. P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *) let args' = Termops.extended_rel_list (dect+nrec) lnamesparrec in let args'' = Termops.extended_rel_list ndepar lnonparrec in let indf' = make_ind_family(indi,args'@args'') in let branches = let constrs = get_constructors env indf' in let fi = Termops.rel_vect (dect-i-nctyi) nctyi in let vecfi = Array.map (fun f -> appvect (f, Termops.extended_rel_vect ndepar lnonparrec)) fi in array_map3 (make_rec_branch_arg env sigma (nparrec,depPvec,larsign)) vecfi constrs (dest_subterms recargsvec.(tyi)) in let j = (match depPvec.(tyi) with | Some (_,c) when isRel c -> destRel c | _ -> assert false) in (* Predicate in the context of the case *) let depind' = build_dependent_inductive env indf' in let arsign',_ = get_arity env indf' in let deparsign' = (Anonymous,None,depind')::arsign' in let pargs = let nrpar = Termops.extended_rel_list (2*ndepar) lnonparrec and nrar = if dep then Termops.extended_rel_list 0 deparsign' else Termops.extended_rel_list 1 arsign' in nrpar@nrar in (* body of i-th component of the mutual fixpoint *) let deftyi = let ci = make_case_info env indi RegularStyle in let concl = applist (mkRel (dect+j+ndepar),pargs) in let pred = it_mkLambda_or_LetIn_name env ((if dep then mkLambda_name env else mkLambda) (Anonymous,depind',concl)) arsign' in it_mkLambda_or_LetIn_name env (mkCase (ci, pred, mkRel 1, branches)) (Termops.lift_rel_context nrec deparsign) in (* type of i-th component of the mutual fixpoint *) let typtyi = let concl = let pargs = if dep then Termops.extended_rel_vect 0 deparsign else Termops.extended_rel_vect 1 arsign in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs) in it_mkProd_or_LetIn_name env concl deparsign in mrec (i+nctyi) (rel_context_nhyps arsign ::ln) (typtyi::ltyp) (deftyi::ldef) rest | [] -> let fixn = Array.of_list (List.rev ln) in let fixtyi = Array.of_list (List.rev ltyp) in let fixdef = Array.of_list (List.rev ldef) in let names = Array.create nrec (Name(id_of_string "F")) in mkFix ((fixn,p),(names,fixtyi,fixdef)) in mrec 0 [] [] [] in let rec make_branch env i = function | (indi,mibi,mipi,dep,_)::rest -> let tyi = snd indi in let nconstr = Array.length mipi.mind_consnames in let rec onerec env j = if j = nconstr then make_branch env (i+j) rest else let recarg = (dest_subterms recargsvec.(tyi)).(j) in let recarg = recargpar@recarg in let vargs = Termops.extended_rel_list (nrec+i+j) lnamesparrec in let cs = get_constructor (indi,mibi,mipi,vargs) (j+1) in let p_0 = type_rec_branch true dep env sigma (vargs,depPvec,i+j) tyi cs recarg in mkLambda_string "f" p_0 (onerec (push_rel (Anonymous,None,p_0) env) (j+1)) in onerec env 0 | [] -> makefix i listdepkind in let rec put_arity env i = function | (indi,_,_,dep,kinds)::rest -> let indf = make_ind_family (indi, Termops.extended_rel_list i lnamesparrec) in let typP = make_arity env dep indf (Termops.new_sort_in_family kinds) in mkLambda_string "P" typP (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest) | [] -> make_branch env 0 listdepkind in (* Body on make_one_rec *) let (indi,mibi,mipi,dep,kind) = List.nth listdepkind p in if (mis_is_recursive_subset (List.map (fun (indi,_,_,_,_) -> snd indi) listdepkind) mipi.mind_recargs) then let env' = push_rel_context lnamesparrec env in it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) lnamesparrec else mis_make_case_com dep env sigma indi (mibi,mipi) kind in (* Body of mis_make_indrec *) list_tabulate make_one_rec nrec (**********************************************************************) (* This builds elimination predicate for Case tactic *) let build_case_analysis_scheme env sigma ity dep kind = let (mib,mip) = lookup_mind_specif env ity in mis_make_case_com dep env sigma ity (mib,mip) kind let build_case_analysis_scheme_default env sigma ity kind = let (mib,mip) = lookup_mind_specif env ity in let dep = inductive_sort_family mip <> InProp in mis_make_case_com dep env sigma ity (mib,mip) kind (**********************************************************************) (* [modify_sort_scheme s rec] replaces the sort of the scheme [rec] by [s] *) let change_sort_arity sort = let rec drec a = match kind_of_term a with | Cast (c,_,_) -> drec c | Prod (n,t,c) -> mkProd (n, t, drec c) | LetIn (n,b,t,c) -> mkLetIn (n,b, t, drec c) | Sort _ -> mkSort sort | _ -> assert false in drec (* [npar] is the number of expected arguments (then excluding letin's) *) let modify_sort_scheme sort = let rec drec npar elim = match kind_of_term elim with | Lambda (n,t,c) -> if npar = 0 then mkLambda (n, change_sort_arity sort t, c) else mkLambda (n, t, drec (npar-1) c) | LetIn (n,b,t,c) -> mkLetIn (n,b,t,drec npar c) | _ -> anomaly "modify_sort_scheme: wrong elimination type" in drec (* Change the sort in the type of an inductive definition, builds the corresponding eta-expanded term *) let weaken_sort_scheme sort npars term = let rec drec np elim = match kind_of_term elim with | Prod (n,t,c) -> if np = 0 then let t' = change_sort_arity sort t in mkProd (n, t', c), mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1))) else let c',term' = drec (np-1) c in mkProd (n, t, c'), mkLambda (n, t, term') | LetIn (n,b,t,c) -> let c',term' = drec np c in mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term') | _ -> anomaly "weaken_sort_scheme: wrong elimination type" in drec npars (**********************************************************************) (* Interface to build complex Scheme *) (* Check inductive types only occurs once (otherwise we obtain a meaning less scheme) *) let check_arities listdepkind = let _ = List.fold_left (fun ln ((_,ni as mind),mibi,mipi,dep,kind) -> let kelim = elim_sorts (mibi,mipi) in if not (List.exists ((=) kind) kelim) then raise (RecursionSchemeError (NotAllowedCaseAnalysis (true, Termops.new_sort_in_family kind,mind))) else if List.mem ni ln then raise (RecursionSchemeError (NotMutualInScheme (mind,mind))) else ni::ln) [] listdepkind in true let build_mutual_induction_scheme env sigma = function | (mind,dep,s)::lrecspec -> let (mib,mip) = Global.lookup_inductive mind in let (sp,tyi) = mind in let listdepkind = (mind,mib,mip,dep,s):: (List.map (function (mind',dep',s') -> let (sp',_) = mind' in if sp=sp' then let (mibi',mipi') = lookup_mind_specif env mind' in (mind',mibi',mipi',dep',s') else raise (RecursionSchemeError (NotMutualInScheme (mind,mind')))) lrecspec) in let _ = check_arities listdepkind in mis_make_indrec env sigma listdepkind mib | _ -> anomaly "build_induction_scheme expects a non empty list of inductive types" let build_induction_scheme env sigma ind dep kind = let (mib,mip) = lookup_mind_specif env ind in List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] mib) (*s Eliminations. *) let elimination_suffix = function | InProp -> "_ind" | InSet -> "_rec" | InType -> "_rect" let case_suffix = "_case" let make_elimination_ident id s = add_suffix id (elimination_suffix s) (* Look up function for the default elimination constant *) let lookup_eliminator ind_sp s = let kn,i = ind_sp in let mp,dp,l = repr_mind kn in let ind_id = (Global.lookup_mind kn).mind_packets.(i).mind_typename in let id = add_suffix ind_id (elimination_suffix s) in (* Try first to get an eliminator defined in the same section as the *) (* inductive type *) try let cst =Global.constant_of_delta_kn (make_kn mp dp (label_of_id id)) in let _ = Global.lookup_constant cst in mkConst cst with Not_found -> (* Then try to get a user-defined eliminator in some other places *) (* using short name (e.g. for "eq_rec") *) try constr_of_global (Nametab.locate (qualid_of_ident id)) with Not_found -> errorlabstrm "default_elim" (strbrk "Cannot find the elimination combinator " ++ pr_id id ++ strbrk ", the elimination of the inductive definition " ++ pr_global_env Idset.empty (IndRef ind_sp) ++ strbrk " on sort " ++ Termops.pr_sort_family s ++ strbrk " is probably not allowed.") coq-8.4pl4/pretyping/inductiveops.mli0000644000175000017500000001242112326224777017073 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* inductive -> types (** Return type as quoted by the user *) val type_of_constructor : env -> constructor -> types val type_of_constructors : env -> inductive -> types array (** Return constructor types in normal form *) val arities_of_constructors : env -> inductive -> types array (** An inductive type with its parameters *) type inductive_family val make_ind_family : inductive * constr list -> inductive_family val dest_ind_family : inductive_family -> inductive * constr list val map_ind_family : (constr -> constr) -> inductive_family -> inductive_family val liftn_inductive_family : int -> int -> inductive_family -> inductive_family val lift_inductive_family : int -> inductive_family -> inductive_family val substnl_ind_family : constr list -> int -> inductive_family -> inductive_family (** An inductive type with its parameters and real arguments *) type inductive_type = IndType of inductive_family * constr list val make_ind_type : inductive_family * constr list -> inductive_type val dest_ind_type : inductive_type -> inductive_family * constr list val map_inductive_type : (constr -> constr) -> inductive_type -> inductive_type val liftn_inductive_type : int -> int -> inductive_type -> inductive_type val lift_inductive_type : int -> inductive_type -> inductive_type val substnl_ind_type : constr list -> int -> inductive_type -> inductive_type val mkAppliedInd : inductive_type -> constr val mis_is_recursive_subset : int list -> wf_paths -> bool val mis_is_recursive : inductive * mutual_inductive_body * one_inductive_body -> bool val mis_nf_constructor_type : inductive * mutual_inductive_body * one_inductive_body -> int -> constr (** Extract information from an inductive name *) (** Arity of constructors excluding parameters and local defs *) val mis_constr_nargs : inductive -> int array val mis_constr_nargs_env : env -> inductive -> int array val nconstructors : inductive -> int (** Return the lengths of parameters signature and real arguments signature *) val inductive_nargs : env -> inductive -> int * int val mis_constructor_nargs_env : env -> constructor -> int val constructor_nrealargs : env -> constructor -> int val constructor_nrealhyps : env -> constructor -> int val get_full_arity_sign : env -> inductive -> rel_context val allowed_sorts : env -> inductive -> sorts_family list (** Extract information from an inductive family *) type constructor_summary = { cs_cstr : constructor; (* internal name of the constructor *) cs_params : constr list; (* parameters of the constructor in current ctx *) cs_nargs : int; (* length of arguments signature (letin included) *) cs_args : rel_context; (* signature of the arguments (letin included) *) cs_concl_realargs : constr array; (* actual realargs in the concl of cstr *) } val lift_constructor : int -> constructor_summary -> constructor_summary val get_constructor : inductive * mutual_inductive_body * one_inductive_body * constr list -> int -> constructor_summary val get_arity : env -> inductive_family -> rel_context * sorts_family val get_constructors : env -> inductive_family -> constructor_summary array val build_dependent_constructor : constructor_summary -> constr val build_dependent_inductive : env -> inductive_family -> constr val make_arity_signature : env -> bool -> inductive_family -> rel_context val make_arity : env -> bool -> inductive_family -> sorts -> types val build_branch_type : env -> bool -> constr -> constructor_summary -> types (** Raise [Not_found] if not given an valid inductive type *) val extract_mrectype : constr -> inductive * constr list val find_mrectype : env -> evar_map -> types -> inductive * constr list val find_rectype : env -> evar_map -> types -> inductive_type val find_inductive : env -> evar_map -> types -> inductive * constr list val find_coinductive : env -> evar_map -> types -> inductive * constr list (********************) (** Builds the case predicate arity (dependent or not) *) val arity_of_case_predicate : env -> inductive_family -> bool -> sorts -> types val type_case_branches_with_names : env -> inductive * constr list -> constr -> constr -> types array * types (** Annotation for cases *) val make_case_info : env -> inductive -> case_style -> case_info (*i Compatibility val make_default_case_info : env -> case_style -> inductive -> case_info i*) (********************) val type_of_inductive_knowing_conclusion : env -> one_inductive_body -> types -> types (********************) val control_only_guard : env -> types -> unit val subst_inductive : Mod_subst.substitution -> inductive -> inductive coq-8.4pl4/pretyping/evarconv.ml0000644000175000017500000010252712326224777016040 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* !debug_unification); Goptions.optwrite = (fun a -> debug_unification:=a); } type flex_kind_of_term = | Rigid of constr | PseudoRigid of constr (* approximated as rigid but not necessarily so *) | MaybeFlexible of constr (* approx'ed as reducible but not necessarily so *) | Flexible of existential let flex_kind_of_term c l = match kind_of_term c with | Rel _ | Const _ | Var _ -> MaybeFlexible c | Lambda _ when l<>[] -> MaybeFlexible c | LetIn _ -> MaybeFlexible c | Evar ev -> Flexible ev | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ -> Rigid c | Meta _ | Case _ | Fix _ -> PseudoRigid c | Cast _ | App _ -> assert false let eval_flexible_term ts env c = match kind_of_term c with | Const c -> if is_transparent_constant ts c then constant_opt_value env c else None | Rel n -> (try let (_,v,_) = lookup_rel n env in Option.map (lift n) v with Not_found -> None) | Var id -> (try if is_transparent_variable ts id then let (_,v,_) = lookup_named id env in v else None with Not_found -> None) | LetIn (_,b,_,c) -> Some (subst1 b c) | Lambda _ -> Some c | _ -> assert false let evar_apprec ts env evd stack c = let sigma = evd in let rec aux s = let (t,stack) = whd_betaiota_deltazeta_for_iota_state ts env sigma s in match kind_of_term t with | Evar (evk,_ as ev) when Evd.is_defined sigma evk -> aux (Evd.existential_value sigma ev, stack) | _ -> (t, list_of_stack stack) in aux (c, append_stack_list stack empty_stack) let apprec_nohdbeta ts env evd c = match kind_of_term (fst (Reductionops.whd_stack evd c)) with | (Case _ | Fix _) -> applist (evar_apprec ts env evd [] c) | _ -> c let position_problem l2r = function | CONV -> None | CUMUL -> Some l2r (* [check_conv_record (t1,l1) (t2,l2)] tries to decompose the problem (t1 l1) = (t2 l2) into a problem l1 = params1@c1::extra_args1 l2 = us2@extra_args2 (t1 params1 c1) = (proji params (c xs)) (t2 us2) = (cstr us) extra_args1 = extra_args2 by finding a record R and an object c := [xs:bs](Build_R params v1..vn) with vi = (cstr us), for which we know that the i-th projection proji satisfies (proji params (c xs)) = (cstr us) Rem: such objects, usable for conversion, are defined in the objdef table; practically, it amounts to "canonically" equip t2 into a object c in structure R (since, if c1 were not an evar, the projection would have been reduced) *) let check_conv_record (t1,l1) (t2,l2) = try let proji = global_of_constr t1 in let canon_s,l2_effective = try match kind_of_term t2 with Prod (_,a,b) -> (* assert (l2=[]); *) if dependent (mkRel 1) b then raise Not_found else lookup_canonical_conversion (proji, Prod_cs),[a;pop b] | Sort s -> lookup_canonical_conversion (proji, Sort_cs (family_of_sort s)),[] | _ -> let c2 = global_of_constr t2 in lookup_canonical_conversion (proji, Const_cs c2),l2 with Not_found -> lookup_canonical_conversion (proji,Default_cs),[] in let { o_DEF = c; o_INJ=n; o_TABS = bs; o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in let params1, c1, extra_args1 = match list_chop nparams l1 with | params1, c1::extra_args1 -> params1, c1, extra_args1 | _ -> raise Not_found in let us2,extra_args2 = list_chop (List.length us) l2_effective in c,bs,(params,params1),(us,us2),(extra_args1,extra_args2),c1, (n,applist(t2,l2)) with Failure _ | Not_found -> raise Not_found (* Precondition: one of the terms of the pb is an uninstantiated evar, * possibly applied to arguments. *) let rec ise_try evd = function [] -> assert false | [f] -> f evd | f1::l -> let (evd',b) = f1 evd in if b then (evd',b) else ise_try evd l let ise_and evd l = let rec ise_and i = function [] -> assert false | [f] -> f i | f1::l -> let (i',b) = f1 i in if b then ise_and i' l else (evd,false) in ise_and evd l let ise_list2 evd f l1 l2 = let rec ise_list2 i l1 l2 = match l1,l2 with [], [] -> (i, true) | [x], [y] -> f i x y | x::l1, y::l2 -> let (i',b) = f i x y in if b then ise_list2 i' l1 l2 else (evd,false) | _ -> (evd, false) in ise_list2 evd l1 l2 let ise_array2 evd f v1 v2 = let rec allrec i = function | -1 -> (i,true) | n -> let (i',b) = f i v1.(n) v2.(n) in if b then allrec i' (n-1) else (evd,false) in let lv1 = Array.length v1 in if lv1 = Array.length v2 then allrec evd (pred lv1) else (evd,false) let rec evar_conv_x ts env evd pbty term1 term2 = let term1 = whd_head_evar evd term1 in let term2 = whd_head_evar evd term2 in (* Maybe convertible but since reducing can erase evars which [evar_apprec] could have found, we do it only if the terms are free of evar. Note: incomplete heuristic... *) let ground_test = if is_ground_term evd term1 && is_ground_term evd term2 then if is_trans_fconv pbty ts env evd term1 term2 then Some true else if is_ground_env evd env then Some false else None else None in match ground_test with Some b -> (evd,b) | None -> (* Until pattern-unification is used consistently, use nohdbeta to not destroy beta-redexes that can be used for 1st-order unification *) let term1 = apprec_nohdbeta ts env evd term1 in let term2 = apprec_nohdbeta ts env evd term2 in if is_undefined_evar evd term1 then solve_simple_eqn (evar_conv_x ts) env evd (position_problem true pbty,destEvar term1,term2) else if is_undefined_evar evd term2 then solve_simple_eqn (evar_conv_x ts) env evd (position_problem false pbty,destEvar term2,term1) else evar_eqappr_x ts env evd pbty (decompose_app term1) (decompose_app term2) and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = let eta env evd onleft term l term' l' = assert (l = []); let (na,c,body) = destLambda term in let c = nf_evar evd c in let env' = push_rel (na,None,c) env in let appr1 = evar_apprec ts env' evd [] body in let appr2 = (lift 1 term', List.map (lift 1) l' @ [mkRel 1]) in if onleft then evar_eqappr_x ts env' evd CONV appr1 appr2 else evar_eqappr_x ts env' evd CONV appr2 appr1 in (* Evar must be undefined since we have flushed evars *) let () = if !debug_unification then let open Pp in let pr_state (tm,l) = h 0 (Termops.print_constr tm ++ str "|" ++ cut () ++ prlist_with_sep pr_semicolon (fun x -> hov 1 (Termops.print_constr x)) l) in pp (v 0 (pr_state appr1 ++ cut () ++ pr_state appr2 ++ cut ()) ++ fnl ()) in match (flex_kind_of_term term1 l1, flex_kind_of_term term2 l2) with | Flexible (sp1,al1 as ev1), Flexible (sp2,al2 as ev2) -> let f1 i = if List.length l1 > List.length l2 then let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in ise_and i [(fun i -> solve_simple_eqn (evar_conv_x ts) env i (position_problem false pbty,ev2,applist(term1,deb1))); (fun i -> ise_list2 i (fun i -> evar_conv_x ts env i CONV) rest1 l2)] else let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in ise_and i [(fun i -> solve_simple_eqn (evar_conv_x ts) env i (position_problem true pbty,ev1,applist(term2,deb2))); (fun i -> ise_list2 i (fun i -> evar_conv_x ts env i CONV) l1 rest2)] and f2 i = if sp1 = sp2 then ise_and i [(fun i -> ise_list2 i (fun i -> evar_conv_x ts env i CONV) l1 l2); (fun i -> solve_refl (evar_conv_x ts) env i sp1 al1 al2, true)] else (i,false) in ise_try evd [f1; f2] | Flexible ev1, MaybeFlexible flex2 -> let f1 i = match is_unification_pattern_evar env evd ev1 l1 (applist appr2) with | Some l1' -> (* Miller-Pfenning's patterns unification *) (* Preserve generality (except that CCI has no eta-conversion) *) let t2 = nf_evar evd (applist appr2) in let t2 = solve_pattern_eqn env l1' t2 in solve_simple_eqn (evar_conv_x ts) env evd (position_problem true pbty,ev1,t2) | None -> (i,false) and f2 i = if List.length l1 <= List.length l2 then (* Try first-order unification *) (* (heuristic that gives acceptable results in practice) *) let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in ise_and i (* First compare extra args for better failure message *) [(fun i -> ise_list2 i (fun i -> evar_conv_x ts env i CONV) l1 rest2); (fun i -> evar_conv_x ts env i pbty term1 (applist(term2,deb2)))] else (i,false) and f3 i = match eval_flexible_term ts env flex2 with | Some v2 -> evar_eqappr_x ts env i pbty appr1 (evar_apprec ts env i l2 v2) | None -> (i,false) in ise_try evd [f1; f2; f3] | MaybeFlexible flex1, Flexible ev2 -> let f1 i = match is_unification_pattern_evar env evd ev2 l2 (applist appr1) with | Some l1' -> (* Miller-Pfenning's patterns unification *) (* Preserve generality (except that CCI has no eta-conversion) *) let t1 = nf_evar evd (applist appr1) in let t1 = solve_pattern_eqn env l2 t1 in solve_simple_eqn (evar_conv_x ts) env evd (position_problem false pbty,ev2,t1) | None -> (i,false) and f2 i = if List.length l2 <= List.length l1 then (* Try first-order unification *) (* (heuristic that gives acceptable results in practice) *) let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in ise_and i (* First compare extra args for better failure message *) [(fun i -> ise_list2 i (fun i -> evar_conv_x ts env i CONV) rest1 l2); (fun i -> evar_conv_x ts env i pbty (applist(term1,deb1)) term2)] else (i,false) and f3 i = match eval_flexible_term ts env flex1 with | Some v1 -> evar_eqappr_x ts env i pbty (evar_apprec ts env i l1 v1) appr2 | None -> (i,false) in ise_try evd [f1; f2; f3] | MaybeFlexible flex1, MaybeFlexible flex2 -> begin match kind_of_term flex1, kind_of_term flex2 with | LetIn (na,b1,t1,c'1), LetIn (_,b2,_,c'2) -> let f1 i = ise_and i [(fun i -> evar_conv_x ts env i CONV b1 b2); (fun i -> let b = nf_evar i b1 in let t = nf_evar i t1 in evar_conv_x ts (push_rel (na,Some b,t) env) i pbty c'1 c'2); (fun i -> ise_list2 i (fun i -> evar_conv_x ts env i CONV) l1 l2)] and f2 i = let appr1 = evar_apprec ts env i l1 (subst1 b1 c'1) and appr2 = evar_apprec ts env i l2 (subst1 b2 c'2) in evar_eqappr_x ts env i pbty appr1 appr2 in ise_try evd [f1; f2] | _, _ -> let f1 i = if eq_constr flex1 flex2 then ise_list2 i (fun i -> evar_conv_x ts env i CONV) l1 l2 else (i,false) and f2 i = (try conv_record ts env i (try check_conv_record appr1 appr2 with Not_found -> check_conv_record appr2 appr1) with Not_found -> (i,false)) and f3 i = (* heuristic: unfold second argument first, exception made if the first argument is a beta-redex (expand a constant only if necessary) or the second argument is potentially usable as a canonical projection or canonical value *) let rec is_unnamed (hd, args) = match kind_of_term hd with | (Var _|Construct _|Ind _|Const _|Prod _|Sort _) -> false | (Case _|Fix _|CoFix _|Meta _|Rel _)-> true | Evar _ -> false (* immediate solution without Canon Struct *) | Lambda _ -> assert(args = []); true | LetIn (_,b,_,c) -> is_unnamed (evar_apprec ts env i args (subst1 b c)) | App _| Cast _ -> assert false in let rhs_is_stuck_and_unnamed () = match eval_flexible_term ts env flex2 with | None -> false | Some v2 -> is_unnamed (evar_apprec ts env i l2 v2) in let rhs_is_already_stuck = rhs_is_already_stuck || rhs_is_stuck_and_unnamed () in if isLambda flex1 || rhs_is_already_stuck then match eval_flexible_term ts env flex1 with | Some v1 -> evar_eqappr_x ~rhs_is_already_stuck ts env i pbty (evar_apprec ts env i l1 v1) appr2 | None -> match eval_flexible_term ts env flex2 with | Some v2 -> evar_eqappr_x ts env i pbty appr1 (evar_apprec ts env i l2 v2) | None -> (i,false) else match eval_flexible_term ts env flex2 with | Some v2 -> evar_eqappr_x ts env i pbty appr1 (evar_apprec ts env i l2 v2) | None -> match eval_flexible_term ts env flex1 with | Some v1 -> evar_eqappr_x ts env i pbty (evar_apprec ts env i l1 v1) appr2 | None -> (i,false) in ise_try evd [f1; f2; f3] end | Rigid c1, Rigid c2 when isLambda c1 & isLambda c2 -> let (na,c1,c'1) = destLambda c1 in let (_,c2,c'2) = destLambda c2 in assert (l1=[] & l2=[]); ise_and evd [(fun i -> evar_conv_x ts env i CONV c1 c2); (fun i -> let c = nf_evar i c1 in evar_conv_x ts (push_rel (na,None,c) env) i CONV c'1 c'2)] | Flexible ev1, (Rigid _ | PseudoRigid _) -> (match is_unification_pattern_evar env evd ev1 l1 (applist appr2) with | Some l1 -> (* Miller-Pfenning's pattern unification *) (* Preserve generality thanks to eta-conversion) *) let t2 = nf_evar evd (applist appr2) in let t2 = solve_pattern_eqn env l1 t2 in solve_simple_eqn (evar_conv_x ts) env evd (position_problem true pbty,ev1,t2) | None -> if isLambda term2 then eta env evd false term2 l2 term1 l1 else (* Postpone the use of an heuristic *) add_conv_pb (pbty,env,applist appr1,applist appr2) evd, true) | (Rigid _ | PseudoRigid _), Flexible ev2 -> (match is_unification_pattern_evar env evd ev2 l2 (applist appr1) with | Some l2 -> (* Miller-Pfenning's pattern unification *) (* Preserve generality thanks to eta-conversion) *) let t1 = nf_evar evd (applist appr1) in let t1 = solve_pattern_eqn env l2 t1 in solve_simple_eqn (evar_conv_x ts) env evd (position_problem false pbty,ev2,t1) | None -> if isLambda term1 then eta env evd true term1 l1 term2 l2 else (* Postpone the use of an heuristic *) add_conv_pb (pbty,env,applist appr1,applist appr2) evd, true) | MaybeFlexible flex1, (Rigid _ | PseudoRigid _) -> let f3 i = (try conv_record ts env i (check_conv_record appr1 appr2) with Not_found -> (i,false)) and f4 i = match eval_flexible_term ts env flex1 with | Some v1 -> evar_eqappr_x ts env i pbty (evar_apprec ts env i l1 v1) appr2 | None -> if isLambda term2 then eta env i false term2 l2 term1 l1 else (i,false) in ise_try evd [f3; f4] | (Rigid _ | PseudoRigid _), MaybeFlexible flex2 -> let f3 i = (try conv_record ts env i (check_conv_record appr2 appr1) with Not_found -> (i,false)) and f4 i = match eval_flexible_term ts env flex2 with | Some v2 -> evar_eqappr_x ts env i pbty appr1 (evar_apprec ts env i l2 v2) | None -> if isLambda term1 then eta env i true term1 l1 term2 l2 else (i,false) in ise_try evd [f3; f4] (* Eta-expansion *) | Rigid c1, _ when isLambda c1 -> eta env evd true term1 l1 term2 l2 | _, Rigid c2 when isLambda c2 -> eta env evd false term2 l2 term1 l1 | Rigid c1, Rigid c2 -> begin match kind_of_term c1, kind_of_term c2 with | Sort s1, Sort s2 when l1=[] & l2=[] -> (try let evd' = if pbty = CONV then Evd.set_eq_sort evd s1 s2 else Evd.set_leq_sort evd s1 s2 in (evd', true) with Univ.UniverseInconsistency _ -> (evd, false) | e when Errors.noncritical e -> (evd, false)) | Prod (n,c1,c'1), Prod (_,c2,c'2) when l1=[] & l2=[] -> ise_and evd [(fun i -> evar_conv_x ts env i CONV c1 c2); (fun i -> let c = nf_evar i c1 in evar_conv_x ts (push_rel (n,None,c) env) i pbty c'1 c'2)] | Ind sp1, Ind sp2 -> if eq_ind sp1 sp2 then ise_list2 evd (fun i -> evar_conv_x ts env i CONV) l1 l2 else (evd, false) | Construct sp1, Construct sp2 -> if eq_constructor sp1 sp2 then ise_list2 evd (fun i -> evar_conv_x ts env i CONV) l1 l2 else (evd, false) | CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) -> if i1=i2 then ise_and evd [(fun i -> ise_array2 i (fun i -> evar_conv_x ts env i CONV) tys1 tys2); (fun i -> ise_array2 i (fun i -> evar_conv_x ts (push_rec_types recdef1 env) i CONV) bds1 bds2); (fun i -> ise_list2 i (fun i -> evar_conv_x ts env i CONV) l1 l2)] else (evd,false) | (Ind _ | Construct _ | Sort _ | Prod _ | CoFix _), _ -> (evd,false) | _, (Ind _ | Construct _ | Sort _ | Prod _ | CoFix _) -> (evd,false) | (App _ | Meta _ | Cast _ | Case _ | Fix _), _ -> assert false | (LetIn _ | Rel _ | Var _ | Const _ | Evar _), _ -> assert false | (Lambda _), _ -> assert false end | PseudoRigid c1, PseudoRigid c2 -> begin match kind_of_term c1, kind_of_term c2 with | Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) -> ise_and evd [(fun i -> evar_conv_x ts env i CONV p1 p2); (fun i -> evar_conv_x ts env i CONV c1 c2); (fun i -> ise_array2 i (fun i -> evar_conv_x ts env i CONV) cl1 cl2); (fun i -> ise_list2 i (fun i -> evar_conv_x ts env i CONV) l1 l2)] | Fix (li1,(_,tys1,bds1 as recdef1)), Fix (li2,(_,tys2,bds2)) -> if li1=li2 then ise_and evd [(fun i -> ise_array2 i (fun i -> evar_conv_x ts env i CONV) tys1 tys2); (fun i -> ise_array2 i (fun i -> evar_conv_x ts (push_rec_types recdef1 env) i CONV) bds1 bds2); (fun i -> ise_list2 i (fun i -> evar_conv_x ts env i CONV) l1 l2)] else (evd,false) | (Meta _ | Case _ | Fix _ | CoFix _), (Meta _ | Case _ | Fix _ | CoFix _) -> (evd,false) | (App _ | Ind _ | Construct _ | Sort _ | Prod _), _ -> assert false | _, (App _ | Ind _ | Construct _ | Sort _ | Prod _) -> assert false | (LetIn _ | Cast _), _ -> assert false | _, (LetIn _ | Cast _) -> assert false | (Lambda _ | Rel _ | Var _ | Const _ | Evar _), _ -> assert false | _, (Lambda _ | Rel _ | Var _ | Const _ | Evar _) -> assert false end | PseudoRigid _, Rigid _ -> (evd,false) | Rigid _, PseudoRigid _ -> (evd,false) and conv_record trs env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = let (evd',ks,_) = List.fold_left (fun (i,ks,m) b -> if m=n then (i,t2::ks, m-1) else let dloc = (dummy_loc,InternalHole) in let (i',ev) = new_evar i env ~src:dloc (substl ks b) in (i', ev :: ks, m - 1)) (evd,[],List.length bs - 1) bs in ise_and evd' [(fun i -> ise_list2 i (fun i x1 x -> evar_conv_x trs env i CONV x1 (substl ks x)) params1 params); (fun i -> ise_list2 i (fun i u1 u -> evar_conv_x trs env i CONV u1 (substl ks u)) us2 us); (fun i -> evar_conv_x trs env i CONV c1 (applist (c,(List.rev ks)))); (fun i -> ise_list2 i (fun i -> evar_conv_x trs env i CONV) ts ts1)] (* getting rid of the optional argument rhs_is_already_stuck *) let evar_eqappr_x ts env evd pbty appr1 appr2 = evar_eqappr_x ts env evd pbty appr1 appr2 (* We assume here |l1| <= |l2| *) let first_order_unification ts env evd (ev1,l1) (term2,l2) = let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in ise_and evd (* First compare extra args for better failure message *) [(fun i -> ise_list2 i (fun i -> evar_conv_x ts env i CONV) rest2 l1); (fun i -> (* Then instantiate evar unless already done by unifying args *) let t2 = applist(term2,deb2) in if is_defined_evar i ev1 then evar_conv_x ts env i CONV t2 (mkEvar ev1) else solve_simple_eqn ~choose:true (evar_conv_x ts) env i (None,ev1,t2))] let choose_less_dependent_instance evk evd term args = let evi = Evd.find_undefined evd evk in let subst = make_pure_subst evi args in let subst' = List.filter (fun (id,c) -> eq_constr c term) subst in if subst' = [] then evd, false else Evd.define evk (mkVar (fst (List.hd subst'))) evd, true let apply_on_subterm evdref f c t = let rec applyrec (k,c as kc) t = (* By using eq_constr, we make an approximation, for instance, we *) (* could also be interested in finding a term u convertible to t *) (* such that c occurs in u *) if eq_constr c t then f k else match kind_of_term t with | Evar (evk,args) when Evd.is_undefined !evdref evk -> let ctx = evar_filtered_context (Evd.find_undefined !evdref evk) in let g (_,b,_) a = if b = None then applyrec kc a else a in mkEvar (evk, Array.of_list (List.map2 g ctx (Array.to_list args))) | _ -> map_constr_with_binders_left_to_right (fun d (k,c) -> (k+1,lift 1 c)) applyrec kc t in applyrec (0,c) t let filter_possible_projections c ty ctxt args = let fv1 = free_rels c in let fv2 = collect_vars c in let tyvars = collect_vars ty in List.map2 (fun (id,b,_) a -> b <> None || a == c || (* Here we make an approximation, for instance, we could also be *) (* interested in finding a term u convertible to c such that a occurs *) (* in u *) isRel a && Intset.mem (destRel a) fv1 || isVar a && Idset.mem (destVar a) fv2 || Idset.mem id tyvars) ctxt args let initial_evar_data evi = let ids = List.map pi1 (evar_context evi) in (evar_filter evi, List.map mkVar ids) let solve_evars = ref (fun _ -> failwith "solve_evars not installed") let set_solve_evars f = solve_evars := f (* We solve the problem env_rhs |- ?e[u1..un] = rhs knowing * x1:T1 .. xn:Tn |- ev : ty * by looking for a maximal well-typed abtraction over u1..un in rhs * * We first build C[e11..e1p1,..,en1..enpn] obtained from rhs by replacing * all occurrences of u1..un by evars eij of type Ti' where itself Ti' has * been obtained from the type of ui by also replacing all occurrences of * u1..ui-1 by evars. * * Then, we use typing to infer the relations between the different * occurrences. If some occurrence is still unconstrained after typing, * we instantiate successively the unresolved occurrences of un by xn, * of un-1 by xn-1, etc [the idea comes from Chung-Kil Hur, that he * used for his Heq plugin; extensions to several arguments based on a * proposition from Dan Grayson] *) let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = try let args = Array.to_list args in let evi = Evd.find_undefined evd evk in let env_evar = evar_env evi in let sign = named_context_val env_evar in let ctxt = evar_filtered_context evi in let filter = evar_filter evi in let instance = List.map mkVar (List.map pi1 ctxt) in let rec make_subst = function | (id,_,t)::ctxt', c::l, occs::occsl when isVarId id c -> if occs<>None then error "Cannot force abstraction on identity instance." else make_subst (ctxt',l,occsl) | (id,_,t)::ctxt', c::l, occs::occsl -> let evs = ref [] in let ty = Retyping.get_type_of env_rhs evd c in let filter' = filter_possible_projections c ty ctxt args in let filter = List.map2 (&&) filter filter' in (id,t,c,ty,evs,filter,occs) :: make_subst (ctxt',l,occsl) | [], [], [] -> [] | _ -> anomaly "Signature, instance and occurrences list do not match" in let rec set_holes evdref rhs = function | (id,_,c,cty,evsref,filter,occs)::subst -> let set_var k = match occs with | Some (false,[]) -> mkVar id | Some _ -> error "Selection of specific occurrences not supported" | None -> let evty = set_holes evdref cty subst in let instance = snd (list_filter2 (fun b c -> b) (filter,instance)) in let evd,ev = new_evar_instance sign !evdref evty ~filter instance in evdref := evd; evsref := (fst (destEvar ev),evty)::!evsref; ev in set_holes evdref (apply_on_subterm evdref set_var c rhs) subst | [] -> rhs in let subst = make_subst (ctxt,args,argoccs) in let evdref = ref evd in let rhs = set_holes evdref rhs subst in let evd = !evdref in (* We instantiate the evars of which the value is forced by typing *) let evd,rhs = try !solve_evars env_evar evd rhs with e when Pretype_errors.precatchable_exception e -> (* Could not revert all subterms *) raise Exit in let rec abstract_free_holes evd = function | (id,idty,c,_,evsref,_,_)::l -> let rec force_instantiation evd = function | (evk,evty)::evs -> let evd = if is_undefined evd evk then (* We force abstraction over this unconstrained occurrence *) (* and we use typing to propagate this instantiation *) (* This is an arbitrary choice *) let evd = Evd.define evk (mkVar id) evd in let evd,b = evar_conv_x ts env_evar evd CUMUL idty evty in if not b then error "Cannot find an instance"; let evd,b = reconsider_conv_pbs (evar_conv_x ts) evd in if not b then error "Cannot find an instance"; evd else evd in force_instantiation evd evs | [] -> abstract_free_holes evd l in force_instantiation evd !evsref | [] -> Evd.define evk rhs evd in abstract_free_holes evd subst, true with Exit -> evd, false let second_order_matching_with_args ts env evd ev l t = (* let evd,ev = evar_absorb_arguments env evd ev l in let argoccs = array_map_to_list (fun _ -> None) (snd ev) in second_order_matching ts env evd ev argoccs t *) (evd,false) let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = let t1 = apprec_nohdbeta ts env evd (whd_head_evar evd t1) in let t2 = apprec_nohdbeta ts env evd (whd_head_evar evd t2) in let (term1,l1 as appr1) = decompose_app t1 in let (term2,l2 as appr2) = decompose_app t2 in match kind_of_term term1, kind_of_term term2 with | Evar (evk1,args1), (Rel _|Var _) when l1 = [] & l2 = [] & List.for_all (fun a -> eq_constr a term2 or isEvar a) (remove_instance_local_defs evd evk1 (Array.to_list args1)) -> (* The typical kind of constraint coming from pattern-matching return type inference *) choose_less_dependent_instance evk1 evd term2 args1 | (Rel _|Var _), Evar (evk2,args2) when l1 = [] & l2 = [] & List.for_all (fun a -> eq_constr a term1 or isEvar a) (remove_instance_local_defs evd evk2 (Array.to_list args2)) -> (* The typical kind of constraint coming from pattern-matching return type inference *) choose_less_dependent_instance evk2 evd term1 args2 | Evar (evk1,args1), Evar (evk2,args2) when evk1 = evk2 -> let f env evd pbty x y = (evd,is_trans_fconv pbty ts env evd x y) in solve_refl ~can_drop:true f env evd evk1 args1 args2, true | Evar ev1, Evar ev2 -> solve_evar_evar ~force:true (evar_define (evar_conv_x ts)) (evar_conv_x ts) env evd ev1 ev2, true | Evar ev1,_ when List.length l1 <= List.length l2 -> (* On "?n t1 .. tn = u u1 .. u(n+p)", try first-order unification *) (* and otherwise second-order matching *) ise_try evd [(fun evd -> first_order_unification ts env evd (ev1,l1) appr2); (fun evd -> second_order_matching_with_args ts env evd ev1 l1 (applist appr2))] | _,Evar ev2 when List.length l2 <= List.length l1 -> (* On "u u1 .. u(n+p) = ?n t1 .. tn", try first-order unification *) (* and otherwise second-order matching *) ise_try evd [(fun evd -> first_order_unification ts env evd (ev2,l2) appr1); (fun evd -> second_order_matching_with_args ts env evd ev2 l2 (applist appr1))] | Evar ev1,_ -> (* Try second-order pattern-matching *) second_order_matching_with_args ts env evd ev1 l1 (applist appr2) | _,Evar ev2 -> (* Try second-order pattern-matching *) second_order_matching_with_args ts env evd ev2 l2 (applist appr1) | _ -> (* Some head evar have been instantiated, or unknown kind of problem *) evar_conv_x ts env evd pbty t1 t2 let check_problems_are_solved env evd = match snd (extract_all_conv_pbs evd) with | (pbty,env,t1,t2)::_ -> Pretype_errors.error_cannot_unify env evd (t1, t2) | _ -> () let max_undefined_with_candidates evd = (* If evar were ordered with highest index first, fold_undefined would be going decreasingly and we could use fold_undefined to find the undefined evar of maximum index (alternatively, max_bindings from ocaml 3.12 could be used); instead we traverse the whole map *) let l = Evd.fold_undefined (fun evk ev_info evars -> match ev_info.evar_candidates with | None -> evars | Some l -> (evk,ev_info,l)::evars) evd [] in match l with | [] -> None | a::l -> Some (list_last (a::l)) let rec solve_unconstrained_evars_with_canditates evd = (* max_undefined is supposed to return the most recent, hence possibly most dependent evar *) match max_undefined_with_candidates evd with | None -> evd | Some (evk,ev_info,l) -> let rec aux = function | [] -> error "Unsolvable existential variables." | a::l -> try let conv_algo = evar_conv_x full_transparent_state in let evd = check_evar_instance evd evk a conv_algo in let evd = Evd.define evk a evd in let evd,b = reconsider_conv_pbs conv_algo evd in if b then solve_unconstrained_evars_with_canditates evd else aux l with e when Pretype_errors.precatchable_exception e -> aux l in (* List.rev is there to favor most dependent solutions *) (* and favor progress when used with the refine tactics *) let evd = aux (List.rev l) in solve_unconstrained_evars_with_canditates evd let solve_unconstrained_impossible_cases evd = Evd.fold_undefined (fun evk ev_info evd' -> match ev_info.evar_source with | _,ImpossibleCase -> Evd.define evk (j_type (coq_unit_judge ())) evd' | _ -> evd') evd evd let consider_remaining_unif_problems ?(ts=full_transparent_state) env evd = let evd = solve_unconstrained_evars_with_canditates evd in let rec aux evd pbs progress stuck = match pbs with | (pbty,env,t1,t2 as pb) :: pbs -> let evd', b = apply_conversion_problem_heuristic ts env evd pbty t1 t2 in if b then let (evd', rest) = extract_all_conv_pbs evd' in if rest = [] then aux evd' pbs true stuck else (* Unification got actually stuck, postpone *) aux evd pbs progress (pb :: stuck) else Pretype_errors.error_cannot_unify env evd (t1, t2) | _ -> if progress then aux evd stuck false [] else match stuck with | [] -> (* We're finished *) evd | (pbty,env,t1,t2) :: _ -> (* There remains stuck problems *) Pretype_errors.error_cannot_unify env evd (t1, t2) in let (evd,pbs) = extract_all_conv_pbs evd in let heuristic_solved_evd = aux evd pbs false [] in check_problems_are_solved env heuristic_solved_evd; solve_unconstrained_impossible_cases heuristic_solved_evd (* Main entry points *) let the_conv_x ?(ts=full_transparent_state) env t1 t2 evd = match evar_conv_x ts env evd CONV t1 t2 with (evd',true) -> evd' | _ -> raise Reduction.NotConvertible let the_conv_x_leq ?(ts=full_transparent_state) env t1 t2 evd = match evar_conv_x ts env evd CUMUL t1 t2 with (evd', true) -> evd' | _ -> raise Reduction.NotConvertible let e_conv ?(ts=full_transparent_state) env evdref t1 t2 = match evar_conv_x ts env !evdref CONV t1 t2 with (evd',true) -> evdref := evd'; true | _ -> false let e_cumul ?(ts=full_transparent_state) env evdref t1 t2 = match evar_conv_x ts env !evdref CUMUL t1 t2 with (evd',true) -> evdref := evd'; true | _ -> false coq-8.4pl4/pretyping/typeclasses.ml0000644000175000017500000003734512326224777016561 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* assert false) let register_add_instance_hint = (:=) add_instance_hint_ref let add_instance_hint id = !add_instance_hint_ref id let remove_instance_hint_ref = ref (fun id -> assert false) let register_remove_instance_hint = (:=) remove_instance_hint_ref let remove_instance_hint id = !remove_instance_hint_ref id let set_typeclass_transparency_ref = ref (fun id local c -> assert false) let register_set_typeclass_transparency = (:=) set_typeclass_transparency_ref let set_typeclass_transparency gr local c = !set_typeclass_transparency_ref gr local c let classes_transparent_state_ref = ref (fun () -> assert false) let register_classes_transparent_state = (:=) classes_transparent_state_ref let classes_transparent_state () = !classes_transparent_state_ref () let solve_instanciation_problem = ref (fun _ _ _ -> assert false) let resolve_one_typeclass env evm t = !solve_instanciation_problem env evm t type rels = constr list type direction = Forward | Backward (* This module defines type-classes *) type typeclass = { (* The class implementation *) cl_impl : global_reference; (* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. *) cl_context : (global_reference * bool) option list * rel_context; (* Context of definitions and properties on defs, will not be shared *) cl_props : rel_context; (* The method implementaions as projections. *) cl_projs : (name * (direction * int option) option * constant option) list; } module Gmap = Fmap.Make(RefOrdered) type typeclasses = typeclass Gmap.t type instance = { is_class: global_reference; is_pri: int option; (* Sections where the instance should be redeclared, -1 for discard, 0 for none, mutable to avoid redeclarations when multiple rebuild_object happen. *) is_global: int; is_impl: global_reference; } type instances = (instance Gmap.t) Gmap.t let instance_impl is = is.is_impl let new_instance cl pri glob impl = let global = if glob then Lib.sections_depth () else -1 in { is_class = cl.cl_impl; is_pri = pri ; is_global = global ; is_impl = impl } (* * states management *) let classes : typeclasses ref = ref Gmap.empty let instances : instances ref = ref Gmap.empty let freeze () = !classes, !instances let unfreeze (cl,is) = classes:=cl; instances:=is let init () = classes:= Gmap.empty; instances:= Gmap.empty let _ = Summary.declare_summary "classes_and_instances" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = init } let class_info c = try Gmap.find c !classes with Not_found -> not_a_class (Global.env()) (constr_of_global c) let global_class_of_constr env c = try class_info (global_of_constr c) with Not_found -> not_a_class env c let dest_class_app env c = let cl, args = decompose_app c in global_class_of_constr env cl, args let dest_class_arity env c = let rels, c = Term.decompose_prod_assum c in rels, dest_class_app env c let class_of_constr c = try Some (dest_class_arity (Global.env ()) c) with e when Errors.noncritical e -> None let rec is_class_type evd c = match kind_of_term c with | Prod (_, _, t) -> is_class_type evd t | Evar (e, _) when is_defined evd e -> is_class_type evd (Evarutil.nf_evar evd c) | _ -> class_of_constr c <> None let is_class_evar evd evi = is_class_type evd evi.Evd.evar_concl (* * classes persistent object *) let load_class (_, cl) = classes := Gmap.add cl.cl_impl cl !classes let cache_class = load_class let subst_class (subst,cl) = let do_subst_con c = fst (Mod_subst.subst_con subst c) and do_subst c = Mod_subst.subst_mps subst c and do_subst_gr gr = fst (subst_global subst gr) in let do_subst_ctx ctx = list_smartmap (fun (na, b, t) -> (na, Option.smartmap do_subst b, do_subst t)) ctx in let do_subst_context (grs,ctx) = list_smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs, do_subst_ctx ctx in let do_subst_projs projs = list_smartmap (fun (x, y, z) -> (x, y, Option.smartmap do_subst_con z)) projs in { cl_impl = do_subst_gr cl.cl_impl; cl_context = do_subst_context cl.cl_context; cl_props = do_subst_ctx cl.cl_props; cl_projs = do_subst_projs cl.cl_projs; } let discharge_class (_,cl) = let repl = Lib.replacement_context () in let rel_of_variable_context ctx = List.fold_right ( fun (n,_,b,t) (ctx', subst) -> let decl = (Name n, Option.map (substn_vars 1 subst) b, substn_vars 1 subst t) in (decl :: ctx', n :: subst) ) ctx ([], []) in let discharge_rel_context subst n rel = let rel = map_rel_context (Cooking.expmod_constr repl) rel in let ctx, _ = List.fold_right (fun (id, b, t) (ctx, k) -> (id, Option.smartmap (substn_vars k subst) b, substn_vars k subst t) :: ctx, succ k) rel ([], n) in ctx in let abs_context cl = match cl.cl_impl with | VarRef _ | ConstructRef _ -> assert false | ConstRef cst -> Lib.section_segment_of_constant cst | IndRef (ind,_) -> Lib.section_segment_of_mutual_inductive ind in let discharge_context ctx' subst (grs, ctx) = let grs' = let newgrs = List.map (fun (_, _, t) -> match class_of_constr t with | None -> None | Some (_, (tc, _)) -> Some (tc.cl_impl, true)) ctx' in list_smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs @ newgrs in grs', discharge_rel_context subst 1 ctx @ ctx' in let cl_impl' = Lib.discharge_global cl.cl_impl in if cl_impl' == cl.cl_impl then cl else let ctx = abs_context cl in let ctx, subst = rel_of_variable_context ctx in let context = discharge_context ctx subst cl.cl_context in let props = discharge_rel_context subst (succ (List.length (fst cl.cl_context))) cl.cl_props in { cl_impl = cl_impl'; cl_context = context; cl_props = props; cl_projs = list_smartmap (fun (x, y, z) -> x, y, Option.smartmap Lib.discharge_con z) cl.cl_projs } let rebuild_class cl = try let cst = Tacred.evaluable_of_global_reference (Global.env ()) cl.cl_impl in set_typeclass_transparency cst false false; cl with e when Errors.noncritical e -> cl let class_input : typeclass -> obj = declare_object { (default_object "type classes state") with cache_function = cache_class; load_function = (fun _ -> load_class); open_function = (fun _ -> load_class); classify_function = (fun x -> Substitute x); discharge_function = (fun a -> Some (discharge_class a)); rebuild_function = rebuild_class; subst_function = subst_class } let add_class cl = Lib.add_anonymous_leaf (class_input cl) (** Build the subinstances hints. *) let check_instance env sigma c = try let (evd, c) = resolve_one_typeclass env sigma (Retyping.get_type_of env sigma c) in Evd.is_empty (Evd.undefined_evars evd) with e when Errors.noncritical e -> false let build_subclasses ~check env sigma glob pri = let rec aux pri c = let ty = Evarutil.nf_evar sigma (Retyping.get_type_of env sigma c) in match class_of_constr ty with | None -> [] | Some (rels, (tc, args)) -> let instapp = Reductionops.whd_beta sigma (appvectc c (Termops.extended_rel_vect 0 rels)) in let projargs = Array.of_list (args @ [instapp]) in let projs = list_map_filter (fun (n, b, proj) -> match b with | None -> None | Some (Backward, _) -> None | Some (Forward, pri') -> let proj = Option.get proj in let body = it_mkLambda_or_LetIn (mkApp (mkConst proj, projargs)) rels in if check && check_instance env sigma body then None else let pri = match pri, pri' with | Some p, Some p' -> Some (p + p') | Some p, None -> Some (p + 1) | _, _ -> None in Some (ConstRef proj, pri, body)) tc.cl_projs in let declare_proj hints (cref, pri, body) = let rest = aux pri body in hints @ (pri, body) :: rest in List.fold_left declare_proj [] projs in aux pri (constr_of_global glob) (* * instances persistent object *) type instance_action = | AddInstance | RemoveInstance let load_instance inst = let insts = try Gmap.find inst.is_class !instances with Not_found -> Gmap.empty in let insts = Gmap.add inst.is_impl inst insts in instances := Gmap.add inst.is_class insts !instances let remove_instance inst = let insts = try Gmap.find inst.is_class !instances with Not_found -> assert false in let insts = Gmap.remove inst.is_impl insts in instances := Gmap.add inst.is_class insts !instances let cache_instance (_, (action, i)) = match action with | AddInstance -> load_instance i | RemoveInstance -> remove_instance i let subst_instance (subst, (action, inst)) = action, { inst with is_class = fst (subst_global subst inst.is_class); is_impl = fst (subst_global subst inst.is_impl) } let discharge_instance (_, (action, inst)) = if inst.is_global <= 0 then None else Some (action, { inst with is_global = pred inst.is_global; is_class = Lib.discharge_global inst.is_class; is_impl = Lib.discharge_global inst.is_impl }) let is_local i = i.is_global = -1 let add_instance check inst = add_instance_hint (constr_of_global inst.is_impl) (is_local inst) inst.is_pri; List.iter (fun (pri, c) -> add_instance_hint c (is_local inst) pri) (build_subclasses ~check:(check && not (isVarRef inst.is_impl)) (Global.env ()) Evd.empty inst.is_impl inst.is_pri) let rebuild_instance (action, inst) = if action = AddInstance then add_instance true inst; (action, inst) let classify_instance (action, inst) = if is_local inst then Dispose else Substitute (action, inst) let load_instance (_, (action, inst) as ai) = cache_instance ai; if action = AddInstance then add_instance_hint (constr_of_global inst.is_impl) (is_local inst) inst.is_pri let instance_input : instance_action * instance -> obj = declare_object { (default_object "type classes instances state") with cache_function = cache_instance; load_function = (fun _ x -> cache_instance x); open_function = (fun _ x -> cache_instance x); classify_function = classify_instance; discharge_function = discharge_instance; rebuild_function = rebuild_instance; subst_function = subst_instance } let add_instance i = Lib.add_anonymous_leaf (instance_input (AddInstance, i)); add_instance true i let remove_instance i = Lib.add_anonymous_leaf (instance_input (RemoveInstance, i)); remove_instance_hint i.is_impl let declare_instance pri local glob = let c = constr_of_global glob in let ty = Retyping.get_type_of (Global.env ()) Evd.empty c in match class_of_constr ty with | Some (rels, (tc, args) as _cl) -> add_instance (new_instance tc pri (not local) glob) (* let path, hints = build_subclasses (not local) (Global.env ()) Evd.empty glob in *) (* let entries = List.map (fun (path, pri, c) -> (pri, local, path, c)) hints in *) (* Auto.add_hints local [typeclasses_db] (Auto.HintsResolveEntry entries); *) (* Auto.add_hints local [typeclasses_db] *) (* (Auto.HintsCutEntry (PathSeq (PathStar (PathAtom PathAny), path))) *) | None -> () let add_class cl = add_class cl; List.iter (fun (n, inst, body) -> match inst with | Some (Backward, pri) -> declare_instance pri false (ConstRef (Option.get body)) | _ -> ()) cl.cl_projs open Declarations let add_constant_class cst = let ty = Typeops.type_of_constant (Global.env ()) cst in let ctx, arity = decompose_prod_assum ty in let tc = { cl_impl = ConstRef cst; cl_context = (List.map (const None) ctx, ctx); cl_props = [(Anonymous, None, arity)]; cl_projs = [] } in add_class tc; set_typeclass_transparency (EvalConstRef cst) false false let add_inductive_class ind = let mind, oneind = Global.lookup_inductive ind in let k = let ctx = oneind.mind_arity_ctxt in let ty = Inductive.type_of_inductive_knowing_parameters (push_rel_context ctx (Global.env ())) oneind (Termops.extended_rel_vect 0 ctx) in { cl_impl = IndRef ind; cl_context = List.map (const None) ctx, ctx; cl_props = [Anonymous, None, ty]; cl_projs = [] } in add_class k (* * interface functions *) let instance_constructor cl args = let lenpars = List.length (List.filter (fun (na, b, t) -> b = None) (snd cl.cl_context)) in let pars = fst (list_chop lenpars args) in match cl.cl_impl with | IndRef ind -> Some (applistc (mkConstruct (ind, 1)) args), applistc (mkInd ind) pars | ConstRef cst -> let term = if args = [] then None else Some (list_last args) in term, applistc (mkConst cst) pars | _ -> assert false let typeclasses () = Gmap.fold (fun _ l c -> l :: c) !classes [] let cmap_elements c = Gmap.fold (fun k v acc -> v :: acc) c [] let instances_of c = try cmap_elements (Gmap.find c.cl_impl !instances) with Not_found -> [] let all_instances () = Gmap.fold (fun k v acc -> Gmap.fold (fun k v acc -> v :: acc) v acc) !instances [] let instances r = let cl = class_info r in instances_of cl let is_class gr = Gmap.fold (fun k v acc -> acc || v.cl_impl = gr) !classes false let is_instance = function | ConstRef c -> (match Decls.constant_kind c with | IsDefinition Instance -> true | _ -> false) | VarRef v -> (match Decls.variable_kind v with | IsDefinition Instance -> true | _ -> false) | ConstructRef (ind,_) -> is_class (IndRef ind) | _ -> false (* To embed a boolean for resolvability status. This is essentially a hack to mark which evars correspond to goals and do not need to be resolved when we have nested [resolve_all_evars] calls (e.g. when doing apply in an External hint in typeclass_instances). Would be solved by having real evars-as-goals. Nota: we will only check the resolvability status of undefined evars. *) let resolvable = Store.field () open Store.Field let is_resolvable evi = assert (evi.evar_body = Evar_empty); Option.default true (resolvable.get evi.evar_extra) let mark_resolvability_undef b evi = let t = resolvable.set b evi.evar_extra in { evi with evar_extra = t } let mark_resolvability b evi = assert (evi.evar_body = Evar_empty); mark_resolvability_undef b evi let mark_unresolvable evi = mark_resolvability false evi let mark_resolvable evi = mark_resolvability true evi let mark_resolvability b sigma = Evd.fold_undefined (fun ev evi evs -> Evd.add evs ev (mark_resolvability_undef b evi)) sigma (Evd.defined_evars sigma) let mark_unresolvables sigma = mark_resolvability false sigma let has_typeclasses evd = Evd.fold_undefined (fun ev evi has -> has || (is_resolvable evi && is_class_evar evd evi)) evd false let solve_instanciations_problem = ref (fun _ _ _ _ _ -> assert false) type evar_filter = hole_kind -> bool let no_goals = function GoalEvar -> false | _ -> true let all_evars _ = true let resolve_typeclasses ?(filter=no_goals) ?(split=true) ?(fail=true) env evd = if not (has_typeclasses evd) then evd else !solve_instanciations_problem env evd filter split fail coq-8.4pl4/pretyping/recordops.mli0000644000175000017500000000602612326224777016363 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit (** [lookup_structure isp] returns the struc_typ associated to the inductive path [isp] if it corresponds to a structure, otherwise it fails with [Not_found] *) val lookup_structure : inductive -> struc_typ (** [lookup_projections isp] returns the projections associated to the inductive path [isp] if it corresponds to a structure, otherwise it fails with [Not_found] *) val lookup_projections : inductive -> constant option list (** raise [Not_found] if not a projection *) val find_projection_nparams : global_reference -> int (** raise [Not_found] if not a projection *) val find_projection : global_reference -> struc_typ (** we keep an index (dnet) of record's arguments + fields (=methods). Here is how to declare them: *) val declare_method : global_reference -> Evd.evar -> Evd.evar_map -> unit (** and here is how to search for methods matched by a given term: *) val methods_matching : constr -> ((global_reference*Evd.evar*Evd.evar_map) * (constr*existential_key)*Termops.subst) list (** {6 Canonical structures } *) (** A canonical structure declares "canonical" conversion hints between the effective components of a structure and the projections of the structure *) type cs_pattern = Const_cs of global_reference | Prod_cs | Sort_cs of sorts_family | Default_cs type obj_typ = { o_DEF : constr; o_INJ : int; (** position of trivial argument *) o_TABS : constr list; (** ordered *) o_TPARAMS : constr list; (** ordered *) o_NPARAMS : int; o_TCOMPS : constr list } (** ordered *) val cs_pattern_of_constr : constr -> cs_pattern * int * constr list val pr_cs_pattern : cs_pattern -> Pp.std_ppcmds val lookup_canonical_conversion : (global_reference * cs_pattern) -> obj_typ val declare_canonical_structure : global_reference -> unit val is_open_canonical_projection : Environ.env -> Evd.evar_map -> (constr * constr list) -> bool val canonical_projections : unit -> ((global_reference * cs_pattern) * obj_typ) list coq-8.4pl4/pretyping/evarconv.mli0000644000175000017500000000363712326224777016213 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* env -> constr -> constr -> evar_map -> evar_map val the_conv_x_leq : ?ts:transparent_state -> env -> constr -> constr -> evar_map -> evar_map (** The same function resolving evars by side-effect and catching the exception *) val e_conv : ?ts:transparent_state -> env -> evar_map ref -> constr -> constr -> bool val e_cumul : ?ts:transparent_state -> env -> evar_map ref -> constr -> constr -> bool (**/**) (* For debugging *) val evar_conv_x : transparent_state -> env -> evar_map -> conv_pb -> constr -> constr -> evar_map * bool val evar_eqappr_x : transparent_state -> env -> evar_map -> conv_pb -> constr * constr list -> constr * constr list -> evar_map * bool (**/**) val consider_remaining_unif_problems : ?ts:transparent_state -> env -> evar_map -> evar_map val check_conv_record : constr * types list -> constr * types list -> constr * constr list * (constr list * constr list) * (constr list * types list) * (constr list * types list) * constr * (int * constr) val set_solve_evars : (env -> evar_map -> constr -> evar_map * constr) -> unit val second_order_matching : transparent_state -> env -> evar_map -> existential -> occurrences option list -> constr -> evar_map * bool coq-8.4pl4/pretyping/term_dnet.mli0000644000175000017500000000657012326224777016350 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t -> int (** how to substitute them for storage *) val subst : substitution -> t -> t (** how to recover the term from the identifier *) val constr_of : t -> constr end (** Options : *) module type OPT = sig (** pre-treatment to terms before adding or searching *) val reduce : constr -> constr (** direction of post-filtering w.r.t sort subtyping : - true means query <= terms in the structure - false means terms <= query *) val direction : bool end module type S = sig type t type ident (** results of filtering : identifier, a context (term with Evar hole) and the substitution in that context*) type result = ident * (constr*existential_key) * Termops.subst val empty : t (** [add c i dn] adds the binding [(c,i)] to [dn]. [c] can be a closed term or a pattern (with untyped Evars). No Metas accepted *) val add : constr -> ident -> t -> t (** merge of dnets. Faster than re-adding all terms *) val union : t -> t -> t val subst : substitution -> t -> t (* * High-level primitives describing specific search problems *) (** [search_pattern dn c] returns all terms/patterns in dn matching/matched by c *) val search_pattern : t -> constr -> result list (** [search_concl dn c] returns all matches under products and letins, i.e. it finds subterms whose conclusion matches c. The complexity depends only on c ! *) val search_concl : t -> constr -> result list (** [search_head_concl dn c] matches under products and applications heads. Finds terms of the form [forall H_1...H_n, C t_1...t_n] where C matches c *) val search_head_concl : t -> constr -> result list (** [search_eq_concl dn eq c] searches terms of the form [forall H1...Hn, eq _ X1 X2] where either X1 or X2 matches c *) val search_eq_concl : t -> constr -> constr -> result list (** [find_all dn] returns all idents contained in dn *) val find_all : t -> ident list val map : (ident -> ident) -> t -> t end module Make : functor (Ident : IDENT) -> functor (Opt : OPT) -> S with type ident = Ident.t coq-8.4pl4/pretyping/vnorm.ml0000644000175000017500000002461012326224777015352 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (j+1) (* Argggg, ces constructeurs de ... qui commencent a 1*) let find_rectype_a env c = let (t, l) = let t = whd_betadeltaiota env c in try destApp t with e when Errors.noncritical e -> (t,[||]) in match kind_of_term t with | Ind ind -> (ind, l) | _ -> raise Not_found (* Instantiate inductives and parameters in constructor type *) let type_constructor mind mib typ params = let s = ind_subst mind mib in let ctyp = substl s typ in let nparams = Array.length params in if nparams = 0 then ctyp else let _,ctyp = decompose_prod_n nparams ctyp in substl (List.rev (Array.to_list params)) ctyp let construct_of_constr const env tag typ = let (mind,_ as ind), allargs = find_rectype_a env typ in (* spiwack : here be a branch for specific decompilation handled by retroknowledge *) try if const then ((retroknowledge Retroknowledge.get_vm_decompile_constant_info env (Ind ind) tag), typ) (*spiwack: this may need to be changed in case there are parameters in the type which may cause a constant value to have an arity. (type_constructor seems to be all about parameters actually) but it shouldn't really matter since constant values don't use their ctyp in the rest of the code.*) else raise Not_found (* No retroknowledge function (yet) for block decompilation *) with Not_found -> let mib,mip = lookup_mind_specif env ind in let nparams = mib.mind_nparams in let i = invert_tag const tag mip.mind_reloc_tbl in let params = Array.sub allargs 0 nparams in let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in (mkApp(mkConstruct(ind,i), params), ctyp) let construct_of_constr_const env tag typ = fst (construct_of_constr true env tag typ) let construct_of_constr_block = construct_of_constr false let constr_type_of_idkey env idkey = match idkey with | ConstKey cst -> mkConst cst, Typeops.type_of_constant env cst | VarKey id -> let (_,_,ty) = lookup_named id env in mkVar id, ty | RelKey i -> let n = (nb_rel env - i) in let (_,_,ty) = lookup_rel n env in mkRel n, lift n ty let type_of_ind env ind = type_of_inductive env (Inductive.lookup_mind_specif env ind) let build_branches_type env (mind,_ as _ind) mib mip params dep p = let rtbl = mip.mind_reloc_tbl in (* [build_one_branch i cty] construit le type de la ieme branche (commence a 0) et les lambda correspondant aux realargs *) let build_one_branch i cty = let typi = type_constructor mind mib cty params in let decl,indapp = decompose_prod_assum typi in let ind,cargs = find_rectype_a env indapp in let nparams = Array.length params in let carity = snd (rtbl.(i)) in let crealargs = Array.sub cargs nparams (Array.length cargs - nparams) in let codom = let papp = mkApp(lift (List.length decl) p,crealargs) in if dep then let cstr = ith_constructor_of_inductive ind (i+1) in let relargs = Array.init carity (fun i -> mkRel (carity-i)) in let dep_cstr = mkApp(mkApp(mkConstruct cstr,params),relargs) in mkApp(papp,[|dep_cstr|]) else papp in decl, codom in Array.mapi build_one_branch mip.mind_nf_lc let build_case_type dep p realargs c = if dep then mkApp(mkApp(p, realargs), [|c|]) else mkApp(p, realargs) (* La fonction de normalisation *) let rec nf_val env v t = nf_whd env (whd_val v) t and nf_vtype env v = nf_val env v crazy_type and nf_whd env whd typ = match whd with | Vsort s -> mkSort s | Vprod p -> let dom = nf_vtype env (dom p) in let name = Name (id_of_string "x") in let vc = body_of_vfun (nb_rel env) (codom p) in let codom = nf_vtype (push_rel (name,None,dom) env) vc in mkProd(name,dom,codom) | Vfun f -> nf_fun env f typ | Vfix(f,None) -> nf_fix env f | Vfix(f,Some vargs) -> fst (nf_fix_app env f vargs) | Vcofix(cf,_,None) -> nf_cofix env cf | Vcofix(cf,_,Some vargs) -> let cfd = nf_cofix env cf in let i,(_,ta,_) = destCoFix cfd in let t = ta.(i) in let _, args = nf_args env vargs t in mkApp(cfd,args) | Vconstr_const n -> construct_of_constr_const env n typ | Vconstr_block b -> let capp,ctyp = construct_of_constr_block env (btag b) typ in let args = nf_bargs env b ctyp in mkApp(capp,args) | Vatom_stk(Aid idkey, stk) -> let c,typ = constr_type_of_idkey env idkey in nf_stk env c typ stk | Vatom_stk(Aiddef(idkey,v), stk) -> nf_whd env (whd_stack v stk) typ | Vatom_stk(Aind ind, stk) -> nf_stk env (mkInd ind) (type_of_ind env ind) stk and nf_stk env c t stk = match stk with | [] -> c | Zapp vargs :: stk -> let t, args = nf_args env vargs t in nf_stk env (mkApp(c,args)) t stk | Zfix (f,vargs) :: stk -> let fa, typ = nf_fix_app env f vargs in let _,_,codom = try decompose_prod env typ with e when Errors.noncritical e -> exit 120 in nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk | Zswitch sw :: stk -> let (mind,_ as ind),allargs = find_rectype_a env t in let (mib,mip) = Inductive.lookup_mind_specif env ind in let nparams = mib.mind_nparams in let params,realargs = Util.array_chop nparams allargs in let pT = hnf_prod_applist env (type_of_ind env ind) (Array.to_list params) in let pT = whd_betadeltaiota env pT in let dep, p = nf_predicate env ind mip params (type_of_switch sw) pT in (* Calcul du type des branches *) let btypes = build_branches_type env ind mib mip params dep p in (* calcul des branches *) let bsw = branch_of_switch (nb_rel env) sw in let mkbranch i (n,v) = let decl,codom = btypes.(i) in let b = nf_val (push_rel_context decl env) v codom in it_mkLambda_or_LetIn b decl in let branchs = Array.mapi mkbranch bsw in let tcase = build_case_type dep p realargs c in let ci = case_info sw in nf_stk env (mkCase(ci, p, c, branchs)) tcase stk and nf_predicate env ind mip params v pT = match whd_val v, kind_of_term pT with | Vfun f, Prod _ -> let k = nb_rel env in let vb = body_of_vfun k f in let name,dom,codom = try decompose_prod env pT with e when Errors.noncritical e -> exit 121 in let dep,body = nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in dep, mkLambda(name,dom,body) | Vfun f, _ -> let k = nb_rel env in let vb = body_of_vfun k f in let name = Name (id_of_string "c") in let n = mip.mind_nrealargs in let rargs = Array.init n (fun i -> mkRel (n-i)) in let params = if n=0 then params else Array.map (lift n) params in let dom = mkApp(mkInd ind,Array.append params rargs) in let body = nf_vtype (push_rel (name,None,dom) env) vb in true, mkLambda(name,dom,body) | _, _ -> false, nf_val env v crazy_type and nf_args env vargs t = let t = ref t in let len = nargs vargs in let args = Array.init len (fun i -> let _,dom,codom = try decompose_prod env !t with e when Errors.noncritical e -> exit 123 in let c = nf_val env (arg vargs i) dom in t := subst1 c codom; c) in !t,args and nf_bargs env b t = let t = ref t in let len = bsize b in let args = Array.init len (fun i -> let _,dom,codom = try decompose_prod env !t with e when Errors.noncritical e -> exit 124 in let c = nf_val env (bfield b i) dom in t := subst1 c codom; c) in args and nf_fun env f typ = let k = nb_rel env in let vb = body_of_vfun k f in let name,dom,codom = try decompose_prod env typ with e when Errors.noncritical e -> raise (Type_errors.TypeError(env,Type_errors.ReferenceVariables typ)) in let body = nf_val (push_rel (name,None,dom) env) vb codom in mkLambda(name,dom,body) and nf_fix env f = let init = current_fix f in let rec_args = rec_args f in let k = nb_rel env in let vb, vt = reduce_fix k f in let ndef = Array.length vt in let ft = Array.map (fun v -> nf_val env v crazy_type) vt in let name = Array.init ndef (fun _ -> (Name (id_of_string "Ffix"))) in let env = push_rec_types (name,ft,ft) env in let fb = Util.array_map2 (fun v t -> nf_fun env v t) vb ft in mkFix ((rec_args,init),(name,ft,fb)) and nf_fix_app env f vargs = let fd = nf_fix env f in let (_,i),(_,ta,_) = destFix fd in let t = ta.(i) in let t, args = nf_args env vargs t in mkApp(fd,args),t and nf_cofix env cf = let init = current_cofix cf in let k = nb_rel env in let vb,vt = reduce_cofix k cf in let ndef = Array.length vt in let cft = Array.map (fun v -> nf_val env v crazy_type) vt in let name = Array.init ndef (fun _ -> (Name (id_of_string "Fcofix"))) in let env = push_rec_types (name,cft,cft) env in let cfb = Util.array_map2 (fun v t -> nf_val env v t) vb cft in mkCoFix (init,(name,cft,cfb)) let cbv_vm env c t = let transp = transp_values () in if not transp then set_transp_values true; let v = Vconv.val_of_constr env c in let c = nf_val env v t in if not transp then set_transp_values false; c coq-8.4pl4/pretyping/pretyping.ml0000644000175000017500000007211312326224777016233 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 1=List.length l) possible_indexes then let indexes = Array.of_list (List.map List.hd possible_indexes) in let fix = ((indexes, 0),fixdefs) in (try check_fix env fix with e when Errors.noncritical e -> if loc = dummy_loc then raise e else Loc.raise loc e); indexes else (* we now search recursively amoungst all combinations *) (try List.iter (fun l -> let indexes = Array.of_list l in let fix = ((indexes, 0),fixdefs) in try check_fix env fix; raise (Found indexes) with TypeError _ -> ()) (list_combinations possible_indexes); let errmsg = "Cannot guess decreasing argument of fix." in if loc = dummy_loc then error errmsg else user_err_loc (loc,"search_guard", Pp.str errmsg) with Found indexes -> indexes) (* To embed constr in glob_constr *) let ((constr_in : constr -> Dyn.t), (constr_out : Dyn.t -> constr)) = Dyn.create "constr" (** Miscellaneous interpretation functions *) let interp_sort = function | GProp c -> Prop c | GType _ -> new_Type_sort () let interp_elimination_sort = function | GProp Null -> InProp | GProp Pos -> InSet | GType _ -> InType let resolve_evars env evdref fail_evar resolve_classes = if resolve_classes then evdref := (Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~split:true ~fail:fail_evar env !evdref); (* Resolve eagerly, potentially making wrong choices *) evdref := (try consider_remaining_unif_problems ~ts:(Typeclasses.classes_transparent_state ()) env !evdref with e when Errors.noncritical e -> if fail_evar then raise e else !evdref) let solve_remaining_evars fail_evar use_classes hook env initial_sigma (evd,c) = let evdref = ref evd in resolve_evars env evdref fail_evar use_classes; let rec proc_rec c = let c = Reductionops.whd_evar !evdref c in match kind_of_term c with | Evar (evk,args as ev) when not (Evd.mem initial_sigma evk) -> let sigma = !evdref in (try let c = hook env sigma ev in evdref := Evd.define evk c !evdref; c with Exit -> if fail_evar then let evi = Evd.find_undefined sigma evk in let (loc,src) = evar_source evk !evdref in Pretype_errors.error_unsolvable_implicit loc env sigma evi src None else c) | _ -> map_constr proc_rec c in let c = proc_rec c in (* Side-effect *) !evdref,c module type S = sig module Cases : Cases.S (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *) val allow_anonymous_refs : bool ref (* Generic call to the interpreter from glob_constr to open_constr, leaving unresolved holes as evars and returning the typing contexts of these evars. Work as [understand_gen] for the rest. *) val understand_tcc : ?resolve_classes:bool -> evar_map -> env -> ?expected_type:types -> glob_constr -> open_constr val understand_tcc_evars : ?fail_evar:bool -> ?resolve_classes:bool -> evar_map ref -> env -> typing_constraint -> glob_constr -> constr (* More general entry point with evars from ltac *) (* Generic call to the interpreter from glob_constr to constr, failing unresolved holes in the glob_constr cannot be instantiated. In [understand_ltac expand_evars sigma env ltac_env constraint c], resolve_classes : launch typeclass resolution after typechecking. expand_evars : expand inferred evars by their value if any sigma : initial set of existential variables (typically dependent subgoals) ltac_env : partial substitution of variables (used for the tactic language) constraint : tell if interpreted as a possibly constrained term or a type *) val understand_ltac : ?resolve_classes:bool -> bool -> evar_map -> env -> ltac_var_map -> typing_constraint -> glob_constr -> pure_open_constr (* Standard call to get a constr from a glob_constr, resolving implicit args *) val understand : evar_map -> env -> ?expected_type:Term.types -> glob_constr -> constr (* Idem but the glob_constr is intended to be a type *) val understand_type : evar_map -> env -> glob_constr -> constr (* A generalization of the two previous case *) val understand_gen : typing_constraint -> evar_map -> env -> glob_constr -> constr (* Idem but returns the judgment of the understood term *) val understand_judgment : evar_map -> env -> glob_constr -> unsafe_judgment (* Idem but do not fail on unresolved evars *) val understand_judgment_tcc : evar_map ref -> env -> glob_constr -> unsafe_judgment (*i*) (* Internal of Pretyping... * Unused outside, but useful for debugging *) val pretype : bool -> type_constraint -> env -> evar_map ref -> ltac_var_map -> glob_constr -> unsafe_judgment val pretype_type : bool -> val_constraint -> env -> evar_map ref -> ltac_var_map -> glob_constr -> unsafe_type_judgment val pretype_gen : bool -> bool -> bool -> evar_map ref -> env -> ltac_var_map -> typing_constraint -> glob_constr -> constr (*i*) end module Pretyping_F (Coercion : Coercion.S) = struct module Cases = Cases.Cases_F(Coercion) (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *) let allow_anonymous_refs = ref false let evd_comb0 f evdref = let (evd',x) = f !evdref in evdref := evd'; x let evd_comb1 f evdref x = let (evd',y) = f !evdref x in evdref := evd'; y let evd_comb2 f evdref x y = let (evd',z) = f !evdref x y in evdref := evd'; z let evd_comb3 f evdref x y z = let (evd',t) = f !evdref x y z in evdref := evd'; t let mt_evd = Evd.empty (* Utilisé pour inférer le prédicat des Cases *) (* Semble exagérement fort *) (* Faudra préférer une unification entre les types de toutes les clauses *) (* et autoriser des ? ā rester dans le résultat de l'unification *) let evar_type_fixpoint loc env evdref lna lar vdefj = let lt = Array.length vdefj in if Array.length lar = lt then for i = 0 to lt-1 do if not (e_cumul env evdref (vdefj.(i)).uj_type (lift lt lar.(i))) then error_ill_typed_rec_body_loc loc env !evdref i lna vdefj lar done (* coerce to tycon if any *) let inh_conv_coerce_to_tycon resolve_tc loc env evdref j = function | None -> j | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc loc env) evdref j t let push_rels vars env = List.fold_right push_rel vars env (* used to enforce a name in Lambda when the type constraints itself is named, hence possibly dependent *) let orelse_name name name' = match name with | Anonymous -> name' | _ -> name let invert_ltac_bound_name env id0 id = try mkRel (pi1 (lookup_rel_id id (rel_context env))) with Not_found -> errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++ str " depends on pattern variable name " ++ pr_id id ++ str " which is not bound in current context.") let protected_get_type_of env sigma c = try Retyping.get_type_of env sigma c with Anomaly _ -> errorlabstrm "" (str "Cannot reinterpret " ++ quote (print_constr c) ++ str " in the current environment.") let pretype_id loc env sigma (lvar,unbndltacvars) id = (* Look for the binder of [id] *) try let (n,_,typ) = lookup_rel_id id (rel_context env) in { uj_val = mkRel n; uj_type = lift n typ } with Not_found -> (* Check if [id] is an ltac variable *) try let (ids,c) = List.assoc id lvar in let subst = List.map (invert_ltac_bound_name env id) ids in let c = substl subst c in { uj_val = c; uj_type = protected_get_type_of env sigma c } with Not_found -> (* if [id] an ltac variable not bound to a term *) (* build a nice error message *) try match List.assoc id unbndltacvars with | None -> user_err_loc (loc,"", str "Variable " ++ pr_id id ++ str " should be bound to a term.") | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0 with Not_found -> (* Check if [id] is a section or goal variable *) try let (_,_,typ) = lookup_named id env in { uj_val = mkVar id; uj_type = typ } with Not_found -> (* [id] not found, standard error message *) error_var_not_found_loc loc id let evar_kind_of_term sigma c = kind_of_term (whd_evar sigma c) (*************************************************************************) (* Main pretyping function *) let pretype_ref evdref env ref = let c = constr_of_global ref in make_judge c (Retyping.get_type_of env Evd.empty c) let pretype_ref loc evdref env = function | VarRef id -> (* Section variable *) (try let (_,_,ty) = lookup_named id env in make_judge (mkVar id) ty with Not_found -> (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal variables *) Pretype_errors.error_var_not_found_loc loc id) | ref -> let c = constr_of_global ref in make_judge c (Retyping.get_type_of env Evd.empty c) let pretype_sort evdref = function | GProp c -> judge_of_prop_contents c | GType _ -> evd_comb0 judge_of_new_Type evdref exception Found of fixpoint let new_type_evar evdref env loc = evd_comb0 (fun evd -> Evarutil.new_type_evar evd env ~src:(loc,InternalHole)) evdref (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *) (* in environment [env], with existential variables [evdref] and *) (* the type constraint tycon *) let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t = let pretype = pretype resolve_tc in let pretype_type = pretype_type resolve_tc in let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in match t with | GRef (loc,ref) -> inh_conv_coerce_to_tycon loc env evdref (pretype_ref loc evdref env ref) tycon | GVar (loc, id) -> inh_conv_coerce_to_tycon loc env evdref (pretype_id loc env !evdref lvar id) tycon | GEvar (loc, evk, instopt) -> (* Ne faudrait-il pas s'assurer que hyps est bien un sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *) let hyps = evar_filtered_context (Evd.find !evdref evk) in let args = match instopt with | None -> instance_from_named_context hyps | Some inst -> failwith "Evar subtitutions not implemented" in let c = mkEvar (evk, args) in let j = (Retyping.get_judgment_of env !evdref c) in inh_conv_coerce_to_tycon loc env evdref j tycon | GPatVar (loc,(someta,n)) -> let ty = match tycon with | Some (None, ty) -> ty | None | Some _ -> new_type_evar evdref env loc in let k = MatchingVar (someta,n) in { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty } | GHole (loc,k) -> let ty = match tycon with | Some (None, ty) -> ty | None | Some _ -> new_type_evar evdref env loc in { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty } | GRec (loc,fixkind,names,bl,lar,vdef) -> let rec type_bl env ctxt = function [] -> ctxt | (na,bk,None,ty)::bl -> let ty' = pretype_type empty_valcon env evdref lvar ty in let dcl = (na,None,ty'.utj_val) in type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl | (na,bk,Some bd,ty)::bl -> let ty' = pretype_type empty_valcon env evdref lvar ty in let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar ty in let dcl = (na,Some bd'.uj_val,ty'.utj_val) in type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in let ctxtv = Array.map (type_bl env empty_rel_context) bl in let larj = array_map2 (fun e ar -> pretype_type empty_valcon (push_rel_context e env) evdref lvar ar) ctxtv lar in let lara = Array.map (fun a -> a.utj_val) larj in let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in let nbfix = Array.length lar in let names = Array.map (fun id -> Name id) names in (* Note: bodies are not used by push_rec_types, so [||] is safe *) let newenv = push_rec_types (names,ftys,[||]) env in let vdefj = array_map2_i (fun i ctxt def -> (* we lift nbfix times the type in tycon, because of * the nbfix variables pushed to newenv *) let (ctxt,ty) = decompose_prod_n_assum (rel_context_length ctxt) (lift nbfix ftys.(i)) in let nenv = push_rel_context ctxt newenv in let j = pretype (mk_tycon ty) nenv evdref lvar def in { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) ctxtv vdef in evar_type_fixpoint loc env evdref names ftys vdefj; let ftys = Array.map (nf_evar !evdref) ftys in let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in let fixj = match fixkind with | GFix (vn,i) -> (* First, let's find the guard indexes. *) (* If recursive argument was not given by user, we try all args. An earlier approach was to look only for inductive arguments, but doing it properly involves delta-reduction, and it finally doesn't seem worth the effort (except for huge mutual fixpoints ?) *) let possible_indexes = Array.to_list (Array.mapi (fun i (n,_) -> match n with | Some n -> [n] | None -> list_map_i (fun i _ -> i) 0 ctxtv.(i)) vn) in let fixdecls = (names,ftys,fdefs) in let indexes = search_guard loc env possible_indexes fixdecls in make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) | GCoFix i -> let cofix = (i,(names,ftys,fdefs)) in (try check_cofix env cofix with e when Errors.noncritical e -> Loc.raise loc e); make_judge (mkCoFix cofix) ftys.(i) in inh_conv_coerce_to_tycon loc env evdref fixj tycon | GSort (loc,s) -> let j = pretype_sort evdref s in inh_conv_coerce_to_tycon loc env evdref j tycon | GApp (loc,f,args) -> let fj = pretype empty_tycon env evdref lvar f in let floc = loc_of_glob_constr f in let rec apply_rec env n resj = function | [] -> resj | c::rest -> let argloc = loc_of_glob_constr c in let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env) evdref resj in let resty = whd_betadeltaiota env !evdref resj.uj_type in match kind_of_term resty with | Prod (na,c1,c2) -> let hj = pretype (mk_tycon c1) env evdref lvar c in let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in apply_rec env (n+1) { uj_val = value; uj_type = typ } rest | _ -> let hj = pretype empty_tycon env evdref lvar c in error_cant_apply_not_functional_loc (join_loc floc argloc) env !evdref resj [hj] in let resj = apply_rec env 1 fj args in let resj = match evar_kind_of_term !evdref resj.uj_val with | App (f,args) -> let f = whd_evar !evdref f in begin match kind_of_term f with | Ind _ | Const _ when isInd f or has_polymorphic_type (destConst f) -> let sigma = !evdref in let c = mkApp (f,Array.map (whd_evar sigma) args) in let t = Retyping.get_type_of env sigma c in make_judge c (* use this for keeping evars: resj.uj_val *) t | _ -> resj end | _ -> resj in inh_conv_coerce_to_tycon loc env evdref resj tycon | GLambda(loc,name,bk,c1,c2) -> let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon in let dom_valcon = valcon_of_tycon dom in let j = pretype_type dom_valcon env evdref lvar c1 in let var = (name,None,j.utj_val) in let j' = pretype rng (push_rel var env) evdref lvar c2 in judge_of_abstraction env (orelse_name name name') j j' | GProd(loc,name,bk,c1,c2) -> let j = pretype_type empty_valcon env evdref lvar c1 in let j' = if name = Anonymous then let j = pretype_type empty_valcon env evdref lvar c2 in { j with utj_val = lift 1 j.utj_val } else let var = (name,j.utj_val) in let env' = push_rel_assum var env in pretype_type empty_valcon env' evdref lvar c2 in let resj = try judge_of_product env name j j' with TypeError _ as e -> Loc.raise loc e in inh_conv_coerce_to_tycon loc env evdref resj tycon | GLetIn(loc,name,c1,c2) -> let j = match c1 with | GCast (loc, c, CastConv (DEFAULTcast, t)) -> let tj = pretype_type empty_valcon env evdref lvar t in pretype (mk_tycon tj.utj_val) env evdref lvar c | _ -> pretype empty_tycon env evdref lvar c1 in let t = refresh_universes j.uj_type in let var = (name,Some j.uj_val,t) in let tycon = lift_tycon 1 tycon in let j' = pretype tycon (push_rel var env) evdref lvar c2 in { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; uj_type = subst1 j.uj_val j'.uj_type } | GLetTuple (loc,nal,(na,po),c,d) -> let cj = pretype empty_tycon env evdref lvar c in let (IndType (indf,realargs)) = try find_rectype env !evdref cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in error_case_not_inductive_loc cloc env !evdref cj in let cstrs = get_constructors env indf in if Array.length cstrs <> 1 then user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor."); let cs = cstrs.(0) in if List.length nal <> cs.cs_nargs then user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables."); let fsign = List.map2 (fun na (_,c,t) -> (na,c,t)) (List.rev nal) cs.cs_args in let env_f = push_rels fsign env in (* Make dependencies from arity signature impossible *) let arsgn = let arsgn,_ = get_arity env indf in if not !allow_anonymous_refs then List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn else arsgn in let psign = (na,None,build_dependent_inductive env indf)::arsgn in let nar = List.length arsgn in (match po with | Some p -> let env_p = push_rels psign env in let pj = pretype_type empty_valcon env_p evdref lvar p in let ccl = nf_evar !evdref pj.utj_val in let psign = make_arity_signature env true indf in (* with names *) let p = it_mkLambda_or_LetIn ccl psign in let inst = (Array.to_list cs.cs_concl_realargs) @[build_dependent_constructor cs] in let lp = lift cs.cs_nargs p in let fty = hnf_lam_applist env !evdref lp inst in let fj = pretype (mk_tycon fty) env_f evdref lvar d in let f = it_mkLambda_or_LetIn fj.uj_val fsign in let v = let ind,_ = dest_ind_family indf in let ci = make_case_info env ind LetStyle in Typing.check_allowed_sort env !evdref ind cj.uj_val p; mkCase (ci, p, cj.uj_val,[|f|]) in { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } | None -> let tycon = lift_tycon cs.cs_nargs tycon in let fj = pretype tycon env_f evdref lvar d in let f = it_mkLambda_or_LetIn fj.uj_val fsign in let ccl = nf_evar !evdref fj.uj_type in let ccl = if noccur_between 1 cs.cs_nargs ccl then lift (- cs.cs_nargs) ccl else error_cant_find_case_type_loc loc env !evdref cj.uj_val in let ccl = refresh_universes ccl in let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in let v = let ind,_ = dest_ind_family indf in let ci = make_case_info env ind LetStyle in Typing.check_allowed_sort env !evdref ind cj.uj_val p; mkCase (ci, p, cj.uj_val,[|f|]) in { uj_val = v; uj_type = ccl }) | GIf (loc,c,(na,po),b1,b2) -> let cj = pretype empty_tycon env evdref lvar c in let (IndType (indf,realargs)) = try find_rectype env !evdref cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in error_case_not_inductive_loc cloc env !evdref cj in let cstrs = get_constructors env indf in if Array.length cstrs <> 2 then user_err_loc (loc,"", str "If is only for inductive types with two constructors."); let arsgn = let arsgn,_ = get_arity env indf in if not !allow_anonymous_refs then (* Make dependencies from arity signature impossible *) List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn else arsgn in let nar = List.length arsgn in let psign = (na,None,build_dependent_inductive env indf)::arsgn in let pred,p = match po with | Some p -> let env_p = push_rels psign env in let pj = pretype_type empty_valcon env_p evdref lvar p in let ccl = nf_evar !evdref pj.utj_val in let pred = it_mkLambda_or_LetIn ccl psign in let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in pred, typ | None -> let p = match tycon with | Some (None, ty) -> ty | None | Some _ -> new_type_evar evdref env loc in it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in let pred = nf_evar !evdref pred in let p = nf_evar !evdref p in let f cs b = let n = rel_context_length cs.cs_args in let pi = lift n pred in (* liftn n 2 pred ? *) let pi = beta_applist (pi, [build_dependent_constructor cs]) in let csgn = if not !allow_anonymous_refs then List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args else List.map (fun (n, b, t) -> match n with Name _ -> (n, b, t) | Anonymous -> (Name (id_of_string "H"), b, t)) cs.cs_args in let env_c = push_rels csgn env in let bj = pretype (mk_tycon pi) env_c evdref lvar b in it_mkLambda_or_LetIn bj.uj_val cs.cs_args in let b1 = f cstrs.(0) b1 in let b2 = f cstrs.(1) b2 in let v = let ind,_ = dest_ind_family indf in let ci = make_case_info env ind IfStyle in let pred = nf_evar !evdref pred in Typing.check_allowed_sort env !evdref ind cj.uj_val pred; mkCase (ci, pred, cj.uj_val, [|b1;b2|]) in { uj_val = v; uj_type = p } | GCases (loc,sty,po,tml,eqns) -> Cases.compile_cases loc sty ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref) tycon env (* loc *) (po,tml,eqns) | GCast (loc,c,k) -> let cj = match k with CastCoerce -> let cj = pretype empty_tycon env evdref lvar c in evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj | CastConv (k,t) -> let tj = pretype_type empty_valcon env evdref lvar t in let cj = pretype empty_tycon env evdref lvar c in let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in let cj = match k with | VMcast -> if not (occur_existential cty || occur_existential tval) then begin try ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj with Reduction.NotConvertible -> error_actual_type_loc loc env !evdref cj tval end else user_err_loc (loc,"",str "Cannot check cast with vm: unresolved arguments remain.") | _ -> inh_conv_coerce_to_tycon loc env evdref cj (mk_tycon tval) in let v = mkCast (cj.uj_val, k, tval) in { uj_val = v; uj_type = tval } in inh_conv_coerce_to_tycon loc env evdref cj tycon (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *) and pretype_type resolve_tc valcon env evdref lvar = function | GHole loc -> (match valcon with | Some v -> let s = let sigma = !evdref in let t = Retyping.get_type_of env sigma v in match kind_of_term (whd_betadeltaiota env sigma t) with | Sort s -> s | Evar ev when is_Type (existential_type sigma ev) -> evd_comb1 (define_evar_as_sort) evdref ev | _ -> anomaly "Found a type constraint which is not a type" in { utj_val = v; utj_type = s } | None -> let s = evd_comb0 new_sort_variable evdref in { utj_val = e_new_evar evdref env ~src:loc (mkSort s); utj_type = s}) | c -> let j = pretype resolve_tc empty_tycon env evdref lvar c in let loc = loc_of_glob_constr c in let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) evdref j in match valcon with | None -> tj | Some v -> if e_cumul env evdref v tj.utj_val then tj else error_unexpected_type_loc (loc_of_glob_constr c) env !evdref tj.utj_val v let pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c = let c' = match kind with | OfType exptyp -> let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in (pretype resolve_classes tycon env evdref lvar c).uj_val | IsType -> (pretype_type resolve_classes empty_valcon env evdref lvar c).utj_val in resolve_evars env evdref fail_evar resolve_classes; let c = if expand_evar then nf_evar !evdref c' else c' in if fail_evar then check_evars env Evd.empty !evdref c; c (* TODO: comment faire remonter l'information si le typage a resolu des variables du sigma original. il faudrait que la fonction de typage retourne aussi le nouveau sigma... *) let understand_judgment sigma env c = let evdref = ref sigma in let j = pretype true empty_tycon env evdref ([],[]) c in resolve_evars env evdref true true; let j = j_nf_evar !evdref j in check_evars env sigma !evdref (mkCast(j.uj_val,DEFAULTcast, j.uj_type)); j let understand_judgment_tcc evdref env c = let j = pretype true empty_tycon env evdref ([],[]) c in resolve_evars env evdref false true; j_nf_evar !evdref j (* Raw calls to the unsafe inference machine: boolean says if we must fail on unresolved evars; the unsafe_judgment list allows us to extend env with some bindings *) let ise_pretype_gen expand_evar fail_evar resolve_classes sigma env lvar kind c = let evdref = ref sigma in let c = pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c in !evdref, c (** Entry points of the high-level type synthesis algorithm *) let understand_gen kind sigma env c = snd (ise_pretype_gen true true true sigma env ([],[]) kind c) let understand sigma env ?expected_type:exptyp c = snd (ise_pretype_gen true true true sigma env ([],[]) (OfType exptyp) c) let understand_type sigma env c = snd (ise_pretype_gen true true true sigma env ([],[]) IsType c) let understand_ltac ?(resolve_classes=false) expand_evar sigma env lvar kind c = ise_pretype_gen expand_evar false resolve_classes sigma env lvar kind c let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c = ise_pretype_gen true false resolve_classes sigma env ([],[]) (OfType exptyp) c let understand_tcc_evars ?(fail_evar=false) ?(resolve_classes=true) evdref env kind c = pretype_gen true fail_evar resolve_classes evdref env ([],[]) kind c end module Default : S = Pretyping_F(Coercion.Default) coq-8.4pl4/pretyping/cases.mli0000644000175000017500000000402112326224777015452 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a val error_wrong_numarg_constructor_loc : loc -> env -> constructor -> int -> 'a val error_wrong_numarg_inductive_loc : loc -> env -> inductive -> int -> 'a val error_bad_constructor_loc : loc -> constructor -> inductive -> 'a val error_bad_pattern_loc : loc -> constructor -> constr -> 'a val error_wrong_predicate_arity_loc : loc -> env -> constr -> constr -> constr -> 'a val error_needs_inversion : env -> constr -> types -> 'a (** {6 Compilation primitive. } *) module type S = sig val compile_cases : loc -> case_style -> (type_constraint -> env -> evar_map ref -> glob_constr -> unsafe_judgment) * evar_map ref -> type_constraint -> env -> glob_constr option * tomatch_tuples * cases_clauses -> unsafe_judgment end module Cases_F(C : Coercion.S) : S coq-8.4pl4/pretyping/matching.ml0000644000175000017500000003071512326224777016006 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* if List.mem_assoc n names then Flags.if_warn Pp.msg_warning (str "Collision between bound variable " ++ pr_id n ++ str " and a metavariable of same name."); (names,(n,x)::terms) let add_binders na1 na2 (names,terms as subst) = match na1, na2 with | Name id1, Name id2 -> if List.mem_assoc id1 names then (Flags.if_warn Pp.msg_warning (str "Collision between bound variables of name " ++ pr_id id1); (names,terms)) else (if List.mem_assoc id1 terms then Flags.if_warn Pp.msg_warning (str "Collision between bound variable " ++ pr_id id1 ++ str " and another bound variable of same name."); ((id1,id2)::names,terms)); | _ -> subst let build_lambda toabstract stk (m : constr) = let rec buildrec m p_0 p_1 = match p_0,p_1 with | (_, []) -> m | (n, (_,na,t)::tl) -> if List.mem n toabstract then buildrec (mkLambda (na,t,m)) (n+1) tl else buildrec (lift (-1) m) (n+1) tl in buildrec m 1 stk let rec list_insert f a = function | [] -> [a] | b::l when f a b -> a::b::l | b::l when a = b -> raise PatternMatchingFailure | b::l -> b :: list_insert f a l let extract_bound_vars = let rec aux k = function | ([],_) -> [] | (n::l,(na1,na2,_)::stk) when k = n -> begin match na1,na2 with | Name id1,Name _ -> list_insert (<) id1 (aux (k+1) (l,stk)) | Name _,Anonymous -> anomaly "Unnamed bound variable" | Anonymous,_ -> raise PatternMatchingFailure end | (l,_::stk) -> aux (k+1) (l,stk) | (_,[]) -> assert false in aux 1 let dummy_constr = mkProp let rec make_renaming ids = function | (Name id,Name _,_)::stk -> let renaming = make_renaming ids stk in (try mkRel (list_index id ids) :: renaming with Not_found -> dummy_constr :: renaming) | (_,_,_)::stk -> dummy_constr :: make_renaming ids stk | [] -> [] let merge_binding allow_bound_rels stk n cT subst = let depth = List.length stk in let c = if depth = 0 then (* Optimization *) ([],cT) else let frels = Intset.elements (free_rels cT) in let frels = List.filter (fun i -> i <= depth) frels in if allow_bound_rels then let frels = Sort.list (<) frels in let canonically_ordered_vars = extract_bound_vars (frels,stk) in let renaming = make_renaming canonically_ordered_vars stk in (canonically_ordered_vars, substl renaming cT) else if frels = [] then ([],lift (-depth) cT) else raise PatternMatchingFailure in constrain (n,c) subst let matches_core convert allow_partial_app allow_bound_rels pat c = let conv = match convert with | None -> eq_constr | Some (env,sigma) -> is_conv env sigma in let rec sorec stk subst p t = let cT = strip_outer_cast t in match p,kind_of_term cT with | PSoApp (n,args),m -> let relargs = List.map (function | PRel n -> n | _ -> error "Only bound indices allowed in second order pattern matching.") args in let frels = Intset.elements (free_rels cT) in if list_subset frels relargs then constrain (n,([],build_lambda relargs stk cT)) subst else raise PatternMatchingFailure | PMeta (Some n), m -> merge_binding allow_bound_rels stk n cT subst | PMeta None, m -> subst | PRef (VarRef v1), Var v2 when v1 = v2 -> subst | PVar v1, Var v2 when v1 = v2 -> subst | PRef ref, _ when conv (constr_of_global ref) cT -> subst | PRel n1, Rel n2 when n1 = n2 -> subst | PSort (GProp c1), Sort (Prop c2) when c1 = c2 -> subst | PSort (GType _), Sort (Type _) -> subst | PApp (p, [||]), _ -> sorec stk subst p t | PApp (PApp (h, a1), a2), _ -> sorec stk subst (PApp(h,Array.append a1 a2)) t | PApp (PMeta meta,args1), App (c2,args2) when allow_partial_app -> let p = Array.length args2 - Array.length args1 in if p>=0 then let args21, args22 = array_chop p args2 in let c = mkApp(c2,args21) in let subst = match meta with | None -> subst | Some n -> merge_binding allow_bound_rels stk n c subst in array_fold_left2 (sorec stk) subst args1 args22 else raise PatternMatchingFailure | PApp (c1,arg1), App (c2,arg2) -> (try array_fold_left2 (sorec stk) (sorec stk subst c1 c2) arg1 arg2 with Invalid_argument _ -> raise PatternMatchingFailure) | PProd (na1,c1,d1), Prod(na2,c2,d2) -> sorec ((na1,na2,c2)::stk) (add_binders na1 na2 (sorec stk subst c1 c2)) d1 d2 | PLambda (na1,c1,d1), Lambda(na2,c2,d2) -> sorec ((na1,na2,c2)::stk) (add_binders na1 na2 (sorec stk subst c1 c2)) d1 d2 | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) -> sorec ((na1,na2,t2)::stk) (add_binders na1 na2 (sorec stk subst c1 c2)) d1 d2 | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) -> let ctx,b2 = decompose_lam_n_assum ci.ci_cstr_ndecls.(0) b2 in let ctx',b2' = decompose_lam_n_assum ci.ci_cstr_ndecls.(1) b2' in let n = rel_context_length ctx in let n' = rel_context_length ctx' in if noccur_between 1 n b2 & noccur_between 1 n' b2' then let s = List.fold_left (fun l (na,_,t) -> (Anonymous,na,t)::l) stk ctx in let s' = List.fold_left (fun l (na,_,t) -> (Anonymous,na,t)::l) stk ctx' in let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in sorec s' (sorec s (sorec stk subst a1 a2) b1 b2) b1' b2' else raise PatternMatchingFailure | PCase (ci1,p1,a1,br1), Case (ci2,p2,a2,br2) -> let n2 = Array.length br2 in if (ci1.cip_ind <> None && ci1.cip_ind <> Some ci2.ci_ind) || (not ci1.cip_extensible && List.length br1 <> n2) then raise PatternMatchingFailure; let chk_branch subst (j,n,c) = (* (ind,j+1) is normally known to be a correct constructor and br2 a correct match over the same inductive *) assert (j < n2); sorec stk subst c br2.(j) in let chk_head = sorec stk (sorec stk subst a1 a2) p1 p2 in List.fold_left chk_branch chk_head br1 | PFix c1, Fix _ when eq_constr (mkFix c1) cT -> subst | PCoFix c1, CoFix _ when eq_constr (mkCoFix c1) cT -> subst | _ -> raise PatternMatchingFailure in let names,terms = sorec [] ([],[]) pat c in (names,Sort.list (fun (a,_) (b,_) -> a (a,b)) subst) let extended_matches = matches_core None true true let matches c p = snd (matches_core_closed None true c p) let special_meta = (-1) (* Tells if it is an authorized occurrence and if the instance is closed *) let authorized_occ partial_app closed pat c mk_ctx next = try let sigma = matches_core_closed None partial_app pat c in if closed && not (List.for_all (fun (_,c) -> closed0 c) (snd sigma)) then next () else sigma, mk_ctx (mkMeta special_meta), next with PatternMatchingFailure -> next () (* Tries to match a subterm of [c] with [pat] *) let sub_match ?(partial_app=false) ?(closed=true) pat c = let rec aux c mk_ctx next = match kind_of_term c with | Cast (c1,k,c2) -> authorized_occ partial_app closed pat c mk_ctx (fun () -> let mk_ctx lc = mk_ctx (mkCast (List.hd lc, k,c2)) in try_aux [c1] mk_ctx next) | Lambda (x,c1,c2) -> authorized_occ partial_app closed pat c mk_ctx (fun () -> let mk_ctx lc = mk_ctx (mkLambda (x,List.hd lc,List.nth lc 1)) in try_aux [c1;c2] mk_ctx next) | Prod (x,c1,c2) -> authorized_occ partial_app closed pat c mk_ctx (fun () -> let mk_ctx lc = mk_ctx (mkProd (x,List.hd lc,List.nth lc 1)) in try_aux [c1;c2] mk_ctx next) | LetIn (x,c1,t,c2) -> authorized_occ partial_app closed pat c mk_ctx (fun () -> let mk_ctx = function [c1;c2] -> mkLetIn (x,c1,t,c2) | _ -> assert false in try_aux [c1;c2] mk_ctx next) | App (c1,lc) -> authorized_occ partial_app closed pat c mk_ctx (fun () -> let topdown = true in if partial_app then if topdown then let lc1 = Array.sub lc 0 (Array.length lc - 1) in let app = mkApp (c1,lc1) in let mk_ctx = function | [app';c] -> mk_ctx (mkApp (app',[|c|])) | _ -> assert false in try_aux [app;array_last lc] mk_ctx next else let rec aux2 app args next = match args with | [] -> let mk_ctx le = mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in try_aux (c1::Array.to_list lc) mk_ctx next | arg :: args -> let app = mkApp (app,[|arg|]) in let next () = aux2 app args next in let mk_ctx ce = mk_ctx (mkApp (ce, Array.of_list args)) in aux app mk_ctx next in aux2 c1 (Array.to_list lc) next else let mk_ctx le = mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in try_aux (c1::Array.to_list lc) mk_ctx next) | Case (ci,hd,c1,lc) -> authorized_occ partial_app closed pat c mk_ctx (fun () -> let mk_ctx le = mk_ctx (mkCase (ci,hd,List.hd le,Array.of_list (List.tl le))) in try_aux (c1::Array.to_list lc) mk_ctx next) | Construct _ | Fix _ | Ind _|CoFix _ |Evar _|Const _ | Rel _|Meta _|Var _|Sort _ -> authorized_occ partial_app closed pat c mk_ctx next (* Tries [sub_match] for all terms in the list *) and try_aux lc mk_ctx next = let rec try_sub_match_rec lacc = function | [] -> next () | c::tl -> let mk_ctx ce = mk_ctx (List.rev_append lacc (ce::tl)) in let next () = try_sub_match_rec (c::lacc) tl in aux c mk_ctx next in try_sub_match_rec [] lc in aux c (fun x -> x) (fun () -> raise PatternMatchingFailure) type subterm_matching_result = (bound_ident_map * patvar_map) * constr * (unit -> subterm_matching_result) let match_subterm pat c = sub_match pat c let match_appsubterm pat c = sub_match ~partial_app:true pat c let match_subterm_gen app pat c = sub_match ~partial_app:app pat c let is_matching pat c = try let _ = matches pat c in true with PatternMatchingFailure -> false let is_matching_appsubterm ?(closed=true) pat c = try let _ = sub_match ~partial_app:true ~closed pat c in true with PatternMatchingFailure -> false let matches_conv env sigma c p = snd (matches_core_closed (Some (env,sigma)) false c p) let is_matching_conv env sigma pat n = try let _ = matches_conv env sigma pat n in true with PatternMatchingFailure -> false coq-8.4pl4/pretyping/typeclasses_errors.ml0000644000175000017500000000374312326224777020150 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* raise (TypeClassError (env, UnsatisfiableConstraints (evd, None))) | Some ev -> let loc, kind = Evd.evar_source ev evd in raise (Loc.Exc_located (loc, TypeClassError (env, UnsatisfiableConstraints (evd, Some (ev, kind))))) let mismatched_ctx_inst env c n m = typeclass_error env (MismatchedContextInstance (c, n, m)) let rec unsatisfiable_exception exn = match exn with | TypeClassError (_, UnsatisfiableConstraints _) -> true | Loc.Exc_located(_, e) -> unsatisfiable_exception e | _ -> false coq-8.4pl4/pretyping/pretyping.mllib0000644000175000017500000000042012326224777016712 0ustar stephstephTermops Evd Reductionops Vnorm Namegen Inductiveops Retyping Cbv Pretype_errors Evarutil Term_dnet Recordops Evarconv Arguments_renaming Typing Glob_term Pattern Matching Tacred Typeclasses_errors Typeclasses Classops Coercion Unification Detyping Indrec Cases Pretyping coq-8.4pl4/pretyping/tacred.ml0000644000175000017500000011250212326224777015451 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* is_evaluable_const env cst | EvalVarRef id -> is_evaluable_var env id let value_of_evaluable_ref env = function | EvalConstRef con -> constant_value env con | EvalVarRef id -> Option.get (pi2 (lookup_named id env)) let constr_of_evaluable_ref = function | EvalConstRef con -> mkConst con | EvalVarRef id -> mkVar id let evaluable_of_global_reference env = function | ConstRef cst when is_evaluable_const env cst -> EvalConstRef cst | VarRef id when is_evaluable_var env id -> EvalVarRef id | r -> error_not_evaluable r let global_of_evaluable_reference = function | EvalConstRef cst -> ConstRef cst | EvalVarRef id -> VarRef id type evaluable_reference = | EvalConst of constant | EvalVar of identifier | EvalRel of int | EvalEvar of existential let mkEvalRef = function | EvalConst cst -> mkConst cst | EvalVar id -> mkVar id | EvalRel n -> mkRel n | EvalEvar ev -> mkEvar ev let isEvalRef env c = match kind_of_term c with | Const sp -> is_evaluable env (EvalConstRef sp) | Var id -> is_evaluable env (EvalVarRef id) | Rel _ | Evar _ -> true | _ -> false let destEvalRef c = match kind_of_term c with | Const cst -> EvalConst cst | Var id -> EvalVar id | Rel n -> EvalRel n | Evar ev -> EvalEvar ev | _ -> anomaly "Not an unfoldable reference" let reference_opt_value sigma env = function | EvalConst cst -> constant_opt_value env cst | EvalVar id -> let (_,v,_) = lookup_named id env in v | EvalRel n -> let (_,v,_) = lookup_rel n env in Option.map (lift n) v | EvalEvar ev -> Evd.existential_opt_value sigma ev exception NotEvaluable let reference_value sigma env c = match reference_opt_value sigma env c with | None -> raise NotEvaluable | Some d -> d (************************************************************************) (* Reduction of constants hiding a fixpoint (e.g. for "simpl" tactic). *) (* One reuses the name of the function after reduction of the fixpoint *) type constant_evaluation = | EliminationFix of int * int * (int * (int * constr) list * int) | EliminationMutualFix of int * evaluable_reference * ((int*evaluable_reference) option array * (int * (int * constr) list * int)) | EliminationCases of int | NotAnElimination (* We use a cache registered as a global table *) let eval_table = ref Cmap_env.empty type frozen = (int * constant_evaluation) Cmap_env.t let init () = eval_table := Cmap_env.empty let freeze () = !eval_table let unfreeze ct = eval_table := ct let _ = Summary.declare_summary "evaluation" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = init } (* [compute_consteval] determines whether c is an "elimination constant" either [yn:Tn]..[y1:T1](match yi with f1..fk end g1 ..gp) or [yn:Tn]..[y1:T1](Fix(f|t) yi1..yip) with yi1..yip distinct variables among the yi, not occurring in t In the second case, [check_fix_reversibility [T1;...;Tn] args fix] checks that [args] is a subset of disjoint variables in y1..yn (a necessary condition for reversibility). It also returns the relevant information ([i1,Ti1;..;ip,Tip],n) in order to compute an equivalent of Fix(f|t) such that g := [xp:Tip']..[x1:Ti1'](f a1..an) == [xp:Tip']..[x1:Ti1'](Fix(f|t) yi1..yip) with a_k:=y_k if k<>i_j, a_k:=args_k otherwise, and Tij':=Tij[x1..xi(j-1) <- a1..ai(j-1)] Note that the types Tk, when no i_j=k, must not be dependent on the xp..x1. *) let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) = let n = List.length labs in let nargs = List.length args in if nargs > n then raise Elimconst; let nbfix = Array.length bds in let li = List.map (function d -> match kind_of_term d with | Rel k -> if array_for_all (noccurn k) tys && array_for_all (noccurn (k+nbfix)) bds then (k, List.nth labs (k-1)) else raise Elimconst | _ -> raise Elimconst) args in let reversible_rels = List.map fst li in if not (list_distinct reversible_rels) then raise Elimconst; list_iter_i (fun i t_i -> if not (List.mem_assoc (i+1) li) then let fvs = List.map ((+) (i+1)) (Intset.elements (free_rels t_i)) in if list_intersect fvs reversible_rels <> [] then raise Elimconst) labs; let k = lv.(i) in if k < nargs then (* Such an optimisation would need eta-expansion let p = destRel (List.nth args k) in EliminationFix (n-p+1,(nbfix,li,n)) *) EliminationFix (n,nargs,(nbfix,li,n)) else EliminationFix (n-nargs+k+1,nargs,(nbfix,li,n)) (* Heuristic to look if global names are associated to other components of a mutual fixpoint *) let invert_name labs l na0 env sigma ref = function | Name id -> let minfxargs = List.length l in if na0 <> Name id then let refi = match ref with | EvalRel _ | EvalEvar _ -> None | EvalVar id' -> Some (EvalVar id) | EvalConst kn -> Some (EvalConst (con_with_label kn (label_of_id id))) in match refi with | None -> None | Some ref -> try match reference_opt_value sigma env ref with | None -> None | Some c -> let labs',ccl = decompose_lam c in let _, l' = whd_betalet_stack sigma ccl in let labs' = List.map snd labs' in if labs' = labs & l = l' then Some (minfxargs,ref) else None with Not_found (* Undefined ref *) -> None else Some (minfxargs,ref) | Anonymous -> None (* Actually, should not occur *) (* [compute_consteval_direct] expand all constant in a whole, but [compute_consteval_mutual_fix] only one by one, until finding the last one before the Fix if the latter is mutually defined *) let compute_consteval_direct sigma env ref = let rec srec env n labs c = let c',l = whd_betadelta_stack env sigma c in match kind_of_term c' with | Lambda (id,t,g) when l=[] -> srec (push_rel (id,None,t) env) (n+1) (t::labs) g | Fix fix -> (try check_fix_reversibility labs l fix with Elimconst -> NotAnElimination) | Case (_,_,d,_) when isRel d -> EliminationCases n | _ -> NotAnElimination in match reference_opt_value sigma env ref with | None -> NotAnElimination | Some c -> srec env 0 [] c let compute_consteval_mutual_fix sigma env ref = let rec srec env minarg labs ref c = let c',l = whd_betalet_stack sigma c in let nargs = List.length l in match kind_of_term c' with | Lambda (na,t,g) when l=[] -> srec (push_rel (na,None,t) env) (minarg+1) (t::labs) ref g | Fix ((lv,i),(names,_,_)) -> (* Last known constant wrapping Fix is ref = [labs](Fix l) *) (match compute_consteval_direct sigma env ref with | NotAnElimination -> (*Above const was eliminable but this not!*) NotAnElimination | EliminationFix (minarg',minfxargs,infos) -> let refs = Array.map (invert_name labs l names.(i) env sigma ref) names in let new_minarg = max (minarg'+minarg-nargs) minarg' in EliminationMutualFix (new_minarg,ref,(refs,infos)) | _ -> assert false) | _ when isEvalRef env c' -> (* Forget all \'s and args and do as if we had started with c' *) let ref = destEvalRef c' in (match reference_opt_value sigma env ref with | None -> anomaly "Should have been trapped by compute_direct" | Some c -> srec env (minarg-nargs) [] ref c) | _ -> (* Should not occur *) NotAnElimination in match reference_opt_value sigma env ref with | None -> (* Should not occur *) NotAnElimination | Some c -> srec env 0 [] ref c let compute_consteval sigma env ref = match compute_consteval_direct sigma env ref with | EliminationFix (_,_,(nbfix,_,_)) when nbfix <> 1 -> compute_consteval_mutual_fix sigma env ref | elim -> elim let reference_eval sigma env = function | EvalConst cst as ref -> (try Cmap_env.find cst !eval_table with Not_found -> begin let v = compute_consteval sigma env ref in eval_table := Cmap_env.add cst v !eval_table; v end) | ref -> compute_consteval sigma env ref (* If f is bound to EliminationFix (n',infos), then n' is the minimal number of args for starting the reduction and infos is (nbfix,[(yi1,Ti1);...;(yip,Tip)],n) indicating that f converts to some [y1:T1,...,yn:Tn](Fix(..) yip .. yi1) where the y_{i_j} consist in a disjoint subset of the yi, i.e. 1 <= ij <= n and the ij are disjoint (in particular, p <= n). f is applied to largs := arg1 .. argn and we need for recursive calls to build the function g := [xp:Tip',...,x1:Ti1'](f a1 ... an) s.t. (g u1 ... up) reduces to (Fix(..) u1 ... up) This is made possible by setting a_k:=x_j if k=i_j for some j a_k:=arg_k otherwise The type Tij' is Tij[yi(j-1)..y1 <- ai(j-1)..a1] *) let x = Name (id_of_string "x") let make_elim_fun (names,(nbfix,lv,n)) largs = let lu = list_firstn n (list_of_stack largs) in let p = List.length lv in let lyi = List.map fst lv in let la = list_map_i (fun q aq -> (* k from the comment is q+1 *) try mkRel (p+1-(list_index (n-q) lyi)) with Not_found -> aq) 0 (List.map (lift p) lu) in fun i -> match names.(i) with | None -> None | Some (minargs,ref) -> let body = applistc (mkEvalRef ref) la in let g = list_fold_left_i (fun q (* j = n+1-q *) c (ij,tij) -> let subst = List.map (lift (-q)) (list_firstn (n-ij) la) in let tij' = substl (List.rev subst) tij in mkLambda (x,tij',c)) 1 body (List.rev lv) in Some (minargs,g) (* [f] is convertible to [Fix(recindices,bodynum),bodyvect)]: do so that the reduction uses this extra information *) let dummy = mkProp let vfx = id_of_string"_expanded_fix_" let vfun = id_of_string"_eliminator_function_" (* Mark every occurrence of substituted vars (associated to a function) as a problem variable: an evar that can be instantiated either by vfx (expanded fixpoint) or vfun (named function). *) let substl_with_function subst constr = let cnt = ref 0 in let evd = ref Evd.empty in let minargs = ref Intmap.empty in let v = Array.of_list subst in let rec subst_total k c = match kind_of_term c with Rel i when k if i <= k + Array.length v then match v.(i-k-1) with | (fx,Some(min,ref)) -> decr cnt; evd := Evd.add !evd !cnt (Evd.make_evar (val_of_named_context [(vfx,None,dummy);(vfun,None,dummy)]) dummy); minargs := Intmap.add !cnt min !minargs; lift k (mkEvar(!cnt,[|fx;ref|])) | (fx,None) -> lift k fx else mkRel (i - Array.length v) | _ -> map_constr_with_binders succ subst_total k c in let c = subst_total 0 constr in (c,!evd,!minargs) exception Partial (* each problem variable that cannot be made totally applied even by reduction is solved by the expanded fix term. *) let solve_arity_problem env sigma fxminargs c = let evm = ref sigma in let set_fix i = evm := Evd.define i (mkVar vfx) !evm in let rec check strict c = let c' = whd_betaiotazeta sigma c in let (h,rcargs) = decompose_app c' in match kind_of_term h with Evar(i,_) when Intmap.mem i fxminargs && not (Evd.is_defined !evm i) -> let minargs = Intmap.find i fxminargs in if List.length rcargs < minargs then if strict then set_fix i else raise Partial; List.iter (check strict) rcargs | (Var _|Const _) when isEvalRef env h -> (match reference_opt_value sigma env (destEvalRef h) with Some h' -> let bak = !evm in (try List.iter (check false) rcargs with Partial -> evm := bak; check strict (applist(h',rcargs))) | None -> List.iter (check strict) rcargs) | _ -> iter_constr (check strict) c' in check true c; !evm let substl_checking_arity env subst c = (* we initialize the problem: *) let body,sigma,minargs = substl_with_function subst c in (* we collect arity constraints *) let sigma' = solve_arity_problem env sigma minargs body in (* we propagate the constraints: solved problems are substituted; the other ones are replaced by the function symbol *) let rec nf_fix c = match kind_of_term c with Evar(i,[|fx;f|] as ev) when Intmap.mem i minargs -> (match Evd.existential_opt_value sigma' ev with Some c' -> c' | None -> f) | _ -> map_constr nf_fix c in nf_fix body let contract_fix_use_function env sigma f ((recindices,bodynum),(_names,_types,bodies as typedbodies)) = let nbodies = Array.length recindices in let make_Fi j = (mkFix((recindices,j),typedbodies), f j) in let lbodies = list_tabulate make_Fi nbodies in substl_checking_arity env (List.rev lbodies) (nf_beta sigma bodies.(bodynum)) let reduce_fix_use_function env sigma f whfun fix stack = match fix_recarg fix stack with | None -> NotReducible | Some (recargnum,recarg) -> let (recarg'hd,_ as recarg') = if isRel recarg then (* The recarg cannot be a local def, no worry about the right env *) (recarg, empty_stack) else whfun (recarg, empty_stack) in let stack' = stack_assign stack recargnum (app_stack recarg') in (match kind_of_term recarg'hd with | Construct _ -> Reduced (contract_fix_use_function env sigma f fix,stack') | _ -> NotReducible) let contract_cofix_use_function env sigma f (bodynum,(_names,_,bodies as typedbodies)) = let nbodies = Array.length bodies in let make_Fi j = (mkCoFix(j,typedbodies), f j) in let subbodies = list_tabulate make_Fi nbodies in substl_checking_arity env (List.rev subbodies) (nf_beta sigma bodies.(bodynum)) let reduce_mind_case_use_function func env sigma mia = match kind_of_term mia.mconstr with | Construct(ind_sp,i) -> let real_cargs = list_skipn mia.mci.ci_npar mia.mcargs in applist (mia.mlf.(i-1), real_cargs) | CoFix (bodynum,(names,_,_) as cofix) -> let build_cofix_name = if isConst func then let minargs = List.length mia.mcargs in fun i -> if i = bodynum then Some (minargs,func) else match names.(i) with | Anonymous -> None | Name id -> (* In case of a call to another component of a block of mutual inductive, try to reuse the global name if the block was indeed initially built as a global definition *) let kn = con_with_label (destConst func) (label_of_id id) in try match constant_opt_value env kn with | None -> None (* TODO: check kn is correct *) | Some _ -> Some (minargs,mkConst kn) with Not_found -> None else fun _ -> None in let cofix_def = contract_cofix_use_function env sigma build_cofix_name cofix in mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false let special_red_case env sigma whfun (ci, p, c, lf) = let rec redrec s = let (constr, cargs) = whfun s in if isEvalRef env constr then let ref = destEvalRef constr in match reference_opt_value sigma env ref with | None -> raise Redelimination | Some gvalue -> if reducible_mind_case gvalue then reduce_mind_case_use_function constr env sigma {mP=p; mconstr=gvalue; mcargs=list_of_stack cargs; mci=ci; mlf=lf} else redrec (gvalue, cargs) else if reducible_mind_case constr then reduce_mind_case {mP=p; mconstr=constr; mcargs=list_of_stack cargs; mci=ci; mlf=lf} else raise Redelimination in redrec (c, empty_stack) (* data structure to hold the map kn -> rec_args for simpl *) type behaviour = { b_nargs: int; b_recargs: int list; b_dont_expose_case: bool; } let behaviour_table = ref (Refmap.empty : behaviour Refmap.t) let _ = Summary.declare_summary "simplbehaviour" { Summary.freeze_function = (fun () -> !behaviour_table); Summary.unfreeze_function = (fun x -> behaviour_table := x); Summary.init_function = (fun () -> behaviour_table := Refmap.empty) } type simpl_flag = [ `SimplDontExposeCase | `SimplNeverUnfold ] type req = | ReqLocal | ReqGlobal of global_reference * (int list * int * simpl_flag list) let load_simpl_behaviour _ (_,(_,(r, b))) = behaviour_table := Refmap.add r b !behaviour_table let cache_simpl_behaviour o = load_simpl_behaviour 1 o let classify_simpl_behaviour = function | ReqLocal, _ -> Dispose | ReqGlobal _, _ as o -> Substitute o let subst_simpl_behaviour (subst, (_, (r,o as orig))) = ReqLocal, let r' = fst (subst_global subst r) in if r==r' then orig else (r',o) let discharge_simpl_behaviour = function | _,(ReqGlobal (ConstRef c, req), (_, b)) -> let c' = pop_con c in let vars = Lib.section_segment_of_constant c in let extra = List.length vars in let nargs' = if b.b_nargs < 0 then b.b_nargs else b.b_nargs + extra in let recargs' = List.map ((+) extra) b.b_recargs in let b' = { b with b_nargs = nargs'; b_recargs = recargs' } in Some (ReqGlobal (ConstRef c', req), (ConstRef c', b')) | _ -> None let rebuild_simpl_behaviour = function | req, (ConstRef c, _ as x) -> req, x | _ -> assert false let inSimplBehaviour = declare_object { (default_object "SIMPLBEHAVIOUR") with load_function = load_simpl_behaviour; cache_function = cache_simpl_behaviour; classify_function = classify_simpl_behaviour; subst_function = subst_simpl_behaviour; discharge_function = discharge_simpl_behaviour; rebuild_function = rebuild_simpl_behaviour; } let set_simpl_behaviour local r (recargs, nargs, flags as req) = let nargs = if List.mem `SimplNeverUnfold flags then max_int else nargs in let behaviour = { b_nargs = nargs; b_recargs = recargs; b_dont_expose_case = List.mem `SimplDontExposeCase flags } in let req = if local then ReqLocal else ReqGlobal (r, req) in Lib.add_anonymous_leaf (inSimplBehaviour (req, (r, behaviour))) ;; let get_simpl_behaviour r = try let b = Refmap.find r !behaviour_table in let flags = if b.b_nargs = max_int then [`SimplNeverUnfold] else if b.b_dont_expose_case then [`SimplDontExposeCase] else [] in Some (b.b_recargs, (if b.b_nargs = max_int then -1 else b.b_nargs), flags) with Not_found -> None let get_behaviour = function | EvalVar _ | EvalRel _ | EvalEvar _ -> raise Not_found | EvalConst c -> Refmap.find (ConstRef c) !behaviour_table let recargs r = try let b = get_behaviour r in Some (b.b_recargs, b.b_nargs) with Not_found -> None let dont_expose_case r = try (get_behaviour r).b_dont_expose_case with Not_found -> false (* [red_elim_const] contracts iota/fix/cofix redexes hidden behind constants by keeping the name of the constants in the recursive calls; it fails if no redex is around *) let rec red_elim_const env sigma ref largs = let nargs = stack_args_size largs in let largs, unfold_anyway, unfold_nonelim = match recargs ref with | None -> largs, false, false | Some (_,n) when nargs < n -> raise Redelimination | Some (x::l,_) when nargs <= List.fold_left max x l -> raise Redelimination | Some (l,n) -> List.fold_left (fun stack i -> let arg = stack_nth stack i in let rarg = whd_construct_state env sigma (arg, empty_stack) in match kind_of_term (fst rarg) with | Construct _ -> stack_assign stack i (app_stack rarg) | _ -> raise Redelimination) largs l, n >= 0 && l = [] && nargs >= n, n >= 0 && l <> [] && nargs >= n in try match reference_eval sigma env ref with | EliminationCases n when nargs >= n -> let c = reference_value sigma env ref in let c', lrest = whd_betadelta_state env sigma (c,largs) in let whfun = whd_simpl_state env sigma in (special_red_case env sigma whfun (destCase c'), lrest) | EliminationFix (min,minfxargs,infos) when nargs >= min -> let c = reference_value sigma env ref in let d, lrest = whd_betadelta_state env sigma (c,largs) in let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) largs in let whfun = whd_construct_state env sigma in (match reduce_fix_use_function env sigma f whfun (destFix d) lrest with | NotReducible -> raise Redelimination | Reduced (c,rest) -> (nf_beta sigma c, rest)) | EliminationMutualFix (min,refgoal,refinfos) when nargs >= min -> let rec descend ref args = let c = reference_value sigma env ref in if ref = refgoal then (c,args) else let c', lrest = whd_betalet_state sigma (c,args) in descend (destEvalRef c') lrest in let (_, midargs as s) = descend ref largs in let d, lrest = whd_betadelta_state env sigma s in let f = make_elim_fun refinfos midargs in let whfun = whd_construct_state env sigma in (match reduce_fix_use_function env sigma f whfun (destFix d) lrest with | NotReducible -> raise Redelimination | Reduced (c,rest) -> (nf_beta sigma c, rest)) | NotAnElimination when unfold_nonelim -> let c = reference_value sigma env ref in whd_betaiotazeta sigma (app_stack (c, largs)), empty_stack | _ -> raise Redelimination with Redelimination when unfold_anyway -> let c = reference_value sigma env ref in whd_betaiotazeta sigma (app_stack (c, largs)), empty_stack (* reduce to whd normal form or to an applied constant that does not hide a reducible iota/fix/cofix redex (the "simpl" tactic) *) and whd_simpl_state env sigma s = let rec redrec (x, stack as s) = match kind_of_term x with | Lambda (na,t,c) -> (match decomp_stack stack with | None -> s | Some (a,rest) -> stacklam redrec [a] c rest) | LetIn (n,b,t,c) -> stacklam redrec [b] c stack | App (f,cl) -> redrec (f, append_stack cl stack) | Cast (c,_,_) -> redrec (c, stack) | Case (ci,p,c,lf) -> (try redrec (special_red_case env sigma redrec (ci,p,c,lf), stack) with Redelimination -> s) | Fix fix -> (try match reduce_fix (whd_construct_state env) sigma fix stack with | Reduced s' -> redrec s' | NotReducible -> s with Redelimination -> s) | _ when isEvalRef env x -> let ref = destEvalRef x in (try let hd, _ as s' = redrec (red_elim_const env sigma ref stack) in let rec is_case x = match kind_of_term x with | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x | App (hd, _) -> is_case hd | Case _ -> true | _ -> false in if dont_expose_case ref && is_case hd then raise Redelimination else s' with Redelimination -> s) | _ -> s in redrec s (* reduce until finding an applied constructor or fail *) and whd_construct_state env sigma s = let (constr, cargs as s') = whd_simpl_state env sigma s in if reducible_mind_case constr then s' else if isEvalRef env constr then let ref = destEvalRef constr in match reference_opt_value sigma env ref with | None -> raise Redelimination | Some gvalue -> whd_construct_state env sigma (gvalue, cargs) else raise Redelimination (************************************************************************) (* Special Purpose Reduction Strategies *) (* Red reduction tactic: one step of delta reduction + full beta-iota-fix-cofix-zeta-cast at the head of the conclusion of a sequence of products; fails if no delta redex is around *) let try_red_product env sigma c = let simpfun = clos_norm_flags betaiotazeta env sigma in let rec redrec env x = match kind_of_term x with | App (f,l) -> (match kind_of_term f with | Fix fix -> let stack = append_stack l empty_stack in (match fix_recarg fix stack with | None -> raise Redelimination | Some (recargnum,recarg) -> let recarg' = redrec env recarg in let stack' = stack_assign stack recargnum recarg' in simpfun (app_stack (f,stack'))) | _ -> simpfun (appvect (redrec env f, l))) | Cast (c,_,_) -> redrec env c | Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b) | LetIn (x,a,b,t) -> redrec env (subst1 a t) | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) | _ when isEvalRef env x -> (* TO DO: re-fold fixpoints after expansion *) (* to get true one-step reductions *) let ref = destEvalRef x in (match reference_opt_value sigma env ref with | None -> raise Redelimination | Some c -> c) | _ -> raise Redelimination in redrec env c let red_product env sigma c = try try_red_product env sigma c with Redelimination -> error "Not reducible." (* (* This old version of hnf uses betadeltaiota instead of itself (resp whd_construct_state) to reduce the argument of Case (resp Fix); The new version uses the "simpl" strategy instead. For instance, Variable n:nat. Eval hnf in match (plus (S n) O) with S n => n | _ => O end. returned (fix plus (n m : nat) {struct n} : nat := match n with | O => m | S p => S (plus p m) end) n 0 while the new version returns (plus n O) *) let whd_simpl_orelse_delta_but_fix_old env sigma c = let whd_all = whd_betadeltaiota_state env sigma in let rec redrec (x, stack as s) = match kind_of_term x with | Lambda (na,t,c) -> (match decomp_stack stack with | None -> s | Some (a,rest) -> stacklam redrec [a] c rest) | LetIn (n,b,t,c) -> stacklam redrec [b] c stack | App (f,cl) -> redrec (f, append_stack cl stack) | Cast (c,_,_) -> redrec (c, stack) | Case (ci,p,d,lf) -> (try redrec (special_red_case env sigma whd_all (ci,p,d,lf), stack) with Redelimination -> s) | Fix fix -> (match reduce_fix whd_all fix stack with | Reduced s' -> redrec s' | NotReducible -> s) | _ when isEvalRef env x -> let ref = destEvalRef x in (try redrec (red_elim_const env sigma ref stack) with Redelimination -> match reference_opt_value sigma env ref with | Some c -> (match kind_of_term (strip_lam c) with | CoFix _ | Fix _ -> s | _ -> redrec (c, stack)) | None -> s) | _ -> s in app_stack (redrec (c, empty_stack)) *) (* Same as [whd_simpl] but also reduces constants that do not hide a reducible fix, but does this reduction of constants only until it immediately hides a non reducible fix or a cofix *) let whd_simpl_orelse_delta_but_fix env sigma c = let rec redrec s = let (constr, stack as s') = whd_simpl_state env sigma s in if isEvalRef env constr then match reference_opt_value sigma env (destEvalRef constr) with | Some c -> (match kind_of_term (strip_lam c) with | CoFix _ | Fix _ -> s' | _ -> redrec (c, stack)) | None -> s' else s' in app_stack (redrec (c, empty_stack)) let hnf_constr = whd_simpl_orelse_delta_but_fix (* The "simpl" reduction tactic *) let whd_simpl env sigma c = app_stack (whd_simpl_state env sigma (c, empty_stack)) let simpl env sigma c = strong whd_simpl env sigma c (* Reduction at specific subterms *) let matches_head c t = match kind_of_term t with | App (f,_) -> matches c f | _ -> raise PatternMatchingFailure let contextually byhead ((nowhere_except_in,locs),c) f env sigma t = let maxocc = List.fold_right max locs 0 in let pos = ref 1 in let rec traverse (env,c as envc) t = if nowhere_except_in & (!pos > maxocc) then t else try let subst = if byhead then matches_head c t else matches c t in let ok = if nowhere_except_in then List.mem !pos locs else not (List.mem !pos locs) in incr pos; if ok then f subst env sigma t else if byhead then (* find other occurrences of c in t; TODO: ensure left-to-right *) let (f,l) = destApp t in mkApp (f, array_map_left (traverse envc) l) else t with PatternMatchingFailure -> map_constr_with_binders_left_to_right (fun d (env,c) -> (push_rel d env,lift_pattern 1 c)) traverse envc t in let t' = traverse (env,c) t in if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs; t' (* linear bindings (following pretty-printer) of the value of name in c. * n is the number of the next occurence of name. * ol is the occurence list to find. *) let substlin env evalref n (nowhere_except_in,locs) c = let maxocc = List.fold_right max locs 0 in let pos = ref n in assert (List.for_all (fun x -> x >= 0) locs); let value = value_of_evaluable_ref env evalref in let term = constr_of_evaluable_ref evalref in let rec substrec () c = if nowhere_except_in & !pos > maxocc then c else if eq_constr c term then let ok = if nowhere_except_in then List.mem !pos locs else not (List.mem !pos locs) in incr pos; if ok then value else c else map_constr_with_binders_left_to_right (fun _ () -> ()) substrec () c in let t' = substrec () c in (!pos, t') let string_of_evaluable_ref env = function | EvalVarRef id -> string_of_id id | EvalConstRef kn -> string_of_qualid (Nametab.shortest_qualid_of_global (vars_of_env env) (ConstRef kn)) let unfold env sigma name = if is_evaluable env name then clos_norm_flags (unfold_red name) env sigma else error (string_of_evaluable_ref env name^" is opaque.") (* [unfoldoccs : (readable_constraints -> (int list * full_path) -> constr -> constr)] * Unfolds the constant name in a term c following a list of occurrences occl. * at the occurrences of occ_list. If occ_list is empty, unfold all occurences. * Performs a betaiota reduction after unfolding. *) let unfoldoccs env sigma ((nowhere_except_in,locs as plocs),name) c = if locs = [] then if nowhere_except_in then c else unfold env sigma name c else let (nbocc,uc) = substlin env name 1 plocs c in if nbocc = 1 then error ((string_of_evaluable_ref env name)^" does not occur."); let rest = List.filter (fun o -> o >= nbocc) locs in if rest <> [] then error_invalid_occurrence rest; nf_betaiota sigma uc (* Unfold reduction tactic: *) let unfoldn loccname env sigma c = List.fold_left (fun c occname -> unfoldoccs env sigma occname c) c loccname (* Re-folding constants tactics: refold com in term c *) let fold_one_com com env sigma c = let rcom = try red_product env sigma com with Redelimination -> error "Not reducible." in (* Reason first on the beta-iota-zeta normal form of the constant as unfold produces it, so that the "unfold f; fold f" configuration works to refold fix expressions *) let a = subst_term (clos_norm_flags unfold_side_red env sigma rcom) c in if not (eq_constr a c) then subst1 com a else (* Then reason on the non beta-iota-zeta form for compatibility - even if it is probably a useless configuration *) let a = subst_term rcom c in subst1 com a let fold_commands cl env sigma c = List.fold_right (fun com -> fold_one_com com env sigma) (List.rev cl) c (* call by value reduction functions *) let cbv_norm_flags flags env sigma t = cbv_norm (create_cbv_infos flags env sigma) t let cbv_beta = cbv_norm_flags beta empty_env let cbv_betaiota = cbv_norm_flags betaiota empty_env let cbv_betadeltaiota env sigma = cbv_norm_flags betadeltaiota env sigma let compute = cbv_betadeltaiota (* Pattern *) (* gives [na:ta]c' such that c converts to ([na:ta]c' a), abstracting only * the specified occurrences. *) let abstract_scheme env sigma (locc,a) c = let ta = Retyping.get_type_of env sigma a in let na = named_hd env ta Anonymous in if occur_meta ta then error "Cannot find a type for the generalisation."; if occur_meta a then mkLambda (na,ta,c) else mkLambda (na,ta,subst_closed_term_occ locc a c) let pattern_occs loccs_trm env sigma c = let abstr_trm = List.fold_right (abstract_scheme env sigma) loccs_trm c in try let _ = Typing.type_of env sigma abstr_trm in applist(abstr_trm, List.map snd loccs_trm) with Type_errors.TypeError (env',t) -> raise (ReductionTacticError (InvalidAbstraction (env,abstr_trm,(env',t)))) (* Used in several tactics. *) (* put t as t'=(x1:A1)..(xn:An)B with B an inductive definition of name name return name, B and t' *) let reduce_to_ind_gen allow_product env sigma t = let rec elimrec env t l = let t = hnf_constr env sigma t in match kind_of_term (fst (decompose_app t)) with | Ind ind-> (ind, it_mkProd_or_LetIn t l) | Prod (n,ty,t') -> if allow_product then elimrec (push_rel (n,None,ty) env) t' ((n,None,ty)::l) else errorlabstrm "" (str"Not an inductive definition.") | _ -> (* Last chance: we allow to bypass the Opaque flag (as it was partially the case between V5.10 and V8.1 *) let t' = whd_betadeltaiota env sigma t in match kind_of_term (fst (decompose_app t')) with | Ind ind-> (ind, it_mkProd_or_LetIn t' l) | _ -> errorlabstrm "" (str"Not an inductive product.") in elimrec env t [] let reduce_to_quantified_ind x = reduce_to_ind_gen true x let reduce_to_atomic_ind x = reduce_to_ind_gen false x let rec find_hnf_rectype env sigma t = let ind,t = reduce_to_atomic_ind env sigma t in ind, snd (decompose_app t) (* Reduce the weak-head redex [beta,iota/fix/cofix[all],cast,zeta,simpl/delta] or raise [NotStepReducible] if not a weak-head redex *) exception NotStepReducible let one_step_reduce env sigma c = let rec redrec (x, stack) = match kind_of_term x with | Lambda (n,t,c) -> (match decomp_stack stack with | None -> raise NotStepReducible | Some (a,rest) -> (subst1 a c, rest)) | App (f,cl) -> redrec (f, append_stack cl stack) | LetIn (_,f,_,cl) -> (subst1 f cl,stack) | Cast (c,_,_) -> redrec (c,stack) | Case (ci,p,c,lf) -> (try (special_red_case env sigma (whd_simpl_state env sigma) (ci,p,c,lf), stack) with Redelimination -> raise NotStepReducible) | Fix fix -> (match reduce_fix (whd_construct_state env) sigma fix stack with | Reduced s' -> s' | NotReducible -> raise NotStepReducible) | _ when isEvalRef env x -> let ref = destEvalRef x in (try red_elim_const env sigma ref stack with Redelimination -> match reference_opt_value sigma env ref with | Some d -> d, stack | None -> raise NotStepReducible) | _ -> raise NotStepReducible in app_stack (redrec (c, empty_stack)) let isIndRef = function IndRef _ -> true | _ -> false let reduce_to_ref_gen allow_product env sigma ref t = if isIndRef ref then let (mind,t) = reduce_to_ind_gen allow_product env sigma t in if IndRef mind <> ref then errorlabstrm "" (str "Cannot recognize a statement based on " ++ Nametab.pr_global_env Idset.empty ref ++ str".") else t else (* lazily reduces to match the head of [t] with the expected [ref] *) let rec elimrec env t l = let c, _ = Reductionops.whd_stack sigma t in match kind_of_term c with | Prod (n,ty,t') -> if allow_product then elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l) else errorlabstrm "" (str "Cannot recognize an atomic statement based on " ++ Nametab.pr_global_env Idset.empty ref ++ str".") | _ -> try if global_of_constr c = ref then it_mkProd_or_LetIn t l else raise Not_found with Not_found -> try let t' = nf_betaiota sigma (one_step_reduce env sigma t) in elimrec env t' l with NotStepReducible -> errorlabstrm "" (str "Cannot recognize a statement based on " ++ Nametab.pr_global_env Idset.empty ref ++ str".") in elimrec env t [] let reduce_to_quantified_ref = reduce_to_ref_gen true let reduce_to_atomic_ref = reduce_to_ref_gen false coq-8.4pl4/pretyping/glob_term.ml0000644000175000017500000003470412326224777016170 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* loc | PatCstr(loc,_,_,_) -> loc type patvar = identifier type glob_sort = GProp of Term.contents | GType of Univ.universe option type binding_kind = Lib.binding_kind = Explicit | Implicit type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list type 'a bindings = | ImplicitBindings of 'a list | ExplicitBindings of 'a explicit_bindings | NoBindings type 'a with_bindings = 'a * 'a bindings type 'a cast_type = | CastConv of cast_kind * 'a | CastCoerce (* Cast to a base type (eg, an underlying inductive type) *) type glob_constr = | GRef of (loc * global_reference) | GVar of (loc * identifier) | GEvar of loc * existential_key * glob_constr list option | GPatVar of loc * (bool * patvar) (* Used for patterns only *) | GApp of loc * glob_constr * glob_constr list | GLambda of loc * name * binding_kind * glob_constr * glob_constr | GProd of loc * name * binding_kind * glob_constr * glob_constr | GLetIn of loc * name * glob_constr * glob_constr | GCases of loc * case_style * glob_constr option * tomatch_tuples * cases_clauses | GLetTuple of loc * name list * (name * glob_constr option) * glob_constr * glob_constr | GIf of loc * glob_constr * (name * glob_constr option) * glob_constr * glob_constr | GRec of loc * fix_kind * identifier array * glob_decl list array * glob_constr array * glob_constr array | GSort of loc * glob_sort | GHole of (loc * hole_kind) | GCast of loc * glob_constr * glob_constr cast_type and glob_decl = name * binding_kind * glob_constr option * glob_constr and fix_recursion_order = GStructRec | GWfRec of glob_constr | GMeasureRec of glob_constr * glob_constr option and fix_kind = | GFix of ((int option * fix_recursion_order) array * int) | GCoFix of int and predicate_pattern = name * (loc * inductive * int * name list) option and tomatch_tuple = (glob_constr * predicate_pattern) and tomatch_tuples = tomatch_tuple list and cases_clause = (loc * identifier list * cases_pattern list * glob_constr) and cases_clauses = cases_clause list let cases_predicate_names tml = List.flatten (List.map (function | (tm,(na,None)) -> [na] | (tm,(na,Some (_,_,_,nal))) -> na::nal) tml) let mkGApp loc p t = match p with | GApp (loc,f,l) -> GApp (loc,f,l@[t]) | _ -> GApp (loc,p,[t]) let map_glob_decl_left_to_right f (na,k,obd,ty) = let comp1 = Option.map f obd in let comp2 = f ty in (na,k,comp1,comp2) let map_glob_constr_left_to_right f = function | GApp (loc,g,args) -> let comp1 = f g in let comp2 = Util.list_map_left f args in GApp (loc,comp1,comp2) | GLambda (loc,na,bk,ty,c) -> let comp1 = f ty in let comp2 = f c in GLambda (loc,na,bk,comp1,comp2) | GProd (loc,na,bk,ty,c) -> let comp1 = f ty in let comp2 = f c in GProd (loc,na,bk,comp1,comp2) | GLetIn (loc,na,b,c) -> let comp1 = f b in let comp2 = f c in GLetIn (loc,na,comp1,comp2) | GCases (loc,sty,rtntypopt,tml,pl) -> let comp1 = Option.map f rtntypopt in let comp2 = Util.list_map_left (fun (tm,x) -> (f tm,x)) tml in let comp3 = Util.list_map_left (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl in GCases (loc,sty,comp1,comp2,comp3) | GLetTuple (loc,nal,(na,po),b,c) -> let comp1 = Option.map f po in let comp2 = f b in let comp3 = f c in GLetTuple (loc,nal,(na,comp1),comp2,comp3) | GIf (loc,c,(na,po),b1,b2) -> let comp1 = Option.map f po in let comp2 = f b1 in let comp3 = f b2 in GIf (loc,f c,(na,comp1),comp2,comp3) | GRec (loc,fk,idl,bl,tyl,bv) -> let comp1 = Array.map (Util.list_map_left (map_glob_decl_left_to_right f)) bl in let comp2 = Array.map f tyl in let comp3 = Array.map f bv in GRec (loc,fk,idl,comp1,comp2,comp3) | GCast (loc,c,k) -> let comp1 = f c in let comp2 = match k with CastConv (k,t) -> CastConv (k, f t) | x -> x in GCast (loc,comp1,comp2) | (GVar _ | GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) as x -> x let map_glob_constr = map_glob_constr_left_to_right (* let name_app f e = function | Name id -> let (id, e) = f id e in (Name id, e) | Anonymous -> Anonymous, e let fold_ident g idl e = let (idl,e) = Array.fold_right (fun id (idl,e) -> let id,e = g id e in (id::idl,e)) idl ([],e) in (Array.of_list idl,e) let map_glob_constr_with_binders_loc loc g f e = function | GVar (_,id) -> GVar (loc,id) | GApp (_,a,args) -> GApp (loc,f e a, List.map (f e) args) | GLambda (_,na,ty,c) -> let na,e = name_app g e na in GLambda (loc,na,f e ty,f e c) | GProd (_,na,ty,c) -> let na,e = name_app g e na in GProd (loc,na,f e ty,f e c) | GLetIn (_,na,b,c) -> let na,e = name_app g e na in GLetIn (loc,na,f e b,f e c) | GCases (_,tyopt,tml,pl) -> (* We don't modify pattern variable since we don't traverse patterns *) let g' id e = snd (g id e) in let h (_,idl,p,c) = (loc,idl,p,f (List.fold_right g' idl e) c) in GCases (loc,Option.map (f e) tyopt,List.map (f e) tml, List.map h pl) | GRec (_,fk,idl,tyl,bv) -> let idl',e' = fold_ident g idl e in GRec (loc,fk,idl',Array.map (f e) tyl,Array.map (f e') bv) | GCast (_,c,t) -> GCast (loc,f e c,f e t) | GSort (_,x) -> GSort (loc,x) | GHole (_,x) -> GHole (loc,x) | GRef (_,x) -> GRef (loc,x) | GEvar (_,x,l) -> GEvar (loc,x,l) | GPatVar (_,x) -> GPatVar (loc,x) *) let fold_glob_constr f acc = let rec fold acc = function | GVar _ -> acc | GApp (_,c,args) -> List.fold_left fold (fold acc c) args | GLambda (_,_,_,b,c) | GProd (_,_,_,b,c) | GLetIn (_,_,b,c) -> fold (fold acc b) c | GCases (_,_,rtntypopt,tml,pl) -> List.fold_left fold_pattern (List.fold_left fold (Option.fold_left fold acc rtntypopt) (List.map fst tml)) pl | GLetTuple (_,_,rtntyp,b,c) -> fold (fold (fold_return_type acc rtntyp) b) c | GIf (_,c,rtntyp,b1,b2) -> fold (fold (fold (fold_return_type acc rtntyp) c) b1) b2 | GRec (_,_,_,bl,tyl,bv) -> let acc = Array.fold_left (List.fold_left (fun acc (na,k,bbd,bty) -> fold (Option.fold_left fold acc bbd) bty)) acc bl in Array.fold_left fold (Array.fold_left fold acc tyl) bv | GCast (_,c,k) -> fold (match k with CastConv (_, t) -> fold acc t | CastCoerce -> acc) c | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc and fold_pattern acc (_,idl,p,c) = fold acc c and fold_return_type acc (na,tyopt) = Option.fold_left fold acc tyopt in fold acc let iter_glob_constr f = fold_glob_constr (fun () -> f) () let occur_glob_constr id = let rec occur = function | GVar (loc,id') -> id = id' | GApp (loc,f,args) -> (occur f) or (List.exists occur args) | GLambda (loc,na,bk,ty,c) -> (occur ty) or ((na <> Name id) & (occur c)) | GProd (loc,na,bk,ty,c) -> (occur ty) or ((na <> Name id) & (occur c)) | GLetIn (loc,na,b,c) -> (occur b) or ((na <> Name id) & (occur c)) | GCases (loc,sty,rtntypopt,tml,pl) -> (occur_option rtntypopt) or (List.exists (fun (tm,_) -> occur tm) tml) or (List.exists occur_pattern pl) | GLetTuple (loc,nal,rtntyp,b,c) -> occur_return_type rtntyp id or (occur b) or (not (List.mem (Name id) nal) & (occur c)) | GIf (loc,c,rtntyp,b1,b2) -> occur_return_type rtntyp id or (occur c) or (occur b1) or (occur b2) | GRec (loc,fk,idl,bl,tyl,bv) -> not (array_for_all4 (fun fid bl ty bd -> let rec occur_fix = function [] -> not (occur ty) && (fid=id or not(occur bd)) | (na,k,bbd,bty)::bl -> not (occur bty) && (match bbd with Some bd -> not (occur bd) | _ -> true) && (na=Name id or not(occur_fix bl)) in occur_fix bl) idl bl tyl bv) | GCast (loc,c,k) -> (occur c) or (match k with CastConv (_, t) -> occur t | CastCoerce -> false) | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> false and occur_pattern (loc,idl,p,c) = not (List.mem id idl) & (occur c) and occur_option = function None -> false | Some p -> occur p and occur_return_type (na,tyopt) id = na <> Name id & occur_option tyopt in occur let add_name_to_ids set na = match na with | Anonymous -> set | Name id -> Idset.add id set let free_glob_vars = let rec vars bounded vs = function | GVar (loc,id') -> if Idset.mem id' bounded then vs else Idset.add id' vs | GApp (loc,f,args) -> List.fold_left (vars bounded) vs (f::args) | GLambda (loc,na,_,ty,c) | GProd (loc,na,_,ty,c) | GLetIn (loc,na,ty,c) -> let vs' = vars bounded vs ty in let bounded' = add_name_to_ids bounded na in vars bounded' vs' c | GCases (loc,sty,rtntypopt,tml,pl) -> let vs1 = vars_option bounded vs rtntypopt in let vs2 = List.fold_left (fun vs (tm,_) -> vars bounded vs tm) vs1 tml in List.fold_left (vars_pattern bounded) vs2 pl | GLetTuple (loc,nal,rtntyp,b,c) -> let vs1 = vars_return_type bounded vs rtntyp in let vs2 = vars bounded vs1 b in let bounded' = List.fold_left add_name_to_ids bounded nal in vars bounded' vs2 c | GIf (loc,c,rtntyp,b1,b2) -> let vs1 = vars_return_type bounded vs rtntyp in let vs2 = vars bounded vs1 c in let vs3 = vars bounded vs2 b1 in vars bounded vs3 b2 | GRec (loc,fk,idl,bl,tyl,bv) -> let bounded' = Array.fold_right Idset.add idl bounded in let vars_fix i vs fid = let vs1,bounded1 = List.fold_left (fun (vs,bounded) (na,k,bbd,bty) -> let vs' = vars_option bounded vs bbd in let vs'' = vars bounded vs' bty in let bounded' = add_name_to_ids bounded na in (vs'',bounded') ) (vs,bounded') bl.(i) in let vs2 = vars bounded1 vs1 tyl.(i) in vars bounded1 vs2 bv.(i) in array_fold_left_i vars_fix vs idl | GCast (loc,c,k) -> let v = vars bounded vs c in (match k with CastConv (_,t) -> vars bounded v t | _ -> v) | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> vs and vars_pattern bounded vs (loc,idl,p,c) = let bounded' = List.fold_right Idset.add idl bounded in vars bounded' vs c and vars_option bounded vs = function None -> vs | Some p -> vars bounded vs p and vars_return_type bounded vs (na,tyopt) = let bounded' = add_name_to_ids bounded na in vars_option bounded' vs tyopt in fun rt -> let vs = vars Idset.empty Idset.empty rt in Idset.elements vs let loc_of_glob_constr = function | GRef (loc,_) -> loc | GVar (loc,_) -> loc | GEvar (loc,_,_) -> loc | GPatVar (loc,_) -> loc | GApp (loc,_,_) -> loc | GLambda (loc,_,_,_,_) -> loc | GProd (loc,_,_,_,_) -> loc | GLetIn (loc,_,_,_) -> loc | GCases (loc,_,_,_,_) -> loc | GLetTuple (loc,_,_,_,_) -> loc | GIf (loc,_,_,_,_) -> loc | GRec (loc,_,_,_,_,_) -> loc | GSort (loc,_) -> loc | GHole (loc,_) -> loc | GCast (loc,_,_) -> loc (**********************************************************************) (* Conversion from glob_constr to cases pattern, if possible *) let rec cases_pattern_of_glob_constr na = function | GVar (loc,id) when na<>Anonymous -> (* Unable to manage the presence of both an alias and a variable *) raise Not_found | GVar (loc,id) -> PatVar (loc,Name id) | GHole (loc,_) -> PatVar (loc,na) | GRef (loc,ConstructRef cstr) -> PatCstr (loc,cstr,[],na) | GApp (loc,GRef (_,ConstructRef (ind,_ as cstr)),args) -> let mib,_ = Global.lookup_inductive ind in let nparams = mib.Declarations.mind_nparams in if nparams > List.length args then user_err_loc (loc,"",Pp.str "Invalid notation for pattern."); let params,args = list_chop nparams args in List.iter (function GHole _ -> () | _ -> user_err_loc (loc,"",Pp.str"Invalid notation for pattern.")) params; let args = List.map (cases_pattern_of_glob_constr Anonymous) args in PatCstr (loc,cstr,args,na) | _ -> raise Not_found (* Turn a closed cases pattern into a glob_constr *) let rec glob_constr_of_closed_cases_pattern_aux = function | PatCstr (loc,cstr,[],Anonymous) -> GRef (loc,ConstructRef cstr) | PatCstr (loc,cstr,l,Anonymous) -> let ref = GRef (loc,ConstructRef cstr) in GApp (loc,ref, List.map glob_constr_of_closed_cases_pattern_aux l) | _ -> raise Not_found let glob_constr_of_closed_cases_pattern = function | PatCstr (loc,cstr,l,na) -> na,glob_constr_of_closed_cases_pattern_aux (PatCstr (loc,cstr,l,Anonymous)) | _ -> raise Not_found (**********************************************************************) (* Reduction expressions *) type 'a glob_red_flag = { rBeta : bool; rIota : bool; rZeta : bool; rDelta : bool; (* true = delta all but rConst; false = delta only on rConst*) rConst : 'a list } let all_flags = {rBeta = true; rIota = true; rZeta = true; rDelta = true; rConst = []} type 'a or_var = ArgArg of 'a | ArgVar of identifier located type occurrences_expr = bool * int or_var list let all_occurrences_expr_but l = (false,l) let no_occurrences_expr_but l = (true,l) let all_occurrences_expr = (false,[]) let no_occurrences_expr = (true,[]) type 'a with_occurrences = occurrences_expr * 'a type ('a,'b,'c) red_expr_gen = | Red of bool | Hnf | Simpl of 'c with_occurrences option | Cbv of 'b glob_red_flag | Lazy of 'b glob_red_flag | Unfold of 'b with_occurrences list | Fold of 'a list | Pattern of 'a with_occurrences list | ExtraRedExpr of string | CbvVm type ('a,'b,'c) may_eval = | ConstrTerm of 'a | ConstrEval of ('a,'b,'c) red_expr_gen * 'a | ConstrContext of (loc * identifier) * 'a | ConstrTypeOf of 'a coq-8.4pl4/pretyping/coercion.ml0000644000175000017500000002504512326224777016015 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment (* [inh_coerce_to_sort env evd j] coerces [j] to a type; i.e. it inserts a coercion into [j], if needed, in such a way it gets as type a sort; it fails if no coercion is applicable *) val inh_coerce_to_sort : loc -> env -> evar_map -> unsafe_judgment -> evar_map * unsafe_type_judgment (* [inh_coerce_to_base env evd j] coerces [j] to its base type; i.e. it inserts a coercion into [j], if needed, in such a way it gets as type its base type (the notion depends on the coercion system) *) val inh_coerce_to_base : loc -> env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment (* [inh_coerce_to_prod env evars t] coerces [t] to a product type *) val inh_coerce_to_prod : loc -> env -> evar_map -> type_constraint_type -> evar_map * type_constraint_type (* [inh_conv_coerce_to loc env evd j t] coerces [j] to an object of type [t]; i.e. it inserts a coercion into [j], if needed, in such a way [t] and [j.uj_type] are convertible; it fails if no coercion is applicable *) val inh_conv_coerce_to : bool -> loc -> env -> evar_map -> unsafe_judgment -> type_constraint_type -> evar_map * unsafe_judgment val inh_conv_coerce_rigid_to : bool -> loc -> env -> evar_map -> unsafe_judgment -> type_constraint_type -> evar_map * unsafe_judgment (* [inh_conv_coerces_to loc env evd t t'] checks if an object of type [t] is coercible to an object of type [t'] adding evar constraints if needed; it fails if no coercion exists *) val inh_conv_coerces_to : loc -> env -> evar_map -> types -> type_constraint_type -> evar_map (* [inh_pattern_coerce_to loc env evd pat ind1 ind2] coerces the Cases pattern [pat] typed in [ind1] into a pattern typed in [ind2]; raises [Not_found] if no coercion found *) val inh_pattern_coerce_to : loc -> Glob_term.cases_pattern -> inductive -> inductive -> Glob_term.cases_pattern end module Default = struct (* Typing operations dealing with coercions *) exception NoCoercion (* Here, funj is a coercion therefore already typed in global context *) let apply_coercion_args env argl funj = let rec apply_rec acc typ = function | [] -> { uj_val = applist (j_val funj,argl); uj_type = typ } | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *) match kind_of_term (whd_betadeltaiota env Evd.empty typ) with | Prod (_,c1,c2) -> (* Typage garanti par l'appel ā app_coercion*) apply_rec (h::acc) (subst1 h c2) restl | _ -> anomaly "apply_coercion_args" in apply_rec [] funj.uj_type argl (* appliquer le chemin de coercions de patterns p *) let apply_pattern_coercion loc pat p = List.fold_left (fun pat (co,n) -> let f i = if i let fv,isid = coercion_value i in let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in let jres = apply_coercion_args env argl fv in (if isid then { uj_val = ja.uj_val; uj_type = jres.uj_type } else jres), jres.uj_type) (hj,typ_cl) p) with e when Errors.noncritical e -> anomaly "apply_coercion" let inh_app_fun env evd j = let t = whd_betadeltaiota env evd j.uj_type in match kind_of_term t with | Prod (_,_,_) -> (evd,j) | Evar ev -> let (evd',t) = define_evar_as_product evd ev in (evd',{ uj_val = j.uj_val; uj_type = t }) | _ -> let t,p = lookup_path_to_fun_from env evd j.uj_type in (evd,apply_coercion env evd p j t) let inh_app_fun resolve_tc env evd j = try inh_app_fun env evd j with | Not_found when not resolve_tc -> (evd, j) | Not_found -> try inh_app_fun env (saturate_evd env evd) j with Not_found -> (evd, j) let inh_tosort_force loc env evd j = try let t,p = lookup_path_to_sort_from env evd j.uj_type in let j1 = apply_coercion env evd p j t in let j2 = on_judgment_type (whd_evar evd) j1 in (evd,type_judgment env j2) with Not_found -> error_not_a_type_loc loc env evd j let inh_coerce_to_sort loc env evd j = let typ = whd_betadeltaiota env evd j.uj_type in match kind_of_term typ with | Sort s -> (evd,{ utj_val = j.uj_val; utj_type = s }) | Evar ev when not (is_defined_evar evd ev) -> let (evd',s) = define_evar_as_sort evd ev in (evd',{ utj_val = j.uj_val; utj_type = s }) | _ -> inh_tosort_force loc env evd j let inh_coerce_to_base loc env evd j = (evd, j) let inh_coerce_to_prod loc env evd t = (evd, t) let inh_coerce_to_fail env evd rigidonly v t c1 = if rigidonly & not (Heads.is_rigid env c1 && Heads.is_rigid env t) then raise NoCoercion else let v', t' = try let t2,t1,p = lookup_path_between env evd (t,c1) in match v with Some v -> let j = apply_coercion env evd p {uj_val = v; uj_type = t} t2 in Some j.uj_val, j.uj_type | None -> None, t with Not_found -> raise NoCoercion in try (the_conv_x_leq env t' c1 evd, v') with Reduction.NotConvertible -> raise NoCoercion let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = try (the_conv_x_leq env t c1 evd, v) with Reduction.NotConvertible -> try inh_coerce_to_fail env evd rigidonly v t c1 with NoCoercion -> match kind_of_term (whd_betadeltaiota env evd t), kind_of_term (whd_betadeltaiota env evd c1) with | Prod (name,t1,t2), Prod (_,u1,u2) -> (* Conversion did not work, we may succeed with a coercion. *) (* We eta-expand (hence possibly modifying the original term!) *) (* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *) (* has type forall (x:u1), u2 (with v' recursively obtained) *) (* Note: we retype the term because sort-polymorphism may have *) (* weaken its type *) let name = match name with | Anonymous -> Name (id_of_string "x") | _ -> name in let env1 = push_rel (name,None,u1) env in let (evd', v1) = inh_conv_coerce_to_fail loc env1 evd rigidonly (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in let v1 = Option.get v1 in let v2 = Option.map (fun v -> beta_applist (lift 1 v,[v1])) v in let t2 = match v2 with | None -> subst_term v1 t2 | Some v2 -> Retyping.get_type_of env1 evd' v2 in let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') | _ -> raise NoCoercion (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) let inh_conv_coerce_to_gen resolve_tc rigidonly loc env evd cj (n, t) = match n with None -> let (evd', val') = try inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t with | NoCoercion when not resolve_tc -> error_actual_type_loc loc env evd cj t | NoCoercion -> let evd = saturate_evd env evd in try inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t with NoCoercion -> error_actual_type_loc loc env evd cj t in let val' = match val' with Some v -> v | None -> assert(false) in (evd',{ uj_val = val'; uj_type = t }) | Some (init, cur) -> (evd, cj) let inh_conv_coerce_to resolve_tc = inh_conv_coerce_to_gen resolve_tc false let inh_conv_coerce_rigid_to resolve_tc = inh_conv_coerce_to_gen resolve_tc true let inh_conv_coerces_to loc env (evd : evar_map) t (abs, t') = if abs = None then try fst (inh_conv_coerce_to_fail loc env evd true None t t') with NoCoercion -> evd (* Maybe not enough information to unify *) else evd (* Still problematic, as it changes unification let nabsinit, nabs = match abs with None -> 0, 0 | Some (init, cur) -> init, cur in try let (rels, rng) = (* a little more effort to get products is needed *) try decompose_prod_n nabs t with _ -> if !Flags.debug then msg_warning (str "decompose_prod_n failed"); raise (Invalid_argument "Coercion.inh_conv_coerces_to") in (* The final range free variables must have been replaced by evars, we accept only that evars in rng are applied to free vars. *) if noccur_with_meta 0 (succ nabsinit) rng then ( let env', t, t' = let env' = List.fold_right (fun (n, t) env -> push_rel (n, None, t) env) rels env in env', rng, lift nabs t' in try pi1 (inh_conv_coerce_to_fail loc env' evd None t t') with NoCoercion -> evd) (* Maybe not enough information to unify *) (*let sigma = evd in error_cannot_coerce env' sigma (t, t'))*) else evd with Invalid_argument _ -> evd *) end coq-8.4pl4/pretyping/pretype_errors.mli0000644000175000017500000001057112326224777017447 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool (** Presenting terms without solved evars *) val nf_evar : Evd.evar_map -> constr -> constr val j_nf_evar : Evd.evar_map -> unsafe_judgment -> unsafe_judgment val jl_nf_evar : Evd.evar_map -> unsafe_judgment list -> unsafe_judgment list val jv_nf_evar : Evd.evar_map -> unsafe_judgment array -> unsafe_judgment array val tj_nf_evar : Evd.evar_map -> unsafe_type_judgment -> unsafe_type_judgment val env_nf_evar : Evd.evar_map -> env -> env val env_nf_betaiotaevar : Evd.evar_map -> env -> env val j_nf_betaiotaevar : Evd.evar_map -> unsafe_judgment -> unsafe_judgment val jv_nf_betaiotaevar : Evd.evar_map -> unsafe_judgment array -> unsafe_judgment array (** Raising errors *) val error_actual_type_loc : loc -> env -> Evd.evar_map -> unsafe_judgment -> constr -> 'b val error_cant_apply_not_functional_loc : loc -> env -> Evd.evar_map -> unsafe_judgment -> unsafe_judgment list -> 'b val error_cant_apply_bad_type_loc : loc -> env -> Evd.evar_map -> int * constr * constr -> unsafe_judgment -> unsafe_judgment list -> 'b val error_case_not_inductive_loc : loc -> env -> Evd.evar_map -> unsafe_judgment -> 'b val error_ill_formed_branch_loc : loc -> env -> Evd.evar_map -> constr -> constructor -> constr -> constr -> 'b val error_number_branches_loc : loc -> env -> Evd.evar_map -> unsafe_judgment -> int -> 'b val error_ill_typed_rec_body_loc : loc -> env -> Evd.evar_map -> int -> name array -> unsafe_judgment array -> types array -> 'b val error_not_a_type_loc : loc -> env -> Evd.evar_map -> unsafe_judgment -> 'b val error_cannot_coerce : env -> Evd.evar_map -> constr * constr -> 'b (** {6 Implicit arguments synthesis errors } *) val error_occur_check : env -> Evd.evar_map -> existential_key -> constr -> 'b val error_not_clean : env -> Evd.evar_map -> existential_key -> constr -> loc * Evd.hole_kind -> 'b val error_unsolvable_implicit : loc -> env -> Evd.evar_map -> Evd.evar_info -> Evd.hole_kind -> Evd.unsolvability_explanation option -> 'b val error_cannot_unify : env -> Evd.evar_map -> constr * constr -> 'b val error_cannot_unify_local : env -> Evd.evar_map -> constr * constr * constr -> 'b val error_cannot_find_well_typed_abstraction : env -> Evd.evar_map -> constr -> constr list -> 'b val error_abstraction_over_meta : env -> Evd.evar_map -> metavariable -> metavariable -> 'b val error_non_linear_unification : env -> Evd.evar_map -> metavariable -> constr -> 'b (** {6 Ml Case errors } *) val error_cant_find_case_type_loc : loc -> env -> Evd.evar_map -> constr -> 'b (** {6 Pretyping errors } *) val error_unexpected_type_loc : loc -> env -> Evd.evar_map -> constr -> constr -> 'b val error_not_product_loc : loc -> env -> Evd.evar_map -> constr -> 'b (** {6 Error in conversion from AST to glob_constr } *) val error_var_not_found_loc : loc -> identifier -> 'b coq-8.4pl4/pretyping/evd.ml0000644000175000017500000007273012326224777014775 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true) (named_context_of_val hyps); evar_source = (dummy_loc,InternalHole); evar_candidates = None; evar_extra = Store.empty } let evar_concl evi = evi.evar_concl let evar_hyps evi = evi.evar_hyps let evar_context evi = named_context_of_val evi.evar_hyps let evar_body evi = evi.evar_body let evar_filter evi = evi.evar_filter let evar_filtered_context evi = snd (list_filter2 (fun b c -> b) (evar_filter evi,evar_context evi)) let evar_filtered_hyps evi = List.fold_right push_named_context_val (evar_filtered_context evi) empty_named_context_val let evar_unfiltered_env evi = Global.env_of_context evi.evar_hyps let evar_env evi = List.fold_right push_named (evar_filtered_context evi) (reset_context (Global.env())) let eq_evar_info ei1 ei2 = ei1 == ei2 || eq_constr ei1.evar_concl ei2.evar_concl && eq_named_context_val (ei1.evar_hyps) (ei2.evar_hyps) && ei1.evar_body = ei2.evar_body (* spiwack: Revised hierarchy : - ExistentialMap ( Maps of existential_keys ) - EvarInfoMap ( .t = evar_info ExistentialMap.t * evar_info ExistentialMap ) - EvarMap ( .t = EvarInfoMap.t * sort_constraints ) - evar_map (exported) *) module ExistentialMap = Intmap module ExistentialSet = Intset (* This exception is raised by *.existential_value *) exception NotInstantiatedEvar (* Note: let-in contributes to the instance *) let make_evar_instance sign args = let rec instrec = function | (id,_,_) :: sign, c::args when isVarId id c -> instrec (sign,args) | (id,_,_) :: sign, c::args -> (id,c) :: instrec (sign,args) | [],[] -> [] | [],_ | _,[] -> anomaly "Signature and its instance do not match" in instrec (sign,args) let instantiate_evar sign c args = let inst = make_evar_instance sign args in if inst = [] then c else replace_vars inst c module EvarInfoMap = struct type t = evar_info ExistentialMap.t * evar_info ExistentialMap.t let empty = ExistentialMap.empty, ExistentialMap.empty let is_empty (d,u) = ExistentialMap.is_empty d && ExistentialMap.is_empty u let has_undefined (_,u) = not (ExistentialMap.is_empty u) let to_list (def,undef) = (* Workaround for change in Map.fold behavior in ocaml 3.08.4 *) let l = ref [] in ExistentialMap.iter (fun evk x -> l := (evk,x)::!l) def; ExistentialMap.iter (fun evk x -> l := (evk,x)::!l) undef; !l let undefined_list (def,undef) = (* Order is important: needs ocaml >= 3.08.4 from which "fold" is a "fold_left" *) ExistentialMap.fold (fun evk evi l -> (evk,evi)::l) undef [] let undefined_evars (def,undef) = (ExistentialMap.empty,undef) let defined_evars (def,undef) = (def,ExistentialMap.empty) let find (def,undef) k = try ExistentialMap.find k def with Not_found -> ExistentialMap.find k undef let find_undefined (def,undef) k = ExistentialMap.find k undef let remove (def,undef) k = (ExistentialMap.remove k def,ExistentialMap.remove k undef) let mem (def,undef) k = ExistentialMap.mem k def || ExistentialMap.mem k undef let fold (def,undef) f a = ExistentialMap.fold f def (ExistentialMap.fold f undef a) let fold_undefined (def,undef) f a = ExistentialMap.fold f undef a let exists_undefined (def,undef) f = ExistentialMap.fold (fun k v b -> b || f k v) undef false let add (def,undef) evk newinfo = if newinfo.evar_body = Evar_empty then (def,ExistentialMap.add evk newinfo undef) else (ExistentialMap.add evk newinfo def,undef) let add_undefined (def,undef) evk newinfo = assert (newinfo.evar_body = Evar_empty); (def,ExistentialMap.add evk newinfo undef) let map f (def,undef) = (ExistentialMap.map f def, ExistentialMap.map f undef) let define (def,undef) evk body = let oldinfo = try ExistentialMap.find evk undef with Not_found -> try ExistentialMap.find evk def with Not_found -> anomaly "Evd.define: cannot define undeclared evar" in let newinfo = { oldinfo with evar_body = Evar_defined body } in match oldinfo.evar_body with | Evar_empty -> (ExistentialMap.add evk newinfo def,ExistentialMap.remove evk undef) | _ -> anomaly "Evd.define: cannot define an evar twice" let is_evar = mem let is_defined (def,undef) evk = ExistentialMap.mem evk def let is_undefined (def,undef) evk = ExistentialMap.mem evk undef (*******************************************************************) (* Formerly Instantiate module *) (* Existentials. *) let existential_type sigma (n,args) = let info = try find sigma n with Not_found -> anomaly ("Evar "^(string_of_existential n)^" was not declared") in let hyps = evar_filtered_context info in instantiate_evar hyps info.evar_concl (Array.to_list args) let existential_value sigma (n,args) = let info = find sigma n in let hyps = evar_filtered_context info in match evar_body info with | Evar_defined c -> instantiate_evar hyps c (Array.to_list args) | Evar_empty -> raise NotInstantiatedEvar let existential_opt_value sigma ev = try Some (existential_value sigma ev) with NotInstantiatedEvar -> None end module EvarMap = struct type t = EvarInfoMap.t * (Univ.UniverseLSet.t * Univ.universes) let empty = EvarInfoMap.empty, (Univ.UniverseLSet.empty, Univ.initial_universes) let is_empty (sigma,_) = EvarInfoMap.is_empty sigma let has_undefined (sigma,_) = EvarInfoMap.has_undefined sigma let add (sigma,sm) k v = (EvarInfoMap.add sigma k v, sm) let add_undefined (sigma,sm) k v = (EvarInfoMap.add_undefined sigma k v, sm) let find (sigma,_) = EvarInfoMap.find sigma let find_undefined (sigma,_) = EvarInfoMap.find_undefined sigma let remove (sigma,sm) k = (EvarInfoMap.remove sigma k, sm) let mem (sigma,_) = EvarInfoMap.mem sigma let to_list (sigma,_) = EvarInfoMap.to_list sigma let undefined_list (sigma,_) = EvarInfoMap.undefined_list sigma let undefined_evars (sigma,sm) = (EvarInfoMap.undefined_evars sigma, sm) let defined_evars (sigma,sm) = (EvarInfoMap.defined_evars sigma, sm) let fold (sigma,_) = EvarInfoMap.fold sigma let fold_undefined (sigma,_) = EvarInfoMap.fold_undefined sigma let define (sigma,sm) k v = (EvarInfoMap.define sigma k v, sm) let is_evar (sigma,_) = EvarInfoMap.is_evar sigma let is_defined (sigma,_) = EvarInfoMap.is_defined sigma let is_undefined (sigma,_) = EvarInfoMap.is_undefined sigma let existential_value (sigma,_) = EvarInfoMap.existential_value sigma let existential_type (sigma,_) = EvarInfoMap.existential_type sigma let existential_opt_value (sigma,_) = EvarInfoMap.existential_opt_value sigma let progress_evar_map (sigma1,sm1 as x) (sigma2,sm2 as y) = not (x == y) && (EvarInfoMap.exists_undefined sigma1 (fun k v -> assert (v.evar_body = Evar_empty); EvarInfoMap.is_defined sigma2 k)) let merge e e' = fold e' (fun n v sigma -> add sigma n v) e let add_constraints (sigma, (us, sm)) cstrs = (sigma, (us, Univ.merge_constraints cstrs sm)) end (*******************************************************************) (* Metamaps *) (*******************************************************************) (* Constraints for existential variables *) (*******************************************************************) type 'a freelisted = { rebus : 'a; freemetas : Intset.t } (* Collects all metavars appearing in a constr *) let metavars_of c = let rec collrec acc c = match kind_of_term c with | Meta mv -> Intset.add mv acc | _ -> fold_constr collrec acc c in collrec Intset.empty c let mk_freelisted c = { rebus = c; freemetas = metavars_of c } let map_fl f cfl = { cfl with rebus=f cfl.rebus } (* Status of an instance found by unification wrt to the meta it solves: - a supertype of the meta (e.g. the solution to ?X <= T is a supertype of ?X) - a subtype of the meta (e.g. the solution to T <= ?X is a supertype of ?X) - a term that can be eta-expanded n times while still being a solution (e.g. the solution [P] to [?X u v = P u v] can be eta-expanded twice) *) type instance_constraint = IsSuperType | IsSubType | Conv (* Status of the unification of the type of an instance against the type of the meta it instantiates: - CoerceToType means that the unification of types has not been done and that a coercion can still be inserted: the meta should not be substituted freely (this happens for instance given via the "with" binding clause). - TypeProcessed means that the information obtainable from the unification of types has been extracted. - TypeNotProcessed means that the unification of types has not been done but it is known that no coercion may be inserted: the meta can be substituted freely. *) type instance_typing_status = CoerceToType | TypeNotProcessed | TypeProcessed (* Status of an instance together with the status of its type unification *) type instance_status = instance_constraint * instance_typing_status (* Clausal environments *) type clbinding = | Cltyp of name * constr freelisted | Clval of name * (constr freelisted * instance_status) * constr freelisted let map_clb f = function | Cltyp (na,cfl) -> Cltyp (na,map_fl f cfl) | Clval (na,(cfl1,pb),cfl2) -> Clval (na,(map_fl f cfl1,pb),map_fl f cfl2) (* name of defined is erased (but it is pretty-printed) *) let clb_name = function Cltyp(na,_) -> (na,false) | Clval (na,_,_) -> (na,true) (***********************) module Metaset = Intset let meta_exists p s = Metaset.fold (fun x b -> b || (p x)) s false module Metamap = Intmap let metamap_to_list m = Metamap.fold (fun n v l -> (n,v)::l) m [] (*************************) (* Unification state *) type conv_pb = Reduction.conv_pb type evar_constraint = conv_pb * Environ.env * constr * constr type evar_map = { evars : EvarMap.t; conv_pbs : evar_constraint list; last_mods : ExistentialSet.t; metas : clbinding Metamap.t } (*** Lifting primitive from EvarMap. ***) (* HH: The progress tactical now uses this function. *) let progress_evar_map d1 d2 = EvarMap.progress_evar_map d1.evars d2.evars (* spiwack: tentative. It might very well not be the semantics we want for merging evar_map *) let merge d1 d2 = { evars = EvarMap.merge d1.evars d2.evars ; conv_pbs = List.rev_append d1.conv_pbs d2.conv_pbs ; last_mods = ExistentialSet.union d1.last_mods d2.last_mods ; metas = Metamap.fold (fun k m r -> Metamap.add k m r) d2.metas d1.metas } let add d e i = { d with evars=EvarMap.add d.evars e i } let remove d e = { d with evars=EvarMap.remove d.evars e } let find d e = EvarMap.find d.evars e let find_undefined d e = EvarMap.find_undefined d.evars e let mem d e = EvarMap.mem d.evars e (* spiwack: this function loses information from the original evar_map it might be an idea not to export it. *) let to_list d = EvarMap.to_list d.evars let undefined_list d = EvarMap.undefined_list d.evars let undefined_evars d = { d with evars=EvarMap.undefined_evars d.evars } let defined_evars d = { d with evars=EvarMap.defined_evars d.evars } (* spiwack: not clear what folding over an evar_map, for now we shall simply fold over the inner evar_map. *) let fold f d a = EvarMap.fold d.evars f a let fold_undefined f d a = EvarMap.fold_undefined d.evars f a let is_evar d e = EvarMap.is_evar d.evars e let is_defined d e = EvarMap.is_defined d.evars e let is_undefined d e = EvarMap.is_undefined d.evars e let existential_value d e = EvarMap.existential_value d.evars e let existential_type d e = EvarMap.existential_type d.evars e let existential_opt_value d e = EvarMap.existential_opt_value d.evars e let add_constraints d e = {d with evars= EvarMap.add_constraints d.evars e} (*** /Lifting... ***) (* evar_map are considered empty disregarding histories *) let is_empty d = EvarMap.is_empty d.evars && d.conv_pbs = [] && Metamap.is_empty d.metas let subst_named_context_val s = map_named_val (subst_mps s) let subst_evar_info s evi = let subst_evb = function Evar_empty -> Evar_empty | Evar_defined c -> Evar_defined (subst_mps s c) in { evi with evar_concl = subst_mps s evi.evar_concl; evar_hyps = subst_named_context_val s evi.evar_hyps; evar_body = subst_evb evi.evar_body } let subst_evar_defs_light sub evd = assert (Univ.is_initial_universes (snd (snd evd.evars))); assert (evd.conv_pbs = []); { evd with metas = Metamap.map (map_clb (subst_mps sub)) evd.metas; evars = EvarInfoMap.map (subst_evar_info sub) (fst evd.evars), (snd evd.evars) } let subst_evar_map = subst_evar_defs_light (* spiwack: deprecated *) let create_evar_defs sigma = { sigma with conv_pbs=[]; last_mods=ExistentialSet.empty; metas=Metamap.empty } (* spiwack: tentatively deprecated *) let create_goal_evar_defs sigma = { sigma with (* conv_pbs=[]; last_mods=ExistentialSet.empty; metas=Metamap.empty } *) metas=Metamap.empty } let empty = { evars=EvarMap.empty; conv_pbs=[]; last_mods = ExistentialSet.empty; metas=Metamap.empty } let has_undefined evd = EvarMap.has_undefined evd.evars let evars_reset_evd ?(with_conv_pbs=false) evd d = {d with evars = evd.evars; conv_pbs = if with_conv_pbs then evd.conv_pbs else d.conv_pbs } let add_conv_pb pb d = {d with conv_pbs = pb::d.conv_pbs} let evar_source evk d = (EvarMap.find d.evars evk).evar_source (* define the existential of section path sp as the constr body *) let define evk body evd = { evd with evars = EvarMap.define evd.evars evk body; last_mods = match evd.conv_pbs with | [] -> evd.last_mods | _ -> ExistentialSet.add evk evd.last_mods } let evar_declare hyps evk ty ?(src=(dummy_loc,InternalHole)) ?filter ?candidates evd = let filter = if filter = None then List.map (fun _ -> true) (named_context_of_val hyps) else (let filter = Option.get filter in assert (List.length filter = List.length (named_context_of_val hyps)); filter) in { evd with evars = EvarMap.add_undefined evd.evars evk {evar_hyps = hyps; evar_concl = ty; evar_body = Evar_empty; evar_filter = filter; evar_source = src; evar_candidates = candidates; evar_extra = Store.empty } } let is_defined_evar evd (evk,_) = EvarMap.is_defined evd.evars evk (* Does k corresponds to an (un)defined existential ? *) let is_undefined_evar evd c = match kind_of_term c with | Evar ev -> not (is_defined_evar evd ev) | _ -> false (* extracts conversion problems that satisfy predicate p *) (* Note: conv_pbs not satisying p are stored back in reverse order *) let extract_conv_pbs evd p = let (pbs,pbs1) = List.fold_left (fun (pbs,pbs1) pb -> if p pb then (pb::pbs,pbs1) else (pbs,pb::pbs1)) ([],[]) evd.conv_pbs in {evd with conv_pbs = pbs1; last_mods = ExistentialSet.empty}, pbs let extract_changed_conv_pbs evd p = extract_conv_pbs evd (p evd.last_mods) let extract_all_conv_pbs evd = extract_conv_pbs evd (fun _ -> true) (* spiwack: should it be replaced by Evd.merge? *) let evar_merge evd evars = { evd with evars = EvarMap.merge evd.evars evars.evars } let evar_list evd c = let rec evrec acc c = match kind_of_term c with | Evar (evk, _ as ev) when mem evd evk -> ev :: acc | _ -> fold_constr evrec acc c in evrec [] c let collect_evars c = let rec collrec acc c = match kind_of_term c with | Evar (evk,_) -> ExistentialSet.add evk acc | _ -> fold_constr collrec acc c in collrec ExistentialSet.empty c (**********************************************************) (* Sort variables *) let new_univ_variable ({ evars = (sigma,(us,sm)) } as d) = let u = Termops.new_univ_level () in let us' = Univ.UniverseLSet.add u us in ({d with evars = (sigma, (us', sm))}, Univ.make_universe u) let new_sort_variable d = let (d', u) = new_univ_variable d in (d', Type u) let is_sort_variable {evars=(_,(us,_))} s = match s with Type u -> true | _ -> false let whd_sort_variable {evars=(_,sm)} t = t let univ_of_sort = function | Type u -> u | Prop Pos -> Univ.type0_univ | Prop Null -> Univ.type0m_univ let is_eq_sort s1 s2 = if s1 = s2 then None else let u1 = univ_of_sort s1 and u2 = univ_of_sort s2 in if u1 = u2 then None else Some (u1, u2) let is_univ_var_or_set u = Univ.is_univ_variable u || u = Univ.type0_univ let set_leq_sort ({evars = (sigma, (us, sm))} as d) s1 s2 = match is_eq_sort s1 s2 with | None -> d | Some (u1, u2) -> match s1, s2 with | Prop c, Prop c' -> if c = Null && c' = Pos then d else (raise (Univ.UniverseInconsistency (Univ.Le, u1, u2))) | Type u, Prop c -> if c = Pos then add_constraints d (Univ.enforce_geq Univ.type0_univ u Univ.empty_constraint) else raise (Univ.UniverseInconsistency (Univ.Le, u1, u2)) | _, Type u -> if is_univ_var_or_set u then add_constraints d (Univ.enforce_geq u2 u1 Univ.empty_constraint) else raise (Univ.UniverseInconsistency (Univ.Le, u1, u2)) let is_univ_level_var us u = match Univ.universe_level u with | Some u -> Univ.UniverseLSet.mem u us | None -> false let set_eq_sort ({evars = (sigma, (us, sm))} as d) s1 s2 = match is_eq_sort s1 s2 with | None -> d | Some (u1, u2) -> match s1, s2 with | Prop c, Type u when is_univ_level_var us u -> add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) | Type u, Prop c when is_univ_level_var us u -> add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) | Type u, Type v when (is_univ_level_var us u) || (is_univ_level_var us v) -> add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) | Prop c, Type u when is_univ_var_or_set u && Univ.check_eq sm u1 u2 -> d | Type u, Prop c when is_univ_var_or_set u && Univ.check_eq sm u1 u2 -> d | Type u, Type v when is_univ_var_or_set u && is_univ_var_or_set v -> add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) | _, _ -> raise (Univ.UniverseInconsistency (Univ.Eq, u1, u2)) (**********************************************************) (* Accessing metas *) let meta_list evd = metamap_to_list evd.metas let find_meta evd mv = Metamap.find mv evd.metas let undefined_metas evd = List.sort Pervasives.compare (map_succeed (function | (n,Clval(_,_,typ)) -> failwith "" | (n,Cltyp (_,typ)) -> n) (meta_list evd)) let metas_of evd = List.map (function | (n,Clval(_,_,typ)) -> (n,typ.rebus) | (n,Cltyp (_,typ)) -> (n,typ.rebus)) (meta_list evd) let map_metas_fvalue f evd = { evd with metas = Metamap.map (function | Clval(id,(c,s),typ) -> Clval(id,(mk_freelisted (f c.rebus),s),typ) | x -> x) evd.metas } let meta_opt_fvalue evd mv = match Metamap.find mv evd.metas with | Clval(_,b,_) -> Some b | Cltyp _ -> None let meta_defined evd mv = match Metamap.find mv evd.metas with | Clval _ -> true | Cltyp _ -> false let try_meta_fvalue evd mv = match Metamap.find mv evd.metas with | Clval(_,b,_) -> b | Cltyp _ -> raise Not_found let meta_fvalue evd mv = try try_meta_fvalue evd mv with Not_found -> anomaly "meta_fvalue: meta has no value" let meta_value evd mv = (fst (try_meta_fvalue evd mv)).rebus let meta_ftype evd mv = match Metamap.find mv evd.metas with | Cltyp (_,b) -> b | Clval(_,_,b) -> b let meta_type evd mv = (meta_ftype evd mv).rebus let meta_declare mv v ?(name=Anonymous) evd = { evd with metas = Metamap.add mv (Cltyp(name,mk_freelisted v)) evd.metas } let meta_assign mv (v,pb) evd = match Metamap.find mv evd.metas with | Cltyp(na,ty) -> { evd with metas = Metamap.add mv (Clval(na,(mk_freelisted v,pb),ty)) evd.metas } | _ -> anomaly "meta_assign: already defined" let meta_reassign mv (v,pb) evd = match Metamap.find mv evd.metas with | Clval(na,_,ty) -> { evd with metas = Metamap.add mv (Clval(na,(mk_freelisted v,pb),ty)) evd.metas } | _ -> anomaly "meta_reassign: not yet defined" (* If the meta is defined then forget its name *) let meta_name evd mv = try fst (clb_name (Metamap.find mv evd.metas)) with Not_found -> Anonymous let meta_with_name evd id = let na = Name id in let (mvl,mvnodef) = Metamap.fold (fun n clb (l1,l2 as l) -> let (na',def) = clb_name clb in if na = na' then if def then (n::l1,l2) else (n::l1,n::l2) else l) evd.metas ([],[]) in match mvnodef, mvl with | _,[] -> errorlabstrm "Evd.meta_with_name" (str"No such bound variable " ++ pr_id id ++ str".") | ([n],_|_,[n]) -> n | _ -> errorlabstrm "Evd.meta_with_name" (str "Binder name \"" ++ pr_id id ++ strbrk "\" occurs more than once in clause.") let meta_merge evd1 evd2 = {evd2 with metas = List.fold_left (fun m (n,v) -> Metamap.add n v m) evd2.metas (metamap_to_list evd1.metas) } type metabinding = metavariable * constr * instance_status let retract_coercible_metas evd = let mc,ml = Metamap.fold (fun n v (mc,ml) -> match v with | Clval (na,(b,(Conv,CoerceToType as s)),typ) -> (n,b.rebus,s)::mc, Metamap.add n (Cltyp (na,typ)) ml | v -> mc, Metamap.add n v ml) evd.metas ([],Metamap.empty) in mc, { evd with metas = ml } let rec list_assoc_in_triple x = function [] -> raise Not_found | (a,b,_)::l -> if compare a x = 0 then b else list_assoc_in_triple x l let subst_defined_metas bl c = let rec substrec c = match kind_of_term c with | Meta i -> substrec (list_assoc_snd_in_triple i bl) | _ -> map_constr substrec c in try Some (substrec c) with Not_found -> None (*******************************************************************) type open_constr = evar_map * constr (*******************************************************************) (* The type constructor ['a sigma] adds an evar map to an object of type ['a] *) type 'a sigma = { it : 'a ; sigma : evar_map} let sig_it x = x.it let sig_sig x = x.sigma (**********************************************************) (* Failure explanation *) type unsolvability_explanation = SeveralInstancesFound of int (**********************************************************) (* Pretty-printing *) let pr_instance_status (sc,typ) = begin match sc with | IsSubType -> str " [or a subtype of it]" | IsSuperType -> str " [or a supertype of it]" | Conv -> mt () end ++ begin match typ with | CoerceToType -> str " [up to coercion]" | TypeNotProcessed -> mt () | TypeProcessed -> str " [type is checked]" end let pr_meta_map mmap = let pr_name = function Name id -> str"[" ++ pr_id id ++ str"]" | _ -> mt() in let pr_meta_binding = function | (mv,Cltyp (na,b)) -> hov 0 (pr_meta mv ++ pr_name na ++ str " : " ++ print_constr b.rebus ++ fnl ()) | (mv,Clval(na,(b,s),t)) -> hov 0 (pr_meta mv ++ pr_name na ++ str " := " ++ print_constr b.rebus ++ str " : " ++ print_constr t.rebus ++ spc () ++ pr_instance_status s ++ fnl ()) in prlist pr_meta_binding (metamap_to_list mmap) let pr_decl ((id,b,_),ok) = match b with | None -> if ok then pr_id id else (str "{" ++ pr_id id ++ str "}") | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++ print_constr c ++ str (if ok then ")" else "}") let pr_evar_source = function | QuestionMark _ -> str "underscore" | CasesType -> str "pattern-matching return predicate" | BinderType (Name id) -> str "type of " ++ Nameops.pr_id id | BinderType Anonymous -> str "type of anonymous binder" | ImplicitArg (c,(n,ido),b) -> let id = Option.get ido in str "parameter " ++ pr_id id ++ spc () ++ str "of" ++ spc () ++ print_constr (constr_of_global c) | InternalHole -> str "internal placeholder" | TomatchTypeParameter (ind,n) -> nth n ++ str " argument of type " ++ print_constr (mkInd ind) | GoalEvar -> str "goal evar" | ImpossibleCase -> str "type of impossible pattern-matching clause" | MatchingVar _ -> str "matching variable" let pr_evar_info evi = let phyps = try let decls = List.combine (evar_context evi) (evar_filter evi) in prlist_with_sep pr_spc pr_decl (List.rev decls) with Invalid_argument _ -> str "Ill-formed filtered context" in let pty = print_constr evi.evar_concl in let pb = match evi.evar_body with | Evar_empty -> mt () | Evar_defined c -> spc() ++ str"=> " ++ print_constr c in let candidates = match evi.evar_body, evi.evar_candidates with | Evar_empty, Some l -> spc () ++ str "{" ++ prlist_with_sep (fun () -> str "|") print_constr l ++ str "}" | _ -> mt () in let src = str "(" ++ pr_evar_source (snd evi.evar_source) ++ str ")" in hov 2 (str"[" ++ phyps ++ spc () ++ str"|- " ++ pty ++ pb ++ str"]" ++ candidates ++ spc() ++ src) let compute_evar_dependency_graph (sigma:evar_map) = (* Compute the map binding ev to the evars whose body depends on ev *) fold (fun evk evi acc -> let deps = match evar_body evi with | Evar_empty -> ExistentialSet.empty | Evar_defined c -> collect_evars c in ExistentialSet.fold (fun evk' acc -> let tab = try ExistentialMap.find evk' acc with Not_found -> [] in ExistentialMap.add evk' ((evk,evi)::tab) acc) deps acc) sigma ExistentialMap.empty let evar_dependency_closure n sigma = let graph = compute_evar_dependency_graph sigma in let order a b = fst a < fst b in let rec aux n l = if n=0 then l else let l' = list_map_append (fun (evk,_) -> try ExistentialMap.find evk graph with Not_found -> []) l in aux (n-1) (list_uniquize (Sort.list order (l@l'))) in aux n (undefined_list sigma) let pr_evar_map_t depth sigma = let (evars,(uvs,univs)) = sigma.evars in let pr_evar_list l = h 0 (prlist_with_sep pr_fnl (fun (ev,evi) -> h 0 (str(string_of_existential ev) ++ str"==" ++ pr_evar_info evi)) l) in let evs = if EvarInfoMap.is_empty evars then mt () else match depth with | None -> (* Print all evars *) str"EVARS:"++brk(0,1)++pr_evar_list (to_list sigma)++fnl() | Some n -> (* Print all evars *) str"UNDEFINED EVARS"++ (if n=0 then mt() else str" (+level "++int n++str" closure):")++ brk(0,1)++ pr_evar_list (evar_dependency_closure n sigma)++fnl() and svs = if Univ.UniverseLSet.is_empty uvs then mt () else str"UNIVERSE VARIABLES:"++brk(0,1)++ h 0 (prlist_with_sep pr_fnl (fun u -> Univ.pr_uni_level u) (Univ.UniverseLSet.elements uvs))++fnl() and cs = if Univ.is_initial_universes univs then mt () else str"UNIVERSES:"++brk(0,1)++ h 0 (Univ.pr_universes univs)++fnl() in evs ++ svs ++ cs let print_env_short env = let pr_body n = function None -> pr_name n | Some b -> str "(" ++ pr_name n ++ str " := " ++ print_constr b ++ str ")" in let pr_named_decl (n, b, _) = pr_body (Name n) b in let pr_rel_decl (n, b, _) = pr_body n b in let nc = List.rev (named_context env) in let rc = List.rev (rel_context env) in str "[" ++ prlist_with_sep pr_spc pr_named_decl nc ++ str "]" ++ spc () ++ str "[" ++ prlist_with_sep pr_spc pr_rel_decl rc ++ str "]" let pr_constraints pbs = h 0 (prlist_with_sep pr_fnl (fun (pbty,env,t1,t2) -> print_env_short env ++ spc () ++ str "|-" ++ spc () ++ print_constr t1 ++ spc() ++ str (match pbty with | Reduction.CONV -> "==" | Reduction.CUMUL -> "<=") ++ spc() ++ print_constr t2) pbs) let pr_evar_map_constraints evd = if evd.conv_pbs = [] then mt() else pr_constraints evd.conv_pbs++fnl() let pr_evar_map allevars evd = let pp_evm = if EvarMap.is_empty evd.evars then mt() else pr_evar_map_t allevars evd++fnl() in let cstrs = if evd.conv_pbs = [] then mt() else str"CONSTRAINTS:"++brk(0,1)++pr_constraints evd.conv_pbs++fnl() in let pp_met = if Metamap.is_empty evd.metas then mt() else str"METAS:"++brk(0,1)++pr_meta_map evd.metas in v 0 (pp_evm ++ cstrs ++ pp_met) let pr_metaset metas = str "[" ++ prlist_with_sep spc pr_meta (Metaset.elements metas) ++ str "]" coq-8.4pl4/pretyping/vnorm.mli0000644000175000017500000000121712326224777015521 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> types -> constr coq-8.4pl4/pretyping/termops.mli0000644000175000017500000002627712326224777016066 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Univ.universe_level val new_univ : unit -> Univ.universe val new_sort_in_family : sorts_family -> sorts val new_Type : unit -> types val new_Type_sort : unit -> sorts val refresh_universes : types -> types val refresh_universes_strict : types -> types (** printers *) val print_sort : sorts -> std_ppcmds val pr_sort_family : sorts_family -> std_ppcmds (** debug printer: do not use to display terms to the casual user... *) val set_print_constr : (env -> constr -> std_ppcmds) -> unit val print_constr : constr -> std_ppcmds val print_constr_env : env -> constr -> std_ppcmds val print_named_context : env -> std_ppcmds val pr_rel_decl : env -> rel_declaration -> std_ppcmds val print_rel_context : env -> std_ppcmds val print_env : env -> std_ppcmds (** about contexts *) val push_rel_assum : name * types -> env -> env val push_rels_assum : (name * types) list -> env -> env val push_named_rec_types : name array * types array * 'a -> env -> env val lookup_rel_id : identifier -> rel_context -> int * constr option * types (** builds argument lists matching a block of binders or a context *) val rel_vect : int -> int -> constr array val rel_list : int -> int -> constr list val extended_rel_list : int -> rel_context -> constr list val extended_rel_vect : int -> rel_context -> constr array (** iterators/destructors on terms *) val mkProd_or_LetIn : rel_declaration -> types -> types val mkProd_wo_LetIn : rel_declaration -> types -> types val it_mkProd : types -> (name * types) list -> types val it_mkLambda : constr -> (name * types) list -> constr val it_mkProd_or_LetIn : types -> rel_context -> types val it_mkProd_wo_LetIn : types -> rel_context -> types val it_mkLambda_or_LetIn : constr -> rel_context -> constr val it_mkNamedProd_or_LetIn : types -> named_context -> types val it_mkNamedProd_wo_LetIn : types -> named_context -> types val it_mkNamedLambda_or_LetIn : constr -> named_context -> constr val it_named_context_quantifier : (named_declaration -> 'a -> 'a) -> init:'a -> named_context -> 'a (** {6 Generic iterators on constr} *) val map_constr_with_named_binders : (name -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr val map_constr_with_binders_left_to_right : (rel_declaration -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr val map_constr_with_full_binders : (rel_declaration -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr (** [fold_constr_with_binders g f n acc c] folds [f n] on the immediate subterms of [c] starting from [acc] and proceeding from left to right according to the usual representation of the constructions as [fold_constr] but it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive *) val fold_constr_with_binders : ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b val iter_constr_with_full_binders : (rel_declaration -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit (**********************************************************************) val strip_head_cast : constr -> constr val drop_extra_implicit_args : constr -> constr (** occur checks *) exception Occur val occur_meta : types -> bool val occur_existential : types -> bool val occur_meta_or_existential : types -> bool val occur_const : constant -> types -> bool val occur_evar : existential_key -> types -> bool val occur_var : env -> identifier -> types -> bool val occur_var_in_decl : env -> identifier -> 'a * types option * types -> bool val free_rels : constr -> Intset.t val dependent : constr -> constr -> bool val dependent_no_evar : constr -> constr -> bool val count_occurrences : constr -> constr -> int val collect_metas : constr -> int list val collect_vars : constr -> Idset.t (** for visible vars only *) val occur_term : constr -> constr -> bool (** Synonymous of dependent Substitution of metavariables *) type meta_value_map = (metavariable * constr) list val subst_meta : meta_value_map -> constr -> constr (** Type assignment for metavariables *) type meta_type_map = (metavariable * types) list (** [pop c] lifts by -1 the positive indexes in [c] *) val pop : constr -> constr (** {6 ... } *) (** Substitution of an arbitrary large term. Uses equality modulo reduction of let *) (** [subst_term_gen eq d c] replaces [Rel 1] by [d] in [c] using [eq] as equality *) val subst_term_gen : (constr -> constr -> bool) -> constr -> constr -> constr (** [replace_term_gen eq d e c] replaces [d] by [e] in [c] using [eq] as equality *) val replace_term_gen : (constr -> constr -> bool) -> constr -> constr -> constr -> constr (** [subst_term d c] replaces [Rel 1] by [d] in [c] *) val subst_term : constr -> constr -> constr (** [replace_term d e c] replaces [d] by [e] in [c] *) val replace_term : constr -> constr -> constr -> constr (** In occurrences sets, false = everywhere except and true = nowhere except *) type occurrences = bool * int list val all_occurrences : occurrences val no_occurrences_in_set : occurrences (** [subst_closed_term_occ_gen occl n c d] replaces occurrences of closed [c] at positions [occl], counting from [n], by [Rel 1] in [d] *) val subst_closed_term_occ_gen : occurrences -> int -> constr -> types -> int * types (** [subst_closed_term_occ_modulo] looks for subterm modulo a testing function returning a substitution of type ['a] (or failing with NotUnifiable); a function for merging substitution (possibly failing with NotUnifiable) and an initial substitution are required too *) type hyp_location_flag = (** To distinguish body and type of local defs *) | InHyp | InHypTypeOnly | InHypValueOnly type 'a testing_function = { match_fun : constr -> 'a; merge_fun : 'a -> 'a -> 'a; mutable testing_state : 'a; mutable last_found : ((identifier * hyp_location_flag) option * int * constr) option } val make_eq_test : constr -> unit testing_function exception NotUnifiable val subst_closed_term_occ_modulo : occurrences -> 'a testing_function -> (identifier * hyp_location_flag) option -> constr -> types (** [subst_closed_term_occ occl c d] replaces occurrences of closed [c] at positions [occl] by [Rel 1] in [d] (see also Note OCC) *) val subst_closed_term_occ : occurrences -> constr -> constr -> constr (** [subst_closed_term_occ_decl occl c decl] replaces occurrences of closed [c] at positions [occl] by [Rel 1] in [decl] *) val subst_closed_term_occ_decl : occurrences * hyp_location_flag -> constr -> named_declaration -> named_declaration val subst_closed_term_occ_decl_modulo : occurrences * hyp_location_flag -> 'a testing_function -> named_declaration -> named_declaration val error_invalid_occurrence : int list -> 'a (** Alternative term equalities *) val base_sort_cmp : Reduction.conv_pb -> sorts -> sorts -> bool val compare_constr_univ : (Reduction.conv_pb -> constr -> constr -> bool) -> Reduction.conv_pb -> constr -> constr -> bool val constr_cmp : Reduction.conv_pb -> constr -> constr -> bool val eq_constr : constr -> constr -> bool val eta_reduce_head : constr -> constr val eta_eq_constr : constr -> constr -> bool exception CannotFilter (** Lightweight first-order filtering procedure. Unification variables ar represented by (untyped) Evars. [filtering c1 c2] returns the substitution n'th evar -> (context,term), or raises [CannotFilter]. Warning: Outer-kernel sort subtyping are taken into account: c1 has to be smaller than c2 wrt. sorts. *) type subst = (rel_context*constr) Intmap.t val filtering : rel_context -> Reduction.conv_pb -> constr -> constr -> subst val decompose_prod_letin : constr -> int * rel_context * constr val align_prod_letin : constr -> constr -> rel_context * constr (** Get the last arg of a constr intended to be an application *) val last_arg : constr -> constr (** Force the decomposition of a term as an applicative one *) val decompose_app_vect : constr -> constr * constr array val adjust_app_list_size : constr -> constr list -> constr -> constr list -> (constr * constr list * constr * constr list) val adjust_app_array_size : constr -> constr array -> constr -> constr array -> (constr * constr array * constr * constr array) (** name contexts *) type names_context = name list val add_name : name -> names_context -> names_context val lookup_name_of_rel : int -> names_context -> name val lookup_rel_of_name : identifier -> names_context -> int val empty_names_context : names_context val ids_of_rel_context : rel_context -> identifier list val ids_of_named_context : named_context -> identifier list val ids_of_context : env -> identifier list val names_of_rel_context : env -> names_context val context_chop : int -> rel_context -> rel_context * rel_context val env_rel_context_chop : int -> env -> env * rel_context (** Set of local names *) val vars_of_env: env -> Idset.t val add_vname : Idset.t -> name -> Idset.t (** other signature iterators *) val process_rel_context : (rel_declaration -> env -> env) -> env -> env val assums_of_rel_context : rel_context -> (name * constr) list val lift_rel_context : int -> rel_context -> rel_context val substl_rel_context : constr list -> rel_context -> rel_context val smash_rel_context : rel_context -> rel_context (** expand lets in context *) val adjust_subst_to_rel_context : rel_context -> constr list -> constr list val map_rel_context_in_env : (env -> constr -> constr) -> env -> rel_context -> rel_context val map_rel_context_with_binders : (int -> constr -> constr) -> rel_context -> rel_context val fold_named_context_both_sides : ('a -> named_declaration -> named_declaration list -> 'a) -> named_context -> init:'a -> 'a val mem_named_context : identifier -> named_context -> bool val clear_named_body : identifier -> env -> env val global_vars : env -> constr -> identifier list val global_vars_set_of_decl : env -> named_declaration -> Idset.t (** Gives an ordered list of hypotheses, closed by dependencies, containing a given set *) val dependency_closure : env -> named_context -> Idset.t -> identifier list (** Test if an identifier is the basename of a global reference *) val is_section_variable : identifier -> bool val isGlobalRef : constr -> bool val has_polymorphic_type : constant -> bool (** Combinators on judgments *) val on_judgment : (types -> types) -> unsafe_judgment -> unsafe_judgment val on_judgment_value : (types -> types) -> unsafe_judgment -> unsafe_judgment val on_judgment_type : (types -> types) -> unsafe_judgment -> unsafe_judgment (** {6 Functions to deal with impossible cases } *) val set_impossible_default_clause : constr * types -> unit val coq_unit_judge : unit -> unsafe_judgment coq-8.4pl4/pretyping/unification.mli0000644000175000017500000000560712326224777016677 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* evar_map -> conv_pb -> ?flags:unify_flags -> constr -> constr -> evar_map (** [w_unify_to_subterm env (c,t) m] performs unification of [c] with a subterm of [t]. Constraints are added to [m] and the matched subterm of [t] is also returned. *) val w_unify_to_subterm : env -> evar_map -> ?flags:unify_flags -> constr * constr -> evar_map * constr val w_unify_to_subterm_all : env -> evar_map -> ?flags:unify_flags -> constr * constr -> (evar_map * constr) list val w_unify_meta_types : env -> ?flags:unify_flags -> evar_map -> evar_map (** [w_coerce_to_type env evd c ctyp typ] tries to coerce [c] of type [ctyp] so that its gets type [typ]; [typ] may contain metavariables *) val w_coerce_to_type : env -> evar_map -> constr -> types -> types -> evar_map * constr (*i This should be in another module i*) (** [abstract_list_all env evd t c l] abstracts the terms in l over c to get a term of type t (exported for inv.ml) *) val abstract_list_all : env -> evar_map -> constr -> constr -> constr list -> constr (* For tracing *) val w_merge : env -> bool -> unify_flags -> evar_map * (metavariable * constr * (instance_constraint * instance_typing_status)) list * (env * types pexistential * types) list -> evar_map val unify_0 : Environ.env -> Evd.evar_map -> Evd.conv_pb -> unify_flags -> Term.types -> Term.types -> Evd.evar_map * Evd.metabinding list * (Environ.env * Term.types Term.pexistential * Term.constr) list coq-8.4pl4/pretyping/typeclasses_errors.mli0000644000175000017500000000272412326224777020317 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> 'a val unbound_method : env -> global_reference -> identifier located -> 'a val no_instance : env -> identifier located -> constr list -> 'a val unsatisfiable_constraints : env -> evar_map -> evar option -> 'a val mismatched_ctx_inst : env -> contexts -> constr_expr list -> rel_context -> 'a val unsatisfiable_exception : exn -> bool coq-8.4pl4/pretyping/unification.ml0000644000175000017500000013561512326224777016531 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* raise Occur | Evar (ev,args) -> (match evar_body (Evd.find evd ev) with | Evar_defined c -> occrec c; Array.iter occrec args | Evar_empty -> raise Occur) | Sort s when is_sort_variable evd s -> raise Occur | _ -> iter_constr occrec c in try occrec c; false with Occur | Not_found -> true let occur_meta_evd sigma mv c = let rec occrec c = (* Note: evars are not instantiated by terms with metas *) let c = whd_evar sigma (whd_meta sigma c) in match kind_of_term c with | Meta mv' when mv = mv' -> raise Occur | _ -> iter_constr occrec c in try occrec c; false with Occur -> true (* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms, gives [x1:A1]..[xn:An]c' such that c converts to ([x1:A1]..[xn:An]c' l) *) let abstract_scheme env c l lname_typ = List.fold_left2 (fun t (locc,a) (na,_,ta) -> let na = match kind_of_term a with Var id -> Name id | _ -> na in (* [occur_meta ta] test removed for support of eelim/ecase but consequences are unclear... if occur_meta ta then error "cannot find a type for the generalisation" else *) if occur_meta a then mkLambda_name env (na,ta,t) else mkLambda_name env (na,ta,subst_closed_term_occ locc a t)) c (List.rev l) lname_typ let abstract_list_all env evd typ c l = let ctxt,_ = splay_prod_n env evd (List.length l) typ in let l_with_all_occs = List.map (function a -> (all_occurrences,a)) l in let p = abstract_scheme env c l_with_all_occs ctxt in try if is_conv_leq env evd (Typing.type_of env evd p) typ then p else error "abstract_list_all" with UserError _ | Type_errors.TypeError _ -> error_cannot_find_well_typed_abstraction env evd p l let set_occurrences_of_last_arg args = Some all_occurrences :: List.tl (array_map_to_list (fun _ -> None) args) let abstract_list_all_with_dependencies env evd typ c l = let evd,ev = new_evar evd env typ in let evd,ev' = evar_absorb_arguments env evd (destEvar ev) l in let argoccs = set_occurrences_of_last_arg (snd ev') in let evd,b = Evarconv.second_order_matching empty_transparent_state env evd ev' argoccs c in if b then nf_evar evd (existential_value evd (destEvar ev)) else error "Cannot find a well-typed abstraction." (**) (* A refinement of [conv_pb]: the integers tells how many arguments were applied in the context of the conversion problem; if the number is non zero, steps of eta-expansion will be allowed *) let opp_status = function | IsSuperType -> IsSubType | IsSubType -> IsSuperType | Conv -> Conv let add_type_status (x,y) = ((x,TypeNotProcessed),(y,TypeNotProcessed)) let extract_instance_status = function | CUMUL -> add_type_status (IsSubType, IsSuperType) | CONV -> add_type_status (Conv, Conv) let rec assoc_pair x = function [] -> raise Not_found | (a,b,_)::l -> if compare a x = 0 then b else assoc_pair x l let rec subst_meta_instances bl c = match kind_of_term c with | Meta i -> (try assoc_pair i bl with Not_found -> c) | _ -> map_constr (subst_meta_instances bl) c let pose_all_metas_as_evars env evd t = let evdref = ref evd in let rec aux t = match kind_of_term t with | Meta mv -> (match Evd.meta_opt_fvalue !evdref mv with | Some ({rebus=c},_) -> c | None -> let {rebus=ty;freemetas=mvs} = Evd.meta_ftype evd mv in let ty = if mvs = Evd.Metaset.empty then ty else aux ty in let ev = Evarutil.e_new_evar evdref env ~src:(dummy_loc,GoalEvar) ty in evdref := meta_assign mv (ev,(Conv,TypeNotProcessed)) !evdref; ev) | _ -> map_constr aux t in let c = aux t in (* side-effect *) (!evdref, c) let solve_pattern_eqn_array (env,nb) f l c (sigma,metasubst,evarsubst) = match kind_of_term f with | Meta k -> let sigma,c = pose_all_metas_as_evars env sigma c in let c = solve_pattern_eqn env l c in let pb = (Conv,TypeNotProcessed) in if noccur_between 1 nb c then sigma,(k,lift (-nb) c,pb)::metasubst,evarsubst else error_cannot_unify_local env sigma (applist (f, l),c,c) | Evar ev -> let sigma,c = pose_all_metas_as_evars env sigma c in sigma,metasubst,(env,ev,solve_pattern_eqn env l c)::evarsubst | _ -> assert false let push d (env,n) = (push_rel_assum d env,n+1) (*******************************) (* Unification à l'ordre 0 de m et n: [unify_0 env sigma cv_pb m n] renvoie deux listes: metasubst:(int*constr)list rÃĐcolte les instances des (Meta k) evarsubst:(constr*constr)list rÃĐcolte les instances des (Const "?k") Attention : pas d'unification entre les diffÃĐrences instances d'une mÊme meta ou evar, il peut rester des doublons *) (* Unification order: *) (* Left to right: unifies first argument and then the other arguments *) (*let unify_l2r x = List.rev x (* Right to left: unifies last argument and then the other arguments *) let unify_r2l x = x let sort_eqns = unify_r2l *) (* Option introduced and activated in Coq 8.3 *) let global_evars_pattern_unification_flag = ref true open Goptions let _ = declare_bool_option { optsync = true; optdepr = false; optname = "pattern-unification for existential variables in tactics"; optkey = ["Tactic";"Evars";"Pattern";"Unification"]; optread = (fun () -> !global_evars_pattern_unification_flag); optwrite = (:=) global_evars_pattern_unification_flag } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "pattern-unification for existential variables in tactics"; optkey = ["Tactic";"Pattern";"Unification"]; optread = (fun () -> !global_evars_pattern_unification_flag); optwrite = (:=) global_evars_pattern_unification_flag } type unify_flags = { modulo_conv_on_closed_terms : Names.transparent_state option; (* What this flag controls was activated with all constants transparent, *) (* even for auto, since Coq V5.10 *) use_metas_eagerly_in_conv_on_closed_terms : bool; (* This refinement of the conversion on closed terms is activable *) (* (and activated for apply, rewrite but not auto since Feb 2008 for 8.2) *) modulo_delta : Names.transparent_state; (* This controls which constants are unfoldable; this is on for apply *) (* (but not simple apply) since Feb 2008 for 8.2 *) modulo_delta_types : Names.transparent_state; modulo_delta_in_merge : Names.transparent_state option; (* This controls whether unfoldability is different when trying to unify *) (* several instances of the same metavariable *) (* Typical situation is when we give a pattern to be matched *) (* syntactically against a subterm but we want the metas of the *) (* pattern to be modulo convertibility *) check_applied_meta_types : bool; (* This controls whether meta's applied to arguments have their *) (* type unified with the type of their instance *) resolve_evars : bool; (* This says if type classes instances resolution must be used to infer *) (* the remaining evars *) use_pattern_unification : bool; (* This says if type classes instances resolution must be used to infer *) (* the remaining evars *) use_meta_bound_pattern_unification : bool; (* This solves pattern "?n x1 ... xn = t" when the xi are distinct rels *) (* This allows for instance to unify "forall x:A, B(x)" with "A' -> B'" *) (* This was on for all tactics, including auto, since Sep 2006 for 8.1 *) frozen_evars : ExistentialSet.t; (* Evars of this set are considered axioms and never instantiated *) (* Useful e.g. for autorewrite *) restrict_conv_on_strict_subterms : bool; (* No conversion at the root of the term; potentially useful for rewrite *) modulo_betaiota : bool; (* Support betaiota in the reduction *) (* Note that zeta is always used *) modulo_eta : bool; (* Support eta in the reduction *) allow_K_in_toplevel_higher_order_unification : bool (* This is used only in second/higher order unification when looking for *) (* subterms (rewrite and elim) *) } (* Default flag for unifying a type against a type (e.g. apply) *) (* We set all conversion flags (no flag should be modified anymore) *) let default_unify_flags = { modulo_conv_on_closed_terms = Some full_transparent_state; use_metas_eagerly_in_conv_on_closed_terms = true; modulo_delta = full_transparent_state; modulo_delta_types = full_transparent_state; modulo_delta_in_merge = None; check_applied_meta_types = true; resolve_evars = false; use_pattern_unification = true; use_meta_bound_pattern_unification = true; frozen_evars = ExistentialSet.empty; restrict_conv_on_strict_subterms = false; modulo_betaiota = true; modulo_eta = true; allow_K_in_toplevel_higher_order_unification = false (* in fact useless when not used in w_unify_to_subterm_list *) } let set_merge_flags flags = match flags.modulo_delta_in_merge with | None -> flags | Some ts -> { flags with modulo_delta = ts; modulo_conv_on_closed_terms = Some ts } (* Default flag for the "simple apply" version of unification of a *) (* type against a type (e.g. apply) *) (* We set only the flags available at the time the new "apply" extends *) (* out of "simple apply" *) let default_no_delta_unify_flags = { default_unify_flags with modulo_delta = empty_transparent_state; check_applied_meta_types = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; modulo_betaiota = false; } (* Default flags for looking for subterms in elimination tactics *) (* Not used in practice at the current date, to the exception of *) (* allow_K) because only closed terms are involved in *) (* induction/destruct/case/elim and w_unify_to_subterm_list does not *) (* call w_unify for induction/destruct/case/elim (13/6/2011) *) let elim_flags = { default_unify_flags with restrict_conv_on_strict_subterms = false; (* ? *) modulo_betaiota = false; allow_K_in_toplevel_higher_order_unification = true } let elim_no_delta_flags = { elim_flags with modulo_delta = empty_transparent_state; check_applied_meta_types = false; use_pattern_unification = false; } let set_no_head_reduction flags = { flags with restrict_conv_on_strict_subterms = true } let use_evars_pattern_unification flags = !global_evars_pattern_unification_flag && flags.use_pattern_unification && Flags.version_strictly_greater Flags.V8_2 let use_metas_pattern_unification flags nb l = !global_evars_pattern_unification_flag && flags.use_pattern_unification || (Flags.version_less_or_equal Flags.V8_3 || flags.use_meta_bound_pattern_unification) && array_for_all (fun c -> isRel c && destRel c <= nb) l let expand_key env = function | Some (ConstKey cst) -> constant_opt_value env cst | Some (VarKey id) -> (try named_body id env with Not_found -> None) | Some (RelKey _) -> None | None -> None let subterm_restriction is_subterm flags = not is_subterm && flags.restrict_conv_on_strict_subterms let key_of b flags f = if subterm_restriction b flags then None else match kind_of_term f with | Const cst when is_transparent (ConstKey cst) && Cpred.mem cst (snd flags.modulo_delta) -> Some (ConstKey cst) | Var id when is_transparent (VarKey id) && Idpred.mem id (fst flags.modulo_delta) -> Some (VarKey id) | _ -> None let oracle_order env cf1 cf2 = match cf1 with | None -> (match cf2 with | None -> None | Some k2 -> Some false) | Some k1 -> match cf2 with | None -> Some true | Some k2 -> Some (Conv_oracle.oracle_order false k1 k2) let do_reduce ts (env, nb) sigma c = let (t, stack') = whd_betaiota_deltazeta_for_iota_state ts env sigma (c, empty_stack) in let l = list_of_stack stack' in applist (t, l) let use_full_betaiota flags = flags.modulo_betaiota && Flags.version_strictly_greater Flags.V8_3 let isAllowedEvar flags c = match kind_of_term c with | Evar (evk,_) -> not (ExistentialSet.mem evk flags.frozen_evars) | _ -> false let check_compatibility env (sigma,metasubst,evarsubst) tyM tyN = match subst_defined_metas metasubst tyM with | None -> () | Some m -> match subst_defined_metas metasubst tyN with | None -> () | Some n -> if not (is_trans_fconv CONV full_transparent_state env sigma m n) && is_ground_term sigma m && is_ground_term sigma n then error_cannot_unify env sigma (m,n) let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flags m n = let rec unirec_rec (curenv,nb as curenvnb) pb b wt ((sigma,metasubst,evarsubst) as substn) curm curn = let cM = Evarutil.whd_head_evar sigma curm and cN = Evarutil.whd_head_evar sigma curn in match (kind_of_term cM,kind_of_term cN) with | Meta k1, Meta k2 -> if k1 = k2 then substn else let stM,stN = extract_instance_status pb in if wt && flags.check_applied_meta_types then (let tyM = Typing.meta_type sigma k1 in let tyN = Typing.meta_type sigma k2 in check_compatibility curenv substn tyM tyN); if k2 < k1 then sigma,(k1,cN,stN)::metasubst,evarsubst else sigma,(k2,cM,stM)::metasubst,evarsubst | Meta k, _ when not (dependent cM cN) (* helps early trying alternatives *) -> if wt && flags.check_applied_meta_types then (try let tyM = Typing.meta_type sigma k in let tyN = get_type_of curenv sigma cN in check_compatibility curenv substn tyM tyN with Anomaly _ (* Hack *) -> (* Renounce, maybe metas/evars prevents typing *) ()); (* Here we check that [cN] does not contain any local variables *) if nb = 0 then sigma,(k,cN,snd (extract_instance_status pb))::metasubst,evarsubst else if noccur_between 1 nb cN then (sigma, (k,lift (-nb) cN,snd (extract_instance_status pb))::metasubst, evarsubst) else error_cannot_unify_local curenv sigma (m,n,cN) | _, Meta k when not (dependent cN cM) (* helps early trying alternatives *) -> if wt && flags.check_applied_meta_types then (try let tyM = get_type_of curenv sigma cM in let tyN = Typing.meta_type sigma k in check_compatibility curenv substn tyM tyN with Anomaly _ (* Hack *) -> (* Renounce, maybe metas/evars prevents typing *) ()); (* Here we check that [cM] does not contain any local variables *) if nb = 0 then (sigma,(k,cM,fst (extract_instance_status pb))::metasubst,evarsubst) else if noccur_between 1 nb cM then (sigma,(k,lift (-nb) cM,fst (extract_instance_status pb))::metasubst, evarsubst) else error_cannot_unify_local curenv sigma (m,n,cM) | Evar (evk,_ as ev), _ when not (ExistentialSet.mem evk flags.frozen_evars) -> let cmvars = free_rels cM and cnvars = free_rels cN in if Intset.subset cnvars cmvars then sigma,metasubst,((curenv,ev,cN)::evarsubst) else error_cannot_unify_local curenv sigma (m,n,cN) | _, Evar (evk,_ as ev) when not (ExistentialSet.mem evk flags.frozen_evars) -> let cmvars = free_rels cM and cnvars = free_rels cN in if Intset.subset cmvars cnvars then sigma,metasubst,((curenv,ev,cM)::evarsubst) else error_cannot_unify_local curenv sigma (m,n,cN) | Sort s1, Sort s2 -> (try let sigma' = if cv_pb = CUMUL then Evd.set_leq_sort sigma s1 s2 else Evd.set_eq_sort sigma s1 s2 in (sigma', metasubst, evarsubst) with e when Errors.noncritical e -> error_cannot_unify curenv sigma (m,n)) | Lambda (na,t1,c1), Lambda (_,t2,c2) -> unirec_rec (push (na,t1) curenvnb) CONV true wt (unirec_rec curenvnb CONV true false substn t1 t2) c1 c2 | Prod (na,t1,c1), Prod (_,t2,c2) -> unirec_rec (push (na,t1) curenvnb) pb true false (unirec_rec curenvnb CONV true false substn t1 t2) c1 c2 | LetIn (_,a,_,c), _ -> unirec_rec curenvnb pb b wt substn (subst1 a c) cN | _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb b wt substn cM (subst1 a c) (* eta-expansion *) | Lambda (na,t1,c1), _ when flags.modulo_eta -> unirec_rec (push (na,t1) curenvnb) CONV true wt substn c1 (mkApp (lift 1 cN,[|mkRel 1|])) | _, Lambda (na,t2,c2) when flags.modulo_eta -> unirec_rec (push (na,t2) curenvnb) CONV true wt substn (mkApp (lift 1 cM,[|mkRel 1|])) c2 | Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) -> (try array_fold_left2 (unirec_rec curenvnb CONV true wt) (unirec_rec curenvnb CONV true false (unirec_rec curenvnb CONV true false substn p1 p2) c1 c2) cl1 cl2 with ex when precatchable_exception ex -> reduce curenvnb pb b wt substn cM cN) | App (f1,l1), _ when (isMeta f1 && use_metas_pattern_unification flags nb l1 || use_evars_pattern_unification flags && isAllowedEvar flags f1) -> (match is_unification_pattern curenvnb sigma f1 (Array.to_list l1) cN with | None -> (match kind_of_term cN with | App (f2,l2) -> unify_app curenvnb pb b substn cM f1 l1 cN f2 l2 | _ -> unify_not_same_head curenvnb pb b wt substn cM cN) | Some l -> solve_pattern_eqn_array curenvnb f1 l cN substn) | _, App (f2,l2) when (isMeta f2 && use_metas_pattern_unification flags nb l2 || use_evars_pattern_unification flags && isAllowedEvar flags f2) -> (match is_unification_pattern curenvnb sigma f2 (Array.to_list l2) cM with | None -> (match kind_of_term cM with | App (f1,l1) -> unify_app curenvnb pb b substn cM f1 l1 cN f2 l2 | _ -> unify_not_same_head curenvnb pb b wt substn cM cN) | Some l -> solve_pattern_eqn_array curenvnb f2 l cM substn) | App (f1,l1), App (f2,l2) -> unify_app curenvnb pb b substn cM f1 l1 cN f2 l2 | _ -> unify_not_same_head curenvnb pb b wt substn cM cN and unify_app curenvnb pb b substn cM f1 l1 cN f2 l2 = try let (f1,l1,f2,l2) = adjust_app_array_size f1 l1 f2 l2 in array_fold_left2 (unirec_rec curenvnb CONV true false) (unirec_rec curenvnb CONV true true substn f1 f2) l1 l2 with ex when precatchable_exception ex -> try reduce curenvnb pb b false substn cM cN with ex when precatchable_exception ex -> try expand curenvnb pb b false substn cM f1 l1 cN f2 l2 with ex when precatchable_exception ex -> canonical_projections curenvnb pb b cM cN substn and unify_not_same_head curenvnb pb b wt substn cM cN = try canonical_projections curenvnb pb b cM cN substn with ex when precatchable_exception ex -> if constr_cmp cv_pb cM cN then substn else try reduce curenvnb pb b wt substn cM cN with ex when precatchable_exception ex -> let (f1,l1) = match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in let (f2,l2) = match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in expand curenvnb pb b wt substn cM f1 l1 cN f2 l2 and reduce curenvnb pb b wt (sigma, metas, evars as substn) cM cN = if use_full_betaiota flags && not (subterm_restriction b flags) then let cM' = do_reduce flags.modulo_delta curenvnb sigma cM in if not (eq_constr cM cM') then unirec_rec curenvnb pb b wt substn cM' cN else let cN' = do_reduce flags.modulo_delta curenvnb sigma cN in if not (eq_constr cN cN') then unirec_rec curenvnb pb b wt substn cM cN' else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) and expand (curenv,_ as curenvnb) pb b wt (sigma,metasubst,_ as substn) cM f1 l1 cN f2 l2 = if (* Try full conversion on meta-free terms. *) (* Back to 1995 (later on called trivial_unify in 2002), the heuristic was to apply conversion on meta-free (but not evar-free!) terms in all cases (i.e. for apply but also for auto and rewrite, even though auto and rewrite did not use modulo conversion in the rest of the unification algorithm). By compatibility we need to support this separately from the main unification algorithm *) (* The exploitation of known metas has been added in May 2007 (it is used by apply and rewrite); it might now be redundant with the support for delta-expansion (which is used essentially for apply)... *) not (subterm_restriction b flags) && match flags.modulo_conv_on_closed_terms with | None -> false | Some convflags -> let subst = if flags.use_metas_eagerly_in_conv_on_closed_terms then metasubst else ms in match subst_defined_metas subst cM with | None -> (* some undefined Metas in cM *) false | Some m1 -> match subst_defined_metas subst cN with | None -> (* some undefined Metas in cN *) false | Some n1 -> (* No subterm restriction there, too much incompatibilities *) if is_trans_fconv pb convflags env sigma m1 n1 then true else if is_ground_term sigma m1 && is_ground_term sigma n1 then error_cannot_unify curenv sigma (cM,cN) else false then substn else let cf1 = key_of b flags f1 and cf2 = key_of b flags f2 in match oracle_order curenv cf1 cf2 with | None -> error_cannot_unify curenv sigma (cM,cN) | Some true -> (match expand_key curenv cf1 with | Some c -> unirec_rec curenvnb pb b wt substn (whd_betaiotazeta sigma (mkApp(c,l1))) cN | None -> (match expand_key curenv cf2 with | Some c -> unirec_rec curenvnb pb b wt substn cM (whd_betaiotazeta sigma (mkApp(c,l2))) | None -> error_cannot_unify curenv sigma (cM,cN))) | Some false -> (match expand_key curenv cf2 with | Some c -> unirec_rec curenvnb pb b wt substn cM (whd_betaiotazeta sigma (mkApp(c,l2))) | None -> (match expand_key curenv cf1 with | Some c -> unirec_rec curenvnb pb b wt substn (whd_betaiotazeta sigma (mkApp(c,l1))) cN | None -> error_cannot_unify curenv sigma (cM,cN))) and canonical_projections curenvnb pb b cM cN (sigma,_,_ as substn) = let f1 () = if isApp cM then let f1l1 = decompose_app cM in if is_open_canonical_projection env sigma f1l1 then let f2l2 = decompose_app cN in solve_canonical_projection curenvnb pb b cM f1l1 cN f2l2 substn else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) in if flags.modulo_conv_on_closed_terms = None || subterm_restriction b flags then error_cannot_unify (fst curenvnb) sigma (cM,cN) else try f1 () with e when precatchable_exception e -> if isApp cN then let f2l2 = decompose_app cN in if is_open_canonical_projection env sigma f2l2 then let f1l1 = decompose_app cM in solve_canonical_projection curenvnb pb b cN f2l2 cM f1l1 substn else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) and solve_canonical_projection curenvnb pb b cM f1l1 cN f2l2 (sigma,ms,es) = let (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = try Evarconv.check_conv_record f1l1 f2l2 with Not_found -> error_cannot_unify (fst curenvnb) sigma (cM,cN) in let (evd,ks,_) = List.fold_left (fun (evd,ks,m) b -> if m=n then (evd,t2::ks, m-1) else let mv = new_meta () in let evd' = meta_declare mv (substl ks b) evd in (evd', mkMeta mv :: ks, m - 1)) (sigma,[],List.length bs - 1) bs in let unilist2 f substn l l' = try List.fold_left2 f substn l l' with Invalid_argument "List.fold_left2" -> error_cannot_unify (fst curenvnb) sigma (cM,cN) in let substn = unilist2 (fun s u1 u -> unirec_rec curenvnb pb b false s u1 (substl ks u)) (evd,ms,es) us2 us in let substn = unilist2 (fun s u1 u -> unirec_rec curenvnb pb b false s u1 (substl ks u)) substn params1 params in let substn = unilist2 (unirec_rec curenvnb pb b false) substn ts ts1 in unirec_rec curenvnb pb b false substn c1 (applist (c,(List.rev ks))) in let evd = sigma in if (if occur_meta_or_undefined_evar evd m || occur_meta_or_undefined_evar evd n || subterm_restriction conv_at_top flags then false else if (match flags.modulo_conv_on_closed_terms with | Some convflags -> is_trans_fconv cv_pb convflags env sigma m n | _ -> constr_cmp cv_pb m n) then true else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with | Some (cv_id, cv_k), (dl_id, dl_k) -> Idpred.subset dl_id cv_id && Cpred.subset dl_k cv_k | None,(dl_id, dl_k) -> Idpred.is_empty dl_id && Cpred.is_empty dl_k) then error_cannot_unify env sigma (m, n) else false) then subst else unirec_rec (env,0) cv_pb conv_at_top false subst m n let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env let left = true let right = false let rec unify_with_eta keptside flags env sigma c1 c2 = (* Question: try whd_betadeltaiota on ci if not two lambdas? *) match kind_of_term c1, kind_of_term c2 with | (Lambda (na,t1,c1'), Lambda (_,t2,c2')) -> let env' = push_rel_assum (na,t1) env in let sigma,metas,evars = unify_0 env sigma CONV flags t1 t2 in let side,(sigma,metas',evars') = unify_with_eta keptside flags env' sigma c1' c2' in (side,(sigma,metas@metas',evars@evars')) | (Lambda (na,t,c1'),_)-> let env' = push_rel_assum (na,t) env in let side = left in (* expansion on the right: we keep the left side *) unify_with_eta side flags env' sigma c1' (mkApp (lift 1 c2,[|mkRel 1|])) | (_,Lambda (na,t,c2')) -> let env' = push_rel_assum (na,t) env in let side = right in (* expansion on the left: we keep the right side *) unify_with_eta side flags env' sigma (mkApp (lift 1 c1,[|mkRel 1|])) c2' | _ -> (keptside,unify_0 env sigma CONV flags c1 c2) (* We solved problems [?n =_pb u] (i.e. [u =_(opp pb) ?n]) and [?n =_pb' u'], we now compute the problem on [u =? u'] and decide which of u or u' is kept Rem: the upper constraint is lost in case u <= ?n <= u' (and symmetrically in the case u' <= ?n <= u) *) let merge_instances env sigma flags st1 st2 c1 c2 = match (opp_status st1, st2) with | (Conv, Conv) -> let side = left (* arbitrary choice, but agrees with compatibility *) in let (side,res) = unify_with_eta side flags env sigma c1 c2 in (side,Conv,res) | ((IsSubType | Conv as oppst1), (IsSubType | Conv)) -> let res = unify_0 env sigma CUMUL flags c2 c1 in if oppst1=st2 then (* arbitrary choice *) (left, st1, res) else if st2=IsSubType then (left, st1, res) else (right, st2, res) | ((IsSuperType | Conv as oppst1), (IsSuperType | Conv)) -> let res = unify_0 env sigma CUMUL flags c1 c2 in if oppst1=st2 then (* arbitrary choice *) (left, st1, res) else if st2=IsSuperType then (left, st1, res) else (right, st2, res) | (IsSuperType,IsSubType) -> (try (left, IsSubType, unify_0 env sigma CUMUL flags c2 c1) with e when Errors.noncritical e -> (right, IsSubType, unify_0 env sigma CUMUL flags c1 c2)) | (IsSubType,IsSuperType) -> (try (left, IsSuperType, unify_0 env sigma CUMUL flags c1 c2) with e when Errors.noncritical e -> (right, IsSuperType, unify_0 env sigma CUMUL flags c2 c1)) (* Unification * * Procedure: * (1) The function [unify mc wc M N] produces two lists: * (a) a list of bindings Meta->RHS * (b) a list of bindings EVAR->RHS * * The Meta->RHS bindings cannot themselves contain * meta-vars, so they get applied eagerly to the other * bindings. This may or may not close off all RHSs of * the EVARs. For each EVAR whose RHS is closed off, * we can just apply it, and go on. For each which * is not closed off, we need to do a mimick step - * in general, we have something like: * * ?X == (c e1 e2 ... ei[Meta(k)] ... en) * * so we need to do a mimick step, converting ?X * into * * ?X -> (c ?z1 ... ?zn) * * of the proper types. Then, we can decompose the * equation into * * ?z1 --> e1 * ... * ?zi --> ei[Meta(k)] * ... * ?zn --> en * * and keep on going. Whenever we find that a R.H.S. * is closed, we can, as before, apply the constraint * directly. Whenever we find an equation of the form: * * ?z -> Meta(n) * * we can reverse the equation, put it into our metavar * substitution, and keep going. * * The most efficient mimick possible is, for each * Meta-var remaining in the term, to declare a * new EVAR of the same type. This is supposedly * determinable from the clausale form context - * we look up the metavar, take its type there, * and apply the metavar substitution to it, to * close it off. But this might not always work, * since other metavars might also need to be resolved. *) let applyHead env evd n c = let rec apprec n c cty evd = if n = 0 then (evd, c) else match kind_of_term (whd_betadeltaiota env evd cty) with | Prod (_,c1,c2) -> let (evd',evar) = Evarutil.new_evar evd env ~src:(dummy_loc,GoalEvar) c1 in apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd' | _ -> error "Apply_Head_Then" in apprec n c (Typing.type_of env evd c) evd let is_mimick_head ts f = match kind_of_term f with | Const c -> not (Closure.is_transparent_constant ts c) | Var id -> not (Closure.is_transparent_variable ts id) | (Rel _|Construct _|Ind _) -> true | _ -> false let try_to_coerce env evd c cty tycon = let j = make_judge c cty in let (evd',j') = inh_conv_coerce_rigid_to true dummy_loc env evd j tycon in let evd' = Evarconv.consider_remaining_unif_problems env evd' in let evd' = Evd.map_metas_fvalue (nf_evar evd') evd' in (evd',j'.uj_val) let w_coerce_to_type env evd c cty mvty = let evd,mvty = pose_all_metas_as_evars env evd mvty in let tycon = mk_tycon_type mvty in try try_to_coerce env evd c cty tycon with e when precatchable_exception e -> (* inh_conv_coerce_rigid_to should have reasoned modulo reduction but there are cases where it though it was not rigid (like in fst (nat,nat)) and stops while it could have seen that it is rigid *) let cty = Tacred.hnf_constr env evd cty in try_to_coerce env evd c cty tycon let w_coerce env evd mv c = let cty = get_type_of env evd c in let mvty = Typing.meta_type evd mv in w_coerce_to_type env evd c cty mvty let unify_to_type env sigma flags c status u = let c = refresh_universes c in let t = get_type_of env sigma c in let t = nf_betaiota sigma (nf_meta sigma t) in unify_0 env sigma CUMUL flags t u let unify_type env sigma flags mv status c = let mvty = Typing.meta_type sigma mv in let mvty = nf_meta sigma mvty in unify_to_type env sigma {flags with modulo_delta = flags.modulo_delta_types; modulo_conv_on_closed_terms = Some flags.modulo_delta_types; modulo_betaiota = true} c status mvty (* Move metas that may need coercion at the end of the list of instances *) let order_metas metas = let rec order latemetas = function | [] -> List.rev latemetas | (_,_,(status,to_type) as meta)::metas -> if to_type = CoerceToType then order (meta::latemetas) metas else meta :: order latemetas metas in order [] metas (* Solve an equation ?n[x1=u1..xn=un] = t where ?n is an evar *) let solve_simple_evar_eqn ts env evd ev rhs = let evd,b = solve_simple_eqn (Evarconv.evar_conv_x ts) env evd (None,ev,rhs) in if not b then error_cannot_unify env evd (mkEvar ev,rhs); Evarconv.consider_remaining_unif_problems env evd (* [w_merge env sigma b metas evars] merges common instances in metas or in evars, possibly generating new unification problems; if [b] is true, unification of types of metas is required *) let w_merge env with_types flags (evd,metas,evars) = let rec w_merge_rec evd metas evars eqns = (* Process evars *) match evars with | (curenv,(evk,_ as ev),rhs)::evars' -> if Evd.is_defined evd evk then let v = Evd.existential_value evd ev in let (evd,metas',evars'') = unify_0 curenv evd CONV (set_merge_flags flags) rhs v in w_merge_rec evd (metas'@metas) (evars''@evars') eqns else begin (* This can make rhs' ill-typed if metas are *) let rhs' = subst_meta_instances metas rhs in match kind_of_term rhs with | App (f,cl) when occur_meta rhs' -> if occur_evar evk rhs' then error_occur_check curenv evd evk rhs'; if is_mimick_head flags.modulo_delta f then let evd' = mimick_undefined_evar evd flags f (Array.length cl) evk in w_merge_rec evd' metas evars eqns else let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in w_merge_rec (solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs'') metas evars' eqns | _ -> let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in w_merge_rec (solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs'') metas evars' eqns end | [] -> (* Process metas *) match metas with | (mv,c,(status,to_type))::metas -> let ((evd,c),(metas'',evars'')),eqns = if with_types & to_type <> TypeProcessed then if to_type = CoerceToType then (* Some coercion may have to be inserted *) (w_coerce env evd mv c,([],[])),eqns else (* No coercion needed: delay the unification of types *) ((evd,c),([],[])),(mv,status,c)::eqns else ((evd,c),([],[])),eqns in if meta_defined evd mv then let {rebus=c'},(status',_) = meta_fvalue evd mv in let (take_left,st,(evd,metas',evars')) = merge_instances env evd flags status' status c' c in let evd' = if take_left then evd else meta_reassign mv (c,(st,TypeProcessed)) evd in w_merge_rec evd' (metas'@metas@metas'') (evars'@evars'') eqns else let evd' = if occur_meta_evd evd mv c then if isMetaOf mv (whd_betadeltaiota env evd c) then evd else error_cannot_unify env evd (mkMeta mv,c) else meta_assign mv (c,(status,TypeProcessed)) evd in w_merge_rec evd' (metas''@metas) evars'' eqns | [] -> (* Process type eqns *) let rec process_eqns failures = function | (mv,status,c)::eqns -> (match (try Inl (unify_type env evd flags mv status c) with e when Errors.noncritical e -> Inr e) with | Inr e -> process_eqns (((mv,status,c),e)::failures) eqns | Inl (evd,metas,evars) -> w_merge_rec evd metas evars (List.map fst failures @ eqns)) | [] -> (match failures with | [] -> evd | ((mv,status,c),e)::_ -> raise e) in process_eqns [] eqns and mimick_undefined_evar evd flags hdc nargs sp = let ev = Evd.find_undefined evd sp in let sp_env = Global.env_of_context ev.evar_hyps in let (evd', c) = applyHead sp_env evd nargs hdc in let (evd'',mc,ec) = unify_0 sp_env evd' CUMUL (set_merge_flags flags) (get_type_of sp_env evd' c) ev.evar_concl in let evd''' = w_merge_rec evd'' mc ec [] in if evd' == evd''' then Evd.define sp c evd''' else Evd.define sp (Evarutil.nf_evar evd''' c) evd''' in (* merge constraints *) w_merge_rec evd (order_metas metas) evars [] let w_unify_meta_types env ?(flags=default_unify_flags) evd = let metas,evd = retract_coercible_metas evd in w_merge env true flags (evd,metas,[]) (* [w_unify env evd M N] performs a unification of M and N, generating a bunch of unification constraints in the process. These constraints are processed, one-by-one - they may either generate new bindings, or, if there is already a binding, new unifications, which themselves generate new constraints. This continues until we get failure, or we run out of constraints. [clenv_typed_unify M N clenv] expects in addition that expected types of metavars are unifiable with the types of their instances *) let check_types env flags (sigma,_,_ as subst) m n = if isEvar_or_Meta (fst (whd_stack sigma m)) then unify_0_with_initial_metas subst true env CUMUL flags (get_type_of env sigma n) (get_type_of env sigma m) else if isEvar_or_Meta (fst (whd_stack sigma n)) then unify_0_with_initial_metas subst true env CUMUL flags (get_type_of env sigma m) (get_type_of env sigma n) else subst let try_resolve_typeclasses env evd flags m n = if flags.resolve_evars then try Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~split:false ~fail:true env evd with e when Typeclasses_errors.unsatisfiable_exception e -> error_cannot_unify env evd (m, n) else evd let w_unify_core_0 env evd with_types cv_pb flags m n = let (mc1,evd') = retract_coercible_metas evd in let (sigma,ms,es) = check_types env flags (evd,mc1,[]) m n in let subst2 = unify_0_with_initial_metas (evd',ms,es) false env cv_pb flags m n in let evd = w_merge env with_types flags subst2 in try_resolve_typeclasses env evd flags m n let w_unify_0 env evd = w_unify_core_0 env evd false let w_typed_unify env evd = w_unify_core_0 env evd true let w_typed_unify_list env evd flags f1 l1 f2 l2 = let flags' = { flags with resolve_evars = false } in let f1,l1,f2,l2 = adjust_app_list_size f1 l1 f2 l2 in let (mc1,evd') = retract_coercible_metas evd in let subst = List.fold_left2 (fun subst m n -> unify_0_with_initial_metas subst true env CONV flags' m n) (evd',[],[]) (f1::l1) (f2::l2) in let evd = w_merge env true flags subst in try_resolve_typeclasses env evd flags (applist(f1,l1)) (applist(f2,l2)) (* takes a substitution s, an open term op and a closed term cl try to find a subterm of cl which matches op, if op is just a Meta FAIL because we cannot find a binding *) let iter_fail f a = let n = Array.length a in let rec ffail i = if i = n then error "iter_fail" else try f a.(i) with ex when precatchable_exception ex -> ffail (i+1) in ffail 0 (* Tries to find an instance of term [cl] in term [op]. Unifies [cl] to every subterm of [op] until it finds a match. Fails if no match is found *) let w_unify_to_subterm env evd ?(flags=default_unify_flags) (op,cl) = let rec matchrec cl = let cl = strip_outer_cast cl in (try if closed0 cl && not (isEvar cl) then w_typed_unify env evd CONV flags op cl,cl else error "Bound 1" with ex when precatchable_exception ex -> (match kind_of_term cl with | App (f,args) -> let n = Array.length args in assert (n>0); let c1 = mkApp (f,Array.sub args 0 (n-1)) in let c2 = args.(n-1) in (try matchrec c1 with ex when precatchable_exception ex -> matchrec c2) | Case(_,_,c,lf) -> (* does not search in the predicate *) (try matchrec c with ex when precatchable_exception ex -> iter_fail matchrec lf) | LetIn(_,c1,_,c2) -> (try matchrec c1 with ex when precatchable_exception ex -> matchrec c2) | Fix(_,(_,types,terms)) -> (try iter_fail matchrec types with ex when precatchable_exception ex -> iter_fail matchrec terms) | CoFix(_,(_,types,terms)) -> (try iter_fail matchrec types with ex when precatchable_exception ex -> iter_fail matchrec terms) | Prod (_,t,c) -> (try matchrec t with ex when precatchable_exception ex -> matchrec c) | Lambda (_,t,c) -> (try matchrec t with ex when precatchable_exception ex -> matchrec c) | _ -> error "Match_subterm")) in try matchrec cl with ex when precatchable_exception ex -> raise (PretypeError (env,evd,NoOccurrenceFound (op, None))) (* Tries to find all instances of term [cl] in term [op]. Unifies [cl] to every subterm of [op] and return all the matches. Fails if no match is found *) let w_unify_to_subterm_all env evd ?(flags=default_unify_flags) (op,cl) = let return a b = let (evd,c as a) = a () in if List.exists (fun (evd',c') -> eq_constr c c') b then b else a :: b in let fail str _ = error str in let bind f g a = let a1 = try f a with ex when precatchable_exception ex -> a in try g a1 with ex when precatchable_exception ex -> a1 in let bind_iter f a = let n = Array.length a in let rec ffail i = if i = n then fun a -> a else bind (f a.(i)) (ffail (i+1)) in ffail 0 in let rec matchrec cl = let cl = strip_outer_cast cl in (bind (if closed0 cl then return (fun () -> w_typed_unify env evd CONV flags op cl,cl) else fail "Bound 1") (match kind_of_term cl with | App (f,args) -> let n = Array.length args in assert (n>0); let c1 = mkApp (f,Array.sub args 0 (n-1)) in let c2 = args.(n-1) in bind (matchrec c1) (matchrec c2) | Case(_,_,c,lf) -> (* does not search in the predicate *) bind (matchrec c) (bind_iter matchrec lf) | LetIn(_,c1,_,c2) -> bind (matchrec c1) (matchrec c2) | Fix(_,(_,types,terms)) -> bind (bind_iter matchrec types) (bind_iter matchrec terms) | CoFix(_,(_,types,terms)) -> bind (bind_iter matchrec types) (bind_iter matchrec terms) | Prod (_,t,c) -> bind (matchrec t) (matchrec c) | Lambda (_,t,c) -> bind (matchrec t) (matchrec c) | _ -> fail "Match_subterm")) in let res = matchrec cl [] in if res = [] then raise (PretypeError (env,evd,NoOccurrenceFound (op, None))) else res let w_unify_to_subterm_list env evd flags hdmeta oplist t = List.fold_right (fun op (evd,l) -> let op = whd_meta evd op in if isMeta op then if flags.allow_K_in_toplevel_higher_order_unification then (evd,op::l) else error_abstraction_over_meta env evd hdmeta (destMeta op) else if occur_meta_or_existential op then let (evd',cl) = try (* This is up to delta for subterms w/o metas ... *) w_unify_to_subterm env evd ~flags (strip_outer_cast op,t) with PretypeError (env,_,NoOccurrenceFound _) when flags.allow_K_in_toplevel_higher_order_unification -> (evd,op) in if not flags.allow_K_in_toplevel_higher_order_unification && (* ensure we found a different instance *) List.exists (fun op -> eq_constr op cl) l then error_non_linear_unification env evd hdmeta cl else (evd',cl::l) else if flags.allow_K_in_toplevel_higher_order_unification or dependent op t then (evd,op::l) else (* This is not up to delta ... *) raise (PretypeError (env,evd,NoOccurrenceFound (op, None)))) oplist (evd,[]) let secondOrderAbstraction env evd flags typ (p, oplist) = (* Remove delta when looking for a subterm *) let flags = { flags with modulo_delta = (fst flags.modulo_delta, Cpred.empty) } in let (evd',cllist) = w_unify_to_subterm_list env evd flags p oplist typ in let typp = Typing.meta_type evd' p in let pred = abstract_list_all env evd' typp typ cllist in w_merge env false flags (evd',[p,pred,(Conv,TypeProcessed)],[]) let secondOrderDependentAbstraction env evd flags typ (p, oplist) = let typp = Typing.meta_type evd p in let pred = abstract_list_all_with_dependencies env evd typp typ oplist in w_merge env false flags (evd,[p,pred,(Conv,TypeProcessed)],[]) let secondOrderAbstractionAlgo dep = if dep then secondOrderDependentAbstraction else secondOrderAbstraction let w_unify2 env evd flags dep cv_pb ty1 ty2 = let c1, oplist1 = whd_stack evd ty1 in let c2, oplist2 = whd_stack evd ty2 in match kind_of_term c1, kind_of_term c2 with | Meta p1, _ -> (* Find the predicate *) secondOrderAbstractionAlgo dep env evd flags ty2 (p1,oplist1) | _, Meta p2 -> (* Find the predicate *) secondOrderAbstractionAlgo dep env evd flags ty1 (p2, oplist2) | _ -> error "w_unify2" (* The unique unification algorithm works like this: If the pattern is flexible, and the goal has a lambda-abstraction at the head, then we do a first-order unification. If the pattern is not flexible, then we do a first-order unification, too. If the pattern is flexible, and the goal doesn't have a lambda-abstraction head, then we second-order unification. *) (* We decide here if first-order or second-order unif is used for Apply *) (* We apply a term of type (ai:Ai)C and try to solve a goal C' *) (* The type C is in clenv.templtyp.rebus with a lot of Meta to solve *) (* 3-4-99 [HH] New fo/so choice heuristic : In case we have to unify (Meta(1) args) with ([x:A]t args') we first try second-order unification and if it fails first-order. Before, second-order was used if the type of Meta(1) and [x:A]t was convertible and first-order otherwise. But if failed if e.g. the type of Meta(1) had meta-variables in it. *) let w_unify env evd cv_pb ?(flags=default_unify_flags) ty1 ty2 = let hd1,l1 = whd_stack evd ty1 in let hd2,l2 = whd_stack evd ty2 in match kind_of_term hd1, l1<>[], kind_of_term hd2, l2<>[] with (* Pattern case *) | (Meta _, true, Lambda _, _ | Lambda _, _, Meta _, true) when List.length l1 = List.length l2 -> (try w_typed_unify_list env evd flags hd1 l1 hd2 l2 with ex when precatchable_exception ex -> try w_unify2 env evd flags false cv_pb ty1 ty2 with PretypeError (env,_,NoOccurrenceFound _) as e -> raise e) (* Second order case *) | (Meta _, true, _, _ | _, _, Meta _, true) -> (try w_unify2 env evd flags false cv_pb ty1 ty2 with PretypeError (env,_,NoOccurrenceFound _) as e -> raise e | ex when precatchable_exception ex -> try w_typed_unify_list env evd flags hd1 l1 hd2 l2 with ex' when precatchable_exception ex' -> (* Last chance, use pattern-matching with typed dependencies (done late for compatibility) *) try w_unify2 env evd flags true cv_pb ty1 ty2 with ex' when precatchable_exception ex' -> raise ex) (* General case: try first order *) | _ -> w_typed_unify env evd cv_pb flags ty1 ty2 coq-8.4pl4/pretyping/typing.ml0000644000175000017500000002400112326224777015515 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* anomaly ("unknown meta ?"^Nameops.string_of_meta mv) in meta_instance evd ty let constant_type_knowing_parameters env cst jl = let paramstyp = Array.map (fun j -> j.uj_type) jl in type_of_constant_knowing_parameters env (constant_type env cst) paramstyp let inductive_type_knowing_parameters env ind jl = let (mib,mip) = lookup_mind_specif env ind in let paramstyp = Array.map (fun j -> j.uj_type) jl in Inductive.type_of_inductive_knowing_parameters env mip paramstyp let e_type_judgment env evdref j = match kind_of_term (whd_betadeltaiota env !evdref j.uj_type) with | Sort s -> {utj_val = j.uj_val; utj_type = s } | Evar ev -> let (evd,s) = Evarutil.define_evar_as_sort !evdref ev in evdref := evd; { utj_val = j.uj_val; utj_type = s } | _ -> error_not_type env j let e_assumption_of_judgment env evdref j = try (e_type_judgment env evdref j).utj_val with TypeError _ -> error_assumption env j let e_judge_of_apply env evdref funj argjv = let rec apply_rec n typ = function | [] -> { uj_val = mkApp (j_val funj, Array.map j_val argjv); uj_type = typ } | hj::restjl -> match kind_of_term (whd_betadeltaiota env !evdref typ) with | Prod (_,c1,c2) -> if Evarconv.e_cumul env evdref hj.uj_type c1 then apply_rec (n+1) (subst1 hj.uj_val c2) restjl else error_cant_apply_bad_type env (n,c1, hj.uj_type) funj argjv | Evar ev -> let (evd',t) = Evarutil.define_evar_as_product !evdref ev in evdref := evd'; let (_,_,c2) = destProd t in apply_rec (n+1) (subst1 hj.uj_val c2) restjl | _ -> error_cant_apply_not_functional env funj argjv in apply_rec 1 funj.uj_type (Array.to_list argjv) let e_check_branch_types env evdref ind cj (lfj,explft) = if Array.length lfj <> Array.length explft then error_number_branches env cj (Array.length explft); for i = 0 to Array.length explft - 1 do if not (Evarconv.e_cumul env evdref lfj.(i).uj_type explft.(i)) then error_ill_formed_branch env cj.uj_val (ind,i+1) lfj.(i).uj_type explft.(i) done let rec max_sort l = if List.mem InType l then InType else if List.mem InSet l then InSet else InProp let e_is_correct_arity env evdref c pj ind specif params = let arsign = make_arity_signature env true (make_ind_family (ind,params)) in let allowed_sorts = elim_sorts specif in let error () = error_elim_arity env ind allowed_sorts c pj None in let rec srec env pt ar = let pt' = whd_betadeltaiota env !evdref pt in match kind_of_term pt', ar with | Prod (na1,a1,t), (_,None,a1')::ar' -> if not (Evarconv.e_cumul env evdref a1 a1') then error (); srec (push_rel (na1,None,a1) env) t ar' | Sort s, [] -> if not (List.mem (family_of_sort s) allowed_sorts) then error () | Evar (ev,_), [] -> let s = Termops.new_sort_in_family (max_sort allowed_sorts) in evdref := Evd.define ev (mkSort s) !evdref | _, (_,Some _,_ as d)::ar' -> srec (push_rel d env) (lift 1 pt') ar' | _ -> error () in srec env pj.uj_type (List.rev arsign) let e_type_case_branches env evdref (ind,largs) pj c = let specif = lookup_mind_specif env ind in let nparams = inductive_params specif in let (params,realargs) = list_chop nparams largs in let p = pj.uj_val in let univ = e_is_correct_arity env evdref c pj ind specif params in let lc = build_branches_type ind specif params p in let n = (snd specif).Declarations.mind_nrealargs_ctxt in let ty = whd_betaiota !evdref (Reduction.betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) in (lc, ty, univ) let e_judge_of_case env evdref ci pj cj lfj = let indspec = try find_mrectype env !evdref cj.uj_type with Not_found -> error_case_not_inductive env cj in let _ = check_case_info env (fst indspec) ci in let (bty,rslty,univ) = e_type_case_branches env evdref indspec pj cj.uj_val in e_check_branch_types env evdref (fst indspec) cj (lfj,bty); { uj_val = mkCase (ci, pj.uj_val, cj.uj_val, Array.map j_val lfj); uj_type = rslty } let check_allowed_sort env sigma ind c p = let pj = Retyping.get_judgment_of env sigma p in let ksort = family_of_sort (sort_of_arity env sigma pj.uj_type) in let specif = Global.lookup_inductive ind in let sorts = elim_sorts specif in if not (List.exists ((=) ksort) sorts) then let s = inductive_sort_family (snd specif) in error_elim_arity env ind sorts c pj (Some(ksort,s,error_elim_explain ksort s)) let e_judge_of_cast env evdref cj k tj = let expected_type = tj.utj_val in if not (Evarconv.e_cumul env evdref cj.uj_type expected_type) then error_actual_type env cj expected_type; { uj_val = mkCast (cj.uj_val, k, expected_type); uj_type = expected_type } (* The typing machine without information, without universes but with existential variables. *) (* cstr must be in n.f. w.r.t. evars and execute returns a judgement where both the term and type are in n.f. *) let rec execute env evdref cstr = match kind_of_term cstr with | Meta n -> { uj_val = cstr; uj_type = meta_type !evdref n } | Evar ev -> let ty = Evd.existential_type !evdref ev in let jty = execute env evdref (whd_evar !evdref ty) in let jty = e_assumption_of_judgment env evdref jty in { uj_val = cstr; uj_type = jty } | Rel n -> judge_of_relative env n | Var id -> judge_of_variable env id | Const c -> make_judge cstr (rename_type_of_constant env c) | Ind ind -> make_judge cstr (rename_type_of_inductive env ind) | Construct cstruct -> make_judge cstr (rename_type_of_constructor env cstruct) | Case (ci,p,c,lf) -> let cj = execute env evdref c in let pj = execute env evdref p in let lfj = execute_array env evdref lf in e_judge_of_case env evdref ci pj cj lfj | Fix ((vn,i as vni),recdef) -> let (_,tys,_ as recdef') = execute_recdef env evdref recdef in let fix = (vni,recdef') in check_fix env fix; make_judge (mkFix fix) tys.(i) | CoFix (i,recdef) -> let (_,tys,_ as recdef') = execute_recdef env evdref recdef in let cofix = (i,recdef') in check_cofix env cofix; make_judge (mkCoFix cofix) tys.(i) | Sort (Prop c) -> judge_of_prop_contents c | Sort (Type u) -> judge_of_type u | App (f,args) -> let jl = execute_array env evdref args in let j = match kind_of_term f with | Ind ind -> (* Sort-polymorphism of inductive types *) make_judge f (inductive_type_knowing_parameters env ind (jv_nf_evar !evdref jl)) | Const cst -> (* Sort-polymorphism of inductive types *) make_judge f (constant_type_knowing_parameters env cst (jv_nf_evar !evdref jl)) | _ -> execute env evdref f in e_judge_of_apply env evdref j jl | Lambda (name,c1,c2) -> let j = execute env evdref c1 in let var = e_type_judgment env evdref j in let env1 = push_rel (name,None,var.utj_val) env in let j' = execute env1 evdref c2 in judge_of_abstraction env1 name var j' | Prod (name,c1,c2) -> let j = execute env evdref c1 in let varj = e_type_judgment env evdref j in let env1 = push_rel (name,None,varj.utj_val) env in let j' = execute env1 evdref c2 in let varj' = e_type_judgment env1 evdref j' in judge_of_product env name varj varj' | LetIn (name,c1,c2,c3) -> let j1 = execute env evdref c1 in let j2 = execute env evdref c2 in let j2 = e_type_judgment env evdref j2 in let _ = judge_of_cast env j1 DEFAULTcast j2 in let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in let j3 = execute env1 evdref c3 in judge_of_letin env name j1 j2 j3 | Cast (c,k,t) -> let cj = execute env evdref c in let tj = execute env evdref t in let tj = e_type_judgment env evdref tj in e_judge_of_cast env evdref cj k tj and execute_recdef env evdref (names,lar,vdef) = let larj = execute_array env evdref lar in let lara = Array.map (e_assumption_of_judgment env evdref) larj in let env1 = push_rec_types (names,lara,vdef) env in let vdefj = execute_array env1 evdref vdef in let vdefv = Array.map j_val vdefj in let _ = type_fixpoint env1 names lara vdefj in (names,lara,vdefv) and execute_array env evdref = Array.map (execute env evdref) let check env evd c t = let evdref = ref evd in let j = execute env evdref c in if not (Evarconv.e_cumul env evdref j.uj_type t) then error_actual_type env j (nf_evar evd t) (* Type of a constr *) let type_of env evd c = let j = execute env (ref evd) c in (* We are outside the kernel: we take fresh universes *) (* to avoid tactics and co to refresh universes themselves *) Termops.refresh_universes j.uj_type (* Sort of a type *) let sort_of env evd c = let evdref = ref evd in let j = execute env evdref c in let a = e_type_judgment env evdref j in a.utj_type (* Try to solve the existential variables by typing *) let e_type_of env evd c = let evdref = ref evd in let j = execute env evdref c in (* side-effect on evdref *) !evdref, Termops.refresh_universes j.uj_type let solve_evars env evd c = let evdref = ref evd in let c = (execute env evdref c).uj_val in (* side-effect on evdref *) !evdref, nf_evar !evdref c let _ = Evarconv.set_solve_evars solve_evars coq-8.4pl4/pretyping/namegen.mli0000644000175000017500000000711212326224777015772 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string val sort_hdchar : sorts -> string val hdchar : env -> types -> string val id_of_name_using_hdchar : env -> types -> name -> identifier val named_hd : env -> types -> name -> name val mkProd_name : env -> name * types * types -> types val mkLambda_name : env -> name * types * constr -> constr (** Deprecated synonyms of [mkProd_name] and [mkLambda_name] *) val prod_name : env -> name * types * types -> types val lambda_name : env -> name * types * constr -> constr val prod_create : env -> types * types -> constr val lambda_create : env -> types * constr -> constr val name_assumption : env -> rel_declaration -> rel_declaration val name_context : env -> rel_context -> rel_context val mkProd_or_LetIn_name : env -> types -> rel_declaration -> types val mkLambda_or_LetIn_name : env -> constr -> rel_declaration -> constr val it_mkProd_or_LetIn_name : env -> types -> rel_context -> types val it_mkLambda_or_LetIn_name : env -> constr -> rel_context -> constr (********************************************************************* Fresh names *) (** Avoid clashing with a name satisfying some predicate *) val next_ident_away_from : identifier -> (identifier -> bool) -> identifier (** Avoid clashing with a name of the given list *) val next_ident_away : identifier -> identifier list -> identifier (** Avoid clashing with a name already used in current module *) val next_ident_away_in_goal : identifier -> identifier list -> identifier (** Avoid clashing with a name already used in current module but tolerate overwriting section variables, as in goals *) val next_global_ident_away : identifier -> identifier list -> identifier (** Avoid clashing with a constructor name already used in current module *) val next_name_away_in_cases_pattern : name -> identifier list -> identifier val next_name_away : name -> identifier list -> identifier (** default is "H" *) val next_name_away_with_default : string -> name -> identifier list -> identifier val next_name_away_with_default_using_types : string -> name -> identifier list -> types -> identifier val set_reserved_typed_name : (types -> name) -> unit (********************************************************************* Making name distinct for displaying *) type renaming_flags = | RenamingForCasesPattern (** avoid only global constructors *) | RenamingForGoal (** avoid all globals (as in intro) *) | RenamingElsewhereFor of (name list * constr) val make_all_name_different : env -> env val compute_displayed_name_in : renaming_flags -> identifier list -> name -> constr -> name * identifier list val compute_and_force_displayed_name_in : renaming_flags -> identifier list -> name -> constr -> name * identifier list val compute_displayed_let_name_in : renaming_flags -> identifier list -> name -> constr -> name * identifier list val rename_bound_vars_as_displayed : identifier list -> name list -> types -> types coq-8.4pl4/pretyping/term_dnet.ml0000644000175000017500000003152512326224777016175 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* std_ppcmds = function | DRel -> str "*" | DSort -> str "Sort" | DRef _ -> str "Ref" | DCtx (ctx,t) -> f ctx ++ spc() ++ str "|-" ++ spc () ++ f t | DLambda (t1,t2) -> str "fun"++ spc() ++ f t1 ++ spc() ++ str"->" ++ spc() ++ f t2 | DApp (t1,t2) -> f t1 ++ spc() ++ f t2 | DCase (_,t1,t2,ta) -> str "case" | DFix _ -> str "fix" | DCoFix _ -> str "cofix" | DCons ((t,dopt),tl) -> f t ++ (match dopt with Some t' -> str ":=" ++ f t' | None -> str "") ++ spc() ++ str "::" ++ spc() ++ f tl | DNil -> str "[]" (* * Functional iterators for the t datatype * a.k.a boring and error-prone boilerplate code *) let map f = function | (DRel | DSort | DNil | DRef _) as c -> c | DCtx (ctx,c) -> DCtx (f ctx, f c) | DLambda (t,c) -> DLambda (f t, f c) | DApp (t,u) -> DApp (f t,f u) | DCase (ci,p,c,bl) -> DCase (ci, f p, f c, Array.map f bl) | DFix (ia,i,ta,ca) -> DFix (ia,i,Array.map f ta,Array.map f ca) | DCoFix(i,ta,ca) -> DCoFix (i,Array.map f ta,Array.map f ca) | DCons ((t,topt),u) -> DCons ((f t,Option.map f topt), f u) let compare x y = let make_name n = match n with | DRef(ConstRef con) -> DRef(ConstRef(constant_of_kn(canonical_con con))) | DRef(IndRef (kn,i)) -> DRef(IndRef(mind_of_kn(canonical_mind kn),i)) | DRef(ConstructRef ((kn,i),j ))-> DRef(ConstructRef((mind_of_kn(canonical_mind kn),i),j)) | k -> k in Pervasives.compare (make_name x) (make_name y) let fold f acc = function | (DRel | DNil | DSort | DRef _) -> acc | DCtx (ctx,c) -> f (f acc ctx) c | DLambda (t,c) -> f (f acc t) c | DApp (t,u) -> f (f acc t) u | DCase (ci,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl | DFix (ia,i,ta,ca) -> Array.fold_left f (Array.fold_left f acc ta) ca | DCoFix(i,ta,ca) -> Array.fold_left f (Array.fold_left f acc ta) ca | DCons ((t,topt),u) -> f (Option.fold_left f (f acc t) topt) u let choose f = function | (DRel | DSort | DNil | DRef _) -> invalid_arg "choose" | DCtx (ctx,c) -> f ctx | DLambda (t,c) -> f t | DApp (t,u) -> f u | DCase (ci,p,c,bl) -> f c | DFix (ia,i,ta,ca) -> f ta.(0) | DCoFix (i,ta,ca) -> f ta.(0) | DCons ((t,topt),u) -> f u let fold2 (f:'a -> 'b -> 'c -> 'a) (acc:'a) (c1:'b t) (c2:'c t) : 'a = let head w = map (fun _ -> ()) w in if compare (head c1) (head c2) <> 0 then invalid_arg "fold2:compare" else match c1,c2 with | (DRel, DRel | DNil, DNil | DSort, DSort | DRef _, DRef _) -> acc | (DCtx (c1,t1), DCtx (c2,t2) | DApp (c1,t1), DApp (c2,t2) | DLambda (c1,t1), DLambda (c2,t2)) -> f (f acc c1 c2) t1 t2 | DCase (ci,p1,c1,bl1),DCase (_,p2,c2,bl2) -> array_fold_left2 f (f (f acc p1 p2) c1 c2) bl1 bl2 | DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) -> array_fold_left2 f (array_fold_left2 f acc ta1 ta2) ca1 ca2 | DCoFix(i,ta1,ca1), DCoFix(_,ta2,ca2) -> array_fold_left2 f (array_fold_left2 f acc ta1 ta2) ca1 ca2 | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> f (Option.fold_left2 f (f acc t1 t2) topt1 topt2) u1 u2 | _ -> assert false let map2 (f:'a -> 'b -> 'c) (c1:'a t) (c2:'b t) : 'c t = let head w = map (fun _ -> ()) w in if compare (head c1) (head c2) <> 0 then invalid_arg "map2_t:compare" else match c1,c2 with | (DRel, DRel | DSort, DSort | DNil, DNil | DRef _, DRef _) as cc -> let (c,_) = cc in c | DCtx (c1,t1), DCtx (c2,t2) -> DCtx (f c1 c2, f t1 t2) | DLambda (t1,c1), DLambda (t2,c2) -> DLambda (f t1 t2, f c1 c2) | DApp (t1,u1), DApp (t2,u2) -> DApp (f t1 t2,f u1 u2) | DCase (ci,p1,c1,bl1), DCase (_,p2,c2,bl2) -> DCase (ci, f p1 p2, f c1 c2, array_map2 f bl1 bl2) | DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) -> DFix (ia,i,array_map2 f ta1 ta2,array_map2 f ca1 ca2) | DCoFix (i,ta1,ca1), DCoFix (_,ta2,ca2) -> DCoFix (i,array_map2 f ta1 ta2,array_map2 f ca1 ca2) | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> DCons ((f t1 t2,Option.lift2 f topt1 topt2), f u1 u2) | _ -> assert false let terminal = function | (DRel | DSort | DNil | DRef _) -> true | _ -> false end (* * Terms discrimination nets * Uses the general dnet datatype on DTerm.t * (here you can restart reading) *) (* * Construction of the module *) module type IDENT = sig type t val compare : t -> t -> int val subst : substitution -> t -> t val constr_of : t -> constr end module type OPT = sig val reduce : constr -> constr val direction : bool end module Make = functor (Ident : IDENT) -> functor (Opt : OPT) -> struct module TDnet : Dnet.S with type ident=Ident.t and type 'a structure = 'a DTerm.t and type meta = metavariable = Dnet.Make(DTerm)(Ident) (struct type t = metavariable let compare = Pervasives.compare end) type t = TDnet.t type ident = TDnet.ident type 'a pattern = 'a TDnet.pattern type term_pattern = term_pattern DTerm.t pattern type idset = TDnet.Idset.t type result = ident * (constr*existential_key) * Termops.subst open DTerm open TDnet let rec pat_of_constr c : term_pattern = match kind_of_term c with | Rel _ -> Term DRel | Sort _ -> Term DSort | Var i -> Term (DRef (VarRef i)) | Const c -> Term (DRef (ConstRef c)) | Ind i -> Term (DRef (IndRef i)) | Construct c -> Term (DRef (ConstructRef c)) | Term.Meta _ -> assert false | Evar (i,_) -> Meta i | Case (ci,c1,c2,ca) -> Term(DCase(ci,pat_of_constr c1,pat_of_constr c2,Array.map pat_of_constr ca)) | Fix ((ia,i),(_,ta,ca)) -> Term(DFix(ia,i,Array.map pat_of_constr ta, Array.map pat_of_constr ca)) | CoFix (i,(_,ta,ca)) -> Term(DCoFix(i,Array.map pat_of_constr ta,Array.map pat_of_constr ca)) | Cast (c,_,_) -> pat_of_constr c | Lambda (_,t,c) -> Term(DLambda (pat_of_constr t, pat_of_constr c)) | (Prod (_,_,_) | LetIn(_,_,_,_)) -> let (ctx,c) = ctx_of_constr (Term DNil) c in Term (DCtx (ctx,c)) | App (f,ca) -> Array.fold_left (fun c a -> Term (DApp (c,a))) (pat_of_constr f) (Array.map pat_of_constr ca) and ctx_of_constr ctx c : term_pattern * term_pattern = match kind_of_term c with | Prod (_,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t,None),ctx))) c | LetIn(_,d,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t, Some (pat_of_constr d)),ctx))) c | _ -> ctx,pat_of_constr c let empty_ctx : term_pattern -> term_pattern = function | Meta _ as c -> c | Term (DCtx(_,_)) as c -> c | c -> Term (DCtx (Term DNil, c)) (* * Basic primitives *) let empty = TDnet.empty let subst s t = let sleaf id = Ident.subst s id in let snode = function | DTerm.DRef gr -> DTerm.DRef (fst (subst_global s gr)) | n -> n in TDnet.map sleaf snode t let union = TDnet.union let add (c:constr) (id:Ident.t) (dn:t) = let c = Opt.reduce c in let c = empty_ctx (pat_of_constr c) in TDnet.add dn c id let new_meta_no = let ctr = ref 0 in fun () -> decr ctr; !ctr let new_meta_no = Evarutil.new_untyped_evar let neutral_meta = new_meta_no() let new_meta () = Meta (new_meta_no()) let new_evar () = mkEvar(new_meta_no(),[||]) let rec remove_cap : term_pattern -> term_pattern = function | Term (DCons (t,u)) -> Term (DCons (t,remove_cap u)) | Term DNil -> new_meta() | Meta _ as m -> m | _ -> assert false let under_prod : term_pattern -> term_pattern = function | Term (DCtx (t,u)) -> Term (DCtx (remove_cap t,u)) | Meta m -> Term (DCtx(new_meta(), Meta m)) | _ -> assert false let init = let e = new_meta_no() in (mkEvar (e,[||]),e) let rec e_subst_evar i (t:unit->constr) c = match kind_of_term c with | Evar (j,_) when i=j -> t() | _ -> map_constr (e_subst_evar i t) c let subst_evar i c = e_subst_evar i (fun _ -> c) (* debug *) let rec pr_term_pattern p = (fun pr_t -> function | Term t -> pr_t t | Meta m -> str"["++Util.pr_int (Obj.magic m)++str"]" ) (pr_dconstr pr_term_pattern) p let search_pat cpat dpat dn (up,plug) = let whole_c = subst_evar plug cpat up in (* if we are at the root, add an empty context *) let dpat = if isEvar_or_Meta up then under_prod (empty_ctx dpat) else dpat in TDnet.Idset.fold (fun id acc -> let c_id = Opt.reduce (Ident.constr_of id) in let (ctx,wc) = try Termops.align_prod_letin whole_c c_id with Invalid_argument _ -> [],c_id in let up = it_mkProd_or_LetIn up ctx in let wc,whole_c = if Opt.direction then whole_c,wc else wc,whole_c in try (id,(up,plug),Termops.filtering ctx Reduction.CUMUL wc whole_c)::acc with Termops.CannotFilter -> (* msgnl(str"recon "++Termops.print_constr_env (Global.env()) wc); *) acc ) (TDnet.find_match dpat dn) [] let fold_pattern_neutral f = fold_pattern (fun acc (mset,m,dn) -> if m=neutral_meta then acc else f m dn acc) let fold_pattern_nonlin f = let defined = ref Gmap.empty in fold_pattern_neutral ( fun m dn acc -> let dn = try TDnet.inter dn (Gmap.find m !defined) with Not_found -> dn in defined := Gmap.add m dn !defined; f m dn acc ) let fold_pattern_up f acc dpat cpat dn (up,plug) = fold_pattern_nonlin ( fun m dn acc -> f dn (subst_evar plug (e_subst_evar neutral_meta new_evar cpat) up, m) acc ) acc dpat dn let possibly_under pat k dn (up,plug) = let rec aux fst dn (up,plug) acc = let cpat = pat() in let dpat = pat_of_constr cpat in let dpat = if fst then under_prod (empty_ctx dpat) else dpat in (k dn (up,plug)) @ snd (fold_pattern_up (aux false) acc dpat cpat dn (up,plug)) in aux true dn (up,plug) [] let eq_pat eq () = mkApp(eq,[|mkEvar(neutral_meta,[||]);new_evar();new_evar()|]) let app_pat () = mkApp(new_evar(),[|mkEvar(neutral_meta,[||])|]) (* * High-level primitives describing specific search problems *) let search_pattern dn pat = let pat = Opt.reduce pat in search_pat pat (empty_ctx (pat_of_constr pat)) dn init let search_concl dn pat = let pat = Opt.reduce pat in search_pat pat (under_prod (empty_ctx (pat_of_constr pat))) dn init let search_eq_concl dn eq pat = let pat = Opt.reduce pat in let eq_pat = eq_pat eq () in let eq_dpat = under_prod (empty_ctx (pat_of_constr eq_pat)) in snd (fold_pattern_up (fun dn up acc -> search_pat pat (pat_of_constr pat) dn up @ acc ) [] eq_dpat eq_pat dn init) let search_head_concl dn pat = let pat = Opt.reduce pat in possibly_under app_pat (search_pat pat (pat_of_constr pat)) dn init let find_all dn = Idset.elements (TDnet.find_all dn) let map f dn = TDnet.map f (fun x -> x) dn end module type S = sig type t type ident type result = ident * (constr*existential_key) * Termops.subst val empty : t val add : constr -> ident -> t -> t val union : t -> t -> t val subst : substitution -> t -> t val search_pattern : t -> constr -> result list val search_concl : t -> constr -> result list val search_head_concl : t -> constr -> result list val search_eq_concl : t -> constr -> constr -> result list val find_all : t -> ident list val map : (ident -> ident) -> t -> t end coq-8.4pl4/pretyping/detyping.mli0000644000175000017500000000546212326224777016211 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* cases_pattern -> cases_pattern val subst_glob_constr : substitution -> glob_constr -> glob_constr (** [detype isgoal avoid ctx c] turns a closed [c], into a glob_constr de Bruijn indexes are turned to bound names, avoiding names in [avoid] [isgoal] tells if naming must avoid global-level synonyms as intro does [ctx] gives the names of the free variables *) val detype : bool -> identifier list -> names_context -> constr -> glob_constr val detype_case : bool -> ('a -> glob_constr) -> (constructor array -> int array -> 'a array -> (loc * identifier list * cases_pattern list * glob_constr) list) -> ('a -> int -> bool) -> identifier list -> inductive * case_style * int * int array * int -> 'a option -> 'a -> 'a array -> glob_constr val detype_sort : sorts -> glob_sort val detype_rel_context : constr option -> identifier list -> names_context -> rel_context -> glob_decl list (** look for the index of a named var or a nondep var as it is renamed *) val lookup_name_as_displayed : env -> constr -> identifier -> int option val lookup_index_as_renamed : env -> constr -> int -> int option val set_detype_anonymous : (loc -> int -> glob_constr) -> unit val force_wildcard : unit -> bool val synthetize_type : unit -> bool (** Utilities to transform kernel cases to simple pattern-matching problem *) val it_destRLambda_or_LetIn_names : int -> glob_constr -> name list * glob_constr val simple_cases_matrix_of_branches : inductive -> (int * int * glob_constr) list -> cases_clauses val return_type_of_predicate : inductive -> int -> int -> glob_constr -> predicate_pattern * glob_constr option module PrintingInductiveMake : functor (Test : sig val encode : Libnames.reference -> Names.inductive val member_message : Pp.std_ppcmds -> bool -> Pp.std_ppcmds val field : string val title : string end) -> sig type t = Names.inductive val encode : Libnames.reference -> Names.inductive val subst : substitution -> t -> t val printer : t -> Pp.std_ppcmds val key : Goptions.option_name val title : string val member_message : t -> bool -> Pp.std_ppcmds val synchronous : bool end coq-8.4pl4/pretyping/reductionops.ml0000644000175000017500000007734212326224777016741 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list type stack_reduction_function = contextual_stack_reduction_function type local_stack_reduction_function = evar_map -> constr -> constr * constr list type contextual_state_reduction_function = env -> evar_map -> state -> state type state_reduction_function = contextual_state_reduction_function type local_state_reduction_function = evar_map -> state -> state (*************************************) (*** Reduction Functions Operators ***) (*************************************) let safe_evar_value sigma ev = try Some (Evd.existential_value sigma ev) with NotInstantiatedEvar | Not_found -> None let rec whd_app_state sigma (x, stack as s) = match kind_of_term x with | App (f,cl) -> whd_app_state sigma (f, append_stack cl stack) | Cast (c,_,_) -> whd_app_state sigma (c, stack) | Evar ev -> (match safe_evar_value sigma ev with Some c -> whd_app_state sigma (c,stack) | _ -> s) | _ -> s let safe_meta_value sigma ev = try Some (Evd.meta_value sigma ev) with Not_found -> None let appterm_of_stack (f,s) = (f,list_of_stack s) let whd_stack sigma x = appterm_of_stack (whd_app_state sigma (x, empty_stack)) let whd_castapp_stack = whd_stack let strong whdfun env sigma t = let rec strongrec env t = map_constr_with_full_binders push_rel strongrec env (whdfun env sigma t) in strongrec env t let local_strong whdfun sigma = let rec strongrec t = map_constr strongrec (whdfun sigma t) in strongrec let rec strong_prodspine redfun sigma c = let x = redfun sigma c in match kind_of_term x with | Prod (na,a,b) -> mkProd (na,a,strong_prodspine redfun sigma b) | _ -> x (*************************************) (*** Reduction using bindingss ***) (*************************************) (* This signature is very similar to Closure.RedFlagsSig except there is eta but no per-constant unfolding *) module type RedFlagsSig = sig type flags type flag val fbeta : flag val fdelta : flag val feta : flag val fiota : flag val fzeta : flag val mkflags : flag list -> flags val red_beta : flags -> bool val red_delta : flags -> bool val red_eta : flags -> bool val red_iota : flags -> bool val red_zeta : flags -> bool end (* Compact Implementation *) module RedFlags = (struct type flag = int type flags = int let fbeta = 1 let fdelta = 2 let feta = 8 let fiota = 16 let fzeta = 32 let mkflags = List.fold_left (lor) 0 let red_beta f = f land fbeta <> 0 let red_delta f = f land fdelta <> 0 let red_eta f = f land feta <> 0 let red_iota f = f land fiota <> 0 let red_zeta f = f land fzeta <> 0 end : RedFlagsSig) open RedFlags (* Local *) let beta = mkflags [fbeta] let eta = mkflags [feta] let zeta = mkflags [fzeta] let betaiota = mkflags [fiota; fbeta] let betaiotazeta = mkflags [fiota; fbeta;fzeta] (* Contextual *) let delta = mkflags [fdelta] let betadelta = mkflags [fbeta;fdelta;fzeta] let betadeltaeta = mkflags [fbeta;fdelta;fzeta;feta] let betadeltaiota = mkflags [fbeta;fdelta;fzeta;fiota] let betadeltaiota_nolet = mkflags [fbeta;fdelta;fiota] let betadeltaiotaeta = mkflags [fbeta;fdelta;fzeta;fiota;feta] let betaetalet = mkflags [fbeta;feta;fzeta] let betalet = mkflags [fbeta;fzeta] (* Beta Reduction tools *) let rec stacklam recfun env t stack = match (decomp_stack stack,kind_of_term t) with | Some (h,stacktl), Lambda (_,_,c) -> stacklam recfun (h::env) c stacktl | _ -> recfun (substl env t, stack) let beta_applist (c,l) = stacklam app_stack [] c (append_stack_list l empty_stack) (* Iota reduction tools *) type 'a miota_args = { mP : constr; (* the result type *) mconstr : constr; (* the constructor *) mci : case_info; (* special info to re-build pattern *) mcargs : 'a list; (* the constructor's arguments *) mlf : 'a array } (* the branch code vector *) let reducible_mind_case c = match kind_of_term c with | Construct _ | CoFix _ -> true | _ -> false let contract_cofix (bodynum,(types,names,bodies as typedbodies)) = let nbodies = Array.length bodies in let make_Fi j = mkCoFix (nbodies-j-1,typedbodies) in substl (list_tabulate make_Fi nbodies) bodies.(bodynum) let reduce_mind_case mia = match kind_of_term mia.mconstr with | Construct (ind_sp,i) -> (* let ncargs = (fst mia.mci).(i-1) in*) let real_cargs = list_skipn mia.mci.ci_npar mia.mcargs in applist (mia.mlf.(i-1),real_cargs) | CoFix cofix -> let cofix_def = contract_cofix cofix in mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false (* contracts fix==FIX[nl;i](A1...Ak;[F1...Fk]{B1....Bk}) to produce Bi[Fj --> FIX[nl;j](A1...Ak;[F1...Fk]{B1...Bk})] *) let contract_fix ((recindices,bodynum),(types,names,bodies as typedbodies)) = let nbodies = Array.length recindices in let make_Fi j = mkFix ((recindices,nbodies-j-1),typedbodies) in substl (list_tabulate make_Fi nbodies) bodies.(bodynum) let fix_recarg ((recindices,bodynum),_) stack = assert (0 <= bodynum & bodynum < Array.length recindices); let recargnum = Array.get recindices bodynum in try Some (recargnum, stack_nth stack recargnum) with Not_found -> None type fix_reduction_result = NotReducible | Reduced of state let reduce_fix whdfun sigma fix stack = match fix_recarg fix stack with | None -> NotReducible | Some (recargnum,recarg) -> let (recarg'hd,_ as recarg') = whdfun sigma (recarg, empty_stack) in let stack' = stack_assign stack recargnum (app_stack recarg') in (match kind_of_term recarg'hd with | Construct _ -> Reduced (contract_fix fix, stack') | _ -> NotReducible) (* Generic reduction function *) (* Y avait un commentaire pour whd_betadeltaiota : NB : Cette fonction alloue peu c'est l'appel ``let (c,cargs) = whfun (recarg, empty_stack)'' ------------------- qui coute cher *) let rec whd_state_gen flags ts env sigma = let rec whrec (x, stack as s) = match kind_of_term x with | Rel n when red_delta flags -> (match lookup_rel n env with | (_,Some body,_) -> whrec (lift n body, stack) | _ -> s) | Var id when red_delta flags -> (match lookup_named id env with | (_,Some body,_) -> whrec (body, stack) | _ -> s) | Evar ev -> (match safe_evar_value sigma ev with | Some body -> whrec (body, stack) | None -> s) | Meta ev -> (match safe_meta_value sigma ev with | Some body -> whrec (body, stack) | None -> s) | Const const when is_transparent_constant ts const -> (match constant_opt_value env const with | Some body -> whrec (body, stack) | None -> s) | LetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack | Cast (c,_,_) -> whrec (c, stack) | App (f,cl) -> whrec (f, append_stack cl stack) | Lambda (na,t,c) -> (match decomp_stack stack with | Some (a,m) when red_beta flags -> stacklam whrec [a] c m | None when red_eta flags -> let env' = push_rel (na,None,t) env in let whrec' = whd_state_gen flags ts env' sigma in (match kind_of_term (app_stack (whrec' (c, empty_stack))) with | App (f,cl) -> let napp = Array.length cl in if napp > 0 then let x', l' = whrec' (array_last cl, empty_stack) in match kind_of_term x', decomp_stack l' with | Rel 1, None -> let lc = Array.sub cl 0 (napp-1) in let u = if napp=1 then f else appvect (f,lc) in if noccurn 1 u then (pop u,empty_stack) else s | _ -> s else s | _ -> s) | _ -> s) | Case (ci,p,d,lf) when red_iota flags -> let (c,cargs) = whrec (d, empty_stack) in if reducible_mind_case c then whrec (reduce_mind_case {mP=p; mconstr=c; mcargs=list_of_stack cargs; mci=ci; mlf=lf}, stack) else (mkCase (ci, p, app_stack (c,cargs), lf), stack) | Fix fix when red_iota flags -> (match reduce_fix (fun _ -> whrec) sigma fix stack with | Reduced s' -> whrec s' | NotReducible -> s) | x -> s in whrec let local_whd_state_gen flags sigma = let rec whrec (x, stack as s) = match kind_of_term x with | LetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack | Cast (c,_,_) -> whrec (c, stack) | App (f,cl) -> whrec (f, append_stack cl stack) | Lambda (_,_,c) -> (match decomp_stack stack with | Some (a,m) when red_beta flags -> stacklam whrec [a] c m | None when red_eta flags -> (match kind_of_term (app_stack (whrec (c, empty_stack))) with | App (f,cl) -> let napp = Array.length cl in if napp > 0 then let x', l' = whrec (array_last cl, empty_stack) in match kind_of_term x', decomp_stack l' with | Rel 1, None -> let lc = Array.sub cl 0 (napp-1) in let u = if napp=1 then f else appvect (f,lc) in if noccurn 1 u then (pop u,empty_stack) else s | _ -> s else s | _ -> s) | _ -> s) | Case (ci,p,d,lf) when red_iota flags -> let (c,cargs) = whrec (d, empty_stack) in if reducible_mind_case c then whrec (reduce_mind_case {mP=p; mconstr=c; mcargs=list_of_stack cargs; mci=ci; mlf=lf}, stack) else (mkCase (ci, p, app_stack (c,cargs), lf), stack) | Fix fix when red_iota flags -> (match reduce_fix (fun _ ->whrec) sigma fix stack with | Reduced s' -> whrec s' | NotReducible -> s) | Evar ev -> (match safe_evar_value sigma ev with Some c -> whrec (c,stack) | None -> s) | Meta ev -> (match safe_meta_value sigma ev with Some c -> whrec (c,stack) | None -> s) | x -> s in whrec let stack_red_of_state_red f sigma x = appterm_of_stack (f sigma (x, empty_stack)) let red_of_state_red f sigma x = app_stack (f sigma (x,empty_stack)) (* 1. Beta Reduction Functions *) let whd_beta_state = local_whd_state_gen beta let whd_beta_stack = stack_red_of_state_red whd_beta_state let whd_beta = red_of_state_red whd_beta_state (* Nouveau ! *) let whd_betaetalet_state = local_whd_state_gen betaetalet let whd_betaetalet_stack = stack_red_of_state_red whd_betaetalet_state let whd_betaetalet = red_of_state_red whd_betaetalet_state let whd_betalet_state = local_whd_state_gen betalet let whd_betalet_stack = stack_red_of_state_red whd_betalet_state let whd_betalet = red_of_state_red whd_betalet_state (* 2. Delta Reduction Functions *) let whd_delta_state e = whd_state_gen delta full_transparent_state e let whd_delta_stack env = stack_red_of_state_red (whd_delta_state env) let whd_delta env = red_of_state_red (whd_delta_state env) let whd_betadelta_state e = whd_state_gen betadelta full_transparent_state e let whd_betadelta_stack env = stack_red_of_state_red (whd_betadelta_state env) let whd_betadelta env = red_of_state_red (whd_betadelta_state env) let whd_betadeltaeta_state e = whd_state_gen betadeltaeta full_transparent_state e let whd_betadeltaeta_stack env = stack_red_of_state_red (whd_betadeltaeta_state env) let whd_betadeltaeta env = red_of_state_red (whd_betadeltaeta_state env) (* 3. Iota reduction Functions *) let whd_betaiota_state = local_whd_state_gen betaiota let whd_betaiota_stack = stack_red_of_state_red whd_betaiota_state let whd_betaiota = red_of_state_red whd_betaiota_state let whd_betaiotazeta_state = local_whd_state_gen betaiotazeta let whd_betaiotazeta_stack = stack_red_of_state_red whd_betaiotazeta_state let whd_betaiotazeta = red_of_state_red whd_betaiotazeta_state let whd_betadeltaiota_state env = whd_state_gen betadeltaiota full_transparent_state env let whd_betadeltaiota_stack env = stack_red_of_state_red (whd_betadeltaiota_state env) let whd_betadeltaiota env = red_of_state_red (whd_betadeltaiota_state env) let whd_betadeltaiota_state_using ts env = whd_state_gen betadeltaiota ts env let whd_betadeltaiota_stack_using ts env = stack_red_of_state_red (whd_betadeltaiota_state_using ts env) let whd_betadeltaiota_using ts env = red_of_state_red (whd_betadeltaiota_state_using ts env) let whd_betadeltaiotaeta_state env = whd_state_gen betadeltaiotaeta full_transparent_state env let whd_betadeltaiotaeta_stack env = stack_red_of_state_red (whd_betadeltaiotaeta_state env) let whd_betadeltaiotaeta env = red_of_state_red (whd_betadeltaiotaeta_state env) let whd_betadeltaiota_nolet_state env = whd_state_gen betadeltaiota_nolet full_transparent_state env let whd_betadeltaiota_nolet_stack env = stack_red_of_state_red (whd_betadeltaiota_nolet_state env) let whd_betadeltaiota_nolet env = red_of_state_red (whd_betadeltaiota_nolet_state env) (* 4. Eta reduction Functions *) let whd_eta c = app_stack (local_whd_state_gen eta Evd.empty (c,empty_stack)) (* 5. Zeta Reduction Functions *) let whd_zeta c = app_stack (local_whd_state_gen zeta Evd.empty (c,empty_stack)) (****************************************************************************) (* Reduction Functions *) (****************************************************************************) (* Replacing defined evars for error messages *) let rec whd_evar sigma c = match kind_of_term c with | Evar ev -> (match safe_evar_value sigma ev with Some c -> whd_evar sigma c | None -> c) | Sort s -> whd_sort_variable sigma c | _ -> c let nf_evar = local_strong whd_evar (* lazy reduction functions. The infos must be created for each term *) (* Note by HH [oct 08] : why would it be the job of clos_norm_flags to add a [nf_evar] here *) let clos_norm_flags flgs env sigma t = try norm_val (create_clos_infos ~evars:(safe_evar_value sigma) flgs env) (inject t) with Anomaly _ -> error "Tried to normalized ill-typed term" let nf_beta = clos_norm_flags Closure.beta empty_env let nf_betaiota = clos_norm_flags Closure.betaiota empty_env let nf_betadeltaiota env sigma = clos_norm_flags Closure.betadeltaiota env sigma (* Attention reduire un beta-redexe avec un argument qui n'est pas une variable, peut changer enormement le temps de conversion lors du type checking : (fun x => x + x) M *) let rec whd_betaiota_preserving_vm_cast env sigma t = let rec stacklam_var subst t stack = match (decomp_stack stack,kind_of_term t) with | Some (h,stacktl), Lambda (_,_,c) -> begin match kind_of_term h with | Rel i when not (evaluable_rel i env) -> stacklam_var (h::subst) c stacktl | Var id when not (evaluable_named id env)-> stacklam_var (h::subst) c stacktl | _ -> whrec (substl subst t, stack) end | _ -> whrec (substl subst t, stack) and whrec (x, stack as s) = match kind_of_term x with | Evar ev -> (match safe_evar_value sigma ev with | Some body -> whrec (body, stack) | None -> s) | Cast (c,VMcast,t) -> let c = app_stack (whrec (c,empty_stack)) in let t = app_stack (whrec (t,empty_stack)) in (mkCast(c,VMcast,t),stack) | Cast (c,DEFAULTcast,_) -> whrec (c, stack) | App (f,cl) -> whrec (f, append_stack cl stack) | Lambda (na,t,c) -> (match decomp_stack stack with | Some (a,m) -> stacklam_var [a] c m | _ -> s) | Case (ci,p,d,lf) -> let (c,cargs) = whrec (d, empty_stack) in if reducible_mind_case c then whrec (reduce_mind_case {mP=p; mconstr=c; mcargs=list_of_stack cargs; mci=ci; mlf=lf}, stack) else (mkCase (ci, p, app_stack (c,cargs), lf), stack) | x -> s in app_stack (whrec (t,empty_stack)) let nf_betaiota_preserving_vm_cast = strong whd_betaiota_preserving_vm_cast (********************************************************************) (* Conversion *) (********************************************************************) (* let fkey = Profile.declare_profile "fhnf";; let fhnf info v = Profile.profile2 fkey fhnf info v;; let fakey = Profile.declare_profile "fhnf_apply";; let fhnf_apply info k h a = Profile.profile4 fakey fhnf_apply info k h a;; *) let is_transparent k = Conv_oracle.get_strategy k <> Conv_oracle.Opaque (* Conversion utility functions *) type conversion_test = constraints -> constraints let pb_is_equal pb = pb = CONV let pb_equal = function | CUMUL -> CONV | CONV -> CONV let sort_cmp = sort_cmp let test_conversion (f: ?l2r:bool-> ?evars:'a->'b) env sigma x y = try let _ = f ~evars:(safe_evar_value sigma) env x y in true with NotConvertible -> false | Anomaly _ -> error "Conversion test raised an anomaly" let is_conv env sigma = test_conversion Reduction.conv env sigma let is_conv_leq env sigma = test_conversion Reduction.conv_leq env sigma let is_fconv = function | CONV -> is_conv | CUMUL -> is_conv_leq let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y = try let _ = f ~evars:(safe_evar_value sigma) reds env x y in true with NotConvertible -> false | Anomaly _ -> error "Conversion test raised an anomaly" let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv reds env sigma let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq reds env sigma let is_trans_fconv = function | CONV -> is_trans_conv | CUMUL -> is_trans_conv_leq (********************************************************************) (* Special-Purpose Reduction *) (********************************************************************) let whd_meta sigma c = match kind_of_term c with | Meta p -> (try meta_value sigma p with Not_found -> c) | _ -> c (* Try to replace all metas. Does not replace metas in the metas' values * Differs from (strong whd_meta). *) let plain_instance s c = let rec irec n u = match kind_of_term u with | Meta p -> (try lift n (List.assoc p s) with Not_found -> u) | App (f,l) when isCast f -> let (f,_,t) = destCast f in let l' = Array.map (irec n) l in (match kind_of_term f with | Meta p -> (* Don't flatten application nodes: this is used to extract a proof-term from a proof-tree and we want to keep the structure of the proof-tree *) (try let g = List.assoc p s in match kind_of_term g with | App _ -> let h = id_of_string "H" in mkLetIn (Name h,g,t,mkApp(mkRel 1,Array.map (lift 1) l')) | _ -> mkApp (g,l') with Not_found -> mkApp (f,l')) | _ -> mkApp (irec n f,l')) | Cast (m,_,_) when isMeta m -> (try lift n (List.assoc (destMeta m) s) with Not_found -> u) | _ -> map_constr_with_binders succ irec n u in if s = [] then c else irec 0 c (* [instance] is used for [res_pf]; the call to [local_strong whd_betaiota] has (unfortunately) different subtle side effects: - ** Order of subgoals ** If the lemma is a case analysis with parameters, it will move the parameters as first subgoals (e.g. "case H" applied on "H:D->A/\B|-C" will present the subgoal |-D first while w/o betaiota the subgoal |-D would have come last). - ** Betaiota-contraction in statement ** If the lemma has a parameter which is a function and this function is applied in the lemma, then the _strong_ betaiota will contract the application of the function to its argument (e.g. "apply (H (fun x => x))" in "H:forall f, f 0 = 0 |- 0=0" will result in applying the lemma 0=0 in which "(fun x => x) 0" has been contracted). A goal to rewrite may then fail or succeed differently. - ** Naming of hypotheses ** If a lemma is a function of the form "fun H:(forall a:A, P a) => .. F H .." where the expected type of H is "forall b:A, P b", then, without reduction, the application of the lemma will generate a subgoal "forall a:A, P a" (and intro will use name "a"), while with reduction, it will generate a subgoal "forall b:A, P b" (and intro will use name "b"). - ** First-order pattern-matching ** If a lemma has the type "(fun x => p) t" then rewriting t may fail if the type of the lemma is first beta-reduced (this typically happens when rewriting a single variable and the type of the lemma is obtained by meta_instance (with empty map) which itself calls instance with this empty map). *) let instance sigma s c = (* if s = [] then c else *) local_strong whd_betaiota sigma (plain_instance s c) (* pseudo-reduction rule: * [hnf_prod_app env s (Prod(_,B)) N --> B[N] * with an HNF on the first argument to produce a product. * if this does not work, then we use the string S as part of our * error message. *) let hnf_prod_app env sigma t n = match kind_of_term (whd_betadeltaiota env sigma t) with | Prod (_,_,b) -> subst1 n b | _ -> anomaly "hnf_prod_app: Need a product" let hnf_prod_appvect env sigma t nl = Array.fold_left (hnf_prod_app env sigma) t nl let hnf_prod_applist env sigma t nl = List.fold_left (hnf_prod_app env sigma) t nl let hnf_lam_app env sigma t n = match kind_of_term (whd_betadeltaiota env sigma t) with | Lambda (_,_,b) -> subst1 n b | _ -> anomaly "hnf_lam_app: Need an abstraction" let hnf_lam_appvect env sigma t nl = Array.fold_left (hnf_lam_app env sigma) t nl let hnf_lam_applist env sigma t nl = List.fold_left (hnf_lam_app env sigma) t nl let splay_prod env sigma = let rec decrec env m c = let t = whd_betadeltaiota env sigma c in match kind_of_term t with | Prod (n,a,c0) -> decrec (push_rel (n,None,a) env) ((n,a)::m) c0 | _ -> m,t in decrec env [] let splay_lam env sigma = let rec decrec env m c = let t = whd_betadeltaiota env sigma c in match kind_of_term t with | Lambda (n,a,c0) -> decrec (push_rel (n,None,a) env) ((n,a)::m) c0 | _ -> m,t in decrec env [] let splay_prod_assum env sigma = let rec prodec_rec env l c = let t = whd_betadeltaiota_nolet env sigma c in match kind_of_term t with | Prod (x,t,c) -> prodec_rec (push_rel (x,None,t) env) (add_rel_decl (x, None, t) l) c | LetIn (x,b,t,c) -> prodec_rec (push_rel (x, Some b, t) env) (add_rel_decl (x, Some b, t) l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> l,t in prodec_rec env empty_rel_context let splay_arity env sigma c = let l, c = splay_prod env sigma c in match kind_of_term c with | Sort s -> l,s | _ -> invalid_arg "splay_arity" let sort_of_arity env sigma c = snd (splay_arity env sigma c) let splay_prod_n env sigma n = let rec decrec env m ln c = if m = 0 then (ln,c) else match kind_of_term (whd_betadeltaiota env sigma c) with | Prod (n,a,c0) -> decrec (push_rel (n,None,a) env) (m-1) (add_rel_decl (n,None,a) ln) c0 | _ -> invalid_arg "splay_prod_n" in decrec env n empty_rel_context let splay_lam_n env sigma n = let rec decrec env m ln c = if m = 0 then (ln,c) else match kind_of_term (whd_betadeltaiota env sigma c) with | Lambda (n,a,c0) -> decrec (push_rel (n,None,a) env) (m-1) (add_rel_decl (n,None,a) ln) c0 | _ -> invalid_arg "splay_lam_n" in decrec env n empty_rel_context exception NotASort let decomp_sort env sigma t = match kind_of_term (whd_betadeltaiota env sigma t) with | Sort s -> s | _ -> raise NotASort let is_sort env sigma arity = try let _ = decomp_sort env sigma arity in true with NotASort -> false (* reduction to head-normal-form allowing delta/zeta only in argument of case/fix (heuristic used by evar_conv) *) let whd_betaiota_deltazeta_for_iota_state ts env sigma s = let rec whrec s = let (t, stack as s) = whd_betaiota_state sigma s in match kind_of_term t with | Case (ci,p,d,lf) -> let (cr,crargs) = whd_betadeltaiota_stack_using ts env sigma d in let rslt = mkCase (ci, p, applist (cr,crargs), lf) in if reducible_mind_case cr then whrec (rslt, stack) else s | Fix fix -> (match reduce_fix (whd_betadeltaiota_state_using ts env) sigma fix stack with | Reduced s -> whrec s | NotReducible -> s) | _ -> s in whrec s (* A reduction function like whd_betaiota but which keeps casts * and does not reduce redexes containing existential variables. * Used in Correctness. * Added by JCF, 29/1/98. *) let whd_programs_stack env sigma = let rec whrec (x, stack as s) = match kind_of_term x with | App (f,cl) -> let n = Array.length cl - 1 in let c = cl.(n) in if occur_existential c then s else whrec (mkApp (f, Array.sub cl 0 n), append_stack [|c|] stack) | LetIn (_,b,_,c) -> if occur_existential b then s else stacklam whrec [b] c stack | Lambda (_,_,c) -> (match decomp_stack stack with | None -> s | Some (a,m) -> stacklam whrec [a] c m) | Case (ci,p,d,lf) -> if occur_existential d then s else let (c,cargs) = whrec (d, empty_stack) in if reducible_mind_case c then whrec (reduce_mind_case {mP=p; mconstr=c; mcargs=list_of_stack cargs; mci=ci; mlf=lf}, stack) else (mkCase (ci, p, app_stack(c,cargs), lf), stack) | Fix fix -> (match reduce_fix (fun _ ->whrec) sigma fix stack with | Reduced s' -> whrec s' | NotReducible -> s) | _ -> s in whrec let whd_programs env sigma x = app_stack (whd_programs_stack env sigma (x, empty_stack)) exception IsType let find_conclusion env sigma = let rec decrec env c = let t = whd_betadeltaiota env sigma c in match kind_of_term t with | Prod (x,t,c0) -> decrec (push_rel (x,None,t) env) c0 | Lambda (x,t,c0) -> decrec (push_rel (x,None,t) env) c0 | t -> t in decrec env let is_arity env sigma c = match find_conclusion env sigma c with | Sort _ -> true | _ -> false (*************************************) (* Metas *) let meta_value evd mv = let rec valrec mv = match meta_opt_fvalue evd mv with | Some (b,_) -> instance evd (List.map (fun mv' -> (mv',valrec mv')) (Metaset.elements b.freemetas)) b.rebus | None -> mkMeta mv in valrec mv let meta_instance sigma b = let c_sigma = List.map (fun mv -> (mv,meta_value sigma mv)) (Metaset.elements b.freemetas) in if c_sigma = [] then b.rebus else instance sigma c_sigma b.rebus let nf_meta sigma c = meta_instance sigma (mk_freelisted c) (* Instantiate metas that create beta/iota redexes *) let meta_reducible_instance evd b = let fm = Metaset.elements b.freemetas in let metas = List.fold_left (fun l mv -> match (try meta_opt_fvalue evd mv with Not_found -> None) with | Some (g,(_,s)) -> (mv,(g.rebus,s))::l | None -> l) [] fm in let rec irec u = let u = whd_betaiota Evd.empty u in match kind_of_term u with | Case (ci,p,c,bl) when isMeta c or isCast c & isMeta (pi1 (destCast c)) -> let m = try destMeta c with e when Errors.noncritical e -> destMeta (pi1 (destCast c)) in (match try let g,s = List.assoc m metas in if isConstruct g or s <> CoerceToType then Some g else None with Not_found -> None with | Some g -> irec (mkCase (ci,p,g,bl)) | None -> mkCase (ci,irec p,c,Array.map irec bl)) | App (f,l) when isMeta f or isCast f & isMeta (pi1 (destCast f)) -> let m = try destMeta f with e when Errors.noncritical e -> destMeta (pi1 (destCast f)) in (match try let g,s = List.assoc m metas in if isLambda g or s <> CoerceToType then Some g else None with Not_found -> None with | Some g -> irec (mkApp (g,l)) | None -> mkApp (f,Array.map irec l)) | Meta m -> (try let g,s = List.assoc m metas in if s<>CoerceToType then irec g else u with Not_found -> u) | _ -> map_constr irec u in if fm = [] then (* nf_betaiota? *) b.rebus else irec b.rebus let head_unfold_under_prod ts env _ c = let unfold cst = if Cpred.mem cst (snd ts) then match constant_opt_value env cst with | Some c -> c | None -> mkConst cst else mkConst cst in let rec aux c = match kind_of_term c with | Prod (n,t,c) -> mkProd (n,aux t, aux c) | _ -> let (h,l) = decompose_app c in match kind_of_term h with | Const cst -> beta_applist (unfold cst,l) | _ -> c in aux c coq-8.4pl4/pretyping/evarutil.mli0000644000175000017500000002222712326224777016217 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* metavariable val mk_new_meta : unit -> constr (** [new_untyped_evar] is a generator of unique evar keys *) val new_untyped_evar : unit -> existential_key (** {6 Creating a fresh evar given their type and context} *) val new_evar : evar_map -> env -> ?src:loc * hole_kind -> ?filter:bool list -> ?candidates:constr list -> types -> evar_map * constr (** the same with side-effects *) val e_new_evar : evar_map ref -> env -> ?src:loc * hole_kind -> ?filter:bool list -> ?candidates:constr list -> types -> constr (** Create a new Type existential variable, as we keep track of them during type-checking and unification. *) val new_type_evar : ?src:loc * hole_kind -> ?filter:bool list -> evar_map -> env -> evar_map * constr (** Create a fresh evar in a context different from its definition context: [new_evar_instance sign evd ty inst] creates a new evar of context [sign] and type [ty], [inst] is a mapping of the evar context to the context where the evar should occur. This means that the terms of [inst] are typed in the occurrence context and their type (seen as a telescope) is [sign] *) val new_evar_instance : named_context_val -> evar_map -> types -> ?src:loc * hole_kind -> ?filter:bool list -> ?candidates:constr list -> constr list -> evar_map * constr val make_pure_subst : evar_info -> constr array -> (identifier * constr) list (** {6 Instantiate evars} *) type conv_fun = env -> evar_map -> conv_pb -> constr -> constr -> evar_map * bool (** [evar_define choose env ev c] try to instantiate [ev] with [c] (typed in [env]), possibly solving related unification problems, possibly leaving open some problems that cannot be solved in a unique way (except if choose is true); fails if the instance is not valid for the given [ev] *) val evar_define : conv_fun -> ?choose:bool -> env -> evar_map -> existential -> constr -> evar_map (** {6 Evars/Metas switching...} *) (** [evars_to_metas] generates new metavariables for each non dependent existential and performs the replacement in the given constr; it also returns the evar_map extended with dependent evars *) val evars_to_metas : evar_map -> open_constr -> (evar_map * constr) val non_instantiated : evar_map -> (evar * evar_info) list (** {6 Unification utils} *) (** [head_evar c] returns the head evar of [c] if any *) exception NoHeadEvar val head_evar : constr -> existential_key (** may raise NoHeadEvar *) (* Expand head evar if any *) val whd_head_evar : evar_map -> constr -> constr val is_ground_term : evar_map -> constr -> bool val is_ground_env : evar_map -> env -> bool val solve_refl : ?can_drop:bool -> conv_fun -> env -> evar_map -> existential_key -> constr array -> constr array -> evar_map val solve_evar_evar : ?force:bool -> (env -> evar_map -> existential -> constr -> evar_map) -> conv_fun -> env -> evar_map -> existential -> existential -> evar_map val solve_simple_eqn : conv_fun -> ?choose:bool -> env -> evar_map -> bool option * existential * constr -> evar_map * bool val reconsider_conv_pbs : conv_fun -> evar_map -> evar_map * bool (** [check_evars env initial_sigma extended_sigma c] fails if some new unresolved evar remains in [c] *) val check_evars : env -> evar_map -> evar_map -> constr -> unit val define_evar_as_product : evar_map -> existential -> evar_map * types val define_evar_as_lambda : env -> evar_map -> existential -> evar_map * types val define_evar_as_sort : evar_map -> existential -> evar_map * sorts val is_unification_pattern_evar : env -> evar_map -> existential -> constr list -> constr -> constr list option val is_unification_pattern : env * int -> evar_map -> constr -> constr list -> constr -> constr list option val evar_absorb_arguments : env -> evar_map -> existential -> constr list -> evar_map * existential val solve_pattern_eqn : env -> constr list -> constr -> constr (** The following functions return the set of evars immediately contained in the object, including defined evars *) val evars_of_term : constr -> Intset.t val evars_of_named_context : named_context -> Intset.t val evars_of_evar_info : evar_info -> Intset.t (** [gather_dependent_evars evm seeds] classifies the evars in [evm] as dependent_evars and goals (these may overlap). A goal is an evar in [seeds] or an evar appearing in the (partial) definition of a goal. A dependent evar is an evar appearing in the type (hypotheses and conclusion) of a goal, or in the type or (partial) definition of a dependent evar. The value return is a map associating to each dependent evar [None] if it has no (partial) definition or [Some s] if [s] is the list of evars appearing in its (partial) definition. *) val gather_dependent_evars : evar_map -> evar list -> (Intset.t option) Intmap.t (** The following functions return the set of undefined evars contained in the object, the defined evars being traversed. This is roughly a combination of the previous functions and [nf_evar]. *) val undefined_evars_of_term : evar_map -> constr -> Intset.t val undefined_evars_of_named_context : evar_map -> named_context -> Intset.t val undefined_evars_of_evar_info : evar_map -> evar_info -> Intset.t (** {6 Value/Type constraints} *) val judge_of_new_Type : evar_map -> evar_map * unsafe_judgment type type_constraint_type = (int * int) option * constr type type_constraint = type_constraint_type option type val_constraint = constr option val empty_tycon : type_constraint val mk_tycon_type : constr -> type_constraint_type val mk_abstr_tycon_type : int -> constr -> type_constraint_type val mk_tycon : constr -> type_constraint val mk_abstr_tycon : int -> constr -> type_constraint val empty_valcon : val_constraint val mk_valcon : constr -> val_constraint val split_tycon : loc -> env -> evar_map -> type_constraint -> evar_map * (name * type_constraint * type_constraint) val valcon_of_tycon : type_constraint -> val_constraint val lift_abstr_tycon_type : int -> type_constraint_type -> type_constraint_type val lift_tycon_type : int -> type_constraint_type -> type_constraint_type val lift_tycon : int -> type_constraint -> type_constraint (***********************************************************) (** [flush_and_check_evars] raise [Uninstantiated_evar] if an evar remains uninstantiated; [nf_evar] leaves uninstantiated evars as is *) val nf_evar : evar_map -> constr -> constr val j_nf_evar : evar_map -> unsafe_judgment -> unsafe_judgment val jl_nf_evar : evar_map -> unsafe_judgment list -> unsafe_judgment list val jv_nf_evar : evar_map -> unsafe_judgment array -> unsafe_judgment array val tj_nf_evar : evar_map -> unsafe_type_judgment -> unsafe_type_judgment val nf_named_context_evar : evar_map -> named_context -> named_context val nf_rel_context_evar : evar_map -> rel_context -> rel_context val nf_env_evar : evar_map -> env -> env val nf_evar_info : evar_map -> evar_info -> evar_info val nf_evar_map : evar_map -> evar_map val nf_evar_map_undefined : evar_map -> evar_map (** Replacing all evars, possibly raising [Uninstantiated_evar] *) exception Uninstantiated_evar of existential_key val flush_and_check_evars : evar_map -> constr -> constr (** Replace the vars and rels that are aliases to other vars and rels by their representative that is most ancient in the context *) val expand_vars_in_term : env -> constr -> constr (** {6 debug pretty-printer:} *) val pr_tycon_type : env -> type_constraint_type -> Pp.std_ppcmds val pr_tycon : env -> type_constraint -> Pp.std_ppcmds (** {6 Removing hyps in evars'context} raise OccurHypInSimpleClause if the removal breaks dependencies *) type clear_dependency_error = | OccurHypInSimpleClause of identifier option | EvarTypingBreak of existential exception ClearDependencyError of identifier * clear_dependency_error (* spiwack: marks an evar that has been "defined" by clear. used by [Goal] and (indirectly) [Proofview] to handle the clear tactic gracefully*) val cleared : bool Store.Field.t val clear_hyps_in_evi : evar_map ref -> named_context_val -> types -> identifier list -> named_context_val * types val push_rel_context_to_named_context : Environ.env -> types -> named_context_val * types * constr list * constr list val generalize_evar_over_rels : evar_map -> existential -> types * constr list val check_evar_instance : evar_map -> existential_key -> constr -> conv_fun -> evar_map val remove_instance_local_defs : evar_map -> existential_key -> constr list -> constr list coq-8.4pl4/pretyping/coercion.mli0000644000175000017500000000607712326224777016172 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment (** [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it inserts a coercion into [j], if needed, in such a way it gets as type a sort; it fails if no coercion is applicable *) val inh_coerce_to_sort : loc -> env -> evar_map -> unsafe_judgment -> evar_map * unsafe_type_judgment (** [inh_coerce_to_base env isevars j] coerces [j] to its base type; i.e. it inserts a coercion into [j], if needed, in such a way it gets as type its base type (the notion depends on the coercion system) *) val inh_coerce_to_base : loc -> env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment (** [inh_coerce_to_prod env isevars t] coerces [t] to a product type *) val inh_coerce_to_prod : loc -> env -> evar_map -> type_constraint_type -> evar_map * type_constraint_type (** [inh_conv_coerce_to resolve_tc loc env isevars j t] coerces [j] to an object of type [t]; i.e. it inserts a coercion into [j], if needed, in such a way [t] and [j.uj_type] are convertible; it fails if no coercion is applicable. resolve_tc=false disables resolving type classes (as the last resort before failing) *) val inh_conv_coerce_to : bool -> loc -> env -> evar_map -> unsafe_judgment -> type_constraint_type -> evar_map * unsafe_judgment val inh_conv_coerce_rigid_to : bool -> loc -> env -> evar_map -> unsafe_judgment -> type_constraint_type -> evar_map * unsafe_judgment (** [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t] is coercible to an object of type [t'] adding evar constraints if needed; it fails if no coercion exists *) val inh_conv_coerces_to : loc -> env -> evar_map -> types -> type_constraint_type -> evar_map (** [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases pattern [pat] typed in [ind1] into a pattern typed in [ind2]; raises [Not_found] if no coercion found *) val inh_pattern_coerce_to : loc -> cases_pattern -> inductive -> inductive -> cases_pattern end module Default : S coq-8.4pl4/pretyping/arguments_renaming.ml0000644000175000017500000000737412326224777020106 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* !name_table); Summary.unfreeze_function = (fun r -> name_table := r); Summary.init_function = (fun () -> name_table := empty_name_table) } type req = | ReqLocal | ReqGlobal of global_reference * name list list let load_rename_args _ (_, (_, (r, names))) = name_table := Refmap.add r names !name_table let cache_rename_args o = load_rename_args 1 o let classify_rename_args = function | ReqLocal, _ -> Dispose | ReqGlobal _, _ as o -> Substitute o let subst_rename_args (subst, (_, (r, names as orig))) = ReqLocal, let r' = fst (subst_global subst r) in if r==r' then orig else (r', names) let section_segment_of_reference = function | ConstRef con -> Lib.section_segment_of_constant con | IndRef (kn,_) | ConstructRef ((kn,_),_) -> Lib.section_segment_of_mutual_inductive kn | _ -> [] let discharge_rename_args = function | _, (ReqGlobal (c, names), _ as req) -> (try let vars = section_segment_of_reference c in let c' = pop_global_reference c in let var_names = List.map (fun (id, _,_,_) -> Name id) vars in let names' = List.map (fun l -> var_names @ l) names in Some (ReqGlobal (c', names), (c', names')) with Not_found -> Some req) | _ -> None let rebuild_rename_args x = x let inRenameArgs = declare_object { (default_object "RENAME-ARGUMENTS" ) with load_function = load_rename_args; cache_function = cache_rename_args; classify_function = classify_rename_args; subst_function = subst_rename_args; discharge_function = discharge_rename_args; rebuild_function = rebuild_rename_args; } let rename_arguments local r names = let req = if local then ReqLocal else ReqGlobal (r, names) in Lib.add_anonymous_leaf (inRenameArgs (req, (r, names))) let arguments_names r = Refmap.find r !name_table let rec rename_prod c = function | [] -> c | (Name _ as n) :: tl -> (match kind_of_type c with | ProdType (_, s, t) -> mkProd (n, s, rename_prod t tl) | _ -> c) | _ :: tl -> match kind_of_type c with | ProdType (n, s, t) -> mkProd (n, s, rename_prod t tl) | _ -> c let rename_type ty ref = try rename_prod ty (List.hd (arguments_names ref)) with Not_found -> ty let rename_type_of_constant env c = let ty = Typeops.type_of_constant env c in rename_type ty (ConstRef c) let rename_type_of_inductive env ind = let ty = Inductiveops.type_of_inductive env ind in rename_type ty (IndRef ind) let rename_type_of_constructor env cstruct = let ty = Inductiveops.type_of_constructor env cstruct in rename_type ty (ConstructRef cstruct) let rename_typing env c = let j = Typeops.typing env c in match kind_of_term c with | Const c -> { j with uj_type = rename_type j.uj_type (ConstRef c) } | Ind i -> { j with uj_type = rename_type j.uj_type (IndRef i) } | Construct k -> { j with uj_type = rename_type j.uj_type (ConstructRef k) } | _ -> j coq-8.4pl4/pretyping/classops.ml0000644000175000017500000003235412326224777016044 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int * cl_info_typ *) let class_info cl = Bijint.revmap cl !class_tab let class_exists cl = Bijint.mem cl !class_tab (* class_info_from_index : int -> cl_typ * cl_info_typ *) let class_info_from_index i = Bijint.map i !class_tab let cl_fun_index = fst(class_info CL_FUN) let cl_sort_index = fst(class_info CL_SORT) (* coercion_info : coe_typ -> coe_info_typ *) let coercion_info coe = Gmap.find coe !coercion_tab let coercion_exists coe = Gmap.mem coe !coercion_tab (* find_class_type : evar_map -> constr -> cl_typ * constr list *) let find_class_type sigma t = let t', args = Reductionops.whd_betaiotazeta_stack sigma t in match kind_of_term t' with | Var id -> CL_SECVAR id, args | Const sp -> CL_CONST sp, args | Ind ind_sp -> CL_IND ind_sp, args | Prod (_,_,_) -> CL_FUN, [] | Sort _ -> CL_SORT, [] | _ -> raise Not_found let subst_cl_typ subst ct = match ct with CL_SORT | CL_FUN | CL_SECVAR _ -> ct | CL_CONST kn -> let kn',t = subst_con subst kn in if kn' == kn then ct else fst (find_class_type Evd.empty t) | CL_IND (kn,i) -> let kn' = subst_ind subst kn in if kn' == kn then ct else CL_IND (kn',i) (*CSC: here we should change the datatype for coercions: it should be possible to declare any term as a coercion *) let subst_coe_typ subst t = fst (subst_global subst t) (* class_of : Term.constr -> int *) let class_of env sigma t = let (t, n1, i, args) = try let (cl,args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in (t, n1, i, args) with Not_found -> let t = Tacred.hnf_constr env sigma t in let (cl, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in (t, n1, i, args) in if List.length args = n1 then t, i else raise Not_found let inductive_class_of ind = fst (class_info (CL_IND ind)) let class_args_of env sigma c = snd (find_class_type sigma c) let string_of_class = function | CL_FUN -> "Funclass" | CL_SORT -> "Sortclass" | CL_CONST sp -> string_of_qualid (shortest_qualid_of_global Idset.empty (ConstRef sp)) | CL_IND sp -> string_of_qualid (shortest_qualid_of_global Idset.empty (IndRef sp)) | CL_SECVAR sp -> string_of_qualid (shortest_qualid_of_global Idset.empty (VarRef sp)) let pr_class x = str (string_of_class x) (* lookup paths *) let lookup_path_between_class (s,t) = Gmap.find (s,t) !inheritance_graph let lookup_path_to_fun_from_class s = lookup_path_between_class (s,cl_fun_index) let lookup_path_to_sort_from_class s = lookup_path_between_class (s,cl_sort_index) (* advanced path lookup *) let apply_on_class_of env sigma t cont = try let (cl,args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in if List.length args <> n1 then raise Not_found; t, cont i with Not_found -> (* Is it worth to be more incremental on the delta steps? *) let t = Tacred.hnf_constr env sigma t in let (cl, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in if List.length args <> n1 then raise Not_found; t, cont i let lookup_path_between env sigma (s,t) = let (s,(t,p)) = apply_on_class_of env sigma s (fun i -> apply_on_class_of env sigma t (fun j -> lookup_path_between_class (i,j))) in (s,t,p) let lookup_path_to_fun_from env sigma s = apply_on_class_of env sigma s lookup_path_to_fun_from_class let lookup_path_to_sort_from env sigma s = apply_on_class_of env sigma s lookup_path_to_sort_from_class let get_coercion_constructor coe = let c, _ = Reductionops.whd_betadeltaiota_stack (Global.env()) Evd.empty coe.coe_value in match kind_of_term c with | Construct cstr -> (cstr, Inductiveops.constructor_nrealargs (Global.env()) cstr -1) | _ -> raise Not_found let lookup_pattern_path_between (s,t) = let i = inductive_class_of s in let j = inductive_class_of t in List.map get_coercion_constructor (Gmap.find (i,j) !inheritance_graph) (* coercion_value : coe_index -> unsafe_judgment * bool *) let coercion_value { coe_value = c; coe_type = t; coe_is_identity = b } = (make_judge c t, b) (* pretty-print functions are now in Pretty *) (* rajouter une coercion dans le graphe *) let path_printer = ref (fun _ -> str "" : (int * int) * inheritance_path -> std_ppcmds) let install_path_printer f = path_printer := f let print_path x = !path_printer x let message_ambig l = (str"Ambiguous paths:" ++ spc () ++ prlist_with_sep pr_fnl (fun ijp -> print_path ijp) l) (* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit coercion,source,target *) let different_class_params i j = (snd (class_info_from_index i)).cl_param > 0 let add_coercion_in_graph (ic,source,target) = let old_inheritance_graph = !inheritance_graph in let ambig_paths = (ref [] : ((cl_index * cl_index) * inheritance_path) list ref) in let try_add_new_path (i,j as ij) p = try if i=j then begin if different_class_params i j then begin let _ = lookup_path_between_class ij in ambig_paths := (ij,p)::!ambig_paths end end else begin let _ = lookup_path_between_class (i,j) in ambig_paths := (ij,p)::!ambig_paths end; false with Not_found -> begin add_new_path ij p; true end in let try_add_new_path1 ij p = let _ = try_add_new_path ij p in () in if try_add_new_path (source,target) [ic] then begin Gmap.iter (fun (s,t) p -> if s<>t then begin if t = source then begin try_add_new_path1 (s,target) (p@[ic]); Gmap.iter (fun (u,v) q -> if u<>v & u = target && not (list_equal coe_info_typ_equal p q) then try_add_new_path1 (s,v) (p@[ic]@q)) old_inheritance_graph end; if s = target then try_add_new_path1 (source,t) (ic::p) end) old_inheritance_graph end; if (!ambig_paths <> []) && is_verbose () then ppnl (message_ambig !ambig_paths) type coercion = coe_typ * locality * bool * cl_typ * cl_typ * int (* Calcul de l'arité d'une classe *) let reference_arity_length ref = let t = Global.type_of_global ref in List.length (fst (Reductionops.splay_arity (Global.env()) Evd.empty t)) let class_params = function | CL_FUN | CL_SORT -> 0 | CL_CONST sp -> reference_arity_length (ConstRef sp) | CL_SECVAR sp -> reference_arity_length (VarRef sp) | CL_IND sp -> reference_arity_length (IndRef sp) (* add_class : cl_typ -> locality_flag option -> bool -> unit *) let add_class cl = add_new_class cl { cl_param = class_params cl } let automatically_import_coercions = ref false open Goptions let _ = declare_bool_option { optsync = true; optdepr = false; optname = "automatic import of coercions"; optkey = ["Automatic";"Coercions";"Import"]; optread = (fun () -> !automatically_import_coercions); optwrite = (:=) automatically_import_coercions } let cache_coercion (_,(coe,stre,isid,cls,clt,ps)) = add_class cls; add_class clt; let is,_ = class_info cls in let it,_ = class_info clt in let xf = { coe_value = constr_of_global coe; coe_type = Global.type_of_global coe; coe_strength = stre; coe_is_identity = isid; coe_param = ps } in add_new_coercion coe xf; add_coercion_in_graph (xf,is,it) let load_coercion _ o = if !automatically_import_coercions || Flags.version_less_or_equal Flags.V8_2 then cache_coercion o let open_coercion i o = if i = 1 && not (!automatically_import_coercions || Flags.version_less_or_equal Flags.V8_2) then cache_coercion o let subst_coercion (subst,(coe,stre,isid,cls,clt,ps as obj)) = let coe' = subst_coe_typ subst coe in let cls' = subst_cl_typ subst cls in let clt' = subst_cl_typ subst clt in if coe' == coe && cls' == cls & clt' == clt then obj else (coe',stre,isid,cls',clt',ps) let discharge_cl = function | CL_CONST kn -> CL_CONST (Lib.discharge_con kn) | CL_IND ind -> CL_IND (Lib.discharge_inductive ind) | cl -> cl let discharge_coercion (_,(coe,stre,isid,cls,clt,ps)) = if stre = Local then None else let n = try Array.length (Lib.section_instance coe) with Not_found -> 0 in Some (Lib.discharge_global coe, stre, isid, discharge_cl cls, discharge_cl clt, n + ps) let classify_coercion (coe,stre,isid,cls,clt,ps as obj) = if stre = Local then Dispose else Substitute obj type coercion_obj = coe_typ * Decl_kinds.locality * bool * cl_typ * cl_typ * int let inCoercion : coercion_obj -> obj = declare_object {(default_object "COERCION") with open_function = open_coercion; load_function = load_coercion; cache_function = cache_coercion; subst_function = subst_coercion; classify_function = classify_coercion; discharge_function = discharge_coercion } let declare_coercion coef stre ~isid ~src:cls ~target:clt ~params:ps = Lib.add_anonymous_leaf (inCoercion (coef,stre,isid,cls,clt,ps)) (* For printing purpose *) let get_coercion_value v = v.coe_value let pr_cl_index n = int n let classes () = Bijint.dom !class_tab let coercions () = Gmap.rng !coercion_tab let inheritance_graph () = Gmap.to_list !inheritance_graph let coercion_of_reference r = let ref = Nametab.global r in if not (coercion_exists ref) then errorlabstrm "try_add_coercion" (Nametab.pr_global_env Idset.empty ref ++ str" is not a coercion."); ref module CoercionPrinting = struct type t = coe_typ let encode = coercion_of_reference let subst = subst_coe_typ let printer x = pr_global_env Idset.empty x let key = ["Printing";"Coercion"] let title = "Explicitly printed coercions: " let member_message x b = str "Explicit printing of coercion " ++ printer x ++ str (if b then " is set" else " is unset") let synchronous = true end module PrintingCoercion = Goptions.MakeRefTable(CoercionPrinting) let hide_coercion coe = if not (PrintingCoercion.active coe) then let coe_info = coercion_info coe in Some coe_info.coe_param else None coq-8.4pl4/pretyping/retyping.mli0000644000175000017500000000323612326224777016224 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ?refresh:bool -> env -> evar_map -> constr -> types val get_sort_of : ?polyprop:bool -> env -> evar_map -> types -> sorts val get_sort_family_of : ?polyprop:bool -> env -> evar_map -> types -> sorts_family (** Makes an assumption from a constr *) val get_assumption_of : env -> evar_map -> constr -> types (** Makes an unsafe judgment from a constr *) val get_judgment_of : env -> evar_map -> constr -> unsafe_judgment val type_of_global_reference_knowing_parameters : env -> evar_map -> constr -> constr array -> types val type_of_global_reference_knowing_conclusion : env -> evar_map -> constr -> types -> types coq-8.4pl4/pretyping/arguments_renaming.mli0000644000175000017500000000174312326224777020251 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* global_reference -> name list list -> unit (** [Not_found] is raised is no names are defined for [r] *) val arguments_names : global_reference -> name list list val rename_type_of_constant : env -> constant -> types val rename_type_of_inductive : env -> inductive -> types val rename_type_of_constructor : env -> constructor -> types val rename_typing : env -> constr -> unsafe_judgment coq-8.4pl4/pretyping/tacred.mli0000644000175000017500000000721412326224777015625 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* evaluable_global_reference -> bool val error_not_evaluable : Libnames.global_reference -> 'a val evaluable_of_global_reference : Environ.env -> Libnames.global_reference -> evaluable_global_reference val global_of_evaluable_reference : evaluable_global_reference -> Libnames.global_reference exception Redelimination (** Red (raise user error if nothing reducible) *) val red_product : reduction_function (** Red (raise Redelimination if nothing reducible) *) val try_red_product : reduction_function (** Tune the behaviour of simpl for the given constant name *) type simpl_flag = [ `SimplDontExposeCase | `SimplNeverUnfold ] val set_simpl_behaviour : bool -> global_reference -> (int list * int * simpl_flag list) -> unit val get_simpl_behaviour : global_reference -> (int list * int * simpl_flag list) option (** Simpl *) val simpl : reduction_function (** Simpl only at the head *) val whd_simpl : reduction_function (** Hnf: like whd_simpl but force delta-reduction of constants that do not immediately hide a non reducible fix or cofix *) val hnf_constr : reduction_function (** Unfold *) val unfoldn : (occurrences * evaluable_global_reference) list -> reduction_function (** Fold *) val fold_commands : constr list -> reduction_function (** Pattern *) val pattern_occs : (occurrences * constr) list -> reduction_function (** Rem: Lazy strategies are defined in Reduction *) (** Call by value strategy (uses Closures) *) val cbv_norm_flags : Closure.RedFlags.reds -> reduction_function val cbv_beta : local_reduction_function val cbv_betaiota : local_reduction_function val cbv_betadeltaiota : reduction_function val compute : reduction_function (** = [cbv_betadeltaiota] *) (** [reduce_to_atomic_ind env sigma t] puts [t] in the form [t'=(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) val reduce_to_atomic_ind : env -> evar_map -> types -> inductive * types (** [reduce_to_quantified_ind env sigma t] puts [t] in the form [t'=(x1:A1)..(xn:An)(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) val reduce_to_quantified_ind : env -> evar_map -> types -> inductive * types (** [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form [t'=(x1:A1)..(xn:An)(ref args)] and fails with user error if not possible *) val reduce_to_quantified_ref : env -> evar_map -> global_reference -> types -> types val reduce_to_atomic_ref : env -> evar_map -> global_reference -> types -> types val find_hnf_rectype : env -> evar_map -> types -> inductive * constr list val contextually : bool -> occurrences * constr_pattern -> (patvar_map -> reduction_function) -> reduction_function coq-8.4pl4/pretyping/evd.mli0000644000175000017500000002630712326224777015145 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool) -> Metaset.t -> bool type 'a freelisted = { rebus : 'a; freemetas : Metaset.t } val metavars_of : constr -> Metaset.t val mk_freelisted : constr -> constr freelisted val map_fl : ('a -> 'b) -> 'a freelisted -> 'b freelisted (** Status of an instance found by unification wrt to the meta it solves: - a supertype of the meta (e.g. the solution to ?X <= T is a supertype of ?X) - a subtype of the meta (e.g. the solution to T <= ?X is a supertype of ?X) - a term that can be eta-expanded n times while still being a solution (e.g. the solution [P] to [?X u v = P u v] can be eta-expanded twice) *) type instance_constraint = IsSuperType | IsSubType | Conv (** Status of the unification of the type of an instance against the type of the meta it instantiates: - CoerceToType means that the unification of types has not been done and that a coercion can still be inserted: the meta should not be substituted freely (this happens for instance given via the "with" binding clause). - TypeProcessed means that the information obtainable from the unification of types has been extracted. - TypeNotProcessed means that the unification of types has not been done but it is known that no coercion may be inserted: the meta can be substituted freely. *) type instance_typing_status = CoerceToType | TypeNotProcessed | TypeProcessed (** Status of an instance together with the status of its type unification *) type instance_status = instance_constraint * instance_typing_status (** Clausal environments *) type clbinding = | Cltyp of name * constr freelisted | Clval of name * (constr freelisted * instance_status) * constr freelisted val map_clb : (constr -> constr) -> clbinding -> clbinding (******************************************************************** ** Kinds of existential variables ***) (** Should the obligation be defined (opaque or transparent (default)) or defined transparent and expanded in the term? *) type obligation_definition_status = Define of bool | Expand (** Evars *) type hole_kind = | ImplicitArg of global_reference * (int * identifier option) * bool (** Force inference *) | BinderType of name | QuestionMark of obligation_definition_status | CasesType | InternalHole | TomatchTypeParameter of inductive * int | GoalEvar | ImpossibleCase | MatchingVar of bool * identifier (******************************************************************** ** Existential variables and unification states ***) (** A unification state (of type [evar_map]) is primarily a finite mapping from existential variables to records containing the type of the evar ([evar_concl]), the context under which it was introduced ([evar_hyps]) and its definition ([evar_body]). [evar_extra] is used to add any other kind of information. It also contains conversion constraints, debugging information and information about meta variables. *) (** Information about existential variables. *) type evar = existential_key val string_of_existential : evar -> string val existential_of_int : int -> evar type evar_body = | Evar_empty | Evar_defined of constr type evar_info = { evar_concl : constr; evar_hyps : named_context_val; evar_body : evar_body; evar_filter : bool list; evar_source : hole_kind located; evar_candidates : constr list option; evar_extra : Store.t } val eq_evar_info : evar_info -> evar_info -> bool val make_evar : named_context_val -> types -> evar_info val evar_concl : evar_info -> constr val evar_context : evar_info -> named_context val evar_filtered_context : evar_info -> named_context val evar_hyps : evar_info -> named_context_val val evar_filtered_hyps : evar_info -> named_context_val val evar_body : evar_info -> evar_body val evar_filter : evar_info -> bool list val evar_unfiltered_env : evar_info -> env val evar_env : evar_info -> env (*** Unification state ***) type evar_map (** Unification state and existential variables *) (** Assuming that the second map extends the first one, this says if some existing evar has been refined *) val progress_evar_map : evar_map -> evar_map -> bool val empty : evar_map val is_empty : evar_map -> bool (** [has_undefined sigma] is [true] if and only if there are uninstantiated evars in [sigma]. *) val has_undefined : evar_map -> bool (** [add sigma ev info] adds [ev] with evar info [info] in sigma. Precondition: ev must not preexist in [sigma]. *) val add : evar_map -> evar -> evar_info -> evar_map val find : evar_map -> evar -> evar_info val find_undefined : evar_map -> evar -> evar_info val remove : evar_map -> evar -> evar_map val mem : evar_map -> evar -> bool val undefined_list : evar_map -> (evar * evar_info) list val to_list : evar_map -> (evar * evar_info) list val fold : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a val fold_undefined : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a val merge : evar_map -> evar_map -> evar_map val define : evar -> constr -> evar_map -> evar_map val is_evar : evar_map -> evar -> bool val is_defined : evar_map -> evar -> bool val is_undefined : evar_map -> evar -> bool val add_constraints : evar_map -> Univ.constraints -> evar_map (** {6 ... } *) (** [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has no body and [Not_found] if it does not exist in [sigma] *) exception NotInstantiatedEvar val existential_value : evar_map -> existential -> constr val existential_type : evar_map -> existential -> types val existential_opt_value : evar_map -> existential -> constr option val instantiate_evar : named_context -> constr -> constr list -> constr (** Assume empty universe constraints in [evar_map] and [conv_pbs] *) val subst_evar_defs_light : substitution -> evar_map -> evar_map (** spiwack: this function seems to somewhat break the abstraction. *) val evars_reset_evd : ?with_conv_pbs:bool -> evar_map -> evar_map -> evar_map (* spiwack: [is_undefined_evar] should be considered a candidate for moving to evarutils *) val is_undefined_evar : evar_map -> constr -> bool val undefined_evars : evar_map -> evar_map val defined_evars : evar_map -> evar_map (* [fold_undefined f m] iterates ("folds") function [f] over the undefined evars (that is, whose value is [Evar_empty]) of map [m]. It optimizes the call of {!Evd.fold} to [f] and [undefined_evars m] *) val fold_undefined : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a val evar_declare : named_context_val -> evar -> types -> ?src:loc * hole_kind -> ?filter:bool list -> ?candidates:constr list -> evar_map -> evar_map val evar_source : existential_key -> evar_map -> hole_kind located (* spiwack: this function seems to somewhat break the abstraction. [evar_merge evd ev1] extends the evars of [evd] with [evd1] *) val evar_merge : evar_map -> evar_map -> evar_map (** Unification constraints *) type conv_pb = Reduction.conv_pb type evar_constraint = conv_pb * env * constr * constr val add_conv_pb : evar_constraint -> evar_map -> evar_map module ExistentialMap : Map.S with type key = existential_key module ExistentialSet : Set.S with type elt = existential_key val extract_changed_conv_pbs : evar_map -> (ExistentialSet.t -> evar_constraint -> bool) -> evar_map * evar_constraint list val extract_all_conv_pbs : evar_map -> evar_map * evar_constraint list val evar_list : evar_map -> constr -> existential list val collect_evars : constr -> ExistentialSet.t (** Metas *) val find_meta : evar_map -> metavariable -> clbinding val meta_list : evar_map -> (metavariable * clbinding) list val meta_defined : evar_map -> metavariable -> bool (** [meta_fvalue] raises [Not_found] if meta not in map or [Anomaly] if meta has no value *) val meta_value : evar_map -> metavariable -> constr val meta_fvalue : evar_map -> metavariable -> constr freelisted * instance_status val meta_opt_fvalue : evar_map -> metavariable -> (constr freelisted * instance_status) option val meta_type : evar_map -> metavariable -> types val meta_ftype : evar_map -> metavariable -> types freelisted val meta_name : evar_map -> metavariable -> name val meta_with_name : evar_map -> identifier -> metavariable val meta_declare : metavariable -> types -> ?name:name -> evar_map -> evar_map val meta_assign : metavariable -> constr * instance_status -> evar_map -> evar_map val meta_reassign : metavariable -> constr * instance_status -> evar_map -> evar_map (** [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *) val meta_merge : evar_map -> evar_map -> evar_map val undefined_metas : evar_map -> metavariable list val metas_of : evar_map -> meta_type_map val map_metas_fvalue : (constr -> constr) -> evar_map -> evar_map type metabinding = metavariable * constr * instance_status val retract_coercible_metas : evar_map -> metabinding list * evar_map val subst_defined_metas : metabinding list -> constr -> constr option (********************************************************* Sort variables *) val new_univ_variable : evar_map -> evar_map * Univ.universe val new_sort_variable : evar_map -> evar_map * sorts val is_sort_variable : evar_map -> sorts -> bool val whd_sort_variable : evar_map -> constr -> constr val set_leq_sort : evar_map -> sorts -> sorts -> evar_map val set_eq_sort : evar_map -> sorts -> sorts -> evar_map (******************************************************************** constr with holes *) type open_constr = evar_map * constr (******************************************************************** The type constructor ['a sigma] adds an evar map to an object of type ['a] *) type 'a sigma = { it : 'a ; sigma : evar_map} val sig_it : 'a sigma -> 'a val sig_sig : 'a sigma -> evar_map (********************************************************* Failure explanation *) type unsolvability_explanation = SeveralInstancesFound of int (******************************************************************** debug pretty-printer: *) val pr_evar_info : evar_info -> Pp.std_ppcmds val pr_evar_map_constraints : evar_map -> Pp.std_ppcmds val pr_evar_map : int option -> evar_map -> Pp.std_ppcmds val pr_metaset : Metaset.t -> Pp.std_ppcmds (*** /!\Deprecated /!\ ** create an [evar_map] with empty meta map: *) val create_evar_defs : evar_map -> evar_map val create_goal_evar_defs : evar_map -> evar_map val is_defined_evar : evar_map -> existential -> bool val subst_evar_map : substitution -> evar_map -> evar_map (*** /Deprecaded ***) coq-8.4pl4/pretyping/glob_term.mli0000644000175000017500000001327012326224777016334 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* loc type patvar = identifier type glob_sort = GProp of Term.contents | GType of Univ.universe option type binding_kind = Lib.binding_kind = Explicit | Implicit type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list type 'a bindings = | ImplicitBindings of 'a list | ExplicitBindings of 'a explicit_bindings | NoBindings type 'a with_bindings = 'a * 'a bindings type 'a cast_type = | CastConv of cast_kind * 'a | CastCoerce (** Cast to a base type (eg, an underlying inductive type) *) type glob_constr = | GRef of (loc * global_reference) | GVar of (loc * identifier) | GEvar of loc * existential_key * glob_constr list option | GPatVar of loc * (bool * patvar) (** Used for patterns only *) | GApp of loc * glob_constr * glob_constr list | GLambda of loc * name * binding_kind * glob_constr * glob_constr | GProd of loc * name * binding_kind * glob_constr * glob_constr | GLetIn of loc * name * glob_constr * glob_constr | GCases of loc * case_style * glob_constr option * tomatch_tuples * cases_clauses (** [GCases(l,style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in [MatchStyle]) *) | GLetTuple of loc * name list * (name * glob_constr option) * glob_constr * glob_constr | GIf of loc * glob_constr * (name * glob_constr option) * glob_constr * glob_constr | GRec of loc * fix_kind * identifier array * glob_decl list array * glob_constr array * glob_constr array | GSort of loc * glob_sort | GHole of (loc * Evd.hole_kind) | GCast of loc * glob_constr * glob_constr cast_type and glob_decl = name * binding_kind * glob_constr option * glob_constr and fix_recursion_order = GStructRec | GWfRec of glob_constr | GMeasureRec of glob_constr * glob_constr option and fix_kind = | GFix of ((int option * fix_recursion_order) array * int) | GCoFix of int and predicate_pattern = name * (loc * inductive * int * name list) option (** [(na,id)] = "as 'na' in 'id'" where if [id] is [Some(l,I,k,args)], [k] is the number of parameter of [I]. *) and tomatch_tuple = (glob_constr * predicate_pattern) and tomatch_tuples = tomatch_tuple list and cases_clause = (loc * identifier list * cases_pattern list * glob_constr) (** [(p,il,cl,t)] = "|'cl' as 'il' => 't'" *) and cases_clauses = cases_clause list val cases_predicate_names : tomatch_tuples -> name list (* Apply one argument to a glob_constr *) val mkGApp : loc -> glob_constr -> glob_constr -> glob_constr val map_glob_constr : (glob_constr -> glob_constr) -> glob_constr -> glob_constr (* Ensure traversal from left to right *) val map_glob_constr_left_to_right : (glob_constr -> glob_constr) -> glob_constr -> glob_constr (* val map_glob_constr_with_binders_loc : loc -> (identifier -> 'a -> identifier * 'a) -> ('a -> glob_constr -> glob_constr) -> 'a -> glob_constr -> glob_constr *) val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit val occur_glob_constr : identifier -> glob_constr -> bool val free_glob_vars : glob_constr -> identifier list val loc_of_glob_constr : glob_constr -> loc (** Conversion from glob_constr to cases pattern, if possible Take the current alias as parameter, @raise Not_found if translation is impossible *) val cases_pattern_of_glob_constr : name -> glob_constr -> cases_pattern val glob_constr_of_closed_cases_pattern : cases_pattern -> name * glob_constr (** {6 Reduction expressions} *) type 'a glob_red_flag = { rBeta : bool; rIota : bool; rZeta : bool; rDelta : bool; (** true = delta all but rConst; false = delta only on rConst*) rConst : 'a list } val all_flags : 'a glob_red_flag type 'a or_var = ArgArg of 'a | ArgVar of identifier located type occurrences_expr = bool * int or_var list val all_occurrences_expr_but : int or_var list -> occurrences_expr val no_occurrences_expr_but : int or_var list -> occurrences_expr val all_occurrences_expr : occurrences_expr val no_occurrences_expr : occurrences_expr type 'a with_occurrences = occurrences_expr * 'a type ('a,'b,'c) red_expr_gen = | Red of bool | Hnf | Simpl of 'c with_occurrences option | Cbv of 'b glob_red_flag | Lazy of 'b glob_red_flag | Unfold of 'b with_occurrences list | Fold of 'a list | Pattern of 'a with_occurrences list | ExtraRedExpr of string | CbvVm type ('a,'b,'c) may_eval = | ConstrTerm of 'a | ConstrEval of ('a,'b,'c) red_expr_gen * 'a | ConstrContext of (loc * identifier) * 'a | ConstrTypeOf of 'a coq-8.4pl4/pretyping/recordops.ml0000644000175000017500000003116012326224777016207 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Cmap.add proj struc)) projs !projection_table let cache_structure o = load_structure 1 o let subst_structure (subst,((kn,i),id,kl,projs as obj)) = let kn' = subst_ind subst kn in let projs' = (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) list_smartmap (Option.smartmap (fun kn -> fst (subst_con subst kn))) projs in let id' = fst (subst_constructor subst id) in if projs' == projs && kn' == kn && id' == id then obj else ((kn',i),id',kl,projs') let discharge_constructor (ind, n) = (Lib.discharge_inductive ind, n) let discharge_structure (_,(ind,id,kl,projs)) = Some (Lib.discharge_inductive ind, discharge_constructor id, kl, List.map (Option.map Lib.discharge_con) projs) let inStruc : struc_tuple -> obj = declare_object {(default_object "STRUCTURE") with cache_function = cache_structure; load_function = load_structure; subst_function = subst_structure; classify_function = (fun x -> Substitute x); discharge_function = discharge_structure } let declare_structure (s,c,kl,pl) = Lib.add_anonymous_leaf (inStruc (s,c,kl,pl)) let lookup_structure indsp = Indmap.find indsp !structure_table let lookup_projections indsp = (lookup_structure indsp).s_PROJ let find_projection_nparams = function | ConstRef cst -> (Cmap.find cst !projection_table).s_EXPECTEDPARAM | _ -> raise Not_found let find_projection = function | ConstRef cst -> Cmap.find cst !projection_table | _ -> raise Not_found (* Management of a field store : each field + argument of the inferred * records are stored in a discrimination tree *) let subst_id s (gr,ev,evm) = (fst(subst_global s gr),ev,Evd.subst_evar_map s evm) module MethodsDnet : Term_dnet.S with type ident = global_reference * Evd.evar * Evd.evar_map = Term_dnet.Make (struct type t = global_reference * Evd.evar * Evd.evar_map let compare = Pervasives.compare let subst = subst_id let constr_of (_,ev,evm) = Evd.evar_concl (Evd.find evm ev) end) (struct let reduce c = Reductionops.head_unfold_under_prod Names.full_transparent_state (Global.env()) Evd.empty c let direction = true end) let meth_dnet = ref MethodsDnet.empty open Summary let _ = declare_summary "record-methods-state" { freeze_function = (fun () -> !meth_dnet); unfreeze_function = (fun m -> meth_dnet := m); init_function = (fun () -> meth_dnet := MethodsDnet.empty) } open Libobject let load_method (_,(ty,id)) = meth_dnet := MethodsDnet.add ty id !meth_dnet let in_method : constr * MethodsDnet.ident -> obj = declare_object { (default_object "RECMETHODS") with load_function = (fun _ -> load_method); cache_function = load_method; subst_function = (fun (s,(ty,id)) -> Mod_subst.subst_mps s ty,subst_id s id); classify_function = (fun x -> Substitute x) } let methods_matching c = MethodsDnet.search_pattern !meth_dnet c let declare_method cons ev sign = Lib.add_anonymous_leaf (in_method ((Evd.evar_concl (Evd.find sign ev)),(cons,ev,sign))) (************************************************************************) (*s A canonical structure declares "canonical" conversion hints between *) (* the effective components of a structure and the projections of the *) (* structure *) (* Table des definitions "object" : pour chaque object c, c := [x1:B1]...[xk:Bk](Build_R a1...am t1...t_n) If ti has the form (ci ui1...uir) where ci is a global reference and if the corresponding projection Li of the structure R is defined, one declare a "conversion" between ci and Li x1:B1..xk:Bk |- (Li a1..am (c x1..xk)) =_conv (ci ui1...uir) that maps the pair (Li,ci) to the following data o_DEF = c o_TABS = B1...Bk o_PARAMS = a1...am o_NARAMS = m o_TCOMP = ui1...uir *) type obj_typ = { o_DEF : constr; o_INJ : int; (* position of trivial argument (negative= none) *) o_TABS : constr list; (* ordered *) o_TPARAMS : constr list; (* ordered *) o_NPARAMS : int; o_TCOMPS : constr list } (* ordered *) type cs_pattern = Const_cs of global_reference | Prod_cs | Sort_cs of sorts_family | Default_cs let object_table = ref (Refmap.empty : (cs_pattern * obj_typ) list Refmap.t) let canonical_projections () = Refmap.fold (fun x -> List.fold_right (fun (y,c) acc -> ((x,y),c)::acc)) !object_table [] let keep_true_projections projs kinds = map_succeed (function (p,(_,true)) -> p | _ -> failwith "") (List.combine projs kinds) let cs_pattern_of_constr t = match kind_of_term t with App (f,vargs) -> begin try Const_cs (global_of_constr f) , -1, Array.to_list vargs with e when Errors.noncritical e -> raise Not_found end | Rel n -> Default_cs, pred n, [] | Prod (_,a,b) when not (Termops.dependent (mkRel 1) b) -> Prod_cs, -1, [a; Termops.pop b] | Sort s -> Sort_cs (family_of_sort s), -1, [] | _ -> begin try Const_cs (global_of_constr t) , -1, [] with e when Errors.noncritical e -> raise Not_found end (* Intended to always succeed *) let compute_canonical_projections (con,ind) = let v = mkConst con in let c = Environ.constant_value (Global.env()) con in let lt,t = Reductionops.splay_lam (Global.env()) Evd.empty c in let lt = List.rev (List.map snd lt) in let args = snd (decompose_app t) in let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = lookup_structure ind in let params, projs = list_chop p args in let lpj = keep_true_projections lpj kl in let lps = List.combine lpj projs in let comp = List.fold_left (fun l (spopt,t) -> (* comp=components *) match spopt with | Some proji_sp -> begin try let patt, n , args = cs_pattern_of_constr t in ((ConstRef proji_sp, patt, n, args) :: l) with Not_found -> if Flags.is_verbose () then (let con_pp = Nametab.pr_global_env Idset.empty (ConstRef con) and proji_sp_pp = Nametab.pr_global_env Idset.empty (ConstRef proji_sp) in msg_warning (str "No global reference exists for projection value" ++ Termops.print_constr t ++ str " in instance " ++ con_pp ++ str " of " ++ proji_sp_pp ++ str ", ignoring it.")); l end | _ -> l) [] lps in List.map (fun (refi,c,inj,argj) -> (refi,c), {o_DEF=v; o_INJ=inj; o_TABS=lt; o_TPARAMS=params; o_NPARAMS=List.length params; o_TCOMPS=argj}) comp let pr_cs_pattern = function Const_cs c -> Nametab.pr_global_env Idset.empty c | Prod_cs -> str "_ -> _" | Default_cs -> str "_" | Sort_cs s -> Termops.pr_sort_family s let open_canonical_structure i (_,o) = if i=1 then let lo = compute_canonical_projections o in List.iter (fun ((proj,cs_pat),s) -> let l = try Refmap.find proj !object_table with Not_found -> [] in let ocs = try Some (List.assoc cs_pat l) with Not_found -> None in match ocs with | None -> object_table := Refmap.add proj ((cs_pat,s)::l) !object_table; | Some cs -> if Flags.is_verbose () then let old_can_s = (Termops.print_constr cs.o_DEF) and new_can_s = (Termops.print_constr s.o_DEF) in let prj = (Nametab.pr_global_env Idset.empty proj) and hd_val = (pr_cs_pattern cs_pat) in msg_warning (str "Ignoring canonical projection to " ++ hd_val ++ str " by " ++ prj ++ str " in " ++ new_can_s ++ str ": redundant with " ++ old_can_s)) lo let cache_canonical_structure o = open_canonical_structure 1 o let subst_canonical_structure (subst,(cst,ind as obj)) = (* invariant: cst is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) let cst' = fst (subst_con subst cst) in let ind' = Inductiveops.subst_inductive subst ind in if cst' == cst & ind' == ind then obj else (cst',ind') let discharge_canonical_structure (_,(cst,ind)) = Some (Lib.discharge_con cst,Lib.discharge_inductive ind) let inCanonStruc : constant * inductive -> obj = declare_object {(default_object "CANONICAL-STRUCTURE") with open_function = open_canonical_structure; cache_function = cache_canonical_structure; subst_function = subst_canonical_structure; classify_function = (fun x -> Substitute x); discharge_function = discharge_canonical_structure } let add_canonical_structure x = Lib.add_anonymous_leaf (inCanonStruc x) (*s High-level declaration of a canonical structure *) let error_not_structure ref = errorlabstrm "object_declare" (Nameops.pr_id (basename_of_global ref) ++ str" is not a structure object.") let check_and_decompose_canonical_structure ref = let sp = match ref with ConstRef sp -> sp | _ -> error_not_structure ref in let env = Global.env () in let vc = match Environ.constant_opt_value env sp with | Some vc -> vc | None -> error_not_structure ref in let body = snd (splay_lam (Global.env()) Evd.empty vc) in let f,args = match kind_of_term body with | App (f,args) -> f,args | _ -> error_not_structure ref in let indsp = match kind_of_term f with | Construct (indsp,1) -> indsp | _ -> error_not_structure ref in let s = try lookup_structure indsp with Not_found -> error_not_structure ref in let ntrue_projs = List.length (List.filter (fun (_, x) -> x) s.s_PROJKIND) in if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then error_not_structure ref; (sp,indsp) let declare_canonical_structure ref = add_canonical_structure (check_and_decompose_canonical_structure ref) let lookup_canonical_conversion (proj,pat) = List.assoc pat (Refmap.find proj !object_table) let is_open_canonical_projection env sigma (c,args) = try let n = find_projection_nparams (global_of_constr c) in try let arg = whd_betadeltaiota env sigma (List.nth args n) in let hd = match kind_of_term arg with App (hd, _) -> hd | _ -> arg in not (isConstruct hd) with Failure _ -> false with Not_found -> false let freeze () = !structure_table, !projection_table, !object_table let unfreeze (s,p,o) = structure_table := s; projection_table := p; object_table := o let init () = structure_table := Indmap.empty; projection_table := Cmap.empty; object_table := Refmap.empty let _ = init() let _ = Summary.declare_summary "objdefs" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = init } coq-8.4pl4/pretyping/pretype_errors.ml0000644000175000017500000001467612326224777017310 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | _ -> false let nf_evar = Reductionops.nf_evar let j_nf_evar sigma j = { uj_val = nf_evar sigma j.uj_val; uj_type = nf_evar sigma j.uj_type } let j_nf_betaiotaevar sigma j = { uj_val = nf_evar sigma j.uj_val; uj_type = Reductionops.nf_betaiota sigma j.uj_type } let jl_nf_evar sigma jl = List.map (j_nf_evar sigma) jl let jv_nf_betaiotaevar sigma jl = Array.map (j_nf_betaiotaevar sigma) jl let jv_nf_evar sigma = Array.map (j_nf_evar sigma) let tj_nf_evar sigma {utj_val=v;utj_type=t} = {utj_val=nf_evar sigma v;utj_type=t} let env_nf_evar sigma env = process_rel_context (fun d e -> push_rel (map_rel_declaration (nf_evar sigma) d) e) env let env_nf_betaiotaevar sigma env = process_rel_context (fun d e -> push_rel (map_rel_declaration (Reductionops.nf_betaiota sigma) d) e) env (* This simplifies the typing context of Cases clauses *) (* hope it does not disturb other typing contexts *) let contract env lc = let l = ref [] in let contract_context (na,c,t) env = match c with | Some c' when isRel c' -> l := (substl !l c') :: !l; env | _ -> let t' = substl !l t in let c' = Option.map (substl !l) c in let na' = named_hd env t' na in l := (mkRel 1) :: List.map (lift 1) !l; push_rel (na',c',t') env in let env = process_rel_context contract_context env in (env, List.map (substl !l) lc) let contract2 env a b = match contract env [a;b] with | env, [a;b] -> env,a,b | _ -> assert false let contract3 env a b c = match contract env [a;b;c] with | env, [a;b;c] -> env,a,b,c | _ -> assert false let raise_pretype_error (loc,env,sigma,te) = Loc.raise loc (PretypeError(env,sigma,te)) let raise_located_type_error (loc,env,sigma,te) = Loc.raise loc (PretypeError(env,sigma,TypingError te)) let error_actual_type_loc loc env sigma {uj_val=c;uj_type=actty} expty = let env, c, actty, expty = contract3 env c actty expty in let j = {uj_val=c;uj_type=actty} in raise_located_type_error (loc, env, sigma, ActualType (j, expty)) let error_cant_apply_not_functional_loc loc env sigma rator randl = raise_located_type_error (loc, env, sigma, CantApplyNonFunctional (rator, Array.of_list randl)) let error_cant_apply_bad_type_loc loc env sigma (n,c,t) rator randl = raise_located_type_error (loc, env, sigma, CantApplyBadType ((n,c,t), rator, Array.of_list randl)) let error_ill_formed_branch_loc loc env sigma c i actty expty = raise_located_type_error (loc, env, sigma, IllFormedBranch (c, i, actty, expty)) let error_number_branches_loc loc env sigma cj expn = raise_located_type_error (loc, env, sigma, NumberBranches (cj, expn)) let error_case_not_inductive_loc loc env sigma cj = raise_located_type_error (loc, env, sigma, CaseNotInductive cj) let error_ill_typed_rec_body_loc loc env sigma i na jl tys = raise_located_type_error (loc, env, sigma, IllTypedRecBody (i, na, jl, tys)) let error_not_a_type_loc loc env sigma j = raise_located_type_error (loc, env, sigma, NotAType j) (*s Implicit arguments synthesis errors. It is hard to find a precise location. *) let error_occur_check env sigma ev c = raise (PretypeError (env, sigma, OccurCheck (ev,c))) let error_not_clean env sigma ev c (loc,k) = Loc.raise loc (PretypeError (env, sigma, NotClean (ev,c,k))) let error_unsolvable_implicit loc env sigma evi e explain = Loc.raise loc (PretypeError (env, sigma, UnsolvableImplicit (evi, e, explain))) let error_cannot_unify env sigma (m,n) = raise (PretypeError (env, sigma,CannotUnify (m,n))) let error_cannot_unify_local env sigma (m,n,sn) = raise (PretypeError (env, sigma,CannotUnifyLocal (m,n,sn))) let error_cannot_coerce env sigma (m,n) = raise (PretypeError (env, sigma,CannotUnify (m,n))) let error_cannot_find_well_typed_abstraction env sigma p l = raise (PretypeError (env, sigma,CannotFindWellTypedAbstraction (p,l))) let error_abstraction_over_meta env sigma hdmeta metaarg = let m = Evd.meta_name sigma hdmeta and n = Evd.meta_name sigma metaarg in raise (PretypeError (env, sigma,AbstractionOverMeta (m,n))) let error_non_linear_unification env sigma hdmeta t = let m = Evd.meta_name sigma hdmeta in raise (PretypeError (env, sigma,NonLinearUnification (m,t))) (*s Ml Case errors *) let error_cant_find_case_type_loc loc env sigma expr = raise_pretype_error (loc, env, sigma, CantFindCaseType expr) (*s Pretyping errors *) let error_unexpected_type_loc loc env sigma actty expty = let env, actty, expty = contract2 env actty expty in raise_pretype_error (loc, env, sigma, UnexpectedType (actty, expty)) let error_not_product_loc loc env sigma c = raise_pretype_error (loc, env, sigma, NotProduct c) (*s Error in conversion from AST to glob_constr *) let error_var_not_found_loc loc s = raise_pretype_error (loc, empty_env, Evd.empty, VarNotFound s) coq-8.4pl4/pretyping/cases.ml0000644000175000017500000021735212326224777015316 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* case_style -> (type_constraint -> env -> evar_map ref -> glob_constr -> unsafe_judgment) * evar_map ref -> type_constraint -> env -> glob_constr option * tomatch_tuples * cases_clauses -> unsafe_judgment end let rec list_try_compile f = function | [a] -> f a | [] -> anomaly "try_find_f" | h::t -> try f h with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _ | Loc.Exc_located (_, (UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _)) -> list_try_compile f t let force_name = let nx = Name (id_of_string "x") in function Anonymous -> nx | na -> na (************************************************************************) (* Pattern-matching compilation (Cases) *) (************************************************************************) (************************************************************************) (* Configuration, errors and warnings *) open Pp let msg_may_need_inversion () = strbrk "Found a matching with no clauses on a term unknown to have an empty inductive type." (* Utils *) let make_anonymous_patvars n = list_make n (PatVar (dummy_loc,Anonymous)) (* Environment management *) let push_rels vars env = List.fold_right push_rel vars env (* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *) let relocate_rel n1 n2 k j = if j = n1+k then n2+k else j let rec relocate_index n1 n2 k t = match kind_of_term t with | Rel j when j = n1+k -> mkRel (n2+k) | Rel j when j < n1+k -> t | Rel j when j > n1+k -> t | _ -> map_constr_with_binders succ (relocate_index n1 n2) k t (**********************************************************************) (* Structures used in compiling pattern-matching *) type 'a rhs = { rhs_env : env; rhs_vars : identifier list; avoid_ids : identifier list; it : 'a option} type 'a equation = { patterns : cases_pattern list; rhs : 'a rhs; alias_stack : name list; eqn_loc : loc; used : bool ref } type 'a matrix = 'a equation list (* 1st argument of IsInd is the original ind before extracting the summary *) type tomatch_type = | IsInd of types * inductive_type * name list | NotInd of constr option * types type tomatch_status = | Pushed of ((constr * tomatch_type) * int list * name) | Alias of (name * constr * (constr * types)) | NonDepAlias | Abstract of int * rel_declaration type tomatch_stack = tomatch_status list (* We keep a constr for aliases and a cases_pattern for error message *) type pattern_history = | Top | MakeConstructor of constructor * pattern_continuation and pattern_continuation = | Continuation of int * cases_pattern list * pattern_history | Result of cases_pattern list let start_history n = Continuation (n, [], Top) let feed_history arg = function | Continuation (n, l, h) when n>=1 -> Continuation (n-1, arg :: l, h) | Continuation (n, _, _) -> anomaly ("Bad number of expected remaining patterns: "^(string_of_int n)) | Result _ -> anomaly "Exhausted pattern history" (* This is for non exhaustive error message *) let rec glob_pattern_of_partial_history args2 = function | Continuation (n, args1, h) -> let args3 = make_anonymous_patvars (n - (List.length args2)) in build_glob_pattern (List.rev_append args1 (args2@args3)) h | Result pl -> pl and build_glob_pattern args = function | Top -> args | MakeConstructor (pci, rh) -> glob_pattern_of_partial_history [PatCstr (dummy_loc, pci, args, Anonymous)] rh let complete_history = glob_pattern_of_partial_history [] (* This is to build glued pattern-matching history and alias bodies *) let rec pop_history_pattern = function | Continuation (0, l, Top) -> Result (List.rev l) | Continuation (0, l, MakeConstructor (pci, rh)) -> feed_history (PatCstr (dummy_loc,pci,List.rev l,Anonymous)) rh | _ -> anomaly "Constructor not yet filled with its arguments" let pop_history h = feed_history (PatVar (dummy_loc, Anonymous)) h (* Builds a continuation expecting [n] arguments and building [ci] applied to this [n] arguments *) let push_history_pattern n pci cont = Continuation (n, [], MakeConstructor (pci, cont)) (* A pattern-matching problem has the following form: env, evd |- match terms_to_tomatch return pred with mat end where terms_to_match is some sequence of "instructions" (t1 ... tp) and mat is some matrix (p11 ... p1n -> rhs1) ( ... ) (pm1 ... pmn -> rhsm) Terms to match: there are 3 kinds of instructions - "Pushed" terms to match are typed in [env]; these are usually just Rel(n) except for the initial terms given by user; in Pushed ((c,tm),deps,na), [c] is the reference to the term (which is a Rel or an initial term), [tm] is its type (telling whether we know if it is an inductive type or not), [deps] is the list of terms to abstract before matching on [c] (these are rels too) - "Abstract" instructions mean that an abstraction has to be inserted in the current branch to build (this means a pattern has been detected dependent in another one and a generalization is necessary to ensure well-typing) Abstract instructions extend the [env] in which the other instructions are typed - "Alias" instructions mean an alias has to be inserted (this alias is usually removed at the end, except when its type is not the same as the type of the matched term from which it comes - typically because the inductive types are "real" parameters) - "NonDepAlias" instructions mean the completion of a matching over a term to match as for Alias but without inserting this alias because there is no dependency in it Right-hand sides: They consist of a raw term to type in an environment specific to the clause they belong to: the names of declarations are those of the variables present in the patterns. Therefore, they come with their own [rhs_env] (actually it is the same as [env] except for the names of variables). *) type 'a pattern_matching_problem = { env : env; evdref : evar_map ref; pred : constr; tomatch : tomatch_stack; history : pattern_continuation; mat : 'a matrix; caseloc : loc; casestyle : case_style; typing_function: type_constraint -> env -> evar_map ref -> 'a option -> unsafe_judgment } (*--------------------------------------------------------------------------* * A few functions to infer the inductive type from the patterns instead of * * checking that the patterns correspond to the ind. type of the * * destructurated object. Allows type inference of examples like * * match n with O => true | _ => false end * * match x in I with C => true | _ => false end * *--------------------------------------------------------------------------*) (* Computing the inductive type from the matrix of patterns *) (* We use the "in I" clause to coerce the terms to match and otherwise use the constructor to know in which type is the matching problem Note that insertion of coercions inside nested patterns is done each time the matrix is expanded *) let rec find_row_ind = function [] -> None | PatVar _ :: l -> find_row_ind l | PatCstr(loc,c,_,_) :: _ -> Some (loc,c) let inductive_template evdref env tmloc ind = let arsign = get_full_arity_sign env ind in let hole_source = match tmloc with | Some loc -> fun i -> (loc, TomatchTypeParameter (ind,i)) | None -> fun _ -> (dummy_loc, InternalHole) in let (_,evarl,_) = List.fold_right (fun (na,b,ty) (subst,evarl,n) -> match b with | None -> let ty' = substl subst ty in let e = e_new_evar evdref env ~src:(hole_source n) ty' in (e::subst,e::evarl,n+1) | Some b -> (substl subst b::subst,evarl,n+1)) arsign ([],[],1) in applist (mkInd ind,List.rev evarl) let try_find_ind env sigma typ realnames = let (IndType(_,realargs) as ind) = find_rectype env sigma typ in let names = match realnames with | Some names -> names | None -> list_make (List.length realargs) Anonymous in IsInd (typ,ind,names) let inh_coerce_to_ind evdref env ty tyi = let expected_typ = inductive_template evdref env None tyi in (* devrait Être indiffÃĐrent d'exiger leq ou pas puisque pour un inductif cela doit Être ÃĐgal *) let _ = e_cumul env evdref expected_typ ty in () let binding_vars_of_inductive = function | NotInd _ -> [] | IsInd (_,IndType(_,realargs),_) -> List.filter isRel realargs let extract_inductive_data env sigma (_,b,t) = if b<>None then (NotInd (None,t),[]) else let tmtyp = try try_find_ind env sigma t None with Not_found -> NotInd (None,t) in let tmtypvars = binding_vars_of_inductive tmtyp in (tmtyp,tmtypvars) let unify_tomatch_with_patterns evdref env loc typ pats realnames = match find_row_ind pats with | None -> NotInd (None,typ) | Some (_,(ind,_)) -> inh_coerce_to_ind evdref env typ ind; try try_find_ind env !evdref typ realnames with Not_found -> NotInd (None,typ) let find_tomatch_tycon evdref env loc = function (* Try if some 'in I ...' is present and can be used as a constraint *) | Some (_,ind,_,realnal) -> mk_tycon (inductive_template evdref env loc ind),Some (List.rev realnal) | None -> empty_tycon,None let coerce_row typing_fun evdref env pats (tomatch,(_,indopt)) = let loc = Some (loc_of_glob_constr tomatch) in let tycon,realnames = find_tomatch_tycon evdref env loc indopt in let j = typing_fun tycon env evdref tomatch in let typ = nf_evar !evdref j.uj_type in let t = try try_find_ind env !evdref typ realnames with Not_found -> unify_tomatch_with_patterns evdref env loc typ pats realnames in (j.uj_val,t) let coerce_to_indtype typing_fun evdref env matx tomatchl = let pats = List.map (fun r -> r.patterns) matx in let matx' = match matrix_transpose pats with | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *) | m -> m in List.map2 (coerce_row typing_fun evdref env) matx' tomatchl (************************************************************************) (* Utils *) let mkExistential env ?(src=(dummy_loc,InternalHole)) evdref = e_new_evar evdref env ~src:src (new_Type ()) let evd_comb2 f evdref x y = let (evd',y) = f !evdref x y in evdref := evd'; y module Cases_F(Coercion : Coercion.S) : S = struct let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) = (* Ideally, we could find a common inductive type to which both the term to match and the patterns coerce *) (* In practice, we coerce the term to match if it is not already an inductive type and it is not dependent; moreover, we use only the first pattern type and forget about the others *) let typ,names = match typ with IsInd(t,_,names) -> t,Some names | NotInd(_,t) -> t,None in let tmtyp = try try_find_ind pb.env !(pb.evdref) typ names with Not_found -> NotInd (None,typ) in match tmtyp with | NotInd (None,typ) -> let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in (match find_row_ind tm1 with | None -> (current,tmtyp) | Some (_,(ind,_)) -> let indt = inductive_template pb.evdref pb.env None ind in let current = if deps = [] & isEvar typ then (* Don't insert coercions if dependent; only solve evars *) let _ = e_cumul pb.env pb.evdref indt typ in current else (evd_comb2 (Coercion.inh_conv_coerce_to true dummy_loc pb.env) pb.evdref (make_judge current typ) (mk_tycon_type indt)).uj_val in let sigma = !(pb.evdref) in (current,try_find_ind pb.env sigma indt names)) | _ -> (current,tmtyp) let type_of_tomatch = function | IsInd (t,_,_) -> t | NotInd (_,t) -> t let mkDeclTomatch na = function | IsInd (t,_,_) -> (na,None,t) | NotInd (c,t) -> (na,c,t) let map_tomatch_type f = function | IsInd (t,ind,names) -> IsInd (f t,map_inductive_type f ind,names) | NotInd (c,t) -> NotInd (Option.map f c, f t) let liftn_tomatch_type n depth = map_tomatch_type (liftn n depth) let lift_tomatch_type n = liftn_tomatch_type n 1 (**********************************************************************) (* Utilities on patterns *) let current_pattern eqn = match eqn.patterns with | pat::_ -> pat | [] -> anomaly "Empty list of patterns" let alias_of_pat = function | PatVar (_,name) -> name | PatCstr(_,_,_,name) -> name let remove_current_pattern eqn = match eqn.patterns with | pat::pats -> { eqn with patterns = pats; alias_stack = alias_of_pat pat :: eqn.alias_stack } | [] -> anomaly "Empty list of patterns" let push_current_pattern (cur,ty) eqn = match eqn.patterns with | pat::pats -> let rhs_env = push_rel (alias_of_pat pat,Some cur,ty) eqn.rhs.rhs_env in { eqn with rhs = { eqn.rhs with rhs_env = rhs_env }; patterns = pats } | [] -> anomaly "Empty list of patterns" let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns } (**********************************************************************) (* Well-formedness tests *) (* Partial check on patterns *) exception NotAdjustable let rec adjust_local_defs loc = function | (pat :: pats, (_,None,_) :: decls) -> pat :: adjust_local_defs loc (pats,decls) | (pats, (_,Some _,_) :: decls) -> PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls) | [], [] -> [] | _ -> raise NotAdjustable let check_and_adjust_constructor env ind cstrs = function | PatVar _ as pat -> pat | PatCstr (loc,((_,i) as cstr),args,alias) as pat -> (* Check it is constructor of the right type *) let ind' = inductive_of_constructor cstr in if eq_ind ind' ind then (* Check the constructor has the right number of args *) let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in if List.length args = nb_args_constr then pat else try let args' = adjust_local_defs loc (args, List.rev ci.cs_args) in PatCstr (loc, cstr, args', alias) with NotAdjustable -> error_wrong_numarg_constructor_loc loc (Global.env()) cstr nb_args_constr else (* Try to insert a coercion *) try Coercion.inh_pattern_coerce_to loc pat ind' ind with Not_found -> error_bad_constructor_loc loc cstr ind let check_all_variables typ mat = List.iter (fun eqn -> match current_pattern eqn with | PatVar (_,id) -> () | PatCstr (loc,cstr_sp,_,_) -> error_bad_pattern_loc loc cstr_sp typ) mat let check_unused_pattern env eqn = if not !(eqn.used) then raise_pattern_matching_error (eqn.eqn_loc, env, UnusedClause eqn.patterns) let set_used_pattern eqn = eqn.used := true let extract_rhs pb = match pb.mat with | [] -> errorlabstrm "build_leaf" (msg_may_need_inversion()) | eqn::_ -> set_used_pattern eqn; eqn.rhs (**********************************************************************) (* Functions to deal with matrix factorization *) let occur_in_rhs na rhs = match na with | Anonymous -> false | Name id -> List.mem id rhs.rhs_vars let is_dep_patt_in eqn = function | PatVar (_,name) -> occur_in_rhs name eqn.rhs | PatCstr _ -> true let mk_dep_patt_row (pats,_,eqn) = List.map (is_dep_patt_in eqn) pats let dependencies_in_pure_rhs nargs eqns = if eqns = [] then list_make nargs false (* Only "_" patts *) else let deps_rows = List.map mk_dep_patt_row eqns in let deps_columns = matrix_transpose deps_rows in List.map (List.exists ((=) true)) deps_columns let dependent_decl a = function | (na,None,t) -> dependent a t | (na,Some c,t) -> dependent a t || dependent a c let rec dep_in_tomatch n = function | (Pushed _ | Alias _ | NonDepAlias) :: l -> dep_in_tomatch n l | Abstract (_,d) :: l -> dependent_decl (mkRel n) d or dep_in_tomatch (n+1) l | [] -> false let dependencies_in_rhs nargs current tms eqns = match kind_of_term current with | Rel n when dep_in_tomatch n tms -> list_make nargs true | _ -> dependencies_in_pure_rhs nargs eqns (* Computing the matrix of dependencies *) (* [find_dependency_list tmi [d(i+1);...;dn]] computes in which declarations [d(i+1);...;dn] the term [tmi] is dependent in. [find_dependencies_signature (used1,...,usedn) ((tm1,d1),...,(tmn,dn))] returns [(deps1,...,depsn)] where [depsi] is a subset of n,..,i+1 denoting in which of the d(i+1)...dn, the term tmi is dependent. Dependencies are expressed by index, e.g. in dependency list [n-2;1], [1] points to [dn] and [n-2] to [d3] *) let rec find_dependency_list tmblock = function | [] -> [] | (used,tdeps,d)::rest -> let deps = find_dependency_list tmblock rest in if used && List.exists (fun x -> dependent_decl x d) tmblock then list_add_set (List.length rest + 1) (list_union deps tdeps) else deps let find_dependencies is_dep_or_cstr_in_rhs (tm,(_,tmtypleaves),d) nextlist = let deps = find_dependency_list (tm::tmtypleaves) nextlist in if is_dep_or_cstr_in_rhs || deps <> [] then ((true ,deps,d)::nextlist) else ((false,[] ,d)::nextlist) let find_dependencies_signature deps_in_rhs typs = let l = List.fold_right2 find_dependencies deps_in_rhs typs [] in List.map (fun (_,deps,_) -> deps) l (* Assume we had terms t1..tq to match in a context xp:Tp,...,x1:T1 |- and xn:Tn has just been regeneralized into x:Tn so that the terms to match are now to be considered in the context xp:Tp,...,x1:T1,x:Tn |-. [relocate_index_tomatch n 1 tomatch] updates t1..tq so that former references to xn1 are now references to x. Note that t1..tq are already adjusted to the context xp:Tp,...,x1:T1,x:Tn |-. [relocate_index_tomatch 1 n tomatch] will go the way back. *) let relocate_index_tomatch n1 n2 = let rec genrec depth = function | [] -> [] | Pushed ((c,tm),l,na) :: rest -> let c = relocate_index n1 n2 depth c in let tm = map_tomatch_type (relocate_index n1 n2 depth) tm in let l = List.map (relocate_rel n1 n2 depth) l in Pushed ((c,tm),l,na) :: genrec depth rest | Alias (na,c,d) :: rest -> (* [c] is out of relocation scope *) Alias (na,c,map_pair (relocate_index n1 n2 depth) d) :: genrec depth rest | NonDepAlias :: rest -> NonDepAlias :: genrec depth rest | Abstract (i,d) :: rest -> let i = relocate_rel n1 n2 depth i in Abstract (i,map_rel_declaration (relocate_index n1 n2 depth) d) :: genrec (depth+1) rest in genrec 0 (* [replace_tomatch n c tomatch] replaces [Rel n] by [c] in [tomatch] *) let rec replace_term n c k t = if isRel t && destRel t = n+k then lift k c else map_constr_with_binders succ (replace_term n c) k t let length_of_tomatch_type_sign na = function | NotInd _ -> if na<>Anonymous then 1 else 0 | IsInd (_,_,names) -> List.length names + if na<>Anonymous then 1 else 0 let replace_tomatch n c = let rec replrec depth = function | [] -> [] | Pushed ((b,tm),l,na) :: rest -> let b = replace_term n c depth b in let tm = map_tomatch_type (replace_term n c depth) tm in List.iter (fun i -> if i=n+depth then anomaly "replace_tomatch") l; Pushed ((b,tm),l,na) :: replrec depth rest | Alias (na,b,d) :: rest -> (* [b] is out of replacement scope *) Alias (na,b,map_pair (replace_term n c depth) d) :: replrec depth rest | NonDepAlias :: rest -> NonDepAlias :: replrec depth rest | Abstract (i,d) :: rest -> Abstract (i,map_rel_declaration (replace_term n c depth) d) :: replrec (depth+1) rest in replrec 0 (* [liftn_tomatch_stack]: a term to match has just been substituted by some constructor t = (ci x1...xn) and the terms x1 ... xn have been added to match; all pushed terms to match must be lifted by n (knowing that [Abstract] introduces a binder in the list of pushed terms to match). *) let rec liftn_tomatch_stack n depth = function | [] -> [] | Pushed ((c,tm),l,na)::rest -> let c = liftn n depth c in let tm = liftn_tomatch_type n depth tm in let l = List.map (fun i -> if i Alias (na,liftn n depth c,map_pair (liftn n depth) d) ::(liftn_tomatch_stack n depth rest) | NonDepAlias :: rest -> NonDepAlias :: liftn_tomatch_stack n depth rest | Abstract (i,d)::rest -> let i = if i x | x => x end] should be compiled into [match y with O => y | (S n) => match n with O => y | (S x) => x end end] and [match y with (S (S n)) => n | n => n end] into [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end] i.e. user names should be preserved and created names should not interfere with user names The exact names here are not important for typing (because they are put in pb.env and not in the rhs.rhs_env of branches. However, whether a name is Anonymous or not may have an effect on whether a generalization is done or not. *) let merge_name get_name obj = function | Anonymous -> get_name obj | na -> na let merge_names get_name = List.map2 (merge_name get_name) let get_names env sign eqns = let names1 = list_make (List.length sign) Anonymous in (* If any, we prefer names used in pats, from top to bottom *) let names2,aliasname = List.fold_right (fun (pats,pat_alias,eqn) (names,aliasname) -> (merge_names alias_of_pat pats names, merge_name (fun x -> x) pat_alias aliasname)) eqns (names1,Anonymous) in (* Otherwise, we take names from the parameters of the constructor but avoiding conflicts with user ids *) let allvars = List.fold_left (fun l (_,_,eqn) -> list_union l eqn.rhs.avoid_ids) [] eqns in let names3,_ = List.fold_left2 (fun (l,avoid) d na -> let na = merge_name (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid)) d na in (na::l,(out_name na)::avoid)) ([],allvars) (List.rev sign) names2 in names3,aliasname (*****************************************************************) (* Recovering names for variables pushed to the rhs' environment *) (* We just factorized a match over a matrix of equations *) (* "C xi1 .. xin as xi" as a single match over "C y1 .. yn as y" *) (* We now replace the names y1 .. yn y by the actual names *) (* xi1 .. xin xi to be found in the i-th clause of the matrix *) let set_declaration_name x (_,c,t) = (x,c,t) let recover_initial_subpattern_names = List.map2 set_declaration_name let recover_alias_names get_name = List.map2 (fun x (_,c,t) ->(get_name x,c,t)) let push_rels_eqn sign eqn = {eqn with rhs = {eqn.rhs with rhs_env = push_rels sign eqn.rhs.rhs_env} } let push_rels_eqn_with_names sign eqn = let subpats = List.rev (list_firstn (List.length sign) eqn.patterns) in let subpatnames = List.map alias_of_pat subpats in let sign = recover_initial_subpattern_names subpatnames sign in push_rels_eqn sign eqn let push_generalized_decl_eqn env n (na,c,t) eqn = let na = match na with | Anonymous -> Anonymous | Name id -> pi1 (Environ.lookup_rel n eqn.rhs.rhs_env) in push_rels_eqn [(na,c,t)] eqn let drop_alias_eqn eqn = { eqn with alias_stack = List.tl eqn.alias_stack } let push_alias_eqn alias eqn = let aliasname = List.hd eqn.alias_stack in let eqn = drop_alias_eqn eqn in let alias = set_declaration_name aliasname alias in push_rels_eqn [alias] eqn (**********************************************************************) (* Functions to deal with elimination predicate *) (* Infering the predicate *) (* The problem to solve is the following: We match Gamma |- t : I(u01..u0q) against the following constructors: Gamma, x11...x1p1 |- C1(x11..x1p1) : I(u11..u1q) ... Gamma, xn1...xnpn |- Cn(xn1..xnp1) : I(un1..unq) Assume the types in the branches are the following Gamma, x11...x1p1 |- branch1 : T1 ... Gamma, xn1...xnpn |- branchn : Tn Assume the type of the global case expression is Gamma |- T The predicate has the form phi = [y1..yq][z:I(y1..yq)]psi and it has to satisfy the following n+1 equations: Gamma, x11...x1p1 |- (phi u11..u1q (C1 x11..x1p1)) = T1 ... Gamma, xn1...xnpn |- (phi un1..unq (Cn xn1..xnpn)) = Tn Gamma |- (phi u01..u0q t) = T Some hints: - Clearly, if xij occurs in Ti, then, a "match z with (Ci xi1..xipi) => ... end" or a "psi(yk)", with psi extracting xij from uik, should be inserted somewhere in Ti. - If T is undefined, an easy solution is to insert a "match z with (Ci xi1..xipi) => ... end" in front of each Ti - Otherwise, T1..Tn and T must be step by step unified, if some of them diverge, then try to replace the diverging subterm by one of y1..yq or z. - The main problem is what to do when an existential variables is encountered *) (* Propagation of user-provided predicate through compilation steps *) let rec map_predicate f k ccl = function | [] -> f k ccl | Pushed ((_,tm),_,na) :: rest -> let k' = length_of_tomatch_type_sign na tm in map_predicate f (k+k') ccl rest | (Alias _ | NonDepAlias) :: rest -> map_predicate f k ccl rest | Abstract _ :: rest -> map_predicate f (k+1) ccl rest let noccur_predicate_between n = map_predicate (noccur_between n) let liftn_predicate n = map_predicate (liftn n) let lift_predicate n = liftn_predicate n 1 let regeneralize_index_predicate n = map_predicate (relocate_index n 1) 0 let substnl_predicate sigma = map_predicate (substnl sigma) (* This is parallel bindings *) let subst_predicate (args,copt) ccl tms = let sigma = match copt with | None -> List.rev args | Some c -> c::(List.rev args) in substnl_predicate sigma 0 ccl tms let specialize_predicate_var (cur,typ,dep) tms ccl = let c = if dep<>Anonymous then Some cur else None in let l = match typ with | IsInd (_,IndType(_,realargs),names) -> if names<>[] then realargs else [] | NotInd _ -> [] in subst_predicate (l,c) ccl tms (*****************************************************************************) (* We have pred = [X:=realargs;x:=c]P typed in Gamma1, x:I(realargs), Gamma2 *) (* and we want to abstract P over y:t(x) typed in the same context to get *) (* *) (* pred' = [X:=realargs;x':=c](y':t(x'))P[y:=y'] *) (* *) (* We first need to lift t(x) s.t. it is typed in Gamma, X:=rargs, x' *) (* then we have to replace x by x' in t(x) and y by y' in P *) (*****************************************************************************) let generalize_predicate (names,na) ny d tms ccl = if na=Anonymous then anomaly "Undetected dependency"; let p = List.length names + 1 in let ccl = lift_predicate 1 ccl tms in regeneralize_index_predicate (ny+p+1) ccl tms (*****************************************************************************) (* We just matched over cur:ind(realargs) in the following matching problem *) (* *) (* env |- match cur tms return ccl with ... end *) (* *) (* and we want to build the predicate corresponding to the individual *) (* matching over cur *) (* *) (* pred = fun X:realargstyps x:ind(X)] PI tms.ccl *) (* *) (* where pred is computed by abstract_predicate and PI tms.ccl by *) (* extract_predicate *) (*****************************************************************************) let rec extract_predicate ccl = function | (Alias _ | NonDepAlias)::tms -> (* substitution already done in build_branch *) extract_predicate ccl tms | Abstract (i,d)::tms -> mkProd_wo_LetIn d (extract_predicate ccl tms) | Pushed ((cur,NotInd _),_,na)::tms -> let tms = if na<>Anonymous then lift_tomatch_stack 1 tms else tms in let pred = extract_predicate ccl tms in if na<>Anonymous then subst1 cur pred else pred | Pushed ((cur,IsInd (_,IndType(_,realargs),_)),_,na)::tms -> let realargs = List.rev realargs in let k = if na<>Anonymous then 1 else 0 in let tms = lift_tomatch_stack (List.length realargs + k) tms in let pred = extract_predicate ccl tms in substl (if na<>Anonymous then cur::realargs else realargs) pred | [] -> ccl let abstract_predicate env sigma indf cur realargs (names,na) tms ccl = let sign = make_arity_signature env true indf in (* n is the number of real args + 1 (+ possible let-ins in sign) *) let n = List.length sign in (* Before abstracting we generalize over cur and on those realargs *) (* that are rels, consistently with the specialization made in *) (* build_branch *) let tms = List.fold_right2 (fun par arg tomatch -> match kind_of_term par with | Rel i -> relocate_index_tomatch (i+n) (destRel arg) tomatch | _ -> tomatch) (realargs@[cur]) (extended_rel_list 0 sign) (lift_tomatch_stack n tms) in (* Pred is already dependent in the current term to match (if *) (* (na<>Anonymous) and its realargs; we just need to adjust it to *) (* full sign if dep in cur is not taken into account *) let ccl = if na <> Anonymous then ccl else lift_predicate 1 ccl tms in let pred = extract_predicate ccl tms in (* Build the predicate properly speaking *) let sign = List.map2 set_declaration_name (na::names) sign in it_mkLambda_or_LetIn_name env pred sign (* [expand_arg] is used by [specialize_predicate] if Yk denotes [Xk;xk] or [Xk], it replaces gamma, x1...xn, x1...xk Yk+1...Yn |- pred by gamma, x1...xn, x1...xk-1 [Xk;xk] Yk+1...Yn |- pred (if dep) or by gamma, x1...xn, x1...xk-1 [Xk] Yk+1...Yn |- pred (if not dep) *) let expand_arg tms (p,ccl) ((_,t),_,na) = let k = length_of_tomatch_type_sign na t in (p+k,liftn_predicate (k-1) (p+1) ccl tms) let adjust_impossible_cases pb pred tomatch submat = if submat = [] then match kind_of_term (whd_evar !(pb.evdref) pred) with | Evar (evk,_) when snd (evar_source evk !(pb.evdref)) = ImpossibleCase -> let default = (coq_unit_judge ()).uj_type in pb.evdref := Evd.define evk default !(pb.evdref); (* we add an "assert false" case *) let pats = List.map (fun _ -> PatVar (dummy_loc,Anonymous)) tomatch in let aliasnames = map_succeed (function Alias _ | NonDepAlias -> Anonymous | _ -> failwith"") tomatch in [ { patterns = pats; rhs = { rhs_env = pb.env; rhs_vars = []; avoid_ids = []; it = None }; alias_stack = Anonymous::aliasnames; eqn_loc = dummy_loc; used = ref false } ] | _ -> submat else submat (*****************************************************************************) (* Let pred = PI [X;x:I(X)]. PI tms. P be a typing predicate for the *) (* following pattern-matching problem: *) (* *) (* Gamma |- match Pushed(c:I(V)) as x in I(X), tms return pred with...end *) (* *) (* where the branch with constructor Ci:(x1:T1)...(xn:Tn)->I(realargsi) *) (* is considered. Assume each Ti is some Ii(argsi) with Ti:PI Ui. sort_i *) (* We let subst = X:=realargsi;x:=Ci(x1,...,xn) and replace pred by *) (* *) (* pred' = PI [X1:Ui;x1:I1(X1)]...[Xn:Un;xn:In(Xn)]. (PI tms. P)[subst] *) (* *) (* s.t. the following well-typed sub-pattern-matching problem is obtained *) (* *) (* Gamma,x'1..x'n |- *) (* match *) (* Pushed(x'1) as x1 in I(X1), *) (* .., *) (* Pushed(x'n) as xn in I(Xn), *) (* tms *) (* return pred' *) (* with .. end *) (* *) (*****************************************************************************) let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl = (* Assume some gamma st: gamma |- PI [X,x:I(X)]. PI tms. ccl *) let nrealargs = List.length names in let k = nrealargs + (if depna<>Anonymous then 1 else 0) in (* We adjust pred st: gamma, x1..xn |- PI [X,x:I(X)]. PI tms. ccl' *) (* so that x can later be instantiated by Ci(x1..xn) *) (* and X by the realargs for Ci *) let n = cs.cs_nargs in let ccl' = liftn_predicate n (k+1) ccl tms in (* We prepare the substitution of X and x:I(X) *) let realargsi = if nrealargs <> 0 then adjust_subst_to_rel_context arsign (Array.to_list cs.cs_concl_realargs) else [] in let copti = if depna<>Anonymous then Some (build_dependent_constructor cs) else None in (* The substituends realargsi, copti are all defined in gamma, x1...xn *) (* We need _parallel_ bindings to get gamma, x1...xn |- PI tms. ccl'' *) (* Note: applying the substitution in tms is not important (is it sure?) *) let ccl'' = whd_betaiota Evd.empty (subst_predicate (realargsi, copti) ccl' tms) in (* We adjust ccl st: gamma, x'1..x'n, x1..xn, tms |- ccl'' *) let ccl''' = liftn_predicate n (n+1) ccl'' tms in (* We finally get gamma,x'1..x'n,x |- [X1;x1:I(X1)]..[Xn;xn:I(Xn)]pred'''*) snd (List.fold_left (expand_arg tms) (1,ccl''') newtomatchs) let find_predicate loc env evdref p current (IndType (indf,realargs)) dep tms = let pred = abstract_predicate env !evdref indf current realargs dep tms p in (pred, whd_betaiota !evdref (applist (pred, realargs@[current]))) (* Take into account that a type has been discovered to be inductive, leading to more dependencies in the predicate if the type has indices *) let adjust_predicate_from_tomatch tomatch (current,typ as ct) pb = let ((_,oldtyp),deps,na) = tomatch in match typ, oldtyp with | IsInd (_,_,names), NotInd _ -> let k = if na <> Anonymous then 2 else 1 in let n = List.length names in { pb with pred = liftn_predicate n k pb.pred pb.tomatch }, (ct,List.map (fun i -> if i >= k then i+n else i) deps,na) | _ -> pb, (ct,deps,na) (* Remove commutative cuts that turn out to be non-dependent after some evars have been instantiated *) let rec ungeneralize n ng body = match kind_of_term body with | Lambda (_,_,c) when ng = 0 -> subst1 (mkRel n) c | Lambda (na,t,c) -> (* We traverse an inner generalization *) mkLambda (na,t,ungeneralize (n+1) (ng-1) c) | LetIn (na,b,t,c) -> (* We traverse an alias *) mkLetIn (na,b,t,ungeneralize (n+1) ng c) | Case (ci,p,c,brs) -> (* We traverse a split *) let p = let sign,p = decompose_lam_assum p in let sign2,p = decompose_prod_n_assum ng p in let p = prod_applist p [mkRel (n+List.length sign+ng)] in it_mkLambda_or_LetIn (it_mkProd_or_LetIn p sign2) sign in mkCase (ci,p,c,array_map2 (fun q c -> let sign,b = decompose_lam_n_assum q c in it_mkLambda_or_LetIn (ungeneralize (n+q) ng b) sign) ci.ci_cstr_ndecls brs) | App (f,args) -> (* We traverse an inner generalization *) assert (isCase f); mkApp (ungeneralize n (ng+Array.length args) f,args) | _ -> assert false let ungeneralize_branch n k (sign,body) cs = (sign,ungeneralize (n+cs.cs_nargs) k body) let postprocess_dependencies evd tocheck brs tomatch pred deps cs = let rec aux k brs tomatch pred tocheck deps = match deps, tomatch with | [], _ -> brs,tomatch,pred,[] | n::deps, Abstract (i,d) :: tomatch -> let d = map_rel_declaration (nf_evar evd) d in if List.exists (fun c -> dependent_decl (lift k c) d) tocheck || pi2 d <> None then (* Dependency in the current term to match and its dependencies is real *) let brs,tomatch,pred,inst = aux (k+1) brs tomatch pred (mkRel n::tocheck) deps in let inst = if pi2 d = None then mkRel n::inst else inst in brs, Abstract (i,d) :: tomatch, pred, inst else (* Finally, no dependency remains, so, we can replace the generalized *) (* terms by its actual value in both the remaining terms to match and *) (* the bodies of the Case *) let pred = lift_predicate (-1) pred tomatch in let tomatch = relocate_index_tomatch 1 (n+1) tomatch in let tomatch = lift_tomatch_stack (-1) tomatch in let brs = array_map2 (ungeneralize_branch n k) brs cs in aux k brs tomatch pred tocheck deps | _ -> assert false in aux 0 brs tomatch pred tocheck deps (************************************************************************) (* Sorting equations by constructor *) let rec irrefutable env = function | PatVar (_,name) -> true | PatCstr (_,cstr,args,_) -> let ind = inductive_of_constructor cstr in let (_,mip) = Inductive.lookup_mind_specif env ind in let one_constr = Array.length mip.mind_user_lc = 1 in one_constr & List.for_all (irrefutable env) args let first_clause_irrefutable env = function | eqn::mat -> List.for_all (irrefutable env) eqn.patterns | _ -> false let group_equations pb ind current cstrs mat = let mat = if first_clause_irrefutable pb.env mat then [List.hd mat] else mat in let brs = Array.create (Array.length cstrs) [] in let only_default = ref true in let _ = List.fold_right (* To be sure it's from bottom to top *) (fun eqn () -> let rest = remove_current_pattern eqn in let pat = current_pattern eqn in match check_and_adjust_constructor pb.env ind cstrs pat with | PatVar (_,name) -> (* This is a default clause that we expand *) for i=1 to Array.length cstrs do let args = make_anonymous_patvars cstrs.(i-1).cs_nargs in brs.(i-1) <- (args, name, rest) :: brs.(i-1) done | PatCstr (loc,((_,i)),args,name) -> (* This is a regular clause *) only_default := false; brs.(i-1) <- (args, name, rest) :: brs.(i-1)) mat () in (brs,!only_default) (************************************************************************) (* Here starts the pattern-matching compilation algorithm *) (* Abstracting over dependent subterms to match *) let rec generalize_problem names pb = function | [] -> pb, [] | i::l -> let (na,b,t as d) = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in let pb',deps = generalize_problem names pb l in if na = Anonymous & b <> None then pb',deps else let d = on_pi3 (whd_betaiota !(pb.evdref)) d in (* for better rendering *) let tomatch = lift_tomatch_stack 1 pb'.tomatch in let tomatch = relocate_index_tomatch (i+1) 1 tomatch in { pb' with tomatch = Abstract (i,d) :: tomatch; pred = generalize_predicate names i d pb'.tomatch pb'.pred }, i::deps (* No more patterns: typing the right-hand side of equations *) let build_leaf pb = let rhs = extract_rhs pb in let j = pb.typing_function (mk_tycon pb.pred) rhs.rhs_env pb.evdref rhs.it in j_nf_evar !(pb.evdref) j (* Build the sub-pattern-matching problem for a given branch "C x1..xn as x" *) let build_branch current realargs deps (realnames,curname) pb arsign eqns const_info = (* We remember that we descend through constructor C *) let history = push_history_pattern const_info.cs_nargs const_info.cs_cstr pb.history in (* We prepare the matching on x1:T1 .. xn:Tn using some heuristic to *) (* build the name x1..xn from the names present in the equations *) (* that had matched constructor C *) let cs_args = const_info.cs_args in let names,aliasname = get_names pb.env cs_args eqns in let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in (* We build the matrix obtained by expanding the matching on *) (* "C x1..xn as x" followed by a residual matching on eqn into *) (* a matching on "x1 .. xn eqn" *) let submat = List.map (fun (tms,_,eqn) -> prepend_pattern tms eqn) eqns in (* We adjust the terms to match in the context they will be once the *) (* context [x1:T1,..,xn:Tn] will have been pushed on the current env *) let typs' = list_map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 typs in let extenv = push_rels typs pb.env in let typs' = List.map (fun (c,d) -> (c,extract_inductive_data extenv !(pb.evdref) d,d)) typs' in (* We compute over which of x(i+1)..xn and x matching on xi will need a *) (* generalization *) let dep_sign = find_dependencies_signature (dependencies_in_rhs const_info.cs_nargs current pb.tomatch eqns) (List.rev typs') in (* The dependent term to subst in the types of the remaining UnPushed terms is relative to the current context enriched by topushs *) let ci = build_dependent_constructor const_info in (* Current context Gamma has the form Gamma1;cur:I(realargs);Gamma2 *) (* We go from Gamma |- PI tms. pred to *) (* Gamma;x1..xn;curalias:I(x1..xn) |- PI tms'. pred' *) (* where, in tms and pred, those realargs that are vars are *) (* replaced by the corresponding xi and cur replaced by curalias *) let cirealargs = Array.to_list const_info.cs_concl_realargs in (* Do the specialization for terms to match *) let tomatch = List.fold_right2 (fun par arg tomatch -> match kind_of_term par with | Rel i -> replace_tomatch (i+const_info.cs_nargs) arg tomatch | _ -> tomatch) (current::realargs) (ci::cirealargs) (lift_tomatch_stack const_info.cs_nargs pb.tomatch) in let pred_is_not_dep = noccur_predicate_between 1 (List.length realnames + 1) pb.pred tomatch in let typs' = List.map2 (fun (tm,(tmtyp,_),(na,_,_)) deps -> let na = match curname with | Name _ -> (if na <> Anonymous then na else curname) | Anonymous -> if deps = [] && pred_is_not_dep then Anonymous else force_name na in ((tm,tmtyp),deps,na)) typs' (List.rev dep_sign) in (* Do the specialization for the predicate *) let pred = specialize_predicate typs' (realnames,curname) arsign const_info tomatch pb.pred in let currents = List.map (fun x -> Pushed x) typs' in let alias = if aliasname = Anonymous then NonDepAlias else let cur_alias = lift const_info.cs_nargs current in let ind = appvect ( applist (mkInd (inductive_of_constructor const_info.cs_cstr), List.map (lift const_info.cs_nargs) const_info.cs_params), const_info.cs_concl_realargs) in Alias (aliasname,cur_alias,(ci,ind)) in let tomatch = List.rev_append (alias :: currents) tomatch in let submat = adjust_impossible_cases pb pred tomatch submat in if submat = [] then raise_pattern_matching_error (dummy_loc, pb.env, NonExhaustive (complete_history history)); typs, { pb with env = extenv; tomatch = tomatch; pred = pred; history = history; mat = List.map (push_rels_eqn_with_names typs) submat } (********************************************************************** INVARIANT: pb = { env, pred, tomatch, mat, ...} tomatch = list of Pushed (c:T), Abstract (na:T), Alias (c:T) or NonDepAlias all terms and types in Pushed, Abstract and Alias are relative to env enriched by the Abstract coming before *) (**********************************************************************) (* Main compiling descent *) let rec compile pb = match pb.tomatch with | Pushed cur :: rest -> match_current { pb with tomatch = rest } cur | Alias x :: rest -> compile_alias pb x rest | NonDepAlias :: rest -> compile_non_dep_alias pb rest | Abstract (i,d) :: rest -> compile_generalization pb i d rest | [] -> build_leaf pb (* Case splitting *) and match_current pb tomatch = let tm = adjust_tomatch_to_pattern pb tomatch in let pb,tomatch = adjust_predicate_from_tomatch tomatch tm pb in let ((current,typ),deps,dep) = tomatch in match typ with | NotInd (_,typ) -> check_all_variables typ pb.mat; shift_problem tomatch pb | IsInd (_,(IndType(indf,realargs) as indt),names) -> let mind,_ = dest_ind_family indf in let cstrs = get_constructors pb.env indf in let arsign, _ = get_arity pb.env indf in let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in if (Array.length cstrs <> 0 or pb.mat <> []) & onlydflt then shift_problem tomatch pb else (* We generalize over terms depending on current term to match *) let pb,deps = generalize_problem (names,dep) pb deps in (* We compile branches *) let brvals = array_map2 (compile_branch current realargs (names,dep) deps pb arsign) eqns cstrs in (* We build the (elementary) case analysis *) let depstocheck = current::binding_vars_of_inductive typ in let brvals,tomatch,pred,inst = postprocess_dependencies !(pb.evdref) depstocheck brvals pb.tomatch pb.pred deps cstrs in let brvals = Array.map (fun (sign,body) -> it_mkLambda_or_LetIn body sign) brvals in let (pred,typ) = find_predicate pb.caseloc pb.env pb.evdref pred current indt (names,dep) tomatch in let ci = make_case_info pb.env mind pb.casestyle in let pred = nf_betaiota !(pb.evdref) pred in let case = mkCase (ci,pred,current,brvals) in Typing.check_allowed_sort pb.env !(pb.evdref) mind current pred; { uj_val = applist (case, inst); uj_type = prod_applist typ inst } (* Building the sub-problem when all patterns are variables *) and shift_problem ((current,t),_,na) pb = let ty = type_of_tomatch t in let tomatch = lift_tomatch_stack 1 pb.tomatch in let pred = specialize_predicate_var (current,t,na) pb.tomatch pb.pred in let pb = { pb with env = push_rel (na,Some current,ty) pb.env; tomatch = tomatch; pred = lift_predicate 1 pred tomatch; history = pop_history pb.history; mat = List.map (push_current_pattern (current,ty)) pb.mat } in let j = compile pb in { uj_val = subst1 current j.uj_val; uj_type = subst1 current j.uj_type } (* Building the sub-problem when all patterns are variables *) and compile_branch current realargs names deps pb arsign eqns cstr = let sign, pb = build_branch current realargs deps names pb arsign eqns cstr in sign, (compile pb).uj_val (* Abstract over a declaration before continuing splitting *) and compile_generalization pb i d rest = let pb = { pb with env = push_rel d pb.env; tomatch = rest; mat = List.map (push_generalized_decl_eqn pb.env i d) pb.mat } in let j = compile pb in { uj_val = mkLambda_or_LetIn d j.uj_val; uj_type = mkProd_wo_LetIn d j.uj_type } and compile_alias pb (na,orig,(expanded,expanded_typ)) rest = let f c t = let alias = (na,Some c,t) in let pb = { pb with env = push_rel alias pb.env; tomatch = lift_tomatch_stack 1 rest; pred = lift_predicate 1 pb.pred pb.tomatch; history = pop_history_pattern pb.history; mat = List.map (push_alias_eqn alias) pb.mat } in let j = compile pb in { uj_val = if isRel c || isVar c || count_occurrences (mkRel 1) j.uj_val <= 1 then subst1 c j.uj_val else mkLetIn (na,c,t,j.uj_val); uj_type = subst1 c j.uj_type } in if isRel orig or isVar orig then (* Try to compile first using non expanded alias *) try f orig (Retyping.get_type_of pb.env !(pb.evdref) orig) with e when precatchable_exception e -> (* Try then to compile using expanded alias *) f expanded expanded_typ else (* Try to compile first using expanded alias *) try f expanded expanded_typ with e when precatchable_exception e -> (* Try then to compile using non expanded alias *) f orig (Retyping.get_type_of pb.env !(pb.evdref) orig) (* Remember that a non-trivial pattern has been consumed *) and compile_non_dep_alias pb rest = let pb = { pb with tomatch = rest; history = pop_history_pattern pb.history; mat = List.map drop_alias_eqn pb.mat } in compile pb (* pour les alias des initiaux, enrichir les env de ce qu'il faut et substituer aprÃĻs par les initiaux *) (**************************************************************************) (* Preparation of the pattern-matching problem *) (* builds the matrix of equations testing that each eqn has n patterns * and linearizing the _ patterns. * Syntactic correctness has already been done in astterm *) let matx_of_eqns env tomatchl eqns = let build_eqn (loc,ids,lpat,rhs) = let initial_lpat,initial_rhs = lpat,rhs in let initial_rhs = rhs in let rhs = { rhs_env = env; rhs_vars = free_glob_vars initial_rhs; avoid_ids = ids@(ids_of_named_context (named_context env)); it = Some initial_rhs } in { patterns = initial_lpat; alias_stack = []; eqn_loc = loc; used = ref false; rhs = rhs } in List.map build_eqn eqns (***************** Building an inversion predicate ************************) (* Let "match t1 in I1 u11..u1n_1 ... tm in Im um1..umn_m with ... end : T" be a pattern-matching problem. We assume that each uij can be decomposed under the form pij(vij1..vijq_ij) where pij(aij1..aijq_ij) is a pattern depending on some variables aijk and the vijk are instances of these variables. We also assume that each ti has the form of a pattern qi(wi1..wiq_i) where qi(bi1..biq_i) is a pattern depending on some variables bik and the wik are instances of these variables (in practice, there is no reason that ti is already constructed and the qi will be degenerated). We then look for a type U(..a1jk..b1 .. ..amjk..bm) so that T = U(..v1jk..t1 .. ..vmjk..tm). This a higher-order matching problem with a priori different solutions (one of them if T itself!). We finally invert the uij and the ti and build the return clause phi(x11..x1n_1y1..xm1..xmn_mym) = match x11..x1n_1 y1 .. xm1..xmn_m ym with | p11..p1n_1 q1 .. pm1..pmn_m qm => U(..a1jk..b1 .. ..amjk..bm) | _ .. _ _ .. _ .. _ _ => True end so that "phi(u11..u1n_1t1..um1..umn_mtm) = T" (note that the clause returning True never happens and any inhabited type can be put instead). *) let adjust_to_extended_env_and_remove_deps env extenv subst t = let n = rel_context_length (rel_context env) in let n' = rel_context_length (rel_context extenv) in (* We first remove the bindings that are dependently typed (they are difficult to manage and it is not sure these are so useful in practice); Notes: - [subst] is made of pairs [(id,u)] where id is a name in [extenv] and [u] a term typed in [env]; - [subst0] is made of items [(p,u,(u,ty))] where [ty] is the type of [u] and both are adjusted to [extenv] while [p] is the index of [id] in [extenv] (after expansion of the aliases) *) let subst0 = map_succeed (fun (x,u) -> (* d1 ... dn dn+1 ... dn'-p+1 ... dn' *) (* \--env-/ (= x:ty) *) (* \--------------extenv------------/ *) let (p,_,_) = lookup_rel_id x (rel_context extenv) in let rec traverse_local_defs p = match pi2 (lookup_rel p extenv) with | Some c -> assert (isRel c); traverse_local_defs (p + destRel c) | None -> p in let p = traverse_local_defs p in let u = lift (n'-n) u in (p,u,expand_vars_in_term extenv u)) subst in let t0 = lift (n'-n) t in (subst0,t0) let push_binder d (k,env,subst) = (k+1,push_rel d env,List.map (fun (na,u,d) -> (na,lift 1 u,d)) subst) let rec list_assoc_in_triple x = function [] -> raise Not_found | (a,b,_)::l -> if compare a x = 0 then b else list_assoc_in_triple x l (* Let vijk and ti be a set of dependent terms and T a type, all * defined in some environment env. The vijk and ti are supposed to be * instances for variables aijk and bi. * * [abstract_tycon Gamma0 Sigma subst T Gamma] looks for U(..v1jk..t1 .. ..vmjk..tm) * defined in some extended context * "Gamma0, ..a1jk:V1jk.. b1:W1 .. ..amjk:Vmjk.. bm:Wm" * such that env |- T = U(..v1jk..t1 .. ..vmjk..tm). To not commit to * a particular solution, we replace each subterm t in T that unifies with * a subset u1..ul of the vijk and ti by a special evar * ?id(x=t;c1:=c1,..,cl=cl) defined in context Gamma0,x,c1,...,cl |- ?id * (where the c1..cl are the aijk and bi matching the u1..ul), and * similarly for each ti. *) let abstract_tycon loc env evdref subst _tycon extenv t = let sigma = !evdref in let t = nf_betaiota sigma t in (* it helps in some cases to remove K-redex *) let subst0,t0 = adjust_to_extended_env_and_remove_deps env extenv subst t in (* We traverse the type T of the original problem Xi looking for subterms that match the non-constructor part of the constraints (this part is in subst); these subterms are the "good" subterms and we replace them by an evar that may depend (and only depend) on the corresponding convertible subterms of the substitution *) let rec aux (k,env,subst as x) t = let t = whd_evar !evdref t in match kind_of_term t with | Rel n when pi2 (lookup_rel n env) <> None -> map_constr_with_full_binders push_binder aux x t | Evar ev -> let ty = get_type_of env sigma t in let inst = list_map_i (fun i _ -> try list_assoc_in_triple i subst0 with Not_found -> mkRel i) 1 (rel_context env) in let ev = e_new_evar evdref env ~src:(loc, CasesType) ty in evdref := add_conv_pb (Reduction.CONV,env,substl inst ev,t) !evdref; ev | _ -> let good = List.filter (fun (_,u,_) -> is_conv_leq env sigma t u) subst in if good <> [] then let u = pi3 (List.hd good) in (* u is in extenv *) let vl = List.map pi1 good in let ty = lift (-k) (aux x (get_type_of env !evdref t)) in let depvl = free_rels ty in let inst = list_map_i (fun i _ -> if List.mem i vl then u else mkRel i) 1 (rel_context extenv) in let rel_filter = List.map (fun a -> not (isRel a) || dependent a u || Intset.mem (destRel a) depvl) inst in let named_filter = List.map (fun (id,_,_) -> dependent (mkVar id) u) (named_context extenv) in let filter = rel_filter@named_filter in let candidates = u :: List.map mkRel vl in let ev = e_new_evar evdref extenv ~src:(loc, CasesType) ~filter ~candidates ty in lift k ev else map_constr_with_full_binders push_binder aux x t in aux (0,extenv,subst0) t0 let build_tycon loc env tycon_env subst tycon extenv evdref t = let t,tt = match t with | None -> (* This is the situation we are building a return predicate and we are in an impossible branch *) let n = rel_context_length (rel_context env) in let n' = rel_context_length (rel_context tycon_env) in let tt = new_Type () in let impossible_case_type = e_new_evar evdref env ~src:(loc,ImpossibleCase) tt in (lift (n'-n) impossible_case_type, tt) | Some t -> let t = abstract_tycon loc tycon_env evdref subst tycon extenv t in let evd,tt = Typing.e_type_of extenv !evdref t in evdref := evd; (t,tt) in { uj_val = t; uj_type = tt } (* For a multiple pattern-matching problem Xi on t1..tn with return * type T, [build_inversion_problem Gamma Sigma (t1..tn) T] builds a return * predicate for Xi that is itself made by an auxiliary * pattern-matching problem of which the first clause reveals the * pattern structure of the constraints on the inductive types of the t1..tn, * and the second clause is a wildcard clause for catching the * impossible cases. See above "Building an inversion predicate" for * further explanations *) let build_inversion_problem loc env sigma tms t = let make_patvar t (subst,avoid) = let id = next_name_away (named_hd env t Anonymous) avoid in PatVar (dummy_loc,Name id), ((id,t)::subst, id::avoid) in let rec reveal_pattern t (subst,avoid as acc) = match kind_of_term (whd_betadeltaiota env sigma t) with | Construct cstr -> PatCstr (dummy_loc,cstr,[],Anonymous), acc | App (f,v) when isConstruct f -> let cstr = destConstruct f in let n = constructor_nrealargs env cstr in let l = list_lastn n (Array.to_list v) in let l,acc = list_fold_map' reveal_pattern l acc in PatCstr (dummy_loc,cstr,l,Anonymous), acc | _ -> make_patvar t acc in let rec aux n env acc_sign tms acc = match tms with | [] -> [], acc_sign, acc | (t, IsInd (_,IndType(indf,realargs),_)) :: tms -> let patl,acc = list_fold_map' reveal_pattern realargs acc in let pat,acc = make_patvar t acc in let indf' = lift_inductive_family n indf in let sign = make_arity_signature env true indf' in let sign = recover_alias_names alias_of_pat (pat :: List.rev patl) sign in let p = List.length realargs in let env' = push_rels sign env in let patl',acc_sign,acc = aux (n+p+1) env' (sign@acc_sign) tms acc in patl@pat::patl',acc_sign,acc | (t, NotInd (bo,typ)) :: tms -> let pat,acc = make_patvar t acc in let d = (alias_of_pat pat,None,t) in let patl,acc_sign,acc = aux (n+1) (push_rel d env) (d::acc_sign) tms acc in pat::patl,acc_sign,acc in let avoid0 = ids_of_context env in (* [patl] is a list of patterns revealing the substructure of constructors present in the constraints on the type of the multiple terms t1..tn that are matched in the original problem; [subst] is the substitution of the free pattern variables in [patl] that returns the non-constructor parts of the constraints. Especially, if the ti has type I ui1..uin_i, and the patterns associated to ti are pi1..pin_i, then subst(pij) is uij; the substitution is useful to recognize which subterms of the whole type T of the original problem have to be abstracted *) let patl,sign,(subst,avoid) = aux 0 env [] tms ([],avoid0) in let n = List.length sign in let decls = list_map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 sign in let pb_env = push_rels sign env in let decls = List.map (fun (c,d) -> (c,extract_inductive_data pb_env sigma d,d)) decls in let decls = List.rev decls in let dep_sign = find_dependencies_signature (list_make n true) decls in let sub_tms = List.map2 (fun deps (tm,(tmtyp,_),(na,b,t)) -> let na = if deps = [] then Anonymous else force_name na in Pushed ((tm,tmtyp),deps,na)) dep_sign decls in let subst = List.map (fun (na,t) -> (na,lift n t)) subst in (* [eqn1] is the first clause of the auxiliary pattern-matching that serves as skeleton for the return type: [patl] is the substructure of constructors extracted from the list of constraints on the inductive types of the multiple terms matched in the original pattern-matching problem Xi *) let eqn1 = { patterns = patl; alias_stack = []; eqn_loc = dummy_loc; used = ref false; rhs = { rhs_env = pb_env; (* we assume all vars are used; in practice we discard dependent vars so that the field rhs_vars is normally not used *) rhs_vars = List.map fst subst; avoid_ids = avoid; it = Some (lift n t) } } in (* [eqn2] is the default clause of the auxiliary pattern-matching: it will catch the clauses of the original pattern-matching problem Xi whose type constraints are incompatible with the constraints on the inductive types of the multiple terms matched in Xi *) let eqn2 = { patterns = List.map (fun _ -> PatVar (dummy_loc,Anonymous)) patl; alias_stack = []; eqn_loc = dummy_loc; used = ref false; rhs = { rhs_env = pb_env; rhs_vars = []; avoid_ids = avoid0; it = None } } in (* [pb] is the auxiliary pattern-matching serving as skeleton for the return type of the original problem Xi *) let evdref = ref sigma in let pb = { env = pb_env; evdref = evdref; pred = new_Type(); tomatch = sub_tms; history = start_history n; mat = [eqn1;eqn2]; caseloc = loc; casestyle = RegularStyle; typing_function = build_tycon loc env pb_env subst} in let pred = (compile pb).uj_val in (!evdref,pred) (* Here, [pred] is assumed to be in the context built from all *) (* realargs and terms to match *) let build_initial_predicate arsign pred = let rec buildrec n pred tmnames = function | [] -> List.rev tmnames,pred | ((na,c,t)::realdecls)::lnames -> let n' = n + List.length realdecls in buildrec (n'+1) pred (force_name na::tmnames) lnames | _ -> assert false in buildrec 0 pred [] (List.rev arsign) let extract_arity_signature env0 tomatchl tmsign = let get_one_sign n tm (na,t) = match tm with | NotInd (bo,typ) -> (match t with | None -> [na,Option.map (lift n) bo,lift n typ] | Some (loc,_,_,_) -> user_err_loc (loc,"", str"Unexpected type annotation for a term of non inductive type.")) | IsInd (term,IndType(indf,realargs),_) -> let indf' = lift_inductive_family n indf in let (ind,_) = dest_ind_family indf' in let nparams_ctxt,nrealargs_ctxt = inductive_nargs env0 ind in let arsign = fst (get_arity env0 indf') in let realnal = match t with | Some (loc,ind',nparams,realnal) -> if ind <> ind' then user_err_loc (loc,"",str "Wrong inductive type."); if nparams_ctxt <> nparams or nrealargs_ctxt <> List.length realnal then anomaly "Ill-formed 'in' clause in cases"; List.rev realnal | None -> list_make nrealargs_ctxt Anonymous in (na,None,build_dependent_inductive env0 indf') ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in let rec buildrec n = function | [],[] -> [] | (_,tm)::ltm, (_,x)::tmsign -> let l = get_one_sign n tm x in l :: buildrec (n + List.length l) (ltm,tmsign) | _ -> assert false in List.rev (buildrec 0 (tomatchl,tmsign)) let inh_conv_coerce_to_tycon loc env evdref j tycon = match tycon with | Some p -> let (evd',j) = Coercion.inh_conv_coerce_to true loc env !evdref j p in evdref := evd'; j | None -> j (* We put the tycon inside the arity signature, possibly discovering dependencies. *) let prepare_predicate_from_arsign_tycon loc tomatchs arsign c = let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in let subst, len = List.fold_left2 (fun (subst, len) (tm, tmtype) sign -> let signlen = List.length sign in match kind_of_term tm with | Rel n when dependent tm c && signlen = 1 (* The term to match is not of a dependent type itself *) -> ((n, len) :: subst, len - signlen) | Rel n when signlen > 1 (* The term is of a dependent type, maybe some variable in its type appears in the tycon. *) -> (match tmtype with NotInd _ -> (subst, len - signlen) | IsInd (_, IndType(indf,realargs),_) -> let subst = if dependent tm c && List.for_all isRel realargs then (n, 1) :: subst else subst in List.fold_left (fun (subst, len) arg -> match kind_of_term arg with | Rel n when dependent arg c -> ((n, len) :: subst, pred len) | _ -> (subst, pred len)) (subst, len) realargs) | _ -> (subst, len - signlen)) ([], nar) tomatchs arsign in let rec predicate lift c = match kind_of_term c with | Rel n when n > lift -> (try (* Make the predicate dependent on the matched variable *) let idx = List.assoc (n - lift) subst in mkRel (idx + lift) with Not_found -> (* A variable that is not matched, lift over the arsign. *) mkRel (n + nar)) | _ -> map_constr_with_binders succ predicate lift c in predicate 0 c (* Builds the predicate. If the predicate is dependent, its context is * made of 1+nrealargs assumptions for each matched term in an inductive * type and 1 assumption for each term not _syntactically_ in an * inductive type. * Each matched terms are independently considered dependent or not. * A type constraint but no annotation case: we try to specialize the * tycon to make the predicate if it is not closed. *) let prepare_predicate loc typing_fun sigma env tomatchs arsign tycon pred = let preds = match pred, tycon with (* No type annotation *) | None, Some (None, t) when not (noccur_with_meta 0 max_int t) -> (* If the tycon is not closed w.r.t real variables, we try *) (* two different strategies *) (* First strategy: we abstract the tycon wrt to the dependencies *) let pred1 = prepare_predicate_from_arsign_tycon loc tomatchs arsign t in (* Second strategy: we build an "inversion" predicate *) let sigma2,pred2 = build_inversion_problem loc env sigma tomatchs t in [sigma, pred1; sigma2, pred2] | None, _ -> (* No dependent type constraint, or no constraints at all: *) (* we use two strategies *) let sigma,t = match tycon with | Some (None, t) -> sigma,t | _ -> new_type_evar sigma env ~src:(loc, CasesType) in (* First strategy: we build an "inversion" predicate *) let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in (* Second strategy: we directly use the evar as a non dependent pred *) let pred2 = lift (List.length (List.flatten arsign)) t in [sigma1, pred1; sigma, pred2] (* Some type annotation *) | Some rtntyp, _ -> (* We extract the signature of the arity *) let envar = List.fold_right push_rels arsign env in let sigma, newt = new_sort_variable sigma in let evdref = ref sigma in let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref rtntyp in let sigma = Option.cata (fun tycon -> let na = Name (id_of_string "x") in let tms = List.map (fun tm -> Pushed(tm,[],na)) tomatchs in let predinst = extract_predicate predcclj.uj_val tms in Coercion.inh_conv_coerces_to loc env !evdref predinst tycon) !evdref tycon in let predccl = (j_nf_evar sigma predcclj).uj_val in [sigma, predccl] in List.map (fun (sigma,pred) -> let (nal,pred) = build_initial_predicate arsign pred in sigma,nal,pred) preds (**************************************************************************) (* Main entry of the matching compilation *) let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, eqns) = (* We build the matrix of patterns and right-hand side *) let matx = matx_of_eqns env tomatchl eqns in (* We build the vector of terms to match consistently with the *) (* constructors found in patterns *) let tomatchs = coerce_to_indtype typing_fun evdref env matx tomatchl in (* If an elimination predicate is provided, we check it is compatible with the type of arguments to match; if none is provided, we build alternative possible predicates *) let arsign = extract_arity_signature env tomatchs tomatchl in let preds = prepare_predicate loc typing_fun !evdref env tomatchs arsign tycon predopt in let compile_for_one_predicate (sigma,nal,pred) = (* We push the initial terms to match and push their alias to rhs' envs *) (* names of aliases will be recovered from patterns (hence Anonymous *) (* here) *) let out_tmt na = function NotInd (c,t) -> (na,c,t) | IsInd (typ,_,_) -> (na,None,typ) in let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in let typs = List.map (fun (c,d) -> (c,extract_inductive_data env sigma d,d)) typs in let dep_sign = find_dependencies_signature (list_make (List.length typs) true) typs in let typs' = list_map3 (fun (tm,tmt) deps na -> let deps = if not (isRel tm) then [] else deps in ((tm,tmt),deps,na)) tomatchs dep_sign nal in let initial_pushed = List.map (fun x -> Pushed x) typs' in (* A typing function that provides with a canonical term for absurd cases*) let typing_fun tycon env evdref = function | Some t -> typing_fun tycon env evdref t | None -> coq_unit_judge () in let myevdref = ref sigma in let pb = { env = env; evdref = myevdref; pred = pred; tomatch = initial_pushed; history = start_history (List.length initial_pushed); mat = matx; caseloc = loc; casestyle = style; typing_function = typing_fun } in let j = compile pb in evdref := !myevdref; j in (* Return the term compiled with the first possible elimination *) (* predicate for which the compilation succeeds *) let j = list_try_compile compile_for_one_predicate preds in (* We check for unused patterns *) List.iter (check_unused_pattern env) matx; (* We coerce to the tycon (if an elim predicate was provided) *) inh_conv_coerce_to_tycon loc env evdref j tycon end coq-8.4pl4/pretyping/typing.mli0000644000175000017500000000302112326224777015665 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* evar_map -> constr -> types (** Typecheck a term and return its type + updated evars *) val e_type_of : env -> evar_map -> constr -> evar_map * types (** Typecheck a type and return its sort *) val sort_of : env -> evar_map -> types -> sorts (** Typecheck a term has a given type (assuming the type is OK) *) val check : env -> evar_map -> constr -> types -> unit (** Returns the instantiated type of a metavariable *) val meta_type : evar_map -> metavariable -> types (** Solve existential variables using typing *) val solve_evars : env -> evar_map -> constr -> evar_map * constr (** Raise an error message if incorrect elimination for this inductive *) (** (first constr is term to match, second is return predicate) *) val check_allowed_sort : env -> evar_map -> inductive -> constr -> constr -> unit coq-8.4pl4/pretyping/doc.tex0000644000175000017500000000032712326224777015145 0ustar stephsteph \newpage \section*{Pre-typing} \ocwsection \label{pretyping} \bigskip \begin{center}\epsfig{file=pretyping.dep.ps,width=\linewidth}\end{center} %%% Local Variables: %%% mode: latex %%% TeX-master: t %%% End: coq-8.4pl4/pretyping/pattern.mli0000644000175000017500000001124212326224777016034 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ?p,fun y x => ?p)] => [forall x y => p]] will be accepted. Thanks to the reference by index, a matching problem like [match ... with [(fun x => ?p)] => [forall x => p]] will work even if [x] is also the name of an existing goal variable. Note: we do not keep types in the signature. Besides simplicity, the main reason is that it would force to close the signature over binders that occur only in the types of effective binders but not in the term itself (e.g. for a term [f x] with [f:A -> True] and [x:A]). On the opposite side, by not keeping the types, we loose opportunity to propagate type informations which otherwise would not be inferable, as e.g. when matching [forall x, x = 0] with pattern [forall x, ?h = 0] and using the solution "x|-h:=x" in expression [forall x, h = x] where nothing tells how the type of x could be inferred. We also loose the ability of typing ltac variables before calling the right-hand-side of ltac matching clauses. *) type constr_under_binders = identifier list * constr (** Types of substitutions with or w/o bound variables *) type patvar_map = (patvar * constr) list type extended_patvar_map = (patvar * constr_under_binders) list (** {5 Patterns} *) type case_info_pattern = { cip_style : case_style; cip_ind : inductive option; cip_ind_args : (int * int) option; (** number of params and args *) cip_extensible : bool (** does this match end with _ => _ ? *) } type constr_pattern = | PRef of global_reference | PVar of identifier | PEvar of existential_key * constr_pattern array | PRel of int | PApp of constr_pattern * constr_pattern array | PSoApp of patvar * constr_pattern list | PLambda of name * constr_pattern * constr_pattern | PProd of name * constr_pattern * constr_pattern | PLetIn of name * constr_pattern * constr_pattern | PSort of glob_sort | PMeta of patvar option | PIf of constr_pattern * constr_pattern * constr_pattern | PCase of case_info_pattern * constr_pattern * constr_pattern * (int * int * constr_pattern) list (** index of constructor, nb of args *) | PFix of fixpoint | PCoFix of cofixpoint (** Nota : in a [PCase], the array of branches might be shorter than expected, denoting the use of a final "_ => _" branch *) (** {5 Functions on patterns} *) val occur_meta_pattern : constr_pattern -> bool val subst_pattern : substitution -> constr_pattern -> constr_pattern exception BoundPattern (** [head_pattern_bound t] extracts the head variable/constant of the type [t] or raises [BoundPattern] (even if a sort); it raises an anomaly if [t] is an abstraction *) val head_pattern_bound : constr_pattern -> global_reference (** [head_of_constr_reference c] assumes [r] denotes a reference and returns its label; raises an anomaly otherwise *) val head_of_constr_reference : Term.constr -> global_reference (** [pattern_of_constr c] translates a term [c] with metavariables into a pattern; currently, no destructor (Cases, Fix, Cofix) and no existential variable are allowed in [c] *) val pattern_of_constr : Evd.evar_map -> constr -> named_context * constr_pattern (** [pattern_of_glob_constr l c] translates a term [c] with metavariables into a pattern; variables bound in [l] are replaced by the pattern to which they are bound *) val pattern_of_glob_constr : glob_constr -> patvar list * constr_pattern val instantiate_pattern : Evd.evar_map -> (identifier * (identifier list * constr)) list -> constr_pattern -> constr_pattern val lift_pattern : int -> constr_pattern -> constr_pattern coq-8.4pl4/pretyping/typeclasses.mli0000644000175000017500000001103212326224777016713 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* instance list val typeclasses : unit -> typeclass list val all_instances : unit -> instance list val add_class : typeclass -> unit val add_constant_class : constant -> unit val add_inductive_class : inductive -> unit val new_instance : typeclass -> int option -> bool -> global_reference -> instance val add_instance : instance -> unit val remove_instance : instance -> unit val class_info : global_reference -> typeclass (** raises a UserError if not a class *) (** These raise a UserError if not a class. *) val dest_class_app : env -> constr -> typeclass * constr list (** Just return None if not a class *) val class_of_constr : constr -> (rel_context * (typeclass * constr list)) option val instance_impl : instance -> global_reference val is_class : global_reference -> bool val is_instance : global_reference -> bool (** Returns the term and type for the given instance of the parameters and fields of the type class. *) val instance_constructor : typeclass -> constr list -> constr option * types (** Resolvability. Only undefined evars could be marked or checked for resolvability. *) val is_resolvable : evar_info -> bool val mark_unresolvable : evar_info -> evar_info val mark_resolvable : evar_info -> evar_info val mark_unresolvables : evar_map -> evar_map val is_class_evar : evar_map -> evar_info -> bool (** Filter which evars to consider for resolution. *) type evar_filter = hole_kind -> bool val no_goals : evar_filter val all_evars : evar_filter val resolve_typeclasses : ?filter:evar_filter -> ?split:bool -> ?fail:bool -> env -> evar_map -> evar_map val resolve_one_typeclass : env -> evar_map -> types -> open_constr val register_set_typeclass_transparency : (evaluable_global_reference -> bool (*local?*) -> bool -> unit) -> unit val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit val register_classes_transparent_state : (unit -> transparent_state) -> unit val classes_transparent_state : unit -> transparent_state val register_add_instance_hint : (constr -> bool (* local? *) -> int option -> unit) -> unit val register_remove_instance_hint : (global_reference -> unit) -> unit val add_instance_hint : constr -> bool -> int option -> unit val remove_instance_hint : global_reference -> unit val solve_instanciations_problem : (env -> evar_map -> evar_filter -> bool -> bool -> evar_map) ref val solve_instanciation_problem : (env -> evar_map -> types -> open_constr) ref val declare_instance : int option -> bool -> global_reference -> unit (** Build the subinstances hints for a given typeclass object. check tells if we should check for existence of the subinstances and add only the missing ones. *) val build_subclasses : check:bool -> env -> evar_map -> global_reference -> int option (* priority *) -> (int option * constr) list coq-8.4pl4/pretyping/detyping.ml0000644000175000017500000006114512326224777016040 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* inductive val member_message : std_ppcmds -> bool -> std_ppcmds val field : string val title : string end) -> struct type t = inductive let encode = Test.encode let subst subst (kn, ints as obj) = let kn' = subst_ind subst kn in if kn' == kn then obj else kn', ints let printer ind = pr_global_env Idset.empty (IndRef ind) let key = ["Printing";Test.field] let title = Test.title let member_message x = Test.member_message (printer x) let synchronous = true end module PrintingCasesIf = PrintingInductiveMake (struct let encode = encode_bool let field = "If" let title = "Types leading to pretty-printing of Cases using a `if' form: " let member_message s b = str "Cases on elements of " ++ s ++ str (if b then " are printed using a `if' form" else " are not printed using a `if' form") end) module PrintingCasesLet = PrintingInductiveMake (struct let encode = encode_tuple let field = "Let" let title = "Types leading to a pretty-printing of Cases using a `let' form:" let member_message s b = str "Cases on elements of " ++ s ++ str (if b then " are printed using a `let' form" else " are not printed using a `let' form") end) module PrintingIf = Goptions.MakeRefTable(PrintingCasesIf) module PrintingLet = Goptions.MakeRefTable(PrintingCasesLet) (* Flags.for printing or not wildcard and synthetisable types *) open Goptions let wildcard_value = ref true let force_wildcard () = !wildcard_value let _ = declare_bool_option { optsync = true; optdepr = false; optname = "forced wildcard"; optkey = ["Printing";"Wildcard"]; optread = force_wildcard; optwrite = (:=) wildcard_value } let synth_type_value = ref true let synthetize_type () = !synth_type_value let _ = declare_bool_option { optsync = true; optdepr = false; optname = "pattern matching return type synthesizability"; optkey = ["Printing";"Synth"]; optread = synthetize_type; optwrite = (:=) synth_type_value } let reverse_matching_value = ref true let reverse_matching () = !reverse_matching_value let _ = declare_bool_option { optsync = true; optdepr = false; optname = "pattern-matching reversibility"; optkey = ["Printing";"Matching"]; optread = reverse_matching; optwrite = (:=) reverse_matching_value } (* Auxiliary function for MutCase printing *) (* [computable] tries to tell if the predicate typing the result is inferable*) let computable p k = (* We first remove as many lambda as the arity, then we look if it remains a lambda for a dependent elimination. This function works for normal eta-expanded term. For non eta-expanded or non-normal terms, it may affirm the pred is synthetisable because of an undetected ultimate dependent variable in the second clause, or else, it may affirms the pred non synthetisable because of a non normal term in the fourth clause. A solution could be to store, in the MutCase, the eta-expanded normal form of pred to decide if it depends on its variables Lorsque le prédicat est dépendant de maničre certaine, on ne déclare pas le prédicat synthétisable (męme si la variable dépendante ne l'est pas effectivement) parce que sinon on perd la réciprocité de la synthčse (qui, lui, engendrera un prédicat non dépendant) *) let sign,ccl = decompose_lam_assum p in (rel_context_length sign = k+1) && noccur_between 1 (k+1) ccl let lookup_name_as_displayed env t s = let rec lookup avoid n c = match kind_of_term c with | Prod (name,_,c') -> (match compute_displayed_name_in RenamingForGoal avoid name c' with | (Name id,avoid') -> if id=s then Some n else lookup avoid' (n+1) c' | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) | LetIn (name,_,_,c') -> (match compute_displayed_name_in RenamingForGoal avoid name c' with | (Name id,avoid') -> if id=s then Some n else lookup avoid' (n+1) c' | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) | Cast (c,_,_) -> lookup avoid n c | _ -> None in lookup (ids_of_named_context (named_context env)) 1 t let lookup_index_as_renamed env t n = let rec lookup n d c = match kind_of_term c with | Prod (name,_,c') -> (match compute_displayed_name_in RenamingForGoal [] name c' with (Name _,_) -> lookup n (d+1) c' | (Anonymous,_) -> if n=0 then Some (d-1) else if n=1 then Some d else lookup (n-1) (d+1) c') | LetIn (name,_,_,c') -> (match compute_displayed_name_in RenamingForGoal [] name c' with | (Name _,_) -> lookup n (d+1) c' | (Anonymous,_) -> if n=0 then Some (d-1) else if n=1 then Some d else lookup (n-1) (d+1) c' ) | Cast (c,_,_) -> lookup n d c | _ -> if n=0 then Some (d-1) else None in lookup n 1 t (**********************************************************************) (* Fragile algorithm to reverse pattern-matching compilation *) let update_name na ((_,e),c) = match na with | Name _ when force_wildcard () & noccurn (list_index na e) c -> Anonymous | _ -> na let rec decomp_branch n nal b (avoid,env as e) c = let flag = if b then RenamingForGoal else RenamingForCasesPattern in if n=0 then (List.rev nal,(e,c)) else let na,c,f = match kind_of_term (strip_outer_cast c) with | Lambda (na,_,c) -> na,c,compute_displayed_let_name_in | LetIn (na,_,_,c) -> na,c,compute_displayed_name_in | _ -> Name (id_of_string "x"),(applist (lift 1 c, [mkRel 1])), compute_displayed_name_in in let na',avoid' = f flag avoid na c in decomp_branch (n-1) (na'::nal) b (avoid',add_name na' env) c let rec build_tree na isgoal e ci cl = let mkpat n rhs pl = PatCstr(dl,(ci.ci_ind,n+1),pl,update_name na rhs) in let cnl = ci.ci_cstr_ndecls in List.flatten (list_tabulate (fun i -> contract_branch isgoal e (cnl.(i),mkpat i,cl.(i))) (Array.length cl)) and align_tree nal isgoal (e,c as rhs) = match nal with | [] -> [[],rhs] | na::nal -> match kind_of_term c with | Case (ci,p,c,cl) when c = mkRel (list_index na (snd e)) & (* don't contract if p dependent *) computable p (ci.ci_pp_info.ind_nargs) -> let clauses = build_tree na isgoal e ci cl in List.flatten (List.map (fun (pat,rhs) -> let lines = align_tree nal isgoal rhs in List.map (fun (hd,rest) -> pat::hd,rest) lines) clauses) | _ -> let pat = PatVar(dl,update_name na rhs) in let mat = align_tree nal isgoal rhs in List.map (fun (hd,rest) -> pat::hd,rest) mat and contract_branch isgoal e (cn,mkpat,b) = let nal,rhs = decomp_branch cn [] isgoal e b in let mat = align_tree nal isgoal rhs in List.map (fun (hd,rhs) -> (mkpat rhs hd,rhs)) mat (**********************************************************************) (* Transform internal representation of pattern-matching into list of *) (* clauses *) let is_nondep_branch c n = try let sign,ccl = decompose_lam_n_assum n c in noccur_between 1 (rel_context_length sign) ccl with e when Errors.noncritical e -> (* Not eta-expanded or not reduced *) false let extract_nondep_branches test c b n = let rec strip n r = if n=0 then r else match r with | GLambda (_,_,_,_,t) -> strip (n-1) t | GLetIn (_,_,_,t) -> strip (n-1) t | _ -> assert false in if test c n then Some (strip n b) else None let it_destRLambda_or_LetIn_names n c = let rec aux n nal c = if n=0 then (List.rev nal,c) else match c with | GLambda (_,na,_,_,c) -> aux (n-1) (na::nal) c | GLetIn (_,na,_,c) -> aux (n-1) (na::nal) c | _ -> (* eta-expansion *) let rec next l = let x = next_ident_away (id_of_string "x") l in (* Not efficient but unusual and no function to get free glob_vars *) (* if occur_glob_constr x c then next (x::l) else x in *) x in let x = next (free_glob_vars c) in let a = GVar (dl,x) in aux (n-1) (Name x :: nal) (match c with | GApp (loc,p,l) -> GApp (loc,p,l@[a]) | _ -> (GApp (dl,c,[a]))) in aux n [] c let detype_case computable detype detype_eqns testdep avoid data p c bl = let (indsp,st,nparams,consnargsl,k) = data in let synth_type = synthetize_type () in let tomatch = detype c in let alias, aliastyp, pred= if (not !Flags.raw_print) & synth_type & computable & Array.length bl<>0 then Anonymous, None, None else match Option.map detype p with | None -> Anonymous, None, None | Some p -> let nl,typ = it_destRLambda_or_LetIn_names k p in let n,typ = match typ with | GLambda (_,x,_,t,c) -> x, c | _ -> Anonymous, typ in let aliastyp = if List.for_all ((=) Anonymous) nl then None else Some (dl,indsp,nparams,nl) in n, aliastyp, Some typ in let constructs = Array.init (Array.length bl) (fun i -> (indsp,i+1)) in let tag = try if !Flags.raw_print then RegularStyle else if st = LetPatternStyle then st else if PrintingLet.active indsp then LetStyle else if PrintingIf.active indsp then IfStyle else st with Not_found -> st in match tag with | LetStyle when aliastyp = None -> let bl' = Array.map detype bl in let (nal,d) = it_destRLambda_or_LetIn_names consnargsl.(0) bl'.(0) in GLetTuple (dl,nal,(alias,pred),tomatch,d) | IfStyle when aliastyp = None -> let bl' = Array.map detype bl in let nondepbrs = array_map3 (extract_nondep_branches testdep) bl bl' consnargsl in if array_for_all ((<>) None) nondepbrs then GIf (dl,tomatch,(alias,pred), Option.get nondepbrs.(0),Option.get nondepbrs.(1)) else let eqnl = detype_eqns constructs consnargsl bl in GCases (dl,tag,pred,[tomatch,(alias,aliastyp)],eqnl) | _ -> let eqnl = detype_eqns constructs consnargsl bl in GCases (dl,tag,pred,[tomatch,(alias,aliastyp)],eqnl) let detype_sort = function | Prop c -> GProp c | Type u -> GType (Some u) type binder_kind = BProd | BLambda | BLetIn (**********************************************************************) (* Main detyping function *) let detype_anonymous = ref (fun loc n -> anomaly "detype: index to an anonymous variable") let set_detype_anonymous f = detype_anonymous := f let rec detype (isgoal:bool) avoid env t = match kind_of_term (collapse_appl t) with | Rel n -> (try match lookup_name_of_rel n env with | Name id -> GVar (dl, id) | Anonymous -> !detype_anonymous dl n with Not_found -> let s = "_UNBOUND_REL_"^(string_of_int n) in GVar (dl, id_of_string s)) | Meta n -> (* Meta in constr are not user-parsable and are mapped to Evar *) GEvar (dl, n, None) | Var id -> (try let _ = Global.lookup_named id in GRef (dl, VarRef id) with e when Errors.noncritical e -> GVar (dl, id)) | Sort s -> GSort (dl,detype_sort s) | Cast (c1,REVERTcast,c2) when not !Flags.raw_print -> detype isgoal avoid env c1 | Cast (c1,k,c2) -> GCast(dl,detype isgoal avoid env c1, CastConv (k, detype isgoal avoid env c2)) | Prod (na,ty,c) -> detype_binder isgoal BProd avoid env na ty c | Lambda (na,ty,c) -> detype_binder isgoal BLambda avoid env na ty c | LetIn (na,b,_,c) -> detype_binder isgoal BLetIn avoid env na b c | App (f,args) -> GApp (dl,detype isgoal avoid env f, array_map_to_list (detype isgoal avoid env) args) | Const sp -> GRef (dl, ConstRef sp) | Evar (ev,cl) -> GEvar (dl, ev, Some (List.map (detype isgoal avoid env) (Array.to_list cl))) | Ind ind_sp -> GRef (dl, IndRef ind_sp) | Construct cstr_sp -> GRef (dl, ConstructRef cstr_sp) | Case (ci,p,c,bl) -> let comp = computable p (ci.ci_pp_info.ind_nargs) in detype_case comp (detype isgoal avoid env) (detype_eqns isgoal avoid env ci comp) is_nondep_branch avoid (ci.ci_ind,ci.ci_pp_info.style,ci.ci_npar, ci.ci_cstr_ndecls,ci.ci_pp_info.ind_nargs) (Some p) c bl | Fix (nvn,recdef) -> detype_fix isgoal avoid env nvn recdef | CoFix (n,recdef) -> detype_cofix isgoal avoid env n recdef and detype_fix isgoal avoid env (vn,_ as nvn) (names,tys,bodies) = let def_avoid, def_env, lfi = Array.fold_left (fun (avoid, env, l) na -> let id = next_name_away na avoid in (id::avoid, add_name (Name id) env, id::l)) (avoid, env, []) names in let n = Array.length tys in let v = array_map3 (fun c t i -> share_names isgoal (i+1) [] def_avoid def_env c (lift n t)) bodies tys vn in GRec(dl,GFix (Array.map (fun i -> Some i, GStructRec) (fst nvn), snd nvn),Array.of_list (List.rev lfi), Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) and detype_cofix isgoal avoid env n (names,tys,bodies) = let def_avoid, def_env, lfi = Array.fold_left (fun (avoid, env, l) na -> let id = next_name_away na avoid in (id::avoid, add_name (Name id) env, id::l)) (avoid, env, []) names in let ntys = Array.length tys in let v = array_map2 (fun c t -> share_names isgoal 0 [] def_avoid def_env c (lift ntys t)) bodies tys in GRec(dl,GCoFix n,Array.of_list (List.rev lfi), Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) and share_names isgoal n l avoid env c t = match kind_of_term c, kind_of_term t with (* factorize even when not necessary to have better presentation *) | Lambda (na,t,c), Prod (na',t',c') -> let na = match (na,na') with Name _, _ -> na | _, Name _ -> na' | _ -> na in let t = detype isgoal avoid env t in let id = next_name_away na avoid in let avoid = id::avoid and env = add_name (Name id) env in share_names isgoal (n-1) ((Name id,Explicit,None,t)::l) avoid env c c' (* May occur for fix built interactively *) | LetIn (na,b,t',c), _ when n > 0 -> let t' = detype isgoal avoid env t' in let b = detype isgoal avoid env b in let id = next_name_away na avoid in let avoid = id::avoid and env = add_name (Name id) env in share_names isgoal n ((Name id,Explicit,Some b,t')::l) avoid env c (lift 1 t) (* Only if built with the f/n notation or w/o let-expansion in types *) | _, LetIn (_,b,_,t) when n > 0 -> share_names isgoal n l avoid env c (subst1 b t) (* If it is an open proof: we cheat and eta-expand *) | _, Prod (na',t',c') when n > 0 -> let t' = detype isgoal avoid env t' in let id = next_name_away na' avoid in let avoid = id::avoid and env = add_name (Name id) env in let appc = mkApp (lift 1 c,[|mkRel 1|]) in share_names isgoal (n-1) ((Name id,Explicit,None,t')::l) avoid env appc c' (* If built with the f/n notation: we renounce to share names *) | _ -> if n>0 then msg_warn "Detyping.detype: cannot factorize fix enough"; let c = detype isgoal avoid env c in let t = detype isgoal avoid env t in (List.rev l,c,t) and detype_eqns isgoal avoid env ci computable constructs consnargsl bl = try if !Flags.raw_print or not (reverse_matching ()) then raise Exit; let mat = build_tree Anonymous isgoal (avoid,env) ci bl in List.map (fun (pat,((avoid,env),c)) -> (dl,[],[pat],detype isgoal avoid env c)) mat with e when Errors.noncritical e -> Array.to_list (array_map3 (detype_eqn isgoal avoid env) constructs consnargsl bl) and detype_eqn isgoal avoid env constr construct_nargs branch = let make_pat x avoid env b ids = if force_wildcard () & noccurn 1 b then PatVar (dl,Anonymous),avoid,(add_name Anonymous env),ids else let id = next_name_away_in_cases_pattern x avoid in PatVar (dl,Name id),id::avoid,(add_name (Name id) env),id::ids in let rec buildrec ids patlist avoid env n b = if n=0 then (dl, ids, [PatCstr(dl, constr, List.rev patlist,Anonymous)], detype isgoal avoid env b) else match kind_of_term b with | Lambda (x,_,b) -> let pat,new_avoid,new_env,new_ids = make_pat x avoid env b ids in buildrec new_ids (pat::patlist) new_avoid new_env (n-1) b | LetIn (x,_,_,b) -> let pat,new_avoid,new_env,new_ids = make_pat x avoid env b ids in buildrec new_ids (pat::patlist) new_avoid new_env (n-1) b | Cast (c,_,_) -> (* Oui, il y a parfois des cast *) buildrec ids patlist avoid env n c | _ -> (* eta-expansion : n'arrivera plus lorsque tous les termes seront construits ā partir de la syntaxe Cases *) (* nommage de la nouvelle variable *) let new_b = applist (lift 1 b, [mkRel 1]) in let pat,new_avoid,new_env,new_ids = make_pat Anonymous avoid env new_b ids in buildrec new_ids (pat::patlist) new_avoid new_env (n-1) new_b in buildrec [] [] avoid env construct_nargs branch and detype_binder isgoal bk avoid env na ty c = let flag = if isgoal then RenamingForGoal else RenamingElsewhereFor (env,c) in let na',avoid' = if bk = BLetIn then compute_displayed_let_name_in flag avoid na c else compute_displayed_name_in flag avoid na c in let r = detype isgoal avoid' (add_name na' env) c in match bk with | BProd -> GProd (dl, na',Explicit,detype false avoid env ty, r) | BLambda -> GLambda (dl, na',Explicit,detype false avoid env ty, r) | BLetIn -> GLetIn (dl, na',detype false avoid env ty, r) let rec detype_rel_context where avoid env sign = let where = Option.map (fun c -> it_mkLambda_or_LetIn c sign) where in let rec aux avoid env = function | [] -> [] | (na,b,t)::rest -> let na',avoid' = match where with | None -> na,avoid | Some c -> if b<>None then compute_displayed_let_name_in (RenamingElsewhereFor (env,c)) avoid na c else compute_displayed_name_in (RenamingElsewhereFor (env,c)) avoid na c in let b = Option.map (detype false avoid env) b in let t = detype false avoid env t in (na',Explicit,b,t) :: aux avoid' (add_name na' env) rest in aux avoid env (List.rev sign) (**********************************************************************) (* Module substitution: relies on detyping *) let rec subst_cases_pattern subst pat = match pat with | PatVar _ -> pat | PatCstr (loc,((kn,i),j),cpl,n) -> let kn' = subst_ind subst kn and cpl' = list_smartmap (subst_cases_pattern subst) cpl in if kn' == kn && cpl' == cpl then pat else PatCstr (loc,((kn',i),j),cpl',n) let rec subst_glob_constr subst raw = match raw with | GRef (loc,ref) -> let ref',t = subst_global subst ref in if ref' == ref then raw else detype false [] [] t | GVar _ -> raw | GEvar _ -> raw | GPatVar _ -> raw | GApp (loc,r,rl) -> let r' = subst_glob_constr subst r and rl' = list_smartmap (subst_glob_constr subst) rl in if r' == r && rl' == rl then raw else GApp(loc,r',rl') | GLambda (loc,n,bk,r1,r2) -> let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in if r1' == r1 && r2' == r2 then raw else GLambda (loc,n,bk,r1',r2') | GProd (loc,n,bk,r1,r2) -> let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in if r1' == r1 && r2' == r2 then raw else GProd (loc,n,bk,r1',r2') | GLetIn (loc,n,r1,r2) -> let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in if r1' == r1 && r2' == r2 then raw else GLetIn (loc,n,r1',r2') | GCases (loc,sty,rtno,rl,branches) -> let rtno' = Option.smartmap (subst_glob_constr subst) rtno and rl' = list_smartmap (fun (a,x as y) -> let a' = subst_glob_constr subst a in let (n,topt) = x in let topt' = Option.smartmap (fun (loc,(sp,i),x,y as t) -> let sp' = subst_ind subst sp in if sp == sp' then t else (loc,(sp',i),x,y)) topt in if a == a' && topt == topt' then y else (a',(n,topt'))) rl and branches' = list_smartmap (fun (loc,idl,cpl,r as branch) -> let cpl' = list_smartmap (subst_cases_pattern subst) cpl and r' = subst_glob_constr subst r in if cpl' == cpl && r' == r then branch else (loc,idl,cpl',r')) branches in if rtno' == rtno && rl' == rl && branches' == branches then raw else GCases (loc,sty,rtno',rl',branches') | GLetTuple (loc,nal,(na,po),b,c) -> let po' = Option.smartmap (subst_glob_constr subst) po and b' = subst_glob_constr subst b and c' = subst_glob_constr subst c in if po' == po && b' == b && c' == c then raw else GLetTuple (loc,nal,(na,po'),b',c') | GIf (loc,c,(na,po),b1,b2) -> let po' = Option.smartmap (subst_glob_constr subst) po and b1' = subst_glob_constr subst b1 and b2' = subst_glob_constr subst b2 and c' = subst_glob_constr subst c in if c' == c & po' == po && b1' == b1 && b2' == b2 then raw else GIf (loc,c',(na,po'),b1',b2') | GRec (loc,fix,ida,bl,ra1,ra2) -> let ra1' = array_smartmap (subst_glob_constr subst) ra1 and ra2' = array_smartmap (subst_glob_constr subst) ra2 in let bl' = array_smartmap (list_smartmap (fun (na,k,obd,ty as dcl) -> let ty' = subst_glob_constr subst ty in let obd' = Option.smartmap (subst_glob_constr subst) obd in if ty'==ty & obd'==obd then dcl else (na,k,obd',ty'))) bl in if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else GRec (loc,fix,ida,bl',ra1',ra2') | GSort _ -> raw | GHole (loc,ImplicitArg (ref,i,b)) -> let ref',_ = subst_global subst ref in if ref' == ref then raw else GHole (loc,InternalHole) | GHole (loc, (BinderType _ | QuestionMark _ | CasesType | InternalHole | TomatchTypeParameter _ | GoalEvar | ImpossibleCase | MatchingVar _)) -> raw | GCast (loc,r1,k) -> (match k with CastConv (k,r2) -> let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in if r1' == r1 && r2' == r2 then raw else GCast (loc,r1', CastConv (k,r2')) | CastCoerce -> let r1' = subst_glob_constr subst r1 in if r1' == r1 then raw else GCast (loc,r1',k)) (* Utilities to transform kernel cases to simple pattern-matching problem *) let simple_cases_matrix_of_branches ind brs = List.map (fun (i,n,b) -> let nal,c = it_destRLambda_or_LetIn_names n b in let mkPatVar na = PatVar (dummy_loc,na) in let p = PatCstr (dummy_loc,(ind,i+1),List.map mkPatVar nal,Anonymous) in let ids = map_succeed Nameops.out_name nal in (dummy_loc,ids,[p],c)) brs let return_type_of_predicate ind nparams nrealargs_ctxt pred = let nal,p = it_destRLambda_or_LetIn_names (nrealargs_ctxt+1) pred in (List.hd nal, Some (dummy_loc, ind, nparams, List.tl nal)), Some p coq-8.4pl4/pretyping/reductionops.mli0000644000175000017500000002142312326224777017077 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a stack -> 'a stack val append_stack_list : 'a list -> 'a stack -> 'a stack val decomp_stack : 'a stack -> ('a * 'a stack) option val list_of_stack : 'a stack -> 'a list val array_of_stack : 'a stack -> 'a array val stack_assign : 'a stack -> int -> 'a -> 'a stack val stack_args_size : 'a stack -> int val app_stack : constr * constr stack -> constr val stack_tail : int -> 'a stack -> 'a stack val stack_nth : 'a stack -> int -> 'a (************************************************************************) type state = constr * constr stack type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list type stack_reduction_function = contextual_stack_reduction_function type local_stack_reduction_function = evar_map -> constr -> constr * constr list type contextual_state_reduction_function = env -> evar_map -> state -> state type state_reduction_function = contextual_state_reduction_function type local_state_reduction_function = evar_map -> state -> state (** Removes cast and put into applicative form *) val whd_stack : local_stack_reduction_function (** For compatibility: alias for whd\_stack *) val whd_castapp_stack : local_stack_reduction_function (** {6 Reduction Function Operators } *) val strong : reduction_function -> reduction_function val local_strong : local_reduction_function -> local_reduction_function val strong_prodspine : local_reduction_function -> local_reduction_function (*i val stack_reduction_of_reduction : 'a reduction_function -> 'a state_reduction_function i*) val stacklam : (state -> 'a) -> constr list -> constr -> constr stack -> 'a (** {6 Generic Optimized Reduction Function using Closures } *) val clos_norm_flags : Closure.RedFlags.reds -> reduction_function (** Same as [(strong whd_beta[delta][iota])], but much faster on big terms *) val nf_beta : local_reduction_function val nf_betaiota : local_reduction_function val nf_betadeltaiota : reduction_function val nf_evar : evar_map -> constr -> constr val nf_betaiota_preserving_vm_cast : reduction_function (** Lazy strategy, weak head reduction *) val whd_evar : evar_map -> constr -> constr val whd_beta : local_reduction_function val whd_betaiota : local_reduction_function val whd_betaiotazeta : local_reduction_function val whd_betadeltaiota : contextual_reduction_function val whd_betadeltaiota_nolet : contextual_reduction_function val whd_betaetalet : local_reduction_function val whd_betalet : local_reduction_function val whd_beta_stack : local_stack_reduction_function val whd_betaiota_stack : local_stack_reduction_function val whd_betaiotazeta_stack : local_stack_reduction_function val whd_betadeltaiota_stack : contextual_stack_reduction_function val whd_betadeltaiota_nolet_stack : contextual_stack_reduction_function val whd_betaetalet_stack : local_stack_reduction_function val whd_betalet_stack : local_stack_reduction_function val whd_beta_state : local_state_reduction_function val whd_betaiota_state : local_state_reduction_function val whd_betaiotazeta_state : local_state_reduction_function val whd_betadeltaiota_state : contextual_state_reduction_function val whd_betadeltaiota_nolet_state : contextual_state_reduction_function val whd_betaetalet_state : local_state_reduction_function val whd_betalet_state : local_state_reduction_function (** {6 Head normal forms } *) val whd_delta_stack : stack_reduction_function val whd_delta_state : state_reduction_function val whd_delta : reduction_function val whd_betadelta_stack : stack_reduction_function val whd_betadelta_state : state_reduction_function val whd_betadelta : reduction_function val whd_betadeltaeta_stack : stack_reduction_function val whd_betadeltaeta_state : state_reduction_function val whd_betadeltaeta : reduction_function val whd_betadeltaiotaeta_stack : stack_reduction_function val whd_betadeltaiotaeta_state : state_reduction_function val whd_betadeltaiotaeta : reduction_function val whd_eta : constr -> constr val whd_zeta : constr -> constr (** Various reduction functions *) val safe_evar_value : evar_map -> existential -> constr option val beta_applist : constr * constr list -> constr val hnf_prod_app : env -> evar_map -> constr -> constr -> constr val hnf_prod_appvect : env -> evar_map -> constr -> constr array -> constr val hnf_prod_applist : env -> evar_map -> constr -> constr list -> constr val hnf_lam_app : env -> evar_map -> constr -> constr -> constr val hnf_lam_appvect : env -> evar_map -> constr -> constr array -> constr val hnf_lam_applist : env -> evar_map -> constr -> constr list -> constr val splay_prod : env -> evar_map -> constr -> (name * constr) list * constr val splay_lam : env -> evar_map -> constr -> (name * constr) list * constr val splay_arity : env -> evar_map -> constr -> (name * constr) list * sorts val sort_of_arity : env -> evar_map -> constr -> sorts val splay_prod_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_lam_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_prod_assum : env -> evar_map -> constr -> rel_context * constr val decomp_sort : env -> evar_map -> types -> sorts val is_sort : env -> evar_map -> types -> bool type 'a miota_args = { mP : constr; (** the result type *) mconstr : constr; (** the constructor *) mci : case_info; (** special info to re-build pattern *) mcargs : 'a list; (** the constructor's arguments *) mlf : 'a array } (** the branch code vector *) val reducible_mind_case : constr -> bool val reduce_mind_case : constr miota_args -> constr val find_conclusion : env -> evar_map -> constr -> (constr,constr) kind_of_term val is_arity : env -> evar_map -> constr -> bool val whd_programs : reduction_function (** [reduce_fix redfun fix stk] contracts [fix stk] if it is actually reducible; the structural argument is reduced by [redfun] *) type fix_reduction_result = NotReducible | Reduced of state val fix_recarg : fixpoint -> constr stack -> (int * constr) option val reduce_fix : local_state_reduction_function -> evar_map -> fixpoint -> constr stack -> fix_reduction_result (** {6 Querying the kernel conversion oracle: opaque/transparent constants } *) val is_transparent : 'a tableKey -> bool (** {6 Conversion Functions (uses closures, lazy strategy) } *) type conversion_test = constraints -> constraints val pb_is_equal : conv_pb -> bool val pb_equal : conv_pb -> conv_pb val sort_cmp : conv_pb -> sorts -> sorts -> conversion_test val is_conv : env -> evar_map -> constr -> constr -> bool val is_conv_leq : env -> evar_map -> constr -> constr -> bool val is_fconv : conv_pb -> env -> evar_map -> constr -> constr -> bool val is_trans_conv : transparent_state -> env -> evar_map -> constr -> constr -> bool val is_trans_conv_leq : transparent_state -> env -> evar_map -> constr -> constr -> bool val is_trans_fconv : conv_pb -> transparent_state -> env -> evar_map -> constr -> constr -> bool (** {6 Special-Purpose Reduction Functions } *) val whd_meta : evar_map -> constr -> constr val plain_instance : (metavariable * constr) list -> constr -> constr val instance :evar_map -> (metavariable * constr) list -> constr -> constr val head_unfold_under_prod : transparent_state -> reduction_function (** {6 Heuristic for Conversion with Evar } *) val whd_betaiota_deltazeta_for_iota_state : transparent_state -> state_reduction_function (** {6 Meta-related reduction functions } *) val meta_instance : evar_map -> constr freelisted -> constr val nf_meta : evar_map -> constr -> constr val meta_reducible_instance : evar_map -> constr freelisted -> constr coq-8.4pl4/pretyping/pretyping.mli0000644000175000017500000001064212326224777016403 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* env -> int list list -> rec_declaration -> int array type typing_constraint = OfType of types option | IsType type var_map = (identifier * Pattern.constr_under_binders) list type unbound_ltac_var_map = (identifier * identifier option) list type ltac_var_map = var_map * unbound_ltac_var_map type glob_constr_ltac_closure = ltac_var_map * glob_constr type pure_open_constr = evar_map * constr module type S = sig module Cases : Cases.S (** Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *) val allow_anonymous_refs : bool ref (** Generic call to the interpreter from glob_constr to open_constr, leaving unresolved holes as evars and returning the typing contexts of these evars. Work as [understand_gen] for the rest. *) val understand_tcc : ?resolve_classes:bool -> evar_map -> env -> ?expected_type:types -> glob_constr -> open_constr val understand_tcc_evars : ?fail_evar:bool -> ?resolve_classes:bool -> evar_map ref -> env -> typing_constraint -> glob_constr -> constr (** More general entry point with evars from ltac *) (** Generic call to the interpreter from glob_constr to constr, failing unresolved holes in the glob_constr cannot be instantiated. In [understand_ltac expand_evars sigma env ltac_env constraint c], resolve_classes : launch typeclass resolution after typechecking. expand_evars : expand inferred evars by their value if any sigma : initial set of existential variables (typically dependent subgoals) ltac_env : partial substitution of variables (used for the tactic language) constraint : tell if interpreted as a possibly constrained term or a type *) val understand_ltac : ?resolve_classes:bool -> bool -> evar_map -> env -> ltac_var_map -> typing_constraint -> glob_constr -> pure_open_constr (** Standard call to get a constr from a glob_constr, resolving implicit args *) val understand : evar_map -> env -> ?expected_type:Term.types -> glob_constr -> constr (** Idem but the glob_constr is intended to be a type *) val understand_type : evar_map -> env -> glob_constr -> constr (** A generalization of the two previous case *) val understand_gen : typing_constraint -> evar_map -> env -> glob_constr -> constr (** Idem but returns the judgment of the understood term *) val understand_judgment : evar_map -> env -> glob_constr -> unsafe_judgment (** Idem but do not fail on unresolved evars *) val understand_judgment_tcc : evar_map ref -> env -> glob_constr -> unsafe_judgment (**/**) (** Internal of Pretyping... *) val pretype : bool -> type_constraint -> env -> evar_map ref -> ltac_var_map -> glob_constr -> unsafe_judgment val pretype_type : bool -> val_constraint -> env -> evar_map ref -> ltac_var_map -> glob_constr -> unsafe_type_judgment val pretype_gen : bool -> bool -> bool -> evar_map ref -> env -> ltac_var_map -> typing_constraint -> glob_constr -> constr (**/**) end module Pretyping_F (C : Coercion.S) : S module Default : S (** To embed constr in glob_constr *) val constr_in : constr -> Dyn.t val constr_out : Dyn.t -> constr val interp_sort : glob_sort -> sorts val interp_elimination_sort : glob_sort -> sorts_family (** Last chance for solving evars, possibly using external solver *) val solve_remaining_evars : bool -> bool -> (env -> evar_map -> existential -> constr) -> env -> evar_map -> pure_open_constr -> pure_open_constr coq-8.4pl4/pretyping/termops.ml0000644000175000017500000011324012326224777015700 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (str "Set") | Prop Null -> (str "Prop") | Type u -> (str "Type(" ++ Univ.pr_uni u ++ str ")") let pr_sort_family = function | InSet -> (str "Set") | InProp -> (str "Prop") | InType -> (str "Type") let pr_name = function | Name id -> pr_id id | Anonymous -> str "_" let pr_con sp = str(string_of_con sp) let rec pr_constr c = match kind_of_term c with | Rel n -> str "#"++int n | Meta n -> str "Meta(" ++ int n ++ str ")" | Var id -> pr_id id | Sort s -> print_sort s | Cast (c,_, t) -> hov 1 (str"(" ++ pr_constr c ++ cut() ++ str":" ++ pr_constr t ++ str")") | Prod (Name(id),t,c) -> hov 1 (str"forall " ++ pr_id id ++ str":" ++ pr_constr t ++ str"," ++ spc() ++ pr_constr c) | Prod (Anonymous,t,c) -> hov 0 (str"(" ++ pr_constr t ++ str " ->" ++ spc() ++ pr_constr c ++ str")") | Lambda (na,t,c) -> hov 1 (str"fun " ++ pr_name na ++ str":" ++ pr_constr t ++ str" =>" ++ spc() ++ pr_constr c) | LetIn (na,b,t,c) -> hov 0 (str"let " ++ pr_name na ++ str":=" ++ pr_constr b ++ str":" ++ brk(1,2) ++ pr_constr t ++ cut() ++ pr_constr c) | App (c,l) -> hov 1 (str"(" ++ pr_constr c ++ spc() ++ prlist_with_sep spc pr_constr (Array.to_list l) ++ str")") | Evar (e,l) -> hov 1 (str"Evar#" ++ int e ++ str"{" ++ prlist_with_sep spc pr_constr (Array.to_list l) ++str"}") | Const c -> str"Cst(" ++ pr_con c ++ str")" | Ind (sp,i) -> str"Ind(" ++ pr_mind sp ++ str"," ++ int i ++ str")" | Construct ((sp,i),j) -> str"Constr(" ++ pr_mind sp ++ str"," ++ int i ++ str"," ++ int j ++ str")" | Case (ci,p,c,bl) -> v 0 (hv 0 (str"<"++pr_constr p++str">"++ cut() ++ str"Case " ++ pr_constr c ++ str"of") ++ cut() ++ prlist_with_sep (fun _ -> brk(1,2)) pr_constr (Array.to_list bl) ++ cut() ++ str"end") | Fix ((t,i),(lna,tl,bl)) -> let fixl = Array.mapi (fun i na -> (na,t.(i),tl.(i),bl.(i))) lna in hov 1 (str"fix " ++ int i ++ spc() ++ str"{" ++ v 0 (prlist_with_sep spc (fun (na,i,ty,bd) -> pr_name na ++ str"/" ++ int i ++ str":" ++ pr_constr ty ++ cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++ str"}") | CoFix(i,(lna,tl,bl)) -> let fixl = Array.mapi (fun i na -> (na,tl.(i),bl.(i))) lna in hov 1 (str"cofix " ++ int i ++ spc() ++ str"{" ++ v 0 (prlist_with_sep spc (fun (na,ty,bd) -> pr_name na ++ str":" ++ pr_constr ty ++ cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++ str"}") let term_printer = ref (fun _ -> pr_constr) let print_constr_env t = !term_printer t let print_constr t = !term_printer (Global.env()) t let set_print_constr f = term_printer := f let pr_var_decl env (id,c,typ) = let pbody = match c with | None -> (mt ()) | Some c -> (* Force evaluation *) let pb = print_constr_env env c in (str" := " ++ pb ++ cut () ) in let pt = print_constr_env env typ in let ptyp = (str" : " ++ pt) in (pr_id id ++ hov 0 (pbody ++ ptyp)) let pr_rel_decl env (na,c,typ) = let pbody = match c with | None -> mt () | Some c -> (* Force evaluation *) let pb = print_constr_env env c in (str":=" ++ spc () ++ pb ++ spc ()) in let ptyp = print_constr_env env typ in match na with | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) | Name id -> hov 0 (pr_id id ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) let print_named_context env = hv 0 (fold_named_context (fun env d pps -> pps ++ ws 2 ++ pr_var_decl env d) env ~init:(mt ())) let print_rel_context env = hv 0 (fold_rel_context (fun env d pps -> pps ++ ws 2 ++ pr_rel_decl env d) env ~init:(mt ())) let print_env env = let sign_env = fold_named_context (fun env d pps -> let pidt = pr_var_decl env d in (pps ++ fnl () ++ pidt)) env ~init:(mt ()) in let db_env = fold_rel_context (fun env d pps -> let pnat = pr_rel_decl env d in (pps ++ fnl () ++ pnat)) env ~init:(mt ()) in (sign_env ++ db_env) (*let current_module = ref empty_dirpath let set_module m = current_module := m*) let new_univ_level = let univ_gen = ref 0 in (fun sp -> incr univ_gen; Univ.make_universe_level (Lib.library_dp(),!univ_gen)) let new_univ () = Univ.make_universe (new_univ_level ()) let new_Type () = mkType (new_univ ()) let new_Type_sort () = Type (new_univ ()) (* This refreshes universes in types; works only for inferred types (i.e. for types of the form (x1:A1)...(xn:An)B with B a sort or an atom in head normal form) *) let refresh_universes_gen strict t = let modified = ref false in let rec refresh t = match kind_of_term t with | Sort (Type u) when strict or u <> Univ.type0m_univ -> modified := true; new_Type () | Prod (na,u,v) -> mkProd (na,u,refresh v) | _ -> t in let t' = refresh t in if !modified then t' else t let refresh_universes = refresh_universes_gen false let refresh_universes_strict = refresh_universes_gen true let new_sort_in_family = function | InProp -> prop_sort | InSet -> set_sort | InType -> Type (new_univ ()) (* [Rel (n+m);...;Rel(n+1)] *) let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) let rel_list n m = let rec reln l p = if p>m then l else reln (mkRel(n+p)::l) (p+1) in reln [] 1 (* Same as [rel_list] but takes a context as argument and skips let-ins *) let extended_rel_list n hyps = let rec reln l p = function | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps | (_,Some _,_) :: hyps -> reln l (p+1) hyps | [] -> l in reln [] 1 hyps let extended_rel_vect n hyps = Array.of_list (extended_rel_list n hyps) let push_rel_assum (x,t) env = push_rel (x,None,t) env let push_rels_assum assums = push_rel_context (List.map (fun (x,t) -> (x,None,t)) assums) let push_named_rec_types (lna,typarray,_) env = let ctxt = array_map2_i (fun i na t -> match na with | Name id -> (id, None, lift i t) | Anonymous -> anomaly "Fix declarations must be named") lna typarray in Array.fold_left (fun e assum -> push_named assum e) env ctxt let rec lookup_rel_id id sign = let rec lookrec = function | (n, (Anonymous,_,_)::l) -> lookrec (n+1,l) | (n, (Name id',b,t)::l) -> if id' = id then (n,b,t) else lookrec (n+1,l) | (_, []) -> raise Not_found in lookrec (1,sign) (* Constructs either [forall x:t, c] or [let x:=b:t in c] *) let mkProd_or_LetIn (na,body,t) c = match body with | None -> mkProd (na, t, c) | Some b -> mkLetIn (na, b, t, c) (* Constructs either [forall x:t, c] or [c] in which [x] is replaced by [b] *) let mkProd_wo_LetIn (na,body,t) c = match body with | None -> mkProd (na, t, c) | Some b -> subst1 b c let it_mkProd init = List.fold_left (fun c (n,t) -> mkProd (n, t, c)) init let it_mkLambda init = List.fold_left (fun c (n,t) -> mkLambda (n, t, c)) init let it_named_context_quantifier f ~init = List.fold_left (fun c d -> f d c) init let it_mkProd_or_LetIn init = it_named_context_quantifier mkProd_or_LetIn ~init let it_mkProd_wo_LetIn init = it_named_context_quantifier mkProd_wo_LetIn ~init let it_mkLambda_or_LetIn init = it_named_context_quantifier mkLambda_or_LetIn ~init let it_mkNamedProd_or_LetIn init = it_named_context_quantifier mkNamedProd_or_LetIn ~init let it_mkNamedProd_wo_LetIn init = it_named_context_quantifier mkNamedProd_wo_LetIn ~init let it_mkNamedLambda_or_LetIn init = it_named_context_quantifier mkNamedLambda_or_LetIn ~init (* *) (* strips head casts and flattens head applications *) let rec strip_head_cast c = match kind_of_term c with | App (f,cl) -> let rec collapse_rec f cl2 = match kind_of_term f with | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) | Cast (c,_,_) -> collapse_rec c cl2 | _ -> if Array.length cl2 = 0 then f else mkApp (f,cl2) in collapse_rec f cl | Cast (c,_,_) -> strip_head_cast c | _ -> c let rec drop_extra_implicit_args c = match kind_of_term c with (* Removed trailing extra implicit arguments, what improves compatibility for constants with recently added maximal implicit arguments *) | App (f,args) when isEvar (array_last args) -> drop_extra_implicit_args (mkApp (f,fst (array_chop (Array.length args - 1) args))) | _ -> c (* Get the last arg of an application *) let last_arg c = match kind_of_term c with | App (f,cl) -> array_last cl | _ -> anomaly "last_arg" (* Get the last arg of an application *) let decompose_app_vect c = match kind_of_term c with | App (f,cl) -> (f, cl) | _ -> (c,[||]) let adjust_app_list_size f1 l1 f2 l2 = let len1 = List.length l1 and len2 = List.length l2 in if len1 = len2 then (f1,l1,f2,l2) else if len1 < len2 then let extras,restl2 = list_chop (len2-len1) l2 in (f1, l1, applist (f2,extras), restl2) else let extras,restl1 = list_chop (len1-len2) l1 in (applist (f1,extras), restl1, f2, l2) let adjust_app_array_size f1 l1 f2 l2 = let len1 = Array.length l1 and len2 = Array.length l2 in if len1 = len2 then (f1,l1,f2,l2) else if len1 < len2 then let extras,restl2 = array_chop (len2-len1) l2 in (f1, l1, appvect (f2,extras), restl2) else let extras,restl1 = array_chop (len1-len2) l1 in (appvect (f1,extras), restl1, f2, l2) (* [map_constr_with_named_binders g f l c] maps [f l] on the immediate subterms of [c]; it carries an extra data [l] (typically a name list) which is processed by [g na] (which typically cons [na] to [l]) at each binder traversal (with name [na]); it is not recursive and the order with which subterms are processed is not specified *) let map_constr_with_named_binders g f l c = match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> c | Cast (c,k,t) -> mkCast (f l c, k, f l t) | Prod (na,t,c) -> mkProd (na, f l t, f (g na l) c) | Lambda (na,t,c) -> mkLambda (na, f l t, f (g na l) c) | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g na l) c) | App (c,al) -> mkApp (f l c, Array.map (f l) al) | Evar (e,al) -> mkEvar (e, Array.map (f l) al) | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl) | Fix (ln,(lna,tl,bl)) -> let l' = Array.fold_left (fun l na -> g na l) l lna in mkFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) | CoFix(ln,(lna,tl,bl)) -> let l' = Array.fold_left (fun l na -> g na l) l lna in mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) (* [map_constr_with_binders_left_to_right g f n c] maps [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; the subterms are processed from left to right according to the usual representation of the constructions (this may matter if [f] does a side-effect); it is not recursive; in fact, the usual representation of the constructions is at the time being almost those of the ML representation (except for (co-)fixpoint) *) let fold_rec_types g (lna,typarray,_) e = let ctxt = array_map2_i (fun i na t -> (na, None, lift i t)) lna typarray in Array.fold_left (fun e assum -> g assum e) e ctxt let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> c | Cast (c,k,t) -> let c' = f l c in mkCast (c',k,f l t) | Prod (na,t,c) -> let t' = f l t in mkProd (na, t', f (g (na,None,t) l) c) | Lambda (na,t,c) -> let t' = f l t in mkLambda (na, t', f (g (na,None,t) l) c) | LetIn (na,b,t,c) -> let b' = f l b in let t' = f l t in let c' = f (g (na,Some b,t) l) c in mkLetIn (na, b', t', c') | App (c,[||]) -> assert false | App (c,al) -> (*Special treatment to be able to recognize partially applied subterms*) let a = al.(Array.length al - 1) in let hd = f l (mkApp (c, Array.sub al 0 (Array.length al - 1))) in mkApp (hd, [| f l a |]) | Evar (e,al) -> mkEvar (e, array_map_left (f l) al) | Case (ci,p,c,bl) -> (* In v8 concrete syntax, predicate is after the term to match! *) let c' = f l c in let p' = f l p in mkCase (ci, p', c', array_map_left (f l) bl) | Fix (ln,(lna,tl,bl as fx)) -> let l' = fold_rec_types g fx l in let (tl',bl') = array_map_left_pair (f l) tl (f l') bl in mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl as fx)) -> let l' = fold_rec_types g fx l in let (tl',bl') = array_map_left_pair (f l) tl (f l') bl in mkCoFix (ln,(lna,tl',bl')) (* strong *) let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> cstr | Cast (c,k, t) -> let c' = f l c in let t' = f l t in if c==c' && t==t' then cstr else mkCast (c', k, t') | Prod (na,t,c) -> let t' = f l t in let c' = f (g (na,None,t) l) c in if t==t' && c==c' then cstr else mkProd (na, t', c') | Lambda (na,t,c) -> let t' = f l t in let c' = f (g (na,None,t) l) c in if t==t' && c==c' then cstr else mkLambda (na, t', c') | LetIn (na,b,t,c) -> let b' = f l b in let t' = f l t in let c' = f (g (na,Some b,t) l) c in if b==b' && t==t' && c==c' then cstr else mkLetIn (na, b', t', c') | App (c,al) -> let c' = f l c in let al' = Array.map (f l) al in if c==c' && array_for_all2 (==) al al' then cstr else mkApp (c', al') | Evar (e,al) -> let al' = Array.map (f l) al in if array_for_all2 (==) al al' then cstr else mkEvar (e, al') | Case (ci,p,c,bl) -> let p' = f l p in let c' = f l c in let bl' = Array.map (f l) bl in if p==p' && c==c' && array_for_all2 (==) bl bl' then cstr else mkCase (ci, p', c', bl') | Fix (ln,(lna,tl,bl)) -> let tl' = Array.map (f l) tl in let l' = array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in let bl' = Array.map (f l') bl in if array_for_all2 (==) tl tl' && array_for_all2 (==) bl bl' then cstr else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> let tl' = Array.map (f l) tl in let l' = array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in let bl' = Array.map (f l') bl in if array_for_all2 (==) tl tl' && array_for_all2 (==) bl bl' then cstr else mkCoFix (ln,(lna,tl',bl')) (* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate subterms of [c] starting from [acc] and proceeding from left to right according to the usual representation of the constructions as [fold_constr] but it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive *) let fold_constr_with_binders g f n acc c = match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> acc | Cast (c,_, t) -> f n (f n acc c) t | Prod (_,t,c) -> f (g n) (f n acc t) c | Lambda (_,t,c) -> f (g n) (f n acc t) c | LetIn (_,b,t,c) -> f (g n) (f n (f n acc b) t) c | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Evar (_,l) -> Array.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl | Fix (_,(lna,tl,bl)) -> let n' = iterate g (Array.length tl) n in let fd = array_map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd | CoFix (_,(lna,tl,bl)) -> let n' = iterate g (Array.length tl) n in let fd = array_map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd (* [iter_constr_with_full_binders g f acc c] iters [f acc] on the immediate subterms of [c]; it carries an extra data [acc] which is processed by [g] at each binder traversal; it is not recursive and the order with which subterms are processed is not specified *) let iter_constr_with_full_binders g f l c = match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () | Cast (c,_, t) -> f l c; f l t | Prod (na,t,c) -> f l t; f (g (na,None,t) l) c | Lambda (na,t,c) -> f l t; f (g (na,None,t) l) c | LetIn (na,b,t,c) -> f l b; f l t; f (g (na,Some b,t) l) c | App (c,args) -> f l c; Array.iter (f l) args | Evar (_,args) -> Array.iter (f l) args | Case (_,p,c,bl) -> f l p; f l c; Array.iter (f l) bl | Fix (_,(lna,tl,bl)) -> let l' = array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in Array.iter (f l) tl; Array.iter (f l') bl | CoFix (_,(lna,tl,bl)) -> let l' = array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in Array.iter (f l) tl; Array.iter (f l') bl (***************************) (* occurs check functions *) (***************************) exception Occur let occur_meta c = let rec occrec c = match kind_of_term c with | Meta _ -> raise Occur | _ -> iter_constr occrec c in try occrec c; false with Occur -> true let occur_existential c = let rec occrec c = match kind_of_term c with | Evar _ -> raise Occur | _ -> iter_constr occrec c in try occrec c; false with Occur -> true let occur_meta_or_existential c = let rec occrec c = match kind_of_term c with | Evar _ -> raise Occur | Meta _ -> raise Occur | _ -> iter_constr occrec c in try occrec c; false with Occur -> true let occur_const s c = let rec occur_rec c = match kind_of_term c with | Const sp when sp=s -> raise Occur | _ -> iter_constr occur_rec c in try occur_rec c; false with Occur -> true let occur_evar n c = let rec occur_rec c = match kind_of_term c with | Evar (sp,_) when sp=n -> raise Occur | _ -> iter_constr occur_rec c in try occur_rec c; false with Occur -> true let occur_in_global env id constr = let vars = vars_of_global env constr in if List.mem id vars then raise Occur let occur_var env id c = let rec occur_rec c = match kind_of_term c with | Var _ | Const _ | Ind _ | Construct _ -> occur_in_global env id c | _ -> iter_constr occur_rec c in try occur_rec c; false with Occur -> true let occur_var_in_decl env hyp (_,c,typ) = match c with | None -> occur_var env hyp typ | Some body -> occur_var env hyp typ || occur_var env hyp body (* returns the list of free debruijn indices in a term *) let free_rels m = let rec frec depth acc c = match kind_of_term c with | Rel n -> if n >= depth then Intset.add (n-depth+1) acc else acc | _ -> fold_constr_with_binders succ frec depth acc c in frec 1 Intset.empty m (* collects all metavar occurences, in left-to-right order, preserving * repetitions and all. *) let collect_metas c = let rec collrec acc c = match kind_of_term c with | Meta mv -> list_add_set mv acc | _ -> fold_constr collrec acc c in List.rev (collrec [] c) (* collects all vars; warning: this is only visible vars, not dependencies in all section variables; for the latter, use global_vars_set *) let collect_vars c = let rec aux vars c = match kind_of_term c with | Var id -> Idset.add id vars | _ -> fold_constr aux vars c in aux Idset.empty c (* Tests whether [m] is a subterm of [t]: [m] is appropriately lifted through abstractions of [t] *) let dependent_main noevar m t = let rec deprec m t = if eq_constr m t then raise Occur else match kind_of_term m, kind_of_term t with | App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt -> deprec m (mkApp (ft,Array.sub lt 0 (Array.length lm))); Array.iter (deprec m) (Array.sub lt (Array.length lm) ((Array.length lt) - (Array.length lm))) | _, Cast (c,_,_) when noevar & isMeta c -> () | _, Evar _ when noevar -> () | _ -> iter_constr_with_binders (lift 1) deprec m t in try deprec m t; false with Occur -> true let dependent = dependent_main false let dependent_no_evar = dependent_main true let count_occurrences m t = let n = ref 0 in let rec countrec m t = if eq_constr m t then incr n else match kind_of_term m, kind_of_term t with | App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt -> countrec m (mkApp (ft,Array.sub lt 0 (Array.length lm))); Array.iter (countrec m) (Array.sub lt (Array.length lm) ((Array.length lt) - (Array.length lm))) | _, Cast (c,_,_) when isMeta c -> () | _, Evar _ -> () | _ -> iter_constr_with_binders (lift 1) countrec m t in countrec m t; !n (* Synonymous *) let occur_term = dependent let pop t = lift (-1) t (***************************) (* bindings functions *) (***************************) type meta_type_map = (metavariable * types) list type meta_value_map = (metavariable * constr) list let rec subst_meta bl c = match kind_of_term c with | Meta i -> (try List.assoc i bl with Not_found -> c) | _ -> map_constr (subst_meta bl) c (* First utilities for avoiding telescope computation for subst_term *) let prefix_application eq_fun (k,c) (t : constr) = let c' = collapse_appl c and t' = collapse_appl t in match kind_of_term c', kind_of_term t' with | App (f1,cl1), App (f2,cl2) -> let l1 = Array.length cl1 and l2 = Array.length cl2 in if l1 <= l2 && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then Some (mkApp (mkRel k, Array.sub cl2 l1 (l2 - l1))) else None | _ -> None let my_prefix_application eq_fun (k,c) (by_c : constr) (t : constr) = let c' = collapse_appl c and t' = collapse_appl t in match kind_of_term c', kind_of_term t' with | App (f1,cl1), App (f2,cl2) -> let l1 = Array.length cl1 and l2 = Array.length cl2 in if l1 <= l2 && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then Some (mkApp ((lift k by_c), Array.sub cl2 l1 (l2 - l1))) else None | _ -> None (* Recognizing occurrences of a given subterm in a term: [subst_term c t] substitutes [(Rel 1)] for all occurrences of term [c] in a term [t]; works if [c] has rels *) let subst_term_gen eq_fun c t = let rec substrec (k,c as kc) t = match prefix_application eq_fun kc t with | Some x -> x | None -> if eq_fun c t then mkRel k else map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c)) substrec kc t in substrec (1,c) t let subst_term = subst_term_gen eq_constr (* Recognizing occurrences of a given subterm in a term : [replace_term c1 c2 t] substitutes [c2] for all occurrences of term [c1] in a term [t]; works if [c1] and [c2] have rels *) let replace_term_gen eq_fun c by_c in_t = let rec substrec (k,c as kc) t = match my_prefix_application eq_fun kc by_c t with | Some x -> x | None -> (if eq_fun c t then (lift k by_c) else map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c)) substrec kc t) in substrec (0,c) in_t let replace_term = replace_term_gen eq_constr (* Substitute only at a list of locations or excluding a list of locations; in the occurrences list (b,l), b=true means no occurrence except the ones in l and b=false, means all occurrences except the ones in l *) type hyp_location_flag = (* To distinguish body and type of local defs *) | InHyp | InHypTypeOnly | InHypValueOnly type occurrences = bool * int list let all_occurrences = (false,[]) let no_occurrences_in_set = (true,[]) let error_invalid_occurrence l = let l = list_uniquize (List.sort Pervasives.compare l) in errorlabstrm "" (str ("Invalid occurrence " ^ plural (List.length l) "number" ^": ") ++ prlist_with_sep spc int l ++ str ".") let pr_position (cl,pos) = let clpos = match cl with | None -> str " of the goal" | Some (id,InHyp) -> str " of hypothesis " ++ pr_id id | Some (id,InHypTypeOnly) -> str " of the type of hypothesis " ++ pr_id id | Some (id,InHypValueOnly) -> str " of the body of hypothesis " ++ pr_id id in int pos ++ clpos let error_cannot_unify_occurrences nested (cl2,pos2,t2) (cl1,pos1,t1) (nowhere_except_in,locs) = let s = if nested then "Found nested occurrences of the pattern" else "Found incompatible occurrences of the pattern" in errorlabstrm "" (str s ++ str ":" ++ spc () ++ str "Matched term " ++ quote (print_constr t2) ++ strbrk " at position " ++ pr_position (cl2,pos2) ++ strbrk " is not compatible with matched term " ++ quote (print_constr t1) ++ strbrk " at position " ++ pr_position (cl1,pos1) ++ str ".") let is_selected pos (nowhere_except_in,locs) = nowhere_except_in && List.mem pos locs || not nowhere_except_in && not (List.mem pos locs) exception NotUnifiable type 'a testing_function = { match_fun : constr -> 'a; merge_fun : 'a -> 'a -> 'a; mutable testing_state : 'a; mutable last_found : ((identifier * hyp_location_flag) option * int * constr) option } let subst_closed_term_occ_gen_modulo (nowhere_except_in,locs as plocs) test cl occ t = let maxocc = List.fold_right max locs 0 in let pos = ref occ in let nested = ref false in let add_subst t subst = try test.testing_state <- test.merge_fun subst test.testing_state; test.last_found <- Some (cl,!pos,t) with NotUnifiable -> let lastpos = Option.get test.last_found in error_cannot_unify_occurrences !nested (cl,!pos,t) lastpos plocs in let rec substrec k t = if nowhere_except_in & !pos > maxocc then t else try let subst = test.match_fun t in if is_selected !pos plocs then (add_subst t subst; incr pos; (* Check nested matching subterms *) nested := true; ignore (subst_below k t); nested := false; (* Do the effective substitution *) mkRel k) else (incr pos; subst_below k t) with NotUnifiable -> subst_below k t and subst_below k t = map_constr_with_binders_left_to_right (fun d k -> k+1) substrec k t in let t' = substrec 1 t in (!pos, t') let is_nowhere (nowhere_except_in,locs) = nowhere_except_in && locs = [] let check_used_occurrences nbocc (nowhere_except_in,locs) = let rest = List.filter (fun o -> o >= nbocc) locs in if rest <> [] then error_invalid_occurrence rest let proceed_with_occurrences f plocs x = if is_nowhere plocs then (* optimization *) x else begin assert (List.for_all (fun x -> x >= 0) (snd plocs)); let (nbocc,x) = f 1 x in check_used_occurrences nbocc plocs; x end let make_eq_test c = { match_fun = (fun c' -> if eq_constr c c' then () else raise NotUnifiable); merge_fun = (fun () () -> ()); testing_state = (); last_found = None } let subst_closed_term_occ_gen plocs pos c t = subst_closed_term_occ_gen_modulo plocs (make_eq_test c) None pos t let subst_closed_term_occ plocs c t = proceed_with_occurrences (fun occ -> subst_closed_term_occ_gen plocs occ c) plocs t let subst_closed_term_occ_modulo plocs test cl t = proceed_with_occurrences (subst_closed_term_occ_gen_modulo plocs test cl) plocs t let map_named_declaration_with_hyploc f hyploc acc (id,bodyopt,typ) = let f = f (Some (id,hyploc)) in match bodyopt,hyploc with | None, InHypValueOnly -> errorlabstrm "" (pr_id id ++ str " has no value.") | None, _ | Some _, InHypTypeOnly -> let acc,typ = f acc typ in acc,(id,bodyopt,typ) | Some body, InHypValueOnly -> let acc,body = f acc body in acc,(id,Some body,typ) | Some body, InHyp -> let acc,body = f acc body in let acc,typ = f acc typ in acc,(id,Some body,typ) let subst_closed_term_occ_decl (plocs,hyploc) c d = proceed_with_occurrences (map_named_declaration_with_hyploc (fun _ occ -> subst_closed_term_occ_gen plocs occ c) hyploc) plocs d let subst_closed_term_occ_decl_modulo (plocs,hyploc) test d = proceed_with_occurrences (map_named_declaration_with_hyploc (subst_closed_term_occ_gen_modulo plocs test) hyploc) plocs d let vars_of_env env = let s = Sign.fold_named_context (fun (id,_,_) s -> Idset.add id s) (named_context env) ~init:Idset.empty in Sign.fold_rel_context (fun (na,_,_) s -> match na with Name id -> Idset.add id s | _ -> s) (rel_context env) ~init:s let add_vname vars = function Name id -> Idset.add id vars | _ -> vars (*************************) (* Names environments *) (*************************) type names_context = name list let add_name n nl = n::nl let lookup_name_of_rel p names = try List.nth names (p-1) with Invalid_argument _ | Failure _ -> raise Not_found let rec lookup_rel_of_name id names = let rec lookrec n = function | Anonymous :: l -> lookrec (n+1) l | (Name id') :: l -> if id' = id then n else lookrec (n+1) l | [] -> raise Not_found in lookrec 1 names let empty_names_context = [] let ids_of_rel_context sign = Sign.fold_rel_context (fun (na,_,_) l -> match na with Name id -> id::l | Anonymous -> l) sign ~init:[] let ids_of_named_context sign = Sign.fold_named_context (fun (id,_,_) idl -> id::idl) sign ~init:[] let ids_of_context env = (ids_of_rel_context (rel_context env)) @ (ids_of_named_context (named_context env)) let names_of_rel_context env = List.map (fun (na,_,_) -> na) (rel_context env) let is_section_variable id = try let _ = Global.lookup_named id in true with Not_found -> false let isGlobalRef c = match kind_of_term c with | Const _ | Ind _ | Construct _ | Var _ -> true | _ -> false let has_polymorphic_type c = match (Global.lookup_constant c).Declarations.const_type with | Declarations.PolymorphicArity _ -> true | _ -> false let base_sort_cmp pb s0 s1 = match (s0,s1) with | (Prop c1, Prop c2) -> c1 = Null or c2 = Pos (* Prop <= Set *) | (Prop c1, Type u) -> pb = Reduction.CUMUL | (Type u1, Type u2) -> true | _ -> false (* eq_constr extended with universe erasure *) let compare_constr_univ f cv_pb t1 t2 = match kind_of_term t1, kind_of_term t2 with Sort s1, Sort s2 -> base_sort_cmp cv_pb s1 s2 | Prod (_,t1,c1), Prod (_,t2,c2) -> f Reduction.CONV t1 t2 & f cv_pb c1 c2 | _ -> compare_constr (f Reduction.CONV) t1 t2 let rec constr_cmp cv_pb t1 t2 = compare_constr_univ constr_cmp cv_pb t1 t2 let eq_constr = constr_cmp Reduction.CONV (* App(c,[t1,...tn]) -> ([c,t1,...,tn-1],tn) App(c,[||]) -> ([],c) *) let split_app c = match kind_of_term c with App(c,l) -> let len = Array.length l in if len=0 then ([],c) else let last = Array.get l (len-1) in let prev = Array.sub l 0 (len-1) in c::(Array.to_list prev), last | _ -> assert false let hdtl l = List.hd l, List.tl l type subst = (rel_context*constr) Intmap.t exception CannotFilter let filtering env cv_pb c1 c2 = let evm = ref Intmap.empty in let define cv_pb e1 ev c1 = try let (e2,c2) = Intmap.find ev !evm in let shift = List.length e1 - List.length e2 in if constr_cmp cv_pb c1 (lift shift c2) then () else raise CannotFilter with Not_found -> evm := Intmap.add ev (e1,c1) !evm in let rec aux env cv_pb c1 c2 = match kind_of_term c1, kind_of_term c2 with | App _, App _ -> let ((p1,l1),(p2,l2)) = (split_app c1),(split_app c2) in aux env cv_pb l1 l2; if p1=[] & p2=[] then () else aux env cv_pb (applist (hdtl p1)) (applist (hdtl p2)) | Prod (n,t1,c1), Prod (_,t2,c2) -> aux env cv_pb t1 t2; aux ((n,None,t1)::env) cv_pb c1 c2 | _, Evar (ev,_) -> define cv_pb env ev c1 | Evar (ev,_), _ -> define cv_pb env ev c2 | _ -> if compare_constr_univ (fun pb c1 c2 -> aux env pb c1 c2; true) cv_pb c1 c2 then () else raise CannotFilter (* TODO: le reste des binders *) in aux env cv_pb c1 c2; !evm let decompose_prod_letin : constr -> int * rel_context * constr = let rec prodec_rec i l c = match kind_of_term c with | Prod (n,t,c) -> prodec_rec (succ i) ((n,None,t)::l) c | LetIn (n,d,t,c) -> prodec_rec (succ i) ((n,Some d,t)::l) c | Cast (c,_,_) -> prodec_rec i l c | _ -> i,l,c in prodec_rec 0 [] let align_prod_letin c a : rel_context * constr = let (lc,_,_) = decompose_prod_letin c in let (la,l,a) = decompose_prod_letin a in if not (la >= lc) then invalid_arg "align_prod_letin"; let (l1,l2) = Util.list_chop lc l in l2,it_mkProd_or_LetIn a l1 (* On reduit une serie d'eta-redex de tete ou rien du tout *) (* [x1:c1;...;xn:cn]@(f;a1...an;x1;...;xn) --> @(f;a1...an) *) (* Remplace 2 versions précédentes buggées *) let rec eta_reduce_head c = match kind_of_term c with | Lambda (_,c1,c') -> (match kind_of_term (eta_reduce_head c') with | App (f,cl) -> let lastn = (Array.length cl) - 1 in if lastn < 1 then anomaly "application without arguments" else (match kind_of_term cl.(lastn) with | Rel 1 -> let c' = if lastn = 1 then f else mkApp (f, Array.sub cl 0 lastn) in if noccurn 1 c' then lift (-1) c' else c | _ -> c) | _ -> c) | _ -> c (* alpha-eta conversion : ignore print names and casts *) let eta_eq_constr = let rec aux t1 t2 = let t1 = eta_reduce_head (strip_head_cast t1) and t2 = eta_reduce_head (strip_head_cast t2) in t1=t2 or compare_constr aux t1 t2 in aux (* iterator on rel context *) let process_rel_context f env = let sign = named_context_val env in let rels = rel_context env in let env0 = reset_with_named_context sign env in Sign.fold_rel_context f rels ~init:env0 let assums_of_rel_context sign = Sign.fold_rel_context (fun (na,c,t) l -> match c with Some _ -> l | None -> (na, t)::l) sign ~init:[] let map_rel_context_in_env f env sign = let rec aux env acc = function | d::sign -> aux (push_rel d env) (map_rel_declaration (f env) d :: acc) sign | [] -> acc in aux env [] (List.rev sign) let map_rel_context_with_binders f sign = let rec aux k = function | d::sign -> map_rel_declaration (f k) d :: aux (k-1) sign | [] -> [] in aux (rel_context_length sign) sign let substl_rel_context l = map_rel_context_with_binders (fun k -> substnl l (k-1)) let lift_rel_context n = map_rel_context_with_binders (liftn n) let smash_rel_context sign = let rec aux acc = function | [] -> acc | (_,None,_ as d) :: l -> aux (d::acc) l | (_,Some b,_) :: l -> (* Quadratic in the number of let but there are probably a few of them *) aux (List.rev (substl_rel_context [b] (List.rev acc))) l in List.rev (aux [] sign) let adjust_subst_to_rel_context sign l = let rec aux subst sign l = match sign, l with | (_,None,_)::sign', a::args' -> aux (a::subst) sign' args' | (_,Some c,_)::sign', args' -> aux (substl (List.rev subst) c :: subst) sign' args' | [], [] -> List.rev subst | _ -> anomaly "Instance and signature do not match" in aux [] (List.rev sign) l let fold_named_context_both_sides f l ~init = list_fold_right_and_left f l init let rec mem_named_context id = function | (id',_,_) :: _ when id=id' -> true | _ :: sign -> mem_named_context id sign | [] -> false let clear_named_body id env = let rec aux _ = function | (id',Some c,t) when id = id' -> push_named (id,None,t) | d -> push_named d in fold_named_context aux env ~init:(reset_context env) let global_vars env ids = Idset.elements (global_vars_set env ids) let global_vars_set_of_decl env = function | (_,None,t) -> global_vars_set env t | (_,Some c,t) -> Idset.union (global_vars_set env t) (global_vars_set env c) let dependency_closure env sign hyps = if Idset.is_empty hyps then [] else let (_,lh) = Sign.fold_named_context_reverse (fun (hs,hl) (x,_,_ as d) -> if Idset.mem x hs then (Idset.union (global_vars_set_of_decl env d) (Idset.remove x hs), x::hl) else (hs,hl)) ~init:(hyps,[]) sign in List.rev lh (* Combinators on judgments *) let on_judgment f j = { uj_val = f j.uj_val; uj_type = f j.uj_type } let on_judgment_value f j = { j with uj_val = f j.uj_val } let on_judgment_type f j = { j with uj_type = f j.uj_type } (* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k variables; skips let-in's *) let context_chop k ctx = let rec chop_aux acc = function | (0, l2) -> (List.rev acc, l2) | (n, ((_,Some _,_ as h)::t)) -> chop_aux (h::acc) (n, t) | (n, (h::t)) -> chop_aux (h::acc) (pred n, t) | (_, []) -> anomaly "context_chop" in chop_aux [] (k,ctx) (* Do not skip let-in's *) let env_rel_context_chop k env = let rels = rel_context env in let ctx1,ctx2 = list_chop k rels in push_rel_context ctx2 (reset_with_named_context (named_context_val env) env), ctx1 (*******************************************) (* Functions to deal with impossible cases *) (*******************************************) let impossible_default_case = ref None let set_impossible_default_clause c = impossible_default_case := Some c let coq_unit_judge = let na1 = Name (id_of_string "A") in let na2 = Name (id_of_string "H") in fun () -> match !impossible_default_case with | Some (id,type_of_id) -> make_judge id type_of_id | None -> (* In case the constants id/ID are not defined *) make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1))) (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))) coq-8.4pl4/pretyping/namegen.ml0000644000175000017500000002660412326224777015630 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let rec find_prefix = function |MPfile dp1 -> not (dp1=dp) |MPdot(mp,_) -> find_prefix mp |MPbound(_) -> false in find_prefix current_mp | p -> false let is_imported_ref = function | VarRef _ -> false | IndRef (kn,_) | ConstructRef ((kn,_),_) -> let (mp,_,_) = repr_mind kn in is_imported_modpath mp | ConstRef kn -> let (mp,_,_) = repr_con kn in is_imported_modpath mp let is_global id = try let ref = locate (qualid_of_ident id) in not (is_imported_ref ref) with Not_found -> false let is_constructor id = try match locate (qualid_of_ident id) with | ConstructRef _ -> true | _ -> false with Not_found -> false (**********************************************************************) (* Generating "intuitive" names from its type *) let lowercase_first_char id = (* First character of a constr *) lowercase_first_char_utf8 (string_of_id id) let sort_hdchar = function | Prop(_) -> "P" | Type(_) -> "T" let hdchar env c = let rec hdrec k c = match kind_of_term c with | Prod (_,_,c) -> hdrec (k+1) c | Lambda (_,_,c) -> hdrec (k+1) c | LetIn (_,_,_,c) -> hdrec (k+1) c | Cast (c,_,_) -> hdrec k c | App (f,l) -> hdrec k f | Const kn -> lowercase_first_char (id_of_label (con_label kn)) | Ind x -> lowercase_first_char (basename_of_global (IndRef x)) | Construct x -> lowercase_first_char (basename_of_global (ConstructRef x)) | Var id -> lowercase_first_char id | Sort s -> sort_hdchar s | Rel n -> (if n<=k then "p" (* the initial term is flexible product/function *) else try match Environ.lookup_rel (n-k) env with | (Name id,_,_) -> lowercase_first_char id | (Anonymous,_,t) -> hdrec 0 (lift (n-k) t) with Not_found -> "y") | Fix ((_,i),(lna,_,_)) -> let id = match lna.(i) with Name id -> id | _ -> assert false in lowercase_first_char id | CoFix (i,(lna,_,_)) -> let id = match lna.(i) with Name id -> id | _ -> assert false in lowercase_first_char id | Meta _|Evar _|Case (_, _, _, _) -> "y" in hdrec 0 c let id_of_name_using_hdchar env a = function | Anonymous -> id_of_string (hdchar env a) | Name id -> id let named_hd env a = function | Anonymous -> Name (id_of_string (hdchar env a)) | x -> x let mkProd_name env (n,a,b) = mkProd (named_hd env a n, a, b) let mkLambda_name env (n,a,b) = mkLambda (named_hd env a n, a, b) let lambda_name = mkLambda_name let prod_name = mkProd_name let prod_create env (a,b) = mkProd (named_hd env a Anonymous, a, b) let lambda_create env (a,b) = mkLambda (named_hd env a Anonymous, a, b) let name_assumption env (na,c,t) = match c with | None -> (named_hd env t na, None, t) | Some body -> (named_hd env body na, c, t) let name_context env hyps = snd (List.fold_left (fun (env,hyps) d -> let d' = name_assumption env d in (push_rel d' env, d' :: hyps)) (env,[]) (List.rev hyps)) let mkProd_or_LetIn_name env b d = mkProd_or_LetIn (name_assumption env d) b let mkLambda_or_LetIn_name env b d = mkLambda_or_LetIn (name_assumption env d)b let it_mkProd_or_LetIn_name env b hyps = it_mkProd_or_LetIn b (name_context env hyps) let it_mkLambda_or_LetIn_name env b hyps = it_mkLambda_or_LetIn b (name_context env hyps) (**********************************************************************) (* Fresh names *) let default_x = id_of_string "x" (* Looks for next "good" name by lifting subscript *) let next_ident_away_from id bad = let rec name_rec id = if bad id then name_rec (lift_subscript id) else id in name_rec id (* Restart subscript from x0 if name starts with xN, or x00 if name starts with x0N, etc *) let restart_subscript id = if not (has_subscript id) then id else (* Ce serait sans doute mieux avec quelque chose inspiré de *** make_ident id (Some 0) *** mais įa brise la compatibilité... *) forget_subscript id (* Now, there are different renaming strategies... *) (* 1- Looks for a fresh name for printing in cases pattern *) let next_name_away_in_cases_pattern na avoid = let id = match na with Name id -> id | Anonymous -> default_x in next_ident_away_from id (fun id -> List.mem id avoid or is_constructor id) (* 2- Looks for a fresh name for introduction in goal *) (* The legacy strategy for renaming introduction variables is not very uniform: - if the name to use is fresh in the context but used as a global name, then a fresh name is taken by finding a free subscript starting from the current subscript; - but if the name to use is not fresh in the current context, the fresh name is taken by finding a free subscript starting from 0 *) let next_ident_away_in_goal id avoid = let id = if List.mem id avoid then restart_subscript id else id in let bad id = List.mem id avoid || (is_global id & not (is_section_variable id)) in next_ident_away_from id bad let next_name_away_in_goal na avoid = let id = match na with Name id -> id | Anonymous -> id_of_string "H" in next_ident_away_in_goal id avoid (* 3- Looks for next fresh name outside a list that is moreover valid as a global identifier; the legacy algorithm is that if the name is already used in the list, one looks for a name of same base with lower available subscript; if the name is not in the list but is used globally, one looks for a name of same base with lower subscript beyond the current subscript *) let next_global_ident_away id avoid = let id = if List.mem id avoid then restart_subscript id else id in let bad id = List.mem id avoid || is_global id in next_ident_away_from id bad (* 4- Looks for next fresh name outside a list; if name already used, looks for same name with lower available subscript *) let next_ident_away id avoid = if List.mem id avoid then next_ident_away_from (restart_subscript id) (fun id -> List.mem id avoid) else id let next_name_away_with_default default na avoid = let id = match na with Name id -> id | Anonymous -> id_of_string default in next_ident_away id avoid let reserved_type_name = ref (fun t -> Anonymous) let set_reserved_typed_name f = reserved_type_name := f let next_name_away_with_default_using_types default na avoid t = let id = match na with | Name id -> id | Anonymous -> match !reserved_type_name t with | Name id -> id | Anonymous -> id_of_string default in next_ident_away id avoid let next_name_away = next_name_away_with_default "H" let make_all_name_different env = let avoid = ref (ids_of_named_context (named_context env)) in process_rel_context (fun (na,c,t) newenv -> let id = next_name_away na !avoid in avoid := id::!avoid; push_rel (Name id,c,t) newenv) env (* 5- Looks for next fresh name outside a list; avoids also to use names that would clash with short name of global references; if name is already used, looks for name of same base with lower available subscript beyond current subscript *) let occur_rel p env id = try lookup_name_of_rel p env = Name id with Not_found -> false (* Unbound indice : may happen in debug *) let visibly_occur_id id (nenv,c) = let rec occur n c = match kind_of_term c with | Const _ | Ind _ | Construct _ | Var _ when shortest_qualid_of_global Idset.empty (global_of_constr c) = qualid_of_ident id -> raise Occur | Rel p when p>n & occur_rel (p-n) nenv id -> raise Occur | _ -> iter_constr_with_binders succ occur n c in try occur 1 c; false with Occur -> true | Not_found -> false (* Happens when a global is not in the env *) let next_ident_away_for_default_printing env_t id avoid = let bad id = List.mem id avoid or visibly_occur_id id env_t in next_ident_away_from id bad let next_name_away_for_default_printing env_t na avoid = let id = match na with | Name id -> id | Anonymous -> (* In principle, an anonymous name is not dependent and will not be *) (* taken into account by the function compute_displayed_name_in; *) (* just in case, invent a valid name *) id_of_string "H" in next_ident_away_for_default_printing env_t id avoid (**********************************************************************) (* Displaying terms avoiding bound variables clashes *) (* Renaming strategy introduced in December 1998: - Rule number 1: all names, even if unbound and not displayed, contribute to the list of names to avoid - Rule number 2: only the dependency status is used for deciding if a name is displayed or not Example: bool_ind: "forall (P:bool->Prop)(f:(P true))(f:(P false))(b:bool), P b" is displayed "forall P:bool->Prop, P true -> P false -> forall b:bool, P b" but f and f0 contribute to the list of variables to avoid (knowing that f and f0 are how the f's would be named if introduced, assuming no other f and f0 are already used). *) type renaming_flags = | RenamingForCasesPattern | RenamingForGoal | RenamingElsewhereFor of (name list * constr) let next_name_for_display flags = match flags with | RenamingForCasesPattern -> next_name_away_in_cases_pattern | RenamingForGoal -> next_name_away_in_goal | RenamingElsewhereFor env_t -> next_name_away_for_default_printing env_t (* Remark: Anonymous var may be dependent in Evar's contexts *) let compute_displayed_name_in flags avoid na c = if na = Anonymous & noccurn 1 c then (Anonymous,avoid) else let fresh_id = next_name_for_display flags na avoid in let idopt = if noccurn 1 c then Anonymous else Name fresh_id in (idopt, fresh_id::avoid) let compute_and_force_displayed_name_in flags avoid na c = if na = Anonymous & noccurn 1 c then (Anonymous,avoid) else let fresh_id = next_name_for_display flags na avoid in (Name fresh_id, fresh_id::avoid) let compute_displayed_let_name_in flags avoid na c = let fresh_id = next_name_for_display flags na avoid in (Name fresh_id, fresh_id::avoid) let rec rename_bound_vars_as_displayed avoid env c = let rec rename avoid env c = match kind_of_term c with | Prod (na,c1,c2) -> let na',avoid' = compute_displayed_name_in (RenamingElsewhereFor (env,c2)) avoid na c2 in mkProd (na', c1, rename avoid' (add_name na' env) c2) | LetIn (na,c1,t,c2) -> let na',avoid' = compute_displayed_let_name_in (RenamingElsewhereFor (env,c2)) avoid na c2 in mkLetIn (na',c1,t, rename avoid' (add_name na' env) c2) | Cast (c,k,t) -> mkCast (rename avoid env c, k,t) | _ -> c in rename avoid env c coq-8.4pl4/pretyping/pattern.ml0000644000175000017500000003276412326224777015677 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* _ ? *) } type constr_pattern = | PRef of global_reference | PVar of identifier | PEvar of existential_key * constr_pattern array | PRel of int | PApp of constr_pattern * constr_pattern array | PSoApp of patvar * constr_pattern list | PLambda of name * constr_pattern * constr_pattern | PProd of name * constr_pattern * constr_pattern | PLetIn of name * constr_pattern * constr_pattern | PSort of glob_sort | PMeta of patvar option | PIf of constr_pattern * constr_pattern * constr_pattern | PCase of case_info_pattern * constr_pattern * constr_pattern * (int * int * constr_pattern) list (** constructor index, nb of args *) | PFix of fixpoint | PCoFix of cofixpoint let rec occur_meta_pattern = function | PApp (f,args) -> (occur_meta_pattern f) or (array_exists occur_meta_pattern args) | PLambda (na,t,c) -> (occur_meta_pattern t) or (occur_meta_pattern c) | PProd (na,t,c) -> (occur_meta_pattern t) or (occur_meta_pattern c) | PLetIn (na,t,c) -> (occur_meta_pattern t) or (occur_meta_pattern c) | PIf (c,c1,c2) -> (occur_meta_pattern c) or (occur_meta_pattern c1) or (occur_meta_pattern c2) | PCase(_,p,c,br) -> (occur_meta_pattern p) or (occur_meta_pattern c) or (List.exists (fun (_,_,p) -> occur_meta_pattern p) br) | PMeta _ | PSoApp _ -> true | PEvar _ | PVar _ | PRef _ | PRel _ | PSort _ | PFix _ | PCoFix _ -> false exception BoundPattern;; let rec head_pattern_bound t = match t with | PProd (_,_,b) -> head_pattern_bound b | PLetIn (_,_,b) -> head_pattern_bound b | PApp (c,args) -> head_pattern_bound c | PIf (c,_,_) -> head_pattern_bound c | PCase (_,p,c,br) -> head_pattern_bound c | PRef r -> r | PVar id -> VarRef id | PEvar _ | PRel _ | PMeta _ | PSoApp _ | PSort _ | PFix _ -> raise BoundPattern (* Perhaps they were arguments, but we don't beta-reduce *) | PLambda _ -> raise BoundPattern | PCoFix _ -> anomaly "head_pattern_bound: not a type" let head_of_constr_reference c = match kind_of_term c with | Const sp -> ConstRef sp | Construct sp -> ConstructRef sp | Ind sp -> IndRef sp | Var id -> VarRef id | _ -> anomaly "Not a rigid reference" open Evd let pattern_of_constr sigma t = let ctx = ref [] in let rec pattern_of_constr t = match kind_of_term t with | Rel n -> PRel n | Meta n -> PMeta (Some (id_of_string ("META" ^ string_of_int n))) | Var id -> PVar id | Sort (Prop c) -> PSort (GProp c) | Sort (Type _) -> PSort (GType None) | Cast (c,_,_) -> pattern_of_constr c | LetIn (na,c,_,b) -> PLetIn (na,pattern_of_constr c,pattern_of_constr b) | Prod (na,c,b) -> PProd (na,pattern_of_constr c,pattern_of_constr b) | Lambda (na,c,b) -> PLambda (na,pattern_of_constr c,pattern_of_constr b) | App (f,a) -> (match match kind_of_term f with Evar (evk,args as ev) -> (match snd (Evd.evar_source evk sigma) with MatchingVar (true,id) -> ctx := (id,None,existential_type sigma ev)::!ctx; Some id | _ -> None) | _ -> None with | Some n -> PSoApp (n,Array.to_list (Array.map pattern_of_constr a)) | None -> PApp (pattern_of_constr f,Array.map (pattern_of_constr) a)) | Const sp -> PRef (ConstRef (constant_of_kn(canonical_con sp))) | Ind sp -> PRef (canonical_gr (IndRef sp)) | Construct sp -> PRef (canonical_gr (ConstructRef sp)) | Evar (evk,ctxt as ev) -> (match snd (Evd.evar_source evk sigma) with | MatchingVar (b,id) -> ctx := (id,None,existential_type sigma ev)::!ctx; assert (not b); PMeta (Some id) | GoalEvar -> PEvar (evk,Array.map pattern_of_constr ctxt) | _ -> PMeta None) | Case (ci,p,a,br) -> let cip = { cip_style = ci.ci_pp_info.style; cip_ind = Some ci.ci_ind; cip_ind_args = Some (ci.ci_npar, ci.ci_pp_info.ind_nargs); cip_extensible = false } in let branch_of_constr i c = (i, ci.ci_cstr_ndecls.(i), pattern_of_constr c) in PCase (cip, pattern_of_constr p, pattern_of_constr a, Array.to_list (Array.mapi branch_of_constr br)) | Fix f -> PFix f | CoFix f -> PCoFix f in let p = pattern_of_constr t in (* side-effect *) (* Warning: the order of dependencies in ctx is not ensured *) (!ctx,p) (* To process patterns, we need a translation without typing at all. *) let map_pattern_with_binders g f l = function | PApp (p,pl) -> PApp (f l p, Array.map (f l) pl) | PSoApp (n,pl) -> PSoApp (n, List.map (f l) pl) | PLambda (n,a,b) -> PLambda (n,f l a,f (g n l) b) | PProd (n,a,b) -> PProd (n,f l a,f (g n l) b) | PLetIn (n,a,b) -> PLetIn (n,f l a,f (g n l) b) | PIf (c,b1,b2) -> PIf (f l c,f l b1,f l b2) | PCase (ci,po,p,pl) -> PCase (ci,f l po,f l p, List.map (fun (i,n,c) -> (i,n,f l c)) pl) (* Non recursive *) | (PVar _ | PEvar _ | PRel _ | PRef _ | PSort _ | PMeta _ (* Bound to terms *) | PFix _ | PCoFix _ as x) -> x let error_instantiate_pattern id l = let is = if List.length l = 1 then "is" else "are" in errorlabstrm "" (str "Cannot substitute the term bound to " ++ pr_id id ++ strbrk " in pattern because the term refers to " ++ pr_enum pr_id l ++ strbrk " which " ++ str is ++ strbrk " not bound in the pattern.") let instantiate_pattern sigma lvar c = let rec aux vars = function | PVar id as x -> (try let ctx,c = List.assoc id lvar in try let inst = List.map (fun id -> mkRel (list_index (Name id) vars)) ctx in let c = substl inst c in snd (pattern_of_constr sigma c) with Not_found (* list_index failed *) -> let vars = list_map_filter (function Name id -> Some id | _ -> None) vars in error_instantiate_pattern id (list_subtract ctx vars) with Not_found (* List.assoc failed *) -> x) | (PFix _ | PCoFix _) -> error ("Non instantiable pattern.") | c -> map_pattern_with_binders (fun id vars -> id::vars) aux vars c in aux [] c let rec liftn_pattern k n = function | PRel i as x -> if i >= n then PRel (i+k) else x | PFix x -> PFix (destFix (liftn k n (mkFix x))) | PCoFix x -> PCoFix (destCoFix (liftn k n (mkCoFix x))) | c -> map_pattern_with_binders (fun _ -> succ) (liftn_pattern k) n c let lift_pattern k = liftn_pattern k 1 let rec subst_pattern subst pat = match pat with | PRef ref -> let ref',t = subst_global subst ref in if ref' == ref then pat else snd (pattern_of_constr Evd.empty t) | PVar _ | PEvar _ | PRel _ -> pat | PApp (f,args) -> let f' = subst_pattern subst f in let args' = array_smartmap (subst_pattern subst) args in if f' == f && args' == args then pat else PApp (f',args') | PSoApp (i,args) -> let args' = list_smartmap (subst_pattern subst) args in if args' == args then pat else PSoApp (i,args') | PLambda (name,c1,c2) -> let c1' = subst_pattern subst c1 in let c2' = subst_pattern subst c2 in if c1' == c1 && c2' == c2 then pat else PLambda (name,c1',c2') | PProd (name,c1,c2) -> let c1' = subst_pattern subst c1 in let c2' = subst_pattern subst c2 in if c1' == c1 && c2' == c2 then pat else PProd (name,c1',c2') | PLetIn (name,c1,c2) -> let c1' = subst_pattern subst c1 in let c2' = subst_pattern subst c2 in if c1' == c1 && c2' == c2 then pat else PLetIn (name,c1',c2') | PSort _ | PMeta _ -> pat | PIf (c,c1,c2) -> let c' = subst_pattern subst c in let c1' = subst_pattern subst c1 in let c2' = subst_pattern subst c2 in if c' == c && c1' == c1 && c2' == c2 then pat else PIf (c',c1',c2') | PCase (cip,typ,c,branches) -> let ind = cip.cip_ind in let ind' = Option.smartmap (Inductiveops.subst_inductive subst) ind in let cip' = if ind' == ind then cip else { cip with cip_ind = ind' } in let typ' = subst_pattern subst typ in let c' = subst_pattern subst c in let subst_branch ((i,n,c) as br) = let c' = subst_pattern subst c in if c' == c then br else (i,n,c') in let branches' = list_smartmap subst_branch branches in if cip' == cip && typ' == typ && c' == c && branches' == branches then pat else PCase(cip', typ', c', branches') | PFix fixpoint -> let cstr = mkFix fixpoint in let fixpoint' = destFix (subst_mps subst cstr) in if fixpoint' == fixpoint then pat else PFix fixpoint' | PCoFix cofixpoint -> let cstr = mkCoFix cofixpoint in let cofixpoint' = destCoFix (subst_mps subst cstr) in if cofixpoint' == cofixpoint then pat else PCoFix cofixpoint' let mkPLambda na b = PLambda(na,PMeta None,b) let rev_it_mkPLambda = List.fold_right mkPLambda let err loc pp = user_err_loc (loc,"pattern_of_glob_constr", pp) let rec pat_of_raw metas vars = function | GVar (_,id) -> (try PRel (list_index (Name id) vars) with Not_found -> PVar id) | GPatVar (_,(false,n)) -> metas := n::!metas; PMeta (Some n) | GRef (_,gr) -> PRef (canonical_gr gr) (* Hack pour ne pas réécrire une interprétation complčte des patterns*) | GApp (_, GPatVar (_,(true,n)), cl) -> metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl) | GApp (_,c,cl) -> PApp (pat_of_raw metas vars c, Array.of_list (List.map (pat_of_raw metas vars) cl)) | GLambda (_,na,bk,c1,c2) -> name_iter (fun n -> metas := n::!metas) na; PLambda (na, pat_of_raw metas vars c1, pat_of_raw metas (na::vars) c2) | GProd (_,na,bk,c1,c2) -> name_iter (fun n -> metas := n::!metas) na; PProd (na, pat_of_raw metas vars c1, pat_of_raw metas (na::vars) c2) | GLetIn (_,na,c1,c2) -> name_iter (fun n -> metas := n::!metas) na; PLetIn (na, pat_of_raw metas vars c1, pat_of_raw metas (na::vars) c2) | GSort (_,s) -> PSort s | GHole _ -> PMeta None | GCast (_,c,_) -> Flags.if_warn Pp.msg_warning (str "Cast not taken into account in constr pattern"); pat_of_raw metas vars c | GIf (_,c,(_,None),b1,b2) -> PIf (pat_of_raw metas vars c, pat_of_raw metas vars b1,pat_of_raw metas vars b2) | GLetTuple (loc,nal,(_,None),b,c) -> let mkGLambda c na = GLambda (loc,na,Explicit,GHole (loc,Evd.InternalHole),c) in let c = List.fold_left mkGLambda c nal in let cip = { cip_style = LetStyle; cip_ind = None; cip_ind_args = None; cip_extensible = false } in PCase (cip, PMeta None, pat_of_raw metas vars b, [0,1,pat_of_raw metas vars c]) | GCases (loc,sty,p,[c,(na,indnames)],brs) -> let get_ind = function | (_,_,[PatCstr(_,(ind,_),_,_)],_)::_ -> Some ind | _ -> None in let ind_nargs,ind = match indnames with | Some (_,ind,n,nal) -> Some (n,List.length nal), Some ind | None -> None, get_ind brs in let ext,brs = pats_of_glob_branches loc metas vars ind brs in let pred = match p,indnames with | Some p, Some (_,_,_,nal) -> rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas vars p)) | _ -> PMeta None in let info = { cip_style = sty; cip_ind = ind; cip_ind_args = ind_nargs; cip_extensible = ext } in (* Nota : when we have a non-trivial predicate, the inductive type is known. Same when we have at least one non-trivial branch. These facts are used in [Constrextern]. *) PCase (info, pred, pat_of_raw metas vars c, brs) | r -> err (loc_of_glob_constr r) (Pp.str "Non supported pattern.") and pats_of_glob_branches loc metas vars ind brs = let get_arg = function | PatVar(_,na) -> na | PatCstr(loc,_,_,_) -> err loc (Pp.str "Non supported pattern.") in let rec get_pat indexes = function | [] -> false, [] | [(_,_,[PatVar(_,Anonymous)],GHole _)] -> true, [] (* ends with _ => _ *) | (_,_,[PatCstr(_,(indsp,j),lv,_)],br) :: brs -> if ind <> None && ind <> Some indsp then err loc (Pp.str "All constructors must be in the same inductive type."); if Intset.mem (j-1) indexes then err loc (str "No unique branch for " ++ int j ++ str"-th constructor."); let lna = List.map get_arg lv in let vars' = List.rev lna @ vars in let pat = rev_it_mkPLambda lna (pat_of_raw metas vars' br) in let ext,pats = get_pat (Intset.add (j-1) indexes) brs in ext, ((j-1, List.length lv, pat) :: pats) | (loc,_,_,_) :: _ -> err loc (Pp.str "Non supported pattern.") in get_pat Intset.empty brs let pattern_of_glob_constr c = let metas = ref [] in let p = pat_of_raw metas [] c in (!metas,p) coq-8.4pl4/pretyping/classops.mli0000644000175000017500000000653312326224777016215 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* cl_typ -> cl_typ (** This is the type of infos for declared classes *) type cl_info_typ = { cl_param : int } (** This is the type of coercion kinds *) type coe_typ = Libnames.global_reference (** This is the type of infos for declared coercions *) type coe_info_typ (** [cl_index] is the type of class keys *) type cl_index (** [coe_index] is the type of coercion keys *) type coe_index (** This is the type of paths from a class to another *) type inheritance_path = coe_index list (** {6 Access to classes infos } *) val class_info : cl_typ -> (cl_index * cl_info_typ) val class_exists : cl_typ -> bool val class_info_from_index : cl_index -> cl_typ * cl_info_typ (** [find_class_type env sigma c] returns the head reference of [c] and its arguments *) val find_class_type : evar_map -> types -> cl_typ * constr list (** raises [Not_found] if not convertible to a class *) val class_of : env -> evar_map -> types -> types * cl_index (** raises [Not_found] if not mapped to a class *) val inductive_class_of : inductive -> cl_index val class_args_of : env -> evar_map -> types -> constr list (** {6 [declare_coercion] adds a coercion in the graph of coercion paths } *) val declare_coercion : coe_typ -> locality -> isid:bool -> src:cl_typ -> target:cl_typ -> params:int -> unit (** {6 Access to coercions infos } *) val coercion_exists : coe_typ -> bool val coercion_value : coe_index -> (unsafe_judgment * bool) (** {6 Lookup functions for coercion paths } *) val lookup_path_between_class : cl_index * cl_index -> inheritance_path val lookup_path_between : env -> evar_map -> types * types -> types * types * inheritance_path val lookup_path_to_fun_from : env -> evar_map -> types -> types * inheritance_path val lookup_path_to_sort_from : env -> evar_map -> types -> types * inheritance_path val lookup_pattern_path_between : inductive * inductive -> (constructor * int) list (**/**) (* Crade *) open Pp val install_path_printer : ((cl_index * cl_index) * inheritance_path -> std_ppcmds) -> unit (**/**) (** {6 This is for printing purpose } *) val string_of_class : cl_typ -> string val pr_class : cl_typ -> std_ppcmds val pr_cl_index : cl_index -> std_ppcmds val get_coercion_value : coe_index -> constr val inheritance_graph : unit -> ((cl_index * cl_index) * inheritance_path) list val classes : unit -> cl_typ list val coercions : unit -> coe_index list (** [hide_coercion] returns the number of params to skip if the coercion must be hidden, [None] otherwise; it raises [Not_found] if not a coercion *) val hide_coercion : coe_typ -> int option coq-8.4pl4/pretyping/retyping.ml0000644000175000017500000001726212326224777016057 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* if is_fconv Reduction.CONV env sigma t t1 then Some t2 else if is_fconv Reduction.CONV env sigma t t2 then Some t1 else None) (snd (Evd.extract_all_conv_pbs sigma)) with | t::l -> t | _ -> raise Not_found else raise Not_found let rec subst_type env sigma typ = function | [] -> typ | h::rest -> match kind_of_term (whd_betadeltaiota env sigma typ) with | Prod (na,c1,c2) -> subst_type env sigma (subst1 h c2) rest | _ -> anomaly "Non-functional construction" (* Si ft est le type d'un terme f, lequel est appliqué ā args, *) (* [sort_of_atomic_ty] calcule ft[args] qui doit ętre une sorte *) (* On suit une méthode paresseuse, en espčrant que ft est une arité *) (* et sinon on substitue *) let sort_of_atomic_type env sigma ft args = let rec concl_of_arity env ar args = match kind_of_term (whd_betadeltaiota env sigma ar), args with | Prod (na, t, b), h::l -> concl_of_arity (push_rel (na,Some h,t) env) b l | Sort s, [] -> s | _ -> anomaly "Not a sort" in concl_of_arity env ft (Array.to_list args) let type_of_var env id = try let (_,_,ty) = lookup_named id env in ty with Not_found -> anomaly ("type_of: variable "^(string_of_id id)^" unbound") let retype ?(polyprop=true) sigma = let rec type_of env cstr= match kind_of_term cstr with | Meta n -> (try strip_outer_cast (Evd.meta_ftype sigma n).Evd.rebus with Not_found -> anomaly ("type_of: unknown meta " ^ string_of_int n)) | Rel n -> let (_,_,ty) = lookup_rel n env in lift n ty | Var id -> type_of_var env id | Const cst -> Typeops.type_of_constant env cst | Evar ev -> Evd.existential_type sigma ev | Ind ind -> type_of_inductive env ind | Construct cstr -> type_of_constructor env cstr | Case (_,p,c,lf) -> let Inductiveops.IndType(_,realargs) = let t = type_of env c in try Inductiveops.find_rectype env sigma t with Not_found -> try let t = get_type_from_constraints env sigma t in Inductiveops.find_rectype env sigma t with Not_found -> anomaly "type_of: Bad recursive type" in let t = whd_beta sigma (applist (p, realargs)) in (match kind_of_term (whd_betadeltaiota env sigma (type_of env t)) with | Prod _ -> whd_beta sigma (applist (t, [c])) | _ -> t) | Lambda (name,c1,c2) -> mkProd (name, c1, type_of (push_rel (name,None,c1) env) c2) | LetIn (name,b,c1,c2) -> subst1 b (type_of (push_rel (name,Some b,c1) env) c2) | Fix ((_,i),(_,tys,_)) -> tys.(i) | CoFix (i,(_,tys,_)) -> tys.(i) | App(f,args) when isGlobalRef f -> let t = type_of_global_reference_knowing_parameters env f args in strip_outer_cast (subst_type env sigma t (Array.to_list args)) | App(f,args) -> strip_outer_cast (subst_type env sigma (type_of env f) (Array.to_list args)) | Cast (c,_, t) -> t | Sort _ | Prod _ -> mkSort (sort_of env cstr) and sort_of env t = match kind_of_term t with | Cast (c,_, s) when isSort s -> destSort s | Sort (Prop c) -> type1_sort | Sort (Type u) -> Type (Univ.super u) | Prod (name,t,c2) -> (match (sort_of env t, sort_of (push_rel (name,None,t) env) c2) with | _, (Prop Null as s) -> s | Prop _, (Prop Pos as s) -> s | Type _, (Prop Pos as s) when Environ.engagement env = Some ImpredicativeSet -> s | (Type _, _) | (_, Type _) -> new_Type_sort () (* | Type u1, Prop Pos -> Type (Univ.sup u1 Univ.type0_univ) | Prop Pos, (Type u2) -> Type (Univ.sup Univ.type0_univ u2) | Prop Null, (Type _ as s) -> s | Type u1, Type u2 -> Type (Univ.sup u1 u2)*)) | App(f,args) when isGlobalRef f -> let t = type_of_global_reference_knowing_parameters env f args in sort_of_atomic_type env sigma t args | App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args | Lambda _ | Fix _ | Construct _ -> anomaly "sort_of: Not a type (1)" | _ -> decomp_sort env sigma (type_of env t) and sort_family_of env t = match kind_of_term t with | Cast (c,_, s) when isSort s -> family_of_sort (destSort s) | Sort (Prop c) -> InType | Sort (Type u) -> InType | Prod (name,t,c2) -> let s2 = sort_family_of (push_rel (name,None,t) env) c2 in if Environ.engagement env <> Some ImpredicativeSet && s2 = InSet & sort_family_of env t = InType then InType else s2 | App(f,args) when isGlobalRef f -> let t = type_of_global_reference_knowing_parameters env f args in family_of_sort (sort_of_atomic_type env sigma t args) | App(f,args) -> family_of_sort (sort_of_atomic_type env sigma (type_of env f) args) | Lambda _ | Fix _ | Construct _ -> anomaly "sort_of: Not a type (1)" | _ -> family_of_sort (decomp_sort env sigma (type_of env t)) and type_of_global_reference_knowing_parameters env c args = let argtyps = Array.map (fun c -> nf_evar sigma (type_of env c)) args in match kind_of_term c with | Ind ind -> let (_,mip) = lookup_mind_specif env ind in (try Inductive.type_of_inductive_knowing_parameters ~polyprop env mip argtyps with Reduction.NotArity -> anomaly "type_of: Not an arity") | Const cst -> let t = constant_type env cst in (try Typeops.type_of_constant_knowing_parameters env t argtyps with Reduction.NotArity -> anomaly "type_of: Not an arity") | Var id -> type_of_var env id | Construct cstr -> type_of_constructor env cstr | _ -> assert false in type_of, sort_of, sort_family_of, type_of_global_reference_knowing_parameters let get_sort_of ?(polyprop=true) env sigma t = let _,f,_,_ = retype ~polyprop sigma in f env t let get_sort_family_of ?(polyprop=true) env sigma c = let _,_,f,_ = retype ~polyprop sigma in f env c let type_of_global_reference_knowing_parameters env sigma c args = let _,_,_,f = retype sigma in f env c args let type_of_global_reference_knowing_conclusion env sigma c conclty = let conclty = nf_evar sigma conclty in match kind_of_term c with | Ind ind -> let (_,mip) = Inductive.lookup_mind_specif env ind in type_of_inductive_knowing_conclusion env mip conclty | Const cst -> let t = constant_type env cst in (* TODO *) Typeops.type_of_constant_knowing_parameters env t [||] | Var id -> type_of_var env id | Construct cstr -> type_of_constructor env cstr | _ -> assert false (* We are outside the kernel: we take fresh universes *) (* to avoid tactics and co to refresh universes themselves *) let get_type_of ?(polyprop=true) ?(refresh=true) env sigma c = let f,_,_,_ = retype ~polyprop sigma in let t = f env c in if refresh then refresh_universes t else t (* Makes an assumption from a constr *) let get_assumption_of env evc c = c (* Makes an unsafe judgment from a constr *) let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c } coq-8.4pl4/pretyping/inductiveops.ml0000644000175000017500000003731712326224777016735 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* match dest_recarg ra with | Mrec (_,i) -> List.mem i listind | _ -> false) rvec in array_exists one_is_rec (dest_subterms rarg) let mis_is_recursive (ind,mib,mip) = mis_is_recursive_subset (interval 0 (mib.mind_ntypes-1)) mip.mind_recargs let mis_nf_constructor_type (ind,mib,mip) j = let specif = mip.mind_nf_lc and ntypes = mib.mind_ntypes and nconstr = Array.length mip.mind_consnames in let make_Ik k = mkInd ((fst ind),ntypes-k-1) in if j > nconstr then error "Not enough constructors in the type."; substl (list_tabulate make_Ik ntypes) specif.(j-1) (* Arity of constructors excluding parameters and local defs *) let mis_constr_nargs indsp = let (mib,mip) = Global.lookup_inductive indsp in let recargs = dest_subterms mip.mind_recargs in Array.map List.length recargs let mis_constr_nargs_env env (kn,i) = let mib = Environ.lookup_mind kn env in let mip = mib.mind_packets.(i) in let recargs = dest_subterms mip.mind_recargs in Array.map List.length recargs let mis_constructor_nargs_env env ((kn,i),j) = let mib = Environ.lookup_mind kn env in let mip = mib.mind_packets.(i) in recarg_length mip.mind_recargs j + mib.mind_nparams let constructor_nrealargs env (ind,j) = let (_,mip) = Inductive.lookup_mind_specif env ind in recarg_length mip.mind_recargs j let constructor_nrealhyps env (ind,j) = let (mib,mip) = Inductive.lookup_mind_specif env ind in mip.mind_consnrealdecls.(j-1) let get_full_arity_sign env ind = let (mib,mip) = Inductive.lookup_mind_specif env ind in mip.mind_arity_ctxt let nconstructors ind = let (mib,mip) = Inductive.lookup_mind_specif (Global.env()) ind in Array.length mip.mind_consnames (* Length of arity (w/o local defs) *) let inductive_nargs env ind = let (mib,mip) = Inductive.lookup_mind_specif env ind in (rel_context_length (mib.mind_params_ctxt), mip.mind_nrealargs_ctxt) let allowed_sorts env (kn,i as ind) = let (mib,mip) = Inductive.lookup_mind_specif env ind in mip.mind_kelim (* Annotation for cases *) let make_case_info env ind style = let (mib,mip) = Inductive.lookup_mind_specif env ind in let print_info = { ind_nargs = mip.mind_nrealargs_ctxt; style = style } in { ci_ind = ind; ci_npar = mib.mind_nparams; ci_cstr_ndecls = mip.mind_consnrealdecls; ci_pp_info = print_info } (*s Useful functions *) type constructor_summary = { cs_cstr : constructor; cs_params : constr list; cs_nargs : int; cs_args : rel_context; cs_concl_realargs : constr array } let lift_constructor n cs = { cs_cstr = cs.cs_cstr; cs_params = List.map (lift n) cs.cs_params; cs_nargs = cs.cs_nargs; cs_args = lift_rel_context n cs.cs_args; cs_concl_realargs = Array.map (liftn n (cs.cs_nargs+1)) cs.cs_concl_realargs } (* Accept less parameters than in the signature *) let instantiate_params t args sign = let rec inst s t = function | ((_,None,_)::ctxt,a::args) -> (match kind_of_term t with | Prod(_,_,t) -> inst (a::s) t (ctxt,args) | _ -> anomaly"instantiate_params: type, ctxt and args mismatch") | ((_,(Some b),_)::ctxt,args) -> (match kind_of_term t with | LetIn(_,_,_,t) -> inst ((substl s b)::s) t (ctxt,args) | _ -> anomaly"instantiate_params: type, ctxt and args mismatch") | _, [] -> substl s t | _ -> anomaly"instantiate_params: type, ctxt and args mismatch" in inst [] t (List.rev sign,args) let get_constructor (ind,mib,mip,params) j = assert (j <= Array.length mip.mind_consnames); let typi = mis_nf_constructor_type (ind,mib,mip) j in let typi = instantiate_params typi params mib.mind_params_ctxt in let (args,ccl) = decompose_prod_assum typi in let (_,allargs) = decompose_app ccl in let vargs = list_skipn (List.length params) allargs in { cs_cstr = ith_constructor_of_inductive ind j; cs_params = params; cs_nargs = rel_context_length args; cs_args = args; cs_concl_realargs = Array.of_list vargs } let get_constructors env (ind,params) = let (mib,mip) = Inductive.lookup_mind_specif env ind in Array.init (Array.length mip.mind_consnames) (fun j -> get_constructor (ind,mib,mip,params) (j+1)) (* substitution in a signature *) let substnl_rel_context subst n sign = let rec aux n = function | d::sign -> substnl_decl subst n d :: aux (n+1) sign | [] -> [] in List.rev (aux n (List.rev sign)) let substl_rel_context subst = substnl_rel_context subst 0 let rec instantiate_context sign args = let rec aux subst = function | (_,None,_)::sign, a::args -> aux (a::subst) (sign,args) | (_,Some b,_)::sign, args -> aux (substl subst b::subst) (sign,args) | [], [] -> subst | _ -> anomaly "Signature/instance mismatch in inductive family" in aux [] (List.rev sign,args) let get_arity env (ind,params) = let (mib,mip) = Inductive.lookup_mind_specif env ind in let parsign = (* Dynamically detect if called with an instance of recursively uniform parameter only or also of non recursively uniform parameters *) let parsign = mib.mind_params_ctxt in let nnonrecparams = mib.mind_nparams - mib.mind_nparams_rec in if List.length params = rel_context_nhyps parsign - nnonrecparams then snd (list_chop nnonrecparams mib.mind_params_ctxt) else parsign in let arproperlength = List.length mip.mind_arity_ctxt - List.length parsign in let arsign,_ = list_chop arproperlength mip.mind_arity_ctxt in let subst = instantiate_context parsign params in (substl_rel_context subst arsign, Inductive.inductive_sort_family mip) (* Functions to build standard types related to inductive *) let build_dependent_constructor cs = applist (mkConstruct cs.cs_cstr, (List.map (lift cs.cs_nargs) cs.cs_params) @(extended_rel_list 0 cs.cs_args)) let build_dependent_inductive env ((ind, params) as indf) = let arsign,_ = get_arity env indf in let nrealargs = List.length arsign in applist (mkInd ind, (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign)) (* builds the arity of an elimination predicate in sort [s] *) let make_arity_signature env dep indf = let (arsign,_) = get_arity env indf in if dep then (* We need names everywhere *) name_context env ((Anonymous,None,build_dependent_inductive env indf)::arsign) (* Costly: would be better to name once for all at definition time *) else (* No need to enforce names *) arsign let make_arity env dep indf s = mkArity (make_arity_signature env dep indf, s) (* [p] is the predicate and [cs] a constructor summary *) let build_branch_type env dep p cs = let base = appvect (lift cs.cs_nargs p, cs.cs_concl_realargs) in if dep then it_mkProd_or_LetIn_name env (applist (base,[build_dependent_constructor cs])) cs.cs_args else it_mkProd_or_LetIn base cs.cs_args (**************************************************) let extract_mrectype t = let (t, l) = decompose_app t in match kind_of_term t with | Ind ind -> (ind, l) | _ -> raise Not_found let find_mrectype env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with | Ind ind -> (ind, l) | _ -> raise Not_found let find_rectype env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with | Ind ind -> let (mib,mip) = Inductive.lookup_mind_specif env ind in if mib.mind_nparams > List.length l then raise Not_found; let (par,rargs) = list_chop mib.mind_nparams l in IndType((ind, par),rargs) | _ -> raise Not_found let find_inductive env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with | Ind ind when (fst (Inductive.lookup_mind_specif env ind)).mind_finite -> (ind, l) | _ -> raise Not_found let find_coinductive env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with | Ind ind when not (fst (Inductive.lookup_mind_specif env ind)).mind_finite -> (ind, l) | _ -> raise Not_found (***********************************************) (* find appropriate names for pattern variables. Useful in the Case and Inversion (case_then_using et case_nodep_then_using) tactics. *) let is_predicate_explicitly_dep env pred arsign = let rec srec env pval arsign = let pv' = whd_betadeltaiota env Evd.empty pval in match kind_of_term pv', arsign with | Lambda (na,t,b), (_,None,_)::arsign -> srec (push_rel_assum (na,t) env) b arsign | Lambda (na,_,_), _ -> (* The following code has an impact on the introduction names given by the tactics "case" and "inversion": when the elimination is not dependent, "case" uses Anonymous for inductive types in Prop and names created by mkProd_name for inductive types in Set/Type while "inversion" uses anonymous for inductive types both in Prop and Set/Type !! Previously, whether names were created or not relied on whether the predicate created in Indrec.make_case_com had a dependent arity or not. To avoid different predicates printed the same in v8, all predicates built in indrec.ml got a dependent arity (Aug 2004). The new way to decide whether names have to be created or not is to use an Anonymous or Named variable to enforce the expected dependency status (of course, Anonymous implies non dependent, but not conversely). At the end, this is only to preserve the compatibility: a check whether the predicate is actually dependent or not would indeed be more natural! *) na <> Anonymous | _ -> anomaly "Non eta-expanded dep-expanded \"match\" predicate" in srec env pred arsign let is_elim_predicate_explicitly_dependent env pred indf = let arsign,_ = get_arity env indf in is_predicate_explicitly_dep env pred arsign let set_names env n brty = let (ctxt,cl) = decompose_prod_n_assum n brty in it_mkProd_or_LetIn_name env cl ctxt let set_pattern_names env ind brv = let (mib,mip) = Inductive.lookup_mind_specif env ind in let arities = Array.map (fun c -> rel_context_length ((prod_assum c)) - mib.mind_nparams) mip.mind_nf_lc in array_map2 (set_names env) arities brv let type_case_branches_with_names env indspec p c = let (ind,args) = indspec in let (mib,mip as specif) = Inductive.lookup_mind_specif env ind in let nparams = mib.mind_nparams in let (params,realargs) = list_chop nparams args in let lbrty = Inductive.build_branches_type ind specif params p in (* Build case type *) let conclty = Reduction.beta_appvect p (Array.of_list (realargs@[c])) in (* Adjust names *) if is_elim_predicate_explicitly_dependent env p (ind,params) then (set_pattern_names env ind lbrty, conclty) else (lbrty, conclty) (* Type of Case predicates *) let arity_of_case_predicate env (ind,params) dep k = let arsign,_ = get_arity env (ind,params) in let mind = build_dependent_inductive env (ind,params) in let concl = if dep then mkArrow mind (mkSort k) else mkSort k in it_mkProd_or_LetIn concl arsign (***********************************************) (* Inferring the sort of parameters of a polymorphic inductive type knowing the sort of the conclusion *) (* Compute the inductive argument types: replace the sorts that appear in the type of the inductive by the sort of the conclusion, and the other ones by fresh universes. *) let rec instantiate_universes env scl is = function | (_,Some _,_ as d)::sign, exp -> d :: instantiate_universes env scl is (sign, exp) | d::sign, None::exp -> d :: instantiate_universes env scl is (sign, exp) | (na,None,ty)::sign, Some u::exp -> let ctx,_ = Reduction.dest_arity env ty in let s = (* Does the sort of parameter [u] appear in (or equal) the sort of inductive [is] ? *) if univ_depends u is then scl (* constrained sort: replace by scl *) else (* unconstriained sort: replace by fresh universe *) new_Type_sort() in (na,None,mkArity(ctx,s)):: instantiate_universes env scl is (sign, exp) | sign, [] -> sign (* Uniform parameters are exhausted *) | [], _ -> assert false (* Does not deal with universes, but only with Set/Type distinction *) let type_of_inductive_knowing_conclusion env mip conclty = match mip.mind_arity with | Monomorphic s -> s.mind_user_arity | Polymorphic ar -> let _,scl = Reduction.dest_arity env conclty in let ctx = List.rev mip.mind_arity_ctxt in let ctx = instantiate_universes env scl ar.poly_level (ctx,ar.poly_param_levels) in mkArity (List.rev ctx,scl) (***********************************************) (* Guard condition *) (* A function which checks that a term well typed verifies both syntactic conditions *) let control_only_guard env c = let check_fix_cofix e c = match kind_of_term c with | CoFix (_,(_,_,_) as cofix) -> Inductive.check_cofix e cofix | Fix (_,(_,_,_) as fix) -> Inductive.check_fix e fix | _ -> () in let rec iter env c = check_fix_cofix env c; iter_constr_with_full_binders push_rel iter env c in iter env c let subst_inductive subst (kn,i as ind) = let kn' = Mod_subst.subst_ind subst kn in if kn == kn' then ind else (kn',i) coq-8.4pl4/pretyping/matching.mli0000644000175000017500000000755312326224777016163 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> patvar_map (** [extended_matches pat c] also returns the names of bound variables in [c] that matches the bound variables in [pat]; if several bound variables or metavariables have the same name, the metavariable, or else the rightmost bound variable, takes precedence *) val extended_matches : constr_pattern -> constr -> bound_ident_map * extended_patvar_map (** [is_matching pat c] just tells if [c] matches against [pat] *) val is_matching : constr_pattern -> constr -> bool (** [matches_conv env sigma] matches up to conversion in environment [(env,sigma)] when constants in pattern are concerned; it raises [PatternMatchingFailure] if not matchable; bindings are given in increasing order based on the numbers given in the pattern *) val matches_conv :env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map (** The type of subterm matching results: a substitution + a context (whose hole is denoted with [special_meta]) + a continuation that either returns the next matching subterm or raise PatternMatchingFailure *) type subterm_matching_result = (bound_ident_map * patvar_map) * constr * (unit -> subterm_matching_result) (** [match_subterm n pat c] returns the substitution and the context corresponding to the first **closed** subterm of [c] matching [pat], and a continuation that looks for the next matching subterm. It raises PatternMatchingFailure if no subterm matches the pattern *) val match_subterm : constr_pattern -> constr -> subterm_matching_result (** [match_appsubterm pat c] returns the substitution and the context corresponding to the first **closed** subterm of [c] matching [pat], considering application contexts as well. It also returns a continuation that looks for the next matching subterm. It raises PatternMatchingFailure if no subterm matches the pattern *) val match_appsubterm : constr_pattern -> constr -> subterm_matching_result (** [match_subterm_gen] calls either [match_subterm] or [match_appsubterm] *) val match_subterm_gen : bool (** true = with app context *) -> constr_pattern -> constr -> subterm_matching_result (** [is_matching_appsubterm pat c] tells if a subterm of [c] matches against [pat] taking partial subterms into consideration *) val is_matching_appsubterm : ?closed:bool -> constr_pattern -> constr -> bool (** [is_matching_conv env sigma pat c] tells if [c] matches against [pat] up to conversion for constants in patterns *) val is_matching_conv : env -> Evd.evar_map -> constr_pattern -> constr -> bool coq-8.4pl4/pretyping/cbv.mli0000644000175000017500000000402712326224777015134 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* env -> Evd.evar_map -> cbv_infos val cbv_norm : cbv_infos -> constr -> constr (*********************************************************************** i This is for cbv debug *) type cbv_value = | VAL of int * constr | STACK of int * cbv_value * cbv_stack | CBN of constr * cbv_value subs | LAM of int * (name * constr) list * constr * cbv_value subs | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array | CONSTR of constructor * cbv_value array and cbv_stack = | TOP | APP of cbv_value array * cbv_stack | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack val shift_value : int -> cbv_value -> cbv_value val stack_app : cbv_value array -> cbv_stack -> cbv_stack val strip_appl : cbv_value -> cbv_stack -> cbv_value * cbv_stack (** recursive functions... *) val cbv_stack_term : cbv_infos -> cbv_stack -> cbv_value subs -> constr -> cbv_value val cbv_norm_term : cbv_infos -> cbv_value subs -> constr -> constr val norm_head : cbv_infos -> cbv_value subs -> constr -> cbv_stack -> cbv_value * cbv_stack val apply_stack : cbv_infos -> constr -> cbv_stack -> constr val cbv_norm_value : cbv_infos -> cbv_value -> constr (** End of cbv debug section i*) coq-8.4pl4/pretyping/cbv.ml0000644000175000017500000003342012326224777014762 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [S.c]b * This corresponds to the usual strategy of weak reduction * FIXP(op,bd,S,args) is the fixpoint (Fix or Cofix) of bodies bd under * the bindings S, and then applied to args. Here again, * weak reduction. * CONSTR(c,args) is the constructor [c] applied to [args]. * *) type cbv_value = | VAL of int * constr | STACK of int * cbv_value * cbv_stack | CBN of constr * cbv_value subs | LAM of int * (name * constr) list * constr * cbv_value subs | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array | CONSTR of constructor * cbv_value array (* type of terms with a hole. This hole can appear only under App or Case. * TOP means the term is considered without context * APP(v,stk) means the term is applied to v, and then the context stk * (v.0 is the first argument). * this corresponds to the application stack of the KAM. * The members of l are values: we evaluate arguments before calling the function. * CASE(t,br,pat,S,stk) means the term is in a case (which is himself in stk * t is the type of the case and br are the branches, all of them under * the subs S, pat is information on the patterns of the Case * (Weak reduction: we propagate the sub only when the selected branch * is determined) * * Important remark: the APPs should be collapsed: * (APP (l,(APP ...))) forbidden *) and cbv_stack = | TOP | APP of cbv_value array * cbv_stack | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack (* les vars pourraient etre des constr, cela permet de retarder les lift: utile ?? *) (* relocation of a value; used when a value stored in a context is expanded * in a larger context. e.g. [%k (S.t)](k+1) --> [^k]t (t is shifted of k) *) let rec shift_value n = function | VAL (k,t) -> VAL (k+n,t) | STACK(k,v,stk) -> STACK(k+n,v,stk) | CBN (t,s) -> CBN(t,subs_shft(n,s)) | LAM (nlams,ctxt,b,s) -> LAM (nlams,ctxt,b,subs_shft (n,s)) | FIXP (fix,s,args) -> FIXP (fix,subs_shft (n,s), Array.map (shift_value n) args) | COFIXP (cofix,s,args) -> COFIXP (cofix,subs_shft (n,s), Array.map (shift_value n) args) | CONSTR (c,args) -> CONSTR (c, Array.map (shift_value n) args) let shift_value n v = if n = 0 then v else shift_value n v (* Contracts a fixpoint: given a fixpoint and a bindings, * returns the corresponding fixpoint body, and the bindings in which * it should be evaluated: its first variables are the fixpoint bodies * (S, (fix Fi {F0 := T0 .. Fn-1 := Tn-1})) * -> (S. [S]F0 . [S]F1 ... . [S]Fn-1, Ti) *) let contract_fixp env ((reci,i),(_,_,bds as bodies)) = let make_body j = FIXP(((reci,j),bodies), env, [||]) in let n = Array.length bds in subs_cons(Array.init n make_body, env), bds.(i) let contract_cofixp env (i,(_,_,bds as bodies)) = let make_body j = COFIXP((j,bodies), env, [||]) in let n = Array.length bds in subs_cons(Array.init n make_body, env), bds.(i) let make_constr_ref n = function | RelKey p -> mkRel (n+p) | VarKey id -> mkVar id | ConstKey cst -> mkConst cst (* Adds an application list. Collapse APPs! *) let stack_app appl stack = if Array.length appl = 0 then stack else match stack with | APP(args,stk) -> APP(Array.append appl args,stk) | _ -> APP(appl, stack) let rec stack_concat stk1 stk2 = match stk1 with TOP -> stk2 | APP(v,stk1') -> APP(v,stack_concat stk1' stk2) | CASE(c,b,i,s,stk1') -> CASE(c,b,i,s,stack_concat stk1' stk2) (* merge stacks when there is no shifts in between *) let mkSTACK = function v, TOP -> v | STACK(0,v0,stk0), stk -> STACK(0,v0,stack_concat stk0 stk) | v,stk -> STACK(0,v,stk) (* Change: zeta reduction cannot be avoided in CBV *) open RedFlags let red_set_ref flags = function | RelKey _ -> red_set flags fDELTA | VarKey id -> red_set flags (fVAR id) | ConstKey sp -> red_set flags (fCONST sp) (* Transfer application lists from a value to the stack * useful because fixpoints may be totally applied in several times. * On the other hand, irreductible atoms absorb the full stack. *) let strip_appl head stack = match head with | FIXP (fix,env,app) -> (FIXP(fix,env,[||]), stack_app app stack) | COFIXP (cofix,env,app) -> (COFIXP(cofix,env,[||]), stack_app app stack) | CONSTR (c,app) -> (CONSTR(c,[||]), stack_app app stack) | _ -> (head, stack) (* Tests if fixpoint reduction is possible. *) let fixp_reducible flgs ((reci,i),_) stk = if red_set flgs fIOTA then match stk with | APP(appl,_) -> Array.length appl > reci.(i) && (match appl.(reci.(i)) with CONSTR _ -> true | _ -> false) | _ -> false else false let cofixp_reducible flgs _ stk = if red_set flgs fIOTA then match stk with | (CASE _ | APP(_,CASE _)) -> true | _ -> false else false (* The main recursive functions * * Go under applications and cases (pushed in the stack), expand head * constants or substitued de Bruijn, and try to make appear a * constructor, a lambda or a fixp in the head. If not, it is a value * and is completely computed here. The head redexes are NOT reduced: * the function returns the pair of a cbv_value and its stack. * * Invariant: if the result of norm_head is CONSTR or (CO)FIXP, it last * argument is []. Because we must put all the applied terms in the * stack. *) let rec norm_head info env t stack = (* no reduction under binders *) match kind_of_term t with (* stack grows (remove casts) *) | App (head,args) -> (* Applied terms are normalized immediately; they could be computed when getting out of the stack *) let nargs = Array.map (cbv_stack_term info TOP env) args in norm_head info env head (stack_app nargs stack) | Case (ci,p,c,v) -> norm_head info env c (CASE(p,v,ci,env,stack)) | Cast (ct,_,_) -> norm_head info env ct stack (* constants, axioms * the first pattern is CRUCIAL, n=0 happens very often: * when reducing closed terms, n is always 0 *) | Rel i -> (match expand_rel i env with | Inl (0,v) -> strip_appl v stack | Inl (n,v) -> strip_appl (shift_value n v) stack | Inr (n,None) -> (VAL(0, mkRel n), stack) | Inr (n,Some p) -> norm_head_ref (n-p) info env stack (RelKey p)) | Var id -> norm_head_ref 0 info env stack (VarKey id) | Const sp -> norm_head_ref 0 info env stack (ConstKey sp) | LetIn (_, b, _, c) -> (* zeta means letin are contracted; delta without zeta means we *) (* allow bindings but leave let's in place *) if red_set (info_flags info) fZETA then (* New rule: for Cbv, Delta does not apply to locally bound variables or red_set (info_flags info) fDELTA *) let env' = subs_cons ([|cbv_stack_term info TOP env b|],env) in norm_head info env' c stack else (CBN(t,env), stack) (* Considérer une coupure commutative ? *) | Evar ev -> (match evar_value info ev with Some c -> norm_head info env c stack | None -> (VAL(0, t), stack)) (* non-neutral cases *) | Lambda _ -> let ctxt,b = decompose_lam t in (LAM(List.length ctxt, List.rev ctxt,b,env), stack) | Fix fix -> (FIXP(fix,env,[||]), stack) | CoFix cofix -> (COFIXP(cofix,env,[||]), stack) | Construct c -> (CONSTR(c, [||]), stack) (* neutral cases *) | (Sort _ | Meta _ | Ind _) -> (VAL(0, t), stack) | Prod _ -> (CBN(t,env), stack) and norm_head_ref k info env stack normt = if red_set_ref (info_flags info) normt then match ref_value_cache info normt with | Some body -> strip_appl (shift_value k body) stack | None -> (VAL(0,make_constr_ref k normt),stack) else (VAL(0,make_constr_ref k normt),stack) (* cbv_stack_term performs weak reduction on constr t under the subs * env, with context stack, i.e. ([env]t stack). First computes weak * head normal form of t and checks if a redex appears with the stack. * If so, recursive call to reach the real head normal form. If not, * we build a value. *) and cbv_stack_term info stack env t = match norm_head info env t stack with (* a lambda meets an application -> BETA *) | (LAM (nlams,ctxt,b,env), APP (args, stk)) when red_set (info_flags info) fBETA -> let nargs = Array.length args in if nargs == nlams then cbv_stack_term info stk (subs_cons(args,env)) b else if nlams < nargs then let env' = subs_cons(Array.sub args 0 nlams, env) in let eargs = Array.sub args nlams (nargs-nlams) in cbv_stack_term info (APP(eargs,stk)) env' b else let ctxt' = list_skipn nargs ctxt in LAM(nlams-nargs,ctxt', b, subs_cons(args,env)) (* a Fix applied enough -> IOTA *) | (FIXP(fix,env,[||]), stk) when fixp_reducible (info_flags info) fix stk -> let (envf,redfix) = contract_fixp env fix in cbv_stack_term info stk envf redfix (* constructor guard satisfied or Cofix in a Case -> IOTA *) | (COFIXP(cofix,env,[||]), stk) when cofixp_reducible (info_flags info) cofix stk-> let (envf,redfix) = contract_cofixp env cofix in cbv_stack_term info stk envf redfix (* constructor in a Case -> IOTA *) | (CONSTR((sp,n),[||]), APP(args,CASE(_,br,ci,env,stk))) when red_set (info_flags info) fIOTA -> let cargs = Array.sub args ci.ci_npar (Array.length args - ci.ci_npar) in cbv_stack_term info (stack_app cargs stk) env br.(n-1) (* constructor of arity 0 in a Case -> IOTA *) | (CONSTR((_,n),[||]), CASE(_,br,_,env,stk)) when red_set (info_flags info) fIOTA -> cbv_stack_term info stk env br.(n-1) (* may be reduced later by application *) | (FIXP(fix,env,[||]), APP(appl,TOP)) -> FIXP(fix,env,appl) | (COFIXP(cofix,env,[||]), APP(appl,TOP)) -> COFIXP(cofix,env,appl) | (CONSTR(c,[||]), APP(appl,TOP)) -> CONSTR(c,appl) (* definitely a value *) | (head,stk) -> mkSTACK(head, stk) (* When we are sure t will never produce a redex with its stack, we * normalize (even under binders) the applied terms and we build the * final term *) let rec apply_stack info t = function | TOP -> t | APP (args,st) -> apply_stack info (mkApp(t,Array.map (cbv_norm_value info) args)) st | CASE (ty,br,ci,env,st) -> apply_stack info (mkCase (ci, cbv_norm_term info env ty, t, Array.map (cbv_norm_term info env) br)) st (* performs the reduction on a constr, and returns a constr *) and cbv_norm_term info env t = (* reduction under binders *) cbv_norm_value info (cbv_stack_term info TOP env t) (* reduction of a cbv_value to a constr *) and cbv_norm_value info = function (* reduction under binders *) | VAL (n,t) -> lift n t | STACK (0,v,stk) -> apply_stack info (cbv_norm_value info v) stk | STACK (n,v,stk) -> lift n (apply_stack info (cbv_norm_value info v) stk) | CBN(t,env) -> map_constr_with_binders subs_lift (cbv_norm_term info) env t | LAM (n,ctxt,b,env) -> let nctxt = list_map_i (fun i (x,ty) -> (x,cbv_norm_term info (subs_liftn i env) ty)) 0 ctxt in compose_lam (List.rev nctxt) (cbv_norm_term info (subs_liftn n env) b) | FIXP ((lij,(names,lty,bds)),env,args) -> mkApp (mkFix (lij, (names, Array.map (cbv_norm_term info env) lty, Array.map (cbv_norm_term info (subs_liftn (Array.length lty) env)) bds)), Array.map (cbv_norm_value info) args) | COFIXP ((j,(names,lty,bds)),env,args) -> mkApp (mkCoFix (j, (names,Array.map (cbv_norm_term info env) lty, Array.map (cbv_norm_term info (subs_liftn (Array.length lty) env)) bds)), Array.map (cbv_norm_value info) args) | CONSTR (c,args) -> mkApp(mkConstruct c, Array.map (cbv_norm_value info) args) (* with profiling *) let cbv_norm infos constr = with_stats (lazy (cbv_norm_term infos (subs_id 0) constr)) type cbv_infos = cbv_value infos (* constant bodies are normalized at the first expansion *) let create_cbv_infos flgs env sigma = create (fun old_info c -> cbv_stack_term old_info TOP (subs_id 0) c) flgs env (Reductionops.safe_evar_value sigma) coq-8.4pl4/pretyping/indrec.mli0000644000175000017500000000451312326224777015626 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* evar_map -> inductive -> dep_flag -> sorts_family -> constr (** Build a dependent case elimination predicate unless type is in Prop *) val build_case_analysis_scheme_default : env -> evar_map -> inductive -> sorts_family -> constr (** Builds a recursive induction scheme (Peano-induction style) in the same sort family as the inductive family; it is dependent if not in Prop *) val build_induction_scheme : env -> evar_map -> inductive -> dep_flag -> sorts_family -> constr (** Builds mutual (recursive) induction schemes *) val build_mutual_induction_scheme : env -> evar_map -> (inductive * dep_flag * sorts_family) list -> constr list (** Scheme combinators *) (** [modify_sort_scheme s n c] modifies the quantification sort of scheme c whose predicate is abstracted at position [n] of [c] *) val modify_sort_scheme : sorts -> int -> constr -> constr (** [weaken_sort_scheme s n c t] derives by subtyping from [c:t] whose conclusion is quantified on [Type] at position [n] of [t] a scheme quantified on sort [s] *) val weaken_sort_scheme : sorts -> int -> constr -> types -> constr * types (** Recursor names utilities *) val lookup_eliminator : inductive -> sorts_family -> constr val elimination_suffix : sorts_family -> string val make_elimination_ident : identifier -> sorts_family -> identifier val case_suffix : string coq-8.4pl4/pretyping/evarutil.ml0000644000175000017500000024005412326224777016046 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (match existential_opt_value sigma ev with | None -> raise (Uninstantiated_evar evk) | Some c -> flush_and_check_evars sigma c) | _ -> map_constr (flush_and_check_evars sigma) c let nf_evar = Pretype_errors.nf_evar let j_nf_evar = Pretype_errors.j_nf_evar let jl_nf_evar = Pretype_errors.jl_nf_evar let jv_nf_evar = Pretype_errors.jv_nf_evar let tj_nf_evar = Pretype_errors.tj_nf_evar let nf_named_context_evar sigma ctx = Sign.map_named_context (Reductionops.nf_evar sigma) ctx let nf_rel_context_evar sigma ctx = Sign.map_rel_context (Reductionops.nf_evar sigma) ctx let nf_env_evar sigma env = let nc' = nf_named_context_evar sigma (Environ.named_context env) in let rel' = nf_rel_context_evar sigma (Environ.rel_context env) in push_rel_context rel' (reset_with_named_context (val_of_named_context nc') env) let nf_evar_info evc info = { info with evar_concl = Reductionops.nf_evar evc info.evar_concl; evar_hyps = map_named_val (Reductionops.nf_evar evc) info.evar_hyps; evar_body = match info.evar_body with | Evar_empty -> Evar_empty | Evar_defined c -> Evar_defined (Reductionops.nf_evar evc c) } let nf_evars evm = Evd.fold (fun ev evi evm' -> Evd.add evm' ev (nf_evar_info evm evi)) evm Evd.empty let nf_evars_undefined evm = Evd.fold_undefined (fun ev evi evm' -> Evd.add evm' ev (nf_evar_info evm evi)) evm (defined_evars evm) let nf_evar_map evd = Evd.evars_reset_evd (nf_evars evd) evd let nf_evar_map_undefined evd = Evd.evars_reset_evd (nf_evars_undefined evd) evd (*-------------------*) (* Auxiliary functions for the conversion algorithms modulo evars *) let has_undefined_evars_or_sorts evd t = let rec has_ev t = match kind_of_term t with | Evar (ev,args) -> (match evar_body (Evd.find evd ev) with | Evar_defined c -> has_ev c; Array.iter has_ev args | Evar_empty -> raise NotInstantiatedEvar) | Sort s when is_sort_variable evd s -> raise Not_found | _ -> iter_constr has_ev t in try let _ = has_ev t in false with (Not_found | NotInstantiatedEvar) -> true let is_ground_term evd t = not (has_undefined_evars_or_sorts evd t) let is_ground_env evd env = let is_ground_decl = function (_,Some b,_) -> is_ground_term evd b | _ -> true in List.for_all is_ground_decl (rel_context env) && List.for_all is_ground_decl (named_context env) (* Memoization is safe since evar_map and environ are applicative structures *) let is_ground_env = memo1_2 is_ground_env (* Return the head evar if any *) exception NoHeadEvar let head_evar = let rec hrec c = match kind_of_term c with | Evar (evk,_) -> evk | Case (_,_,c,_) -> hrec c | App (c,_) -> hrec c | Cast (c,_,_) -> hrec c | _ -> raise NoHeadEvar in hrec (* Expand head evar if any (currently consider only applications but I guess it should consider Case too) *) let whd_head_evar_stack sigma c = let rec whrec (c, l as s) = match kind_of_term c with | Evar (evk,args as ev) when Evd.is_defined sigma evk -> whrec (existential_value sigma ev, l) | Cast (c,_,_) -> whrec (c, l) | App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l) | _ -> s in whrec (c, []) let whd_head_evar sigma c = applist (whd_head_evar_stack sigma c) let noccur_evar env evd evk c = let rec occur_rec k c = match kind_of_term c with | Evar (evk',args' as ev') -> (match safe_evar_value evd ev' with | Some c -> occur_rec k c | None -> if evk = evk' then raise Occur else Array.iter (occur_rec k) args') | Rel i when i > k -> (match pi2 (Environ.lookup_rel (i-k) env) with | None -> () | Some b -> occur_rec k (lift i b)) | _ -> iter_constr_with_binders succ occur_rec k c in try occur_rec 0 c; true with Occur -> false let normalize_evar evd ev = match kind_of_term (whd_evar evd (mkEvar ev)) with | Evar (evk,args) -> (evk,args) | _ -> assert false (**********************) (* Creating new metas *) (**********************) (* Generator of metavariables *) let new_meta = let meta_ctr = ref 0 in Summary.declare_summary "meta counter" { Summary.freeze_function = (fun () -> !meta_ctr); Summary.unfreeze_function = (fun n -> meta_ctr := n); Summary.init_function = (fun () -> meta_ctr := 0) }; fun () -> incr meta_ctr; !meta_ctr let mk_new_meta () = mkMeta(new_meta()) let collect_evars emap c = let rec collrec acc c = match kind_of_term c with | Evar (evk,_) -> if Evd.is_undefined emap evk then evk::acc else (* No recursion on the evar instantiation *) acc | _ -> fold_constr collrec acc c in list_uniquize (collrec [] c) let push_dependent_evars sigma emap = Evd.fold_undefined (fun ev {evar_concl = ccl} (sigma',emap') -> List.fold_left (fun (sigma',emap') ev -> (Evd.add sigma' ev (Evd.find emap' ev),Evd.remove emap' ev)) (sigma',emap') (collect_evars emap' ccl)) emap (sigma,emap) let push_duplicated_evars sigma emap c = let rec collrec (one,(sigma,emap) as acc) c = match kind_of_term c with | Evar (evk,_) when not (Evd.mem sigma evk) -> if List.mem evk one then let sigma' = Evd.add sigma evk (Evd.find emap evk) in let emap' = Evd.remove emap evk in (one,(sigma',emap')) else (evk::one,(sigma,emap)) | _ -> fold_constr collrec acc c in snd (collrec ([],(sigma,emap)) c) (* replaces a mapping of existentials into a mapping of metas. Problem if an evar appears in the type of another one (pops anomaly) *) let evars_to_metas sigma (emap, c) = let emap = nf_evar_map_undefined emap in let sigma',emap' = push_dependent_evars sigma emap in let sigma',emap' = push_duplicated_evars sigma' emap' c in (* if an evar has been instantiated in [emap] (as part of typing [c]) then it is instantiated in [sigma]. *) let repair_evars sigma emap = fold_undefined begin fun ev _ sigma' -> try let info = find emap ev in match evar_body info with | Evar_empty -> sigma' | Evar_defined body -> define ev body sigma' with Not_found -> sigma' end sigma sigma in let sigma' = repair_evars sigma' emap in let change_exist evar = let ty = nf_betaiota emap (existential_type emap evar) in let n = new_meta() in mkCast (mkMeta n, DEFAULTcast, ty) in let rec replace c = match kind_of_term c with | Evar (evk,_ as ev) when Evd.mem emap' evk -> change_exist ev | _ -> map_constr replace c in (sigma', replace c) (* The list of non-instantiated existential declarations (order is important) *) let non_instantiated sigma = let listev = Evd.undefined_list sigma in List.map (fun (ev,evi) -> (ev,nf_evar_info sigma evi)) listev (************************) (* Manipulating filters *) (************************) let apply_subfilter filter subfilter = fst (List.fold_right (fun oldb (l,filter) -> if oldb then List.hd filter::l,List.tl filter else (false::l,filter)) filter ([], List.rev subfilter)) let extract_subfilter initial_filter refined_filter = snd (list_filter2 (fun b1 b2 -> b1) (initial_filter,refined_filter)) (**********************) (* Creating new evars *) (**********************) (* Generator of existential names *) let new_untyped_evar = let evar_ctr = ref 0 in Summary.declare_summary "evar counter" { Summary.freeze_function = (fun () -> !evar_ctr); Summary.unfreeze_function = (fun n -> evar_ctr := n); Summary.init_function = (fun () -> evar_ctr := 0) }; fun () -> incr evar_ctr; existential_of_int !evar_ctr (*------------------------------------* * functional operations on evar sets * *------------------------------------*) (* [push_rel_context_to_named_context] builds the defining context and the * initial instance of an evar. If the evar is to be used in context * * Gamma = a1 ... an xp ... x1 * \- named part -/ \- de Bruijn part -/ * * then the x1...xp are turned into variables so that the evar is declared in * context * * a1 ... an xp ... x1 * \----------- named part ------------/ * * but used applied to the initial instance "a1 ... an Rel(p) ... Rel(1)" * so that ev[a1:=a1 ... an:=an xp:=Rel(p) ... x1:=Rel(1)] is correctly typed * in context Gamma. * * Remark 1: The instance is reverted in practice (i.e. Rel(1) comes first) * Remark 2: If some of the ai or xj are definitions, we keep them in the * instance. This is necessary so that no unfolding of local definitions * happens when inferring implicit arguments (consider e.g. the problem * "x:nat; x':=x; f:forall y, y=y -> Prop |- f _ (refl_equal x')" which * produces the equation "?y[x,x']=?y[x,x']" =? "x'=x'": we want * the hole to be instantiated by x', not by x (which would have been * the case in [invert_definition] if x' had disappeared from the instance). * Note that at any time, if, in some context env, the instance of * declaration x:A is t and the instance of definition x':=phi(x) is u, then * we have the property that u and phi(t) are convertible in env. *) let push_rel_context_to_named_context env typ = (* compute the instances relative to the named context and rel_context *) let ids = List.map pi1 (named_context env) in let inst_vars = List.map mkVar ids in let inst_rels = List.rev (rel_list 0 (nb_rel env)) in (* move the rel context to a named context and extend the named instance *) (* with vars of the rel context *) (* We do keep the instances corresponding to local definition (see above) *) let (subst, _, env) = Sign.fold_rel_context (fun (na,c,t) (subst, avoid, env) -> let id = next_name_away na avoid in let d = (id,Option.map (substl subst) c,substl subst t) in (mkVar id :: subst, id::avoid, push_named d env)) (rel_context env) ~init:([], ids, env) in (named_context_val env, substl subst typ, inst_rels@inst_vars, subst) (*------------------------------------* * Entry points to define new evars * *------------------------------------*) let default_source = (dummy_loc,InternalHole) let new_pure_evar evd sign ?(src=default_source) ?filter ?candidates typ = let newevk = new_untyped_evar() in let evd = evar_declare sign newevk typ ~src ?filter ?candidates evd in (evd,newevk) let new_evar_instance sign evd typ ?src ?filter ?candidates instance = assert (not !Flags.debug || list_distinct (ids_of_named_context (named_context_of_val sign))); let evd,newevk = new_pure_evar evd sign ?src ?filter ?candidates typ in (evd,mkEvar (newevk,Array.of_list instance)) (* [new_evar] declares a new existential in an env env with type typ *) (* Converting the env into the sign of the evar to define *) let new_evar evd env ?src ?filter ?candidates typ = let sign,typ',instance,subst = push_rel_context_to_named_context env typ in let candidates = Option.map (List.map (substl subst)) candidates in let instance = match filter with | None -> instance | Some filter -> list_filter_with filter instance in new_evar_instance sign evd typ' ?src ?filter ?candidates instance let new_type_evar ?src ?filter evd env = let evd', s = new_sort_variable evd in new_evar evd' env ?src ?filter (mkSort s) (* The same using side-effect *) let e_new_evar evdref env ?(src=(dummy_loc,InternalHole)) ?filter ?candidates ty = let (evd',ev) = new_evar !evdref env ~src:src ?filter ?candidates ty in evdref := evd'; ev (*------------------------------------* * Restricting existing evars * *------------------------------------*) let restrict_evar_key evd evk filter candidates = if filter = None && candidates = None then evd,evk else let evi = Evd.find_undefined evd evk in let oldfilter = evar_filter evi in if filter = Some oldfilter && candidates = None then evd,evk else let filter = match filter with | None -> evar_filter evi | Some filter -> filter in let candidates = match candidates with None -> evi.evar_candidates | _ -> candidates in let ccl = evi.evar_concl in let sign = evar_hyps evi in let src = evi.evar_source in let evd,newevk = new_pure_evar evd sign ccl ~src ~filter ?candidates in let ctxt = snd (list_filter2 (fun b c -> b) (filter,evar_context evi)) in let id_inst = Array.of_list (List.map (fun (id,_,_) -> mkVar id) ctxt) in Evd.define evk (mkEvar(newevk,id_inst)) evd,newevk (* Restrict an applied evar and returns its restriction in the same context *) let restrict_applied_evar evd (evk,argsv) filter candidates = let evd,newevk = restrict_evar_key evd evk filter candidates in let newargsv = match filter with | None -> (* optim *) argsv | Some filter -> let evi = Evd.find evd evk in let subfilter = extract_subfilter (evar_filter evi) filter in array_filter_with subfilter argsv in evd,(newevk,newargsv) (* Restrict an evar in the current evar_map *) let restrict_evar evd evk filter candidates = fst (restrict_evar_key evd evk filter candidates) (* Restrict an evar in the current evar_map *) let restrict_instance evd evk filter argsv = match filter with None -> argsv | Some filter -> let evi = Evd.find evd evk in array_filter_with (extract_subfilter (evar_filter evi) filter) argsv (* This assumes an evar with identity instance and generalizes it over only the De Bruijn part of the context *) let generalize_evar_over_rels sigma (ev,args) = let evi = Evd.find sigma ev in let sign = named_context_of_val evi.evar_hyps in List.fold_left2 (fun (c,inst as x) a d -> if isRel a then (mkNamedProd_or_LetIn d c,a::inst) else x) (evi.evar_concl,[]) (Array.to_list args) sign (***************************************) (* Managing chains of local definitons *) (***************************************) (* Expand rels and vars that are bound to other rels or vars so that dependencies in variables are canonically associated to the most ancient variable in its family of aliased variables *) let compute_var_aliases sign = List.fold_right (fun (id,b,c) aliases -> match b with | Some t -> (match kind_of_term t with | Var id' -> let aliases_of_id = try Idmap.find id' aliases with Not_found -> [] in Idmap.add id (aliases_of_id@[t]) aliases | _ -> Idmap.add id [t] aliases) | None -> aliases) sign Idmap.empty let compute_rel_aliases var_aliases rels = snd (List.fold_right (fun (_,b,t) (n,aliases) -> (n-1, match b with | Some t -> (match kind_of_term t with | Var id' -> let aliases_of_n = try Idmap.find id' var_aliases with Not_found -> [] in Intmap.add n (aliases_of_n@[t]) aliases | Rel p -> let aliases_of_n = try Intmap.find (p+n) aliases with Not_found -> [] in Intmap.add n (aliases_of_n@[mkRel (p+n)]) aliases | _ -> Intmap.add n [lift n t] aliases) | None -> aliases)) rels (List.length rels,Intmap.empty)) let make_alias_map env = (* We compute the chain of aliases for each var and rel *) let var_aliases = compute_var_aliases (named_context env) in let rel_aliases = compute_rel_aliases var_aliases (rel_context env) in (var_aliases,rel_aliases) let lift_aliases n (var_aliases,rel_aliases as aliases) = if n = 0 then aliases else (var_aliases, Intmap.fold (fun p l -> Intmap.add (p+n) (List.map (lift n) l)) rel_aliases Intmap.empty) let get_alias_chain_of aliases x = match kind_of_term x with | Rel n -> (try Intmap.find n (snd aliases) with Not_found -> []) | Var id -> (try Idmap.find id (fst aliases) with Not_found -> []) | _ -> [] let normalize_alias_opt aliases x = match get_alias_chain_of aliases x with | [] -> None | a::_ when isRel a or isVar a -> Some a | [_] -> None | _::a::_ -> Some a let normalize_alias aliases x = match normalize_alias_opt aliases x with | Some a -> a | None -> x let normalize_alias_var var_aliases id = destVar (normalize_alias (var_aliases,Intmap.empty) (mkVar id)) let extend_alias (_,b,_) (var_aliases,rel_aliases) = let rel_aliases = Intmap.fold (fun n l -> Intmap.add (n+1) (List.map (lift 1) l)) rel_aliases Intmap.empty in let rel_aliases = match b with | Some t -> (match kind_of_term t with | Var id' -> let aliases_of_binder = try Idmap.find id' var_aliases with Not_found -> [] in Intmap.add 1 (aliases_of_binder@[t]) rel_aliases | Rel p -> let aliases_of_binder = try Intmap.find (p+1) rel_aliases with Not_found -> [] in Intmap.add 1 (aliases_of_binder@[mkRel (p+1)]) rel_aliases | _ -> Intmap.add 1 [lift 1 t] rel_aliases) | None -> rel_aliases in (var_aliases, rel_aliases) let expand_alias_once aliases x = match get_alias_chain_of aliases x with | [] -> None | l -> Some (list_last l) let rec expansions_of_var aliases x = match get_alias_chain_of aliases x with | [] -> [x] | a::_ as l when isRel a || isVar a -> x :: List.rev l | _::l -> x :: List.rev l let expansion_of_var aliases x = match get_alias_chain_of aliases x with | [] -> x | a::_ -> a let rec expand_vars_in_term_using aliases t = match kind_of_term t with | Rel _ | Var _ -> normalize_alias aliases t | _ -> map_constr_with_full_binders extend_alias expand_vars_in_term_using aliases t let expand_vars_in_term env = expand_vars_in_term_using (make_alias_map env) let free_vars_and_rels_up_alias_expansion aliases c = let acc1 = ref Intset.empty and acc2 = ref Idset.empty in let cache_rel = ref Intset.empty and cache_var = ref Idset.empty in let is_in_cache depth = function | Rel n -> Intset.mem (n-depth) !cache_rel | Var s -> Idset.mem s !cache_var | _ -> false in let put_in_cache depth = function | Rel n -> cache_rel := Intset.add (n-depth) !cache_rel | Var s -> cache_var := Idset.add s !cache_var | _ -> () in let rec frec (aliases,depth) c = match kind_of_term c with | Rel _ | Var _ as ck -> if is_in_cache depth ck then () else begin put_in_cache depth ck; let c = expansion_of_var aliases c in match kind_of_term c with | Var id -> acc2 := Idset.add id !acc2 | Rel n -> if n >= depth+1 then acc1 := Intset.add (n-depth) !acc1 | _ -> frec (aliases,depth) c end | Const _ | Ind _ | Construct _ -> acc2 := List.fold_right Idset.add (vars_of_global (Global.env()) c) !acc2 | _ -> iter_constr_with_full_binders (fun d (aliases,depth) -> (extend_alias d aliases,depth+1)) frec (aliases,depth) c in frec (aliases,0) c; (!acc1,!acc2) (************************************) (* Removing a dependency in an evar *) (************************************) type clear_dependency_error = | OccurHypInSimpleClause of identifier option | EvarTypingBreak of existential exception ClearDependencyError of identifier * clear_dependency_error open Store.Field let cleared = Store.field () let rec check_and_clear_in_constr evdref err ids c = (* returns a new constr where all the evars have been 'cleaned' (ie the hypotheses ids have been removed from the contexts of evars) *) let check id' = if List.mem id' ids then raise (ClearDependencyError (id',err)) in match kind_of_term c with | Var id' -> check id'; c | ( Const _ | Ind _ | Construct _ ) -> let vars = Environ.vars_of_global (Global.env()) c in List.iter check vars; c | Evar (evk,l as ev) -> if Evd.is_defined !evdref evk then (* If evk is already defined we replace it by its definition *) let nc = whd_evar !evdref c in (check_and_clear_in_constr evdref err ids nc) else (* We check for dependencies to elements of ids in the evar_info corresponding to e and in the instance of arguments. Concurrently, we build a new evar corresponding to e where hypotheses of ids have been removed *) let evi = Evd.find_undefined !evdref evk in let ctxt = Evd.evar_filtered_context evi in let (nhyps,nargs,rids) = List.fold_right2 (fun (rid,ob,c as h) a (hy,ar,ri) -> (* Check if some id to clear occurs in the instance a of rid in ev and remember the dependency *) match List.filter (fun id -> List.mem id ids) (Idset.elements (collect_vars a)) with | id :: _ -> (hy,ar,(rid,id)::ri) | _ -> (* Check if some rid to clear in the context of ev has dependencies in another hyp of the context of ev and transitively remember the dependency *) match List.filter (fun (id,_) -> occur_var_in_decl (Global.env()) id h) ri with | (_,id') :: _ -> (hy,ar,(rid,id')::ri) | _ -> (* No dependency at all, we can keep this ev's context hyp *) (h::hy,a::ar,ri)) ctxt (Array.to_list l) ([],[],[]) in (* Check if some rid to clear in the context of ev has dependencies in the type of ev and adjust the source of the dependency *) let nconcl = try check_and_clear_in_constr evdref (EvarTypingBreak ev) (List.map fst rids) (evar_concl evi) with ClearDependencyError (rid,err) -> raise (ClearDependencyError (List.assoc rid rids,err)) in if rids = [] then c else begin let env = Sign.fold_named_context push_named nhyps ~init:(empty_env) in let ev'= e_new_evar evdref env ~src:(evar_source evk !evdref) nconcl in evdref := Evd.define evk ev' !evdref; let (evk',_) = destEvar ev' in (* spiwack: hacking session to mark the old [evk] as having been "cleared" *) let evi = Evd.find !evdref evk in let extra = evi.evar_extra in let extra' = cleared.set true extra in let evi' = { evi with evar_extra = extra' } in evdref := Evd.add !evdref evk evi' ; (* spiwack: /hacking session *) mkEvar(evk', Array.of_list nargs) end | _ -> map_constr (check_and_clear_in_constr evdref err ids) c let clear_hyps_in_evi evdref hyps concl ids = (* clear_hyps_in_evi erases hypotheses ids in hyps, checking if some hypothesis does not depend on a element of ids, and erases ids in the contexts of the evars occuring in evi *) let nconcl = check_and_clear_in_constr evdref (OccurHypInSimpleClause None) ids concl in let nhyps = let check_context (id,ob,c) = let err = OccurHypInSimpleClause (Some id) in (id, Option.map (check_and_clear_in_constr evdref err ids) ob, check_and_clear_in_constr evdref err ids c) in let check_value vk = match !vk with | VKnone -> vk | VKvalue (v,d) -> if (List.for_all (fun e -> not (Idset.mem e d)) ids) then (* v does depend on any of ids, it's ok *) vk else (* v depends on one of the cleared hyps: we forget the computed value *) ref VKnone in remove_hyps ids check_context check_value hyps in (nhyps,nconcl) (********************************) (* Managing pattern-unification *) (********************************) let rec expand_and_check_vars aliases = function | [] -> [] | a::l when isRel a or isVar a -> let a = expansion_of_var aliases a in if isRel a or isVar a then a :: expand_and_check_vars aliases l else raise Exit | _ -> raise Exit module Constrhash = Hashtbl.Make (struct type t = constr let equal = eq_constr let hash = hash_constr end) let rec constr_list_distinct l = let visited = Constrhash.create 23 in let rec loop = function | h::t -> if Constrhash.mem visited h then false else (Constrhash.add visited h h; loop t) | [] -> true in loop l let get_actual_deps aliases l t = if occur_meta_or_existential t then (* Probably no restrictions on allowed vars in presence of evars *) l else (* Probably strong restrictions coming from t being evar-closed *) let (fv_rels,fv_ids) = free_vars_and_rels_up_alias_expansion aliases t in List.filter (fun c -> match kind_of_term c with | Var id -> Idset.mem id fv_ids | Rel n -> Intset.mem n fv_rels | _ -> assert false) l let remove_instance_local_defs evd evk args = let evi = Evd.find evd evk in let rec aux = function | (_,Some _,_)::sign, a::args -> aux (sign,args) | (_,None,_)::sign, a::args -> a::aux (sign,args) | [], [] -> [] | _ -> assert false in aux (evar_filtered_context evi, args) (* Check if an applied evar "?X[args] l" is a Miller's pattern *) let find_unification_pattern_args env l t = if List.for_all (fun x -> isRel x || isVar x) l (* common failure case *) then let aliases = make_alias_map env in match (try Some (expand_and_check_vars aliases l) with Exit -> None) with | Some l as x when constr_list_distinct (get_actual_deps aliases l t) -> x | _ -> None else None let is_unification_pattern_meta env nb m l t = (* Variables from context and rels > nb are implicitly all there *) (* so we need to be a rel <= nb *) if List.for_all (fun x -> isRel x && destRel x <= nb) l then match find_unification_pattern_args env l t with | Some _ as x when not (dependent (mkMeta m) t) -> x | _ -> None else None let is_unification_pattern_evar env evd (evk,args) l t = if List.for_all (fun x -> isRel x || isVar x) l & noccur_evar env evd evk t then let args = remove_instance_local_defs evd evk (Array.to_list args) in let n = List.length args in match find_unification_pattern_args env (args @ l) t with | Some l -> Some (list_skipn n l) | _ -> None else None let is_unification_pattern_pure_evar env evd (evk,args) t = is_unification_pattern_evar env evd (evk,args) [] t <> None let is_unification_pattern (env,nb) evd f l t = match kind_of_term f with | Meta m -> is_unification_pattern_meta env nb m l t | Evar ev -> is_unification_pattern_evar env evd ev l t | _ -> None (* From a unification problem "?X l = c", build "\x1...xn.(term1 l2)" (pattern unification). It is assumed that l is made of rel's that are distinct and not bound to aliases. *) (* It is also assumed that c does not contain metas because metas *implicitly* depend on Vars but lambda abstraction will not reflect this dependency: ?X x = ?1 (?1 is a meta) will return \_.?1 while it should return \y. ?1{x\y} (non constant function if ?1 depends on x) (BB) *) let solve_pattern_eqn env l c = let c' = List.fold_right (fun a c -> let c' = subst_term (lift 1 a) (lift 1 c) in match kind_of_term a with (* Rem: if [a] links to a let-in, do as if it were an assumption *) | Rel n -> let d = map_rel_declaration (lift n) (lookup_rel n env) in mkLambda_or_LetIn d c' | Var id -> let d = lookup_named id env in mkNamedLambda_or_LetIn d c' | _ -> assert false) l c in (* Warning: we may miss some opportunity to eta-reduce more since c' is not in normal form *) whd_eta c' (*****************************************) (* Refining/solving unification problems *) (*****************************************) (* Knowing that [Gamma |- ev : T] and that [ev] is applied to [args], * [make_projectable_subst ev args] builds the substitution [Gamma:=args]. * If a variable and an alias of it are bound to the same instance, we skip * the alias (we just use eq_constr -- instead of conv --, since anyway, * only instances that are variables -- or evars -- are later considered; * morever, we can bet that similar instances came at some time from * the very same substitution. The removal of aliased duplicates is * useful to ensure the uniqueness of a projection. *) let make_projectable_subst aliases sigma evi args = let sign = evar_filtered_context evi in let evar_aliases = compute_var_aliases sign in let (_,full_subst,cstr_subst) = List.fold_right (fun (id,b,c) (args,all,cstrs) -> match b,args with | None, a::rest -> let a = whd_evar sigma a in let cstrs = let a',args = decompose_app_vect a in match kind_of_term a' with | Construct cstr -> let l = try Constrmap.find cstr cstrs with Not_found -> [] in Constrmap.add cstr ((args,id)::l) cstrs | _ -> cstrs in (rest,Idmap.add id [a,normalize_alias_opt aliases a,id] all,cstrs) | Some c, a::rest -> let a = whd_evar sigma a in (match kind_of_term c with | Var id' -> let idc = normalize_alias_var evar_aliases id' in let sub = try Idmap.find idc all with Not_found -> [] in if List.exists (fun (c,_,_) -> eq_constr a c) sub then (rest,all,cstrs) else (rest, Idmap.add idc ((a,normalize_alias_opt aliases a,id)::sub) all, cstrs) | _ -> (rest,Idmap.add id [a,normalize_alias_opt aliases a,id] all,cstrs)) | _ -> anomaly "Instance does not match its signature") sign (array_rev_to_list args,Idmap.empty,Constrmap.empty) in (full_subst,cstr_subst) let make_pure_subst evi args = snd (List.fold_right (fun (id,b,c) (args,l) -> match args with | a::rest -> (rest, (id,a)::l) | _ -> anomaly "Instance does not match its signature") (evar_filtered_context evi) (array_rev_to_list args,[])) (*------------------------------------* * operations on the evar constraints * *------------------------------------*) (* We have a unification problem ÎĢ; Γ |- ?e[u1..uq] = t : s where ?e is not yet * declared in ÎĢ but yet known to be declarable in some context x1:T1..xq:Tq. * [define_evar_from_virtual_equation ... Γ ÎĢ t (x1:T1..xq:Tq) .. (u1..uq) (x1..xq)] * declares x1:T1..xq:Tq |- ?e : s such that ?e[u1..uq] = t holds. *) let define_evar_from_virtual_equation define_fun env evd t_in_env sign filter inst_in_env = let ty_t_in_env = Retyping.get_type_of env evd t_in_env in let evd,evar_in_env = new_evar_instance sign evd ty_t_in_env ~filter inst_in_env in let t_in_env = whd_evar evd t_in_env in let evd = define_fun env evd (destEvar evar_in_env) t_in_env in let ids = List.map pi1 (named_context_of_val sign) in let inst_in_sign = List.map mkVar (list_filter_with filter ids) in let evar_in_sign = mkEvar (fst (destEvar evar_in_env), Array.of_list inst_in_sign) in (evd,whd_evar evd evar_in_sign) (* We have x1..xq |- ?e1 : τ and had to solve something like * ÎĢ; Γ |- ?e1[u1..uq] = (...\y1 ... \yk ... c), where c is typically some * ?e2[v1..vn], hence flexible. We had to go through k binders and now * virtually have x1..xq, y1'..yk' | ?e1' : τ' and the equation * Γ, y1..yk |- ?e1'[u1..uq y1..yk] = c. * [materialize_evar Γ evd k (?e1[u1..uq]) τ'] extends ÎĢ with the declaration * of ?e1' and returns both its instance ?e1'[x1..xq y1..yk] in an extension * of the context of e1 so that e1 can be instantiated by * (...\y1' ... \yk' ... ?e1'[x1..xq y1'..yk']), * and the instance ?e1'[u1..uq y1..yk] so that the remaining equation * ?e1'[u1..uq y1..yk] = c can be registered * * Note that, because invert_definition does not check types, we need to * guess the types of y1'..yn' by inverting the types of y1..yn along the * substitution u1..uq. *) let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let evi1 = Evd.find_undefined evd evk1 in let env1,rel_sign = env_rel_context_chop k env in let sign1 = evar_hyps evi1 in let filter1 = evar_filter evi1 in let ids1 = List.map pi1 (named_context_of_val sign1) in let inst_in_sign = List.map mkVar (list_filter_with filter1 ids1) in let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) = List.fold_right (fun (na,b,t_in_env as d) (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) -> let id = next_name_away na avoid in let evd,t_in_sign = define_evar_from_virtual_equation define_fun env evd t_in_env sign filter inst_in_env in let evd,b_in_sign = match b with | None -> evd,None | Some b -> let evd,b = define_evar_from_virtual_equation define_fun env evd b sign filter inst_in_env in evd,Some b in (push_named_context_val (id,b_in_sign,t_in_sign) sign,true::filter, (mkRel 1)::(List.map (lift 1) inst_in_env), (mkRel 1)::(List.map (lift 1) inst_in_sign), push_rel d env,evd,id::avoid)) rel_sign (sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,ids1) in let evd,ev2ty_in_sign = define_evar_from_virtual_equation define_fun env evd ty_in_env sign2 filter2 inst2_in_env in let evd,ev2_in_sign = new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 inst2_in_sign in let ev2_in_env = (fst (destEvar ev2_in_sign), Array.of_list inst2_in_env) in (evd, ev2_in_sign, ev2_in_env) let restrict_upon_filter evd evk p args = let newfilter = List.map p args in if List.for_all (fun id -> id) newfilter then None else let oldfullfilter = evar_filter (Evd.find_undefined evd evk) in Some (apply_subfilter oldfullfilter newfilter) (* Inverting constructors in instances (common when inferring type of match) *) let find_projectable_constructor env evd cstr k args cstr_subst = try let l = Constrmap.find cstr cstr_subst in let args = Array.map (lift (-k)) args in let l = List.filter (fun (args',id) -> (* is_conv is maybe too strong (and source of useless computation) *) (* (at least expansion of aliases is needed) *) array_for_all2 (is_conv env evd) args args') l in List.map snd l with Not_found -> [] (* [find_projectable_vars env sigma y subst] finds all vars of [subst] * that project on [y]. It is able to find solutions to the following * two kinds of problems: * * - ?n[...;x:=y;...] = y * - ?n[...;x:=?m[args];...] = y with ?m[args] = y recursively solvable * * (see test-suite/success/Fixpoint.v for an example of application of * the second kind of problem). * * The seek for [y] is up to variable aliasing. In case of solutions that * differ only up to aliasing, the binding that requires the less * steps of alias reduction is kept. At the end, only one solution up * to aliasing is kept. * * [find_projectable_vars] also unifies against evars that themselves mention * [y] and recursively. * * In short, the following situations give the following solutions: * * problem evar ctxt soluce remark * z1; z2:=z1 |- ?ev[z1;z2] = z1 y1:A; y2:=y1 y1 \ thanks to defs kept in * z1; z2:=z1 |- ?ev[z1;z2] = z2 y1:A; y2:=y1 y2 / subst and preferring = * z1; z2:=z1 |- ?ev[z1] = z2 y1:A y1 thanks to expand_var * z1; z2:=z1 |- ?ev[z2] = z1 y1:A y1 thanks to expand_var * z3 |- ?ev[z3;z3] = z3 y1:A; y2:=y1 y2 see make_projectable_subst * * Remark: [find_projectable_vars] assumes that identical instances of * variables in the same set of aliased variables are already removed (see * [make_projectable_subst]) *) type evar_projection = | ProjectVar | ProjectEvar of existential * evar_info * identifier * evar_projection exception NotUnique exception NotUniqueInType of (identifier * evar_projection) list let rec assoc_up_to_alias sigma aliases y yc = function | [] -> raise Not_found | (c,cc,id)::l -> let c' = whd_evar sigma c in if eq_constr y c' then id else if l <> [] then assoc_up_to_alias sigma aliases y yc l else (* Last chance, we reason up to alias conversion *) match (if c == c' then cc else normalize_alias_opt aliases c') with | Some cc when eq_constr yc cc -> id | _ -> if eq_constr yc c then id else raise Not_found let rec find_projectable_vars with_evars aliases sigma y subst = let yc = normalize_alias aliases y in let is_projectable idc idcl subst' = (* First test if some [id] aliased to [idc] is bound to [y] in [subst] *) try let id = assoc_up_to_alias sigma aliases y yc idcl in (id,ProjectVar)::subst' with Not_found -> (* Then test if [idc] is (indirectly) bound in [subst] to some evar *) (* projectable on [y] *) if with_evars then let idcl' = List.filter (fun (c,_,id) -> isEvar c) idcl in match idcl' with | [c,_,id] -> begin let (evk,argsv as t) = destEvar c in let evi = Evd.find sigma evk in let subst,_ = make_projectable_subst aliases sigma evi argsv in let l = find_projectable_vars with_evars aliases sigma y subst in match l with | [id',p] -> (id,ProjectEvar (t,evi,id',p))::subst' | _ -> subst' end | [] -> subst' | _ -> anomaly "More than one non var in aliases class of evar instance" else subst' in Idmap.fold is_projectable subst [] (* [filter_solution] checks if one and only one possible projection exists * among a set of solutions to a projection problem *) let filter_solution = function | [] -> raise Not_found | (id,p)::_::_ -> raise NotUnique | [id,p] -> (mkVar id, p) let project_with_effects aliases sigma effects t subst = let c, p = filter_solution (find_projectable_vars false aliases sigma t subst) in effects := p :: !effects; c let rec find_solution_type evarenv = function | (id,ProjectVar)::l -> pi3 (lookup_named id evarenv) | [id,ProjectEvar _] -> (* bugged *) pi3 (lookup_named id evarenv) | (id,ProjectEvar _)::l -> find_solution_type evarenv l | [] -> assert false (* In case the solution to a projection problem requires the instantiation of * subsidiary evars, [do_projection_effects] performs them; it * also try to instantiate the type of those subsidiary evars if their * type is an evar too. * * Note: typing creates new evar problems, which induces a recursive dependency * with [define]. To avoid a too large set of recursive functions, we * pass [define] to [do_projection_effects] as a parameter. *) let rec do_projection_effects define_fun env ty evd = function | ProjectVar -> evd | ProjectEvar ((evk,argsv),evi,id,p) -> let evd = Evd.define evk (mkVar id) evd in (* TODO: simplify constraints involving evk *) let evd = do_projection_effects define_fun env ty evd p in let ty = whd_betadeltaiota env evd (Lazy.force ty) in if not (isSort ty) then (* Don't try to instantiate if a sort because if evar_concl is an evar it may commit to a univ level which is not the right one (however, regarding coercions, because t is obtained by unif, we know that no coercion can be inserted) *) let subst = make_pure_subst evi argsv in let ty' = replace_vars subst evi.evar_concl in let ty' = whd_evar evd ty' in if isEvar ty' then define_fun env evd (destEvar ty') ty else evd else evd (* Assuming ÎĢ; Γ, y1..yk |- c, [invert_arg_from_subst Γ k ÎĢ [x1:=u1..xn:=un] c] * tries to return φ(x1..xn) such that equation φ(u1..un) = c is valid. * The strategy is to imitate the structure of c and then to invert * the variables of c (i.e. rels or vars of Γ) using the algorithm * implemented by project_with_effects/find_projectable_vars. * It returns either a unique solution or says whether 0 or more than * 1 solutions is found. * * Precondition: ÎĢ; Γ, y1..yk |- c /\ ÎĢ; Γ |- u1..un * Postcondition: if φ(x1..xn) is returned then * ÎĢ; Γ, y1..yk |- φ(u1..un) = c /\ x1..xn |- φ(x1..xn) * * The effects correspond to evars instantiated while trying to project. * * [invert_arg_from_subst] is used on instances of evars. Since the * evars are flexible, these instances are potentially erasable. This * is why we don't investigate whether evars in the instances of evars * are unifiable, to the contrary of [invert_definition]. *) type projectibility_kind = | NoUniqueProjection | UniqueProjection of constr * evar_projection list type projectibility_status = | CannotInvert | Invertible of projectibility_kind let invert_arg_from_subst evd aliases k0 subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders = let effects = ref [] in let rec aux k t = let t = whd_evar evd t in match kind_of_term t with | Rel i when i>k0+k -> aux' k (mkRel (i-k)) | Var id -> aux' k t | _ -> map_constr_with_binders succ aux k t and aux' k t = try project_with_effects aliases evd effects t subst_in_env_extended_with_k_binders with Not_found -> match expand_alias_once aliases t with | None -> raise Not_found | Some c -> aux k c in try let c = aux 0 c_in_env_extended_with_k_binders in Invertible (UniqueProjection (c,!effects)) with | Not_found -> CannotInvert | NotUnique -> Invertible NoUniqueProjection let invert_arg fullenv evd aliases k evk subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders = let res = invert_arg_from_subst evd aliases k subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders in match res with | Invertible (UniqueProjection (c,_)) when not (noccur_evar fullenv evd evk c) -> CannotInvert | _ -> res let effective_projections = map_succeed (function Invertible c -> c | _ -> failwith"") let instance_of_projection f env t evd projs = let ty = lazy (nf_evar evd (Retyping.get_type_of env evd t)) in match projs with | NoUniqueProjection -> raise NotUnique | UniqueProjection (c,effects) -> (List.fold_left (do_projection_effects f env ty) evd effects, c) exception NotEnoughInformationToInvert let extract_unique_projections projs = List.map (function | Invertible (UniqueProjection (c,_)) -> c | _ -> (* For instance, there are evars with non-invertible arguments and *) (* we cannot arbitrarily restrict these evars before knowing if there *) (* will really be used; it can also be due to some argument *) (* (typically a rel) that is not inversible and that cannot be *) (* inverted either because it is needed for typing the conclusion *) (* of the evar to project *) raise NotEnoughInformationToInvert) projs let extract_candidates sols = try Some (List.map (function (id,ProjectVar) -> mkVar id | _ -> raise Exit) sols) with Exit -> None let filter_of_projection = function Invertible _ -> true | _ -> false let invert_invertible_arg fullenv evd aliases k (evk,argsv) args' = let evi = Evd.find_undefined evd evk in let subst,_ = make_projectable_subst aliases evd evi argsv in let projs = array_map_to_list (invert_arg fullenv evd aliases k evk subst) args' in Array.of_list (extract_unique_projections projs) (* Redefines an evar with a smaller context (i.e. it may depend on less * variables) such that c becomes closed. * Example: in "fun (x:?1) (y:list ?2[x]) => x = y :> ?3[x,y] /\ x = nil bool" * ?3 <-- ?1 no pb: env of ?3 is larger than ?1's * ?1 <-- list ?2 pb: ?2 may depend on x, but not ?1. * What we do is that ?2 is defined by a new evar ?4 whose context will be * a prefix of ?2's env, included in ?1's env. * * If "hyps |- ?e : T" and "filter" selects a subset hyps' of hyps then * [do_restrict_hyps evd ?e filter] sets ?e:=?e'[hyps'] and returns ?e' * such that "hyps' |- ?e : T" *) let filter_effective_candidates evi filter candidates = match filter with | None -> candidates | Some filter -> let ids = List.map pi1 (list_filter_with filter (evar_context evi)) in List.filter (fun a -> list_subset (Idset.elements (collect_vars a)) ids) candidates let filter_candidates evd evk filter candidates_update = let evi = Evd.find_undefined evd evk in let candidates = match candidates_update with | None -> evi.evar_candidates | Some _ -> candidates_update in match candidates with | None -> None | Some l -> let l' = filter_effective_candidates evi filter l in if List.length l = List.length l' && candidates_update = None then None else Some l' let closure_of_filter evd evk filter = let evi = Evd.find_undefined evd evk in let vars = collect_vars (nf_evar evd (evar_concl evi)) in let test (id,c,_) b = b || Idset.mem id vars || c <> None in let newfilter = List.map2 test (evar_context evi) filter in if newfilter = evar_filter evi then None else Some newfilter let restrict_hyps evd evk filter candidates = (* What to do with dependencies? Assume we have x:A, y:B(x), z:C(x,y) |- ?e:T(x,y,z) and restrict on y. - If y is in a non-erasable position in C(x,y) (i.e. it is not below an occurrence of x in the hnf of C), then z should be removed too. - If y is in a non-erasable position in T(x,y,z) then the problem is unsolvable. Computing whether y is erasable or not may be costly and the interest for this early detection in practice is not obvious. We let it for future work. In any case, thanks to the use of filters, the whole (unrestricted) context remains consistent. *) let candidates = filter_candidates evd evk (Some filter) candidates in let typablefilter = closure_of_filter evd evk filter in (typablefilter,candidates) exception EvarSolvedWhileRestricting of evar_map * constr let do_restrict_hyps evd (evk,args as ev) filter candidates = let filter,candidates = match filter with | None -> None,candidates | Some filter -> restrict_hyps evd evk filter candidates in match candidates,filter with | Some [], _ -> error "Not solvable." | Some [nc],_ -> let evd = Evd.define evk nc evd in raise (EvarSolvedWhileRestricting (evd,whd_evar evd (mkEvar ev))) | None, None -> evd,ev | _ -> restrict_applied_evar evd ev filter candidates (* [postpone_non_unique_projection] postpones equation of the form ?e[?] = c *) (* ?e is assumed to have no candidates *) let postpone_non_unique_projection env evd (evk,argsv as ev) sols rhs = let rhs = expand_vars_in_term env rhs in let filter = restrict_upon_filter evd evk (* Keep only variables that occur in rhs *) (* This is not safe: is the variable is a local def, its body *) (* may contain references to variables that are removed, leading to *) (* a ill-formed context. We would actually need a notion of filter *) (* that says that the body is hidden. Note that expand_vars_in_term *) (* expands only rels and vars aliases, not rels or vars bound to an *) (* arbitrary complex term *) (fun a -> not (isRel a || isVar a) || dependent a rhs || List.exists (fun (id,_) -> isVarId id a) sols) (Array.to_list argsv) in let filter = match filter with | None -> None | Some filter -> closure_of_filter evd evk filter in let candidates = extract_candidates sols in if candidates <> None then restrict_evar evd evk filter candidates else (* We made an approximation by not expanding a local definition *) let evd,ev = restrict_applied_evar evd ev filter None in let pb = (Reduction.CONV,env,mkEvar ev,rhs) in Evd.add_conv_pb pb evd (* [postpone_evar_evar] postpones an equation of the form ?e1[?1] = ?e2[?2] *) let postpone_evar_evar f env evd filter1 ev1 filter2 ev2 = (* Leave an equation between (restrictions of) ev1 andv ev2 *) try let evd,ev1' = do_restrict_hyps evd ev1 filter1 None in try let evd,ev2' = do_restrict_hyps evd ev2 filter2 None in add_conv_pb (Reduction.CONV,env,mkEvar ev1',mkEvar ev2') evd with EvarSolvedWhileRestricting (evd,ev2) -> (* ev2 solved on the fly *) f env evd ev1' ev2 with EvarSolvedWhileRestricting (evd,ev1) -> (* ev1 solved on the fly *) f env evd ev2 ev1 (* [solve_evar_evar f Γ ÎĢ ?e1[u1..un] ?e2[v1..vp]] applies an heuristic * to solve the equation ÎĢ; Γ âŠĒ ?e1[u1..un] = ?e2[v1..vp]: * - if there are at most one φj for each vj s.t. vj = φj(u1..un), * we first restrict ?e2 to the subset v_k1..v_kq of the vj that are * inversible and we set ?e1[x1..xn] := ?e2[φk1(x1..xn)..φkp(x1..xn)] * (this is a case of pattern-unification) * - symmetrically if there are at most one ψj for each uj s.t. * uj = ψj(v1..vp), * - otherwise, each position i s.t. ui does not occur in v1..vp has to * be restricted and similarly for the vi, and we leave the equation * as an open equation (performed by [postpone_evar]) * * Warning: the notion of unique φj is relative to some given class * of unification problems * * Note: argument f is the function used to instantiate evars. *) let are_canonical_instances args1 args2 env = let n1 = Array.length args1 in let n2 = Array.length args2 in let rec aux n = function | (id,_,c)::sign when n < n1 && isVarId id args1.(n) && isVarId id args2.(n) -> aux (n+1) sign | [] -> let rec aux2 n = n = n1 || (isRelN (n1-n) args1.(n) && isRelN (n1-n) args2.(n) && aux2 (n+1)) in aux2 n | _ -> false in n1 = n2 & aux 0 (named_context env) let filter_compatible_candidates conv_algo env evd evi args rhs c = let c' = instantiate_evar (evar_filtered_context evi) c args in let evd, b = conv_algo env evd Reduction.CONV rhs c' in if b then Some (c,evd) else None exception DoesNotPreserveCandidateRestriction let restrict_candidates conv_algo env evd filter1 (evk1,argsv1) (evk2,argsv2) = let evi1 = Evd.find evd evk1 in let evi2 = Evd.find evd evk2 in let cand1 = filter_candidates evd evk1 filter1 None in let cand2 = evi2.evar_candidates in match cand1, cand2 with | _, None -> cand1 | None, Some _ -> raise DoesNotPreserveCandidateRestriction | Some l1, Some l2 -> let args1 = Array.to_list argsv1 in let args2 = Array.to_list argsv2 in let l1' = List.filter (fun c1 -> let c1' = instantiate_evar (evar_filtered_context evi1) c1 args1 in List.filter (fun c2 -> (filter_compatible_candidates conv_algo env evd evi2 args2 c1' c2 <> None)) l2 <> []) l1 in if List.length l1 = List.length l1' then None else Some l1' exception CannotProject of bool list option (* Assume that FV(?n[x1:=t1..xn:=tn]) belongs to some set U. Can ?n be instantiated by a term u depending essentially on xi such that the FV(u[x1:=t1..xn:=tn]) are in the set U? - If ti is a variable, it has to be in U. - If ti is a constructor, its parameters cannot be erased even if u matches on it, so we have to discard ti if the parameters contain variables not in U. - If ti is rigid, we have to discard it if it contains variables in U. Note: when restricting as part of an equation ?n[x1:=t1..xn:=tn] = ?m[...] then, occurrences of ?m in the ti can be seen, like variables, as occurrences of subterms to eventually discard so as to be allowed to keep ti. *) let rec is_constrainable_in k (ev,(fv_rels,fv_ids) as g) t = let f,args = decompose_app_vect t in match kind_of_term f with | Construct (ind,_) -> let nparams = (fst (Global.lookup_inductive ind)).Declarations.mind_nparams in if nparams > Array.length args then true (* We don't try to be more clever *) else let params,_ = array_chop nparams args in array_for_all (is_constrainable_in k g) params | Ind _ -> array_for_all (is_constrainable_in k g) args | Prod (_,t1,t2) -> is_constrainable_in k g t1 && is_constrainable_in k g t2 | Evar (ev',_) -> ev' <> ev (*If ev' needed, one may also try to restrict it*) | Var id -> Idset.mem id fv_ids | Rel n -> n <= k || Intset.mem n fv_rels | Sort _ -> true | _ -> (* We don't try to be more clever *) true let has_constrainable_free_vars evd aliases k ev (fv_rels,fv_ids as fvs) t = let t = expansion_of_var aliases t in match kind_of_term t with | Var id -> Idset.mem id fv_ids | Rel n -> n <= k || Intset.mem n fv_rels | _ -> is_constrainable_in k (ev,fvs) t let ensure_evar_independent g env evd (evk1,argsv1 as ev1) (evk2,argsv2 as ev2)= let filter1 = restrict_upon_filter evd evk1 (noccur_evar env evd evk2) (Array.to_list argsv1) in let candidates1 = restrict_candidates g env evd filter1 ev1 ev2 in let evd,(evk1,_ as ev1) = do_restrict_hyps evd ev1 filter1 candidates1 in let filter2 = restrict_upon_filter evd evk2 (noccur_evar env evd evk1) (Array.to_list argsv2) in let candidates2 = restrict_candidates g env evd filter2 ev2 ev1 in let evd,ev2 = do_restrict_hyps evd ev2 filter2 candidates2 in evd,ev1,ev2 exception EvarSolvedOnTheFly of evar_map * constr let project_evar_on_evar g env evd aliases k2 (evk1,argsv1 as ev1) (evk2,argsv2 as ev2) = (* Apply filtering on ev1 so that fvs(ev1) are in fvs(ev2). *) let fvs2 = free_vars_and_rels_up_alias_expansion aliases (mkEvar ev2) in let filter1 = restrict_upon_filter evd evk1 (has_constrainable_free_vars evd aliases k2 evk2 fvs2) (Array.to_list argsv1) in (* Only try pruning on variable substitutions, postpone otherwise. *) (* Rules out non-linear instances. *) if is_unification_pattern_pure_evar env evd ev2 (mkEvar ev1) then try let candidates1 = restrict_candidates g env evd filter1 ev1 ev2 in let evd,(evk1',args1) = do_restrict_hyps evd ev1 filter1 candidates1 in evd,mkEvar (evk1',invert_invertible_arg env evd aliases k2 ev2 args1) with | EvarSolvedWhileRestricting (evd,ev1) -> raise (EvarSolvedOnTheFly (evd,ev1)) | DoesNotPreserveCandidateRestriction | NotEnoughInformationToInvert -> raise (CannotProject filter1) else raise (CannotProject filter1) let solve_evar_evar_l2r f g env evd aliases ev1 (evk2,_ as ev2) = try let evd,body = project_evar_on_evar g env evd aliases 0 ev1 ev2 in Evd.define evk2 body evd with EvarSolvedOnTheFly (evd,c) -> f env evd ev2 c let solve_evar_evar ?(force=false) f g env evd (evk1,args1 as ev1) (evk2,args2 as ev2) = if are_canonical_instances args1 args2 env then (* If instances are canonical, we solve the problem in linear time *) let sign = evar_filtered_context (Evd.find evd evk2) in let id_inst = list_map_to_array (fun (id,_,_) -> mkVar id) sign in Evd.define evk2 (mkEvar(evk1,id_inst)) evd else let evd,ev1,ev2 = (* If an evar occurs in the instance of the other evar and the use of an heuristic is forced, we restrict *) if force then ensure_evar_independent g env evd ev1 ev2 else (evd,ev1,ev2) in let aliases = make_alias_map env in try solve_evar_evar_l2r f g env evd aliases ev1 ev2 with CannotProject filter1 -> try solve_evar_evar_l2r f g env evd aliases ev2 ev1 with CannotProject filter2 -> postpone_evar_evar f env evd filter1 ev1 filter2 ev2 type conv_fun = env -> evar_map -> conv_pb -> constr -> constr -> evar_map * bool let check_evar_instance evd evk1 body conv_algo = let evi = Evd.find evd evk1 in let evenv = evar_unfiltered_env evi in (* FIXME: The body might be ill-typed when this is called from w_merge *) let ty = try Retyping.get_type_of evenv evd body with e when Errors.noncritical e -> error "Ill-typed evar instance" in let evd,b = conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl in if b then evd else user_err_loc (fst (evar_source evk1 evd),"", str "Unable to find a well-typed instantiation") (* Solve pbs ?e[t1..tn] = ?e[u1..un] which arise often in fixpoint * definitions. We try to unify the ti with the ui pairwise. The pairs * that don't unify are discarded (i.e. ?e is redefined so that it does not * depend on these args). *) let solve_refl ?(can_drop=false) conv_algo env evd evk argsv1 argsv2 = if array_equal eq_constr argsv1 argsv2 then evd else (* Filter and restrict if needed *) let untypedfilter = restrict_upon_filter evd evk (fun (a1,a2) -> snd (conv_algo env evd Reduction.CONV a1 a2)) (List.combine (Array.to_list argsv1) (Array.to_list argsv2)) in let candidates = filter_candidates evd evk untypedfilter None in let filter = match untypedfilter with | None -> None | Some filter -> closure_of_filter evd evk filter in let evd,ev1 = restrict_applied_evar evd (evk,argsv1) filter candidates in if fst ev1 = evk & can_drop then (* No refinement *) evd else (* either progress, or not allowed to drop, e.g. to preserve possibly *) (* informative equations such as ?e[x:=?y]=?e[x:=?y'] where we don't know *) (* if e can depend on x until ?y is not resolved, or, conversely, we *) (* don't know if ?y has to be unified with ?y, until e is resolved *) let argsv2 = restrict_instance evd evk filter argsv2 in let ev2 = (fst ev1,argsv2) in (* Leave a unification problem *) Evd.add_conv_pb (Reduction.CONV,env,mkEvar ev1,mkEvar ev2) evd (* If the evar can be instantiated by a finite set of candidates known in advance, we check which of them apply *) exception NoCandidates let solve_candidates conv_algo env evd (evk,argsv as ev) rhs = let evi = Evd.find evd evk in let args = Array.to_list argsv in match evi.evar_candidates with | None -> raise NoCandidates | Some l -> let l' = list_map_filter (filter_compatible_candidates conv_algo env evd evi args rhs) l in match l' with | [] -> error_cannot_unify env evd (mkEvar ev, rhs) | [c,evd] -> (* solve_candidates might have been called recursively in the mean *) (* time and the evar been solved by the filtering process *) if Evd.is_undefined evd evk then Evd.define evk c evd else evd | l when List.length l < List.length l' -> let candidates = List.map fst l in restrict_evar evd evk None (Some candidates) | l -> evd (* We try to instantiate the evar assuming the body won't depend * on arguments that are not Rels or Vars, or appearing several times * (i.e. we tackle a generalization of Miller-Pfenning patterns unification) * * 1) Let "env |- ?ev[hyps:=args] = rhs" be the unification problem * 2) We limit it to a patterns unification problem "env |- ev[subst] = rhs" * where only Rel's and Var's are relevant in subst * 3) We recur on rhs, "imitating" the term, and failing if some Rel/Var is * not in the scope of ?ev. For instance, the problem * "y:nat |- ?x[] = y" where "|- ?1:nat" is not satisfiable because * ?1 would be instantiated by y which is not in the scope of ?1. * 4) We try to "project" the term if the process of imitation fails * and that only one projection is possible * * Note: we don't assume rhs in normal form, it may fail while it would * have succeeded after some reductions. * * This is the work of [invert_definition Γ ÎĢ ?ev[hyps:=args] c] * Precondition: ÎĢ; Γ, y1..yk |- c /\ ÎĢ; Γ |- u1..un * Postcondition: if φ(x1..xn) is returned then * ÎĢ; Γ, y1..yk |- φ(u1..un) = c /\ x1..xn |- φ(x1..xn) *) exception NotInvertibleUsingOurAlgorithm of constr exception NotEnoughInformationToProgress of (identifier * evar_projection) list exception NotEnoughInformationEvarEvar of constr exception OccurCheckIn of evar_map * constr let rec invert_definition conv_algo choose env evd (evk,argsv as ev) rhs = let aliases = make_alias_map env in let evdref = ref evd in let progress = ref false in let evi = Evd.find evd evk in let subst,cstr_subst = make_projectable_subst aliases evd evi argsv in (* Projection *) let project_variable t = (* Evar/Var problem: unifiable iff variable projectable from ev subst *) try let sols = find_projectable_vars true aliases !evdref t subst in let c, p = match sols with | [] -> raise Not_found | [id,p] -> (mkVar id, p) | (id,p)::_::_ -> if choose then (mkVar id, p) else raise (NotUniqueInType sols) in let ty = lazy (Retyping.get_type_of env !evdref t) in let evd = do_projection_effects (evar_define conv_algo) env ty !evdref p in evdref := evd; c with | Not_found -> raise (NotInvertibleUsingOurAlgorithm t) | NotUniqueInType sols -> if not !progress then raise (NotEnoughInformationToProgress sols); (* No unique projection but still restrict to where it is possible *) (* materializing is necessary, but is restricting useful? *) let ty = find_solution_type (evar_env evi) sols in let sign = evar_filtered_context evi in let ty' = instantiate_evar sign ty (Array.to_list argsv) in let (evd,evar,(evk',argsv' as ev')) = materialize_evar (evar_define conv_algo) env !evdref 0 ev ty' in let ts = expansions_of_var aliases t in let test c = isEvar c or List.mem c ts in let filter = array_map_to_list test argsv' in let filter = apply_subfilter (evar_filter (Evd.find_undefined evd evk)) filter in let filter = closure_of_filter evd evk' filter in let candidates = extract_candidates sols in let evd = if candidates <> None then restrict_evar evd evk' filter candidates else let evd,ev'' = restrict_applied_evar evd ev' filter None in Evd.add_conv_pb (Reduction.CONV,env,mkEvar ev'',t) evd in evdref := evd; evar in let rec imitate (env',k as envk) t = let t = whd_evar !evdref t in match kind_of_term t with | Rel i when i>k -> (match pi2 (Environ.lookup_rel (i-k) env') with | None -> project_variable (mkRel (i-k)) | Some b -> try project_variable (mkRel (i-k)) with NotInvertibleUsingOurAlgorithm _ -> imitate envk (lift i b)) | Var id -> (match pi2 (Environ.lookup_named id env') with | None -> project_variable t | Some b -> try project_variable t with NotInvertibleUsingOurAlgorithm _ -> imitate envk b) | Evar (evk',args' as ev') -> if evk = evk' then raise (OccurCheckIn (evd,rhs)); (* Evar/Evar problem (but left evar is virtual) *) let aliases = lift_aliases k aliases in (try let ev = (evk,Array.map (lift k) argsv) in let evd,body = project_evar_on_evar conv_algo env' !evdref aliases k ev' ev in evdref := evd; body with | EvarSolvedOnTheFly (evd,t) -> evdref:=evd; imitate envk t | CannotProject filter' -> if not !progress then raise (NotEnoughInformationEvarEvar t); (* Make the virtual left evar real *) let ty = get_type_of env' !evdref t in let (evd,evar'',ev'') = materialize_evar (evar_define conv_algo) env' !evdref k ev ty in (* materialize_evar may instantiate ev' by another evar; adjust it *) let (evk',args' as ev') = normalize_evar evd ev' in let evd = (* Try to project (a restriction of) the left evar ... *) try let evd,body = project_evar_on_evar conv_algo env' evd aliases 0 ev'' ev' in Evd.define evk' body evd with | EvarSolvedOnTheFly _ -> assert false (* ev has no candidates *) | CannotProject filter'' -> (* ... or postpone the problem *) postpone_evar_evar (evar_define conv_algo) env' evd filter'' ev'' filter' ev' in evdref := evd; evar'') | _ -> progress := true; match let c,args = decompose_app_vect t in match kind_of_term c with | Construct cstr when noccur_between 1 k t -> (* This is common case when inferring the return clause of match *) (* (currently rudimentary: we do not treat the case of multiple *) (* possible inversions; we do not treat overlap with a possible *) (* alternative inversion of the subterms of the constructor, etc)*) (match find_projectable_constructor env evd cstr k args cstr_subst with | _::_ as l -> Some (List.map mkVar l) | _ -> None) | _ -> None with | Some l -> let ty = get_type_of env' !evdref t in let candidates = try let t = map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) imitate envk t in t::l with e when Errors.noncritical e -> l in (match candidates with | [x] -> x | _ -> let (evd,evar'',ev'') = materialize_evar (evar_define conv_algo) env' !evdref k ev ty in evdref := restrict_evar evd (fst ev'') None (Some candidates); evar'') | None -> (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *) map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) imitate envk t in let rhs = whd_beta evd rhs (* heuristic *) in let body = imitate (env,0) rhs in (!evdref,body) (* [define] tries to solve the problem "?ev[args] = rhs" when "?ev" is * an (uninstantiated) evar such that "hyps |- ?ev : typ". Otherwise said, * [define] tries to find an instance lhs such that * "lhs [hyps:=args]" unifies to rhs. The term "lhs" must be closed in * context "hyps" and not referring to itself. *) and evar_define conv_algo ?(choose=false) env evd (evk,argsv as ev) rhs = match kind_of_term rhs with | Evar (evk2,argsv2 as ev2) -> if evk = evk2 then solve_refl ~can_drop:choose conv_algo env evd evk argsv argsv2 else solve_evar_evar ~force:choose (evar_define conv_algo) conv_algo env evd ev ev2 | _ -> try solve_candidates conv_algo env evd ev rhs with NoCandidates -> try let (evd',body) = invert_definition conv_algo choose env evd ev rhs in if occur_meta body then error "Meta cannot occur in evar body."; (* invert_definition may have instantiate some evars of rhs with evk *) (* so we recheck acyclicity *) if occur_evar evk body then raise (OccurCheckIn (evd',body)); (* needed only if an inferred type *) let body = refresh_universes body in (* Cannot strictly type instantiations since the unification algorithm * does not unify applications from left to right. * e.g problem f x == g y yields x==y and f==g (in that order) * Another problem is that type variables are evars of type Type let _ = try let env = evar_env evi in let ty = evi.evar_concl in Typing.check env evd' body ty with e -> pperrnl (str "Ill-typed evar instantiation: " ++ fnl() ++ pr_evar_map evd' ++ fnl() ++ str "----> " ++ int ev ++ str " := " ++ print_constr body); raise e in*) let evd' = Evd.define evk body evd' in check_evar_instance evd' evk body conv_algo with | NotEnoughInformationToProgress sols -> postpone_non_unique_projection env evd ev sols rhs | NotEnoughInformationEvarEvar t -> add_conv_pb (Reduction.CONV,env,mkEvar ev,t) evd | NotInvertibleUsingOurAlgorithm t -> error_not_clean env evd evk t (evar_source evk evd) | OccurCheckIn (evd,rhs) -> (* last chance: rhs actually reduces to ev *) let c = whd_betadeltaiota env evd rhs in match kind_of_term c with | Evar (evk',argsv2) when evk = evk' -> solve_refl (fun env sigma pb c c' -> (evd,is_fconv pb env sigma c c')) env evd evk argsv argsv2 | _ -> error_occur_check env evd evk rhs (* This code (i.e. solve_pb, etc.) takes a unification * problem, and tries to solve it. If it solves it, then it removes * all the conversion problems, and re-runs conversion on each one, in * the hopes that the new solution will aid in solving them. * * The kinds of problems it knows how to solve are those in which * the usable arguments of an existential var are all themselves * universal variables. * The solution to this problem is to do renaming for the Var's, * to make them match up with the Var's which are found in the * hyps of the existential, to do a "pop" for each Rel which is * not an argument of the existential, and a subst1 for each which * is, again, with the corresponding variable. This is done by * define * * Thus, we take the arguments of the existential which we are about * to assign, and zip them with the identifiers in the hypotheses. * Then, we process all the Var's in the arguments, and sort the * Rel's into ascending order. Then, we just march up, doing * subst1's and pop's. * * NOTE: We can do this more efficiently for the relative arguments, * by building a long substituend by hand, but this is a pain in the * ass. *) let status_changed lev (pbty,_,t1,t2) = (try ExistentialSet.mem (head_evar t1) lev with NoHeadEvar -> false) or (try ExistentialSet.mem (head_evar t2) lev with NoHeadEvar -> false) let reconsider_conv_pbs conv_algo evd = let (evd,pbs) = extract_changed_conv_pbs evd status_changed in List.fold_left (fun (evd,b as p) (pbty,env,t1,t2) -> if b then conv_algo env evd pbty t1 t2 else p) (evd,true) pbs (* Tries to solve problem t1 = t2. * Precondition: t1 is an uninstantiated evar * Returns an optional list of evars that were instantiated, or None * if the problem couldn't be solved. *) (* Rq: uncomplete algorithm if pbty = CONV_X_LEQ ! *) let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1),t2) = try let t2 = whd_betaiota evd t2 in (* includes whd_evar *) let evd = match pbty with | Some true when isEvar t2 -> add_conv_pb (Reduction.CUMUL,env,mkEvar ev1,t2) evd | Some false when isEvar t2 -> add_conv_pb (Reduction.CUMUL,env,t2,mkEvar ev1) evd | _ -> evar_define conv_algo ~choose env evd ev1 t2 in reconsider_conv_pbs conv_algo evd with e when precatchable_exception e -> (evd,false) (** The following functions return the set of evars immediately contained in the object, including defined evars *) let evars_of_term c = let rec evrec acc c = match kind_of_term c with | Evar (n, l) -> Intset.add n (Array.fold_left evrec acc l) | _ -> fold_constr evrec acc c in evrec Intset.empty c (* spiwack: a few functions to gather evars on which goals depend. *) let queue_set q is_dependent set = Intset.iter (fun a -> Queue.push (is_dependent,a) q) set let queue_term q is_dependent c = queue_set q is_dependent (evars_of_term c) let process_dependent_evar q acc evm is_dependent e = let evi = Evd.find evm e in (* Queues evars appearing in the types of the goal (conclusion, then hypotheses), they are all dependent. *) queue_term q true evi.evar_concl; List.iter begin fun (_,b,t) -> queue_term q true t; match b with | None -> () | Some b -> queue_term q true b end (Environ.named_context_of_val evi.evar_hyps); match evi.evar_body with | Evar_empty -> if is_dependent then Intmap.add e None acc else acc | Evar_defined b -> let subevars = evars_of_term b in (* evars appearing in the definition of an evar [e] are marked as dependent when [e] is dependent itself: if [e] is a non-dependent goal, then, unless they are reach from another path, these evars are just other non-dependent goals. *) queue_set q is_dependent subevars; if is_dependent then Intmap.add e (Some subevars) acc else acc let gather_dependent_evars q evm = let acc = ref Intmap.empty in while not (Queue.is_empty q) do let (is_dependent,e) = Queue.pop q in (* checks if [e] has already been added to [!acc] *) begin if not (Intmap.mem e !acc) then acc := process_dependent_evar q !acc evm is_dependent e end done; !acc let gather_dependent_evars evm l = let q = Queue.create () in List.iter (fun a -> Queue.add (false,a) q) l; gather_dependent_evars q evm (* /spiwack *) let evars_of_named_context nc = List.fold_right (fun (_, b, t) s -> Option.fold_left (fun s t -> Intset.union s (evars_of_term t)) (Intset.union s (evars_of_term t)) b) nc Intset.empty let evars_of_evar_info evi = Intset.union (evars_of_term evi.evar_concl) (Intset.union (match evi.evar_body with | Evar_empty -> Intset.empty | Evar_defined b -> evars_of_term b) (evars_of_named_context (named_context_of_val evi.evar_hyps))) (** The following functions return the set of undefined evars contained in the object, the defined evars being traversed. This is roughly a combination of the previous functions and [nf_evar]. *) let undefined_evars_of_term evd t = let rec evrec acc c = match kind_of_term c with | Evar (n, l) -> let acc = Array.fold_left evrec acc l in (try match (Evd.find evd n).evar_body with | Evar_empty -> Intset.add n acc | Evar_defined c -> evrec acc c with Not_found -> anomaly "undefined_evars_of_term: evar not found") | _ -> fold_constr evrec acc c in evrec Intset.empty t let undefined_evars_of_named_context evd nc = List.fold_right (fun (_, b, t) s -> Option.fold_left (fun s t -> Intset.union s (undefined_evars_of_term evd t)) (Intset.union s (undefined_evars_of_term evd t)) b) nc Intset.empty let undefined_evars_of_evar_info evd evi = Intset.union (undefined_evars_of_term evd evi.evar_concl) (Intset.union (match evi.evar_body with | Evar_empty -> Intset.empty | Evar_defined b -> undefined_evars_of_term evd b) (undefined_evars_of_named_context evd (named_context_of_val evi.evar_hyps))) (* [check_evars] fails if some unresolved evar remains *) let check_evars env initial_sigma sigma c = let rec proc_rec c = match kind_of_term c with | Evar (evk,_ as ev) -> (match existential_opt_value sigma ev with | Some c -> proc_rec c | None -> if not (Evd.mem initial_sigma evk) then let (loc,k) = evar_source evk sigma in match k with | ImplicitArg (gr, (i, id), false) -> () | _ -> let evi = nf_evar_info sigma (Evd.find_undefined sigma evk) in error_unsolvable_implicit loc env sigma evi k None) | _ -> iter_constr proc_rec c in proc_rec c open Glob_term (****************************************) (* Operations on value/type constraints *) (****************************************) type type_constraint_type = (int * int) option * constr type type_constraint = type_constraint_type option type val_constraint = constr option (* Old comment... * Basically, we have the following kind of constraints (in increasing * strength order): * (false,(None,None)) -> no constraint at all * (true,(None,None)) -> we must build a judgement which _TYPE is a kind * (_,(None,Some ty)) -> we must build a judgement which _TYPE is ty * (_,(Some v,_)) -> we must build a judgement which _VAL is v * Maybe a concrete datatype would be easier to understand. * We differentiate (true,(None,None)) from (_,(None,Some Type)) * because otherwise Case(s) would be misled, as in * (n:nat) Case n of bool [_]nat end would infer the predicate Type instead * of Set. *) (* The empty type constraint *) let empty_tycon = None let mk_tycon_type c = (None, c) let mk_abstr_tycon_type n c = (Some (n, n), c) (* First component is initial abstraction, second is current abstraction *) (* Builds a type constraint *) let mk_tycon ty = Some (mk_tycon_type ty) let mk_abstr_tycon n ty = Some (mk_abstr_tycon_type n ty) (* Constrains the value of a type *) let empty_valcon = None (* Builds a value constraint *) let mk_valcon c = Some c let idx = id_of_string "x" (* Refining an evar to a product *) let define_pure_evar_as_product evd evk = let evi = Evd.find_undefined evd evk in let evenv = evar_unfiltered_env evi in let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in let evd1,dom = new_type_evar evd evenv ~filter:(evar_filter evi) in let evd2,rng = let newenv = push_named (id, None, dom) evenv in let src = evar_source evk evd1 in let filter = true::evar_filter evi in new_type_evar evd1 newenv ~src ~filter in let prod = mkProd (Name id, dom, subst_var id rng) in let evd3 = Evd.define evk prod evd2 in evd3,prod (* Refine an applied evar to a product and returns its instantiation *) let define_evar_as_product evd (evk,args) = let evd,prod = define_pure_evar_as_product evd evk in (* Quick way to compute the instantiation of evk with args *) let na,dom,rng = destProd prod in let evdom = mkEvar (fst (destEvar dom), args) in let evrngargs = array_cons (mkRel 1) (Array.map (lift 1) args) in let evrng = mkEvar (fst (destEvar rng), evrngargs) in evd,mkProd (na, evdom, evrng) (* Refine an evar with an abstraction I.e., solve x1..xq |- ?e:T(x1..xq) with e:=Îŧy:A.?e'[x1..xq,y] where: - either T(x1..xq) = πy:A(x1..xq).B(x1..xq,y) or T(x1..xq) = ?d[x1..xq] and we define ?d := πy:?A.?B with x1..xq |- ?A:Type and x1..xq,y |- ?B:Type - x1..xq,y:A |- ?e':B *) let define_pure_evar_as_lambda env evd evk = let evi = Evd.find_undefined evd evk in let evenv = evar_unfiltered_env evi in let typ = whd_betadeltaiota env evd (evar_concl evi) in let evd1,(na,dom,rng) = match kind_of_term typ with | Prod (na,dom,rng) -> (evd,(na,dom,rng)) | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ | _ -> error_not_product_loc dummy_loc env evd typ in let avoid = ids_of_named_context (evar_context evi) in let id = next_name_away_with_default_using_types "x" na avoid (whd_evar evd dom) in let newenv = push_named (id, None, dom) evenv in let filter = true::evar_filter evi in let src = evar_source evk evd1 in let evd2,body = new_evar evd1 newenv ~src (subst1 (mkVar id) rng) ~filter in let lam = mkLambda (Name id, dom, subst_var id body) in Evd.define evk lam evd2, lam let define_evar_as_lambda env evd (evk,args) = let evd,lam = define_pure_evar_as_lambda env evd evk in (* Quick way to compute the instantiation of evk with args *) let na,dom,body = destLambda lam in let evbodyargs = array_cons (mkRel 1) (Array.map (lift 1) args) in let evbody = mkEvar (fst (destEvar body), evbodyargs) in evd,mkLambda (na, dom, evbody) let rec evar_absorb_arguments env evd (evk,args as ev) = function | [] -> evd,ev | a::l -> (* TODO: optimize and avoid introducing intermediate evars *) let evd,lam = define_pure_evar_as_lambda env evd evk in let _,_,body = destLambda lam in let evk = fst (destEvar body) in evar_absorb_arguments env evd (evk, array_cons a args) l (* Refining an evar to a sort *) let define_evar_as_sort evd (ev,args) = let evd, s = new_sort_variable evd in Evd.define ev (mkSort s) evd, s (* We don't try to guess in which sort the type should be defined, since any type has type Type. May cause some trouble, but not so far... *) let judge_of_new_Type evd = let evd', s = new_univ_variable evd in evd', Typeops.judge_of_type s (* Propagation of constraints through application and abstraction: Given a type constraint on a functional term, returns the type constraint on its domain and codomain. If the input constraint is an evar instantiate it with the product of 2 new evars. *) let unlift_tycon init cur c = if cur = 1 then None, c else Some (init, pred cur), c let split_tycon loc env evd tycon = let rec real_split evd c = let t = whd_betadeltaiota env evd c in match kind_of_term t with | Prod (na,dom,rng) -> evd, (na, dom, rng) | Evar ev (* ev is undefined because of whd_betadeltaiota *) -> let (evd',prod) = define_evar_as_product evd ev in let (_,dom,rng) = destProd prod in evd',(Anonymous, dom, rng) | App (c,args) when isEvar c -> let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in real_split evd' (mkApp (lam,args)) | _ -> error_not_product_loc loc env evd c in match tycon with | None -> evd,(Anonymous,None,None) | Some (abs, c) -> (match abs with None -> let evd', (n, dom, rng) = real_split evd c in evd', (n, mk_tycon dom, mk_tycon rng) | Some (init, cur) -> evd, (Anonymous, None, Some (unlift_tycon init cur c))) let valcon_of_tycon x = match x with | Some (None, t) -> Some t | _ -> None let lift_abstr_tycon_type n (abs, t) = match abs with None -> raise (Invalid_argument "lift_abstr_tycon_type: not an abstraction") | Some (init, abs) -> let abs' = abs + n in if abs' < 0 then raise (Invalid_argument "lift_abstr_tycon_type") else (Some (init, abs'), t) let lift_tycon_type n (abs, t) = (abs, lift n t) let lift_tycon n = Option.map (lift_tycon_type n) let pr_tycon_type env (abs, t) = match abs with None -> Termops.print_constr_env env t | Some (init, cur) -> str "Abstract (" ++ int init ++ str "," ++ int cur ++ str ") " ++ Termops.print_constr_env env t let pr_tycon env = function None -> str "None" | Some t -> pr_tycon_type env t coq-8.4pl4/LICENSE0000644000175000017500000005747512326224777012662 0ustar stephsteph 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 coq-8.4pl4/plugins/0000755000175000017500000000000012365131025013276 5ustar stephstephcoq-8.4pl4/plugins/plugins.itarget0000644000175000017500000000007012326224777016353 0ustar stephstephpluginsopt.otarget pluginsbyte.otarget pluginsvo.otargetcoq-8.4pl4/plugins/pluginsvo.itarget0000644000175000017500000000033712326224777016726 0ustar stephstephfield/vo.otarget fourier/vo.otarget funind/vo.otarget nsatz/vo.otarget micromega/vo.otarget omega/vo.otarget quote/vo.otarget ring/vo.otarget romega/vo.otarget rtauto/vo.otarget setoid_ring/vo.otarget extraction/vo.otarget coq-8.4pl4/plugins/pluginsopt.itarget0000644000175000017500000000117112326224777017101 0ustar stephstephfield/field_plugin.cmxa setoid_ring/newring_plugin.cmxa extraction/extraction_plugin.cmxa decl_mode/decl_mode_plugin.cmxa firstorder/ground_plugin.cmxa rtauto/rtauto_plugin.cmxa fourier/fourier_plugin.cmxa romega/romega_plugin.cmxa omega/omega_plugin.cmxa micromega/micromega_plugin.cmxa xml/xml_plugin.cmxa subtac/subtac_plugin.cmxa ring/ring_plugin.cmxa cc/cc_plugin.cmxa nsatz/nsatz_plugin.cmxa funind/recdef_plugin.cmxa syntax/ascii_syntax_plugin.cmxa syntax/nat_syntax_plugin.cmxa syntax/numbers_syntax_plugin.cmxa syntax/r_syntax_plugin.cmxa syntax/string_syntax_plugin.cmxa syntax/z_syntax_plugin.cmxa quote/quote_plugin.cmxa coq-8.4pl4/plugins/rtauto/0000755000175000017500000000000012365131025014614 5ustar stephstephcoq-8.4pl4/plugins/rtauto/Rtauto.v0000644000175000017500000002421712326224777016305 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* form | Arrow : form -> form -> form | Bot | Conjunct : form -> form -> form | Disjunct : form -> form -> form. Notation "[ n ]":=(Atom n). Notation "A =>> B":= (Arrow A B) (at level 59, right associativity). Notation "#" := Bot. Notation "A //\\ B" := (Conjunct A B) (at level 57, left associativity). Notation "A \\// B" := (Disjunct A B) (at level 58, left associativity). Definition ctx := Store form. Fixpoint pos_eq (m n:positive) {struct m} :bool := match m with xI mm => match n with xI nn => pos_eq mm nn | _ => false end | xO mm => match n with xO nn => pos_eq mm nn | _ => false end | xH => match n with xH => true | _ => false end end. Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n. induction m;simpl;destruct n;congruence || (intro e;apply f_equal;auto). Qed. Fixpoint form_eq (p q:form) {struct p} :bool := match p with Atom m => match q with Atom n => pos_eq m n | _ => false end | Arrow p1 p2 => match q with Arrow q1 q2 => form_eq p1 q1 && form_eq p2 q2 | _ => false end | Bot => match q with Bot => true | _ => false end | Conjunct p1 p2 => match q with Conjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 | _ => false end | Disjunct p1 p2 => match q with Disjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 | _ => false end end. Theorem form_eq_refl: forall p q, form_eq p q = true -> p = q. induction p;destruct q;simpl;clean. intro h;generalize (pos_eq_refl _ _ h);congruence. case_eq (form_eq p1 q1);clean. intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. case_eq (form_eq p1 q1);clean. intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. case_eq (form_eq p1 q1);clean. intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. Qed. Arguments form_eq_refl [p q] _. Section with_env. Variable env:Store Prop. Fixpoint interp_form (f:form): Prop := match f with [n]=> match get n env with PNone => True | PSome P => P end | A =>> B => (interp_form A) -> (interp_form B) | # => False | A //\\ B => (interp_form A) /\ (interp_form B) | A \\// B => (interp_form A) \/ (interp_form B) end. Notation "[[ A ]]" := (interp_form A). Fixpoint interp_ctx (hyps:ctx) (F:Full hyps) (G:Prop) {struct F} : Prop := match F with F_empty => G | F_push H hyps0 F0 => interp_ctx hyps0 F0 ([[H]] -> G) end. Require Export BinPos. Ltac wipe := intros;simpl;constructor. Lemma compose0 : forall hyps F (A:Prop), A -> (interp_ctx hyps F A). induction F;intros A H;simpl;auto. Qed. Lemma compose1 : forall hyps F (A B:Prop), (A -> B) -> (interp_ctx hyps F A) -> (interp_ctx hyps F B). induction F;intros A B H;simpl;auto. apply IHF;auto. Qed. Theorem compose2 : forall hyps F (A B C:Prop), (A -> B -> C) -> (interp_ctx hyps F A) -> (interp_ctx hyps F B) -> (interp_ctx hyps F C). induction F;intros A B C H;simpl;auto. apply IHF;auto. Qed. Theorem compose3 : forall hyps F (A B C D:Prop), (A -> B -> C -> D) -> (interp_ctx hyps F A) -> (interp_ctx hyps F B) -> (interp_ctx hyps F C) -> (interp_ctx hyps F D). induction F;intros A B C D H;simpl;auto. apply IHF;auto. Qed. Lemma weaken : forall hyps F f G, (interp_ctx hyps F G) -> (interp_ctx (hyps\f) (F_push f hyps F) G). induction F;simpl;intros;auto. apply compose1 with ([[a]]-> G);auto. Qed. Theorem project_In : forall hyps F g, In g hyps F -> interp_ctx hyps F [[g]]. induction F;simpl. contradiction. intros g H;destruct H. subst;apply compose0;simpl;trivial. apply compose1 with [[g]];auto. Qed. Theorem project : forall hyps F p g, get p hyps = PSome g-> interp_ctx hyps F [[g]]. intros hyps F p g e; apply project_In. apply get_In with p;assumption. Qed. Arguments project [hyps] F [p g] _. Inductive proof:Set := Ax : positive -> proof | I_Arrow : proof -> proof | E_Arrow : positive -> positive -> proof -> proof | D_Arrow : positive -> proof -> proof -> proof | E_False : positive -> proof | I_And: proof -> proof -> proof | E_And: positive -> proof -> proof | D_And: positive -> proof -> proof | I_Or_l: proof -> proof | I_Or_r: proof -> proof | E_Or: positive -> proof -> proof -> proof | D_Or: positive -> proof -> proof | Cut: form -> proof -> proof -> proof. Notation "hyps \ A" := (push A hyps) (at level 72,left associativity). Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool := match P with Ax i => match get i hyps with PSome F => form_eq F gl | _ => false end | I_Arrow p => match gl with A =>> B => check_proof (hyps \ A) B p | _ => false end | E_Arrow i j p => match get i hyps,get j hyps with PSome A,PSome (B =>>C) => form_eq A B && check_proof (hyps \ C) (gl) p | _,_ => false end | D_Arrow i p1 p2 => match get i hyps with PSome ((A =>>B)=>>C) => (check_proof ( hyps \ B =>> C \ A) B p1) && (check_proof (hyps \ C) gl p2) | _ => false end | E_False i => match get i hyps with PSome # => true | _ => false end | I_And p1 p2 => match gl with A //\\ B => check_proof hyps A p1 && check_proof hyps B p2 | _ => false end | E_And i p => match get i hyps with PSome (A //\\ B) => check_proof (hyps \ A \ B) gl p | _=> false end | D_And i p => match get i hyps with PSome (A //\\ B =>> C) => check_proof (hyps \ A=>>B=>>C) gl p | _=> false end | I_Or_l p => match gl with (A \\// B) => check_proof hyps A p | _ => false end | I_Or_r p => match gl with (A \\// B) => check_proof hyps B p | _ => false end | E_Or i p1 p2 => match get i hyps with PSome (A \\// B) => check_proof (hyps \ A) gl p1 && check_proof (hyps \ B) gl p2 | _=> false end | D_Or i p => match get i hyps with PSome (A \\// B =>> C) => (check_proof (hyps \ A=>>C \ B=>>C) gl p) | _=> false end | Cut A p1 p2 => check_proof hyps A p1 && check_proof (hyps \ A) gl p2 end. Theorem interp_proof: forall p hyps F gl, check_proof hyps gl p = true -> interp_ctx hyps F [[gl]]. induction p;intros hyps F gl. (* cas Axiom *) Focus 1. simpl;case_eq (get p hyps);clean. intros f nth_f e;rewrite <- (form_eq_refl e). apply project with p;trivial. (* Cas Arrow_Intro *) Focus 1. destruct gl;clean. simpl;intros. change (interp_ctx (hyps\gl1) (F_push gl1 hyps F) [[gl2]]). apply IHp;try constructor;trivial. (* Cas Arrow_Elim *) Focus 1. simpl check_proof;case_eq (get p hyps);clean. intros f ef;case_eq (get p0 hyps);clean. intros f0 ef0;destruct f0;clean. case_eq (form_eq f f0_1);clean. simpl;intros e check_p1. generalize (project F ef) (project F ef0) (IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1); clear check_p1 IHp p p0 p1 ef ef0. simpl. apply compose3. rewrite (form_eq_refl e). auto. (* cas Arrow_Destruct *) Focus 1. simpl;case_eq (get p1 hyps);clean. intros f ef;destruct f;clean. destruct f1;clean. case_eq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2);clean. intros check_p1 check_p2. generalize (project F ef) (IHp1 (hyps \ f1_2 =>> f2 \ f1_1) (F_push f1_1 (hyps \ f1_2 =>> f2) (F_push (f1_2 =>> f2) hyps F)) f1_2 check_p1) (IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2). simpl;apply compose3;auto. (* Cas False_Elim *) Focus 1. simpl;case_eq (get p hyps);clean. intros f ef;destruct f;clean. intros _; generalize (project F ef). apply compose1;apply False_ind. (* Cas And_Intro *) Focus 1. simpl;destruct gl;clean. case_eq (check_proof hyps gl1 p1);clean. intros Hp1 Hp2;generalize (IHp1 hyps F gl1 Hp1) (IHp2 hyps F gl2 Hp2). apply compose2 ;simpl;auto. (* cas And_Elim *) Focus 1. simpl;case_eq (get p hyps);clean. intros f ef;destruct f;clean. intro check_p;generalize (project F ef) (IHp (hyps \ f1 \ f2) (F_push f2 (hyps \ f1) (F_push f1 hyps F)) gl check_p). simpl;apply compose2;intros [h1 h2];auto. (* cas And_Destruct *) Focus 1. simpl;case_eq (get p hyps);clean. intros f ef;destruct f;clean. destruct f1;clean. intro H;generalize (project F ef) (IHp (hyps \ f1_1 =>> f1_2 =>> f2) (F_push (f1_1 =>> f1_2 =>> f2) hyps F) gl H);clear H;simpl. apply compose2;auto. (* cas Or_Intro_left *) Focus 1. destruct gl;clean. intro Hp;generalize (IHp hyps F gl1 Hp). apply compose1;simpl;auto. (* cas Or_Intro_right *) Focus 1. destruct gl;clean. intro Hp;generalize (IHp hyps F gl2 Hp). apply compose1;simpl;auto. (* cas Or_elim *) Focus 1. simpl;case_eq (get p1 hyps);clean. intros f ef;destruct f;clean. case_eq (check_proof (hyps \ f1) gl p2);clean. intros check_p1 check_p2;generalize (project F ef) (IHp1 (hyps \ f1) (F_push f1 hyps F) gl check_p1) (IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2); simpl;apply compose3;simpl;intro h;destruct h;auto. (* cas Or_Destruct *) Focus 1. simpl;case_eq (get p hyps);clean. intros f ef;destruct f;clean. destruct f1;clean. intro check_p0;generalize (project F ef) (IHp (hyps \ f1_1 =>> f2 \ f1_2 =>> f2) (F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2) (F_push (f1_1 =>> f2) hyps F)) gl check_p0);simpl. apply compose2;auto. (* cas Cut *) Focus 1. simpl;case_eq (check_proof hyps f p1);clean. intros check_p1 check_p2; generalize (IHp1 hyps F f check_p1) (IHp2 (hyps\f) (F_push f hyps F) gl check_p2); simpl; apply compose2;auto. Qed. Theorem Reflect: forall gl prf, if check_proof empty gl prf then [[gl]] else True. intros gl prf;case_eq (check_proof empty gl prf);intro check_prf. change (interp_ctx empty F_empty [[gl]]) ; apply interp_proof with prf;assumption. trivial. Qed. End with_env. (* (* A small example *) Parameters A B C D:Prop. Theorem toto:A /\ (B \/ C) -> (A /\ B) \/ (A /\ C). exact (Reflect (empty \ A \ B \ C) ([1] //\\ ([2] \\// [3]) =>> [1] //\\ [2] \\// [1] //\\ [3]) (I_Arrow (E_And 1 (E_Or 3 (I_Or_l (I_And (Ax 2) (Ax 4))) (I_Or_r (I_And (Ax 2) (Ax 4))))))). Qed. Print toto. *) coq-8.4pl4/plugins/rtauto/vo.itarget0000644000175000017500000000002512326224777016634 0ustar stephstephBintree.vo Rtauto.vo coq-8.4pl4/plugins/rtauto/rtauto_plugin.mllib0000644000175000017500000000006312326224777020546 0ustar stephstephProof_search Refl_tauto G_rtauto Rtauto_plugin_mod coq-8.4pl4/plugins/rtauto/refl_tauto.ml0000644000175000017500000002351212326224777017333 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Closure.whd_val infos (Closure.inject t)) let special_nf gl= let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in (fun t -> Closure.norm_val infos (Closure.inject t)) type atom_env= {mutable next:int; mutable env:(constr*int) list} let make_atom atom_env term= try let (_,i)= List.find (fun (t,_)-> eq_constr term t) atom_env.env in Atom i with Not_found -> let i=atom_env.next in atom_env.env <- (term,i)::atom_env.env; atom_env.next<- i + 1; Atom i let rec make_form atom_env gls term = let normalize=special_nf gls in let cciterm=special_whd gls term in match kind_of_term cciterm with Prod(_,a,b) -> if not (Termops.dependent (mkRel 1) b) && Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) a = InProp then let fa=make_form atom_env gls a in let fb=make_form atom_env gls b in Arrow (fa,fb) else make_atom atom_env (normalize term) | Cast(a,_,_) -> make_form atom_env gls a | Ind ind -> if ind = Lazy.force li_False then Bot else make_atom atom_env (normalize term) | App(hd,argv) when Array.length argv = 2 -> begin try let ind = destInd hd in if ind = Lazy.force li_and then let fa=make_form atom_env gls argv.(0) in let fb=make_form atom_env gls argv.(1) in Conjunct (fa,fb) else if ind = Lazy.force li_or then let fa=make_form atom_env gls argv.(0) in let fb=make_form atom_env gls argv.(1) in Disjunct (fa,fb) else make_atom atom_env (normalize term) with Invalid_argument _ -> make_atom atom_env (normalize term) end | _ -> make_atom atom_env (normalize term) let rec make_hyps atom_env gls lenv = function [] -> [] | (_,Some body,typ)::rest -> make_hyps atom_env gls (typ::body::lenv) rest | (id,None,typ)::rest -> let hrec= make_hyps atom_env gls (typ::lenv) rest in if List.exists (Termops.dependent (mkVar id)) lenv || (Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) typ <> InProp) then hrec else (id,make_form atom_env gls typ)::hrec let rec build_pos n = if n<=1 then force node_count l_xH else if n land 1 = 0 then mkApp (force node_count l_xO,[|build_pos (n asr 1)|]) else mkApp (force node_count l_xI,[|build_pos (n asr 1)|]) let rec build_form = function Atom n -> mkApp (force node_count l_Atom,[|build_pos n|]) | Arrow (f1,f2) -> mkApp (force node_count l_Arrow,[|build_form f1;build_form f2|]) | Bot -> force node_count l_Bot | Conjunct (f1,f2) -> mkApp (force node_count l_Conjunct,[|build_form f1;build_form f2|]) | Disjunct (f1,f2) -> mkApp (force node_count l_Disjunct,[|build_form f1;build_form f2|]) let rec decal k = function [] -> k | (start,delta)::rest -> if k>start then k - delta else decal k rest let add_pop size d pops= match pops with [] -> [size+d,d] | (_,sum)::_ -> (size+sum,sum+d)::pops let rec build_proof pops size = function Ax i -> mkApp (force step_count l_Ax, [|build_pos (decal i pops)|]) | I_Arrow p -> mkApp (force step_count l_I_Arrow, [|build_proof pops (size + 1) p|]) | E_Arrow(i,j,p) -> mkApp (force step_count l_E_Arrow, [|build_pos (decal i pops); build_pos (decal j pops); build_proof pops (size + 1) p|]) | D_Arrow(i,p1,p2) -> mkApp (force step_count l_D_Arrow, [|build_pos (decal i pops); build_proof pops (size + 2) p1; build_proof pops (size + 1) p2|]) | E_False i -> mkApp (force step_count l_E_False, [|build_pos (decal i pops)|]) | I_And(p1,p2) -> mkApp (force step_count l_I_And, [|build_proof pops size p1; build_proof pops size p2|]) | E_And(i,p) -> mkApp (force step_count l_E_And, [|build_pos (decal i pops); build_proof pops (size + 2) p|]) | D_And(i,p) -> mkApp (force step_count l_D_And, [|build_pos (decal i pops); build_proof pops (size + 1) p|]) | I_Or_l(p) -> mkApp (force step_count l_I_Or_l, [|build_proof pops size p|]) | I_Or_r(p) -> mkApp (force step_count l_I_Or_r, [|build_proof pops size p|]) | E_Or(i,p1,p2) -> mkApp (force step_count l_E_Or, [|build_pos (decal i pops); build_proof pops (size + 1) p1; build_proof pops (size + 1) p2|]) | D_Or(i,p) -> mkApp (force step_count l_D_Or, [|build_pos (decal i pops); build_proof pops (size + 2) p|]) | Pop(d,p) -> build_proof (add_pop size d pops) size p let build_env gamma= List.fold_right (fun (p,_) e -> mkApp(force node_count l_push,[|mkProp;p;e|])) gamma.env (mkApp (force node_count l_empty,[|mkProp|])) open Goptions let verbose = ref false let opt_verbose= {optsync=true; optdepr=false; optname="Rtauto Verbose"; optkey=["Rtauto";"Verbose"]; optread=(fun () -> !verbose); optwrite=(fun b -> verbose:=b)} let _ = declare_bool_option opt_verbose let check = ref false let opt_check= {optsync=true; optdepr=false; optname="Rtauto Check"; optkey=["Rtauto";"Check"]; optread=(fun () -> !check); optwrite=(fun b -> check:=b)} let _ = declare_bool_option opt_check open Pp let rtauto_tac gls= Coqlib.check_required_library ["Coq";"rtauto";"Rtauto"]; let gamma={next=1;env=[]} in let gl=pf_concl gls in let _= if Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) gl <> InProp then errorlabstrm "rtauto" (Pp.str "goal should be in Prop") in let glf=make_form gamma gls gl in let hyps=make_hyps gamma gls [gl] (pf_hyps gls) in let formula= List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in let search_fun = if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 then Search.debug_depth_first else Search.depth_first in let _ = begin reset_info (); if !verbose then msgnl (str "Starting proof-search ..."); end in let search_start_time = System.get_time () in let prf = try project (search_fun (init_state [] formula)) with Not_found -> errorlabstrm "rtauto" (Pp.str "rtauto couldn't find any proof") in let search_end_time = System.get_time () in let _ = if !verbose then begin msgnl (str "Proof tree found in " ++ System.fmt_time_difference search_start_time search_end_time); pp_info (); msgnl (str "Building proof term ... ") end in let build_start_time=System.get_time () in let _ = step_count := 0; node_count := 0 in let main = mkApp (force node_count l_Reflect, [|build_env gamma; build_form formula; build_proof [] 0 prf|]) in let term= Term.applist (main,List.rev_map (fun (id,_) -> mkVar id) hyps) in let build_end_time=System.get_time () in let _ = if !verbose then begin msgnl (str "Proof term built in " ++ System.fmt_time_difference build_start_time build_end_time ++ fnl () ++ str "Proof size : " ++ int !step_count ++ str " steps" ++ fnl () ++ str "Proof term size : " ++ int (!step_count+ !node_count) ++ str " nodes (constants)" ++ fnl () ++ str "Giving proof term to Coq ... ") end in let tac_start_time = System.get_time () in let result= if !check then Tactics.exact_check term gls else Tactics.exact_no_check term gls in let tac_end_time = System.get_time () in let _ = if !check then msgnl (str "Proof term type-checking is on"); if !verbose then msgnl (str "Internal tactic executed in " ++ System.fmt_time_difference tac_start_time tac_end_time) in result coq-8.4pl4/plugins/rtauto/proof_search.ml0000644000175000017500000003417212326224777017645 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* !pruning); optwrite=(fun b -> pruning:=b)} let _ = declare_bool_option opt_pruning type form= Atom of int | Arrow of form * form | Bot | Conjunct of form * form | Disjunct of form * form type tag=int let decomp_form=function Atom i -> Some (i,[]) | Arrow (f1,f2) -> Some (-1,[f1;f2]) | Bot -> Some (-2,[]) | Conjunct (f1,f2) -> Some (-3,[f1;f2]) | Disjunct (f1,f2) -> Some (-4,[f1;f2]) module Fmap=Map.Make(struct type t=form let compare=compare end) type sequent = {rev_hyps: form Intmap.t; norev_hyps: form Intmap.t; size:int; left:int Fmap.t; right:(int*form) list Fmap.t; cnx:(int*int*form*form) list; abs:int option; gl:form} let add_one_arrow i f1 f2 m= try Fmap.add f1 ((i,f2)::(Fmap.find f1 m)) m with Not_found -> Fmap.add f1 [i,f2] m type proof = Ax of int | I_Arrow of proof | E_Arrow of int*int*proof | D_Arrow of int*proof*proof | E_False of int | I_And of proof*proof | E_And of int*proof | D_And of int*proof | I_Or_l of proof | I_Or_r of proof | E_Or of int*proof*proof | D_Or of int*proof | Pop of int*proof type rule = SAx of int | SI_Arrow | SE_Arrow of int*int | SD_Arrow of int | SE_False of int | SI_And | SE_And of int | SD_And of int | SI_Or_l | SI_Or_r | SE_Or of int | SD_Or of int let add_step s sub = match s,sub with SAx i,[] -> Ax i | SI_Arrow,[p] -> I_Arrow p | SE_Arrow(i,j),[p] -> E_Arrow (i,j,p) | SD_Arrow i,[p1;p2] -> D_Arrow (i,p1,p2) | SE_False i,[] -> E_False i | SI_And,[p1;p2] -> I_And(p1,p2) | SE_And i,[p] -> E_And(i,p) | SD_And i,[p] -> D_And(i,p) | SI_Or_l,[p] -> I_Or_l p | SI_Or_r,[p] -> I_Or_r p | SE_Or i,[p1;p2] -> E_Or(i,p1,p2) | SD_Or i,[p] -> D_Or(i,p) | _,_ -> anomaly "add_step: wrong arity" type 'a with_deps = {dep_it:'a; dep_goal:bool; dep_hyps:Intset.t} type slice= {proofs_done:proof list; proofs_todo:sequent with_deps list; step:rule; needs_goal:bool; needs_hyps:Intset.t; changes_goal:bool; creates_hyps:Intset.t} type state = Complete of proof | Incomplete of sequent * slice list let project = function Complete prf -> prf | Incomplete (_,_) -> anomaly "not a successful state" let pop n prf = let nprf= match prf.dep_it with Pop (i,p) -> Pop (i+n,p) | p -> Pop(n,p) in {prf with dep_it = nprf} let rec fill stack proof = match stack with [] -> Complete proof.dep_it | slice::super -> if !pruning && slice.proofs_done=[] && not (slice.changes_goal && proof.dep_goal) && not (Intset.exists (fun i -> Intset.mem i proof.dep_hyps) slice.creates_hyps) then begin s_info.pruned_steps<-s_info.pruned_steps+1; s_info.pruned_branches<- s_info.pruned_branches + List.length slice.proofs_todo; let created_here=Intset.cardinal slice.creates_hyps in s_info.pruned_hyps<-s_info.pruned_hyps+ List.fold_left (fun sum dseq -> sum + Intset.cardinal dseq.dep_hyps) created_here slice.proofs_todo; fill super (pop (Intset.cardinal slice.creates_hyps) proof) end else let dep_hyps= Intset.union slice.needs_hyps (Intset.diff proof.dep_hyps slice.creates_hyps) in let dep_goal= slice.needs_goal || ((not slice.changes_goal) && proof.dep_goal) in let proofs_done= proof.dep_it::slice.proofs_done in match slice.proofs_todo with [] -> fill super {dep_it = add_step slice.step (List.rev proofs_done); dep_goal = dep_goal; dep_hyps = dep_hyps} | current::next -> let nslice= {proofs_done=proofs_done; proofs_todo=next; step=slice.step; needs_goal=dep_goal; needs_hyps=dep_hyps; changes_goal=current.dep_goal; creates_hyps=current.dep_hyps} in Incomplete (current.dep_it,nslice::super) let append stack (step,subgoals) = s_info.created_steps<-s_info.created_steps+1; match subgoals with [] -> s_info.branch_successes<-s_info.branch_successes+1; fill stack {dep_it=add_step step.dep_it []; dep_goal=step.dep_goal; dep_hyps=step.dep_hyps} | hd :: next -> s_info.created_branches<- s_info.created_branches+List.length next; let slice= {proofs_done=[]; proofs_todo=next; step=step.dep_it; needs_goal=step.dep_goal; needs_hyps=step.dep_hyps; changes_goal=hd.dep_goal; creates_hyps=hd.dep_hyps} in Incomplete(hd.dep_it,slice::stack) let embed seq= {dep_it=seq; dep_goal=false; dep_hyps=Intset.empty} let change_goal seq gl= {seq with dep_it={seq.dep_it with gl=gl}; dep_goal=true} let add_hyp seqwd f= s_info.created_hyps<-s_info.created_hyps+1; let seq=seqwd.dep_it in let num = seq.size+1 in let left = Fmap.add f num seq.left in let cnx,right= try let l=Fmap.find f seq.right in List.fold_right (fun (i,f0) l0 -> (num,i,f,f0)::l0) l seq.cnx, Fmap.remove f seq.right with Not_found -> seq.cnx,seq.right in let nseq= match f with Bot -> {seq with left=left; right=right; size=num; abs=Some num; cnx=cnx} | Atom _ -> {seq with size=num; left=left; right=right; cnx=cnx} | Conjunct (_,_) | Disjunct (_,_) -> {seq with rev_hyps=Intmap.add num f seq.rev_hyps; size=num; left=left; right=right; cnx=cnx} | Arrow (f1,f2) -> let ncnx,nright= try let i = Fmap.find f1 seq.left in (i,num,f1,f2)::cnx,right with Not_found -> cnx,(add_one_arrow num f1 f2 right) in match f1 with Conjunct (_,_) | Disjunct (_,_) -> {seq with rev_hyps=Intmap.add num f seq.rev_hyps; size=num; left=left; right=nright; cnx=ncnx} | Arrow(_,_) -> {seq with norev_hyps=Intmap.add num f seq.norev_hyps; size=num; left=left; right=nright; cnx=ncnx} | _ -> {seq with size=num; left=left; right=nright; cnx=ncnx} in {seqwd with dep_it=nseq; dep_hyps=Intset.add num seqwd.dep_hyps} exception Here_is of (int*form) let choose m= try Intmap.iter (fun i f -> raise (Here_is (i,f))) m; raise Not_found with Here_is (i,f) -> (i,f) let search_or seq= match seq.gl with Disjunct (f1,f2) -> [{dep_it = SI_Or_l; dep_goal = true; dep_hyps = Intset.empty}, [change_goal (embed seq) f1]; {dep_it = SI_Or_r; dep_goal = true; dep_hyps = Intset.empty}, [change_goal (embed seq) f2]] | _ -> [] let search_norev seq= let goals=ref (search_or seq) in let add_one i f= match f with Arrow (Arrow (f1,f2),f3) -> let nseq = {seq with norev_hyps=Intmap.remove i seq.norev_hyps} in goals:= ({dep_it=SD_Arrow(i); dep_goal=false; dep_hyps=Intset.singleton i}, [add_hyp (add_hyp (change_goal (embed nseq) f2) (Arrow(f2,f3))) f1; add_hyp (embed nseq) f3]):: !goals | _ -> anomaly "search_no_rev: can't happen" in Intmap.iter add_one seq.norev_hyps; List.rev !goals let search_in_rev_hyps seq= try let i,f=choose seq.rev_hyps in let make_step step= {dep_it=step; dep_goal=false; dep_hyps=Intset.singleton i} in let nseq={seq with rev_hyps=Intmap.remove i seq.rev_hyps} in match f with Conjunct (f1,f2) -> [make_step (SE_And(i)), [add_hyp (add_hyp (embed nseq) f1) f2]] | Disjunct (f1,f2) -> [make_step (SE_Or(i)), [add_hyp (embed nseq) f1;add_hyp (embed nseq) f2]] | Arrow (Conjunct (f1,f2),f0) -> [make_step (SD_And(i)), [add_hyp (embed nseq) (Arrow (f1,Arrow (f2,f0)))]] | Arrow (Disjunct (f1,f2),f0) -> [make_step (SD_Or(i)), [add_hyp (add_hyp (embed nseq) (Arrow(f1,f0))) (Arrow (f2,f0))]] | _ -> anomaly "search_in_rev_hyps: can't happen" with Not_found -> search_norev seq let search_rev seq= match seq.cnx with (i,j,f1,f2)::next -> let nseq= match f1 with Conjunct (_,_) | Disjunct (_,_) -> {seq with cnx=next; rev_hyps=Intmap.remove j seq.rev_hyps} | Arrow (_,_) -> {seq with cnx=next; norev_hyps=Intmap.remove j seq.norev_hyps} | _ -> {seq with cnx=next} in [{dep_it=SE_Arrow(i,j); dep_goal=false; dep_hyps=Intset.add i (Intset.singleton j)}, [add_hyp (embed nseq) f2]] | [] -> match seq.gl with Arrow (f1,f2) -> [{dep_it=SI_Arrow; dep_goal=true; dep_hyps=Intset.empty}, [add_hyp (change_goal (embed seq) f2) f1]] | Conjunct (f1,f2) -> [{dep_it=SI_And; dep_goal=true; dep_hyps=Intset.empty},[change_goal (embed seq) f1; change_goal (embed seq) f2]] | _ -> search_in_rev_hyps seq let search_all seq= match seq.abs with Some i -> [{dep_it=SE_False (i); dep_goal=false; dep_hyps=Intset.singleton i},[]] | None -> try let ax = Fmap.find seq.gl seq.left in [{dep_it=SAx (ax); dep_goal=true; dep_hyps=Intset.singleton ax},[]] with Not_found -> search_rev seq let bare_sequent = embed {rev_hyps=Intmap.empty; norev_hyps=Intmap.empty; size=0; left=Fmap.empty; right=Fmap.empty; cnx=[]; abs=None; gl=Bot} let init_state hyps gl= let init = change_goal bare_sequent gl in let goal=List.fold_right (fun (_,f,_) seq ->add_hyp seq f) hyps init in Incomplete (goal.dep_it,[]) let success= function Complete _ -> true | Incomplete (_,_) -> false let branching = function Incomplete (seq,stack) -> check_for_interrupt (); let successors = search_all seq in let _ = match successors with [] -> s_info.branch_failures<-s_info.branch_failures+1 | _::next -> s_info.nd_branching<-s_info.nd_branching+List.length next in List.map (append stack) successors | Complete prf -> anomaly "already succeeded" open Pp let rec pp_form = function Arrow(f1,f2) -> (pp_or f1) ++ (str " -> ") ++ (pp_form f2) | f -> pp_or f and pp_or = function Disjunct(f1,f2) -> (pp_or f1) ++ (str " \\/ ") ++ (pp_and f2) | f -> pp_and f and pp_and = function Conjunct(f1,f2) -> (pp_and f1) ++ (str " /\\ ") ++ (pp_atom f2) | f -> pp_atom f and pp_atom= function Bot -> str "#" | Atom n -> int n | f -> str "(" ++ hv 2 (pp_form f) ++ str ")" let pr_form f = msg (pp_form f) let pp_intmap map = let pp=ref (str "") in Intmap.iter (fun i obj -> pp:= (!pp ++ pp_form obj ++ cut ())) map; str "{ " ++ v 0 (!pp) ++ str " }" let pp_list pp_obj l= let pp=ref (str "") in List.iter (fun o -> pp := !pp ++ (pp_obj o) ++ str ", ") l; str "[ " ++ !pp ++ str "]" let pp_mapint map = let pp=ref (str "") in Fmap.iter (fun obj l -> pp:= (!pp ++ pp_form obj ++ str " => " ++ pp_list (fun (i,f) -> pp_form f) l ++ cut ()) ) map; str "{ " ++ vb 0 ++ (!pp) ++ str " }" ++ close () let pp_connect (i,j,f1,f2) = pp_form f1 ++ str " => " ++ pp_form f2 let pp_gl gl= cut () ++ str "{ " ++ vb 0 ++ begin match gl.abs with None -> str "" | Some i -> str "ABSURD" ++ cut () end ++ str "rev =" ++ pp_intmap gl.rev_hyps ++ cut () ++ str "norev =" ++ pp_intmap gl.norev_hyps ++ cut () ++ str "arrows=" ++ pp_mapint gl.right ++ cut () ++ str "cnx =" ++ pp_list pp_connect gl.cnx ++ cut () ++ str "goal =" ++ pp_form gl.gl ++ str " }" ++ close () let pp = function Incomplete(gl,ctx) -> pp_gl gl ++ fnl () | _ -> str "" let pp_info () = let count_info = if !pruning then str "Proof steps : " ++ int s_info.created_steps ++ str " created / " ++ int s_info.pruned_steps ++ str " pruned" ++ fnl () ++ str "Proof branches : " ++ int s_info.created_branches ++ str " created / " ++ int s_info.pruned_branches ++ str " pruned" ++ fnl () ++ str "Hypotheses : " ++ int s_info.created_hyps ++ str " created / " ++ int s_info.pruned_hyps ++ str " pruned" ++ fnl () else str "Pruning is off" ++ fnl () ++ str "Proof steps : " ++ int s_info.created_steps ++ str " created" ++ fnl () ++ str "Proof branches : " ++ int s_info.created_branches ++ str " created" ++ fnl () ++ str "Hypotheses : " ++ int s_info.created_hyps ++ str " created" ++ fnl () in msgnl ( str "Proof-search statistics :" ++ fnl () ++ count_info ++ str "Branch ends: " ++ int s_info.branch_successes ++ str " successes / " ++ int s_info.branch_failures ++ str " failures" ++ fnl () ++ str "Non-deterministic choices : " ++ int s_info.nd_branching ++ str " branches") coq-8.4pl4/plugins/rtauto/refl_tauto.mli0000644000175000017500000000173412326224777017506 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Proof_type.goal Tacmach.sigma -> Term.types -> Proof_search.form val make_hyps : atom_env -> Proof_type.goal Tacmach.sigma -> Term.types list -> (Names.identifier * Term.types option * Term.types) list -> (Names.identifier * Proof_search.form) list val rtauto_tac : Proof_type.tactic coq-8.4pl4/plugins/rtauto/proof_search.mli0000644000175000017500000000232212326224777020006 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* proof val init_state : ('a * form * 'b) list -> form -> state val branching: state -> state list val success: state -> bool val pp: state -> Pp.std_ppcmds val pr_form : form -> unit val reset_info : unit -> unit val pp_info : unit -> unit coq-8.4pl4/plugins/rtauto/g_rtauto.ml40000644000175000017500000000120012326224777017065 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ Refl_tauto.rtauto_tac ] END coq-8.4pl4/plugins/rtauto/Bintree.v0000644000175000017500000002226212326224777016415 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (p ?= q) = Gt. Proof. intros. rewrite <- Pos.compare_succ_succ. now apply Pos.lt_gt, Pos.lt_lt_succ, Pos.gt_lt. Qed. Lemma Psucc_Gt : forall p, (Pos.succ p ?= p) = Gt. Proof. intros. apply Pos.lt_gt, Pos.lt_succ_diag_r. Qed. Fixpoint Lget (A:Set) (n:nat) (l:list A) {struct l}:option A := match l with nil => None | x::q => match n with O => Some x | S m => Lget A m q end end . Arguments Lget [A] n l. Lemma map_app : forall (A B:Set) (f:A -> B) l m, List.map f (l ++ m) = List.map f l ++ List.map f m. induction l. reflexivity. simpl. intro m ; apply f_equal;apply IHl. Qed. Lemma length_map : forall (A B:Set) (f:A -> B) l, length (List.map f l) = length l. induction l. reflexivity. simpl; apply f_equal;apply IHl. Qed. Lemma Lget_map : forall (A B:Set) (f:A -> B) i l, Lget i (List.map f l) = match Lget i l with Some a => Some (f a) | None => None end. induction i;intros [ | x l ] ;trivial. simpl;auto. Qed. Lemma Lget_app : forall (A:Set) (a:A) l i, Lget i (l ++ a :: nil) = if Arith.EqNat.beq_nat i (length l) then Some a else Lget i l. Proof. induction l;simpl Lget;simpl length. intros [ | i];simpl;reflexivity. intros [ | i];simpl. reflexivity. auto. Qed. Lemma Lget_app_Some : forall (A:Set) l delta i (a: A), Lget i l = Some a -> Lget i (l ++ delta) = Some a. induction l;destruct i;simpl;try congruence;auto. Qed. Section Store. Variable A:Type. Inductive Poption : Type:= PSome : A -> Poption | PNone : Poption. Inductive Tree : Type := Tempty : Tree | Branch0 : Tree -> Tree -> Tree | Branch1 : A -> Tree -> Tree -> Tree. Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption := match T with Tempty => PNone | Branch0 T1 T2 => match p with xI pp => Tget pp T2 | xO pp => Tget pp T1 | xH => PNone end | Branch1 a T1 T2 => match p with xI pp => Tget pp T2 | xO pp => Tget pp T1 | xH => PSome a end end. Fixpoint Tadd (p:positive) (a:A) (T:Tree) {struct p}: Tree := match T with | Tempty => match p with | xI pp => Branch0 Tempty (Tadd pp a Tempty) | xO pp => Branch0 (Tadd pp a Tempty) Tempty | xH => Branch1 a Tempty Tempty end | Branch0 T1 T2 => match p with | xI pp => Branch0 T1 (Tadd pp a T2) | xO pp => Branch0 (Tadd pp a T1) T2 | xH => Branch1 a T1 T2 end | Branch1 b T1 T2 => match p with | xI pp => Branch1 b T1 (Tadd pp a T2) | xO pp => Branch1 b (Tadd pp a T1) T2 | xH => Branch1 a T1 T2 end end. Definition mkBranch0 (T1 T2:Tree) := match T1,T2 with Tempty ,Tempty => Tempty | _,_ => Branch0 T1 T2 end. Fixpoint Tremove (p:positive) (T:Tree) {struct p}: Tree := match T with | Tempty => Tempty | Branch0 T1 T2 => match p with | xI pp => mkBranch0 T1 (Tremove pp T2) | xO pp => mkBranch0 (Tremove pp T1) T2 | xH => T end | Branch1 b T1 T2 => match p with | xI pp => Branch1 b T1 (Tremove pp T2) | xO pp => Branch1 b (Tremove pp T1) T2 | xH => mkBranch0 T1 T2 end end. Theorem Tget_Tempty: forall (p : positive), Tget p (Tempty) = PNone. destruct p;reflexivity. Qed. Theorem Tget_Tadd: forall i j a T, Tget i (Tadd j a T) = match (i ?= j) with Eq => PSome a | Lt => Tget i T | Gt => Tget i T end. Proof. intros i j. case_eq (i ?= j). intro H;rewrite (Pos.compare_eq _ _ H);intros a;clear i H. induction j;destruct T;simpl;try (apply IHj);congruence. unfold Pos.compare. generalize i;clear i;induction j;destruct T;simpl in H|-*; destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. unfold Pos.compare. generalize i;clear i;induction j;destruct T;simpl in H|-*; destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. Qed. Record Store : Type := mkStore {index:positive;contents:Tree}. Definition empty := mkStore xH Tempty. Definition push a S := mkStore (Pos.succ (index S)) (Tadd (index S) a (contents S)). Definition get i S := Tget i (contents S). Lemma get_empty : forall i, get i empty = PNone. intro i; case i; unfold empty,get; simpl;reflexivity. Qed. Inductive Full : Store -> Type:= F_empty : Full empty | F_push : forall a S, Full S -> Full (push a S). Theorem get_Full_Gt : forall S, Full S -> forall i, (i ?= index S) = Gt -> get i S = PNone. Proof. intros S W;induction W. unfold empty,index,get,contents;intros;apply Tget_Tempty. unfold index,get,push;simpl contents. intros i e;rewrite Tget_Tadd. rewrite (Gt_Psucc _ _ e). unfold get in IHW. apply IHW;apply Gt_Psucc;assumption. Qed. Theorem get_Full_Eq : forall S, Full S -> get (index S) S = PNone. intros [index0 contents0] F. case F. unfold empty,index,get,contents;intros;apply Tget_Tempty. unfold index,get,push;simpl contents. intros a S. rewrite Tget_Tadd. rewrite Psucc_Gt. intro W. change (get (Pos.succ (index S)) S =PNone). apply get_Full_Gt; auto. apply Psucc_Gt. Qed. Theorem get_push_Full : forall i a S, Full S -> get i (push a S) = match (i ?= index S) with Eq => PSome a | Lt => get i S | Gt => PNone end. Proof. intros i a S F. case_eq (i ?= index S). intro e;rewrite (Pos.compare_eq _ _ e). destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd. rewrite Pos.compare_refl;reflexivity. intros;destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd. simpl index in H;rewrite H;reflexivity. intro H;generalize H;clear H. unfold get,push;simpl index;simpl contents. rewrite Tget_Tadd;intro e;rewrite e. change (get i S=PNone). apply get_Full_Gt;auto. Qed. Lemma Full_push_compat : forall i a S, Full S -> forall x, get i S = PSome x -> get i (push a S) = PSome x. Proof. intros i a S F x H. case_eq (i ?= index S);intro test. rewrite (Pos.compare_eq _ _ test) in H. rewrite (get_Full_Eq _ F) in H;congruence. rewrite <- H. rewrite (get_push_Full i a). rewrite test;reflexivity. assumption. rewrite (get_Full_Gt _ F) in H;congruence. Qed. Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty. intros [ind cont] F one; inversion F. reflexivity. simpl index in one;assert (h:=Pos.succ_not_1 (index S)). congruence. Qed. Lemma push_not_empty: forall a S, (push a S) <> empty. intros a [ind cont];unfold push,empty. simpl;intro H;injection H; intros _ ; apply Pos.succ_not_1. Qed. Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop := match F with F_empty => False | F_push a SS FF => x=a \/ In x SS FF end. Lemma get_In : forall (x:A) (S:Store) (F:Full S) i , get i S = PSome x -> In x S F. induction F. intro i;rewrite get_empty; congruence. intro i;rewrite get_push_Full;trivial. case_eq (i ?= index S);simpl. left;congruence. right;eauto. congruence. Qed. End Store. Arguments PNone [A]. Arguments PSome [A] _. Arguments Tempty [A]. Arguments Branch0 [A] _ _. Arguments Branch1 [A] _ _ _. Arguments Tget [A] p T. Arguments Tadd [A] p a T. Arguments Tget_Tempty [A] p. Arguments Tget_Tadd [A] i j a T. Arguments mkStore [A] index contents. Arguments index [A] s. Arguments contents [A] s. Arguments empty [A]. Arguments get [A] i S. Arguments push [A] a S. Arguments get_empty [A] i. Arguments get_push_Full [A] i a S _. Arguments Full [A] _. Arguments F_empty [A]. Arguments F_push [A] a S _. Arguments In [A] x S F. Section Map. Variables A B:Set. Variable f: A -> B. Fixpoint Tmap (T: Tree A) : Tree B := match T with Tempty => Tempty | Branch0 t1 t2 => Branch0 (Tmap t1) (Tmap t2) | Branch1 a t1 t2 => Branch1 (f a) (Tmap t1) (Tmap t2) end. Lemma Tget_Tmap: forall T i, Tget i (Tmap T)= match Tget i T with PNone => PNone | PSome a => PSome (f a) end. induction T;intro i;case i;simpl;auto. Defined. Lemma Tmap_Tadd: forall i a T, Tmap (Tadd i a T) = Tadd i (f a) (Tmap T). induction i;intros a T;case T;simpl;intros;try (rewrite IHi);simpl;reflexivity. Defined. Definition map (S:Store A) : Store B := mkStore (index S) (Tmap (contents S)). Lemma get_map: forall i S, get i (map S)= match get i S with PNone => PNone | PSome a => PSome (f a) end. destruct S;unfold get,map,contents,index;apply Tget_Tmap. Defined. Lemma map_push: forall a S, map (push a S) = push (f a) (map S). intros a S. case S. unfold push,map,contents,index. intros;rewrite Tmap_Tadd;reflexivity. Defined. Theorem Full_map : forall S, Full S -> Full (map S). intros S F. induction F. exact F_empty. rewrite map_push;constructor 2;assumption. Defined. End Map. Arguments Tmap [A B] f T. Arguments map [A B] f S. Arguments Full_map [A B f] S _. Notation "hyps \ A" := (push A hyps) (at level 72,left associativity). coq-8.4pl4/plugins/omega/0000755000175000017500000000000012365131025014366 5ustar stephstephcoq-8.4pl4/plugins/omega/omega.ml0000644000175000017500000006355212326224777016041 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bigint -> bool val add : bigint -> bigint -> bigint val sub : bigint -> bigint -> bigint val mult : bigint -> bigint -> bigint val euclid : bigint -> bigint -> bigint * bigint val neg : bigint -> bigint val zero : bigint val one : bigint val to_string : bigint -> string end let debug = ref false module MakeOmegaSolver (Int:INT) = struct type bigint = Int.bigint let (?) x y = Int.less_than y x let (>=?) x y = Int.less_than y x or x = y let (=?) = (=) let (+) = Int.add let (-) = Int.sub let ( * ) = Int.mult let (/) x y = fst (Int.euclid x y) let (mod) x y = snd (Int.euclid x y) let zero = Int.zero let one = Int.one let two = one + one let negone = Int.neg one let abs x = if Int.less_than x zero then Int.neg x else x let string_of_bigint = Int.to_string let neg = Int.neg (* To ensure that polymorphic (<) is not used mistakenly on big integers *) (* Warning: do not use (=) either on big int *) let (<) = ((<) : int -> int -> bool) let (>) = ((>) : int -> int -> bool) let (<=) = ((<=) : int -> int -> bool) let (>=) = ((>=) : int -> int -> bool) let pp i = print_int i; print_newline (); flush stdout let push v l = l := v :: !l let rec pgcd x y = if y =? zero then x else pgcd y (x mod y) let pgcd_l = function | [] -> failwith "pgcd_l" | x :: l -> List.fold_left pgcd x l let floor_div a b = match a >=? zero , b >? zero with | true,true -> a / b | false,false -> a / b | true, false -> (a-one) / b - one | false,true -> (a+one) / b - one type coeff = {c: bigint ; v: int} type linear = coeff list type eqn_kind = EQUA | INEQ | DISE type afine = { (* a number uniquely identifying the equation *) id: int ; (* a boolean true for an eq, false for an ineq (Sigma a_i x_i >= 0) *) kind: eqn_kind; (* the variables and their coefficient *) body: coeff list; (* a constant *) constant: bigint } type state_action = { st_new_eq : afine; st_def : afine; st_orig : afine; st_coef : bigint; st_var : int } type action = | DIVIDE_AND_APPROX of afine * afine * bigint * bigint | NOT_EXACT_DIVIDE of afine * bigint | FORGET_C of int | EXACT_DIVIDE of afine * bigint | SUM of int * (bigint * afine) * (bigint * afine) | STATE of state_action | HYP of afine | FORGET of int * int | FORGET_I of int * int | CONTRADICTION of afine * afine | NEGATE_CONTRADICT of afine * afine * bool | MERGE_EQ of int * afine * int | CONSTANT_NOT_NUL of int * bigint | CONSTANT_NUL of int | CONSTANT_NEG of int * bigint | SPLIT_INEQ of afine * (int * action list) * (int * action list) | WEAKEN of int * bigint exception UNSOLVABLE exception NO_CONTRADICTION let display_eq print_var (l,e) = let _ = List.fold_left (fun not_first f -> print_string (if f.c ? zero then Printf.printf "+ %s " (string_of_bigint e) else if e accu + one + trace_length l1 + trace_length l2 | _ -> accu + one in List.fold_left action_length zero l let operator_of_eq = function | EQUA -> "=" | DISE -> "!=" | INEQ -> ">=" let kind_of = function | EQUA -> "equation" | DISE -> "disequation" | INEQ -> "inequation" let display_system print_var l = List.iter (fun { kind=b; body=e; constant=c; id=id} -> Printf.printf "E%d: " id; display_eq print_var (e,c); Printf.printf "%s 0\n" (operator_of_eq b)) l; print_string "------------------------\n\n" let display_inequations print_var l = List.iter (fun e -> display_eq print_var e;print_string ">= 0\n") l; print_string "------------------------\n\n" let sbi = string_of_bigint let rec display_action print_var = function | act :: l -> begin match act with | DIVIDE_AND_APPROX (e1,e2,k,d) -> Printf.printf "Inequation E%d is divided by %s and the constant coefficient is \ rounded by substracting %s.\n" e1.id (sbi k) (sbi d) | NOT_EXACT_DIVIDE (e,k) -> Printf.printf "Constant in equation E%d is not divisible by the pgcd \ %s of its other coefficients.\n" e.id (sbi k) | EXACT_DIVIDE (e,k) -> Printf.printf "Equation E%d is divided by the pgcd \ %s of its coefficients.\n" e.id (sbi k) | WEAKEN (e,k) -> Printf.printf "To ensure a solution in the dark shadow \ the equation E%d is weakened by %s.\n" e (sbi k) | SUM (e,(c1,e1),(c2,e2)) -> Printf.printf "We state %s E%d = %s %s E%d + %s %s E%d.\n" (kind_of e1.kind) e (sbi c1) (kind_of e1.kind) e1.id (sbi c2) (kind_of e2.kind) e2.id | STATE { st_new_eq = e } -> Printf.printf "We define a new equation E%d: " e.id; display_eq print_var (e.body,e.constant); print_string (operator_of_eq e.kind); print_string " 0" | HYP e -> Printf.printf "We define E%d: " e.id; display_eq print_var (e.body,e.constant); print_string (operator_of_eq e.kind); print_string " 0\n" | FORGET_C e -> Printf.printf "E%d is trivially satisfiable.\n" e | FORGET (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2 | FORGET_I (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2 | MERGE_EQ (e,e1,e2) -> Printf.printf "E%d and E%d can be merged into E%d.\n" e1.id e2 e | CONTRADICTION (e1,e2) -> Printf.printf "Equations E%d and E%d imply a contradiction on their \ constant factors.\n" e1.id e2.id | NEGATE_CONTRADICT(e1,e2,b) -> Printf.printf "Equations E%d and E%d state that their body is at the same time \ equal and different\n" e1.id e2.id | CONSTANT_NOT_NUL (e,k) -> Printf.printf "Equation E%d states %s = 0.\n" e (sbi k) | CONSTANT_NEG(e,k) -> Printf.printf "Equation E%d states %s >= 0.\n" e (sbi k) | CONSTANT_NUL e -> Printf.printf "Inequation E%d states 0 != 0.\n" e | SPLIT_INEQ (e,(e1,l1),(e2,l2)) -> Printf.printf "Equation E%d is split in E%d and E%d\n\n" e.id e1 e2; display_action print_var l1; print_newline (); display_action print_var l2; print_newline () end; display_action print_var l | [] -> flush stdout let default_print_var v = Printf.sprintf "X%d" v (* For debugging *) (*""*) let add_event, history, clear_history = let accu = ref [] in (fun (v:action) -> if !debug then display_action default_print_var [v]; push v accu), (fun () -> !accu), (fun () -> accu := []) let nf_linear = Sort.list (fun x y -> x.v > y.v) let nf ((b : bool),(e,(x : int))) = (b,(nf_linear e,x)) let map_eq_linear f = let rec loop = function | x :: l -> let c = f x.c in if c=?zero then loop l else {v=x.v; c=c} :: loop l | [] -> [] in loop let map_eq_afine f e = { id = e.id; kind = e.kind; body = map_eq_linear f e.body; constant = f e.constant } let negate_eq = map_eq_afine (fun x -> neg x) let rec sum p0 p1 = match (p0,p1) with | ([], l) -> l | (l, []) -> l | (((x1::l1) as l1'), ((x2::l2) as l2')) -> if x1.v = x2.v then let c = x1.c + x2.c in if c =? zero then sum l1 l2 else {v=x1.v;c=c} :: sum l1 l2 else if x1.v > x2.v then x1 :: sum l1 l2' else x2 :: sum l1' l2 let sum_afine new_eq_id eq1 eq2 = { kind = eq1.kind; id = new_eq_id (); body = sum eq1.body eq2.body; constant = eq1.constant + eq2.constant } exception FACTOR1 let rec chop_factor_1 = function | x :: l -> if abs x.c =? one then x,l else let (c',l') = chop_factor_1 l in (c',x::l') | [] -> raise FACTOR1 exception CHOPVAR let rec chop_var v = function | f :: l -> if f.v = v then f,l else let (f',l') = chop_var v l in (f',f::l') | [] -> raise CHOPVAR let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) = if e = [] then begin match eq_flag with | EQUA -> if x =? zero then [] else begin add_event (CONSTANT_NOT_NUL(id,x)); raise UNSOLVABLE end | DISE -> if x <> zero then [] else begin add_event (CONSTANT_NUL id); raise UNSOLVABLE end | INEQ -> if x >=? zero then [] else begin add_event (CONSTANT_NEG(id,x)); raise UNSOLVABLE end end else let gcd = pgcd_l (List.map (fun f -> abs f.c) e) in if eq_flag=EQUA & x mod gcd <> zero then begin add_event (NOT_EXACT_DIVIDE (eq,gcd)); raise UNSOLVABLE end else if eq_flag=DISE & x mod gcd <> zero then begin add_event (FORGET_C eq.id); [] end else if gcd <> one then begin let c = floor_div x gcd in let d = x - c * gcd in let new_eq = {id=id; kind=eq_flag; constant=c; body=map_eq_linear (fun c -> c / gcd) e} in add_event (if eq_flag=EQUA or eq_flag = DISE then EXACT_DIVIDE(eq,gcd) else DIVIDE_AND_APPROX(eq,new_eq,gcd,d)); [new_eq] end else [eq] let eliminate_with_in new_eq_id {v=v;c=c_unite} eq2 ({body=e1; constant=c1} as eq1) = try let (f,_) = chop_var v e1 in let coeff = if c_unite=?one then neg f.c else if c_unite=? negone then f.c else failwith "eliminate_with_in" in let res = sum_afine new_eq_id eq1 (map_eq_afine (fun c -> c * coeff) eq2) in add_event (SUM (res.id,(one,eq1),(coeff,eq2))); res with CHOPVAR -> eq1 let omega_mod a b = a - b * floor_div (two * a + b) (two * b) let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = let e = original.body in let sigma = new_var_id () in let smallest,var = try List.fold_left (fun (v,p) c -> if v >? (abs c.c) then abs c.c,c.v else (v,p)) (abs (List.hd e).c, (List.hd e).v) (List.tl e) with Failure "tl" -> display_system print_var [original] ; failwith "TL" in let m = smallest + one in let new_eq = { constant = omega_mod original.constant m; body = {c= neg m;v=sigma} :: map_eq_linear (fun a -> omega_mod a m) original.body; id = new_eq_id (); kind = EQUA } in let definition = { constant = neg (floor_div (two * original.constant + m) (two * m)); body = map_eq_linear (fun a -> neg (floor_div (two * a + m) (two * m))) original.body; id = new_eq_id (); kind = EQUA } in add_event (STATE {st_new_eq = new_eq; st_def = definition; st_orig = original; st_coef = m; st_var = sigma}); let new_eq = List.hd (normalize new_eq) in let eliminated_var, def = chop_var var new_eq.body in let other_equations = Util.list_map_append (fun e -> normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l1 in let inequations = Util.list_map_append (fun e -> normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l2 in let original' = eliminate_with_in new_eq_id eliminated_var new_eq original in let mod_original = map_eq_afine (fun c -> c / m) original' in add_event (EXACT_DIVIDE (original',m)); List.hd (normalize mod_original),other_equations,inequations let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,other,ineqs) = if !debug then display_system print_var (e::other); try let v,def = chop_factor_1 e.body in (Util.list_map_append (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) other, Util.list_map_append (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) ineqs) with FACTOR1 -> eliminate_one_equation new_ids (banerjee_step new_ids e other ineqs) let rec banerjee ((_,_,print_var) as new_ids) (sys_eq,sys_ineq) = let rec fst_eq_1 = function (eq::l) -> if List.exists (fun x -> abs x.c =? one) eq.body then eq,l else let (eq',l') = fst_eq_1 l in (eq',eq::l') | [] -> raise Not_found in match sys_eq with [] -> if !debug then display_system print_var sys_ineq; sys_ineq | (e1::rest) -> let eq,other = try fst_eq_1 sys_eq with Not_found -> (e1,rest) in if eq.body = [] then if eq.constant =? zero then begin add_event (FORGET_C eq.id); banerjee new_ids (other,sys_ineq) end else begin add_event (CONSTANT_NOT_NUL(eq.id,eq.constant)); raise UNSOLVABLE end else banerjee new_ids (eliminate_one_equation new_ids (eq,other,sys_ineq)) type kind = INVERTED | NORMAL let redundancy_elimination new_eq_id system = let normal = function ({body=f::_} as e) when f.c negate_eq e, INVERTED | e -> e,NORMAL in let table = Hashtbl.create 7 in List.iter (fun e -> let ({body=ne} as nx) ,kind = normal e in if ne = [] then if nx.constant let kept = if v.constant Some nx,optinvert end else begin match optinvert with Some v -> let _kept = if v.constant >? nx.constant then begin add_event (FORGET_I (v.id,nx.id));v end else begin add_event (FORGET_I (nx.id,v.id));nx end in (optnormal,Some(if v.constant >? nx.constant then v else nx)) | None -> optnormal,Some nx end in begin match final with (Some high, Some low) -> if high.constant () end; Hashtbl.remove table ne; Hashtbl.add table ne final with Not_found -> Hashtbl.add table ne (if kind = NORMAL then (Some nx,None) else (None,Some nx))) system; let accu_eq = ref [] in let accu_ineq = ref [] in Hashtbl.iter (fun p0 p1 -> match (p0,p1) with | (e, (Some x, Some y)) when x.constant =? y.constant -> let id=new_eq_id () in add_event (MERGE_EQ(id,x,y.id)); push {id=id; kind=EQUA; body=x.body; constant=x.constant} accu_eq | (e, (optnorm,optinvert)) -> begin match optnorm with Some x -> push x accu_ineq | _ -> () end; begin match optinvert with Some x -> push (negate_eq x) accu_ineq | _ -> () end) table; !accu_eq,!accu_ineq exception SOLVED_SYSTEM let select_variable system = let table = Hashtbl.create 7 in let push v c= try let r = Hashtbl.find table v in r := max !r (abs c) with Not_found -> Hashtbl.add table v (ref (abs c)) in List.iter (fun {body=l} -> List.iter (fun f -> push f.v f.c) l) system; let vmin,cmin = ref (-1), ref zero in let var_cpt = ref 0 in Hashtbl.iter (fun v ({contents = c}) -> incr var_cpt; if c try let f,eq' = chop_var v eq.body in if f.c >=? zero then (not_occ,((f.c,eq) :: below),over) else (not_occ,below,((neg f.c,eq) :: over)) with CHOPVAR -> (eq::not_occ,below,over)) ([],[],[]) system let product new_eq_id dark_shadow low high = List.fold_left (fun accu (a,eq1) -> List.fold_left (fun accu (b,eq2) -> let eq = sum_afine new_eq_id (map_eq_afine (fun c -> c * b) eq1) (map_eq_afine (fun c -> c * a) eq2) in add_event(SUM(eq.id,(b,eq1),(a,eq2))); match normalize eq with | [eq] -> let final_eq = if dark_shadow then let delta = (a - one) * (b - one) in add_event(WEAKEN(eq.id,delta)); {id = eq.id; kind=INEQ; body = eq.body; constant = eq.constant - delta} else eq in final_eq :: accu | (e::_) -> failwith "Product dardk" | [] -> accu) accu high) [] low let fourier_motzkin (new_eq_id,_,print_var) dark_shadow system = let v = select_variable system in let (ineq_out, ineq_low,ineq_high) = classify v system in let expanded = ineq_out @ product new_eq_id dark_shadow ineq_low ineq_high in if !debug then display_system print_var expanded; expanded let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system = if List.exists (fun e -> e.kind = DISE) system then failwith "disequation in simplify"; clear_history (); List.iter (fun e -> add_event (HYP e)) system; let system = Util.list_map_append normalize system in let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in let simp_eq,simp_ineq = redundancy_elimination new_eq_id ineqs in let system = (eqs @ simp_eq,simp_ineq) in let rec loop1a system = let sys_ineq = banerjee new_ids system in loop1b sys_ineq and loop1b sys_ineq = let simp_eq,simp_ineq = redundancy_elimination new_eq_id sys_ineq in if simp_eq = [] then simp_ineq else loop1a (simp_eq,simp_ineq) in let rec loop2 system = try let expanded = fourier_motzkin new_ids dark_shadow system in loop2 (loop1b expanded) with SOLVED_SYSTEM -> if !debug then display_system print_var system; system in loop2 (loop1a system) let rec depend relie_on accu = function | act :: l -> begin match act with | DIVIDE_AND_APPROX (e,_,_,_) -> if List.mem e.id relie_on then depend relie_on (act::accu) l else depend relie_on accu l | EXACT_DIVIDE (e,_) -> if List.mem e.id relie_on then depend relie_on (act::accu) l else depend relie_on accu l | WEAKEN (e,_) -> if List.mem e relie_on then depend relie_on (act::accu) l else depend relie_on accu l | SUM (e,(_,e1),(_,e2)) -> if List.mem e relie_on then depend (e1.id::e2.id::relie_on) (act::accu) l else depend relie_on accu l | STATE {st_new_eq=e;st_orig=o} -> if List.mem e.id relie_on then depend (o.id::relie_on) (act::accu) l else depend relie_on accu l | HYP e -> if List.mem e.id relie_on then depend relie_on (act::accu) l else depend relie_on accu l | FORGET_C _ -> depend relie_on accu l | FORGET _ -> depend relie_on accu l | FORGET_I _ -> depend relie_on accu l | MERGE_EQ (e,e1,e2) -> if List.mem e relie_on then depend (e1.id::e2::relie_on) (act::accu) l else depend relie_on accu l | NOT_EXACT_DIVIDE (e,_) -> depend (e.id::relie_on) (act::accu) l | CONTRADICTION (e1,e2) -> depend (e1.id::e2.id::relie_on) (act::accu) l | CONSTANT_NOT_NUL (e,_) -> depend (e::relie_on) (act::accu) l | CONSTANT_NEG (e,_) -> depend (e::relie_on) (act::accu) l | CONSTANT_NUL e -> depend (e::relie_on) (act::accu) l | NEGATE_CONTRADICT (e1,e2,_) -> depend (e1.id::e2.id::relie_on) (act::accu) l | SPLIT_INEQ _ -> failwith "depend" end | [] -> relie_on, accu (* let depend relie_on accu trace = Printf.printf "Longueur de la trace initiale : %d\n" (trace_length trace + trace_length accu); let rel',trace' = depend relie_on accu trace in Printf.printf "Longueur de la trace simplifiée : %d\n" (trace_length trace'); rel',trace' *) let solve (new_eq_id,new_eq_var,print_var) system = try let _ = simplify new_eq_id false system in failwith "no contradiction" with UNSOLVABLE -> display_action print_var (snd (depend [] [] (history ()))) let negation (eqs,ineqs) = let diseq,_ = List.partition (fun e -> e.kind = DISE) ineqs in let normal = function | ({body=f::_} as e) when f.c negate_eq e, INVERTED | e -> e,NORMAL in let table = Hashtbl.create 7 in List.iter (fun e -> let {body=ne;constant=c} ,kind = normal e in Hashtbl.add table (ne,c) (kind,e)) diseq; List.iter (fun e -> assert (e.kind = EQUA); let {body=ne;constant=c},kind = normal e in try let (kind',e') = Hashtbl.find table (ne,c) in add_event (NEGATE_CONTRADICT (e,e',kind=kind')); raise UNSOLVABLE with Not_found -> ()) eqs exception FULL_SOLUTION of action list * int list let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system = clear_history (); List.iter (fun e -> add_event (HYP e)) system; (* Initial simplification phase *) let rec loop1a system = negation system; let sys_ineq = banerjee new_ids system in loop1b sys_ineq and loop1b sys_ineq = let dise,ine = List.partition (fun e -> e.kind = DISE) sys_ineq in let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in if simp_eq = [] then dise @ simp_ineq else loop1a (simp_eq,dise @ simp_ineq) in let rec loop2 system = try let expanded = fourier_motzkin new_ids false system in loop2 (loop1b expanded) with SOLVED_SYSTEM -> if !debug then display_system print_var system; system in let rec explode_diseq = function | (de::diseq,ineqs,expl_map) -> let id1 = new_eq_id () and id2 = new_eq_id () in let e1 = {id = id1; kind=INEQ; body = de.body; constant = de.constant -one} in let e2 = {id = id2; kind=INEQ; body = map_eq_linear neg de.body; constant = neg de.constant - one} in let new_sys = List.map (fun (what,sys) -> ((de.id,id1,true)::what, e1::sys)) ineqs @ List.map (fun (what,sys) -> ((de.id,id2,false)::what,e2::sys)) ineqs in explode_diseq (diseq,new_sys,(de.id,(de,id1,id2))::expl_map) | ([],ineqs,expl_map) -> ineqs,expl_map in try let system = Util.list_map_append normalize system in let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in let dise,ine = List.partition (fun e -> e.kind = DISE) ineqs in let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in let system = (eqs @ simp_eq,simp_ineq @ dise) in let system' = loop1a system in let diseq,ineq = List.partition (fun e -> e.kind = DISE) system' in let first_segment = history () in let sys_exploded,explode_map = explode_diseq (diseq,[[],ineq],[]) in let all_solutions = List.map (fun (decomp,sys) -> clear_history (); try let _ = loop2 sys in raise NO_CONTRADICTION with UNSOLVABLE -> let relie_on,path = depend [] [] (history ()) in let dc,_ = List.partition (fun (_,id,_) -> List.mem id relie_on) decomp in let red = List.map (fun (x,_,_) -> x) dc in (red,relie_on,decomp,path)) sys_exploded in let max_count sys = let tbl = Hashtbl.create 7 in let augment x = try incr (Hashtbl.find tbl x) with Not_found -> Hashtbl.add tbl x (ref 1) in let eq = ref (-1) and c = ref 0 in List.iter (function | ([],r_on,_,path) -> raise (FULL_SOLUTION (path,r_on)) | (l,_,_,_) -> List.iter augment l) sys; Hashtbl.iter (fun x v -> if !v > !c then begin eq := x; c := !v end) tbl; !eq in let rec solve systems = try let id = max_count systems in let rec sign = function | ((id',_,b)::l) -> if id=id' then b else sign l | [] -> failwith "solve" in let s1,s2 = List.partition (fun (_,_,decomp,_) -> sign decomp) systems in let s1' = List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s1 in let s2' = List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s2 in let (r1,relie1) = solve s1' and (r2,relie2) = solve s2' in let (eq,id1,id2) = List.assoc id explode_map in [SPLIT_INEQ(eq,(id1,r1),(id2, r2))], eq.id :: Util.list_union relie1 relie2 with FULL_SOLUTION (x0,x1) -> (x0,x1) in let act,relie_on = solve all_solutions in snd(depend relie_on act first_segment) with UNSOLVABLE -> snd (depend [] [] (history ())) end coq-8.4pl4/plugins/omega/vo.itarget0000644000175000017500000000006312326224777016410 0ustar stephstephOmegaLemmas.vo OmegaPlugin.vo Omega.vo PreOmega.vo coq-8.4pl4/plugins/omega/PreOmega.v0000644000175000017500000003655612326224777016311 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* simpl (t a) in * | _ => zify_unop_var_or_term t thm a end. Ltac zify_unop_nored t thm a := (* in this version, we don't try to reduce the unop (that can be (Z.add x)) *) let isz := isZcst a in match isz with | true => zify_unop_core t thm a | _ => zify_unop_var_or_term t thm a end. Ltac zify_binop t thm a b:= (* works as zify_unop, except that we should be careful when dealing with b, since it can be equal to a *) let isza := isZcst a in match isza with | true => zify_unop (t a) (thm a) b | _ => let za := fresh "z" in (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) || (remember a as za; match goal with | H : za = b |- _ => zify_unop_nored (t za) (thm za) za | _ => zify_unop_nored (t za) (thm za) b end) end. Ltac zify_op_1 := match goal with | |- context [ Z.max ?a ?b ] => zify_binop Z.max Z.max_spec a b | H : context [ Z.max ?a ?b ] |- _ => zify_binop Z.max Z.max_spec a b | |- context [ Z.min ?a ?b ] => zify_binop Z.min Z.min_spec a b | H : context [ Z.min ?a ?b ] |- _ => zify_binop Z.min Z.min_spec a b | |- context [ Z.sgn ?a ] => zify_unop Z.sgn Z.sgn_spec a | H : context [ Z.sgn ?a ] |- _ => zify_unop Z.sgn Z.sgn_spec a | |- context [ Z.abs ?a ] => zify_unop Z.abs Z.abs_spec a | H : context [ Z.abs ?a ] |- _ => zify_unop Z.abs Z.abs_spec a end. Ltac zify_op := repeat zify_op_1. (** II) Conversion from nat to Z *) Definition Z_of_nat' := Z.of_nat. Ltac hide_Z_of_nat t := let z := fresh "z" in set (z:=Z.of_nat t) in *; change Z.of_nat with Z_of_nat' in z; unfold z in *; clear z. Ltac zify_nat_rel := match goal with (* I: equalities *) | |- (@eq nat ?a ?b) => apply (Nat2Z.inj a b) (* shortcut *) | H : context [ @eq nat ?a ?b ] |- _ => rewrite <- (Nat2Z.inj_iff a b) in H | |- context [ @eq nat ?a ?b ] => rewrite <- (Nat2Z.inj_iff a b) (* II: less than *) | H : context [ lt ?a ?b ] |- _ => rewrite (Nat2Z.inj_lt a b) in H | |- context [ lt ?a ?b ] => rewrite (Nat2Z.inj_lt a b) (* III: less or equal *) | H : context [ le ?a ?b ] |- _ => rewrite (Nat2Z.inj_le a b) in H | |- context [ le ?a ?b ] => rewrite (Nat2Z.inj_le a b) (* IV: greater than *) | H : context [ gt ?a ?b ] |- _ => rewrite (Nat2Z.inj_gt a b) in H | |- context [ gt ?a ?b ] => rewrite (Nat2Z.inj_gt a b) (* V: greater or equal *) | H : context [ ge ?a ?b ] |- _ => rewrite (Nat2Z.inj_ge a b) in H | |- context [ ge ?a ?b ] => rewrite (Nat2Z.inj_ge a b) end. Ltac zify_nat_op := match goal with (* misc type conversions: positive/N/Z to nat *) | H : context [ Z.of_nat (Pos.to_nat ?a) ] |- _ => rewrite (positive_nat_Z a) in H | |- context [ Z.of_nat (Pos.to_nat ?a) ] => rewrite (positive_nat_Z a) | H : context [ Z.of_nat (N.to_nat ?a) ] |- _ => rewrite (N_nat_Z a) in H | |- context [ Z.of_nat (N.to_nat ?a) ] => rewrite (N_nat_Z a) | H : context [ Z.of_nat (Z.abs_nat ?a) ] |- _ => rewrite (Zabs2Nat.id_abs a) in H | |- context [ Z.of_nat (Z.abs_nat ?a) ] => rewrite (Zabs2Nat.id_abs a) (* plus -> Z.add *) | H : context [ Z.of_nat (plus ?a ?b) ] |- _ => rewrite (Nat2Z.inj_add a b) in H | |- context [ Z.of_nat (plus ?a ?b) ] => rewrite (Nat2Z.inj_add a b) (* min -> Z.min *) | H : context [ Z.of_nat (min ?a ?b) ] |- _ => rewrite (Nat2Z.inj_min a b) in H | |- context [ Z.of_nat (min ?a ?b) ] => rewrite (Nat2Z.inj_min a b) (* max -> Z.max *) | H : context [ Z.of_nat (max ?a ?b) ] |- _ => rewrite (Nat2Z.inj_max a b) in H | |- context [ Z.of_nat (max ?a ?b) ] => rewrite (Nat2Z.inj_max a b) (* minus -> Z.max (Z.sub ... ...) 0 *) | H : context [ Z.of_nat (minus ?a ?b) ] |- _ => rewrite (Nat2Z.inj_sub_max a b) in H | |- context [ Z.of_nat (minus ?a ?b) ] => rewrite (Nat2Z.inj_sub_max a b) (* pred -> minus ... -1 -> Z.max (Z.sub ... -1) 0 *) | H : context [ Z.of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H | |- context [ Z.of_nat (pred ?a) ] => rewrite (pred_of_minus a) (* mult -> Z.mul and a positivity hypothesis *) | H : context [ Z.of_nat (mult ?a ?b) ] |- _ => pose proof (Nat2Z.is_nonneg (mult a b)); rewrite (Nat2Z.inj_mul a b) in * | |- context [ Z.of_nat (mult ?a ?b) ] => pose proof (Nat2Z.is_nonneg (mult a b)); rewrite (Nat2Z.inj_mul a b) in * (* O -> Z0 *) | H : context [ Z.of_nat O ] |- _ => simpl (Z.of_nat O) in H | |- context [ Z.of_nat O ] => simpl (Z.of_nat O) (* S -> number or Z.succ *) | H : context [ Z.of_nat (S ?a) ] |- _ => let isnat := isnatcst a in match isnat with | true => simpl (Z.of_nat (S a)) in H | _ => rewrite (Nat2Z.inj_succ a) in H end | |- context [ Z.of_nat (S ?a) ] => let isnat := isnatcst a in match isnat with | true => simpl (Z.of_nat (S a)) | _ => rewrite (Nat2Z.inj_succ a) end (* atoms of type nat : we add a positivity condition (if not already there) *) | _ : 0 <= Z.of_nat ?a |- _ => hide_Z_of_nat a | _ : context [ Z.of_nat ?a ] |- _ => pose proof (Nat2Z.is_nonneg a); hide_Z_of_nat a | |- context [ Z.of_nat ?a ] => pose proof (Nat2Z.is_nonneg a); hide_Z_of_nat a end. Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *. (* III) conversion from positive to Z *) Definition Zpos' := Zpos. Definition Zneg' := Zneg. Ltac hide_Zpos t := let z := fresh "z" in set (z:=Zpos t) in *; change Zpos with Zpos' in z; unfold z in *; clear z. Ltac zify_positive_rel := match goal with (* I: equalities *) | |- (@eq positive ?a ?b) => apply Pos2Z.inj | H : context [ @eq positive ?a ?b ] |- _ => rewrite <- (Pos2Z.inj_iff a b) in H | |- context [ @eq positive ?a ?b ] => rewrite <- (Pos2Z.inj_iff a b) (* II: less than *) | H : context [ (?a < ?b)%positive ] |- _ => change (a change (a change (a<=b)%positive with (Zpos a<=Zpos b) in H | |- context [ (?a <= ?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b) (* IV: greater than *) | H : context [ (?a > ?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H | |- context [ (?a > ?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b) (* V: greater or equal *) | H : context [ (?a >= ?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H | |- context [ (?a >= ?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b) end. Ltac zify_positive_op := match goal with (* Zneg -> -Zpos (except for numbers) *) | H : context [ Zneg ?a ] |- _ => let isp := isPcst a in match isp with | true => change (Zneg a) with (Zneg' a) in H | _ => change (Zneg a) with (- Zpos a) in H end | |- context [ Zneg ?a ] => let isp := isPcst a in match isp with | true => change (Zneg a) with (Zneg' a) | _ => change (Zneg a) with (- Zpos a) end (* misc type conversions: nat to positive *) | H : context [ Zpos (Pos.of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H | |- context [ Zpos (Pos.of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a) (* Pos.add -> Z.add *) | H : context [ Zpos (?a + ?b) ] |- _ => change (Zpos (a+b)) with (Zpos a + Zpos b) in H | |- context [ Zpos (?a + ?b) ] => change (Zpos (a+b)) with (Zpos a + Zpos b) (* Pos.min -> Z.min *) | H : context [ Zpos (Pos.min ?a ?b) ] |- _ => rewrite (Pos2Z.inj_min a b) in H | |- context [ Zpos (Pos.min ?a ?b) ] => rewrite (Pos2Z.inj_min a b) (* Pos.max -> Z.max *) | H : context [ Zpos (Pos.max ?a ?b) ] |- _ => rewrite (Pos2Z.inj_max a b) in H | |- context [ Zpos (Pos.max ?a ?b) ] => rewrite (Pos2Z.inj_max a b) (* Pos.sub -> Z.max 1 (Z.sub ... ...) *) | H : context [ Zpos (Pos.sub ?a ?b) ] |- _ => rewrite (Pos2Z.inj_sub a b) in H | |- context [ Zpos (Pos.sub ?a ?b) ] => rewrite (Pos2Z.inj_sub a b) (* Pos.succ -> Z.succ *) | H : context [ Zpos (Pos.succ ?a) ] |- _ => rewrite (Pos2Z.inj_succ a) in H | |- context [ Zpos (Pos.succ ?a) ] => rewrite (Pos2Z.inj_succ a) (* Pos.pred -> Pos.sub ... -1 -> Z.max 1 (Z.sub ... - 1) *) | H : context [ Zpos (Pos.pred ?a) ] |- _ => rewrite <- (Pos.sub_1_r a) in H | |- context [ Zpos (Pos.pred ?a) ] => rewrite <- (Pos.sub_1_r a) (* Pos.mul -> Z.mul and a positivity hypothesis *) | H : context [ Zpos (?a * ?b) ] |- _ => pose proof (Pos2Z.is_pos (Pos.mul a b)); change (Zpos (a*b)) with (Zpos a * Zpos b) in * | |- context [ Zpos (?a * ?b) ] => pose proof (Pos2Z.is_pos (Pos.mul a b)); change (Zpos (a*b)) with (Zpos a * Zpos b) in * (* xO *) | H : context [ Zpos (xO ?a) ] |- _ => let isp := isPcst a in match isp with | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H | _ => rewrite (Pos2Z.inj_xO a) in H end | |- context [ Zpos (xO ?a) ] => let isp := isPcst a in match isp with | true => change (Zpos (xO a)) with (Zpos' (xO a)) | _ => rewrite (Pos2Z.inj_xO a) end (* xI *) | H : context [ Zpos (xI ?a) ] |- _ => let isp := isPcst a in match isp with | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H | _ => rewrite (Pos2Z.inj_xI a) in H end | |- context [ Zpos (xI ?a) ] => let isp := isPcst a in match isp with | true => change (Zpos (xI a)) with (Zpos' (xI a)) | _ => rewrite (Pos2Z.inj_xI a) end (* xI : nothing to do, just prevent adding a useless positivity condition *) | H : context [ Zpos xH ] |- _ => hide_Zpos xH | |- context [ Zpos xH ] => hide_Zpos xH (* atoms of type positive : we add a positivity condition (if not already there) *) | _ : 0 < Zpos ?a |- _ => hide_Zpos a | _ : context [ Zpos ?a ] |- _ => pose proof (Pos2Z.is_pos a); hide_Zpos a | |- context [ Zpos ?a ] => pose proof (Pos2Z.is_pos a); hide_Zpos a end. Ltac zify_positive := repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *. (* IV) conversion from N to Z *) Definition Z_of_N' := Z.of_N. Ltac hide_Z_of_N t := let z := fresh "z" in set (z:=Z.of_N t) in *; change Z.of_N with Z_of_N' in z; unfold z in *; clear z. Ltac zify_N_rel := match goal with (* I: equalities *) | |- (@eq N ?a ?b) => apply (N2Z.inj a b) (* shortcut *) | H : context [ @eq N ?a ?b ] |- _ => rewrite <- (N2Z.inj_iff a b) in H | |- context [ @eq N ?a ?b ] => rewrite <- (N2Z.inj_iff a b) (* II: less than *) | H : context [ (?a < ?b)%N ] |- _ => rewrite (N2Z.inj_lt a b) in H | |- context [ (?a < ?b)%N ] => rewrite (N2Z.inj_lt a b) (* III: less or equal *) | H : context [ (?a <= ?b)%N ] |- _ => rewrite (N2Z.inj_le a b) in H | |- context [ (?a <= ?b)%N ] => rewrite (N2Z.inj_le a b) (* IV: greater than *) | H : context [ (?a > ?b)%N ] |- _ => rewrite (N2Z.inj_gt a b) in H | |- context [ (?a > ?b)%N ] => rewrite (N2Z.inj_gt a b) (* V: greater or equal *) | H : context [ (?a >= ?b)%N ] |- _ => rewrite (N2Z.inj_ge a b) in H | |- context [ (?a >= ?b)%N ] => rewrite (N2Z.inj_ge a b) end. Ltac zify_N_op := match goal with (* misc type conversions: nat to positive *) | H : context [ Z.of_N (N.of_nat ?a) ] |- _ => rewrite (nat_N_Z a) in H | |- context [ Z.of_N (N.of_nat ?a) ] => rewrite (nat_N_Z a) | H : context [ Z.of_N (Z.abs_N ?a) ] |- _ => rewrite (N2Z.inj_abs_N a) in H | |- context [ Z.of_N (Z.abs_N ?a) ] => rewrite (N2Z.inj_abs_N a) | H : context [ Z.of_N (Npos ?a) ] |- _ => rewrite (N2Z.inj_pos a) in H | |- context [ Z.of_N (Npos ?a) ] => rewrite (N2Z.inj_pos a) | H : context [ Z.of_N N0 ] |- _ => change (Z.of_N N0) with Z0 in H | |- context [ Z.of_N N0 ] => change (Z.of_N N0) with Z0 (* N.add -> Z.add *) | H : context [ Z.of_N (N.add ?a ?b) ] |- _ => rewrite (N2Z.inj_add a b) in H | |- context [ Z.of_N (N.add ?a ?b) ] => rewrite (N2Z.inj_add a b) (* N.min -> Z.min *) | H : context [ Z.of_N (N.min ?a ?b) ] |- _ => rewrite (N2Z.inj_min a b) in H | |- context [ Z.of_N (N.min ?a ?b) ] => rewrite (N2Z.inj_min a b) (* N.max -> Z.max *) | H : context [ Z.of_N (N.max ?a ?b) ] |- _ => rewrite (N2Z.inj_max a b) in H | |- context [ Z.of_N (N.max ?a ?b) ] => rewrite (N2Z.inj_max a b) (* N.sub -> Z.max 0 (Z.sub ... ...) *) | H : context [ Z.of_N (N.sub ?a ?b) ] |- _ => rewrite (N2Z.inj_sub_max a b) in H | |- context [ Z.of_N (N.sub ?a ?b) ] => rewrite (N2Z.inj_sub_max a b) (* N.succ -> Z.succ *) | H : context [ Z.of_N (N.succ ?a) ] |- _ => rewrite (N2Z.inj_succ a) in H | |- context [ Z.of_N (N.succ ?a) ] => rewrite (N2Z.inj_succ a) (* N.mul -> Z.mul and a positivity hypothesis *) | H : context [ Z.of_N (N.mul ?a ?b) ] |- _ => pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in * | |- context [ Z.of_N (N.mul ?a ?b) ] => pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in * (* atoms of type N : we add a positivity condition (if not already there) *) | _ : 0 <= Z.of_N ?a |- _ => hide_Z_of_N a | _ : context [ Z.of_N ?a ] |- _ => pose proof (N2Z.is_nonneg a); hide_Z_of_N a | |- context [ Z.of_N ?a ] => pose proof (N2Z.is_nonneg a); hide_Z_of_N a end. Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *. (** The complete Z-ification tactic *) Ltac zify := repeat progress (zify_nat; zify_positive; zify_N); zify_op. coq-8.4pl4/plugins/omega/OmegaLemmas.v0000644000175000017500000001775712326224777017003 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 <= x -> 0 <= y. Proof. now intros ->. Qed. Lemma OMEGA2 x y : 0 <= x -> 0 <= y -> 0 <= x + y. Proof. Z.order_pos. Qed. Lemma OMEGA3 x y k : k > 0 -> x = y * k -> x = 0 -> y = 0. Proof. intros LT -> EQ. apply Z.mul_eq_0 in EQ. destruct EQ; now subst. Qed. Lemma OMEGA4 x y z : x > 0 -> y > x -> z * y + x <> 0. Proof. Z.swap_greater. intros Hx Hxy. rewrite Z.add_move_0_l, <- Z.mul_opp_l. destruct (Z.lt_trichotomy (-z) 1) as [LT|[->|GT]]. - intro. revert LT. apply Z.le_ngt, (Z.le_succ_l 0). apply Z.mul_pos_cancel_r with y; Z.order. - Z.nzsimpl. Z.order. - rewrite (Z.mul_lt_mono_pos_r y), Z.mul_1_l in GT; Z.order. Qed. Lemma OMEGA5 x y z : x = 0 -> y = 0 -> x + y * z = 0. Proof. now intros -> ->. Qed. Lemma OMEGA6 x y z : 0 <= x -> y = 0 -> 0 <= x + y * z. Proof. intros H ->. now Z.nzsimpl. Qed. Lemma OMEGA7 x y z t : z > 0 -> t > 0 -> 0 <= x -> 0 <= y -> 0 <= x * z + y * t. Proof. intros. Z.swap_greater. Z.order_pos. Qed. Lemma OMEGA8 x y : 0 <= x -> 0 <= y -> x = - y -> x = 0. Proof. intros H1 H2 H3. rewrite <- Z.opp_nonpos_nonneg in H2. Z.order. Qed. Lemma OMEGA9 x y z t : y = 0 -> x = z -> y + (- x + z) * t = 0. Proof. intros. subst. now rewrite Z.add_opp_diag_l. Qed. Lemma OMEGA10 v c1 c2 l1 l2 k1 k2 : (v * c1 + l1) * k1 + (v * c2 + l2) * k2 = v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2). Proof. rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. rewrite <- !Z.add_assoc. f_equal. apply Z.add_shuffle3. Qed. Lemma OMEGA11 v1 c1 l1 l2 k1 : (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2). Proof. rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. now rewrite Z.add_assoc. Qed. Lemma OMEGA12 v2 c2 l1 l2 k2 : l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2). Proof. rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. apply Z.add_shuffle3. Qed. Lemma OMEGA13 (v l1 l2 : Z) (x : positive) : v * Zpos x + l1 + (v * Zneg x + l2) = l1 + l2. Proof. rewrite Z.add_shuffle1. rewrite <- Z.mul_add_distr_l, <- Pos2Z.opp_neg, Z.add_opp_diag_r. now Z.nzsimpl. Qed. Lemma OMEGA14 (v l1 l2 : Z) (x : positive) : v * Zneg x + l1 + (v * Zpos x + l2) = l1 + l2. Proof. rewrite Z.add_shuffle1. rewrite <- Z.mul_add_distr_l, <- Pos2Z.opp_neg, Z.add_opp_diag_r. now Z.nzsimpl. Qed. Lemma OMEGA15 v c1 c2 l1 l2 k2 : v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2). Proof. rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. apply Z.add_shuffle1. Qed. Lemma OMEGA16 v c l k : (v * c + l) * k = v * (c * k) + l * k. Proof. now rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. Qed. Lemma OMEGA17 x y z : Zne x 0 -> y = 0 -> Zne (x + y * z) 0. Proof. unfold Zne, not. intros NE EQ. subst. now Z.nzsimpl. Qed. Lemma OMEGA18 x y k : x = y * k -> Zne x 0 -> Zne y 0. Proof. unfold Zne, not. intros. subst; auto. Qed. Lemma OMEGA19 x : Zne x 0 -> 0 <= x + -1 \/ 0 <= x * -1 + -1. Proof. unfold Zne. intros Hx. apply Z.lt_gt_cases in Hx. destruct Hx as [LT|GT]. - right. change (-1) with (-(1)). rewrite Z.mul_opp_r, <- Z.opp_add_distr. Z.nzsimpl. rewrite Z.opp_nonneg_nonpos. now apply Z.le_succ_l. - left. now apply Z.lt_le_pred. Qed. Lemma OMEGA20 x y z : Zne x 0 -> y = 0 -> Zne (x + y * z) 0. Proof. unfold Zne, not. intros H1 H2 H3; apply H1; rewrite H2 in H3; simpl in H3; rewrite Z.add_0_r in H3; trivial with arith. Qed. Definition fast_Zplus_comm (x y : Z) (P : Z -> Prop) (H : P (y + x)) := eq_ind_r P H (Z.add_comm x y). Definition fast_Zplus_assoc_reverse (n m p : Z) (P : Z -> Prop) (H : P (n + (m + p))) := eq_ind_r P H (Zplus_assoc_reverse n m p). Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop) (H : P (n + m + p)) := eq_ind_r P H (Z.add_assoc n m p). Definition fast_Zplus_permute (n m p : Z) (P : Z -> Prop) (H : P (m + (n + p))) := eq_ind_r P H (Z.add_shuffle3 n m p). Definition fast_OMEGA10 (v c1 c2 l1 l2 k1 k2 : Z) (P : Z -> Prop) (H : P (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))) := eq_ind_r P H (OMEGA10 v c1 c2 l1 l2 k1 k2). Definition fast_OMEGA11 (v1 c1 l1 l2 k1 : Z) (P : Z -> Prop) (H : P (v1 * (c1 * k1) + (l1 * k1 + l2))) := eq_ind_r P H (OMEGA11 v1 c1 l1 l2 k1). Definition fast_OMEGA12 (v2 c2 l1 l2 k2 : Z) (P : Z -> Prop) (H : P (v2 * (c2 * k2) + (l1 + l2 * k2))) := eq_ind_r P H (OMEGA12 v2 c2 l1 l2 k2). Definition fast_OMEGA15 (v c1 c2 l1 l2 k2 : Z) (P : Z -> Prop) (H : P (v * (c1 + c2 * k2) + (l1 + l2 * k2))) := eq_ind_r P H (OMEGA15 v c1 c2 l1 l2 k2). Definition fast_OMEGA16 (v c l k : Z) (P : Z -> Prop) (H : P (v * (c * k) + l * k)) := eq_ind_r P H (OMEGA16 v c l k). Definition fast_OMEGA13 (v l1 l2 : Z) (x : positive) (P : Z -> Prop) (H : P (l1 + l2)) := eq_ind_r P H (OMEGA13 v l1 l2 x). Definition fast_OMEGA14 (v l1 l2 : Z) (x : positive) (P : Z -> Prop) (H : P (l1 + l2)) := eq_ind_r P H (OMEGA14 v l1 l2 x). Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop) (H : P (x * 1)) := eq_ind_r P H (Zred_factor0 x). Definition fast_Zopp_eq_mult_neg_1 (x : Z) (P : Z -> Prop) (H : P (x * -1)) := eq_ind_r P H (Z.opp_eq_mul_m1 x). Definition fast_Zmult_comm (x y : Z) (P : Z -> Prop) (H : P (y * x)) := eq_ind_r P H (Z.mul_comm x y). Definition fast_Zopp_plus_distr (x y : Z) (P : Z -> Prop) (H : P (- x + - y)) := eq_ind_r P H (Z.opp_add_distr x y). Definition fast_Zopp_involutive (x : Z) (P : Z -> Prop) (H : P x) := eq_ind_r P H (Z.opp_involutive x). Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop) (H : P (x * - y)) := eq_ind_r P H (Zopp_mult_distr_r x y). Definition fast_Zmult_plus_distr_l (n m p : Z) (P : Z -> Prop) (H : P (n * p + m * p)) := eq_ind_r P H (Z.mul_add_distr_r n m p). Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop) (H : P (x * - y)) := eq_ind_r P H (Z.mul_opp_comm x y). Definition fast_Zmult_assoc_reverse (n m p : Z) (P : Z -> Prop) (H : P (n * (m * p))) := eq_ind_r P H (Zmult_assoc_reverse n m p). Definition fast_Zred_factor1 (x : Z) (P : Z -> Prop) (H : P (x * 2)) := eq_ind_r P H (Zred_factor1 x). Definition fast_Zred_factor2 (x y : Z) (P : Z -> Prop) (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor2 x y). Definition fast_Zred_factor3 (x y : Z) (P : Z -> Prop) (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor3 x y). Definition fast_Zred_factor4 (x y z : Z) (P : Z -> Prop) (H : P (x * (y + z))) := eq_ind_r P H (Zred_factor4 x y z). Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop) (H : P y) := eq_ind_r P H (Zred_factor5 x y). Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop) (H : P (x + 0)) := eq_ind_r P H (Zred_factor6 x). Theorem intro_Z : forall n:nat, exists y : Z, Z.of_nat n = y /\ 0 <= y * 1 + 0. Proof. intros n; exists (Z.of_nat n); split; trivial. rewrite Z.mul_1_r, Z.add_0_r. apply Nat2Z.is_nonneg. Qed. coq-8.4pl4/plugins/omega/omega_plugin.mllib0000644000175000017500000000005112326224777020067 0ustar stephstephOmega Coq_omega G_omega Omega_plugin_mod coq-8.4pl4/plugins/omega/g_omega.ml40000644000175000017500000000351412326224777016423 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Tacinterp.interp <:tactic> | "positive" -> Tacinterp.interp <:tactic> | "N" -> Tacinterp.interp <:tactic> | "Z" -> Tacinterp.interp <:tactic> | s -> Util.error ("No Omega knowledge base for type "^s)) (Util.list_uniquize (List.sort compare l)) in tclTHEN (tclREPEAT (tclPROGRESS (tclTHENLIST tacs))) omega_solver TACTIC EXTEND omega | [ "omega" ] -> [ omega_tactic [] ] END TACTIC EXTEND omega' | [ "omega" "with" ne_ident_list(l) ] -> [ omega_tactic (List.map Names.string_of_id l) ] | [ "omega" "with" "*" ] -> [ omega_tactic ["nat";"positive";"N";"Z"] ] END coq-8.4pl4/plugins/omega/Omega.v0000644000175000017500000000514712326224777015632 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* nat) => abstract omega: zarith. Hint Extern 10 (_ <= _) => abstract omega: zarith. Hint Extern 10 (_ < _) => abstract omega: zarith. Hint Extern 10 (_ >= _) => abstract omega: zarith. Hint Extern 10 (_ > _) => abstract omega: zarith. Hint Extern 10 (_ <> _ :>nat) => abstract omega: zarith. Hint Extern 10 (~ _ <= _) => abstract omega: zarith. Hint Extern 10 (~ _ < _) => abstract omega: zarith. Hint Extern 10 (~ _ >= _) => abstract omega: zarith. Hint Extern 10 (~ _ > _) => abstract omega: zarith. Hint Extern 10 (_ = _ :>Z) => abstract omega: zarith. Hint Extern 10 (_ <= _)%Z => abstract omega: zarith. Hint Extern 10 (_ < _)%Z => abstract omega: zarith. Hint Extern 10 (_ >= _)%Z => abstract omega: zarith. Hint Extern 10 (_ > _)%Z => abstract omega: zarith. Hint Extern 10 (_ <> _ :>Z) => abstract omega: zarith. Hint Extern 10 (~ (_ <= _)%Z) => abstract omega: zarith. Hint Extern 10 (~ (_ < _)%Z) => abstract omega: zarith. Hint Extern 10 (~ (_ >= _)%Z) => abstract omega: zarith. Hint Extern 10 (~ (_ > _)%Z) => abstract omega: zarith. Hint Extern 10 False => abstract omega: zarith.coq-8.4pl4/plugins/omega/OmegaPlugin.v0000644000175000017500000000106012326224777016777 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* = 8.5, this option is set by default. *) let read f () = !f let write f x = f:=x open Goptions let _ = declare_bool_option { optsync = false; optdepr = false; optname = "Omega system time displaying flag"; optkey = ["Omega";"System"]; optread = read display_system_flag; optwrite = write display_system_flag } let _ = declare_bool_option { optsync = false; optdepr = false; optname = "Omega action display flag"; optkey = ["Omega";"Action"]; optread = read display_action_flag; optwrite = write display_action_flag } let _ = declare_bool_option { optsync = false; optdepr = false; optname = "Omega old style flag"; optkey = ["Omega";"OldStyle"]; optread = read old_style_flag; optwrite = write old_style_flag } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "Omega automatic reset of generated names"; optkey = ["Stable";"Omega"]; optread = read reset_flag; optwrite = write reset_flag } let all_time = timing "Omega " let solver_time = timing "Solver " let exact_time = timing "Rewrites " let elim_time = timing "Elim " let simpl_time = timing "Simpl " let generalize_time = timing "Generalize" let intref, reset_all_references = let refs = ref [] in (fun n -> let r = ref n in refs := (r,n) :: !refs; r), (fun () -> List.iter (fun (r,n) -> r:=n) !refs) let new_identifier = let cpt = intref 0 in (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; id_of_string s) let new_identifier_state = let cpt = intref 0 in (fun () -> let s = make_ident "State" (Some !cpt) in incr cpt; s) let new_identifier_var = let cpt = intref 0 in (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; id_of_string s) let new_id = let cpt = intref 0 in fun () -> incr cpt; !cpt let new_var_num = let cpt = intref 1000 in (fun () -> incr cpt; !cpt) let new_var = let cpt = intref 0 in fun () -> incr cpt; Nameops.make_ident "WW" (Some !cpt) let display_var i = Printf.sprintf "X%d" i let intern_id,unintern_id,reset_intern_tables = let cpt = ref 0 in let table = Hashtbl.create 7 and co_table = Hashtbl.create 7 in (fun (name : identifier) -> try Hashtbl.find table name with Not_found -> let idx = !cpt in Hashtbl.add table name idx; Hashtbl.add co_table idx name; incr cpt; idx), (fun idx -> try Hashtbl.find co_table idx with Not_found -> let v = new_var () in Hashtbl.add table v idx; Hashtbl.add co_table idx v; v), (fun () -> cpt := 0; Hashtbl.clear table) let mk_then = tclTHENLIST let exists_tac c = constructor_tac false (Some 1) 1 (Glob_term.ImplicitBindings [c]) let generalize_tac t = generalize_time (generalize t) let elim t = elim_time (simplest_elim t) let exact t = exact_time (Tactics.refine t) let unfold s = Tactics.unfold_in_concl [Termops.all_occurrences, Lazy.force s] let rev_assoc k = let rec loop = function | [] -> raise Not_found | (v,k')::_ when k = k' -> v | _ :: l -> loop l in loop let tag_hypothesis,tag_of_hyp, hyp_of_tag, clear_tags = let l = ref ([]:(identifier * int) list) in (fun h id -> l := (h,id):: !l), (fun h -> try List.assoc h !l with Not_found -> failwith "tag_hypothesis"), (fun h -> try rev_assoc h !l with Not_found -> failwith "tag_hypothesis"), (fun () -> l := []) let hide_constr,find_constr,clear_constr_tables,dump_tables = let l = ref ([]:(constr * (identifier * identifier * bool)) list) in (fun h id eg b -> l := (h,(id,eg,b)):: !l), (fun h -> try list_assoc_f eq_constr h !l with Not_found -> failwith "find_contr"), (fun () -> l := []), (fun () -> !l) let reset_all () = if !reset_flag then begin reset_all_references (); reset_intern_tables (); clear_tags (); clear_constr_tables () end (* Lazy evaluation is used for Coq constants, because this code is evaluated before the compiled modules are loaded. To use the constant Zplus, one must type "Lazy.force coq_Zplus" This is the right way to access to Coq constants in tactics ML code *) open Coqlib let logic_dir = ["Coq";"Logic";"Decidable"] let coq_modules = init_modules @arith_modules @ [logic_dir] @ zarith_base_modules @ [["Coq"; "omega"; "OmegaLemmas"]] let init_constant = gen_constant_in_modules "Omega" init_modules let constant = gen_constant_in_modules "Omega" coq_modules let z_constant = gen_constant_in_modules "Omega" [["Coq";"ZArith"]] let zbase_constant = gen_constant_in_modules "Omega" [["Coq";"ZArith";"BinInt"]] (* Zarith *) let coq_xH = lazy (constant "xH") let coq_xO = lazy (constant "xO") let coq_xI = lazy (constant "xI") let coq_Z0 = lazy (constant "Z0") let coq_Zpos = lazy (constant "Zpos") let coq_Zneg = lazy (constant "Zneg") let coq_Z = lazy (constant "Z") let coq_comparison = lazy (constant "comparison") let coq_Gt = lazy (constant "Gt") let coq_Zplus = lazy (zbase_constant "Z.add") let coq_Zmult = lazy (zbase_constant "Z.mul") let coq_Zopp = lazy (zbase_constant "Z.opp") let coq_Zminus = lazy (zbase_constant "Z.sub") let coq_Zsucc = lazy (zbase_constant "Z.succ") let coq_Zpred = lazy (zbase_constant "Z.pred") let coq_Zgt = lazy (zbase_constant "Z.gt") let coq_Zle = lazy (zbase_constant "Z.le") let coq_Z_of_nat = lazy (zbase_constant "Z.of_nat") let coq_inj_plus = lazy (z_constant "Nat2Z.inj_add") let coq_inj_mult = lazy (z_constant "Nat2Z.inj_mul") let coq_inj_minus1 = lazy (z_constant "Nat2Z.inj_sub") let coq_inj_minus2 = lazy (constant "inj_minus2") let coq_inj_S = lazy (z_constant "Nat2Z.inj_succ") let coq_inj_le = lazy (z_constant "Znat.inj_le") let coq_inj_lt = lazy (z_constant "Znat.inj_lt") let coq_inj_ge = lazy (z_constant "Znat.inj_ge") let coq_inj_gt = lazy (z_constant "Znat.inj_gt") let coq_inj_neq = lazy (z_constant "inj_neq") let coq_inj_eq = lazy (z_constant "inj_eq") let coq_fast_Zplus_assoc_reverse = lazy (constant "fast_Zplus_assoc_reverse") let coq_fast_Zplus_assoc = lazy (constant "fast_Zplus_assoc") let coq_fast_Zmult_assoc_reverse = lazy (constant "fast_Zmult_assoc_reverse") let coq_fast_Zplus_permute = lazy (constant "fast_Zplus_permute") let coq_fast_Zplus_comm = lazy (constant "fast_Zplus_comm") let coq_fast_Zmult_comm = lazy (constant "fast_Zmult_comm") let coq_Zmult_le_approx = lazy (constant "Zmult_le_approx") let coq_OMEGA1 = lazy (constant "OMEGA1") let coq_OMEGA2 = lazy (constant "OMEGA2") let coq_OMEGA3 = lazy (constant "OMEGA3") let coq_OMEGA4 = lazy (constant "OMEGA4") let coq_OMEGA5 = lazy (constant "OMEGA5") let coq_OMEGA6 = lazy (constant "OMEGA6") let coq_OMEGA7 = lazy (constant "OMEGA7") let coq_OMEGA8 = lazy (constant "OMEGA8") let coq_OMEGA9 = lazy (constant "OMEGA9") let coq_fast_OMEGA10 = lazy (constant "fast_OMEGA10") let coq_fast_OMEGA11 = lazy (constant "fast_OMEGA11") let coq_fast_OMEGA12 = lazy (constant "fast_OMEGA12") let coq_fast_OMEGA13 = lazy (constant "fast_OMEGA13") let coq_fast_OMEGA14 = lazy (constant "fast_OMEGA14") let coq_fast_OMEGA15 = lazy (constant "fast_OMEGA15") let coq_fast_OMEGA16 = lazy (constant "fast_OMEGA16") let coq_OMEGA17 = lazy (constant "OMEGA17") let coq_OMEGA18 = lazy (constant "OMEGA18") let coq_OMEGA19 = lazy (constant "OMEGA19") let coq_OMEGA20 = lazy (constant "OMEGA20") let coq_fast_Zred_factor0 = lazy (constant "fast_Zred_factor0") let coq_fast_Zred_factor1 = lazy (constant "fast_Zred_factor1") let coq_fast_Zred_factor2 = lazy (constant "fast_Zred_factor2") let coq_fast_Zred_factor3 = lazy (constant "fast_Zred_factor3") let coq_fast_Zred_factor4 = lazy (constant "fast_Zred_factor4") let coq_fast_Zred_factor5 = lazy (constant "fast_Zred_factor5") let coq_fast_Zred_factor6 = lazy (constant "fast_Zred_factor6") let coq_fast_Zmult_plus_distr_l = lazy (constant "fast_Zmult_plus_distr_l") let coq_fast_Zmult_opp_comm = lazy (constant "fast_Zmult_opp_comm") let coq_fast_Zopp_plus_distr = lazy (constant "fast_Zopp_plus_distr") let coq_fast_Zopp_mult_distr_r = lazy (constant "fast_Zopp_mult_distr_r") let coq_fast_Zopp_eq_mult_neg_1 = lazy (constant "fast_Zopp_eq_mult_neg_1") let coq_fast_Zopp_involutive = lazy (constant "fast_Zopp_involutive") let coq_Zegal_left = lazy (constant "Zegal_left") let coq_Zne_left = lazy (constant "Zne_left") let coq_Zlt_left = lazy (constant "Zlt_left") let coq_Zge_left = lazy (constant "Zge_left") let coq_Zgt_left = lazy (constant "Zgt_left") let coq_Zle_left = lazy (constant "Zle_left") let coq_new_var = lazy (constant "new_var") let coq_intro_Z = lazy (constant "intro_Z") let coq_dec_eq = lazy (zbase_constant "Z.eq_decidable") let coq_dec_Zne = lazy (constant "dec_Zne") let coq_dec_Zle = lazy (zbase_constant "Z.le_decidable") let coq_dec_Zlt = lazy (zbase_constant "Z.lt_decidable") let coq_dec_Zgt = lazy (constant "dec_Zgt") let coq_dec_Zge = lazy (constant "dec_Zge") let coq_not_Zeq = lazy (constant "not_Zeq") let coq_not_Zne = lazy (constant "not_Zne") let coq_Znot_le_gt = lazy (constant "Znot_le_gt") let coq_Znot_lt_ge = lazy (constant "Znot_lt_ge") let coq_Znot_ge_lt = lazy (constant "Znot_ge_lt") let coq_Znot_gt_le = lazy (constant "Znot_gt_le") let coq_neq = lazy (constant "neq") let coq_Zne = lazy (constant "Zne") let coq_Zle = lazy (zbase_constant "Z.le") let coq_Zgt = lazy (zbase_constant "Z.gt") let coq_Zge = lazy (zbase_constant "Z.ge") let coq_Zlt = lazy (zbase_constant "Z.lt") (* Peano/Datatypes *) let coq_le = lazy (init_constant "le") let coq_lt = lazy (init_constant "lt") let coq_ge = lazy (init_constant "ge") let coq_gt = lazy (init_constant "gt") let coq_minus = lazy (init_constant "minus") let coq_plus = lazy (init_constant "plus") let coq_mult = lazy (init_constant "mult") let coq_pred = lazy (init_constant "pred") let coq_nat = lazy (init_constant "nat") let coq_S = lazy (init_constant "S") let coq_O = lazy (init_constant "O") (* Compare_dec/Peano_dec/Minus *) let coq_pred_of_minus = lazy (constant "pred_of_minus") let coq_le_gt_dec = lazy (constant "le_gt_dec") let coq_dec_eq_nat = lazy (constant "dec_eq_nat") let coq_dec_le = lazy (constant "dec_le") let coq_dec_lt = lazy (constant "dec_lt") let coq_dec_ge = lazy (constant "dec_ge") let coq_dec_gt = lazy (constant "dec_gt") let coq_not_eq = lazy (constant "not_eq") let coq_not_le = lazy (constant "not_le") let coq_not_lt = lazy (constant "not_lt") let coq_not_ge = lazy (constant "not_ge") let coq_not_gt = lazy (constant "not_gt") (* Logic/Decidable *) let coq_eq_ind_r = lazy (constant "eq_ind_r") let coq_dec_or = lazy (constant "dec_or") let coq_dec_and = lazy (constant "dec_and") let coq_dec_imp = lazy (constant "dec_imp") let coq_dec_iff = lazy (constant "dec_iff") let coq_dec_not = lazy (constant "dec_not") let coq_dec_False = lazy (constant "dec_False") let coq_dec_not_not = lazy (constant "dec_not_not") let coq_dec_True = lazy (constant "dec_True") let coq_not_or = lazy (constant "not_or") let coq_not_and = lazy (constant "not_and") let coq_not_imp = lazy (constant "not_imp") let coq_not_iff = lazy (constant "not_iff") let coq_not_not = lazy (constant "not_not") let coq_imp_simp = lazy (constant "imp_simp") let coq_iff = lazy (constant "iff") (* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *) (* For unfold *) open Closure let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with | Const kn when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) -> EvalConstRef kn | _ -> anomaly ("Coq_omega: "^s^" is not an evaluable constant") let sp_Zsucc = lazy (evaluable_ref_of_constr "Z.succ" coq_Zsucc) let sp_Zpred = lazy (evaluable_ref_of_constr "Z.pred" coq_Zpred) let sp_Zminus = lazy (evaluable_ref_of_constr "Z.sub" coq_Zminus) let sp_Zle = lazy (evaluable_ref_of_constr "Z.le" coq_Zle) let sp_Zgt = lazy (evaluable_ref_of_constr "Z.gt" coq_Zgt) let sp_Zge = lazy (evaluable_ref_of_constr "Z.ge" coq_Zge) let sp_Zlt = lazy (evaluable_ref_of_constr "Z.lt" coq_Zlt) let sp_not = lazy (evaluable_ref_of_constr "not" (lazy (build_coq_not ()))) let mk_var v = mkVar (id_of_string v) let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |]) let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |]) let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |]) let mk_eq t1 t2 = mkApp (build_coq_eq (), [| Lazy.force coq_Z; t1; t2 |]) let mk_le t1 t2 = mkApp (Lazy.force coq_Zle, [| t1; t2 |]) let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |]) let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |]) let mk_and t1 t2 = mkApp (build_coq_and (), [| t1; t2 |]) let mk_or t1 t2 = mkApp (build_coq_or (), [| t1; t2 |]) let mk_not t = mkApp (build_coq_not (), [| t |]) let mk_eq_rel t1 t2 = mkApp (build_coq_eq (), [| Lazy.force coq_comparison; t1; t2 |]) let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |]) let mk_integer n = let rec loop n = if n =? one then Lazy.force coq_xH else mkApp((if n mod two =? zero then Lazy.force coq_xO else Lazy.force coq_xI), [| loop (n/two) |]) in if n =? zero then Lazy.force coq_Z0 else mkApp ((if n >? zero then Lazy.force coq_Zpos else Lazy.force coq_Zneg), [| loop (abs n) |]) type omega_constant = | Zplus | Zmult | Zminus | Zsucc | Zopp | Zpred | Plus | Mult | Minus | Pred | S | O | Zpos | Zneg | Z0 | Z_of_nat | Eq | Neq | Zne | Zle | Zlt | Zge | Zgt | Z | Nat | And | Or | False | True | Not | Iff | Le | Lt | Ge | Gt | Other of string type omega_proposition = | Keq of constr * constr * constr | Kn type result = | Kvar of identifier | Kapp of omega_constant * constr list | Kimp of constr * constr | Kufo (* Nota: Kimp correspond to a binder (Prod), but hopefully we won't have to bother with term lifting: Kimp will correspond to anonymous product, for which (Rel 1) doesn't occur in the right term. Moreover, we'll work on fully introduced goals, hence no Rel's in the term parts that we manipulate, but rather Var's. Said otherwise: all constr manipulated here are closed *) let destructurate_prop t = let c, args = decompose_app t in match kind_of_term c, args with | _, [_;_;_] when eq_constr c (build_coq_eq ()) -> Kapp (Eq,args) | _, [_;_] when eq_constr c (Lazy.force coq_neq) -> Kapp (Neq,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zne) -> Kapp (Zne,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zle) -> Kapp (Zle,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zlt) -> Kapp (Zlt,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zge) -> Kapp (Zge,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zgt) -> Kapp (Zgt,args) | _, [_;_] when eq_constr c (build_coq_and ()) -> Kapp (And,args) | _, [_;_] when eq_constr c (build_coq_or ()) -> Kapp (Or,args) | _, [_;_] when eq_constr c (Lazy.force coq_iff) -> Kapp (Iff, args) | _, [_] when eq_constr c (build_coq_not ()) -> Kapp (Not,args) | _, [] when eq_constr c (build_coq_False ()) -> Kapp (False,args) | _, [] when eq_constr c (build_coq_True ()) -> Kapp (True,args) | _, [_;_] when eq_constr c (Lazy.force coq_le) -> Kapp (Le,args) | _, [_;_] when eq_constr c (Lazy.force coq_lt) -> Kapp (Lt,args) | _, [_;_] when eq_constr c (Lazy.force coq_ge) -> Kapp (Ge,args) | _, [_;_] when eq_constr c (Lazy.force coq_gt) -> Kapp (Gt,args) | Const sp, args -> Kapp (Other (string_of_path (path_of_global (ConstRef sp))),args) | Construct csp , args -> Kapp (Other (string_of_path (path_of_global (ConstructRef csp))), args) | Ind isp, args -> Kapp (Other (string_of_path (path_of_global (IndRef isp))),args) | Var id,[] -> Kvar id | Prod (Anonymous,typ,body), [] -> Kimp(typ,body) | Prod (Name _,_,_),[] -> error "Omega: Not a quantifier-free goal" | _ -> Kufo let destructurate_type t = let c, args = decompose_app t in match kind_of_term c, args with | _, [] when eq_constr c (Lazy.force coq_Z) -> Kapp (Z,args) | _, [] when eq_constr c (Lazy.force coq_nat) -> Kapp (Nat,args) | _ -> Kufo let destructurate_term t = let c, args = decompose_app t in match kind_of_term c, args with | _, [_;_] when eq_constr c (Lazy.force coq_Zplus) -> Kapp (Zplus,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zmult) -> Kapp (Zmult,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zminus) -> Kapp (Zminus,args) | _, [_] when eq_constr c (Lazy.force coq_Zsucc) -> Kapp (Zsucc,args) | _, [_] when eq_constr c (Lazy.force coq_Zpred) -> Kapp (Zpred,args) | _, [_] when eq_constr c (Lazy.force coq_Zopp) -> Kapp (Zopp,args) | _, [_;_] when eq_constr c (Lazy.force coq_plus) -> Kapp (Plus,args) | _, [_;_] when eq_constr c (Lazy.force coq_mult) -> Kapp (Mult,args) | _, [_;_] when eq_constr c (Lazy.force coq_minus) -> Kapp (Minus,args) | _, [_] when eq_constr c (Lazy.force coq_pred) -> Kapp (Pred,args) | _, [_] when eq_constr c (Lazy.force coq_S) -> Kapp (S,args) | _, [] when eq_constr c (Lazy.force coq_O) -> Kapp (O,args) | _, [_] when eq_constr c (Lazy.force coq_Zpos) -> Kapp (Zneg,args) | _, [_] when eq_constr c (Lazy.force coq_Zneg) -> Kapp (Zpos,args) | _, [] when eq_constr c (Lazy.force coq_Z0) -> Kapp (Z0,args) | _, [_] when eq_constr c (Lazy.force coq_Z_of_nat) -> Kapp (Z_of_nat,args) | Var id,[] -> Kvar id | _ -> Kufo let recognize_number t = let rec loop t = match decompose_app t with | f, [t] when eq_constr f (Lazy.force coq_xI) -> one + two * loop t | f, [t] when eq_constr f (Lazy.force coq_xO) -> two * loop t | f, [] when eq_constr f (Lazy.force coq_xH) -> one | _ -> failwith "not a number" in match decompose_app t with | f, [t] when eq_constr f (Lazy.force coq_Zpos) -> loop t | f, [t] when eq_constr f (Lazy.force coq_Zneg) -> neg (loop t) | f, [] when eq_constr f (Lazy.force coq_Z0) -> zero | _ -> failwith "not a number" type constr_path = | P_APP of int (* Abstraction and product *) | P_BODY | P_TYPE (* Case *) | P_BRANCH of int | P_ARITY | P_ARG let context operation path (t : constr) = let rec loop i p0 t = match (p0,kind_of_term t) with | (p, Cast (c,k,t)) -> mkCast (loop i p c,k,t) | ([], _) -> operation i t | ((P_APP n :: p), App (f,v)) -> let v' = Array.copy v in v'.(pred n) <- loop i p v'.(pred n); mkApp (f, v') | ((P_BRANCH n :: p), Case (ci,q,c,v)) -> (* avant, y avait mkApp... anyway, BRANCH seems nowhere used *) let v' = Array.copy v in v'.(n) <- loop i p v'.(n); (mkCase (ci,q,c,v')) | ((P_ARITY :: p), App (f,l)) -> appvect (loop i p f,l) | ((P_ARG :: p), App (f,v)) -> let v' = Array.copy v in v'.(0) <- loop i p v'.(0); mkApp (f,v') | (p, Fix ((_,n as ln),(tys,lna,v))) -> let l = Array.length v in let v' = Array.copy v in v'.(n)<- loop (Pervasives.(+) i l) p v.(n); (mkFix (ln,(tys,lna,v'))) | ((P_BODY :: p), Prod (n,t,c)) -> (mkProd (n,t,loop (succ i) p c)) | ((P_BODY :: p), Lambda (n,t,c)) -> (mkLambda (n,t,loop (succ i) p c)) | ((P_BODY :: p), LetIn (n,b,t,c)) -> (mkLetIn (n,b,t,loop (succ i) p c)) | ((P_TYPE :: p), Prod (n,t,c)) -> (mkProd (n,loop i p t,c)) | ((P_TYPE :: p), Lambda (n,t,c)) -> (mkLambda (n,loop i p t,c)) | ((P_TYPE :: p), LetIn (n,b,t,c)) -> (mkLetIn (n,b,loop i p t,c)) | (p, _) -> ppnl (Printer.pr_lconstr t); failwith ("abstract_path " ^ string_of_int(List.length p)) in loop 1 path t let occurence path (t : constr) = let rec loop p0 t = match (p0,kind_of_term t) with | (p, Cast (c,_,_)) -> loop p c | ([], _) -> t | ((P_APP n :: p), App (f,v)) -> loop p v.(pred n) | ((P_BRANCH n :: p), Case (_,_,_,v)) -> loop p v.(n) | ((P_ARITY :: p), App (f,_)) -> loop p f | ((P_ARG :: p), App (f,v)) -> loop p v.(0) | (p, Fix((_,n) ,(_,_,v))) -> loop p v.(n) | ((P_BODY :: p), Prod (n,t,c)) -> loop p c | ((P_BODY :: p), Lambda (n,t,c)) -> loop p c | ((P_BODY :: p), LetIn (n,b,t,c)) -> loop p c | ((P_TYPE :: p), Prod (n,term,c)) -> loop p term | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term | (p, _) -> ppnl (Printer.pr_lconstr t); failwith ("occurence " ^ string_of_int(List.length p)) in loop path t let abstract_path typ path t = let term_occur = ref (mkRel 0) in let abstract = context (fun i t -> term_occur:= t; mkRel i) path t in mkLambda (Name (id_of_string "x"), typ, abstract), !term_occur let focused_simpl path gl = let newc = context (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in convert_concl_no_check newc DEFAULTcast gl let focused_simpl path = simpl_time (focused_simpl path) type oformula = | Oplus of oformula * oformula | Oinv of oformula | Otimes of oformula * oformula | Oatom of identifier | Oz of bigint | Oufo of constr let rec oprint = function | Oplus(t1,t2) -> print_string "("; oprint t1; print_string "+"; oprint t2; print_string ")" | Oinv t -> print_string "~"; oprint t | Otimes (t1,t2) -> print_string "("; oprint t1; print_string "*"; oprint t2; print_string ")" | Oatom s -> print_string (string_of_id s) | Oz i -> print_string (string_of_bigint i) | Oufo f -> print_string "?" let rec weight = function | Oatom c -> intern_id c | Oz _ -> -1 | Oinv c -> weight c | Otimes(c,_) -> weight c | Oplus _ -> failwith "weight" | Oufo _ -> -1 let rec val_of = function | Oatom c -> mkVar c | Oz c -> mk_integer c | Oinv c -> mkApp (Lazy.force coq_Zopp, [| val_of c |]) | Otimes (t1,t2) -> mkApp (Lazy.force coq_Zmult, [| val_of t1; val_of t2 |]) | Oplus(t1,t2) -> mkApp (Lazy.force coq_Zplus, [| val_of t1; val_of t2 |]) | Oufo c -> c let compile name kind = let rec loop accu = function | Oplus(Otimes(Oatom v,Oz n),r) -> loop ({v=intern_id v; c=n} :: accu) r | Oz n -> let id = new_id () in tag_hypothesis name id; {kind = kind; body = List.rev accu; constant = n; id = id} | _ -> anomaly "compile_equation" in loop [] let rec decompile af = let rec loop = function | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r) | [] -> Oz af.constant in loop af.body let mkNewMeta () = mkMeta (Evarutil.new_meta()) let clever_rewrite_base_poly typ p result theorem gl = let full = pf_concl gl in let (abstracted,occ) = abstract_path typ (List.rev p) full in let t = applist (mkLambda (Name (id_of_string "P"), mkArrow typ mkProp, mkLambda (Name (id_of_string "H"), applist (mkRel 1,[result]), mkApp (Lazy.force coq_eq_ind_r, [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), [abstracted]) in exact (applist(t,[mkNewMeta()])) gl let clever_rewrite_base p result theorem gl = clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem gl let clever_rewrite_base_nat p result theorem gl = clever_rewrite_base_poly (Lazy.force coq_nat) p result theorem gl let clever_rewrite_gen p result (t,args) = let theorem = applist(t, args) in clever_rewrite_base p result theorem let clever_rewrite_gen_nat p result (t,args) = let theorem = applist(t, args) in clever_rewrite_base_nat p result theorem let clever_rewrite p vpath t gl = let full = pf_concl gl in let (abstracted,occ) = abstract_path (Lazy.force coq_Z) (List.rev p) full in let vargs = List.map (fun p -> occurence p occ) vpath in let t' = applist(t, (vargs @ [abstracted])) in exact (applist(t',[mkNewMeta()])) gl let rec shuffle p (t1,t2) = match t1,t2 with | Oplus(l1,r1), Oplus(l2,r2) -> if weight l1 > weight l2 then let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in (clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: tac, Oplus(l1,t')) else let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in (clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zplus_permute) :: tac, Oplus(l2,t')) | Oplus(l1,r1), t2 -> if weight l1 > weight t2 then let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: tac, Oplus(l1, t') else [clever_rewrite p [[P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zplus_comm)], Oplus(t2,t1) | t1,Oplus(l2,r2) -> if weight l2 > weight t1 then let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zplus_permute) :: tac, Oplus(l2,t') else [],Oplus(t1,t2) | Oz t1,Oz t2 -> [focused_simpl p], Oz(Bigint.add t1 t2) | t1,t2 -> if weight t1 < weight t2 then [clever_rewrite p [[P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zplus_comm)], Oplus(t2,t1) else [],Oplus(t1,t2) let rec shuffle_mult p_init k1 e1 k2 e2 = let rec loop p = function | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> if v1 = v2 then let tac = clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2; P_APP 1; P_APP 2]; [P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA10) in if Bigint.add (Bigint.mult k1 c1) (Bigint.mult k2 c2) =? zero then let tac' = clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zred_factor5) in tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: loop p (l1,l2) else tac :: loop (P_APP 2 :: p) (l1,l2) else if v1 > v2 then clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]] (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) (l1,l2') else clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1]; [P_APP 2; P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA12) :: loop (P_APP 2 :: p) (l1',l2) | ({c=c1;v=v1}::l1), [] -> clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]] (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) (l1,[]) | [],({c=c2;v=v2}::l2) -> clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1]; [P_APP 2; P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA12) :: loop (P_APP 2 :: p) ([],l2) | [],[] -> [focused_simpl p_init] in loop p_init (e1,e2) let rec shuffle_mult_right p_init e1 k2 e2 = let rec loop p = function | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> if v1 = v2 then let tac = clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1]; [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 2]; [P_APP 2; P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA15) in if Bigint.add c1 (Bigint.mult k2 c2) =? zero then let tac' = clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zred_factor5) in tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: loop p (l1,l2) else tac :: loop (P_APP 2 :: p) (l1,l2) else if v1 > v2 then clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: loop (P_APP 2 :: p) (l1,l2') else clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1]; [P_APP 2; P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA12) :: loop (P_APP 2 :: p) (l1',l2) | ({c=c1;v=v1}::l1), [] -> clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: loop (P_APP 2 :: p) (l1,[]) | [],({c=c2;v=v2}::l2) -> clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1]; [P_APP 2; P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA12) :: loop (P_APP 2 :: p) ([],l2) | [],[] -> [focused_simpl p_init] in loop p_init (e1,e2) let rec shuffle_cancel p = function | [] -> [focused_simpl p] | ({c=c1}::l1) -> let tac = clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2; P_APP 1]] (if c1 >? zero then (Lazy.force coq_fast_OMEGA13) else (Lazy.force coq_fast_OMEGA14)) in tac :: shuffle_cancel p l1 let rec scalar p n = function | Oplus(t1,t2) -> let tac1,t1' = scalar (P_APP 1 :: p) n t1 and tac2,t2' = scalar (P_APP 2 :: p) n t2 in clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zmult_plus_distr_l) :: (tac1 @ tac2), Oplus(t1',t2') | Oinv t -> [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zmult_opp_comm); focused_simpl (P_APP 2 :: p)], Otimes(t,Oz(neg n)) | Otimes(t1,Oz x) -> [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zmult_assoc_reverse); focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (n*x)) | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products" | (Oatom _ as t) -> [], Otimes(t,Oz n) | Oz i -> [focused_simpl p],Oz(n*i) | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zmult, [| mk_integer n; c |])) let rec scalar_norm p_init = let rec loop p = function | [] -> [focused_simpl p_init] | (_::l) -> clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_OMEGA16) :: loop (P_APP 2 :: p) l in loop p_init let rec norm_add p_init = let rec loop p = function | [] -> [focused_simpl p_init] | _:: l -> clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: loop (P_APP 2 :: p) l in loop p_init let rec scalar_norm_add p_init = let rec loop p = function | [] -> [focused_simpl p_init] | _ :: l -> clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]] (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) l in loop p_init let rec negate p = function | Oplus(t1,t2) -> let tac1,t1' = negate (P_APP 1 :: p) t1 and tac2,t2' = negate (P_APP 2 :: p) t2 in clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] (Lazy.force coq_fast_Zopp_plus_distr) :: (tac1 @ tac2), Oplus(t1',t2') | Oinv t -> [clever_rewrite p [[P_APP 1;P_APP 1]] (Lazy.force coq_fast_Zopp_involutive)], t | Otimes(t1,Oz x) -> [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] (Lazy.force coq_fast_Zopp_mult_distr_r); focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (neg x)) | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products" | (Oatom _ as t) -> let r = Otimes(t,Oz(negone)) in [clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1)], r | Oz i -> [focused_simpl p],Oz(neg i) | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zopp, [| c |])) let rec transform p t = let default isnat t' = try let v,th,_ = find_constr t' in [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v with e when Errors.noncritical e -> let v = new_identifier_var () and th = new_identifier () in hide_constr t' v th isnat; [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v in try match destructurate_term t with | Kapp(Zplus,[t1;t2]) -> let tac1,t1' = transform (P_APP 1 :: p) t1 and tac2,t2' = transform (P_APP 2 :: p) t2 in let tac,t' = shuffle p (t1',t2') in tac1 @ tac2 @ tac, t' | Kapp(Zminus,[t1;t2]) -> let tac,t = transform p (mkApp (Lazy.force coq_Zplus, [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in unfold sp_Zminus :: tac,t | Kapp(Zsucc,[t1]) -> let tac,t = transform p (mkApp (Lazy.force coq_Zplus, [| t1; mk_integer one |])) in unfold sp_Zsucc :: tac,t | Kapp(Zpred,[t1]) -> let tac,t = transform p (mkApp (Lazy.force coq_Zplus, [| t1; mk_integer negone |])) in unfold sp_Zpred :: tac,t | Kapp(Zmult,[t1;t2]) -> let tac1,t1' = transform (P_APP 1 :: p) t1 and tac2,t2' = transform (P_APP 2 :: p) t2 in begin match t1',t2' with | (_,Oz n) -> let tac,t' = scalar p n t1' in tac1 @ tac2 @ tac,t' | (Oz n,_) -> let sym = clever_rewrite p [[P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zmult_comm) in let tac,t' = scalar p n t2' in tac1 @ tac2 @ (sym :: tac),t' | _ -> default false t end | Kapp((Zpos|Zneg|Z0),_) -> (try ([],Oz(recognize_number t)) with e when Errors.noncritical e -> default false t) | Kvar s -> [],Oatom s | Kapp(Zopp,[t]) -> let tac,t' = transform (P_APP 1 :: p) t in let tac',t'' = negate p t' in tac @ tac', t'' | Kapp(Z_of_nat,[t']) -> default true t' | _ -> default false t with e when catchable_exception e -> default false t let shrink_pair p f1 f2 = match f1,f2 with | Oatom v,Oatom _ -> let r = Otimes(Oatom v,Oz two) in clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zred_factor1), r | Oatom v, Otimes(_,c2) -> let r = Otimes(Oatom v,Oplus(c2,Oz one)) in clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zred_factor2), r | Otimes (v1,c1),Oatom v -> let r = Otimes(Oatom v,Oplus(c1,Oz one)) in clever_rewrite p [[P_APP 2];[P_APP 1;P_APP 2]] (Lazy.force coq_fast_Zred_factor3), r | Otimes (Oatom v,c1),Otimes (v2,c2) -> let r = Otimes(Oatom v,Oplus(c1,c2)) in clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zred_factor4),r | t1,t2 -> begin oprint t1; print_newline (); oprint t2; print_newline (); flush Pervasives.stdout; error "shrink.1" end let reduce_factor p = function | Oatom v -> let r = Otimes(Oatom v,Oz one) in [clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor0)],r | Otimes(Oatom v,Oz n) as f -> [],f | Otimes(Oatom v,c) -> let rec compute = function | Oz n -> n | Oplus(t1,t2) -> Bigint.add (compute t1) (compute t2) | _ -> error "condense.1" in [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c)) | t -> oprint t; error "reduce_factor.1" let rec condense p = function | Oplus(f1,(Oplus(f2,r) as t)) -> if weight f1 = weight f2 then begin let shrink_tac,t = shrink_pair (P_APP 1 :: p) f1 f2 in let assoc_tac = clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zplus_assoc) in let tac_list,t' = condense p (Oplus(t,r)) in (assoc_tac :: shrink_tac :: tac_list), t' end else begin let tac,f = reduce_factor (P_APP 1 :: p) f1 in let tac',t' = condense (P_APP 2 :: p) t in (tac @ tac'), Oplus(f,t') end | Oplus(f1,Oz n) -> let tac,f1' = reduce_factor (P_APP 1 :: p) f1 in tac,Oplus(f1',Oz n) | Oplus(f1,f2) -> if weight f1 = weight f2 then begin let tac_shrink,t = shrink_pair p f1 f2 in let tac,t' = condense p t in tac_shrink :: tac,t' end else begin let tac,f = reduce_factor (P_APP 1 :: p) f1 in let tac',t' = condense (P_APP 2 :: p) f2 in (tac @ tac'),Oplus(f,t') end | Oz _ as t -> [],t | t -> let tac,t' = reduce_factor p t in let final = Oplus(t',Oz zero) in let tac' = clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor6) in tac @ [tac'], final let rec clear_zero p = function | Oplus(Otimes(Oatom v,Oz n),r) when n =? zero -> let tac = clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zred_factor5) in let tac',t = clear_zero p r in tac :: tac',t | Oplus(f,r) -> let tac,t = clear_zero (P_APP 2 :: p) r in tac,Oplus(f,t) | t -> [],t let replay_history tactic_normalisation = let aux = id_of_string "auxiliary" in let aux1 = id_of_string "auxiliary_1" in let aux2 = id_of_string "auxiliary_2" in let izero = mk_integer zero in let rec loop t = match t with | HYP e :: l -> begin try tclTHEN (List.assoc (hyp_of_tag e.id) tactic_normalisation) (loop l) with Not_found -> loop l end | NEGATE_CONTRADICT (e2,e1,b) :: l -> let eq1 = decompile e1 and eq2 = decompile e2 in let id1 = hyp_of_tag e1.id and id2 = hyp_of_tag e2.id in let k = if b then negone else one in let p_initial = [P_APP 1;P_TYPE] in let tac= shuffle_mult_right p_initial e1.body k e2.body in tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_OMEGA17, [| val_of eq1; val_of eq2; mk_integer k; mkVar id1; mkVar id2 |])]); (mk_then tac); (intros_using [aux]); (resolve_id aux); reflexivity ] | CONTRADICTION (e1,e2) :: l -> let eq1 = decompile e1 and eq2 = decompile e2 in let p_initial = [P_APP 2;P_TYPE] in let tac = shuffle_cancel p_initial e1.body in let solve_le = let not_sup_sup = mkApp (build_coq_eq (), [| Lazy.force coq_comparison; Lazy.force coq_Gt; Lazy.force coq_Gt |]) in tclTHENS (tclTHENLIST [ (unfold sp_Zle); (simpl_in_concl); intro; (absurd not_sup_sup) ]) [ assumption ; reflexivity ] in let theorem = mkApp (Lazy.force coq_OMEGA2, [| val_of eq1; val_of eq2; mkVar (hyp_of_tag e1.id); mkVar (hyp_of_tag e2.id) |]) in tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) (solve_le) | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> let id = hyp_of_tag e1.id in let eq1 = val_of(decompile e1) and eq2 = val_of(decompile e2) in let kk = mk_integer k and dd = mk_integer d in let rhs = mk_plus (mk_times eq2 kk) dd in let state_eg = mk_eq eq1 rhs in let tac = scalar_norm_add [P_APP 3] e2.body in tclTHENS (cut state_eg) [ tclTHENS (tclTHENLIST [ (intros_using [aux]); (generalize_tac [mkApp (Lazy.force coq_OMEGA1, [| eq1; rhs; mkVar aux; mkVar id |])]); (clear [aux;id]); (intros_using [id]); (cut (mk_gt kk dd)) ]) [ tclTHENS (cut (mk_gt kk izero)) [ tclTHENLIST [ (intros_using [aux1; aux2]); (generalize_tac [mkApp (Lazy.force coq_Zmult_le_approx, [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]); (clear [aux1;aux2;id]); (intros_using [id]); (loop l) ]; tclTHENLIST [ (unfold sp_Zgt); (simpl_in_concl); reflexivity ] ]; tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ] ]; tclTHEN (mk_then tac) reflexivity ] | NOT_EXACT_DIVIDE (e1,k) :: l -> let c = floor_div e1.constant k in let d = Bigint.sub e1.constant (Bigint.mult c k) in let e2 = {id=e1.id; kind=EQUA;constant = c; body = map_eq_linear (fun c -> c / k) e1.body } in let eq2 = val_of(decompile e2) in let kk = mk_integer k and dd = mk_integer d in let tac = scalar_norm_add [P_APP 2] e2.body in tclTHENS (cut (mk_gt dd izero)) [ tclTHENS (cut (mk_gt kk dd)) [tclTHENLIST [ (intros_using [aux2;aux1]); (generalize_tac [mkApp (Lazy.force coq_OMEGA4, [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]); (clear [aux1;aux2]); (unfold sp_not); (intros_using [aux]); (resolve_id aux); (mk_then tac); assumption ] ; tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ] ]; tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ] ] | EXACT_DIVIDE (e1,k) :: l -> let id = hyp_of_tag e1.id in let e2 = map_eq_afine (fun c -> c / k) e1 in let eq1 = val_of(decompile e1) and eq2 = val_of(decompile e2) in let kk = mk_integer k in let state_eq = mk_eq eq1 (mk_times eq2 kk) in if e1.kind = DISE then let tac = scalar_norm [P_APP 3] e2.body in tclTHENS (cut state_eq) [tclTHENLIST [ (intros_using [aux1]); (generalize_tac [mkApp (Lazy.force coq_OMEGA18, [| eq1;eq2;kk;mkVar aux1; mkVar id |])]); (clear [aux1;id]); (intros_using [id]); (loop l) ]; tclTHEN (mk_then tac) reflexivity ] else let tac = scalar_norm [P_APP 3] e2.body in tclTHENS (cut state_eq) [ tclTHENS (cut (mk_gt kk izero)) [tclTHENLIST [ (intros_using [aux2;aux1]); (generalize_tac [mkApp (Lazy.force coq_OMEGA3, [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]); (clear [aux1;aux2;id]); (intros_using [id]); (loop l) ]; tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ] ]; tclTHEN (mk_then tac) reflexivity ] | (MERGE_EQ(e3,e1,e2)) :: l -> let id = new_identifier () in tag_hypothesis id e3; let id1 = hyp_of_tag e1.id and id2 = hyp_of_tag e2 in let eq1 = val_of(decompile e1) and eq2 = val_of (decompile (negate_eq e1)) in let tac = clever_rewrite [P_APP 3] [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: scalar_norm [P_APP 3] e1.body in tclTHENS (cut (mk_eq eq1 (mk_inv eq2))) [tclTHENLIST [ (intros_using [aux]); (generalize_tac [mkApp (Lazy.force coq_OMEGA8, [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]); (clear [id1;id2;aux]); (intros_using [id]); (loop l) ]; tclTHEN (mk_then tac) reflexivity] | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l -> let id = new_identifier () and id2 = hyp_of_tag orig.id in tag_hypothesis id e.id; let eq1 = val_of(decompile def) and eq2 = val_of(decompile orig) in let vid = unintern_id v in let theorem = mkApp (build_coq_ex (), [| Lazy.force coq_Z; mkLambda (Name vid, Lazy.force coq_Z, mk_eq (mkRel 1) eq1) |]) in let mm = mk_integer m in let p_initial = [P_APP 2;P_TYPE] in let tac = clever_rewrite (P_APP 1 :: P_APP 1 :: P_APP 2 :: p_initial) [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: shuffle_mult_right p_initial orig.body m ({c= negone;v= v}::def.body) in tclTHENS (cut theorem) [tclTHENLIST [ (intros_using [aux]); (elim_id aux); (clear [aux]); (intros_using [vid; aux]); (generalize_tac [mkApp (Lazy.force coq_OMEGA9, [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]); (mk_then tac); (clear [aux]); (intros_using [id]); (loop l) ]; tclTHEN (exists_tac eq1) reflexivity ] | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> let id1 = new_identifier () and id2 = new_identifier () in tag_hypothesis id1 e1; tag_hypothesis id2 e2; let id = hyp_of_tag e.id in let tac1 = norm_add [P_APP 2;P_TYPE] e.body in let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in let eq = val_of(decompile e) in tclTHENS (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id]))) [tclTHENLIST [ (mk_then tac1); (intros_using [id1]); (loop act1) ]; tclTHENLIST [ (mk_then tac2); (intros_using [id2]); (loop act2) ]] | SUM(e3,(k1,e1),(k2,e2)) :: l -> let id = new_identifier () in tag_hypothesis id e3; let id1 = hyp_of_tag e1.id and id2 = hyp_of_tag e2.id in let eq1 = val_of(decompile e1) and eq2 = val_of(decompile e2) in if k1 =? one & e2.kind = EQUA then let tac_thm = match e1.kind with | EQUA -> Lazy.force coq_OMEGA5 | INEQ -> Lazy.force coq_OMEGA6 | DISE -> Lazy.force coq_OMEGA20 in let kk = mk_integer k2 in let p_initial = if e1.kind=DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in let tac = shuffle_mult_right p_initial e1.body k2 e2.body in tclTHENLIST [ (generalize_tac [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]); (mk_then tac); (intros_using [id]); (loop l) ] else let kk1 = mk_integer k1 and kk2 = mk_integer k2 in let p_initial = [P_APP 2;P_TYPE] in let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in tclTHENS (cut (mk_gt kk1 izero)) [tclTHENS (cut (mk_gt kk2 izero)) [tclTHENLIST [ (intros_using [aux2;aux1]); (generalize_tac [mkApp (Lazy.force coq_OMEGA7, [| eq1;eq2;kk1;kk2; mkVar aux1;mkVar aux2; mkVar id1;mkVar id2 |])]); (clear [aux1;aux2]); (mk_then tac); (intros_using [id]); (loop l) ]; tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ] ]; tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ] ] | CONSTANT_NOT_NUL(e,k) :: l -> tclTHEN (generalize_tac [mkVar (hyp_of_tag e)]) Equality.discrConcl | CONSTANT_NUL(e) :: l -> tclTHEN (resolve_id (hyp_of_tag e)) reflexivity | CONSTANT_NEG(e,k) :: l -> tclTHENLIST [ (generalize_tac [mkVar (hyp_of_tag e)]); (unfold sp_Zle); simpl_in_concl; (unfold sp_not); (intros_using [aux]); (resolve_id aux); reflexivity ] | _ -> tclIDTAC in loop let normalize p_initial t = let (tac,t') = transform p_initial t in let (tac',t'') = condense p_initial t' in let (tac'',t''') = clear_zero p_initial t'' in tac @ tac' @ tac'' , t''' let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) = let p_initial = [P_APP pos ;P_TYPE] in let (tac,t') = normalize p_initial t in let shift_left = tclTHEN (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ]) (tclTRY (clear [id])) in if tac <> [] then let id' = new_identifier () in ((id',(tclTHENLIST [ (shift_left); (mk_then tac); (intros_using [id']) ])) :: tactic, compile id' flag t' :: defs) else (tactic,defs) let destructure_omega gl tac_def (id,c) = if atompart_of_id id = "State" then tac_def else try match destructurate_prop c with | Kapp(Eq,[typ;t1;t2]) when destructurate_type (pf_nf gl typ) = Kapp(Z,[]) -> let t = mk_plus t1 (mk_inv t2) in normalize_equation id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def | Kapp(Zne,[t1;t2]) -> let t = mk_plus t1 (mk_inv t2) in normalize_equation id DISE (Lazy.force coq_Zne_left) 1 t t1 t2 tac_def | Kapp(Zle,[t1;t2]) -> let t = mk_plus t2 (mk_inv t1) in normalize_equation id INEQ (Lazy.force coq_Zle_left) 2 t t1 t2 tac_def | Kapp(Zlt,[t1;t2]) -> let t = mk_plus (mk_plus t2 (mk_integer negone)) (mk_inv t1) in normalize_equation id INEQ (Lazy.force coq_Zlt_left) 2 t t1 t2 tac_def | Kapp(Zge,[t1;t2]) -> let t = mk_plus t1 (mk_inv t2) in normalize_equation id INEQ (Lazy.force coq_Zge_left) 2 t t1 t2 tac_def | Kapp(Zgt,[t1;t2]) -> let t = mk_plus (mk_plus t1 (mk_integer negone)) (mk_inv t2) in normalize_equation id INEQ (Lazy.force coq_Zgt_left) 2 t t1 t2 tac_def | _ -> tac_def with e when catchable_exception e -> tac_def let reintroduce id = (* [id] cannot be cleared if dependent: protect it by a try *) tclTHEN (tclTRY (clear [id])) (intro_using id) let coq_omega gl = clear_constr_tables (); let tactic_normalisation, system = List.fold_left (destructure_omega gl) ([],[]) (pf_hyps_types gl) in let prelude,sys = List.fold_left (fun (tac,sys) (t,(v,th,b)) -> if b then let id = new_identifier () in let i = new_id () in tag_hypothesis id i; (tclTHENLIST [ (simplest_elim (applist (Lazy.force coq_intro_Z, [t]))); (intros_using [v; id]); (elim_id id); (clear [id]); (intros_using [th;id]); tac ]), {kind = INEQ; body = [{v=intern_id v; c=one}]; constant = zero; id = i} :: sys else (tclTHENLIST [ (simplest_elim (applist (Lazy.force coq_new_var, [t]))); (intros_using [v;th]); tac ]), sys) (tclIDTAC,[]) (dump_tables ()) in let system = system @ sys in if !display_system_flag then display_system display_var system; if !old_style_flag then begin try let _ = simplify (new_id,new_var_num,display_var) false system in tclIDTAC gl with UNSOLVABLE -> let _,path = depend [] [] (history ()) in if !display_action_flag then display_action display_var path; (tclTHEN prelude (replay_history tactic_normalisation path)) gl end else begin try let path = simplify_strong (new_id,new_var_num,display_var) system in if !display_action_flag then display_action display_var path; (tclTHEN prelude (replay_history tactic_normalisation path)) gl with NO_CONTRADICTION -> error "Omega can't solve this system" end let coq_omega = solver_time coq_omega let nat_inject gl = let rec explore p t = try match destructurate_term t with | Kapp(Plus,[t1;t2]) -> tclTHENLIST [ (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2)) ((Lazy.force coq_inj_plus),[t1;t2])); (explore (P_APP 1 :: p) t1); (explore (P_APP 2 :: p) t2) ] | Kapp(Mult,[t1;t2]) -> tclTHENLIST [ (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2)) ((Lazy.force coq_inj_mult),[t1;t2])); (explore (P_APP 1 :: p) t1); (explore (P_APP 2 :: p) t2) ] | Kapp(Minus,[t1;t2]) -> let id = new_identifier () in tclTHENS (tclTHEN (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) (intros_using [id])) [ tclTHENLIST [ (clever_rewrite_gen p (mk_minus (mk_inj t1) (mk_inj t2)) ((Lazy.force coq_inj_minus1),[t1;t2;mkVar id])); (loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]); (explore (P_APP 1 :: p) t1); (explore (P_APP 2 :: p) t2) ]; (tclTHEN (clever_rewrite_gen p (mk_integer zero) ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id])) (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])])) ] | Kapp(S,[t']) -> let rec is_number t = try match destructurate_term t with Kapp(S,[t]) -> is_number t | Kapp(O,[]) -> true | _ -> false with e when catchable_exception e -> false in let rec loop p t = try match destructurate_term t with Kapp(S,[t]) -> (tclTHEN (clever_rewrite_gen p (mkApp (Lazy.force coq_Zsucc, [| mk_inj t |])) ((Lazy.force coq_inj_S),[t])) (loop (P_APP 1 :: p) t)) | _ -> explore p t with e when catchable_exception e -> explore p t in if is_number t' then focused_simpl p else loop p t | Kapp(Pred,[t]) -> let t_minus_one = mkApp (Lazy.force coq_minus, [| t; mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in tclTHEN (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one ((Lazy.force coq_pred_of_minus),[t])) (explore p t_minus_one) | Kapp(O,[]) -> focused_simpl p | _ -> tclIDTAC with e when catchable_exception e -> tclIDTAC and loop = function | [] -> tclIDTAC | (i,t)::lit -> begin try match destructurate_prop t with Kapp(Le,[t1;t2]) -> tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); (explore [P_APP 2; P_TYPE] t2); (reintroduce i); (loop lit) ] | Kapp(Lt,[t1;t2]) -> tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); (explore [P_APP 2; P_TYPE] t2); (reintroduce i); (loop lit) ] | Kapp(Ge,[t1;t2]) -> tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); (explore [P_APP 2; P_TYPE] t2); (reintroduce i); (loop lit) ] | Kapp(Gt,[t1;t2]) -> tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_gt, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); (explore [P_APP 2; P_TYPE] t2); (reintroduce i); (loop lit) ] | Kapp(Neq,[t1;t2]) -> tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_neq, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); (explore [P_APP 2; P_TYPE] t2); (reintroduce i); (loop lit) ] | Kapp(Eq,[typ;t1;t2]) -> if pf_conv_x gl typ (Lazy.force coq_nat) then tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]); (explore [P_APP 2; P_TYPE] t1); (explore [P_APP 3; P_TYPE] t2); (reintroduce i); (loop lit) ] else loop lit | _ -> loop lit with e when catchable_exception e -> loop lit end in loop (List.rev (pf_hyps_types gl)) gl let dec_binop = function | Zne -> coq_dec_Zne | Zle -> coq_dec_Zle | Zlt -> coq_dec_Zlt | Zge -> coq_dec_Zge | Zgt -> coq_dec_Zgt | Le -> coq_dec_le | Lt -> coq_dec_lt | Ge -> coq_dec_ge | Gt -> coq_dec_gt | _ -> raise Not_found let not_binop = function | Zne -> coq_not_Zne | Zle -> coq_Znot_le_gt | Zlt -> coq_Znot_lt_ge | Zge -> coq_Znot_ge_lt | Zgt -> coq_Znot_gt_le | Le -> coq_not_le | Lt -> coq_not_lt | Ge -> coq_not_ge | Gt -> coq_not_gt | _ -> raise Not_found (** A decidability check : for some [t], could we build a term of type [decidable t] (i.e. [t\/~t]) ? Otherwise, we raise [Undecidable]. Note that a successful check implies that [t] has type Prop. *) exception Undecidable let rec decidability gl t = match destructurate_prop t with | Kapp(Or,[t1;t2]) -> mkApp (Lazy.force coq_dec_or, [| t1; t2; decidability gl t1; decidability gl t2 |]) | Kapp(And,[t1;t2]) -> mkApp (Lazy.force coq_dec_and, [| t1; t2; decidability gl t1; decidability gl t2 |]) | Kapp(Iff,[t1;t2]) -> mkApp (Lazy.force coq_dec_iff, [| t1; t2; decidability gl t1; decidability gl t2 |]) | Kimp(t1,t2) -> (* This is the only situation where it's not obvious that [t] is in Prop. The recursive call on [t2] will ensure that. *) mkApp (Lazy.force coq_dec_imp, [| t1; t2; decidability gl t1; decidability gl t2 |]) | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1; decidability gl t1 |]) | Kapp(Eq,[typ;t1;t2]) -> begin match destructurate_type (pf_nf gl typ) with | Kapp(Z,[]) -> mkApp (Lazy.force coq_dec_eq, [| t1;t2 |]) | Kapp(Nat,[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) | _ -> raise Undecidable end | Kapp(op,[t1;t2]) -> (try mkApp (Lazy.force (dec_binop op), [| t1; t2 |]) with Not_found -> raise Undecidable) | Kapp(False,[]) -> Lazy.force coq_dec_False | Kapp(True,[]) -> Lazy.force coq_dec_True | _ -> raise Undecidable let onClearedName id tac = (* We cannot ensure that hyps can be cleared (because of dependencies), *) (* so renaming may be necessary *) tclTHEN (tclTRY (clear [id])) (fun gl -> let id = fresh_id [] id gl in tclTHEN (introduction id) (tac id) gl) let onClearedName2 id tac = tclTHEN (tclTRY (clear [id])) (fun gl -> let id1 = fresh_id [] (add_suffix id "_left") gl in let id2 = fresh_id [] (add_suffix id "_right") gl in tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] gl) let destructure_hyps gl = let rec loop = function | [] -> (tclTHEN nat_inject coq_omega) | (i,body,t)::lit -> begin try match destructurate_prop t with | Kapp(False,[]) -> elim_id i | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit | Kapp(Or,[t1;t2]) -> (tclTHENS (elim_id i) [ onClearedName i (fun i -> (loop ((i,None,t1)::lit))); onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ]) | Kapp(And,[t1;t2]) -> tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> loop ((i1,None,t1)::(i2,None,t2)::lit))) | Kapp(Iff,[t1;t2]) -> tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> loop ((i1,None,mkArrow t1 t2)::(i2,None,mkArrow t2 t1)::lit))) | Kimp(t1,t2) -> (* t1 and t2 might be in Type rather than Prop. For t1, the decidability check will ensure being Prop. *) if is_Prop (pf_type_of gl t2) then let d1 = decidability gl t1 in tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_imp_simp, [| t1; t2; d1; mkVar i|])]); (onClearedName i (fun i -> (loop ((i,None,mk_or (mk_not t1) t2)::lit)))) ] else loop lit | Kapp(Not,[t]) -> begin match destructurate_prop t with Kapp(Or,[t1;t2]) -> tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]); (onClearedName i (fun i -> (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit)))) ] | Kapp(And,[t1;t2]) -> let d1 = decidability gl t1 in tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_and, [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit)))) ] | Kapp(Iff,[t1;t2]) -> let d1 = decidability gl t1 in let d2 = decidability gl t2 in tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_iff, [| t1; t2; d1; d2; mkVar i |])]); (onClearedName i (fun i -> (loop ((i,None, mk_or (mk_and t1 (mk_not t2)) (mk_and (mk_not t1) t2))::lit)))) ] | Kimp(t1,t2) -> (* t2 must be in Prop otherwise ~(t1->t2) wouldn't be ok. For t1, being decidable implies being Prop. *) let d1 = decidability gl t1 in tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_imp, [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> (loop ((i,None,mk_and t1 (mk_not t2)) :: lit)))) ] | Kapp(Not,[t]) -> let d = decidability gl t in tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]); (onClearedName i (fun i -> (loop ((i,None,t)::lit)))) ] | Kapp(op,[t1;t2]) -> (try let thm = not_binop op in tclTHENLIST [ (generalize_tac [mkApp (Lazy.force thm, [| t1;t2;mkVar i|])]); (onClearedName i (fun _ -> loop lit)) ] with Not_found -> loop lit) | Kapp(Eq,[typ;t1;t2]) -> if !old_style_flag then begin match destructurate_type (pf_nf gl typ) with | Kapp(Nat,_) -> tclTHENLIST [ (simplest_elim (mkApp (Lazy.force coq_not_eq, [|t1;t2;mkVar i|]))); (onClearedName i (fun _ -> loop lit)) ] | Kapp(Z,_) -> tclTHENLIST [ (simplest_elim (mkApp (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|]))); (onClearedName i (fun _ -> loop lit)) ] | _ -> loop lit end else begin match destructurate_type (pf_nf gl typ) with | Kapp(Nat,_) -> (tclTHEN (convert_hyp_no_check (i,body, (mkApp (Lazy.force coq_neq, [| t1;t2|])))) (loop lit)) | Kapp(Z,_) -> (tclTHEN (convert_hyp_no_check (i,body, (mkApp (Lazy.force coq_Zne, [| t1;t2|])))) (loop lit)) | _ -> loop lit end | _ -> loop lit end | _ -> loop lit with | Undecidable -> loop lit | e when catchable_exception e -> loop lit end in loop (pf_hyps gl) gl let destructure_goal gl = let concl = pf_concl gl in let rec loop t = match destructurate_prop t with | Kapp(Not,[t]) -> (tclTHEN (tclTHEN (unfold sp_not) intro) destructure_hyps) | Kimp(a,b) -> (tclTHEN intro (loop b)) | Kapp(False,[]) -> destructure_hyps | _ -> let goal_tac = try let dec = decidability gl t in tclTHEN (Tactics.refine (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |]))) intro with Undecidable -> Tactics.elim_type (build_coq_False ()) in tclTHEN goal_tac destructure_hyps in (loop concl) gl let destructure_goal = all_time (destructure_goal) let omega_solver gl = Coqlib.check_required_library ["Coq";"omega";"Omega"]; reset_all (); let result = destructure_goal gl in (* if !display_time_flag then begin text_time (); flush Pervasives.stdout end; *) result coq-8.4pl4/plugins/pluginsdyn.itarget0000644000175000017500000000117112326224777017071 0ustar stephstephfield/field_plugin.cmxs setoid_ring/newring_plugin.cmxs extraction/extraction_plugin.cmxs decl_mode/decl_mode_plugin.cmxs firstorder/ground_plugin.cmxs rtauto/rtauto_plugin.cmxs fourier/fourier_plugin.cmxs romega/romega_plugin.cmxs omega/omega_plugin.cmxs micromega/micromega_plugin.cmxs xml/xml_plugin.cmxs subtac/subtac_plugin.cmxs ring/ring_plugin.cmxs cc/cc_plugin.cmxs nsatz/nsatz_plugin.cmxs funind/recdef_plugin.cmxs syntax/ascii_syntax_plugin.cmxs syntax/nat_syntax_plugin.cmxs syntax/numbers_syntax_plugin.cmxs syntax/r_syntax_plugin.cmxs syntax/string_syntax_plugin.cmxs syntax/z_syntax_plugin.cmxs quote/quote_plugin.cmxs coq-8.4pl4/plugins/fourier/0000755000175000017500000000000012365131025014751 5ustar stephstephcoq-8.4pl4/plugins/fourier/Fourier.v0000644000175000017500000000151312326224777016571 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ fourier ] END coq-8.4pl4/plugins/fourier/fourier.ml0000644000175000017500000001410312326224777016773 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* match ie.coef with [] -> raise (Failure "empty ineq") |(c::r) -> if rinf c r0 then pop ie lneg else if rinf r0 c then pop ie lpos else pop ie lnul) s; [!lneg;!lnul;!lpos] ;; (* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!): (add_hist [(equation 1, s1);...;(équation n, sn)]) = [{équation 1, [1;0;...;0], s1}; {équation 2, [0;1;...;0], s2}; ... {équation n, [0;0;...;1], sn}] *) let add_hist le = let n = List.length le in let i=ref 0 in List.map (fun (ie,s) -> let h =ref [] in for k=1 to (n-(!i)-1) do pop r0 h; done; pop r1 h; for k=1 to !i do pop r0 h; done; i:=!i+1; {coef=ie;hist=(!h);strict=s}) le ;; (* additionne deux inéquations *) let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef; hist=List.map2 rplus ie1.hist ie2.hist; strict=ie1.strict || ie2.strict} ;; (* multiplication d'une inéquation par un rationnel (positif) *) let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef; hist=List.map (fun x -> rmult a x) ie.hist; strict= ie.strict} ;; (* on enlčve le premier coefficient *) let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict} ;; (* le premier coefficient: "tęte" de l'inéquation *) let hd_coef ie = List.hd ie.coef ;; (* calcule toutes les combinaisons entre inéquations de tęte négative et inéquations de tęte positive qui annulent le premier coefficient. *) let deduce_add lneg lpos = let res=ref [] in List.iter (fun i1 -> List.iter (fun i2 -> let a = rop (hd_coef i1) in let b = hd_coef i2 in pop (ie_tl (ie_add (ie_emult b i1) (ie_emult a i2))) res) lpos) lneg; !res ;; (* élimination de la premičre variable ā partir d'une liste d'inéquations: opération qu'on itčre dans l'algorithme de Fourier. *) let deduce1 s = match (partitionne s) with [lneg;lnul;lpos] -> let lnew = deduce_add lneg lpos in (List.map ie_tl lnul)@lnew |_->assert false ;; (* algorithme de Fourier: on élimine successivement toutes les variables. *) let deduce lie = let n = List.length (fst (List.hd lie)) in let lie=ref (add_hist lie) in for i=1 to n-1 do lie:= deduce1 !lie; done; !lie ;; (* donne [] si le systčme a des solutions, sinon donne [c,s,lc] oų lc est la combinaison linéaire des inéquations de départ qui donne 0 < c si s=true ou 0 <= c sinon cette inéquation étant absurde. *) let unsolvable lie = let lr = deduce lie in let res = ref [] in (try (List.iter (fun e -> match e with {coef=[c];hist=lc;strict=s} -> if (rinf c r0 && (not s)) || (rinfeq c r0 && s) then (res := [c,s,lc]; raise (Failure "contradiction found")) |_->assert false) lr) with e when Errors.noncritical e -> ()); !res ;; (* Exemples: let test1=[[r1;r1;r0],true;[rop r1;r1;r1],false;[r0;rop r1;rop r1],false];; deduce test1;; unsolvable test1;; let test2=[ [r1;r1;r0;r0;r0],false; [r0;r1;r1;r0;r0],false; [r0;r0;r1;r1;r0],false; [r0;r0;r0;r1;r1],false; [r1;r0;r0;r0;r1],false; [rop r1;rop r1;r0;r0;r0],false; [r0;rop r1;rop r1;r0;r0],false; [r0;r0;rop r1;rop r1;r0],false; [r0;r0;r0;rop r1;rop r1],false; [rop r1;r0;r0;r0;rop r1],false ];; deduce test2;; unsolvable test2;; *) coq-8.4pl4/plugins/fourier/Fourier_util.v0000644000175000017500000001170612326224777017633 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 < a -> a * x1 < a * y1. intros; apply Rmult_lt_compat_l; assumption. Qed. Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1. red. intros. case H; auto with real. Qed. Lemma Rfourier_lt_lt : forall x1 y1 x2 y2 a:R, x1 < y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. intros x1 y1 x2 y2 a H H0 H1; try assumption. apply Rplus_lt_compat. try exact H. apply Rfourier_lt. try exact H0. try exact H1. Qed. Lemma Rfourier_lt_le : forall x1 y1 x2 y2 a:R, x1 < y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. intros x1 y1 x2 y2 a H H0 H1; try assumption. case H0; intros. apply Rplus_lt_compat. try exact H. apply Rfourier_lt; auto with real. rewrite H2. rewrite (Rplus_comm y1 (a * y2)). rewrite (Rplus_comm x1 (a * y2)). apply Rplus_lt_compat_l. try exact H. Qed. Lemma Rfourier_le_lt : forall x1 y1 x2 y2 a:R, x1 <= y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. intros x1 y1 x2 y2 a H H0 H1; try assumption. case H; intros. apply Rfourier_lt_le; auto with real. rewrite H2. apply Rplus_lt_compat_l. apply Rfourier_lt; auto with real. Qed. Lemma Rfourier_le_le : forall x1 y1 x2 y2 a:R, x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2. intros x1 y1 x2 y2 a H H0 H1; try assumption. case H0; intros. red. left; try assumption. apply Rfourier_le_lt; auto with real. rewrite H2. case H; intros. red. left; try assumption. rewrite (Rplus_comm x1 (a * y2)). rewrite (Rplus_comm y1 (a * y2)). apply Rplus_lt_compat_l. try exact H3. rewrite H3. red. right; try assumption. auto with real. Qed. Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x. intros x H; try assumption. rewrite Rplus_comm. apply Rle_lt_0_plus_1. red; auto with real. Qed. Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. intros x y H H0; try assumption. replace 0 with (x * 0). apply Rmult_lt_compat_l; auto with real. ring. Qed. Lemma Rlt_zero_1 : 0 < 1. exact Rlt_0_1. Qed. Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x. intros x H; try assumption. case H; intros. red. left; try assumption. apply Rlt_zero_pos_plus1; auto with real. rewrite <- H0. replace (1 + 0) with 1. red; left. exact Rlt_zero_1. ring. Qed. Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. intros x y H H0; try assumption. case H; intros. red; left. apply Rlt_mult_inv_pos; auto with real. rewrite <- H1. red; right; ring. Qed. Lemma Rle_zero_1 : 0 <= 1. red; left. exact Rlt_zero_1. Qed. Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d. intros n d H; red; intros H0; try exact H0. generalize (Rgt_not_le 0 (n * / d)). intros H1; elim H1; try assumption. replace (n * / d) with (- - (n * / d)). replace 0 with (- -0). replace (- (n * / d)) with (- n * / d). replace (-0) with 0. red. apply Ropp_gt_lt_contravar. red. exact H0. ring. ring. ring. ring. Qed. Lemma Rnot_lt0 : forall x:R, ~ 0 < 0 * x. intros x; try assumption. replace (0 * x) with 0. apply Rlt_irrefl. ring. Qed. Lemma Rlt_not_le_frac_opp : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d. intros n d H; try assumption. apply Rgt_not_le. replace 0 with (-0). replace (- n * / d) with (- (n * / d)). apply Ropp_lt_gt_contravar. try exact H. ring. ring. Qed. Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y. unfold not; intros. apply H. apply Rplus_lt_reg_r with x. replace (x + 0) with x. replace (x + (y - x)) with y. try exact H0. ring. ring. Qed. Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y. unfold not; intros. apply H. case H0; intros. left. apply Rplus_lt_reg_r with x. replace (x + 0) with x. replace (x + (y - x)) with y. try exact H1. ring. ring. right. rewrite H1; ring. Qed. Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y. unfold Rgt; intros; assumption. Qed. Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y. intros x y; exact (Rge_le y x). Qed. Lemma Rfourier_eqLR_to_le : forall x y:R, x = y -> x <= y. exact Req_le. Qed. Lemma Rfourier_eqRL_to_le : forall x y:R, y = x -> x <= y. exact Req_le_sym. Qed. Lemma Rfourier_not_ge_lt : forall x y:R, (x >= y -> False) -> x < y. exact Rnot_ge_lt. Qed. Lemma Rfourier_not_gt_le : forall x y:R, (x > y -> False) -> x <= y. exact Rnot_gt_le. Qed. Lemma Rfourier_not_le_gt : forall x y:R, (x <= y -> False) -> x > y. exact Rnot_le_lt. Qed. Lemma Rfourier_not_lt_ge : forall x y:R, (x < y -> False) -> x >= y. exact Rnot_lt_ge. Qed. coq-8.4pl4/plugins/fourier/fourierR.ml0000644000175000017500000005127512326224777017130 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* r0;; let flin_add f x c = let cx = flin_coef f x in Constrhash.remove f.fhom x; Constrhash.add f.fhom x (rplus cx c); f ;; let flin_add_cste f c = {fhom=f.fhom; fcste=rplus f.fcste c} ;; let flin_one () = flin_add_cste (flin_zero()) r1;; let flin_plus f1 f2 = let f3 = flin_zero() in Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom; flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste; ;; let flin_minus f1 f2 = let f3 = flin_zero() in Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; Constrhash.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom; flin_add_cste (flin_add_cste f3 f1.fcste) (rop f2.fcste); ;; let flin_emult a f = let f2 = flin_zero() in Constrhash.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom; flin_add_cste f2 (rmult a f.fcste); ;; (*****************************************************************************) open Vernacexpr type ineq = Rlt | Rle | Rgt | Rge let string_of_R_constant kn = match Names.repr_con kn with | MPfile dir, sec_dir, id when sec_dir = empty_dirpath && string_of_dirpath dir = "Coq.Reals.Rdefinitions" -> string_of_label id | _ -> "constant_not_of_R" let rec string_of_R_constr c = match kind_of_term c with Cast (c,_,_) -> string_of_R_constr c |Const c -> string_of_R_constant c | _ -> "not_of_constant" let rec rational_of_constr c = match kind_of_term c with | Cast (c,_,_) -> (rational_of_constr c) | App (c,args) -> (match (string_of_R_constr c) with | "Ropp" -> rop (rational_of_constr args.(0)) | "Rinv" -> rinv (rational_of_constr args.(0)) | "Rmult" -> rmult (rational_of_constr args.(0)) (rational_of_constr args.(1)) | "Rdiv" -> rdiv (rational_of_constr args.(0)) (rational_of_constr args.(1)) | "Rplus" -> rplus (rational_of_constr args.(0)) (rational_of_constr args.(1)) | "Rminus" -> rminus (rational_of_constr args.(0)) (rational_of_constr args.(1)) | _ -> failwith "not a rational") | Const kn -> (match (string_of_R_constant kn) with "R1" -> r1 |"R0" -> r0 | _ -> failwith "not a rational") | _ -> failwith "not a rational" ;; let rec flin_of_constr c = try( match kind_of_term c with | Cast (c,_,_) -> (flin_of_constr c) | App (c,args) -> (match (string_of_R_constr c) with "Ropp" -> flin_emult (rop r1) (flin_of_constr args.(0)) | "Rplus"-> flin_plus (flin_of_constr args.(0)) (flin_of_constr args.(1)) | "Rminus"-> flin_minus (flin_of_constr args.(0)) (flin_of_constr args.(1)) | "Rmult"-> (try (let a=(rational_of_constr args.(0)) in try (let b = (rational_of_constr args.(1)) in (flin_add_cste (flin_zero()) (rmult a b))) with e when Errors.noncritical e -> (flin_add (flin_zero()) args.(1) a)) with e when Errors.noncritical e -> (flin_add (flin_zero()) args.(0) (rational_of_constr args.(1)))) | "Rinv"-> let a=(rational_of_constr args.(0)) in flin_add_cste (flin_zero()) (rinv a) | "Rdiv"-> (let b=(rational_of_constr args.(1)) in try (let a = (rational_of_constr args.(0)) in (flin_add_cste (flin_zero()) (rdiv a b))) with e when Errors.noncritical e -> (flin_add (flin_zero()) args.(0) (rinv b))) |_->assert false) | Const c -> (match (string_of_R_constant c) with "R1" -> flin_one () |"R0" -> flin_zero () |_-> assert false) |_-> assert false) with e when Errors.noncritical e -> flin_add (flin_zero()) c r1 ;; let flin_to_alist f = let res=ref [] in Constrhash.iter (fun x c -> res:=(c,x)::(!res)) f; !res ;; (* Représentation des hypothčses qui sont des inéquations ou des équations. *) type hineq={hname:constr; (* le nom de l'hypothčse *) htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *) hleft:constr; hright:constr; hflin:flin; hstrict:bool} ;; (* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0 *) let ineq1_of_constr (h,t) = match (kind_of_term t) with App (f,args) -> (match kind_of_term f with Const c when Array.length args = 2 -> let t1= args.(0) in let t2= args.(1) in (match (string_of_R_constant c) with "Rlt" -> [{hname=h; htype="Rlt"; hleft=t1; hright=t2; hflin= flin_minus (flin_of_constr t1) (flin_of_constr t2); hstrict=true}] |"Rgt" -> [{hname=h; htype="Rgt"; hleft=t2; hright=t1; hflin= flin_minus (flin_of_constr t2) (flin_of_constr t1); hstrict=true}] |"Rle" -> [{hname=h; htype="Rle"; hleft=t1; hright=t2; hflin= flin_minus (flin_of_constr t1) (flin_of_constr t2); hstrict=false}] |"Rge" -> [{hname=h; htype="Rge"; hleft=t2; hright=t1; hflin= flin_minus (flin_of_constr t2) (flin_of_constr t1); hstrict=false}] |_->assert false) | Ind (kn,i) -> if IndRef(kn,i) = Coqlib.glob_eq then let t0= args.(0) in let t1= args.(1) in let t2= args.(2) in (match (kind_of_term t0) with Const c -> (match (string_of_R_constant c) with "R"-> [{hname=h; htype="eqTLR"; hleft=t1; hright=t2; hflin= flin_minus (flin_of_constr t1) (flin_of_constr t2); hstrict=false}; {hname=h; htype="eqTRL"; hleft=t2; hright=t1; hflin= flin_minus (flin_of_constr t2) (flin_of_constr t1); hstrict=false}] |_-> assert false) |_-> assert false) else assert false |_-> assert false) |_-> assert false ;; (* Applique la méthode de Fourier ā une liste d'hypothčses (type hineq) *) let fourier_lineq lineq1 = let nvar=ref (-1) in let hvar=Constrhash.create 50 in (* la table des variables des inéquations *) List.iter (fun f -> Constrhash.iter (fun x _ -> if not (Constrhash.mem hvar x) then begin nvar:=(!nvar)+1; Constrhash.add hvar x (!nvar) end) f.hflin.fhom) lineq1; let sys= List.map (fun h-> let v=Array.create ((!nvar)+1) r0 in Constrhash.iter (fun x c -> v.(Constrhash.find hvar x)<-c) h.hflin.fhom; ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict)) lineq1 in unsolvable sys ;; (*********************************************************************) (* Defined constants *) let get = Lazy.force let constant = Coqlib.gen_constant "Fourier" (* Standard library *) open Coqlib let coq_sym_eqT = lazy (build_coq_eq_sym ()) let coq_False = lazy (build_coq_False ()) let coq_not = lazy (build_coq_not ()) let coq_eq = lazy (build_coq_eq ()) (* Rdefinitions *) let constant_real = constant ["Reals";"Rdefinitions"] let coq_Rlt = lazy (constant_real "Rlt") let coq_Rgt = lazy (constant_real "Rgt") let coq_Rle = lazy (constant_real "Rle") let coq_Rge = lazy (constant_real "Rge") let coq_R = lazy (constant_real "R") let coq_Rminus = lazy (constant_real "Rminus") let coq_Rmult = lazy (constant_real "Rmult") let coq_Rplus = lazy (constant_real "Rplus") let coq_Ropp = lazy (constant_real "Ropp") let coq_Rinv = lazy (constant_real "Rinv") let coq_R0 = lazy (constant_real "R0") let coq_R1 = lazy (constant_real "R1") (* RIneq *) let coq_Rinv_1 = lazy (constant ["Reals";"RIneq"] "Rinv_1") (* Fourier_util *) let constant_fourier = constant ["fourier";"Fourier_util"] let coq_Rlt_zero_1 = lazy (constant_fourier "Rlt_zero_1") let coq_Rlt_zero_pos_plus1 = lazy (constant_fourier "Rlt_zero_pos_plus1") let coq_Rle_zero_pos_plus1 = lazy (constant_fourier "Rle_zero_pos_plus1") let coq_Rlt_mult_inv_pos = lazy (constant_fourier "Rlt_mult_inv_pos") let coq_Rle_zero_zero = lazy (constant_fourier "Rle_zero_zero") let coq_Rle_zero_1 = lazy (constant_fourier "Rle_zero_1") let coq_Rle_mult_inv_pos = lazy (constant_fourier "Rle_mult_inv_pos") let coq_Rnot_lt0 = lazy (constant_fourier "Rnot_lt0") let coq_Rle_not_lt = lazy (constant_fourier "Rle_not_lt") let coq_Rfourier_gt_to_lt = lazy (constant_fourier "Rfourier_gt_to_lt") let coq_Rfourier_ge_to_le = lazy (constant_fourier "Rfourier_ge_to_le") let coq_Rfourier_eqLR_to_le = lazy (constant_fourier "Rfourier_eqLR_to_le") let coq_Rfourier_eqRL_to_le = lazy (constant_fourier "Rfourier_eqRL_to_le") let coq_Rfourier_not_ge_lt = lazy (constant_fourier "Rfourier_not_ge_lt") let coq_Rfourier_not_gt_le = lazy (constant_fourier "Rfourier_not_gt_le") let coq_Rfourier_not_le_gt = lazy (constant_fourier "Rfourier_not_le_gt") let coq_Rfourier_not_lt_ge = lazy (constant_fourier "Rfourier_not_lt_ge") let coq_Rfourier_lt = lazy (constant_fourier "Rfourier_lt") let coq_Rfourier_le = lazy (constant_fourier "Rfourier_le") let coq_Rfourier_lt_lt = lazy (constant_fourier "Rfourier_lt_lt") let coq_Rfourier_lt_le = lazy (constant_fourier "Rfourier_lt_le") let coq_Rfourier_le_lt = lazy (constant_fourier "Rfourier_le_lt") let coq_Rfourier_le_le = lazy (constant_fourier "Rfourier_le_le") let coq_Rnot_lt_lt = lazy (constant_fourier "Rnot_lt_lt") let coq_Rnot_le_le = lazy (constant_fourier "Rnot_le_le") let coq_Rlt_not_le_frac_opp = lazy (constant_fourier "Rlt_not_le_frac_opp") (****************************************************************************** Construction de la preuve en cas de succčs de la méthode de Fourier, i.e. on obtient une contradiction. *) let is_int x = (x.den)=1 ;; (* fraction = couple (num,den) *) let rec rational_to_fraction x= (x.num,x.den) ;; (* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1))) *) let int_to_real n = let nn=abs n in if nn=0 then get coq_R0 else (let s=ref (get coq_R1) in for i=1 to (nn-1) do s:=mkApp (get coq_Rplus,[|get coq_R1;!s|]) done; if n<0 then mkApp (get coq_Ropp, [|!s|]) else !s) ;; (* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1))) *) let rational_to_real x = let (n,d)=rational_to_fraction x in mkApp (get coq_Rmult, [|int_to_real n;mkApp(get coq_Rinv,[|int_to_real d|])|]) ;; (* preuve que 0 False *) let tac_zero_inf_false gl (n,d) = if n=0 then (apply (get coq_Rnot_lt0)) else (tclTHEN (apply (get coq_Rle_not_lt)) (tac_zero_infeq_pos gl (-n,d))) ;; (* preuve que 0<=(-n)*(1/d) => False *) let tac_zero_infeq_false gl (n,d) = (tclTHEN (apply (get coq_Rlt_not_le_frac_opp)) (tac_zero_inf_pos gl (-n,d))) ;; let create_meta () = mkMeta(Evarutil.new_meta());; let my_cut c gl= let concl = pf_concl gl in apply_type (mkProd(Anonymous,c,concl)) [create_meta()] gl ;; let exact = exact_check;; let tac_use h = match h.htype with "Rlt" -> exact h.hname |"Rle" -> exact h.hname |"Rgt" -> (tclTHEN (apply (get coq_Rfourier_gt_to_lt)) (exact h.hname)) |"Rge" -> (tclTHEN (apply (get coq_Rfourier_ge_to_le)) (exact h.hname)) |"eqTLR" -> (tclTHEN (apply (get coq_Rfourier_eqLR_to_le)) (exact h.hname)) |"eqTRL" -> (tclTHEN (apply (get coq_Rfourier_eqRL_to_le)) (exact h.hname)) |_->assert false ;; (* let is_ineq (h,t) = match (kind_of_term t) with App (f,args) -> (match (string_of_R_constr f) with "Rlt" -> true | "Rgt" -> true | "Rle" -> true | "Rge" -> true (* Wrong:not in Rdefinitions: *) | "eqT" -> (match (string_of_R_constr args.(0)) with "R" -> true | _ -> false) | _ ->false) |_->false ;; *) let list_of_sign s = List.map (fun (x,_,z)->(x,z)) s;; let mkAppL a = let l = Array.to_list a in mkApp(List.hd l, Array.of_list (List.tl l)) ;; (* Résolution d'inéquations linéaires dans R *) let rec fourier gl= Coqlib.check_required_library ["Coq";"fourier";"Fourier"]; let goal = strip_outer_cast (pf_concl gl) in let fhyp=id_of_string "new_hyp_for_fourier" in (* si le but est une inéquation, on introduit son contraire, et le but ā prouver devient False *) try (let tac = match (kind_of_term goal) with App (f,args) -> (match (string_of_R_constr f) with "Rlt" -> (tclTHEN (tclTHEN (apply (get coq_Rfourier_not_ge_lt)) (intro_using fhyp)) fourier) |"Rle" -> (tclTHEN (tclTHEN (apply (get coq_Rfourier_not_gt_le)) (intro_using fhyp)) fourier) |"Rgt" -> (tclTHEN (tclTHEN (apply (get coq_Rfourier_not_le_gt)) (intro_using fhyp)) fourier) |"Rge" -> (tclTHEN (tclTHEN (apply (get coq_Rfourier_not_lt_ge)) (intro_using fhyp)) fourier) |_->assert false) |_->assert false in tac gl) with e when Errors.noncritical e -> (* les hypothčses *) let hyps = List.map (fun (h,t)-> (mkVar h,t)) (list_of_sign (pf_hyps gl)) in let lineq =ref [] in List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq)) with e when Errors.noncritical e -> ()) hyps; (* lineq = les inéquations découlant des hypothčses *) if !lineq=[] then Util.error "No inequalities"; let res=fourier_lineq (!lineq) in let tac=ref tclIDTAC in if res=[] then Util.error "fourier failed" (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *) else (match res with [(cres,sres,lc)]-> (* lc=coefficients multiplicateurs des inéquations qui donnent 0 if c<>r0 then (lutil:=(h,c)::(!lutil)(*; print_rational(c);print_string " "*))) (List.combine (!lineq) lc); (* on construit la combinaison linéaire des inéquation *) (match (!lutil) with (h1,c1)::lutil -> let s=ref (h1.hstrict) in let t1=ref (mkAppL [|get coq_Rmult; rational_to_real c1; h1.hleft|]) in let t2=ref (mkAppL [|get coq_Rmult; rational_to_real c1; h1.hright|]) in List.iter (fun (h,c) -> s:=(!s)||(h.hstrict); t1:=(mkAppL [|get coq_Rplus; !t1; mkAppL [|get coq_Rmult; rational_to_real c; h.hleft|] |]); t2:=(mkAppL [|get coq_Rplus; !t2; mkAppL [|get coq_Rmult; rational_to_real c; h.hright|] |])) lutil; let ineq=mkAppL [|if (!s) then get coq_Rlt else get coq_Rle; !t1; !t2 |] in let tc=rational_to_real cres in (* puis sa preuve *) let tac1=ref (if h1.hstrict then (tclTHENS (apply (get coq_Rfourier_lt)) [tac_use h1; tac_zero_inf_pos gl (rational_to_fraction c1)]) else (tclTHENS (apply (get coq_Rfourier_le)) [tac_use h1; tac_zero_inf_pos gl (rational_to_fraction c1)])) in s:=h1.hstrict; List.iter (fun (h,c)-> (if (!s) then (if h.hstrict then tac1:=(tclTHENS (apply (get coq_Rfourier_lt_lt)) [!tac1;tac_use h; tac_zero_inf_pos gl (rational_to_fraction c)]) else tac1:=(tclTHENS (apply (get coq_Rfourier_lt_le)) [!tac1;tac_use h; tac_zero_inf_pos gl (rational_to_fraction c)])) else (if h.hstrict then tac1:=(tclTHENS (apply (get coq_Rfourier_le_lt)) [!tac1;tac_use h; tac_zero_inf_pos gl (rational_to_fraction c)]) else tac1:=(tclTHENS (apply (get coq_Rfourier_le_le)) [!tac1;tac_use h; tac_zero_inf_pos gl (rational_to_fraction c)]))); s:=(!s)||(h.hstrict)) lutil; let tac2= if sres then tac_zero_inf_false gl (rational_to_fraction cres) else tac_zero_infeq_false gl (rational_to_fraction cres) in tac:=(tclTHENS (my_cut ineq) [tclTHEN (change_in_concl None (mkAppL [| get coq_not; ineq|] )) (tclTHEN (apply (if sres then get coq_Rnot_lt_lt else get coq_Rnot_le_le)) (tclTHENS (Equality.replace (mkAppL [|get coq_Rminus;!t2;!t1|] ) tc) [tac2; (tclTHENS (Equality.replace (mkApp (get coq_Rinv, [|get coq_R1|])) (get coq_R1)) (* en attendant Field, įa peut aider Ring de remplacer 1/1 par 1 ... *) [tclORELSE (Ring.polynom []) tclIDTAC; (tclTHEN (apply (get coq_sym_eqT)) (apply (get coq_Rinv_1)))] ) ])); !tac1]); tac:=(tclTHENS (cut (get coq_False)) [tclTHEN intro (contradiction None); !tac]) |_-> assert false) |_-> assert false ); (* ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *) (!tac gl) (* ((tclABSTRACT None !tac) gl) *) ;; (* let fourier_tac x gl = fourier gl ;; let v_fourier = add_tactic "Fourier" fourier_tac *) coq-8.4pl4/plugins/fourier/fourier_plugin.mllib0000644000175000017500000000005612326224777021042 0ustar stephstephFourier FourierR G_fourier Fourier_plugin_mod coq-8.4pl4/plugins/funind/0000755000175000017500000000000012365131025014561 5ustar stephstephcoq-8.4pl4/plugins/funind/functional_principles_types.mli0000644000175000017500000000152712326224777023125 0ustar stephstephopen Names open Term val generate_functional_principle : (* do we accept interactive proving *) bool -> (* induction principle on rel *) types -> (* *) sorts array option -> (* Name of the new principle *) (identifier) option -> (* the compute functions to use *) constant array -> (* We prove the nth- principle *) int -> (* The tactic to use to make the proof w.r the number of params *) (constr array -> int -> Tacmach.tactic) -> unit val compute_new_princ_type_from_rel : constr array -> sorts array -> types -> types exception No_graph_found val make_scheme : (constant*Glob_term.glob_sort) list -> Entries.definition_entry list val build_scheme : (identifier*Libnames.reference*Glob_term.glob_sort) list -> unit val build_case_scheme : (identifier*Libnames.reference*Glob_term.glob_sort) -> unit coq-8.4pl4/plugins/funind/invfun.ml0000644000175000017500000010606112326224777016442 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c) | loc, Glob_term.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c) let pr_bindings prc prlc = function | Glob_term.ImplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ Util.prlist_with_sep spc prc l | Glob_term.ExplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l | Glob_term.NoBindings -> mt () let pr_with_bindings prc prlc (c,bl) = prc c ++ hv 0 (pr_bindings prc prlc bl) let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds = pr_with_bindings prc prc (c,bl) (* The local debuging mechanism *) let msgnl = Pp.msgnl let observe strm = if do_observe () then Pp.msgnl strm else () let observennl strm = if do_observe () then begin Pp.msg strm;Pp.pp_flush () end else () let do_observe_tac s tac g = let goal = try Printer.pr_goal g with e when Errors.noncritical e -> assert false in try let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v with reraise -> let e' = Cerrors.process_vernac_interp_error reraise in msgnl (str "observation "++ s++str " raised exception " ++ Errors.print e' ++ str " on goal " ++ goal ); raise reraise;; let observe_tac_msg s tac g = if do_observe () then do_observe_tac s tac g else tac g let observe_tac s tac g = observe_tac_msg (str s) tac g (* [nf_zeta] $\zeta$-normalization of a term *) let nf_zeta = Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) Environ.empty_env Evd.empty (* [id_to_constr id] finds the term associated to [id] in the global environment *) let id_to_constr id = try Constrintern.global_reference id with Not_found -> raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id)) (* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. [generate_type true f i] returns \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion [generate_type false f i] returns \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion *) let generate_type g_to_f f graph i = (*i we deduce the number of arguments of the function and its returned type from the graph i*) let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph)) in let ctxt,_ = decompose_prod_assum graph_arity in let fun_ctxt,res_type = match ctxt with | [] | [_] -> anomaly "Not a valid context" | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type in let nb_args = List.length fun_ctxt in let args_from_decl i decl = match decl with | (_,Some _,_) -> incr i; failwith "args_from_decl" | _ -> let j = !i in incr i;mkRel (nb_args - j + 1) in (*i We need to name the vars [res] and [fv] i*) let res_id = Namegen.next_ident_away_in_goal (id_of_string "res") (map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "") fun_ctxt) in let fv_id = Namegen.next_ident_away_in_goal (id_of_string "fv") (res_id::(map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "Anonymous!") fun_ctxt)) in (*i we can then type the argument to be applied to the function [f] i*) let args_as_rels = let i = ref 0 in Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt))) in let args_as_rels = Array.map Termops.pop args_as_rels in (*i the hypothesis [res = fv] can then be computed We will need to lift it by one in order to use it as a conclusion i*) let res_eq_f_of_args = mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|]) in (*i The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed We will need to lift it by one in order to use it as a conclusion i*) let graph_applied = let args_and_res_as_rels = let i = ref 0 in Array.of_list ((map_succeed (args_from_decl i) (List.rev ((Name res_id,None,res_type)::fun_ctxt))) ) in let args_and_res_as_rels = Array.mapi (fun i c -> if i <> Array.length args_and_res_as_rels - 1 then lift 1 c else c) args_and_res_as_rels in mkApp(graph,args_and_res_as_rels) in (*i The [pre_context] is the defined to be the context corresponding to \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] i*) let pre_ctxt = (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(mkConst f,args_as_rels)),res_type)::fun_ctxt in (*i and we can return the solution depending on which lemma type we are defining i*) if g_to_f then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args) else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied) (* [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect] WARNING: while convertible, [type_of body] and [type] can be non equal *) let find_induction_principle f = let f_as_constant = match kind_of_term f with | Const c' -> c' | _ -> error "Must be used with a function" in let infos = find_Function_infos f_as_constant in match infos.rect_lemma with | None -> raise Not_found | Some rect_lemma -> let rect_lemma = mkConst rect_lemma in let typ = Typing.type_of (Global.env ()) Evd.empty rect_lemma in rect_lemma,typ (* let fname = *) (* match kind_of_term f with *) (* | Const c' -> *) (* id_of_label (con_label c') *) (* | _ -> error "Must be used with a function" *) (* in *) (* let princ_name = *) (* ( *) (* Indrec.make_elimination_ident *) (* fname *) (* InType *) (* ) *) (* in *) (* let c = (\* mkConst(mk_from_const (destConst f) princ_name ) in *\) failwith "" in *) (* c,Typing.type_of (Global.env ()) Evd.empty c *) let rec generate_fresh_id x avoid i = if i == 0 then [] else let id = Namegen.next_ident_away_in_goal x avoid in id::(generate_fresh_id x (id::avoid) (pred i)) (* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] is the tactic used to prove correctness lemma. [functional_induction] is the tactic defined in [indfun] (dependency problem) [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions (resp. graphs of the functions and principles and correctness lemma types) to prove correct. [i] is the indice of the function to prove correct The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is it looks like~: [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, res = f x_1\ldots x_n in, \rightarrow graph\ x_1\ldots x_n\ res] The sketch of the proof is the following one~: \begin{enumerate} \item intros until $x_n$ \item $functional\ induction\ (f.(i)\ x_1\ldots x_n)$ using schemes.(i) \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the apply the corresponding constructor of the corresponding graph inductive. \end{enumerate} *) let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic = fun g -> (* first of all we recreate the lemmas types to be used as predicates of the induction principle that is~: \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] *) let lemmas = Array.map (fun (_,(ctxt,concl)) -> match ctxt with | [] | [_] | [_;_] -> anomaly "bad context" | hres::res::(x,_,t)::ctxt -> Termops.it_mkLambda_or_LetIn (Termops.it_mkProd_or_LetIn concl [hres;res]) ((x,None,t)::ctxt) ) lemmas_types_infos in (* we the get the definition of the graphs block *) let graph_ind = destInd graphs_constr.(i) in let kn = fst graph_ind in let mib,_ = Global.lookup_inductive graph_ind in (* and the principle to use in this lemma in $\zeta$ normal form *) let f_principle,princ_type = schemes.(i) in let princ_type = nf_zeta princ_type in let princ_infos = Tactics.compute_elim_sig princ_type in (* The number of args of the function is then easilly computable *) let nb_fun_args = nb_prod (pf_concl g) - 2 in let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in (* Since we cannot ensure that the funcitonnal principle is defined in the environement and due to the bug #1174, we will need to pose the principle using a name *) let principle_id = Namegen.next_ident_away_in_goal (id_of_string "princ") ids in let ids = principle_id :: ids in (* We get the branches of the principle *) let branches = List.rev princ_infos.branches in (* and built the intro pattern for each of them *) let intro_pats = List.map (fun (_,_,br_type) -> List.map (fun id -> dummy_loc, Genarg.IntroIdentifier id) (generate_fresh_id (id_of_string "y") ids (List.length (fst (decompose_prod_assum br_type)))) ) branches in (* before building the full intro pattern for the principle *) let eq_ind = Coqlib.build_coq_eq () in let eq_construct = mkConstruct((destInd eq_ind),1) in (* The next to referencies will be used to find out which constructor to apply in each branch *) let ind_number = ref 0 and min_constr_number = ref 0 in (* The tactic to prove the ith branch of the principle *) let this_branche_ids empty add i = List.fold_right (fun (_,pat) acc -> match pat with | Genarg.IntroIdentifier id -> add id acc | _ -> anomaly "Not an identifier" ) (List.nth intro_pats (pred i)) empty in let prove_branche i g = (* We get the identifiers of this branch *) (* and get the real args of the branch by unfolding the defined constant *) let pre_args,pre_tac = List.fold_right (fun (id,b,t) (pre_args,pre_tac) -> if Idset.mem id (this_branche_ids Idset.empty Idset.add i) then match b with | None -> (id::pre_args,pre_tac) | Some b -> (pre_args, tclTHEN (h_reduce (Glob_term.Unfold([Glob_term.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac ) else (pre_args,pre_tac) ) (pf_hyps g) ([],tclIDTAC) in (* We can then recompute the arguments of the constructor. For each [hid] introduced by this branch, if [hid] has type $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are [ fv (hid fv (refl_equal fv)) ]. If [hid] has another type the corresponding argument of the constructor is [hid] *) let constructor_args = List.fold_right (fun hid acc -> let type_of_hid = pf_type_of g (mkVar hid) in match kind_of_term type_of_hid with | Prod(_,_,t') -> begin match kind_of_term t' with | Prod(_,t'',t''') -> begin match kind_of_term t'',kind_of_term t''' with | App(eq,args), App(graph',_) when (eq_constr eq eq_ind) && array_exists (eq_constr graph') graphs_constr -> ((mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) ::args.(2)::acc) | _ -> mkVar hid :: acc end | _ -> mkVar hid :: acc end | _ -> mkVar hid :: acc ) pre_args [] in (* in fact we must also add the parameters to the constructor args *) let constructor_args = let params_id = fst (list_chop princ_infos.nparams args_names) in (List.map mkVar params_id)@(List.rev constructor_args) in (* We then get the constructor corresponding to this branch and modifies the references has needed i.e. if the constructor is the last one of the current inductive then add one the number of the inductive to take and add the number of constructor of the previous graph to the minimal constructor number *) let constructor = let constructor_num = i - !min_constr_number in let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in if constructor_num <= length then begin (kn,!ind_number),constructor_num end else begin incr ind_number; min_constr_number := !min_constr_number + length ; (kn,!ind_number),1 end in (* we can then build the final proof term *) let app_constructor = applist((mkConstruct(constructor)),constructor_args) in (* an apply the tactic *) let res,hres = match generate_fresh_id (id_of_string "z") (ids(* @this_branche_ids *)) 2 with | [res;hres] -> res,hres | _ -> assert false in observe_tac_msg (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor) ( tclTHENSEQ [ (* unfolding of all the defined variables introduced by this branch *) observe_tac "unfolding" pre_tac; (* $zeta$ normalizing of the conclusion *) h_reduce (Glob_term.Cbv { Glob_term.all_flags with Glob_term.rDelta = false ; Glob_term.rConst = [] } ) onConcl; (* introducing the the result of the graph and the equality hypothesis *) observe_tac "introducing" (tclMAP h_intro [res;hres]); (* replacing [res] with its value *) observe_tac "rewriting res value" (Equality.rewriteLR (mkVar hres)); (* Conclusion *) observe_tac "exact" (h_exact app_constructor) ] ) g in (* end of branche proof *) let param_names = fst (list_chop princ_infos.nparams args_names) in let params = List.map mkVar param_names in let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in (* The bindings of the principle that is the params of the principle and the different lemma types *) let bindings = let params_bindings,avoid = List.fold_left2 (fun (bindings,avoid) (x,_,_) p -> let id = Namegen.next_ident_away (Nameops.out_name x) avoid in (dummy_loc,Glob_term.NamedHyp id,p)::bindings,id::avoid ) ([],pf_ids_of_hyps g) princ_infos.params (List.rev params) in let lemmas_bindings = List.rev (fst (List.fold_left2 (fun (bindings,avoid) (x,_,_) p -> let id = Namegen.next_ident_away (Nameops.out_name x) avoid in (dummy_loc,Glob_term.NamedHyp id,(nf_zeta p))::bindings,id::avoid) ([],avoid) princ_infos.predicates (lemmas))) in Glob_term.ExplicitBindings (params_bindings@lemmas_bindings) in tclTHENSEQ [ observe_tac "intro args_names" (tclMAP h_intro args_names); observe_tac "principle" (assert_by (Name principle_id) princ_type (h_exact f_principle)); tclTHEN_i (observe_tac "functional_induction" ( fun g -> observe (pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g)) (mkVar principle_id,bindings)); h_apply false false [dummy_loc,(mkVar principle_id,bindings)] g )) (fun i g -> observe_tac ("proving branche "^string_of_int i) (tclTHEN (tclMAP h_intro (this_branche_ids [] (fun a b -> a::b) i)) (prove_branche i)) g ) ] g (* [generalize_dependent_of x hyp g] generalize every hypothesis which depends of [x] but [hyp] *) let generalize_dependent_of x hyp g = tclMAP (function | (id,None,t) when not (id = hyp) && (Termops.occur_var (pf_env g) x t) -> tclTHEN (h_generalize [mkVar id]) (thin [id]) | _ -> tclIDTAC ) (pf_hyps g) g (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis (unfolding, substituting, destructing cases \ldots) *) let rec intros_with_rewrite g = observe_tac "intros_with_rewrite" intros_with_rewrite_aux g and intros_with_rewrite_aux : tactic = fun g -> let eq_ind = Coqlib.build_coq_eq () in match kind_of_term (pf_concl g) with | Prod(_,t,t') -> begin match kind_of_term t with | App(eq,args) when (eq_constr eq eq_ind) -> if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) then let id = pf_get_new_id (id_of_string "y") g in tclTHENSEQ [ h_intro id; thin [id]; intros_with_rewrite ] g else if isVar args.(1) then let id = pf_get_new_id (id_of_string "y") g in tclTHENSEQ [ h_intro id; generalize_dependent_of (destVar args.(1)) id; tclTRY (Equality.rewriteLR (mkVar id)); intros_with_rewrite ] g else if isVar args.(2) then let id = pf_get_new_id (id_of_string "y") g in tclTHENSEQ [ h_intro id; generalize_dependent_of (destVar args.(2)) id; tclTRY (Equality.rewriteRL (mkVar id)); intros_with_rewrite ] g else begin let id = pf_get_new_id (id_of_string "y") g in tclTHENSEQ[ h_intro id; tclTRY (Equality.rewriteLR (mkVar id)); intros_with_rewrite ] g end | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> Tauto.tauto g | Case(_,_,v,_) -> tclTHENSEQ[ h_case false (v,Glob_term.NoBindings); intros_with_rewrite ] g | LetIn _ -> tclTHENSEQ[ h_reduce (Glob_term.Cbv {Glob_term.all_flags with Glob_term.rDelta = false; }) onConcl ; intros_with_rewrite ] g | _ -> let id = pf_get_new_id (id_of_string "y") g in tclTHENSEQ [ h_intro id;intros_with_rewrite] g end | LetIn _ -> tclTHENSEQ[ h_reduce (Glob_term.Cbv {Glob_term.all_flags with Glob_term.rDelta = false; }) onConcl ; intros_with_rewrite ] g | _ -> tclIDTAC g let rec reflexivity_with_destruct_cases g = let destruct_case () = try match kind_of_term (snd (destApp (pf_concl g))).(2) with | Case(_,_,v,_) -> tclTHENSEQ[ h_case false (v,Glob_term.NoBindings); intros; observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases ] | _ -> reflexivity with e when Errors.noncritical e -> reflexivity in let eq_ind = Coqlib.build_coq_eq () in let discr_inject = Tacticals.onAllHypsAndConcl ( fun sc g -> match sc with None -> tclIDTAC g | Some id -> match kind_of_term (pf_type_of g (mkVar id)) with | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> if Equality.discriminable (pf_env g) (project g) t1 t2 then Equality.discrHyp id g else if Equality.injectable (pf_env g) (project g) t1 t2 then tclTHENSEQ [Equality.injHyp id;thin [id];intros_with_rewrite] g else tclIDTAC g | _ -> tclIDTAC g ) in (tclFIRST [ observe_tac "reflexivity_with_destruct_cases : reflexivity" reflexivity; observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ())); (* We reach this point ONLY if the same value is matched (at least) two times along binding path. In this case, either we have a discriminable hypothesis and we are done, either at least an injectable one and we do the injection before continuing *) observe_tac "reflexivity_with_destruct_cases : others" (tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases) ]) g (* [prove_fun_complete funs graphs schemes lemmas_types_infos i] is the tactic used to prove completness lemma. [funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct. [i] is the indice of the function to prove complete The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is it looks like~: [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, graph\ x_1\ldots x_n\ res, \rightarrow res = f x_1\ldots x_n in] The sketch of the proof is the following one~: \begin{enumerate} \item intros until $H:graph\ x_1\ldots x_n\ res$ \item $elim\ H$ using schemes.(i) \item for each generated branch, intro the news hyptohesis, for each such hyptohesis [h], if [h] has type [x=?] with [x] a variable, then subst [x], if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else if [h] is a match then destruct it, else do just introduce it, after all intros, the conclusion should be a reflexive equality. \end{enumerate} *) let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = fun g -> (* We compute the types of the different mutually recursive lemmas in $\zeta$ normal form *) let lemmas = Array.map (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn concl ctxt)) lemmas_types_infos in (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in let graph_principle = nf_zeta schemes.(i) in let princ_type = pf_type_of g graph_principle in let princ_infos = Tactics.compute_elim_sig princ_type in (* Then we get the number of argument of the function and compute a fresh name for each of them *) let nb_fun_args = nb_prod (pf_concl g) - 2 in let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in (* and fresh names for res H and the principle (cf bug bug #1174) *) let res,hres,graph_principle_id = match generate_fresh_id (id_of_string "z") ids 3 with | [res;hres;graph_principle_id] -> res,hres,graph_principle_id | _ -> assert false in let ids = res::hres::graph_principle_id::ids in (* we also compute fresh names for each hyptohesis of each branche of the principle *) let branches = List.rev princ_infos.branches in let intro_pats = List.map (fun (_,_,br_type) -> List.map (fun id -> id) (generate_fresh_id (id_of_string "y") ids (nb_prod br_type)) ) branches in (* We will need to change the function by its body using [f_equation] if it is recursive (that is the graph is infinite or unfold if the graph is finite *) let rewrite_tac j ids : tactic = let graph_def = graphs.(j) in let infos = try find_Function_infos (destConst funcs.(j)) with Not_found -> error "No graph found" in if infos.is_general || Rtree.is_infinite graph_def.mind_recargs then let eq_lemma = try Option.get (infos).equation_lemma with Option.IsNone -> anomaly "Cannot find equation lemma" in tclTHENSEQ[ tclMAP h_intro ids; Equality.rewriteLR (mkConst eq_lemma); (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *) h_reduce (Glob_term.Cbv {Glob_term.all_flags with Glob_term.rDelta = false; }) onConcl ; h_generalize (List.map mkVar ids); thin ids ] else unfold_in_concl [(Termops.all_occurrences, Names.EvalConstRef (destConst f))] in (* The proof of each branche itself *) let ind_number = ref 0 in let min_constr_number = ref 0 in let prove_branche i g = (* we fist compute the inductive corresponding to the branch *) let this_ind_number = let constructor_num = i - !min_constr_number in let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in if constructor_num <= length then !ind_number else begin incr ind_number; min_constr_number := !min_constr_number + length; !ind_number end in let this_branche_ids = List.nth intro_pats (pred i) in tclTHENSEQ[ (* we expand the definition of the function *) observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); (* introduce hypothesis with some rewrite *) observe_tac "intros_with_rewrite" intros_with_rewrite; (* The proof is (almost) complete *) observe_tac "reflexivity" (reflexivity_with_destruct_cases) ] g in let params_names = fst (list_chop princ_infos.nparams args_names) in let params = List.map mkVar params_names in tclTHENSEQ [ tclMAP h_intro (args_names@[res;hres]); observe_tac "h_generalize" (h_generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]); h_intro graph_principle_id; observe_tac "" (tclTHEN_i (observe_tac "elim" ((elim false (mkVar hres,Glob_term.NoBindings) (Some (mkVar graph_principle_id,Glob_term.NoBindings))))) (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) ] g let do_save () = Lemmas.save_named false (* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness lemmas for each function in [funs] w.r.t. [graphs] [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and [functional_induction] is Indfun.functional_induction (same pb) *) let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) = let previous_state = States.freeze () in let funs = Array.of_list funs and graphs = Array.of_list graphs in let funs_constr = Array.map mkConst funs in try let graphs_constr = Array.map mkInd graphs in let lemmas_types_infos = Util.array_map2_i (fun i f_constr graph -> let const_of_f = destConst f_constr in let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = generate_type false const_of_f graph i in let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let type_of_lemma = nf_zeta type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); type_of_lemma,type_info ) funs_constr graphs_constr in let schemes = (* The functional induction schemes are computed and not saved if there is more that one function if the block contains only one function we can safely reuse [f_rect] *) try if Array.length funs_constr <> 1 then raise Not_found; [| find_induction_principle funs_constr.(0) |] with Not_found -> Array.of_list (List.map (fun entry -> (entry.Entries.const_entry_body, Option.get entry.Entries.const_entry_type ) ) (make_scheme (array_map_to_list (fun const -> const,Glob_term.GType None) funs)) ) in let proving_tac = prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos in Array.iteri (fun i f_as_constant -> let f_id = id_of_label (con_label f_as_constant) in (*i The next call to mk_correct_id is valid since we are constructing the lemma Ensures by: obvious i*) let lem_id = mk_correct_id f_id in Lemmas.start_proof lem_id (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) (fst lemmas_types_infos.(i)) (fun _ _ -> ()); Pfedit.by (observe_tac ("prove correctness ("^(string_of_id f_id)^")") (proving_tac i)); do_save (); let finfo = find_Function_infos f_as_constant in let lem_cst = destConst (Constrintern.global_reference lem_id) in update_Function {finfo with correctness_lemma = Some lem_cst} ) funs; let lemmas_types_infos = Util.array_map2_i (fun i f_constr graph -> let const_of_f = destConst f_constr in let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = generate_type true const_of_f graph i in let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let type_of_lemma = nf_zeta type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); type_of_lemma,type_info ) funs_constr graphs_constr in let kn,_ as graph_ind = destInd graphs_constr.(0) in let mib,mip = Global.lookup_inductive graph_ind in let schemes = Array.of_list (Indrec.build_mutual_induction_scheme (Global.env ()) Evd.empty (Array.to_list (Array.mapi (fun i _ -> (kn,i),true,InType) mib.Declarations.mind_packets ) ) ) in let proving_tac = prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos in Array.iteri (fun i f_as_constant -> let f_id = id_of_label (con_label f_as_constant) in (*i The next call to mk_complete_id is valid since we are constructing the lemma Ensures by: obvious i*) let lem_id = mk_complete_id f_id in Lemmas.start_proof lem_id (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) (fst lemmas_types_infos.(i)) (fun _ _ -> ()); Pfedit.by (observe_tac ("prove completeness ("^(string_of_id f_id)^")") (proving_tac i)); do_save (); let finfo = find_Function_infos f_as_constant in let lem_cst = destConst (Constrintern.global_reference lem_id) in update_Function {finfo with completeness_lemma = Some lem_cst} ) funs; with reraise -> (* In case of problem, we reset all the lemmas *) Pfedit.delete_all_proofs (); States.unfreeze previous_state; raise reraise (***********************************************) (* [revert_graph kn post_tac hid] transforme an hypothesis [hid] having type Ind(kn,num) t1 ... tn res when [kn] denotes a graph block into f_num t1... tn = res (by applying [f_complete] to the first type) before apply post_tac on the result if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing *) let revert_graph kn post_tac hid g = let typ = pf_type_of g (mkVar hid) in match kind_of_term typ with | App(i,args) when isInd i -> let ((kn',num) as ind') = destInd i in if kn = kn' then (* We have generated a graph hypothesis so that we must change it if we can *) let info = try find_Function_of_graph ind' with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*) anomaly "Cannot retrieve infos about a mutual block" in (* if we can find a completeness lemma for this function then we can come back to the functional form. If not, we do nothing *) match info.completeness_lemma with | None -> tclIDTAC g | Some f_complete -> let f_args,res = array_chop (Array.length args - 1) args in tclTHENSEQ [ h_generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]; thin [hid]; h_intro hid; post_tac hid ] g else tclIDTAC g | _ -> tclIDTAC g (* [functional_inversion hid fconst f_correct ] is the functional version of [inversion] [hid] is the hypothesis to invert, [fconst] is the function to invert and [f_correct] is the correctness lemma for [fconst]. The sketch is the follwing~: \begin{enumerate} \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$ (fails if it is not possible) \item replace [hid] with $R\_f t_1 \ldots t_n res$ using [f_correct] \item apply [inversion] on [hid] \item finally in each branch, replace each hypothesis [R\_f ..] by [f ...] using [f_complete] (whenever such a lemma exists) \end{enumerate} *) let functional_inversion kn hid fconst f_correct : tactic = fun g -> let old_ids = List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty in let type_of_h = pf_type_of g (mkVar hid) in match kind_of_term type_of_h with | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> let pre_tac,f_args,res = match kind_of_term args.(1),kind_of_term args.(2) with | App(f,f_args),_ when eq_constr f fconst -> ((fun hid -> h_symmetry (onHyp hid)),f_args,args.(2)) |_,App(f,f_args) when eq_constr f fconst -> ((fun hid -> tclIDTAC),f_args,args.(1)) | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2) in tclTHENSEQ[ pre_tac hid; h_generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]; thin [hid]; h_intro hid; Inv.inv FullInversion None (Glob_term.NamedHyp hid); (fun g -> let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in tclMAP (revert_graph kn pre_tac) (hid::new_ids) g ); ] g | _ -> tclFAIL 1 (mt ()) g let invfun qhyp f = let f = match f with | ConstRef f -> f | _ -> raise (Util.UserError("",str "Not a function")) in try let finfos = find_Function_infos f in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp with | Not_found -> error "No graph found" | Option.IsNone -> error "Cannot use equivalence with graph!" let invfun qhyp f g = match f with | Some f -> invfun qhyp f g | None -> Tactics.try_intros_until (fun hid g -> let hyp_typ = pf_type_of g (mkVar hid) in match kind_of_term hyp_typ with | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> begin let f1,_ = decompose_app args.(1) in try if not (isConst f1) then failwith ""; let finfos = find_Function_infos (destConst f1) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in functional_inversion kn hid f1 f_correct g with | Failure "" | Option.IsNone | Not_found -> try let f2,_ = decompose_app args.(2) in if not (isConst f2) then failwith ""; let finfos = find_Function_infos (destConst f2) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in functional_inversion kn hid f2 f_correct g with | Failure "" -> errorlabstrm "" (str "Hypothesis" ++ Ppconstr.pr_id hid ++ str " must contain at leat one Function") | Option.IsNone -> if do_observe () then error "Cannot use equivalence with graph for any side of the equality" else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) | Not_found -> if do_observe () then error "No graph found for any side of equality" else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) end | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ") ) qhyp g coq-8.4pl4/plugins/funind/Recdef.v0000644000175000017500000000323012326224777016154 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* A) -> A -> A := fun (fl : A -> A) (def : A) => match n with | O => def | S m => fl (iter m fl def) end. End Iter. Theorem SSplus_lt : forall p p' : nat, p < S (S (p + p')). intro p; intro p'; change (S p <= S (S (p + p'))); apply le_S; apply Gt.gt_le_S; change (p < S (p + p')); apply Lt.le_lt_n_Sm; apply Plus.le_plus_l. Qed. Theorem Splus_lt : forall p p' : nat, p' < S (p + p'). intro p; intro p'; change (S p' <= S (p + p')); apply Gt.gt_le_S; change (p' < S (p + p')); apply Lt.le_lt_n_Sm; apply Plus.le_plus_r. Qed. Theorem le_lt_SS : forall x y, x <= y -> x < S (S y). intro x; intro y; intro H; change (S x <= S (S y)); apply le_S; apply Gt.gt_le_S; change (x < S y); apply Lt.le_lt_n_Sm; exact H. Qed. Inductive max_type (m n:nat) : Set := cmt : forall v, m <= v -> n <= v -> max_type m n. Definition max : forall m n:nat, max_type m n. intros m n; case (Compare_dec.le_gt_dec m n). intros h; exists n; [exact h | apply le_n]. intros h; exists m; [apply le_n | apply Lt.lt_le_weak; exact h]. Defined. coq-8.4pl4/plugins/funind/glob_term_to_relation.mli0000644000175000017500000000102412326224777021650 0ustar stephsteph (* [build_inductive parametrize funnames funargs returned_types bodies] constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments and returning [returned_types] using bodies [bodies] *) val build_inductive : Names.identifier list -> (* The list of function name *) (Names.name*Glob_term.glob_constr*bool) list list -> (* The list of function args *) Topconstr.constr_expr list -> (* The list of function returned type *) Glob_term.glob_constr list -> (* the list of body *) unit coq-8.4pl4/plugins/funind/vo.itarget0000644000175000017500000000001212326224777016575 0ustar stephstephRecdef.vo coq-8.4pl4/plugins/funind/merge.ml0000644000175000017500000011274412326224777016241 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* false) t1 t2 then true else false let rec compare_constr' t1 t2 = if compare_constr_nosub t1 t2 then true else (compare_constr (compare_constr') t1 t2) let rec substitterm prof t by_t in_u = if (compare_constr' (lift prof t) in_u) then (lift prof by_t) else map_constr_with_binders succ (fun i -> substitterm i t by_t) prof in_u let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl let understand = Pretyping.Default.understand Evd.empty (Global.env()) (** Operations on names and identifiers *) let id_of_name = function Anonymous -> id_of_string "H" | Name id -> id;; let name_of_string str = Name (id_of_string str) let string_of_name nme = string_of_id (id_of_name nme) (** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *) let isVarf f x = match x with | GVar (_,x) -> Pervasives.compare x f = 0 | _ -> false (** [ident_global_exist id] returns true if identifier [id] is linked in global environment. *) let ident_global_exist id = try let ans = CRef (Libnames.Ident (dummy_loc,id)) in let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in true with e when Errors.noncritical e -> false (** [next_ident_fresh id] returns a fresh identifier (ie not linked in global env) with base [id]. *) let next_ident_fresh (id:identifier) = let res = ref id in while ident_global_exist !res do res := Nameops.lift_subscript !res done; !res (** {2 Debugging} *) (* comment this line to see debug msgs *) let msg x = () ;; let pr_lconstr c = str "" (* uncomment this to see debugging *) let prconstr c = msg (str" " ++ Printer.pr_lconstr c) let prconstrnl c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") let prlistconstr lc = List.iter prconstr lc let prstr s = msg(str s) let prNamedConstr s c = begin msg(str ""); msg(str(s^" {§ ") ++ Printer.pr_lconstr c ++ str " §} "); msg(str ""); end let prNamedRConstr s c = begin msg(str ""); msg(str(s^" {§ ") ++ Printer.pr_glob_constr c ++ str " §} "); msg(str ""); end let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc let prNamedLConstr s lc = begin prstr "[§§§ "; prstr s; prNamedLConstr_aux lc; prstr " §§§]\n"; end let prNamedLDecl s lc = begin prstr s; prstr "\n"; List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc; prstr "\n"; end let prNamedRLDecl s lc = begin prstr s; prstr "\n"; prstr "{§§ "; List.iter (fun x -> match x with | (nm,None,Some tp) -> prNamedRConstr (string_of_name nm) tp | (nm,Some bdy,None) -> prNamedRConstr ("(letin) "^string_of_name nm) bdy | _ -> assert false ) lc; prstr " §§}\n"; prstr "\n"; end let showind (id:identifier) = let cstrid = Constrintern.global_reference id in let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in List.iter (fun (nm, optcstr, tp) -> print_string (string_of_name nm^":"); prconstr tp; print_string "\n") ib1.mind_arity_ctxt; (match ib1.mind_arity with | Monomorphic x -> Printf.printf "arity :"; prconstr x.mind_user_arity | Polymorphic x -> Printf.printf "arity : universe?"); Array.iteri (fun i x -> Printf.printf"type constr %d :" i ; prconstr x) ib1.mind_user_lc (** {2 Misc} *) exception Found of int (* Array scanning *) let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int = try for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done; Array.length arr (* all elt are positive *) with Found i -> i let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a = let i = ref 0 in Array.fold_left (fun acc x -> let res = f !i acc x in i := !i + 1; res) acc arr (* Like list_chop but except that [i] is the size of the suffix of [l]. *) let list_chop_end i l = let size_prefix = List.length l -i in if size_prefix < 0 then failwith "list_chop_end" else list_chop size_prefix l let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a = let i = ref 0 in List.fold_left (fun acc x -> let res = f !i acc x in i := !i + 1; res) acc arr let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list = let i = ref 0 in List.filter (fun x -> let res = f !i x in i := !i + 1; res) l (** Iteration module *) module For = struct let rec map i j (f: int -> 'a) = if i>j then [] else f i :: (map (i+1) j f) let rec foldup i j (f: 'a -> int -> 'a) acc = if i>j then acc else let newacc = f acc i in foldup (i+1) j f newacc let rec folddown i j (f: 'a -> int -> 'a) acc = if i>j then acc else let newacc = f acc j in folddown i (j-1) f newacc let fold i j = if i Printf.sprintf "Linked %d" i | Unlinked -> Printf.sprintf "Unlinked" | Funres -> Printf.sprintf "Funres" let linkmonad f lnkvar = match lnkvar with | Linked i -> Linked (f i) | Unlinked -> Unlinked | Funres -> Funres let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar (* This map is used to deal with debruijn linked indices. *) module Link = Map.Make (struct type t = int let compare = Pervasives.compare end) let pr_links l = Printf.printf "links:\n"; Link.iter (fun k e -> Printf.printf "%d : %s\n" k (prlinked e)) l; Printf.printf "_____________\n" type 'a merged_arg = | Prm_stable of 'a | Prm_linked of 'a | Prm_arg of 'a | Arg_stable of 'a | Arg_linked of 'a | Arg_funres (** Information about graph merging of two inductives. All rel_decl list are IN REVERSE ORDER (ie well suited for compose) *) type merge_infos = { ident:identifier; (** new inductive name *) mib1: mutual_inductive_body; oib1: one_inductive_body; mib2: mutual_inductive_body; oib2: one_inductive_body; (** Array of links of the first inductive (should be all stable) *) lnk1: int merged_arg array; (** Array of links of the second inductive (point to the first ind param/args) *) lnk2: int merged_arg array; (** rec params which remain rec param (ie not linked) *) recprms1: rel_declaration list; recprms2: rel_declaration list; nrecprms1: int; nrecprms2: int; (** rec parms which became non parm (either linked to something or because after a rec parm that became non parm) *) otherprms1: rel_declaration list; otherprms2: rel_declaration list; notherprms1:int; notherprms2:int; (** args which remain args in merge *) args1:rel_declaration list; args2:rel_declaration list; nargs1:int; nargs2:int; (** functional result args *) funresprms1: rel_declaration list; funresprms2: rel_declaration list; nfunresprms1:int; nfunresprms2:int; } let pr_merginfo x = let i,s= match x with | Prm_linked i -> Some i,"Prm_linked" | Arg_linked i -> Some i,"Arg_linked" | Prm_stable i -> Some i,"Prm_stable" | Prm_arg i -> Some i,"Prm_arg" | Arg_stable i -> Some i,"Arg_stable" | Arg_funres -> None , "Arg_funres" in match i with | Some i -> Printf.sprintf "%s(%d)" s i | None -> Printf.sprintf "%s" s let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false (* ?? prm_linked?? *) let isArg_stable x = match x with Arg_stable _ | Prm_arg _ -> true | _ -> false let is_stable x = match x with Arg_stable _ | Prm_stable _ | Prm_arg _ -> true | _ -> false let isArg_funres x = match x with Arg_funres -> true | _ -> false let filter_shift_stable (lnk:int merged_arg array) (l:'a list): 'a list = let prms = list_filteri (fun i _ -> isPrm_stable lnk.(i)) l in let args = list_filteri (fun i _ -> isArg_stable lnk.(i)) l in let fres = list_filteri (fun i _ -> isArg_funres lnk.(i)) l in prms@args@fres (** Reverse the link map, keeping only linked vars, elements are list of int as several vars may be linked to the same var. *) let revlinked lnk = For.fold 0 (Array.length lnk - 1) (fun acc k -> match lnk.(k) with | Unlinked | Funres -> acc | Linked i -> let old = try Link.find i acc with Not_found -> [] in Link.add i (k::old) acc) Link.empty let array_switch arr i j = let aux = arr.(j) in arr.(j) <- arr.(i); arr.(i) <- aux let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list = let larr = Array.of_list l in let _ = Array.iteri (fun j x -> match x with | Prm_linked i -> array_switch larr i j | Arg_linked i -> array_switch larr i j | Prm_stable i -> () | Prm_arg i -> () | Arg_stable i -> () | Arg_funres -> () ) lnk in filter_shift_stable lnk (Array.to_list larr) (** {1 Utilities for merging} *) let ind1name = id_of_string "__ind1" let ind2name = id_of_string "__ind2" (** Performs verifications on two graphs before merging: they must not be co-inductive, and for the moment they must not be mutual either. *) let verify_inds mib1 mib2 = if not mib1.mind_finite then error "First argument is coinductive"; if not mib2.mind_finite then error "Second argument is coinductive"; if mib1.mind_ntypes <> 1 then error "First argument is mutual"; if mib2.mind_ntypes <> 1 then error "Second argument is mutual"; () (* (** [build_raw_params prms_decl avoid] returns a list of variables attributed to the list of decl [prms_decl], avoiding names in [avoid]. *) let build_raw_params prms_decl avoid = let dummy_constr = compose_prod (List.map (fun (x,_,z) -> x,z) prms_decl) (mkRel 1) in let _ = prNamedConstr "DUMMY" dummy_constr in let dummy_glob_constr = Detyping.detype false avoid [] dummy_constr in let _ = prNamedRConstr "RAWDUMMY" dummy_glob_constr in let res,_ = glob_decompose_prod dummy_glob_constr in let comblist = List.combine prms_decl res in comblist, res , (avoid @ (Idset.elements (ids_of_glob_constr dummy_glob_constr))) *) let ids_of_rawlist avoid rawl = List.fold_left Idset.union avoid (List.map ids_of_glob_constr rawl) (** {1 Merging function graphs} *) (** [shift_linked_params mib1 mib2 lnk] Computes which parameters (rec uniform and ordinary ones) of mutual inductives [mib1] and [mib2] remain uniform when linked by [lnk]. All parameters are considered, ie we take parameters of the first inductive body of [mib1] and [mib2]. Explanation: The two inductives have parameters, some of the first are recursively uniform, some of the last are functional result of the functional graph. (I x1 x2 ... xk ... xk' ... xn) (J y1 y2 ... xl ... yl' ... ym) Problem is, if some rec unif params are linked to non rec unif ones, they become non rec (and the following too). And functinal argument have to be shifted at the end *) let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array) id = let _ = prstr "\nYOUHOU shift\n" in let linked_targets = revlinked lnk2 in let is_param_of_mib1 x = x < mib1.mind_nparams_rec in let is_param_of_mib2 x = x < mib2.mind_nparams_rec in let is_targetted_by_non_recparam_lnk1 i = try let targets = Link.find i linked_targets in List.exists (fun x -> not (is_param_of_mib2 x)) targets with Not_found -> false in let mlnk1 = Array.mapi (fun i lkv -> let isprm = is_param_of_mib1 i in let prmlost = is_targetted_by_non_recparam_lnk1 i in match isprm , prmlost, lnk1.(i) with | true , true , _ -> Prm_arg i (* recparam becoming ordinary *) | true , false , _-> Prm_stable i (* recparam remains recparam*) | false , false , Funres -> Arg_funres | _ , _ , Funres -> assert false (* fun res cannot be a rec param or lost *) | false , _ , _ -> Arg_stable i) (* Args of lnk1 are not linked *) lnk1 in let mlnk2 = Array.mapi (fun i lkv -> (* Is this correct if some param of ind2 is lost? *) let isprm = is_param_of_mib2 i in match isprm , lnk2.(i) with | true , Linked j when not (is_param_of_mib1 j) -> Prm_arg j (* recparam becoming ordinary *) | true , Linked j -> Prm_linked j (*recparam linked to recparam*) | true , Unlinked -> Prm_stable i (* recparam remains recparam*) | false , Linked j -> Arg_linked j (* Args of lnk2 lost *) | false , Unlinked -> Arg_stable i (* Args of lnk2 remains *) | false , Funres -> Arg_funres | true , Funres -> assert false (* fun res cannot be a rec param *) ) lnk2 in let oib1 = mib1.mind_packets.(0) in let oib2 = mib2.mind_packets.(0) in (* count params remaining params *) let n_params1 = array_prfx mlnk1 (fun i x -> not (isPrm_stable x)) in let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in let bldprms arity_ctxt mlnk = list_fold_lefti (fun i (acc1,acc2,acc3,acc4) x -> prstr (pr_merginfo mlnk.(i));prstr "\n"; match mlnk.(i) with | Prm_stable _ -> x::acc1 , acc2 , acc3, acc4 | Prm_arg _ -> acc1 , x::acc2 , acc3, acc4 | Arg_stable _ -> acc1 , acc2 , x::acc3, acc4 | Arg_funres -> acc1 , acc2 , acc3, x::acc4 | _ -> acc1 , acc2 , acc3, acc4) ([],[],[],[]) arity_ctxt in (* let arity_ctxt2 = build_raw_params oib2.mind_arity_ctxt (Idset.elements (ids_of_glob_constr oib1.mind_arity_ctxt)) in*) let recprms1,otherprms1,args1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in let _ = prstr "\n\n\n" in let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in let _ = prstr "\notherprms1:\n" in let _ = List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") otherprms1 in let _ = prstr "\notherprms2:\n" in let _ = List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") otherprms2 in { ident=id; mib1=mib1; oib1 = oib1; mib2=mib2; oib2 = oib2; lnk1 = mlnk1; lnk2 = mlnk2; nrecprms1 = n_params1; recprms1 = recprms1; otherprms1 = otherprms1; args1 = args1; funresprms1 = funresprms1; notherprms1 = Array.length mlnk1 - n_params1; nfunresprms1 = List.length funresprms1; nargs1 = List.length args1; nrecprms2 = n_params2; recprms2 = recprms2; otherprms2 = otherprms2; args2 = args2; funresprms2 = funresprms2; notherprms2 = Array.length mlnk2 - n_params2; nargs2 = List.length args2; nfunresprms2 = List.length funresprms2; } (** {1 Merging functions} *) exception NoMerge let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = let lnk = Array.append shift.lnk1 shift.lnk2 in match c1 , c2 with | GApp(_,f1, arr1), GApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> let _ = prstr "\nICI1!\n";Pp.flush_all() in let args = filter_shift_stable lnk (arr1 @ arr2) in GApp (dummy_loc,GVar (dummy_loc,shift.ident) , args) | GApp(_,f1, arr1), GApp(_,f2,arr2) -> raise NoMerge | GLetIn(_,nme,bdy,trm) , _ -> let _ = prstr "\nICI2!\n";Pp.flush_all() in let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in GLetIn(dummy_loc,nme,bdy,newtrm) | _, GLetIn(_,nme,bdy,trm) -> let _ = prstr "\nICI3!\n";Pp.flush_all() in let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in GLetIn(dummy_loc,nme,bdy,newtrm) | _ -> let _ = prstr "\nICI4!\n";Pp.flush_all() in raise NoMerge let rec merge_app_unsafe c1 c2 shift filter_shift_stable = let lnk = Array.append shift.lnk1 shift.lnk2 in match c1 , c2 with | GApp(_,f1, arr1), GApp(_,f2,arr2) -> let args = filter_shift_stable lnk (arr1 @ arr2) in GApp (dummy_loc,GVar(dummy_loc,shift.ident) , args) (* FIXME: what if the function appears in the body of the let? *) | GLetIn(_,nme,bdy,trm) , _ -> let _ = prstr "\nICI2 '!\n";Pp.flush_all() in let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in GLetIn(dummy_loc,nme,bdy,newtrm) | _, GLetIn(_,nme,bdy,trm) -> let _ = prstr "\nICI3 '!\n";Pp.flush_all() in let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in GLetIn(dummy_loc,nme,bdy,newtrm) | _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge (* Heuristic when merging two lists of hypothesis: merge every rec calls of branch 1 with all rec calls of branch 2. *) (* TODO: reecrire cette heuristique (jusqu'a merge_types) *) let rec merge_rec_hyps shift accrec (ltyp:(Names.name * glob_constr option * glob_constr option) list) filter_shift_stable : (Names.name * glob_constr option * glob_constr option) list = let mergeonehyp t reldecl = match reldecl with | (nme,x,Some (GApp(_,i,args) as ind)) -> nme,x, Some (merge_app_unsafe ind t shift filter_shift_stable) | (nme,Some _,None) -> error "letins with recursive calls not treated yet" | (nme,None,Some _) -> assert false | (nme,None,None) | (nme,Some _,Some _) -> assert false in match ltyp with | [] -> [] | (nme,None,Some (GApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> let rechyps = List.map (mergeonehyp t) accrec in rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable let rec build_suppl_reccall (accrec:(name * glob_constr) list) concl2 shift = List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec let find_app (nme:identifier) ltyp = try ignore (List.map (fun x -> match x with | _,None,Some (GApp(_,f,_)) when isVarf nme f -> raise (Found 0) | _ -> ()) ltyp); false with Found _ -> true let prnt_prod_or_letin nm letbdy typ = match letbdy , typ with | Some lbdy , None -> prNamedRConstr ("(letin) " ^ string_of_name nm) lbdy | None , Some tp -> prNamedRConstr (string_of_name nm) tp | _ , _ -> assert false let rec merge_types shift accrec1 (ltyp1:(name * glob_constr option * glob_constr option) list) (concl1:glob_constr) (ltyp2:(name * glob_constr option * glob_constr option) list) concl2 : (name * glob_constr option * glob_constr option) list * glob_constr = let _ = prstr "MERGE_TYPES\n" in let _ = prstr "ltyp 1 : " in let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp1 in let _ = prstr "\nltyp 2 : " in let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp2 in let _ = prstr "\n" in let res = match ltyp1 with | [] -> let isrec1 = (accrec1<>[]) in let isrec2 = find_app ind2name ltyp2 in let rechyps = if isrec1 && isrec2 then (* merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable *) merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 filter_shift_stable_right @ merge_rec_hyps shift accrec1 [name_of_string "concl2",None, Some concl2] filter_shift_stable else if isrec1 (* if rec calls in accrec1 and not in ltyp2, add one to ltyp2 *) then merge_rec_hyps shift accrec1 (ltyp2@[name_of_string "concl2",None,Some concl2]) filter_shift_stable else if isrec2 then merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 filter_shift_stable_right else ltyp2 in let _ = prstr"\nrechyps : " in let _ = List.iter(fun (nm,lbdy,tp)-> prnt_prod_or_letin nm lbdy tp) rechyps in let _ = prstr "MERGE CONCL : " in let _ = prNamedRConstr "concl1" concl1 in let _ = prstr " with " in let _ = prNamedRConstr "concl2" concl2 in let _ = prstr "\n" in let concl = merge_app concl1 concl2 ind1name ind2name shift filter_shift_stable in let _ = prstr "FIN " in let _ = prNamedRConstr "concl" concl in let _ = prstr "\n" in rechyps , concl | (nme,None, Some t1)as e ::lt1 -> (match t1 with | GApp(_,f,carr) when isVarf ind1name f -> merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 | _ -> let recres, recconcl2 = merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in ((nme,None,Some t1) :: recres) , recconcl2) | (nme,Some bd, None) ::lt1 -> (* FIXME: what if ind1name appears in bd? *) let recres, recconcl2 = merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in ((nme,Some bd,None) :: recres) , recconcl2 | (_,None,None)::_ | (_,Some _,Some _)::_ -> assert false in res (** [build_link_map_aux allargs1 allargs2 shift] returns the mapping of linked args [allargs2] to target args of [allargs1] as specified in [shift]. [allargs1] and [allargs2] are in reverse order. Also returns the list of unlinked vars of [allargs2]. *) let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array) (lnk:int merged_arg array) = array_fold_lefti (fun i acc e -> if i = Array.length lnk - 1 then acc (* functional arg, not in allargs *) else match e with | Prm_linked j | Arg_linked j -> Idmap.add allargs2.(i) allargs1.(j) acc | _ -> acc) Idmap.empty lnk let build_link_map allargs1 allargs2 lnk = let allargs1 = Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs1)) in let allargs2 = Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs2)) in build_link_map_aux allargs1 allargs2 lnk (** [merge_one_constructor lnk shift typcstr1 typcstr2] merges the two constructor rawtypes [typcstr1] and [typcstr2]. [typcstr1] and [typcstr2] contain all parameters (including rec. unif. ones) of their inductive. if [typcstr1] and [typcstr2] are of the form: forall recparams1, forall ordparams1, H1a -> H2a... (I1 x1 y1 ... z1) forall recparams2, forall ordparams2, H2b -> H2b... (I2 x2 y2 ... z2) we build: forall recparams1 (recparams2 without linked params), forall ordparams1 (ordparams2 without linked params), H1a' -> H2a' -> ... -> H2a' -> H2b'(shifted) -> ... -> (newI x1 ... z1 x2 y2 ...z2 without linked params) where Hix' have been adapted, ie: - linked vars have been changed, - rec calls to I1 and I2 have been replaced by rec calls to newI. More precisely calls to I1 and I2 have been merge by an experimental heuristic (in particular if n o rec calls for I1 or I2 is found, we use the conclusion as a rec call). See [merge_types] above. Precond: vars sets of [typcstr1] and [typcstr2] must be disjoint. TODO: return nothing if equalities (after linking) are contradictory. *) let merge_one_constructor (shift:merge_infos) (typcstr1:glob_constr) (typcstr2:glob_constr) : glob_constr = (* FIXME: les noms des parametres corerspondent en principe au parametres du niveau mib, mais il faudrait s'en assurer *) (* shift.nfunresprmsx last args are functional result *) let nargs1 = shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in let nargs2 = shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in let allargs1,rest1 = glob_decompose_prod_or_letin_n nargs1 typcstr1 in let allargs2,rest2 = glob_decompose_prod_or_letin_n nargs2 typcstr2 in (* Build map of linked args of [typcstr2], and apply it to [typcstr2]. *) let linked_map = build_link_map allargs1 allargs2 shift.lnk2 in let rest2 = change_vars linked_map rest2 in let hyps1,concl1 = glob_decompose_prod_or_letin rest1 in let hyps2,concl2' = glob_decompose_prod_or_letin rest2 in let ltyp,concl2 = merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in let _ = prNamedRLDecl "ltyp result:" ltyp in let typ = glob_compose_prod_or_letin concl2 (List.rev ltyp) in let revargs1 = list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in let _ = prNamedRLDecl "ltyp allargs1" allargs1 in let _ = prNamedRLDecl "ltyp revargs1" revargs1 in let revargs2 = list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in let _ = prNamedRLDecl "ltyp allargs2" allargs2 in let _ = prNamedRLDecl "ltyp revargs2" revargs2 in let typwithprms = glob_compose_prod_or_letin typ (List.rev revargs2 @ List.rev revargs1) in typwithprms (** constructor numbering *) let fresh_cstror_suffix , cstror_suffix_init = let cstror_num = ref 0 in (fun () -> let res = string_of_int !cstror_num in cstror_num := !cstror_num + 1; res) , (fun () -> cstror_num := 0) (** [merge_constructor_id id1 id2 shift] returns the identifier of the new constructor from the id of the two merged constructor and the merging info. *) let merge_constructor_id id1 id2 shift:identifier = let id = string_of_id shift.ident ^ "_" ^ fresh_cstror_suffix () in next_ident_fresh (id_of_string id) (** [merge_constructors lnk shift avoid] merges the two list of constructor [(name*type)]. These are translated to glob_constr first, each of them having distinct var names. *) let rec merge_constructors (shift:merge_infos) (avoid:Idset.t) (typcstr1:(identifier * glob_constr) list) (typcstr2:(identifier * glob_constr) list) : (identifier * glob_constr) list = List.flatten (List.map (fun (id1,rawtyp1) -> List.map (fun (id2,rawtyp2) -> let typ = merge_one_constructor shift rawtyp1 rawtyp2 in let newcstror_id = merge_constructor_id id1 id2 shift in let _ = prstr "\n**************\n" in newcstror_id , typ) typcstr2) typcstr1) (** [merge_inductive_body lnk shift avoid oib1 oib2] merges two inductive bodies [oib1] and [oib2], linking with [lnk], params info in [shift], avoiding identifiers in [avoid]. *) let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) (oib2:one_inductive_body) = (* building glob_constr type of constructors *) let mkrawcor nme avoid typ = (* first replace rel 1 by a varname *) let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in Detyping.detype false (Idset.elements avoid) [] substindtyp in let lcstr1: glob_constr list = Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in (* add to avoid all indentifiers of lcstr1 *) let avoid2 = Idset.union avoid (ids_of_rawlist avoid lcstr1) in let lcstr2 = Array.to_list (Array.map (mkrawcor ind2name avoid2) oib2.mind_user_lc) in let avoid3 = Idset.union avoid (ids_of_rawlist avoid lcstr2) in let params1 = try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) with e when Errors.noncritical e -> [] in let params2 = try fst (glob_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) with e when Errors.noncritical e -> [] in let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in cstror_suffix_init(); params1,params2,merge_constructors shift avoid3 lcstr1 lcstr2 (** [merge_mutual_inductive_body lnk mib1 mib2 shift] merge mutual inductive bodies [mib1] and [mib2] linking vars with [lnk]. [shift] information on parameters of the new inductive. For the moment, inductives are supposed to be non mutual. *) let rec merge_mutual_inductive_body (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) = (* Mutual not treated, we take first ind body of each. *) merge_inductive_body shift Idset.empty mib1.mind_packets.(0) mib2.mind_packets.(0) let glob_constr_to_constr_expr x = (* build a constr_expr from a glob_constr *) Flags.with_option Flags.raw_print (Constrextern.extern_glob_type Idset.empty) x let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = let params = prms2 @ prms1 in let resparams = List.fold_left (fun acc (nme,tp) -> let _ = prstr "param :" in let _ = prNamedRConstr (string_of_name nme) tp in let _ = prstr " ; " in let typ = glob_constr_to_constr_expr tp in LocalRawAssum ([(dummy_loc,nme)], Topconstr.default_binder_kind, typ) :: acc) [] params in let concl = Constrextern.extern_constr false (Global.env()) concl in let arity,_ = List.fold_left (fun (acc,env) (nm,_,c) -> let typ = Constrextern.extern_constr false env c in let newenv = Environ.push_rel (nm,None,c) env in CProdN (dummy_loc, [[(dummy_loc,nm)],Topconstr.default_binder_kind,typ] , acc) , newenv) (concl,Global.env()) (shift.funresprms2 @ shift.funresprms1 @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in resparams,arity (** [glob_constr_list_to_inductive_expr ident rawlist] returns the induct_expr corresponding to the the list of constructor types [rawlist], named ident. FIXME: params et cstr_expr (arity) *) let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift (rawlist:(identifier * glob_constr) list) = let lident = dummy_loc, shift.ident in let bindlist , cstr_expr = (* params , arities *) merge_rec_params_and_arity prms1 prms2 shift mkSet in let lcstor_expr : (bool * (lident * constr_expr)) list = List.map (* zeta_normalize t ? *) (fun (id,t) -> false, ((dummy_loc,id),glob_constr_to_constr_expr t)) rawlist in lident , bindlist , Some cstr_expr , lcstor_expr let mkProd_reldecl (rdecl:rel_declaration) (t2:glob_constr) = match rdecl with | (nme,None,t) -> let traw = Detyping.detype false [] [] t in GProd (dummy_loc,nme,Explicit,traw,t2) | (_,Some _,_) -> assert false let mkProd_reldecl (rdecl:rel_declaration) (t2:glob_constr) = match rdecl with | (nme,None,t) -> let traw = Detyping.detype false [] [] t in GProd (dummy_loc,nme,Explicit,traw,t2) | (_,Some _,_) -> assert false (** [merge_inductive ind1 ind2 lnk] merges two graphs, linking variables specified in [lnk]. Graphs are not supposed to be mutual inductives for the moment. *) let merge_inductive (ind1: inductive) (ind2: inductive) (lnk1: linked_var array) (lnk2: linked_var array) id = let env = Global.env() in let mib1,_ = Inductive.lookup_mind_specif env ind1 in let mib2,_ = Inductive.lookup_mind_specif env ind2 in let _ = verify_inds mib1 mib2 in (* raises an exception if something wrong *) (* compute params that become ordinary args (because linked to ord. args) *) let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in let _ = prstr "\nrawlist : " in let _ = List.iter (fun (nm,tp) -> prNamedRConstr (string_of_id nm) tp;prstr "\n") rawlist in let _ = prstr "\nend rawlist\n" in (* FIX: retransformer en constr ici let shift_prm = { shift_prm with recprms1=prms1; recprms1=prms1; } in *) let indexpr = glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in (* Declare inductive *) let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in let mie,impls = Command.interp_mutual_inductive indl [] true (* means: not coinductive *) in (* Declare the mutual inductive block with its associated schemes *) ignore (Command.declare_mutual_inductive_with_eliminations Declare.UserVerbose mie impls) (* Find infos on identifier id. *) let find_Function_infos_safe (id:identifier): Indfun_common.function_info = let kn_of_id x = let f_ref = Libnames.Ident (dummy_loc,x) in locate_with_msg (str "Don't know what to do with " ++ Libnames.pr_reference f_ref) locate_constant f_ref in try find_Function_infos (kn_of_id id) with Not_found -> errorlabstrm "indfun" (Nameops.pr_id id ++ str " has no functional scheme") (** [merge id1 id2 args1 args2 id] builds and declares a new inductive type called [id], representing the merged graphs of both graphs [ind1] and [ind2]. identifiers occuring in both arrays [args1] and [args2] are considered linked (i.e. are the same variable) in the new graph. Warning: For the moment, repetitions of an id in [args1] or [args2] are not supported. *) let merge (id1:identifier) (id2:identifier) (args1:identifier array) (args2:identifier array) id : unit = let finfo1 = find_Function_infos_safe id1 in let finfo2 = find_Function_infos_safe id2 in (* FIXME? args1 are supposed unlinked. mergescheme (G x x) ?? *) (* We add one arg (functional arg of the graph) *) let lnk1 = Array.make (Array.length args1 + 1) Unlinked in let lnk2' = (* args2 may be linked to args1 members. FIXME: same as above: vars may be linked inside args2?? *) Array.mapi (fun i c -> match array_find_i (fun i x -> x=c) args1 with | Some j -> Linked j | None -> Unlinked) args2 in (* We add one arg (functional arg of the graph) *) let lnk2 = Array.append lnk2' (Array.make 1 Unlinked) in (* setting functional results *) let _ = lnk1.(Array.length lnk1 - 1) <- Funres in let _ = lnk2.(Array.length lnk2 - 1) <- Funres in merge_inductive finfo1.graph_ind finfo2.graph_ind lnk1 lnk2 id let remove_last_arg c = let (x,y) = decompose_prod c in let xnolast = List.rev (List.tl (List.rev x)) in compose_prod xnolast y let rec remove_n_fst_list n l = if n=0 then l else remove_n_fst_list (n-1) (List.tl l) let remove_n_last_list n l = List.rev (remove_n_fst_list n (List.rev l)) let remove_last_n_arg n c = let (x,y) = decompose_prod c in let xnolast = remove_n_last_list n x in compose_prod xnolast y (* [funify_branches relinfo nfuns branch] returns the branch [branch] of the relinfo [relinfo] modified to fit in a functional principle. Things to do: - remove indargs from rel applications - replace *variables only* corresponding to function (recursive) results by the actual function application. *) let funify_branches relinfo nfuns branch = let mut_induct, induct = match relinfo.indref with | None -> assert false | Some (IndRef ((mutual_ind,i) as ind)) -> mutual_ind,ind | _ -> assert false in let is_dom c = match kind_of_term c with | Ind((u,_)) | Construct((u,_),_) -> u = mut_induct | _ -> false in let _dom_i c = assert (is_dom c); match kind_of_term c with | Ind((u,i)) | Construct((u,_),i) -> i | _ -> assert false in let _is_pred c shift = match kind_of_term c with | Rel i -> let reali = i-shift in (reali>=0 && reali false in (* FIXME: *) (Anonymous,Some mkProp,mkProp) let relprinctype_to_funprinctype relprinctype nfuns = let relinfo = compute_elim_sig relprinctype in assert (not relinfo.farg_in_concl); assert (relinfo.indarg_in_concl); (* first remove indarg and indarg_in_concl *) let relinfo_noindarg = { relinfo with indarg_in_concl = false; indarg = None; concl = remove_last_arg (pop relinfo.concl); } in (* the nfuns last induction arguments are functional ones: remove them *) let relinfo_argsok = { relinfo_noindarg with nargs = relinfo_noindarg.nargs - nfuns; (* args is in reverse order, so remove fst *) args = remove_n_fst_list nfuns relinfo_noindarg.args; concl = popn nfuns relinfo_noindarg.concl } in let new_branches = List.map (funify_branches relinfo_argsok nfuns) relinfo_argsok.branches in let relinfo_branches = { relinfo_argsok with branches = new_branches } in relinfo_branches (* @article{ bundy93rippling, author = "Alan Bundy and Andrew Stevens and Frank van Harmelen and Andrew Ireland and Alan Smaill", title = "Rippling: A Heuristic for Guiding Inductive Proofs", journal = "Artificial Intelligence", volume = "62", number = "2", pages = "185-253", year = "1993", url = "citeseer.ist.psu.edu/bundy93rippling.html" } *) coq-8.4pl4/plugins/funind/glob_termops.ml0000644000175000017500000005125112326224777017631 0ustar stephstephopen Pp open Glob_term open Util open Names (* Ocaml 3.06 Map.S does not handle is_empty *) let idmap_is_empty m = m = Idmap.empty (* Some basic functions to rebuild glob_constr In each of them the location is Util.dummy_loc *) let mkGRef ref = GRef(dummy_loc,ref) let mkGVar id = GVar(dummy_loc,id) let mkGApp(rt,rtl) = GApp(dummy_loc,rt,rtl) let mkGLambda(n,t,b) = GLambda(dummy_loc,n,Explicit,t,b) let mkGProd(n,t,b) = GProd(dummy_loc,n,Explicit,t,b) let mkGLetIn(n,t,b) = GLetIn(dummy_loc,n,t,b) let mkGCases(rto,l,brl) = GCases(dummy_loc,Term.RegularStyle,rto,l,brl) let mkGSort s = GSort(dummy_loc,s) let mkGHole () = GHole(dummy_loc,Evd.BinderType Anonymous) let mkGCast(b,t) = GCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t)) (* Some basic functions to decompose glob_constrs These are analogous to the ones constrs *) let glob_decompose_prod = let rec glob_decompose_prod args = function | GProd(_,n,k,t,b) -> glob_decompose_prod ((n,t)::args) b | rt -> args,rt in glob_decompose_prod [] let glob_decompose_prod_or_letin = let rec glob_decompose_prod args = function | GProd(_,n,k,t,b) -> glob_decompose_prod ((n,None,Some t)::args) b | GLetIn(_,n,t,b) -> glob_decompose_prod ((n,Some t,None)::args) b | rt -> args,rt in glob_decompose_prod [] let glob_compose_prod = List.fold_left (fun b (n,t) -> mkGProd(n,t,b)) let glob_compose_prod_or_letin = List.fold_left ( fun concl decl -> match decl with | (n,None,Some t) -> mkGProd(n,t,concl) | (n,Some bdy,None) -> mkGLetIn(n,bdy,concl) | _ -> assert false) let glob_decompose_prod_n n = let rec glob_decompose_prod i args c = if i<=0 then args,c else match c with | GProd(_,n,_,t,b) -> glob_decompose_prod (i-1) ((n,t)::args) b | rt -> args,rt in glob_decompose_prod n [] let glob_decompose_prod_or_letin_n n = let rec glob_decompose_prod i args c = if i<=0 then args,c else match c with | GProd(_,n,_,t,b) -> glob_decompose_prod (i-1) ((n,None,Some t)::args) b | GLetIn(_,n,t,b) -> glob_decompose_prod (i-1) ((n,Some t,None)::args) b | rt -> args,rt in glob_decompose_prod n [] let glob_decompose_app = let rec decompose_rapp acc rt = (* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) match rt with | GApp(_,rt,rtl) -> decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt | rt -> rt,List.rev acc in decompose_rapp [] (* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *) let glob_make_eq ?(typ= mkGHole ()) t1 t2 = mkGApp(mkGRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1]) (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) let glob_make_neq t1 t2 = mkGApp(mkGRef (Lazy.force Coqlib.coq_not_ref),[glob_make_eq t1 t2]) (* [glob_make_or P1 P2] build the glob_constr corresponding to [P1 \/ P2] *) let glob_make_or t1 t2 = mkGApp (mkGRef(Lazy.force Coqlib.coq_or_ref),[t1;t2]) (* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding to [P1 \/ ( .... \/ Pn)] *) let rec glob_make_or_list = function | [] -> raise (Invalid_argument "mk_or") | [e] -> e | e::l -> glob_make_or e (glob_make_or_list l) let remove_name_from_mapping mapping na = match na with | Anonymous -> mapping | Name id -> Idmap.remove id mapping let change_vars = let rec change_vars mapping rt = match rt with | GRef _ -> rt | GVar(loc,id) -> let new_id = try Idmap.find id mapping with Not_found -> id in GVar(loc,new_id) | GEvar _ -> rt | GPatVar _ -> rt | GApp(loc,rt',rtl) -> GApp(loc, change_vars mapping rt', List.map (change_vars mapping) rtl ) | GLambda(loc,name,k,t,b) -> GLambda(loc, name, k, change_vars mapping t, change_vars (remove_name_from_mapping mapping name) b ) | GProd(loc,name,k,t,b) -> GProd(loc, name, k, change_vars mapping t, change_vars (remove_name_from_mapping mapping name) b ) | GLetIn(loc,name,def,b) -> GLetIn(loc, name, change_vars mapping def, change_vars (remove_name_from_mapping mapping name) b ) | GLetTuple(loc,nal,(na,rto),b,e) -> let new_mapping = List.fold_left remove_name_from_mapping mapping nal in GLetTuple(loc, nal, (na, Option.map (change_vars mapping) rto), change_vars mapping b, change_vars new_mapping e ) | GCases(loc,sty,infos,el,brl) -> GCases(loc,sty, infos, List.map (fun (e,x) -> (change_vars mapping e,x)) el, List.map (change_vars_br mapping) brl ) | GIf(loc,b,(na,e_option),lhs,rhs) -> GIf(loc, change_vars mapping b, (na,Option.map (change_vars mapping) e_option), change_vars mapping lhs, change_vars mapping rhs ) | GRec _ -> error "Local (co)fixes are not supported" | GSort _ -> rt | GHole _ -> rt | GCast(loc,b,CastConv (k,t)) -> GCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t)) | GCast(loc,b,CastCoerce) -> GCast(loc,change_vars mapping b,CastCoerce) and change_vars_br mapping ((loc,idl,patl,res) as br) = let new_mapping = List.fold_right Idmap.remove idl mapping in if idmap_is_empty new_mapping then br else (loc,idl,patl,change_vars new_mapping res) in change_vars let rec alpha_pat excluded pat = match pat with | PatVar(loc,Anonymous) -> let new_id = Indfun_common.fresh_id excluded "_x" in PatVar(loc,Name new_id),(new_id::excluded),Idmap.empty | PatVar(loc,Name id) -> if List.mem id excluded then let new_id = Namegen.next_ident_away id excluded in PatVar(loc,Name new_id),(new_id::excluded), (Idmap.add id new_id Idmap.empty) else pat,excluded,Idmap.empty | PatCstr(loc,constr,patl,na) -> let new_na,new_excluded,map = match na with | Name id when List.mem id excluded -> let new_id = Namegen.next_ident_away id excluded in Name new_id,new_id::excluded, Idmap.add id new_id Idmap.empty | _ -> na,excluded,Idmap.empty in let new_patl,new_excluded,new_map = List.fold_left (fun (patl,excluded,map) pat -> let new_pat,new_excluded,new_map = alpha_pat excluded pat in (new_pat::patl,new_excluded,Idmap.fold Idmap.add new_map map) ) ([],new_excluded,map) patl in PatCstr(loc,constr,List.rev new_patl,new_na),new_excluded,new_map let alpha_patl excluded patl = let patl,new_excluded,map = List.fold_left (fun (patl,excluded,map) pat -> let new_pat,new_excluded,new_map = alpha_pat excluded pat in new_pat::patl,new_excluded,(Idmap.fold Idmap.add new_map map) ) ([],excluded,Idmap.empty) patl in (List.rev patl,new_excluded,map) let raw_get_pattern_id pat acc = let rec get_pattern_id pat = match pat with | PatVar(loc,Anonymous) -> assert false | PatVar(loc,Name id) -> [id] | PatCstr(loc,constr,patternl,_) -> List.fold_right (fun pat idl -> let idl' = get_pattern_id pat in idl'@idl ) patternl [] in (get_pattern_id pat)@acc let get_pattern_id pat = raw_get_pattern_id pat [] let rec alpha_rt excluded rt = let new_rt = match rt with | GRef _ | GVar _ | GEvar _ | GPatVar _ -> rt | GLambda(loc,Anonymous,k,t,b) -> let new_id = Namegen.next_ident_away (id_of_string "_x") excluded in let new_excluded = new_id :: excluded in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in GLambda(loc,Name new_id,k,new_t,new_b) | GProd(loc,Anonymous,k,t,b) -> let new_t = alpha_rt excluded t in let new_b = alpha_rt excluded b in GProd(loc,Anonymous,k,new_t,new_b) | GLetIn(loc,Anonymous,t,b) -> let new_t = alpha_rt excluded t in let new_b = alpha_rt excluded b in GLetIn(loc,Anonymous,new_t,new_b) | GLambda(loc,Name id,k,t,b) -> let new_id = Namegen.next_ident_away id excluded in let t,b = if new_id = id then t,b else let replace = change_vars (Idmap.add id new_id Idmap.empty) in (t,replace b) in let new_excluded = new_id::excluded in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in GLambda(loc,Name new_id,k,new_t,new_b) | GProd(loc,Name id,k,t,b) -> let new_id = Namegen.next_ident_away id excluded in let new_excluded = new_id::excluded in let t,b = if new_id = id then t,b else let replace = change_vars (Idmap.add id new_id Idmap.empty) in (t,replace b) in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in GProd(loc,Name new_id,k,new_t,new_b) | GLetIn(loc,Name id,t,b) -> let new_id = Namegen.next_ident_away id excluded in let t,b = if new_id = id then t,b else let replace = change_vars (Idmap.add id new_id Idmap.empty) in (t,replace b) in let new_excluded = new_id::excluded in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in GLetIn(loc,Name new_id,new_t,new_b) | GLetTuple(loc,nal,(na,rto),t,b) -> let rev_new_nal,new_excluded,mapping = List.fold_left (fun (nal,excluded,mapping) na -> match na with | Anonymous -> (na::nal,excluded,mapping) | Name id -> let new_id = Namegen.next_ident_away id excluded in if new_id = id then na::nal,id::excluded,mapping else (Name new_id)::nal,id::excluded,(Idmap.add id new_id mapping) ) ([],excluded,Idmap.empty) nal in let new_nal = List.rev rev_new_nal in let new_rto,new_t,new_b = if idmap_is_empty mapping then rto,t,b else let replace = change_vars mapping in (Option.map replace rto, t,replace b) in let new_t = alpha_rt new_excluded new_t in let new_b = alpha_rt new_excluded new_b in let new_rto = Option.map (alpha_rt new_excluded) new_rto in GLetTuple(loc,new_nal,(na,new_rto),new_t,new_b) | GCases(loc,sty,infos,el,brl) -> let new_el = List.map (function (rt,i) -> alpha_rt excluded rt, i) el in GCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl) | GIf(loc,b,(na,e_o),lhs,rhs) -> GIf(loc,alpha_rt excluded b, (na,Option.map (alpha_rt excluded) e_o), alpha_rt excluded lhs, alpha_rt excluded rhs ) | GRec _ -> error "Not handled GRec" | GSort _ -> rt | GHole _ -> rt | GCast (loc,b,CastConv (k,t)) -> GCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t)) | GCast (loc,b,CastCoerce) -> GCast(loc,alpha_rt excluded b,CastCoerce) | GApp(loc,f,args) -> GApp(loc, alpha_rt excluded f, List.map (alpha_rt excluded) args ) in new_rt and alpha_br excluded (loc,ids,patl,res) = let new_patl,new_excluded,mapping = alpha_patl excluded patl in let new_ids = List.fold_right raw_get_pattern_id new_patl [] in let new_excluded = new_ids@excluded in let renamed_res = change_vars mapping res in let new_res = alpha_rt new_excluded renamed_res in (loc,new_ids,new_patl,new_res) (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) let is_free_in id = let rec is_free_in = function | GRef _ -> false | GVar(_,id') -> id_ord id' id == 0 | GEvar _ -> false | GPatVar _ -> false | GApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl) | GLambda(_,n,_,t,b) | GProd(_,n,_,t,b) | GLetIn(_,n,t,b) -> let check_in_b = match n with | Name id' -> id_ord id' id <> 0 | _ -> true in is_free_in t || (check_in_b && is_free_in b) | GCases(_,_,_,el,brl) -> (List.exists (fun (e,_) -> is_free_in e) el) || List.exists is_free_in_br brl | GLetTuple(_,nal,_,b,t) -> let check_in_nal = not (List.exists (function Name id' -> id'= id | _ -> false) nal) in is_free_in t || (check_in_nal && is_free_in b) | GIf(_,cond,_,br1,br2) -> is_free_in cond || is_free_in br1 || is_free_in br2 | GRec _ -> raise (UserError("",str "Not handled GRec")) | GSort _ -> false | GHole _ -> false | GCast (_,b,CastConv (_,t)) -> is_free_in b || is_free_in t | GCast (_,b,CastCoerce) -> is_free_in b and is_free_in_br (_,ids,_,rt) = (not (List.mem id ids)) && is_free_in rt in is_free_in let rec pattern_to_term = function | PatVar(loc,Anonymous) -> assert false | PatVar(loc,Name id) -> mkGVar id | PatCstr(loc,constr,patternl,_) -> let cst_narg = Inductiveops.mis_constructor_nargs_env (Global.env ()) constr in let implicit_args = Array.to_list (Array.init (cst_narg - List.length patternl) (fun _ -> mkGHole ()) ) in let patl_as_term = List.map pattern_to_term patternl in mkGApp(mkGRef(Libnames.ConstructRef constr), implicit_args@patl_as_term ) let replace_var_by_term x_id term = let rec replace_var_by_pattern rt = match rt with | GRef _ -> rt | GVar(_,id) when id_ord id x_id == 0 -> term | GVar _ -> rt | GEvar _ -> rt | GPatVar _ -> rt | GApp(loc,rt',rtl) -> GApp(loc, replace_var_by_pattern rt', List.map replace_var_by_pattern rtl ) | GLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt | GLambda(loc,name,k,t,b) -> GLambda(loc, name, k, replace_var_by_pattern t, replace_var_by_pattern b ) | GProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt | GProd(loc,name,k,t,b) -> GProd(loc, name, k, replace_var_by_pattern t, replace_var_by_pattern b ) | GLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt | GLetIn(loc,name,def,b) -> GLetIn(loc, name, replace_var_by_pattern def, replace_var_by_pattern b ) | GLetTuple(_,nal,_,_,_) when List.exists (function Name id -> id = x_id | _ -> false) nal -> rt | GLetTuple(loc,nal,(na,rto),def,b) -> GLetTuple(loc, nal, (na,Option.map replace_var_by_pattern rto), replace_var_by_pattern def, replace_var_by_pattern b ) | GCases(loc,sty,infos,el,brl) -> GCases(loc,sty, infos, List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, List.map replace_var_by_pattern_br brl ) | GIf(loc,b,(na,e_option),lhs,rhs) -> GIf(loc, replace_var_by_pattern b, (na,Option.map replace_var_by_pattern e_option), replace_var_by_pattern lhs, replace_var_by_pattern rhs ) | GRec _ -> raise (UserError("",str "Not handled GRec")) | GSort _ -> rt | GHole _ -> rt | GCast(loc,b,CastConv(k,t)) -> GCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t)) | GCast(loc,b,CastCoerce) -> GCast(loc,replace_var_by_pattern b,CastCoerce) and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = if List.exists (fun id -> id_ord id x_id == 0) idl then br else (loc,idl,patl,replace_var_by_pattern res) in replace_var_by_pattern (* checking unifiability of patterns *) exception NotUnifiable let rec are_unifiable_aux = function | [] -> () | eq::eqs -> match eq with | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> if constructor2 <> constructor1 then raise NotUnifiable else let eqs' = try ((List.combine cpl1 cpl2)@eqs) with e when Errors.noncritical e -> anomaly "are_unifiable_aux" in are_unifiable_aux eqs' let are_unifiable pat1 pat2 = try are_unifiable_aux [pat1,pat2]; true with NotUnifiable -> false let rec eq_cases_pattern_aux = function | [] -> () | eq::eqs -> match eq with | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> if constructor2 <> constructor1 then raise NotUnifiable else let eqs' = try ((List.combine cpl1 cpl2)@eqs) with e when Errors.noncritical e -> anomaly "eq_cases_pattern_aux" in eq_cases_pattern_aux eqs' | _ -> raise NotUnifiable let eq_cases_pattern pat1 pat2 = try eq_cases_pattern_aux [pat1,pat2]; true with NotUnifiable -> false let ids_of_pat = let rec ids_of_pat ids = function | PatVar(_,Anonymous) -> ids | PatVar(_,Name id) -> Idset.add id ids | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl in ids_of_pat Idset.empty let id_of_name = function | Names.Anonymous -> id_of_string "x" | Names.Name x -> x (* TODO: finish Rec caes *) let ids_of_glob_constr c = let rec ids_of_glob_constr acc c = let idof = id_of_name in match c with | GVar (_,id) -> id::acc | GApp (loc,g,args) -> ids_of_glob_constr [] g @ List.flatten (List.map (ids_of_glob_constr []) args) @ acc | GLambda (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc | GProd (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc | GLetIn (loc,na,b,c) -> idof na :: ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc | GCast (loc,c,CastConv(k,t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc | GCast (loc,c,CastCoerce) -> ids_of_glob_constr [] c @ acc | GIf (loc,c,(na,po),b1,b2) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] b1 @ ids_of_glob_constr [] b2 @ acc | GLetTuple (_,nal,(na,po),b,c) -> List.map idof nal @ ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc | GCases (loc,sty,rtntypopt,tml,brchl) -> List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_glob_constr [] c) brchl) | GRec _ -> failwith "Fix inside a constructor branch" | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> [] in (* build the set *) List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_glob_constr [] c) let zeta_normalize = let rec zeta_normalize_term rt = match rt with | GRef _ -> rt | GVar _ -> rt | GEvar _ -> rt | GPatVar _ -> rt | GApp(loc,rt',rtl) -> GApp(loc, zeta_normalize_term rt', List.map zeta_normalize_term rtl ) | GLambda(loc,name,k,t,b) -> GLambda(loc, name, k, zeta_normalize_term t, zeta_normalize_term b ) | GProd(loc,name,k,t,b) -> GProd(loc, name, k, zeta_normalize_term t, zeta_normalize_term b ) | GLetIn(_,Name id,def,b) -> zeta_normalize_term (replace_var_by_term id def b) | GLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b | GLetTuple(loc,nal,(na,rto),def,b) -> GLetTuple(loc, nal, (na,Option.map zeta_normalize_term rto), zeta_normalize_term def, zeta_normalize_term b ) | GCases(loc,sty,infos,el,brl) -> GCases(loc,sty, infos, List.map (fun (e,x) -> (zeta_normalize_term e,x)) el, List.map zeta_normalize_br brl ) | GIf(loc,b,(na,e_option),lhs,rhs) -> GIf(loc, zeta_normalize_term b, (na,Option.map zeta_normalize_term e_option), zeta_normalize_term lhs, zeta_normalize_term rhs ) | GRec _ -> raise (UserError("",str "Not handled GRec")) | GSort _ -> rt | GHole _ -> rt | GCast(loc,b,CastConv(k,t)) -> GCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t)) | GCast(loc,b,CastCoerce) -> GCast(loc,zeta_normalize_term b,CastCoerce) and zeta_normalize_br (loc,idl,patl,res) = (loc,idl,patl,zeta_normalize_term res) in zeta_normalize_term let expand_as = let rec add_as map pat = match pat with | PatVar _ -> map | PatCstr(_,_,patl,Name id) -> Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl) | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl in let rec expand_as map rt = match rt with | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> rt | GVar(_,id) -> begin try Idmap.find id map with Not_found -> rt end | GApp(loc,f,args) -> GApp(loc,expand_as map f,List.map (expand_as map) args) | GLambda(loc,na,k,t,b) -> GLambda(loc,na,k,expand_as map t, expand_as map b) | GProd(loc,na,k,t,b) -> GProd(loc,na,k,expand_as map t, expand_as map b) | GLetIn(loc,na,v,b) -> GLetIn(loc,na, expand_as map v,expand_as map b) | GLetTuple(loc,nal,(na,po),v,b) -> GLetTuple(loc,nal,(na,Option.map (expand_as map) po), expand_as map v, expand_as map b) | GIf(loc,e,(na,po),br1,br2) -> GIf(loc,expand_as map e,(na,Option.map (expand_as map) po), expand_as map br1, expand_as map br2) | GRec _ -> error "Not handled GRec" | GCast(loc,b,CastConv(kind,t)) -> GCast(loc,expand_as map b,CastConv(kind,expand_as map t)) | GCast(loc,b,CastCoerce) -> GCast(loc,expand_as map b,CastCoerce) | GCases(loc,sty,po,el,brl) -> GCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, List.map (expand_as_br map) brl) and expand_as_br map (loc,idl,cpl,rt) = (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt) in expand_as Idmap.empty coq-8.4pl4/plugins/funind/functional_principles_proofs.mli0000644000175000017500000000113112326224777023260 0ustar stephstephopen Names open Term val prove_princ_for_struct : bool -> int -> constant array -> constr array -> int -> Tacmach.tactic val prove_principle_for_gen : constant*constant*constant -> (* name of the function, the fonctionnal and the fixpoint equation *) constr option ref -> (* a pointer to the obligation proofs lemma *) bool -> (* is that function uses measure *) int -> (* the number of recursive argument *) types -> (* the type of the recursive argument *) constr -> (* the wf relation used to prove the function *) Tacmach.tactic (* val is_pte : rel_declaration -> bool *) coq-8.4pl4/plugins/funind/functional_principles_types.ml0000644000175000017500000005567512326224777022771 0ustar stephstephopen Printer open Util open Term open Namegen open Names open Declarations open Pp open Entries open Hiddentac open Evd open Tacmach open Proof_type open Tacticals open Tactics open Indfun_common open Functional_principles_proofs exception Toberemoved_with_rel of int*constr exception Toberemoved let pr_elim_scheme el = let env = Global.env () in let msg = str "params := " ++ Printer.pr_rel_context env el.params in let env = Environ.push_rel_context el.params env in let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in let env = Environ.push_rel_context el.predicates env in let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in let env = Environ.push_rel_context el.branches env in let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in let env = Environ.push_rel_context el.args env in msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl let observe s = if do_observe () then Pp.msgnl s let pr_elim_scheme el = let env = Global.env () in let msg = str "params := " ++ Printer.pr_rel_context env el.params in let env = Environ.push_rel_context el.params env in let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in let env = Environ.push_rel_context el.predicates env in let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in let env = Environ.push_rel_context el.branches env in let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in let env = Environ.push_rel_context el.args env in msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl let observe s = if do_observe () then Pp.msgnl s (* Transform an inductive induction principle into a functional one *) let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let princ_type_info = compute_elim_sig princ_type in let env = Global.env () in let env_with_params = Environ.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in let rec change_predicates_names (avoid:identifier list) (predicates:rel_context) : rel_context = match predicates with | [] -> [] |(Name x,v,t)::predicates -> let id = Namegen.next_ident_away x avoid in Hashtbl.add tbl id x; (Name id,v,t)::(change_predicates_names (id::avoid) predicates) | (Anonymous,_,_)::_ -> anomaly "Anonymous property binder " in let avoid = (Termops.ids_of_context env_with_params ) in let princ_type_info = { princ_type_info with predicates = change_predicates_names avoid princ_type_info.predicates } in (* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) (* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) let change_predicate_sort i (x,_,t) = let new_sort = sorts.(i) in let args,_ = decompose_prod t in let real_args = if princ_type_info.indarg_in_concl then List.tl args else args in Nameops.out_name x,None,compose_prod real_args (mkSort new_sort) in let new_predicates = list_map_i change_predicate_sort 0 princ_type_info.predicates in let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in let rel_as_kn = fst (match princ_type_info.indref with | Some (Libnames.IndRef ind) -> ind | _ -> error "Not a valid predicate" ) in let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in let is_pte = let set = List.fold_right Idset.add ptes_vars Idset.empty in fun t -> match kind_of_term t with | Var id -> Idset.mem id set | _ -> false in let pre_princ = it_mkProd_or_LetIn (it_mkProd_or_LetIn (Option.fold_right mkProd_or_LetIn princ_type_info.indarg princ_type_info.concl ) princ_type_info.args ) princ_type_info.branches in let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in let is_dom c = match kind_of_term c with | Ind((u,_)) -> u = rel_as_kn | Construct((u,_),_) -> u = rel_as_kn | _ -> false in let get_fun_num c = match kind_of_term c with | Ind(_,num) -> num | Construct((_,num),_) -> num | _ -> assert false in let dummy_var = mkVar (id_of_string "________") in let mk_replacement c i args = let res = mkApp(rel_to_fun.(i), Array.map Termops.pop (array_get_start args)) in (* observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); *) res in let rec compute_new_princ_type remove env pre_princ : types*(constr list) = let (new_princ_type,_) as res = match kind_of_term pre_princ with | Rel n -> begin try match Environ.lookup_rel n env with | _,_,t when is_dom t -> raise Toberemoved | _ -> pre_princ,[] with Not_found -> assert false end | Prod(x,t,b) -> compute_new_princ_type_for_binder remove mkProd env x t b | Lambda(x,t,b) -> compute_new_princ_type_for_binder remove mkLambda env x t b | Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved | App(f,args) when is_dom f -> let var_to_be_removed = destRel (array_last args) in let num = get_fun_num f in raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args)) | App(f,args) -> let args = if is_pte f && remove then array_get_start args else args in let new_args,binders_to_remove = Array.fold_right (compute_new_princ_type_with_acc remove env) args ([],[]) in let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in applist(new_f, new_args), list_union_eq eq_constr binders_to_remove_from_f binders_to_remove | LetIn(x,v,t,b) -> compute_new_princ_type_for_letin remove env x v t b | _ -> pre_princ,[] in (* let _ = match kind_of_term pre_princ with *) (* | Prod _ -> *) (* observe(str "compute_new_princ_type for "++ *) (* pr_lconstr_env env pre_princ ++ *) (* str" is "++ *) (* pr_lconstr_env env new_princ_type ++ fnl ()) *) (* | _ -> () in *) res and compute_new_princ_type_for_binder remove bind_fun env x t b = begin try let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in let new_x : name = get_name (Termops.ids_of_context env) x in let new_env = Environ.push_rel (x,None,t) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b then (Termops.pop new_b), filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b else ( bind_fun(new_x,new_t,new_b), list_union_eq eq_constr binders_to_remove_from_t (List.map Termops.pop binders_to_remove_from_b) ) with | Toberemoved -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in new_b, List.map Termops.pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in new_b, list_add_set_eq eq_constr (mkRel n) (List.map Termops.pop binders_to_remove_from_b) end and compute_new_princ_type_for_letin remove env x v t b = begin try let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in let new_x : name = get_name (Termops.ids_of_context env) x in let new_env = Environ.push_rel (x,Some v,t) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b then (Termops.pop new_b),filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b else ( mkLetIn(new_x,new_v,new_t,new_b), list_union_eq eq_constr (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v) (List.map Termops.pop binders_to_remove_from_b) ) with | Toberemoved -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in new_b, List.map Termops.pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in new_b, list_add_set_eq eq_constr (mkRel n) (List.map Termops.pop binders_to_remove_from_b) end and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) = let new_e,to_remove_from_e = compute_new_princ_type remove env e in new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc in (* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) let pre_res,_ = compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ in let pre_res = replace_vars (list_map_i (fun i id -> (id, mkRel i)) 1 ptes_vars) (lift (List.length ptes_vars) pre_res) in it_mkProd_or_LetIn (it_mkProd_or_LetIn pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b) new_predicates) ) princ_type_info.params let change_property_sort toSort princ princName = let princ_info = compute_elim_sig princ in let change_sort_in_predicate (x,v,t) = (x,None, let args,_ = decompose_prod t in compose_prod args (mkSort toSort) ) in let princName_as_constr = Constrintern.global_reference princName in let init = let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in mkApp(princName_as_constr, Array.init nargs (fun i -> mkRel (nargs - i ))) in it_mkLambda_or_LetIn (it_mkLambda_or_LetIn init (List.map change_sort_in_predicate princ_info.predicates) ) princ_info.params let pp_dur time time' = str (string_of_float (System.time_difference time time')) (* let qed () = save_named true *) let defined () = try Lemmas.save_named false with | UserError("extract_proof",msg) -> Util.errorlabstrm "defined" ((try str "On goal : " ++ fnl () ++ pr_open_subgoals () ++ fnl () with e when Errors.noncritical e -> mt () ) ++msg) let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook = (* First we get the type of the old graph principle *) let mutr_nparams = (compute_elim_sig old_princ_type).nparams in (* let time1 = System.get_time () in *) let new_principle_type = compute_new_princ_type_from_rel (Array.map mkConst funs) sorts old_princ_type in (* let time2 = System.get_time () in *) (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) observe (str "new_principle_type : " ++ pr_lconstr new_principle_type); let new_princ_name = next_ident_away_in_goal (id_of_string "___________princ_________") [] in begin Lemmas.start_proof new_princ_name (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) new_principle_type (hook new_principle_type) ; (* let _tim1 = System.get_time () in *) Pfedit.by (proof_tac (Array.map mkConst funs) mutr_nparams); (* let _tim2 = System.get_time () in *) (* begin *) (* let dur1 = System.time_difference tim1 tim2 in *) (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) (* end; *) get_proof_clean true end let generate_functional_principle interactive_proof old_princ_type sorts new_princ_name funs i proof_tac = try let f = funs.(i) in let type_sort = Termops.new_sort_in_family InType in let new_sorts = match sorts with | None -> Array.make (Array.length funs) (type_sort) | Some a -> a in let base_new_princ_name,new_princ_name = match new_princ_name with | Some (id) -> id,id | None -> let id_of_f = id_of_label (con_label f) in id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort) in let names = ref [new_princ_name] in let hook new_principle_type _ _ = if sorts = None then (* let id_of_f = id_of_label (con_label f) in *) let register_with_sort fam_sort = let s = Termops.new_sort_in_family fam_sort in let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in let value = change_property_sort s new_principle_type new_princ_name in (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) let ce = { const_entry_body = value; const_entry_secctx = None; const_entry_type = None; const_entry_opaque = false } in ignore( Declare.declare_constant name (Entries.DefinitionEntry ce, Decl_kinds.IsDefinition (Decl_kinds.Scheme) ) ); Flags.if_verbose (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) name; names := name :: !names in register_with_sort InProp; register_with_sort InSet in let (id,(entry,g_kind,hook)) = build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook in (* Pr 1278 : Don't forget to close the goal if an error is raised !!!! *) save false new_princ_name entry g_kind hook with e when Errors.noncritical e -> begin begin try let id = Pfedit.get_current_proof_name () in let s = string_of_id id in let n = String.length "___________princ_________" in if String.length s >= n then if String.sub s 0 n = "___________princ_________" then Pfedit.delete_current_proof () else () else () with e when Errors.noncritical e -> () end; raise (Defining_principle e) end (* defined () *) exception Not_Rec let get_funs_constant mp dp = let rec get_funs_constant const e : (Names.constant*int) array = match kind_of_term ((strip_lam e)) with | Fix((_,(na,_,_))) -> Array.mapi (fun i na -> match na with | Name id -> let const = make_con mp dp (label_of_id id) in const,i | Anonymous -> anomaly "Anonymous fix" ) na | _ -> [|const,0|] in function const -> let find_constant_body const = match body_of_constant (Global.lookup_constant const) with | Some b -> let body = force b in let body = Tacred.cbv_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) (Global.env ()) (Evd.empty) body in body | None -> error ( "Cannot define a principle over an axiom ") in let f = find_constant_body const in let l_const = get_funs_constant const f in (* We need to check that all the functions found are in the same block to prevent Reset stange thing *) let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in (* all the paremeter must be equal*) let _check_params = let first_params = List.hd l_params in List.iter (fun params -> if not (list_equal (fun (n1, c1) (n2, c2) -> n1 = n2 && eq_constr c1 c2) first_params params) then error "Not a mutal recursive block" ) l_params in (* The bodies has to be very similar *) let _check_bodies = try let extract_info is_first body = match kind_of_term body with | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) | _ -> if is_first && (List.length l_bodies = 1) then raise Not_Rec else error "Not a mutal recursive block" in let first_infos = extract_info true (List.hd l_bodies) in let check body = (* Hope this is correct *) let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) = ia1 = ia2 && na1 = na2 && array_equal eq_constr ta1 ta2 && array_equal eq_constr ca1 ca2 in if not (eq_infos first_infos (extract_info false body)) then error "Not a mutal recursive block" in List.iter check l_bodies with Not_Rec -> () in l_const exception No_graph_found exception Found_type of int let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition_entry list = let env = Global.env () and sigma = Evd.empty in let funs = List.map fst fas in let first_fun = List.hd funs in let funs_mp,funs_dp,_ = Names.repr_con first_fun in let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in let this_block_funs = Array.map fst this_block_funs_indexes in let prop_sort = InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.map (function const -> List.assoc const this_block_funs_indexes) funs in let ind_list = List.map (fun (idx) -> let ind = first_fun_kn,idx in ind,true,prop_sort ) funs_indexes in let l_schemes = List.map (Typing.type_of env sigma) (Indrec.build_mutual_induction_scheme env sigma ind_list) in let i = ref (-1) in let sorts = List.rev_map (fun (_,x) -> Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) ) fas in (* We create the first priciple by tactic *) let first_type,other_princ_types = match l_schemes with s::l_schemes -> s,l_schemes | _ -> anomaly "" in let (_,(const,_,_)) = try build_functional_principle false first_type (Array.of_list sorts) this_block_funs 0 (prove_princ_for_struct false 0 (Array.of_list funs)) (fun _ _ _ -> ()) with e when Errors.noncritical e -> begin begin try let id = Pfedit.get_current_proof_name () in let s = string_of_id id in let n = String.length "___________princ_________" in if String.length s >= n then if String.sub s 0 n = "___________princ_________" then Pfedit.delete_current_proof () else () else () with e when Errors.noncritical e -> () end; raise (Defining_principle e) end in incr i; let opacity = let finfos = find_Function_infos this_block_funs.(0) in try let equation = Option.get finfos.equation_lemma in Declarations.is_opaque (Global.lookup_constant equation) with Option.IsNone -> (* non recursive definition *) false in let const = {const with const_entry_opaque = opacity } in (* The others are just deduced *) if other_princ_types = [] then [const] else let other_fun_princ_types = let funs = Array.map mkConst this_block_funs in let sorts = Array.of_list sorts in List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types in let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in let ctxt,fix = decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*) let (idxs,_),(_,ta,_ as decl) = destFix fix in let other_result = List.map (* we can now compute the other principles *) (fun scheme_type -> incr i; observe (Printer.pr_lconstr scheme_type); let type_concl = (strip_prod_assum scheme_type) in let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in let f = fst (decompose_app applied_f) in try (* we search the number of the function in the fix block (name of the function) *) Array.iteri (fun j t -> let t = (strip_prod_assum t) in let applied_g = List.hd (List.rev (snd (decompose_app t))) in let g = fst (decompose_app applied_g) in if eq_constr f g then raise (Found_type j); observe (Printer.pr_lconstr f ++ str " <> " ++ Printer.pr_lconstr g) ) ta; (* If we reach this point, the two principle are not mutually recursive We fall back to the previous method *) let (_,(const,_,_)) = build_functional_principle false (List.nth other_princ_types (!i - 1)) (Array.of_list sorts) this_block_funs !i (prove_princ_for_struct false !i (Array.of_list funs)) (fun _ _ _ -> ()) in const with Found_type i -> let princ_body = Termops.it_mkLambda_or_LetIn (mkFix((idxs,i),decl)) ctxt in {const with Entries.const_entry_body = princ_body; Entries.const_entry_type = Some scheme_type } ) other_fun_princ_types in const::other_result let build_scheme fas = Dumpglob.pause (); let bodies_types = make_scheme (List.map (fun (_,f,sort) -> let f_as_constant = try match Nametab.global f with | Libnames.ConstRef c -> c | _ -> Util.error "Functional Scheme can only be used with functions" with Not_found -> Util.error ("Cannot find "^ Libnames.string_of_reference f) in (f_as_constant,sort) ) fas ) in List.iter2 (fun (princ_id,_,_) def_entry -> ignore (Declare.declare_constant princ_id (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem)); Flags.if_verbose (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id ) fas bodies_types; Dumpglob.continue () let build_case_scheme fa = let env = Global.env () and sigma = Evd.empty in (* let id_to_constr id = *) (* Constrintern.global_reference id *) (* in *) let funs = (fun (_,f,_) -> try Libnames.constr_of_global (Nametab.global f) with Not_found -> Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in let first_fun = destConst funs in let funs_mp,funs_dp,_ = Names.repr_con first_fun in let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in let this_block_funs = Array.map fst this_block_funs_indexes in let prop_sort = InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.assoc (destConst funs) this_block_funs_indexes in let ind_fun = let ind = first_fun_kn,funs_indexes in ind,prop_sort in let scheme_type = (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf) ind_fun) in let sorts = (fun (_,_,x) -> Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) ) fa in let princ_name = (fun (x,_,_) -> x) fa in let _ = (* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs ); *) generate_functional_principle false scheme_type (Some ([|sorts|])) (Some princ_name) this_block_funs 0 (prove_princ_for_struct false 0 [|destConst funs|]) in () coq-8.4pl4/plugins/funind/g_indfun.ml40000644000175000017500000003514712326224777017020 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c) | loc, Glob_term.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) let pr_bindings prc prlc = function | Glob_term.ImplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ Util.prlist_with_sep spc prc l | Glob_term.ExplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l | Glob_term.NoBindings -> mt () let pr_with_bindings prc prlc (c,bl) = prc c ++ hv 0 (pr_bindings prc prlc bl) let pr_fun_ind_using prc prlc _ opt_c = match opt_c with | None -> mt () | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc b) (* Duplication of printing functions because "'a with_bindings" is (internally) not uniform in 'a: indeed constr_with_bindings at the "typed" level has type "open_constr with_bindings" instead of "constr with_bindings"; hence, its printer cannot be polymorphic in (prc,prlc)... *) let pr_with_bindings_typed prc prlc (c,bl) = prc c ++ hv 0 (pr_bindings prc prlc bl) let pr_fun_ind_using_typed prc prlc _ opt_c = match opt_c with | None -> mt () | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b.Evd.it) ARGUMENT EXTEND fun_ind_using PRINTED BY pr_fun_ind_using_typed RAW_TYPED AS constr_with_bindings_opt RAW_PRINTED BY pr_fun_ind_using GLOB_TYPED AS constr_with_bindings_opt GLOB_PRINTED BY pr_fun_ind_using | [ "using" constr_with_bindings(c) ] -> [ Some c ] | [ ] -> [ None ] END TACTIC EXTEND newfuninv [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] -> [ Invfun.invfun hyp fname ] END let pr_intro_as_pat prc _ _ pat = match pat with | Some pat -> spc () ++ str "as" ++ spc () ++ pr_intro_pattern pat | None -> mt () ARGUMENT EXTEND with_names TYPED AS intro_pattern_opt PRINTED BY pr_intro_as_pat | [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] | [] ->[ None ] END TACTIC EXTEND newfunind ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> [ let c = match cl with | [] -> assert false | [c] -> c | c::cl -> applist(c,cl) in Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl ] END (***** debug only ***) TACTIC EXTEND snewfunind ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> [ let c = match cl with | [] -> assert false | [c] -> c | c::cl -> applist(c,cl) in Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl ] END let pr_constr_coma_sequence prc _ _ = Util.prlist_with_sep Util.pr_comma prc ARGUMENT EXTEND constr_coma_sequence' TYPED AS constr_list PRINTED BY pr_constr_coma_sequence | [ constr(c) "," constr_coma_sequence'(l) ] -> [ c::l ] | [ constr(c) ] -> [ [c] ] END let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc ARGUMENT EXTEND auto_using' TYPED AS constr_list PRINTED BY pr_auto_using | [ "using" constr_coma_sequence'(l) ] -> [ l ] | [ ] -> [ [] ] END module Gram = Pcoq.Gram module Vernac = Pcoq.Vernac_ module Tactic = Pcoq.Tactic module FunctionGram = struct let gec s = Gram.entry_create ("Function."^s) (* types *) let function_rec_definition_loc : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) located Gram.entry = gec "function_rec_definition_loc" end open FunctionGram GEXTEND Gram GLOBAL: function_rec_definition_loc ; function_rec_definition_loc: [ [ g = Vernac.rec_definition -> loc, g ]] ; END type 'a function_rec_definition_loc_argtype = ((Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) located, 'a) Genarg.abstract_argument_type let (wit_function_rec_definition_loc : Genarg.tlevel function_rec_definition_loc_argtype), (globwit_function_rec_definition_loc : Genarg.glevel function_rec_definition_loc_argtype), (rawwit_function_rec_definition_loc : Genarg.rlevel function_rec_definition_loc_argtype) = Genarg.create_arg None "function_rec_definition_loc" VERNAC COMMAND EXTEND Function ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] -> [ do_generate_principle false (List.map snd recsl); ] END let pr_fun_scheme_arg (princ_name,fun_name,s) = Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ Ppconstr.pr_glob_sort s VERNAC ARGUMENT EXTEND fun_scheme_arg PRINTED BY pr_fun_scheme_arg | [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] END let warning_error names e = let e = Cerrors.process_vernac_interp_error e in match e with | Building_graph e -> Pp.msg_warning (str "Cannot define graph(s) for " ++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ if do_observe () then (spc () ++ Errors.print e) else mt ()) | Defining_principle e -> Pp.msg_warning (str "Cannot define principle(s) for "++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ if do_observe () then Errors.print e else mt ()) | _ -> raise e VERNAC COMMAND EXTEND NewFunctionalScheme ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] -> [ begin try Functional_principles_types.build_scheme fas with Functional_principles_types.No_graph_found -> begin match fas with | (_,fun_name,_)::_ -> begin begin make_graph (Nametab.global fun_name) end ; try Functional_principles_types.build_scheme fas with Functional_principles_types.No_graph_found -> Util.error ("Cannot generate induction principle(s)") | e when Errors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in warning_error names e end | _ -> assert false (* we can only have non empty list *) end | e when Errors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in warning_error names e end ] END (***** debug only ***) VERNAC COMMAND EXTEND NewFunctionalCase ["Functional" "Case" fun_scheme_arg(fas) ] -> [ Functional_principles_types.build_case_scheme fas ] END (***** debug only ***) VERNAC COMMAND EXTEND GenerateGraph ["Generate" "graph" "for" reference(c)] -> [ make_graph (Nametab.global c) ] END (* FINDUCTION *) (* comment this line to see debug msgs *) let msg x = () ;; let pr_lconstr c = str "" (* uncomment this to see debugging *) let prconstr c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") let prlistconstr lc = List.iter prconstr lc let prstr s = msg(str s) let prNamedConstr s c = begin msg(str ""); msg(str(s^"==>\n ") ++ Printer.pr_lconstr c ++ str "\n<==\n"); msg(str ""); end (** Information about an occurrence of a function call (application) inside a term. *) type fapp_info = { fname: constr; (** The function applied *) largs: constr list; (** List of arguments *) free: bool; (** [true] if all arguments are debruijn free *) max_rel: int; (** max debruijn index in the funcall *) onlyvars: bool (** [true] if all arguments are variables (and not debruijn) *) } (** [constr_head_match(a b c) a] returns true, false otherwise. *) let constr_head_match u t= if isApp u then let uhd,args= destApp u in uhd=t else false (** [hdMatchSub inu t] returns the list of occurrences of [t] in [inu]. DeBruijn are not pushed, so some of them may be unbound in the result. *) let rec hdMatchSub inu (test: constr -> bool) : fapp_info list = let subres = match kind_of_term inu with | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) -> hdMatchSub tp test @ hdMatchSub (lift 1 cstr) test | Fix (_,(lna,tl,bl)) -> (* not sure Fix is correct *) Array.fold_left (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test) [] bl | _ -> (* Cofix will be wrong *) fold_constr (fun l cstr -> l @ hdMatchSub cstr test) [] inu in if not (test inu) then subres else let f,args = decompose_app inu in let freeset = Termops.free_rels inu in let max_rel = try Util.Intset.max_elt freeset with Not_found -> -1 in {fname = f; largs = args; free = Util.Intset.is_empty freeset; max_rel = max_rel; onlyvars = List.for_all isVar args } ::subres let mkEq typ c1 c2 = mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|]) let poseq_unsafe idunsafe cstr gl = let typ = Tacmach.pf_type_of gl cstr in tclTHEN (Tactics.letin_tac None (Name idunsafe) cstr None allHypsAndConcl) (tclTHENFIRST (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr)) Tactics.reflexivity) gl let poseq id cstr gl = let x = Tactics.fresh_id [] id gl in poseq_unsafe x cstr gl (* dirty? *) let list_constr_largs = ref [] let rec poseq_list_ids_rec lcstr gl = match lcstr with | [] -> tclIDTAC gl | c::lcstr' -> match kind_of_term c with | Var _ -> (list_constr_largs:=c::!list_constr_largs ; poseq_list_ids_rec lcstr' gl) | _ -> let _ = prstr "c = " in let _ = prconstr c in let _ = prstr "\n" in let typ = Tacmach.pf_type_of gl c in let cname = Namegen.id_of_name_using_hdchar (Global.env()) typ Anonymous in let x = Tactics.fresh_id [] cname gl in let _ = list_constr_largs:=mkVar x :: !list_constr_largs in let _ = prstr " list_constr_largs = " in let _ = prlistconstr !list_constr_largs in let _ = prstr "\n" in tclTHEN (poseq_unsafe x c) (poseq_list_ids_rec lcstr') gl let poseq_list_ids lcstr gl = let _ = list_constr_largs := [] in poseq_list_ids_rec lcstr gl (** [find_fapp test g] returns the list of [app_info] of all calls to functions that satisfy [test] in the conclusion of goal g. Trivial repetition (not modulo conversion) are deleted. *) let find_fapp (test:constr -> bool) g : fapp_info list = let pre_res = hdMatchSub (Tacmach.pf_concl g) test in let res = List.fold_right (fun x acc -> if List.mem x acc then acc else x::acc) pre_res [] in (prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res); res) (** [finduction id filter g] tries to apply functional induction on an occurence of function [id] in the conclusion of goal [g]. If [id]=[None] then calls to any function are selected. In any case [heuristic] is used to select the most pertinent occurrence. *) let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info list) (nexttac:Proof_type.tactic) g = let test = match oid with | Some id -> let idconstr = mkConst (const_of_id id) in (fun u -> constr_head_match u idconstr) (* select only id *) | None -> (fun u -> isApp u) in (* select calls to any function *) let info_list = find_fapp test g in let ordered_info_list = heuristic info_list in prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list); if List.length ordered_info_list = 0 then Util.error "function not found in goal\n"; let taclist: Proof_type.tactic list = List.map (fun info -> (tclTHEN (tclTHEN (poseq_list_ids info.largs) ( fun gl -> (functional_induction true (applist (info.fname, List.rev !list_constr_largs)) None None) gl)) nexttac)) ordered_info_list in (* we try each (f t u v) until one does not fail *) (* TODO: try also to mix functional schemes *) tclFIRST taclist g (** [chose_heuristic oi x] returns the heuristic for reordering (and/or forgetting some elts of) a list of occurrences of function calls infos to chose first with functional induction. *) let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list = match oi with | Some i -> (fun l -> [ List.nth l (i-1) ]) (* occurrence was given by the user *) | None -> (* Default heuristic: put first occurrences where all arguments are *bound* (meaning already introduced) variables *) let ordering x y = if x.free && x.onlyvars && y.free && y.onlyvars then 0 (* both pertinent *) else if x.free && x.onlyvars then -1 else if y.free && y.onlyvars then 1 else 0 (* both not pertinent *) in List.sort ordering TACTIC EXTEND finduction ["finduction" ident(id) natural_opt(oi)] -> [ match oi with | Some(n) when n<=0 -> Util.error "numerical argument must be > 0" | _ -> let heuristic = chose_heuristic oi in finduction (Some id) heuristic tclIDTAC ] END TACTIC EXTEND fauto [ "fauto" tactic(tac)] -> [ let heuristic = chose_heuristic None in finduction None heuristic (Tacinterp.eval_tactic tac) ] | [ "fauto" ] -> [ let heuristic = chose_heuristic None in finduction None heuristic tclIDTAC ] END TACTIC EXTEND poseq [ "poseq" ident(x) constr(c) ] -> [ poseq x c ] END VERNAC COMMAND EXTEND Showindinfo [ "showindinfo" ident(x) ] -> [ Merge.showind x ] END VERNAC COMMAND EXTEND MergeFunind [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")" "with" "(" ident(id2) ne_ident_list(cl2) ")" "using" ident(id) ] -> [ let f1 = Constrintern.interp_constr Evd.empty (Global.env()) (CRef (Libnames.Ident (Util.dummy_loc,id1))) in let f2 = Constrintern.interp_constr Evd.empty (Global.env()) (CRef (Libnames.Ident (Util.dummy_loc,id2))) in let f1type = Typing.type_of (Global.env()) Evd.empty f1 in let f2type = Typing.type_of (Global.env()) Evd.empty f2 in let ar1 = List.length (fst (decompose_prod f1type)) in let ar2 = List.length (fst (decompose_prod f2type)) in let _ = if ar1 <> List.length cl1 then Util.error ("not the right number of arguments for " ^ string_of_id id1) in let _ = if ar2 <> List.length cl2 then Util.error ("not the right number of arguments for " ^ string_of_id id2) in Merge.merge id1 id2 (Array.of_list cl1) (Array.of_list cl2) id ] END coq-8.4pl4/plugins/funind/functional_principles_proofs.ml0000644000175000017500000014324212326224777023121 0ustar stephstephopen Printer open Util open Term open Namegen open Names open Declarations open Pp open Entries open Hiddentac open Evd open Tacmach open Proof_type open Tacticals open Tactics open Indfun_common open Libnames let msgnl = Pp.msgnl let observe strm = if do_observe () then Pp.msgnl strm else () let observennl strm = if do_observe () then begin Pp.msg strm;Pp.pp_flush () end else () let do_observe_tac s tac g = try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v with reraise -> let e = Cerrors.process_vernac_interp_error reraise in let goal = try (Printer.pr_goal g) with e when Errors.noncritical e -> assert false in msgnl (str "observation "++ s++str " raised exception " ++ Errors.print e ++ str " on goal " ++ goal ); raise e;; let observe_tac_stream s tac g = if do_observe () then do_observe_tac s tac g else tac g let observe_tac s tac g = observe_tac_stream (str s) tac g (* let tclTRYD tac = *) (* if !Flags.debug || do_observe () *) (* then (fun g -> try (\* do_observe_tac "" *\)tac g with _ -> tclIDTAC g) *) (* else tac *) let list_chop ?(msg="") n l = try list_chop n l with Failure (msg') -> failwith (msg ^ msg') let make_refl_eq constructor type_of_t t = (* let refl_equal_term = Lazy.force refl_equal in *) mkApp(constructor,[|type_of_t;t|]) type pte_info = { proving_tac : (identifier list -> Tacmach.tactic); is_valid : constr -> bool } type ptes_info = pte_info Idmap.t type 'a dynamic_info = { nb_rec_hyps : int; rec_hyps : identifier list ; eq_hyps : identifier list; info : 'a } type body_info = constr dynamic_info let finish_proof dynamic_infos g = observe_tac "finish" ( h_assumption) g let refine c = Tacmach.refine_no_check c let thin l = Tacmach.thin_no_check l let cut_replacing id t tac :tactic= tclTHENS (cut t) [ tclTHEN (thin_no_check [id]) (introduction_no_check id); tac ] let intro_erasing id = tclTHEN (thin [id]) (introduction id) let rec_hyp_id = id_of_string "rec_hyp" let is_trivial_eq t = let res = try begin match kind_of_term t with | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> eq_constr t1 t2 | App(f,[|t1;a1;t2;a2|]) when eq_constr f (jmeq ()) -> eq_constr t1 t2 && eq_constr a1 a2 | _ -> false end with e when Errors.noncritical e -> false in (* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) res let rec incompatible_constructor_terms t1 t2 = let c1,arg1 = decompose_app t1 and c2,arg2 = decompose_app t2 in (not (eq_constr t1 t2)) && isConstruct c1 && isConstruct c2 && ( not (eq_constr c1 c2) || List.exists2 incompatible_constructor_terms arg1 arg2 ) let is_incompatible_eq t = let res = try match kind_of_term t with | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> incompatible_constructor_terms t1 t2 | App(f,[|u1;t1;u2;t2|]) when eq_constr f (jmeq ()) -> (eq_constr u1 u2 && incompatible_constructor_terms t1 t2) | _ -> false with e when Errors.noncritical e -> false in if res then observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t); res let change_hyp_with_using msg hyp_id t tac : tactic = fun g -> let prov_id = pf_get_new_id hyp_id g in tclTHENS ((* observe_tac msg *) (assert_by (Name prov_id) t (tclCOMPLETE tac))) [tclTHENLIST [ (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]); (* observe_tac "change_hyp_with_using rename " *) (h_rename [prov_id,hyp_id]) ]] g exception TOREMOVE let prove_trivial_eq h_id context (constructor,type_of_term,term) = let nb_intros = List.length context in tclTHENLIST [ tclDO nb_intros intro; (* introducing context *) (fun g -> let context_hyps = fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) in let context_hyps' = (mkApp(constructor,[|type_of_term;term|])):: (List.map mkVar context_hyps) in let to_refine = applist(mkVar h_id,List.rev context_hyps') in refine to_refine g ) ] let find_rectype env c = let (t, l) = decompose_app (Reduction.whd_betaiotazeta c) in match kind_of_term t with | Ind ind -> (t, l) | Construct _ -> (t,l) | _ -> raise Not_found let isAppConstruct ?(env=Global.env ()) t = try let t',l = find_rectype (Global.env ()) t in observe (str "isAppConstruct : " ++ Printer.pr_lconstr t ++ str " -> " ++ Printer.pr_lconstr (applist (t',l))); true with Not_found -> false let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) let clos_norm_flags flgs env sigma t = Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in clos_norm_flags Closure.betaiotazeta Environ.empty_env Evd.empty let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = let nochange ?t' msg = begin observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_lconstr t ); failwith "NoChange"; end in let eq_constr = Reductionops.is_conv env sigma in if not (noccurn 1 end_of_type) then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) if not (isApp t) then nochange "not an equality"; let f_eq,args = destApp t in let constructor,t1,t2,t1_typ = try if (eq_constr f_eq (Lazy.force eq)) then let t1 = (args.(1),args.(0)) and t2 = (args.(2),args.(0)) and t1_typ = args.(0) in (Lazy.force refl_equal,t1,t2,t1_typ) else if (eq_constr f_eq (jmeq ())) then (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0)) else nochange "not an equality" with e when Errors.noncritical e -> nochange "not an equality" in if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs"; let rec compute_substitution sub t1 t2 = (* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) if isRel t2 then let t2 = destRel t2 in begin try let t1' = Intmap.find t2 sub in if not (eq_constr t1 t1') then nochange "twice bound variable"; sub with Not_found -> assert (closed0 t1); Intmap.add t2 t1 sub end else if isAppConstruct t1 && isAppConstruct t2 then begin let c1,args1 = find_rectype env t1 and c2,args2 = find_rectype env t2 in if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; List.fold_left2 compute_substitution sub args1 args2 end else if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_betadeltaiota env t1) t2) "cannot solve (diff)" in let sub = compute_substitution Intmap.empty (snd t1) (snd t2) in let sub = compute_substitution sub (fst t1) (fst t2) in let end_of_type_with_pop = Termops.pop end_of_type in (*the equation will be removed *) let new_end_of_type = (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 Can be safely replaced by the next comment for Ocaml >= 3.08.4 *) let sub' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in List.fold_left (fun end_of_type (i,t) -> lift 1 (substnl [t] (i-1) end_of_type)) end_of_type_with_pop sub'' in let old_context_length = List.length context + 1 in let witness_fun = mkLetIn(Anonymous,make_refl_eq constructor t1_typ (fst t1),t, mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i))) ) in let new_type_of_hyp,ctxt_size,witness_fun = list_fold_left_i (fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) -> try let witness = Intmap.find i sub in if b' <> None then anomaly "can not redefine a rel!"; (Termops.pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun)) with Not_found -> (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) ) 1 (new_end_of_type,0,witness_fun) context in let new_type_of_hyp = Reductionops.nf_betaiota Evd.empty new_type_of_hyp in let new_ctxt,new_end_of_type = decompose_prod_n_assum ctxt_size new_type_of_hyp in let prove_new_hyp : tactic = tclTHEN (tclDO ctxt_size intro) (fun g -> let all_ids = pf_ids_of_hyps g in let new_ids,_ = list_chop ctxt_size all_ids in let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in refine to_refine g ) in let simpl_eq_tac = change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp prove_new_hyp in (* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) (* str "removing an equation " ++ fnl ()++ *) (* str "old_typ_of_hyp :=" ++ *) (* Printer.pr_lconstr_env *) (* env *) (* (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *) (* ++ fnl () ++ *) (* str "new_typ_of_hyp := "++ *) (* Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *) (* ++ str "old context := " ++ pr_rel_context env context ++ fnl () *) (* ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl () *) (* ++ str "old type := " ++ pr_lconstr end_of_type ++ fnl () *) (* ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl () *) (* ); *) new_ctxt,new_end_of_type,simpl_eq_tac let is_property ptes_info t_x full_type_of_hyp = if isApp t_x then let pte,args = destApp t_x in if isVar pte && array_for_all closed0 args then try let info = Idmap.find (destVar pte) ptes_info in info.is_valid full_type_of_hyp with Not_found -> false else false else false let isLetIn t = match kind_of_term t with | LetIn _ -> true | _ -> false let h_reduce_with_zeta = h_reduce (Glob_term.Cbv {Glob_term.all_flags with Glob_term.rDelta = false; }) let rewrite_until_var arg_num eq_ids : tactic = (* tests if the declares recursive argument is neither a Constructor nor an applied Constructor since such a form for the recursive argument will break the Guard when trying to save the Lemma. *) let test_var g = let _,args = destApp (pf_concl g) in not ((isConstruct args.(arg_num)) || isAppConstruct args.(arg_num)) in let rec do_rewrite eq_ids g = if test_var g then tclIDTAC g else match eq_ids with | [] -> anomaly "Cannot find a way to prove recursive property"; | eq_id::eq_ids -> tclTHEN (tclTRY (Equality.rewriteRL (mkVar eq_id))) (do_rewrite eq_ids) g in do_rewrite eq_ids let rec_pte_id = id_of_string "Hrec" let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = let coq_False = Coqlib.build_coq_False () in let coq_True = Coqlib.build_coq_True () in let coq_I = Coqlib.build_coq_I () in let rec scan_type context type_of_hyp : tactic = if isLetIn type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in (* length of context didn't change ? *) let new_context,new_typ_of_hyp = decompose_prod_n_assum (List.length context) reduced_type_of_hyp in tclTHENLIST [ h_reduce_with_zeta (Tacticals.onHyp hyp_id) ; scan_type new_context new_typ_of_hyp ] else if isProd type_of_hyp then begin let (x,t_x,t') = destProd type_of_hyp in let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in if is_property ptes_infos t_x actual_real_type_of_hyp then begin let pte,pte_args = (destApp t_x) in let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in let popped_t' = Termops.pop t' in let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in let prove_new_type_of_hyp = let context_length = List.length context in tclTHENLIST [ tclDO context_length intro; (fun g -> let context_hyps_ids = fst (list_chop ~msg:"rec hyp : context_hyps" context_length (pf_ids_of_hyps g)) in let rec_pte_id = pf_get_new_id rec_pte_id g in let to_refine = applist(mkVar hyp_id, List.rev_map mkVar (rec_pte_id::context_hyps_ids) ) in (* observe_tac "rec hyp " *) (tclTHENS (assert_tac (Name rec_pte_id) t_x) [ (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps); (* observe_tac "prove rec hyp" *) (refine to_refine) ]) g ) ] in tclTHENLIST [ (* observe_tac "hyp rec" *) (change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp); scan_type context popped_t' ] end else if eq_constr t_x coq_False then begin (* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) (* str " since it has False in its preconds " *) (* ); *) raise TOREMOVE; (* False -> .. useless *) end else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) else if eq_constr t_x coq_True (* Trivial => we remove this precons *) then (* observe (str "In "++Ppconstr.pr_id hyp_id++ *) (* str " removing useless precond True" *) (* ); *) let popped_t' = Termops.pop t' in let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in let prove_trivial = let nb_intro = List.length context in tclTHENLIST [ tclDO nb_intro intro; (fun g -> let context_hyps = fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g)) in let to_refine = applist (mkVar hyp_id, List.rev (coq_I::List.map mkVar context_hyps) ) in refine to_refine g ) ] in tclTHENLIST[ change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp ((* observe_tac "prove_trivial" *) prove_trivial); scan_type context popped_t' ] else if is_trivial_eq t_x then (* t_x := t = t => we remove this precond *) let popped_t' = Termops.pop t' in let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in let hd,args = destApp t_x in let get_args hd args = if eq_constr hd (Lazy.force eq) then (Lazy.force refl_equal,args.(0),args.(1)) else (jmeq_refl (),args.(0),args.(1)) in tclTHENLIST [ change_hyp_with_using "prove_trivial_eq" hyp_id real_type_of_hyp ((* observe_tac "prove_trivial_eq" *) (prove_trivial_eq hyp_id context (get_args hd args))); scan_type context popped_t' ] else begin try let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in tclTHEN tac (scan_type new_context new_t') with Failure "NoChange" -> (* Last thing todo : push the rel in the context and continue *) scan_type ((x,None,t_x)::context) t' end end else tclIDTAC in try scan_type [] (Typing.type_of env sigma (mkVar hyp_id)), [hyp_id] with TOREMOVE -> thin [hyp_id],[] let clean_goal_with_heq ptes_infos continue_tac dyn_infos = fun g -> let env = pf_env g and sigma = project g in let tac,new_hyps = List.fold_left ( fun (hyps_tac,new_hyps) hyp_id -> let hyp_tac,new_hyp = clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma in (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps ) (tclIDTAC,[]) dyn_infos.rec_hyps in let new_infos = { dyn_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps } in tclTHENLIST [ tac ; (* observe_tac "clean_hyp_with_heq continue" *) (continue_tac new_infos) ] g let heq_id = id_of_string "Heq" let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = fun g -> let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in tclTHENLIST [ (* We first introduce the variables *) tclDO nb_first_intro (intro_avoiding dyn_infos.rec_hyps); (* Then the equation itself *) intro_using heq_id; onLastHypId (fun heq_id -> tclTHENLIST [ (* Then the new hypothesis *) tclMAP introduction_no_check dyn_infos.rec_hyps; observe_tac "after_introduction" (fun g' -> (* We get infos on the equations introduced*) let new_term_value_eq = pf_type_of g' (mkVar heq_id) in (* compute the new value of the body *) let new_term_value = match kind_of_term new_term_value_eq with | App(f,[| _;_;args2 |]) -> args2 | _ -> observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++ pr_lconstr_env (pf_env g') new_term_value_eq ); anomaly "cannot compute new term value" in let fun_body = mkLambda(Anonymous, pf_type_of g' term, Termops.replace_term term (mkRel 1) dyn_infos.info ) in let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in let new_infos = {dyn_infos with info = new_body; eq_hyps = heq_id::dyn_infos.eq_hyps } in clean_goal_with_heq ptes_infos continue_tac new_infos g' )]) ] g let my_orelse tac1 tac2 g = try tac1 g with e when Errors.noncritical e -> (* observe (str "using snd tac since : " ++ Errors.print e); *) tac2 g let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id = let args = Array.of_list (List.map mkVar args_id) in let instanciate_one_hyp hid = my_orelse ( (* we instanciate the hyp if possible *) fun g -> let prov_hid = pf_get_new_id hid g in tclTHENLIST[ pose_proof (Name prov_hid) (mkApp(mkVar hid,args)); thin [hid]; h_rename [prov_hid,hid] ] g ) ( (* if not then we are in a mutual function block and this hyp is a recursive hyp on an other function. We are not supposed to use it while proving this principle so that we can trash it *) (fun g -> (* observe (str "Instanciation: removing hyp " ++ Ppconstr.pr_id hid); *) thin [hid] g ) ) in if args_id = [] then tclTHENLIST [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; do_prove hyps ] else tclTHENLIST [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; tclMAP instanciate_one_hyp hyps; (fun g -> let all_g_hyps_id = List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty in let remaining_hyps = List.filter (fun id -> Idset.mem id all_g_hyps_id) hyps in do_prove remaining_hyps g ) ] let build_proof (interactive_proof:bool) (fnames:constant list) ptes_infos dyn_infos : tactic = let rec build_proof_aux do_finalize dyn_infos : tactic = fun g -> (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) match kind_of_term dyn_infos.info with | Case(ci,ct,t,cb) -> let do_finalize_t dyn_info' = fun g -> let t = dyn_info'.info in let dyn_infos = {dyn_info' with info = mkCase(ci,ct,t,cb)} in let g_nb_prod = nb_prod (pf_concl g) in let type_of_term = pf_type_of g t in let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in tclTHENSEQ [ h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); thin dyn_infos.rec_hyps; pattern_option [(false,[1]),t] None; (fun g -> observe_tac "toto" ( tclTHENSEQ [h_simplest_case t; (fun g' -> let g'_nb_prod = nb_prod (pf_concl g') in let nb_instanciate_partial = g'_nb_prod - g_nb_prod in observe_tac "treat_new_case" (treat_new_case ptes_infos nb_instanciate_partial (build_proof do_finalize) t dyn_infos) g' ) ]) g ) ] g in build_proof do_finalize_t {dyn_infos with info = t} g | Lambda(n,t,b) -> begin match kind_of_term( pf_concl g) with | Prod _ -> tclTHEN intro (fun g' -> let (id,_,_) = pf_last_hyp g' in let new_term = pf_nf_betaiota g' (mkApp(dyn_infos.info,[|mkVar id|])) in let new_infos = {dyn_infos with info = new_term} in let do_prove new_hyps = build_proof do_finalize {new_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps } in (* observe_tac "Lambda" *) (instanciate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' (* build_proof do_finalize new_infos g' *) ) g | _ -> do_finalize dyn_infos g end | Cast(t,_,_) -> build_proof do_finalize {dyn_infos with info = t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> do_finalize dyn_infos g | App(_,_) -> let f,args = decompose_app dyn_infos.info in begin match kind_of_term f with | App _ -> assert false (* we have collected all the app in decompose_app *) | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> let new_infos = { dyn_infos with info = (f,args) } in build_proof_args do_finalize new_infos g | Const c when not (List.mem c fnames) -> let new_infos = { dyn_infos with info = (f,args) } in (* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) build_proof_args do_finalize new_infos g | Const _ -> do_finalize dyn_infos g | Lambda _ -> let new_term = Reductionops.nf_beta Evd.empty dyn_infos.info in build_proof do_finalize {dyn_infos with info = new_term} g | LetIn _ -> let new_infos = { dyn_infos with info = nf_betaiotazeta dyn_infos.info } in tclTHENLIST [tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) dyn_infos.rec_hyps; h_reduce_with_zeta Tacticals.onConcl; build_proof do_finalize new_infos ] g | Cast(b,_,_) -> build_proof do_finalize {dyn_infos with info = b } g | Case _ | Fix _ | CoFix _ -> let new_finalize dyn_infos = let new_infos = { dyn_infos with info = dyn_infos.info,args } in build_proof_args do_finalize new_infos in build_proof new_finalize {dyn_infos with info = f } g end | Fix _ | CoFix _ -> error ( "Anonymous local (co)fixpoints are not handled yet") | Prod _ -> error "Prod" | LetIn _ -> let new_infos = { dyn_infos with info = nf_betaiotazeta dyn_infos.info } in tclTHENLIST [tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) dyn_infos.rec_hyps; h_reduce_with_zeta Tacticals.onConcl; build_proof do_finalize new_infos ] g | Rel _ -> anomaly "Free var in goal conclusion !" and build_proof do_finalize dyn_infos g = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) observe_tac "build_proof" (build_proof_aux do_finalize dyn_infos) g and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic = fun g -> let (f_args',args) = dyn_infos.info in let tac : tactic = fun g -> match args with | [] -> do_finalize {dyn_infos with info = f_args'} g | arg::args -> (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) (* fnl () ++ *) (* pr_goal (Tacmach.sig_it g) *) (* ); *) let do_finalize dyn_infos = let new_arg = dyn_infos.info in (* tclTRYD *) (build_proof_args do_finalize {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} ) in build_proof do_finalize {dyn_infos with info = arg } g in (* observe_tac "build_proof_args" *) (tac ) g in let do_finish_proof dyn_infos = (* tclTRYD *) (clean_goal_with_heq ptes_infos finish_proof dyn_infos) in (* observe_tac "build_proof" *) (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) (* Proof of principles from structural functions *) let is_pte_type t = isSort ((strip_prod t)) let is_pte (_,_,t) = is_pte_type t type static_fix_info = { idx : int; name : identifier; types : types; offset : int; nb_realargs : int; body_with_param : constr; num_in_block : int } let prove_rec_hyp_for_struct fix_info = (fun eq_hyps -> tclTHEN (rewrite_until_var (fix_info.idx) eq_hyps) (fun g -> let _,pte_args = destApp (pf_concl g) in let rec_hyp_proof = mkApp(mkVar fix_info.name,array_get_start pte_args) in refine rec_hyp_proof g )) let prove_rec_hyp fix_info = { proving_tac = prove_rec_hyp_for_struct fix_info ; is_valid = fun _ -> true } exception Not_Rec let generalize_non_dep hyp g = (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) let hyps = [hyp] in let env = Global.env () in let hyp_typ = pf_type_of g (mkVar hyp) in let to_revert,_ = Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) -> if List.mem hyp hyps or List.exists (Termops.occur_var_in_decl env hyp) keep or Termops.occur_var env hyp hyp_typ or Termops.is_section_variable hyp (* should be dangerous *) then (clear,decl::keep) else (hyp::clear,keep)) ~init:([],[]) (pf_env g) in (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) tclTHEN ((* observe_tac "h_generalize" *) (h_generalize (List.map mkVar to_revert) )) ((* observe_tac "thin" *) (thin to_revert)) g let id_of_decl (na,_,_) = (Nameops.out_name na) let var_of_decl decl = mkVar (id_of_decl decl) let revert idl = tclTHEN (generalize (List.map mkVar idl)) (thin idl) let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = (* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) (* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) (* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) let f_def = Global.lookup_constant (destConst f) in let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in let f_body = force (Option.get (body_of_constant f_def)) in let params,f_body_with_params = decompose_lam_n nb_params f_body in let (_,num),(_,_,bodies) = destFix f_body_with_params in let fnames_with_params = let params = Array.init nb_params (fun i -> mkRel(nb_params - i)) in let fnames = List.rev (Array.to_list (Array.map (fun f -> mkApp(f,params)) fnames)) in fnames in (* observe (str "fnames_with_params " ++ prlist_with_sep fnl pr_lconstr fnames_with_params); *) (* observe (str "body " ++ pr_lconstr bodies.(num)); *) let f_body_with_params_and_other_fun = substl fnames_with_params bodies.(num) in (* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) let type_ctxt,type_of_f = decompose_prod_n_assum (nb_params + nb_args) (Typeops.type_of_constant_type (Global.env()) f_def.const_type) in let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in let lemma_type = it_mkProd_or_LetIn eqn type_ctxt in let f_id = id_of_label (con_label (destConst f)) in let prove_replacement = tclTHENSEQ [ tclDO (nb_params + rec_args_num + 1) intro; (* observe_tac "" *) (fun g -> let rec_id = pf_nth_hyp_id g 1 in tclTHENSEQ [(* observe_tac "generalize_non_dep in generate_equation_lemma" *) (generalize_non_dep rec_id); (* observe_tac "h_case" *) (h_case false (mkVar rec_id,Glob_term.NoBindings)); intros_reflexivity] g ) ] in Lemmas.start_proof (*i The next call to mk_equation_id is valid since we are constructing the lemma Ensures by: obvious i*) (mk_equation_id f_id) (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) lemma_type (fun _ _ -> ()); Pfedit.by (prove_replacement); Lemmas.save_named false let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = let equation_lemma = try let finfos = find_Function_infos (destConst f) in mkConst (Option.get finfos.equation_lemma) with (Not_found | Option.IsNone as e) -> let f_id = id_of_label (con_label (destConst f)) in (*i The next call to mk_equation_id is valid since we will construct the lemma Ensures by: obvious i*) let equation_lemma_id = (mk_equation_id f_id) in generate_equation_lemma all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; let _ = match e with | Option.IsNone -> let finfos = find_Function_infos (destConst f) in update_Function {finfos with equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant" ) } | _ -> () in Constrintern.construct_reference (pf_hyps g) equation_lemma_id in let nb_intro_to_do = nb_prod (pf_concl g) in tclTHEN (tclDO nb_intro_to_do intro) ( fun g' -> let just_introduced = nLastDecls nb_intro_to_do g' in let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in tclTHEN (Equality.rewriteLR equation_lemma) (revert just_introduced_id) g' ) g let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : tactic = fun g -> let princ_type = pf_concl g in let princ_info = compute_elim_sig princ_type in let fresh_id = let avoid = ref (pf_ids_of_hyps g) in (fun na -> let new_id = match na with Name id -> fresh_id !avoid (string_of_id id) | Anonymous -> fresh_id !avoid "H" in avoid := new_id :: !avoid; (Name new_id) ) in let fresh_decl = (fun (na,b,t) -> (fresh_id na,b,t) ) in let princ_info : elim_scheme = { princ_info with params = List.map fresh_decl princ_info.params; predicates = List.map fresh_decl princ_info.predicates; branches = List.map fresh_decl princ_info.branches; args = List.map fresh_decl princ_info.args } in let get_body const = match body_of_constant (Global.lookup_constant const) with | Some b -> let body = force b in Tacred.cbv_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) (Global.env ()) (Evd.empty) body | None -> error ( "Cannot define a principle over an axiom ") in let fbody = get_body fnames.(fun_num) in let f_ctxt,f_body = decompose_lam fbody in let f_ctxt_length = List.length f_ctxt in let diff_params = princ_info.nparams - f_ctxt_length in let full_params,princ_params,fbody_with_full_params = if diff_params > 0 then let princ_params,full_params = list_chop diff_params princ_info.params in (full_params, (* real params *) princ_params, (* the params of the principle which are not params of the function *) substl (* function instanciated with real params *) (List.map var_of_decl full_params) f_body ) else let f_ctxt_other,f_ctxt_params = list_chop (- diff_params) f_ctxt in let f_body = compose_lam f_ctxt_other f_body in (princ_info.params, (* real params *) [],(* all params are full params *) substl (* function instanciated with real params *) (List.map var_of_decl princ_info.params) f_body ) in (* observe (str "full_params := " ++ *) (* prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) *) (* full_params *) (* ); *) (* observe (str "princ_params := " ++ *) (* prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) *) (* princ_params *) (* ); *) (* observe (str "fbody_with_full_params := " ++ *) (* pr_lconstr fbody_with_full_params *) (* ); *) let all_funs_with_full_params = Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs in let fix_offset = List.length princ_params in let ptes_to_fix,infos = match kind_of_term fbody_with_full_params with | Fix((idxs,i),(names,typess,bodies)) -> let bodies_with_all_params = Array.map (fun body -> Reductionops.nf_betaiota Evd.empty (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, List.rev_map var_of_decl princ_params)) ) bodies in let info_array = Array.mapi (fun i types -> let types = prod_applist types (List.rev_map var_of_decl princ_params) in { idx = idxs.(i) - fix_offset; name = Nameops.out_name (fresh_id names.(i)); types = types; offset = fix_offset; nb_realargs = List.length (fst (decompose_lam bodies.(i))) - fix_offset; body_with_param = bodies_with_all_params.(i); num_in_block = i } ) typess in let pte_to_fix,rev_info = list_fold_left_i (fun i (acc_map,acc_info) (pte,_,_) -> let infos = info_array.(i) in let type_args,_ = decompose_prod infos.types in let nargs = List.length type_args in let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in let app_f = mkApp(f,first_args) in let pte_args = (Array.to_list first_args)@[app_f] in let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in let body_with_param,num = let body = get_body fnames.(i) in let body_with_full_params = Reductionops.nf_betaiota Evd.empty ( applist(body,List.rev_map var_of_decl full_params)) in match kind_of_term body_with_full_params with | Fix((_,num),(_,_,bs)) -> Reductionops.nf_betaiota Evd.empty ( (applist (substl (List.rev (Array.to_list all_funs_with_full_params)) bs.(num), List.rev_map var_of_decl princ_params)) ),num | _ -> error "Not a mutual block" in let info = {infos with types = compose_prod type_args app_pte; body_with_param = body_with_param; num_in_block = num } in (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++ *) (* str " to " ++ Ppconstr.pr_id info.name); *) (Idmap.add (Nameops.out_name pte) info acc_map,info::acc_info) ) 0 (Idmap.empty,[]) (List.rev princ_info.predicates) in pte_to_fix,List.rev rev_info | _ -> Idmap.empty,[] in let mk_fixes : tactic = let pre_info,infos = list_chop fun_num infos in match pre_info,infos with | [],[] -> tclIDTAC | _, this_fix_info::others_infos -> let other_fix_infos = List.map (fun fi -> fi.name,fi.idx + 1 ,fi.types) (pre_info@others_infos) in if other_fix_infos = [] then (* observe_tac ("h_fix") *) (h_fix (Some this_fix_info.name) (this_fix_info.idx +1)) else h_mutual_fix false this_fix_info.name (this_fix_info.idx + 1) other_fix_infos | _ -> anomaly "Not a valid information" in let first_tac : tactic = (* every operations until fix creations *) tclTHENSEQ [ (* observe_tac "introducing params" *) (intros_using (List.rev_map id_of_decl princ_info.params)); (* observe_tac "introducing predictes" *) (intros_using (List.rev_map id_of_decl princ_info.predicates)); (* observe_tac "introducing branches" *) (intros_using (List.rev_map id_of_decl princ_info.branches)); (* observe_tac "building fixes" *) mk_fixes; ] in let intros_after_fixes : tactic = fun gl -> let ctxt,pte_app = (decompose_prod_assum (pf_concl gl)) in let pte,pte_args = (decompose_app pte_app) in try let pte = try destVar pte with e when Errors.noncritical e -> anomaly "Property is not a variable" in let fix_info = Idmap.find pte ptes_to_fix in let nb_args = fix_info.nb_realargs in tclTHENSEQ [ (* observe_tac ("introducing args") *) (tclDO nb_args intro); (fun g -> (* replacement of the function by its body *) let args = nLastDecls nb_args g in let fix_body = fix_info.body_with_param in (* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) let args_id = List.map (fun (id,_,_) -> id) args in let dyn_infos = { nb_rec_hyps = -100; rec_hyps = []; info = Reductionops.nf_betaiota Evd.empty (applist(fix_body,List.rev_map mkVar args_id)); eq_hyps = [] } in tclTHENSEQ [ (* observe_tac "do_replace" *) (do_replace full_params (fix_info.idx + List.length princ_params) (args_id@(List.map (fun (id,_,_) -> Nameops.out_name id ) princ_params)) (all_funs.(fix_info.num_in_block)) fix_info.num_in_block all_funs ); (* observe_tac "do_replace" *) (* (do_replace princ_info.params fix_info.idx args_id *) (* (List.hd (List.rev pte_args)) fix_body); *) let do_prove = build_proof interactive_proof (Array.to_list fnames) (Idmap.map prove_rec_hyp ptes_to_fix) in let prove_tac branches = let dyn_infos = {dyn_infos with rec_hyps = branches; nb_rec_hyps = List.length branches } in observe_tac "cleaning" (clean_goal_with_heq (Idmap.map prove_rec_hyp ptes_to_fix) do_prove dyn_infos) in (* observe (str "branches := " ++ *) (* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) (* ); *) (* observe_tac "instancing" *) (instanciate_hyps_with_args prove_tac (List.rev_map id_of_decl princ_info.branches) (List.rev args_id)) ] g ); ] gl with Not_found -> let nb_args = min (princ_info.nargs) (List.length ctxt) in tclTHENSEQ [ tclDO nb_args intro; (fun g -> (* replacement of the function by its body *) let args = nLastDecls nb_args g in let args_id = List.map (fun (id,_,_) -> id) args in let dyn_infos = { nb_rec_hyps = -100; rec_hyps = []; info = Reductionops.nf_betaiota Evd.empty (applist(fbody_with_full_params, (List.rev_map var_of_decl princ_params)@ (List.rev_map mkVar args_id) )); eq_hyps = [] } in let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in tclTHENSEQ [unfold_in_concl [(Termops.all_occurrences, Names.EvalConstRef fname)]; let do_prove = build_proof interactive_proof (Array.to_list fnames) (Idmap.map prove_rec_hyp ptes_to_fix) in let prove_tac branches = let dyn_infos = {dyn_infos with rec_hyps = branches; nb_rec_hyps = List.length branches } in clean_goal_with_heq (Idmap.map prove_rec_hyp ptes_to_fix) do_prove dyn_infos in instanciate_hyps_with_args prove_tac (List.rev_map id_of_decl princ_info.branches) (List.rev args_id) ] g ) ] gl in tclTHEN first_tac intros_after_fixes g (* Proof of principles of general functions *) let h_id = Recdef.h_id and hrec_id = Recdef.hrec_id and acc_inv_id = Recdef.acc_inv_id and ltof_ref = Recdef.ltof_ref and acc_rel = Recdef.acc_rel and well_founded = Recdef.well_founded and h_intros = Recdef.h_intros and list_rewrite = Recdef.list_rewrite and evaluable_of_global_reference = Recdef.evaluable_of_global_reference let prove_with_tcc tcc_lemma_constr eqs : tactic = match !tcc_lemma_constr with | None -> anomaly "No tcc proof !!" | Some lemma -> fun gls -> (* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) (* let ids = hid::pf_ids_of_hyps gls in *) tclTHENSEQ [ (* generalize [lemma]; *) (* h_intro hid; *) (* Elim.h_decompose_and (mkVar hid); *) tclTRY(list_rewrite true eqs); (* (fun g -> *) (* let ids' = pf_ids_of_hyps g in *) (* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) (* rewrite *) (* ) *) Eauto.gen_eauto (false,5) [] (Some []) ] gls let backtrack_eqs_until_hrec hrec eqs : tactic = fun gls -> let eqs = List.map mkVar eqs in let rewrite = tclFIRST (List.map Equality.rewriteRL eqs ) in let _,hrec_concl = decompose_prod (pf_type_of gls (mkVar hrec)) in let f_app = array_last (snd (destApp hrec_concl)) in let f = (fst (destApp f_app)) in let rec backtrack : tactic = fun g -> let f_app = array_last (snd (destApp (pf_concl g))) in match kind_of_term f_app with | App(f',_) when eq_constr f' f -> tclIDTAC g | _ -> tclTHEN rewrite backtrack g in backtrack gls let build_clause eqs = { Tacexpr.onhyps = Some (List.map (fun id -> (Glob_term.all_occurrences_expr, id), Termops.InHyp) eqs ); Tacexpr.concl_occs = Glob_term.no_occurrences_expr } let rec rewrite_eqs_in_eqs eqs = match eqs with | [] -> tclIDTAC | eq::eqs -> tclTHEN (tclMAP (fun id gl -> observe_tac (Format.sprintf "rewrite %s in %s " (string_of_id eq) (string_of_id id)) (tclTRY (Equality.general_rewrite_in true Termops.all_occurrences true (* dep proofs also: *) true id (mkVar eq) false)) gl ) eqs ) (rewrite_eqs_in_eqs eqs) let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = fun gls -> (tclTHENSEQ [ backtrack_eqs_until_hrec hrec eqs; (* observe_tac ("new_prove_with_tcc ( applying "^(string_of_id hrec)^" )" ) *) (tclTHENS (* We must have exactly ONE subgoal !*) (apply (mkVar hrec)) [ tclTHENSEQ [ keep (tcc_hyps@eqs); apply (Lazy.force acc_inv); (fun g -> if is_mes then unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g else tclIDTAC g ); observe_tac "rew_and_finish" (tclTHENLIST [tclTRY(Recdef.list_rewrite false (List.map mkVar eqs)); observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs); (observe_tac "finishing using" ( tclCOMPLETE( Eauto.eauto_with_bases (true,5) [Evd.empty,Lazy.force refl_equal] [Auto.Hint_db.empty empty_transparent_state false] ) ) ) ] ) ] ]) ]) gls let is_valid_hypothesis predicates_name = let predicates_name = List.fold_right Idset.add predicates_name Idset.empty in let is_pte typ = if isApp typ then let pte,_ = destApp typ in if isVar pte then Idset.mem (destVar pte) predicates_name else false else false in let rec is_valid_hypothesis typ = is_pte typ || match kind_of_term typ with | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' | _ -> false in is_valid_hypothesis let prove_principle_for_gen (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation gl = let princ_type = pf_concl gl in let princ_info = compute_elim_sig princ_type in let fresh_id = let avoid = ref (pf_ids_of_hyps gl) in fun na -> let new_id = match na with | Name id -> fresh_id !avoid (string_of_id id) | Anonymous -> fresh_id !avoid "H" in avoid := new_id :: !avoid; Name new_id in let fresh_decl (na,b,t) = (fresh_id na,b,t) in let princ_info : elim_scheme = { princ_info with params = List.map fresh_decl princ_info.params; predicates = List.map fresh_decl princ_info.predicates; branches = List.map fresh_decl princ_info.branches; args = List.map fresh_decl princ_info.args } in let wf_tac = if is_mes then (fun b -> Recdef.tclUSER_if_not_mes tclIDTAC b None) else fun _ -> prove_with_tcc tcc_lemma_ref [] in let real_rec_arg_num = rec_arg_num - princ_info.nparams in let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in (* observe ( *) (* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) (* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) (* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) (* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) (* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) (* str "npost_rec_arg := " ++ int npost_rec_arg ); *) let (post_rec_arg,pre_rec_arg) = Util.list_chop npost_rec_arg princ_info.args in let rec_arg_id = match List.rev post_rec_arg with | (Name id,_,_)::_ -> id | _ -> assert false in (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in let relation = substl subst_constrs relation in let input_type = substl subst_constrs rec_arg_type in let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in let acc_rec_arg_id = Nameops.out_name (fresh_id (Name (id_of_string ("Acc_"^(string_of_id rec_arg_id))))) in let revert l = tclTHEN (h_generalize (List.map mkVar l)) (clear l) in let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in let prove_rec_arg_acc g = ((* observe_tac "prove_rec_arg_acc" *) (tclCOMPLETE (tclTHEN (assert_by (Name wf_thm_id) (mkApp (delayed_force well_founded,[|input_type;relation|])) (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)) ( (* observe_tac *) (* "apply wf_thm" *) h_simplest_apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|])) ) ) ) ) g in let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in let lemma = match !tcc_lemma_ref with | None -> anomaly ( "No tcc proof !!") | Some lemma -> lemma in (* let rec list_diff del_list check_list = *) (* match del_list with *) (* [] -> *) (* [] *) (* | f::r -> *) (* if List.mem f check_list then *) (* list_diff r check_list *) (* else *) (* f::(list_diff r check_list) *) (* in *) let tcc_list = ref [] in let start_tac gls = let hyps = pf_ids_of_hyps gls in let hid = next_ident_away_in_goal (id_of_string "prov") hyps in tclTHENSEQ [ generalize [lemma]; h_intro hid; Elim.h_decompose_and (mkVar hid); (fun g -> let new_hyps = pf_ids_of_hyps g in tcc_list := List.rev (list_subtract new_hyps (hid::hyps)); if !tcc_list = [] then begin tcc_list := [hid]; tclIDTAC g end else thin [hid] g ) ] gls in tclTHENSEQ [ observe_tac "start_tac" start_tac; h_intros (List.rev_map (fun (na,_,_) -> Nameops.out_name na) (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) ); (* observe_tac "" *) (assert_by (Name acc_rec_arg_id) (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) (prove_rec_arg_acc) ); (* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *) (* str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *) (* observe_tac "h_fix " *) (h_fix (Some fix_id) (List.length args_ids + 1)); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_type_of g (mkVar fix_id) )); tclIDTAC g); *) h_intros (List.rev (acc_rec_arg_id::args_ids)); Equality.rewriteLR (mkConst eq_ref); (* observe_tac "finish" *) (fun gl' -> let body = let _,args = destApp (pf_concl gl') in array_last args in let body_info rec_hyps = { nb_rec_hyps = List.length rec_hyps; rec_hyps = rec_hyps; eq_hyps = []; info = body } in let acc_inv = lazy ( mkApp ( delayed_force acc_inv_id, [|input_type;relation;mkVar rec_arg_id|] ) ) in let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in let predicates_names = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.predicates in let pte_info = { proving_tac = (fun eqs -> (* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) (* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.args)); *) (* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.params)); *) (* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) (* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) (* observe_tac "new_prove_with_tcc" *) (new_prove_with_tcc is_mes acc_inv fix_id (!tcc_list@(List.map (fun (na,_,_) -> (Nameops.out_name na)) (princ_info.args@princ_info.params) )@ ([acc_rec_arg_id])) eqs ) ); is_valid = is_valid_hypothesis predicates_names } in let ptes_info : pte_info Idmap.t = List.fold_left (fun map pte_id -> Idmap.add pte_id pte_info map ) Idmap.empty predicates_names in let make_proof rec_hyps = build_proof false [f_ref] ptes_info (body_info rec_hyps) in (* observe_tac "instanciate_hyps_with_args" *) (instanciate_hyps_with_args make_proof (List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.branches) (List.rev args_ids) ) gl' ) ] gl coq-8.4pl4/plugins/funind/recdef.ml0000644000175000017500000014041612326224777016367 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* next_global_ident_away id (acc@ids)::acc) idl [] let pf_get_new_id id g = List.hd (pf_get_new_ids [id] g) let h_intros l = tclMAP h_intro l let debug_queue = Stack.create () let rec print_debug_queue b e = if not (Stack.is_empty debug_queue) then begin let lmsg,goal = Stack.pop debug_queue in if b then msgnl (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal) else begin msgnl (str " from " ++ lmsg ++ str " on goal " ++ goal); end; print_debug_queue false e; end let do_observe_tac s tac g = let goal = Printer.pr_goal g in let lmsg = (str "recdef : ") ++ (str s) in Stack.push (lmsg,goal) debug_queue; try let v = tac g in ignore(Stack.pop debug_queue); v with reraise -> if not (Stack.is_empty debug_queue) then print_debug_queue true reraise; raise reraise let observe_tac s tac g = if Tacinterp.get_debug () <> Tactic_debug.DebugOff then do_observe_tac s tac g else tac g let hyp_ids = List.map id_of_string ["x";"v";"k";"def";"p";"h";"n";"h'"; "anonymous"; "teq"; "rec_res"; "hspec";"heq"; "hrec"; "hex"; "teq"; "pmax";"hle"];; let rec nthtl = function l, 0 -> l | _::tl, n -> nthtl (tl, n-1) | [], _ -> [];; let hyp_id n l = List.nth l n;; let (x_id:identifier) = hyp_id 0 hyp_ids;; let (v_id:identifier) = hyp_id 1 hyp_ids;; let (k_id:identifier) = hyp_id 2 hyp_ids;; let (def_id:identifier) = hyp_id 3 hyp_ids;; let (p_id:identifier) = hyp_id 4 hyp_ids;; let (h_id:identifier) = hyp_id 5 hyp_ids;; let (n_id:identifier) = hyp_id 6 hyp_ids;; let (h'_id:identifier) = hyp_id 7 hyp_ids;; let (ano_id:identifier) = hyp_id 8 hyp_ids;; let (rec_res_id:identifier) = hyp_id 10 hyp_ids;; let (hspec_id:identifier) = hyp_id 11 hyp_ids;; let (heq_id:identifier) = hyp_id 12 hyp_ids;; let (hrec_id:identifier) = hyp_id 13 hyp_ids;; let (hex_id:identifier) = hyp_id 14 hyp_ids;; let (teq_id:identifier) = hyp_id 15 hyp_ids;; let (pmax_id:identifier) = hyp_id 16 hyp_ids;; let (hle_id:identifier) = hyp_id 17 hyp_ids;; let message s = if Flags.is_verbose () then msgnl(str s);; let def_of_const t = match (kind_of_term t) with Const sp -> (try (match body_of_constant (Global.lookup_constant sp) with | Some c -> Declarations.force c | _ -> assert false) with e when Errors.noncritical e -> anomaly ("Cannot find definition of constant "^ (string_of_id (id_of_label (con_label sp)))) ) |_ -> assert false let type_of_const t = match (kind_of_term t) with Const sp -> Typeops.type_of_constant (Global.env()) sp |_ -> assert false let arg_type t = match kind_of_term (def_of_const t) with Lambda(a,b,c) -> b | _ -> assert false;; let evaluable_of_global_reference r = match r with ConstRef sp -> EvalConstRef sp | VarRef id -> EvalVarRef id | _ -> assert false;; let rank_for_arg_list h = let predicate a b = try List.for_all2 eq_constr a b with Invalid_argument _ -> false in let rec rank_aux i = function | [] -> None | x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in rank_aux 0;; let rec check_not_nested f t = match kind_of_term t with | App(g, _) when eq_constr f g -> errorlabstrm "recdef" (str "Nested recursive function are not allowed with Function") | Var(_) when eq_constr t f -> errorlabstrm "recdef" (str "Nested recursive function are not allowed with Function") | _ -> iter_constr (check_not_nested f) t let rec (find_call_occs : int -> int -> constr -> constr -> (constr list -> constr) * constr list list) = fun nb_arg nb_lam f expr -> match (kind_of_term expr) with App (g, args) when eq_constr g f -> if Array.length args <> nb_arg then errorlabstrm "recdef" (str "Partial application of function " ++ Printer.pr_lconstr expr ++ str " in its body is not allowed while using Function"); Array.iter (check_not_nested f) args; (fun l -> List.hd l), [Array.to_list args] | App (g, args) -> let (largs: constr list) = Array.to_list args in let rec find_aux = function [] -> (fun x -> []), [] | a::upper_tl -> (match find_aux upper_tl with (cf, ((arg1::args) as args_for_upper_tl)) -> (match find_call_occs nb_arg nb_lam f a with cf2, (_ :: _ as other_args) -> let rec avoid_duplicates args = match args with | [] -> (fun _ -> []), [] | h::tl -> let recomb_tl, args_for_tl = avoid_duplicates tl in match rank_for_arg_list h args_for_upper_tl with | None -> (fun l -> List.hd l::recomb_tl(List.tl l)), h::args_for_tl | Some i -> (fun l -> List.nth l (i+List.length args_for_tl):: recomb_tl l), args_for_tl in let recombine, other_args' = avoid_duplicates other_args in let len1 = List.length other_args' in (fun l -> cf2 (recombine l)::cf(nthtl(l,len1))), other_args'@args_for_upper_tl | _, [] -> (fun x -> a::cf x), args_for_upper_tl) | _, [] -> (match find_call_occs nb_arg nb_lam f a with cf, (arg1::args) -> (fun l -> cf l::upper_tl), (arg1::args) | _, [] -> (fun x -> a::upper_tl), [])) in begin match (find_aux largs) with cf, [] -> (fun l -> mkApp(g, args)), [] | cf, args -> (fun l -> mkApp (g, Array.of_list (cf l))), args end | Rel(v) -> if v > nb_lam then error "find_call_occs : Rel" else ((fun l -> expr),[]) | Var(_) when eq_constr expr f -> errorlabstrm "recdef" (str "Partial application of function " ++ Printer.pr_lconstr expr ++ str " in its body is not allowed while using Function") | Var(id) -> (fun l -> expr), [] | Meta(_) -> error "Found a metavariable. Can not treat such a term" | Evar(_) -> error "Found an evar. Can not treat such a term" | Sort(_) -> (fun l -> expr), [] | Cast(b,_,_) -> find_call_occs nb_arg nb_lam f b | Prod(na,t,b) -> error "Found a product. Can not treat such a term" | Lambda(na,t,b) -> begin match find_call_occs nb_arg (succ nb_lam) f b with | _, [] -> (* Lambda are authorized as long as they do not contain recursives calls *) (fun l -> expr),[] | _ -> error "Found a lambda which body contains a recursive call. Such terms are not allowed" end | LetIn(na,v,t,b) -> begin match find_call_occs nb_arg nb_lam f v, find_call_occs nb_arg (succ nb_lam) f b with | (_,[]),(_,[]) -> ((fun l -> expr), []) | (_,[]),(cf,(_::_ as l)) -> ((fun l -> mkLetIn(na,v,t,cf l)),l) | (cf,(_::_ as l)),(_,[]) -> ((fun l -> mkLetIn(na,cf l,t,b)), l) | _ -> error "Found a letin with recursive calls in both variable value and body. Such terms are not allowed." end | Const(_) -> (fun l -> expr), [] | Ind(_) -> (fun l -> expr), [] | Construct (_, _) -> (fun l -> expr), [] | Case(i,t,a,r) -> (match find_call_occs nb_arg nb_lam f a with cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args) | _ -> (fun l -> expr),[]) | Fix(_) -> error "Found a local fixpoint. Can not treat such a term" | CoFix(_) -> error "Found a local cofixpoint : CoFix";; let coq_constant s = Coqlib.gen_constant_in_modules "RecursiveDefinition" (Coqlib.init_modules @ Coqlib.arith_modules) s;; let coq_base_constant s = Coqlib.gen_constant_in_modules "RecursiveDefinition" (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s;; let constant sl s = constr_of_global (locate (make_qualid(Names.make_dirpath (List.map id_of_string (List.rev sl))) (id_of_string s)));; let find_reference sl s = (locate (make_qualid(Names.make_dirpath (List.map id_of_string (List.rev sl))) (id_of_string s)));; let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS") let le_lt_n_Sm = function () -> (coq_base_constant "le_lt_n_Sm") let le_trans = function () -> (coq_base_constant "le_trans") let le_lt_trans = function () -> (coq_base_constant "le_lt_trans") let lt_S_n = function () -> (coq_base_constant "lt_S_n") let le_n = function () -> (coq_base_constant "le_n") let refl_equal = function () -> (coq_base_constant "eq_refl") let eq = function () -> (coq_base_constant "eq") let ex = function () -> (coq_base_constant "ex") let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig") let coq_sig = function () -> (coq_base_constant "sig") let coq_O = function () -> (coq_base_constant "O") let coq_S = function () -> (coq_base_constant "S") let gt_antirefl = function () -> (coq_constant "gt_irrefl") let lt_n_O = function () -> (coq_base_constant "lt_n_O") let lt_n_Sn = function () -> (coq_base_constant "lt_n_Sn") let f_equal = function () -> (coq_constant "f_equal") let well_founded_induction = function () -> (coq_constant "well_founded_induction") let well_founded = function () -> (coq_constant "well_founded") let acc_rel = function () -> (coq_constant "Acc") let acc_inv_id = function () -> (coq_constant "Acc_inv") let well_founded_ltof = function () -> (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof") let iter_ref = function () -> (try find_reference ["Recdef"] "iter" with Not_found -> error "module Recdef not loaded") let max_ref = function () -> (find_reference ["Recdef"] "max") let iter = function () -> (constr_of_global (delayed_force iter_ref)) let max_constr = function () -> (constr_of_global (delayed_force max_ref)) let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") let coq_conj = function () -> find_reference ["Coq";"Init";"Logic"] "conj" (* These are specific to experiments in nat with lt as well_founded_relation, *) (* but this should be made more general. *) let nat = function () -> (coq_base_constant "nat") let lt = function () -> (coq_base_constant "lt") (* This is simply an implementation of the case_eq tactic. this code should be replaced with the tactic defined in Ltac in Init/Tactics.v *) let mkCaseEq a : tactic = (fun g -> let type_of_a = pf_type_of g a in tclTHENLIST [h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]; (fun g2 -> change_in_concl None (pattern_occs [((false,[1]), a)] (pf_env g2) Evd.empty (pf_concl g2)) g2); simplest_case a] g);; (* This is like the previous one except that it also rewrite on all hypotheses except the ones given in the first argument. All the modified hypotheses are generalized in the process and should be introduced back later; the result is the pair of the tactic and the list of hypotheses that have been generalized and cleared. *) let mkDestructEq : identifier list -> constr -> goal sigma -> tactic * identifier list = fun not_on_hyp expr g -> let hyps = pf_hyps g in let to_revert = Util.map_succeed (fun (id,_,t) -> if List.mem id not_on_hyp || not (Termops.occur_term expr t) then failwith "is_expr_context"; id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in let type_of_expr = pf_type_of g expr in let new_hyps = mkApp(delayed_force refl_equal, [|type_of_expr; expr|]):: to_revert_constr in tclTHENLIST [h_generalize new_hyps; (fun g2 -> change_in_concl None (pattern_occs [((false,[1]), expr)] (pf_env g2) Evd.empty (pf_concl g2)) g2); simplest_case expr], to_revert let rec mk_intros_and_continue thin_intros (extra_eqn:bool) cont_function (eqs:constr list) nb_lam (expr:constr) g = observe_tac "mk_intros_and_continue" ( let finalize () = if extra_eqn then let teq = pf_get_new_id teq_id g in tclTHENLIST [ h_intro teq; thin thin_intros; h_intros thin_intros; tclMAP (fun eq -> tclTRY (Equality.general_rewrite_in true Termops.all_occurrences true (* deps proofs also: *) true teq eq false)) (List.rev eqs); (fun g1 -> let ty_teq = pf_type_of g1 (mkVar teq) in let teq_lhs,teq_rhs = let _,args = try destApp ty_teq with e when Errors.noncritical e -> Pp.msgnl (Printer.pr_goal g1 ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in args.(1),args.(2) in cont_function (mkVar teq::eqs) (Termops.replace_term teq_lhs teq_rhs expr) g1 ) ] else tclTHENSEQ[ thin thin_intros; h_intros thin_intros; cont_function eqs expr ] in if nb_lam = 0 then finalize () else match kind_of_term expr with | Lambda (n, _, b) -> let n1 = match n with Name x -> x | Anonymous -> ano_id in let new_n = pf_get_new_id n1 g in tclTHEN (h_intro new_n) (mk_intros_and_continue thin_intros extra_eqn cont_function eqs (pred nb_lam) (subst1 (mkVar new_n) b)) | _ -> assert false) g (* finalize () *) let const_of_ref = function ConstRef kn -> kn | _ -> anomaly "ConstRef expected" let simpl_iter clause = reduce (Lazy {rBeta=true;rIota=true;rZeta= true; rDelta=false; rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]}) (* (Simpl (Some ([],mkConst (const_of_ref (delayed_force iter_ref))))) *) clause (* The boolean value is_mes expresses that the termination is expressed using a measure function instead of a well-founded relation. *) let tclUSER tac is_mes l g = let clear_tac = match l with | None -> h_clear true [] | Some l -> tclMAP (fun id -> tclTRY (h_clear false [id])) (List.rev l) in tclTHENSEQ [ clear_tac; if is_mes then tclTHEN (unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))]) tac else tac ] g let list_rewrite (rev:bool) (eqs: constr list) = tclREPEAT (List.fold_right (fun eq i -> tclORELSE (rewriteLR eq) i) (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));; let base_leaf_terminate (func:global_reference) eqs expr = (* let _ = msgnl (str "entering base_leaf") in *) (fun g -> let k',h = match pf_get_new_ids [k_id;h_id] g with [k';h] -> k',h | _ -> assert false in tclTHENLIST [observe_tac "first split" (split (ImplicitBindings [expr])); observe_tac "second split" (split (ImplicitBindings [delayed_force coq_O])); observe_tac "intro k" (h_intro k'); observe_tac "case on k" (tclTHENS (simplest_case (mkVar k')) [(tclTHEN (h_intro h) (tclTHEN (simplest_elim (mkApp (delayed_force gt_antirefl, [| delayed_force coq_O |]))) default_auto)); tclIDTAC ]); intros; simpl_iter onConcl; unfold_constr func; list_rewrite true eqs; default_auto] g);; (* La fonction est donnee en premier argument a la fonctionnelle suivie d'autres Lambdas et de Case ... Pour recuperer la fonction f a partir de la fonctionnelle *) let get_f foncl = match (kind_of_term (def_of_const foncl)) with Lambda (Name f, _, _) -> f |_ -> error "la fonctionnelle est mal definie";; let rec compute_le_proofs = function [] -> assumption | a::tl -> tclORELSE assumption (tclTHENS (fun g -> let le_trans = delayed_force le_trans in let t_le_trans = compute_renamed_type g le_trans in let m_id = let _,_,t = destProd t_le_trans in let na,_,_ = destProd t in Nameops.out_name na in apply_with_bindings (le_trans, ExplicitBindings[dummy_loc,NamedHyp m_id,a]) g) [compute_le_proofs tl; tclORELSE (apply (delayed_force le_n)) assumption]) let make_lt_proof pmax le_proof = tclTHENS (fun g -> let le_lt_trans = delayed_force le_lt_trans in let t_le_lt_trans = compute_renamed_type g le_lt_trans in let m_id = let _,_,t = destProd t_le_lt_trans in let na,_,_ = destProd t in Nameops.out_name na in apply_with_bindings (le_lt_trans, ExplicitBindings[dummy_loc,NamedHyp m_id, pmax]) g) [observe_tac "compute_le_proofs" (compute_le_proofs le_proof); tclTHENLIST[observe_tac "lt_S_n" (apply (delayed_force lt_S_n)); default_full_auto]];; let rec list_cond_rewrite k def pmax cond_eqs le_proofs = match cond_eqs with [] -> tclIDTAC | eq::eqs -> (fun g -> let t_eq = compute_renamed_type g (mkVar eq) in let k_id,def_id = let k_na,_,t = destProd t_eq in let _,_,t = destProd t in let def_na,_,_ = destProd t in Nameops.out_name k_na,Nameops.out_name def_na in tclTHENS (general_rewrite_bindings false Termops.all_occurrences (* dep proofs also: *) true true (mkVar eq, ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k; dummy_loc, NamedHyp def_id, mkVar def]) false) [list_cond_rewrite k def pmax eqs le_proofs; observe_tac "make_lt_proof" (make_lt_proof pmax le_proofs)] g ) let rec introduce_all_equalities func eqs values specs bound le_proofs cond_eqs = match specs with [] -> fun g -> let ids = pf_ids_of_hyps g in let s_max = mkApp(delayed_force coq_S, [|bound|]) in let k = next_ident_away_in_goal k_id ids in let ids = k::ids in let h' = next_ident_away_in_goal (h'_id) ids in let ids = h'::ids in let def = next_ident_away_in_goal def_id ids in tclTHENLIST [observe_tac "introduce_all_equalities_final split" (split (ImplicitBindings [s_max])); observe_tac "introduce_all_equalities_final intro k" (h_intro k); tclTHENS (observe_tac "introduce_all_equalities_final case k" (simplest_case (mkVar k))) [ tclTHENLIST[h_intro h'; simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|])); default_full_auto]; tclIDTAC ]; observe_tac "clearing k " (clear [k]); observe_tac "intros k h' def" (h_intros [k;h';def]); observe_tac "simple_iter" (simpl_iter onConcl); observe_tac "unfold functional" (unfold_in_concl[((true,[1]),evaluable_of_global_reference func)]); observe_tac "rewriting equations" (list_rewrite true eqs); observe_tac ("cond rewrite "^(string_of_id k)) (list_cond_rewrite k def bound cond_eqs le_proofs); observe_tac "refl equal" (apply (delayed_force refl_equal))] g | spec1::specs -> fun g -> let ids = Termops.ids_of_named_context (pf_hyps g) in let p = next_ident_away_in_goal p_id ids in let ids = p::ids in let pmax = next_ident_away_in_goal pmax_id ids in let ids = pmax::ids in let hle1 = next_ident_away_in_goal hle_id ids in let ids = hle1::ids in let hle2 = next_ident_away_in_goal hle_id ids in let ids = hle2::ids in let heq = next_ident_away_in_goal heq_id ids in tclTHENLIST [simplest_elim (mkVar spec1); list_rewrite true eqs; h_intros [p; heq]; simplest_elim (mkApp(delayed_force max_constr, [| bound; mkVar p|])); h_intros [pmax; hle1; hle2]; introduce_all_equalities func eqs values specs (mkVar pmax) ((mkVar pmax)::le_proofs) (heq::cond_eqs)] g;; let string_match s = if String.length s < 3 then failwith "string_match"; try for i = 0 to 3 do if String.get s i <> String.get "Acc_" i then failwith "string_match" done; with Invalid_argument _ -> failwith "string_match" let retrieve_acc_var g = (* Julien: I don't like this version .... *) let hyps = pf_ids_of_hyps g in map_succeed (fun id -> string_match (string_of_id id);id) hyps let rec introduce_all_values concl_tac is_mes acc_inv func context_fn eqs hrec args values specs = (match args with [] -> tclTHENLIST [observe_tac "split" (split(ImplicitBindings [context_fn (List.map mkVar (List.rev values))])); observe_tac "introduce_all_equalities" (introduce_all_equalities func eqs (List.rev values) (List.rev specs) (delayed_force coq_O) [] [])] | arg::args -> (fun g -> let ids = Termops.ids_of_named_context (pf_hyps g) in let rec_res = next_ident_away_in_goal rec_res_id ids in let ids = rec_res::ids in let hspec = next_ident_away_in_goal hspec_id ids in let tac = observe_tac "introduce_all_values" ( introduce_all_values concl_tac is_mes acc_inv func context_fn eqs hrec args (rec_res::values)(hspec::specs)) in (tclTHENS (observe_tac "elim h_rec" (simplest_elim (mkApp(mkVar hrec, Array.of_list arg))) ) [tclTHENLIST [h_intros [rec_res; hspec]; tac]; (tclTHENS (observe_tac "acc_inv" (apply (Lazy.force acc_inv))) [(* tclTHEN (tclTRY(list_rewrite true eqs)) *) (observe_tac "h_assumption" h_assumption) ; tclTHENLIST [ tclTRY(list_rewrite true eqs); observe_tac "user proof" (fun g -> tclUSER concl_tac is_mes (Some (hrec::hspec::(retrieve_acc_var g)@specs)) g ) ] ] ) ]) g) ) let rec_leaf_terminate nb_arg f_constr concl_tac is_mes acc_inv hrec (func:global_reference) eqs expr = match find_call_occs nb_arg 0 f_constr expr with | context_fn, args -> observe_tac "introduce_all_values" (introduce_all_values concl_tac is_mes acc_inv func context_fn eqs hrec args [] []) let proveterminate nb_arg rec_arg_id is_mes acc_inv (hrec:identifier) (f_constr:constr) (func:global_reference) base_leaf rec_leaf = let rec proveterminate (eqs:constr list) (expr:constr) = try (* let _ = msgnl (str "entering proveterminate") in *) let v = match (kind_of_term expr) with Case (ci, t, a, l) -> (match find_call_occs nb_arg 0 f_constr a with _,[] -> (fun g -> let destruct_tac, rev_to_thin_intro = mkDestructEq rec_arg_id a g in tclTHENS destruct_tac (list_map_i (fun i -> mk_intros_and_continue (List.rev rev_to_thin_intro) true proveterminate eqs ci.ci_cstr_ndecls.(i)) 0 (Array.to_list l)) g) | _, _::_ -> (match find_call_occs nb_arg 0 f_constr expr with _,[] -> observe_tac "base_leaf" (base_leaf func eqs expr) | _, _:: _ -> observe_tac "rec_leaf" (rec_leaf is_mes acc_inv hrec func eqs expr))) | _ -> (match find_call_occs nb_arg 0 f_constr expr with _,[] -> (try observe_tac "base_leaf" (base_leaf func eqs expr) with reraise -> (msgerrnl (str "failure in base case");raise reraise )) | _, _::_ -> observe_tac "rec_leaf" (rec_leaf is_mes acc_inv hrec func eqs expr)) in v with reraise -> begin msgerrnl(str "failure in proveterminate"); raise reraise end in proveterminate let hyp_terminates nb_args func = let a_arrow_b = arg_type (constr_of_global func) in let rev_args,b = decompose_prod_n nb_args a_arrow_b in let left = mkApp(delayed_force iter, Array.of_list (lift 5 a_arrow_b:: mkRel 3:: constr_of_global func::mkRel 1:: List.rev (list_map_i (fun i _ -> mkRel (6+i)) 0 rev_args) ) ) in let right = mkRel 5 in let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in let result = (mkProd ((Name def_id) , lift 4 a_arrow_b, equality)) in let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in let nb_iter = mkApp(delayed_force ex, [|delayed_force nat; (mkLambda (Name p_id, delayed_force nat, (mkProd (Name k_id, delayed_force nat, mkArrow cond result))))|])in let value = mkApp(delayed_force coq_sig, [|b; (mkLambda (Name v_id, b, nb_iter))|]) in compose_prod rev_args value let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = if is_mes then tclCOMPLETE (h_simplest_apply (delayed_force well_founded_ltof)) else tclUSER concl_tac is_mes names_to_suppress let termination_proof_header is_mes input_type ids args_id relation rec_arg_num rec_arg_id tac wf_tac : tactic = begin fun g -> let nargs = List.length args_id in let pre_rec_args = List.rev_map mkVar (fst (list_chop (rec_arg_num - 1) args_id)) in let relation = substl pre_rec_args relation in let input_type = substl pre_rec_args input_type in let wf_thm = next_ident_away_in_goal (id_of_string ("wf_R")) ids in let wf_rec_arg = next_ident_away_in_goal (id_of_string ("Acc_"^(string_of_id rec_arg_id))) (wf_thm::ids) in let hrec = next_ident_away_in_goal hrec_id (wf_rec_arg::wf_thm::ids) in let acc_inv = lazy ( mkApp ( delayed_force acc_inv_id, [|input_type;relation;mkVar rec_arg_id|] ) ) in tclTHEN (h_intros args_id) (tclTHENS (observe_tac "first assert" (assert_tac (Name wf_rec_arg) (mkApp (delayed_force acc_rel, [|input_type;relation;mkVar rec_arg_id|]) ) ) ) [ (* accesibility proof *) tclTHENS (observe_tac "second assert" (assert_tac (Name wf_thm) (mkApp (delayed_force well_founded,[|input_type;relation|])) ) ) [ (* interactive proof that the relation is well_founded *) observe_tac "wf_tac" (wf_tac is_mes (Some args_id)); (* this gives the accessibility argument *) observe_tac "apply wf_thm" (h_simplest_apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|])) ) ] ; (* rest of the proof *) tclTHENSEQ [observe_tac "generalize" (onNLastHypsId (nargs+1) (tclMAP (fun id -> tclTHEN (h_generalize [mkVar id]) (h_clear false [id])) )) ; observe_tac "h_fix" (h_fix (Some hrec) (nargs+1)); h_intros args_id; h_intro wf_rec_arg; observe_tac "tac" (tac wf_rec_arg hrec acc_inv) ] ] ) g end let rec instantiate_lambda t l = match l with | [] -> t | a::l -> let (bound_name, _, body) = destLambda t in instantiate_lambda (subst1 a body) l ;; let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num : tactic = begin fun g -> let ids = Termops.ids_of_named_context (pf_hyps g) in let func_body = (def_of_const (constr_of_global func)) in let (f_name, _, body1) = destLambda func_body in let f_id = match f_name with | Name f_id -> next_ident_away_in_goal f_id ids | Anonymous -> anomaly "Anonymous function" in let n_names_types,_ = decompose_lam_n nb_args body1 in let n_ids,ids = List.fold_left (fun (n_ids,ids) (n_name,_) -> match n_name with | Name id -> let n_id = next_ident_away_in_goal id ids in n_id::n_ids,n_id::ids | _ -> anomaly "anonymous argument" ) ([],(f_id::ids)) n_names_types in let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in termination_proof_header is_mes input_type ids n_ids relation rec_arg_num rec_arg_id (fun rec_arg_id hrec acc_inv g -> (proveterminate nb_args [rec_arg_id] is_mes acc_inv hrec (mkVar f_id) func base_leaf_terminate (rec_leaf_terminate nb_args (mkVar f_id) concl_tac) [] expr ) g ) (tclUSER_if_not_mes concl_tac) g end let get_current_subgoals_types () = let p = Proof_global.give_me_the_proof () in let { Evd.it=sgs ; sigma=sigma } = Proof.V82.subgoals p in List.map (Goal.V82.abstract_type sigma) sgs let build_and_l l = let and_constr = Coqlib.build_coq_and () in let conj_constr = coq_conj () in let mk_and p1 p2 = Term.mkApp(and_constr,[|p1;p2|]) in let rec is_well_founded t = match kind_of_term t with | Prod(_,_,t') -> is_well_founded t' | App(_,_) -> let (f,_) = decompose_app t in eq_constr f (well_founded ()) | _ -> false in let compare t1 t2 = let b1,b2= is_well_founded t1,is_well_founded t2 in if (b1&&b2) || not (b1 || b2) then 0 else if b1 && not b2 then 1 else -1 in let l = List.sort compare l in let rec f = function | [] -> failwith "empty list of subgoals!" | [p] -> p,tclIDTAC,1 | p1::pl -> let c,tac,nb = f pl in mk_and p1 c, tclTHENS (apply (constr_of_global conj_constr)) [tclIDTAC; tac ],nb+1 in f l let is_rec_res id = let rec_res_name = string_of_id rec_res_id in let id_name = string_of_id id in try String.sub id_name 0 (String.length rec_res_name) = rec_res_name with e when Errors.noncritical e -> false let clear_goals = let rec clear_goal t = match kind_of_term t with | Prod(Name id as na,t',b) -> let b' = clear_goal b in if noccurn 1 b' && (is_rec_res id) then Termops.pop b' else if b' == b then t else mkProd(na,t',b') | _ -> map_constr clear_goal t in List.map clear_goal let build_new_goal_type () = let sub_gls_types = get_current_subgoals_types () in (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let sub_gls_types = clear_goals sub_gls_types in (* Pp.msgnl (str "sub_gls_types2 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let res = build_and_l sub_gls_types in res let is_opaque_constant c = let cb = Global.lookup_constant c in match cb.Declarations.const_body with | Declarations.OpaqueDef _ -> true | Declarations.Undef _ -> true | Declarations.Def _ -> false let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) let current_proof_name = get_current_proof_name () in let name = match goal_name with | Some s -> s | None -> try (add_suffix current_proof_name "_subproof") with e when Errors.noncritical e -> anomaly "open_new_goal with an unamed theorem" in let sign = initialize_named_context_for_proof () in let na = next_global_ident_away name [] in if Termops.occur_existential gls_type then Util.error "\"abstract\" cannot handle existentials"; let hook _ _ = let opacity = let na_ref = Libnames.Ident (dummy_loc,na) in let na_global = Nametab.global na_ref in match na_global with ConstRef c -> is_opaque_constant c | _ -> anomaly "equation_lemma: not a constant" in let lemma = mkConst (Lib.make_con na) in ref_ := Some lemma ; let lid = ref [] in let h_num = ref (-1) in Flags.silently Vernacentries.interp (Vernacexpr.VernacAbort None); build_proof ( fun gls -> let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in tclTHENSEQ [ h_generalize [lemma]; h_intro hid; (fun g -> let ids = pf_ids_of_hyps g in tclTHEN (Elim.h_decompose_and (mkVar hid)) (fun g -> let ids' = pf_ids_of_hyps g in lid := List.rev (list_subtract ids' ids); if !lid = [] then lid := [hid]; tclIDTAC g ) g ); ] gls) (fun g -> match kind_of_term (pf_concl g) with | App(f,_) when eq_constr f (well_founded ()) -> Auto.h_auto None [] (Some []) g | _ -> incr h_num; (observe_tac "finishing using" ( tclCOMPLETE( tclFIRST[ tclTHEN (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)) e_assumption; Eauto.eauto_with_bases (true,5) [Evd.empty,delayed_force refl_equal] [Auto.Hint_db.empty empty_transparent_state false] ] ) ) ) g) ; Lemmas.save_named opacity; in start_proof na (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma) sign gls_type hook ; if Indfun_common.is_strict_tcc () then by (tclIDTAC) else begin by ( fun g -> tclTHEN (decompose_and_tac) (tclORELSE (tclFIRST (List.map (fun c -> tclTHENSEQ [intros; h_simplest_apply (interp_constr Evd.empty (Global.env()) c); tclCOMPLETE Auto.default_auto ] ) using_lemmas) ) tclIDTAC) g) end; try by tclIDTAC; (* raises UserError _ if the proof is complete *) if Flags.is_verbose () then (pp (Printer.pr_open_subgoals())) with UserError _ -> defined () ;; let com_terminate tcc_lemma_name tcc_lemma_ref is_mes fonctional_ref input_type relation rec_arg_num thm_name using_lemmas nb_args hook = let start_proof (tac_start:tactic) (tac_end:tactic) = let (evmap, env) = Lemmas.get_current_context() in start_proof thm_name (Global, Proof Lemma) (Environ.named_context_val env) (hyp_terminates nb_args fonctional_ref) hook; by (observe_tac "starting_tac" tac_start); by (observe_tac "whole_start" (whole_start tac_end nb_args is_mes fonctional_ref input_type relation rec_arg_num )) in start_proof tclIDTAC tclIDTAC; try let new_goal_type = build_new_goal_type () in open_new_goal start_proof using_lemmas tcc_lemma_ref (Some tcc_lemma_name) (new_goal_type); with Failure "empty list of subgoals!" -> (* a non recursive function declared with measure ! *) defined () let ind_of_ref = function | IndRef (ind,i) -> (ind,i) | _ -> anomaly "IndRef expected" let (value_f:constr list -> global_reference -> constr) = fun al fterm -> let d0 = dummy_loc in let rev_x_id_l = ( List.fold_left (fun x_id_l _ -> let x_id = next_ident_away_in_goal x_id x_id_l in x_id::x_id_l ) [] al ) in let context = List.map (fun (x, c) -> Name x, None, c) (List.combine rev_x_id_l (List.rev al)) in let env = Environ.push_rel_context context (Global.env ()) in let glob_body = GCases (d0,RegularStyle,None, [GApp(d0, GRef(d0,fterm), List.rev_map (fun x_id -> GVar(d0, x_id)) rev_x_id_l), (Anonymous,None)], [d0, [v_id], [PatCstr(d0,(ind_of_ref (delayed_force coq_sig_ref),1), [PatVar(d0, Name v_id); PatVar(d0, Anonymous)], Anonymous)], GVar(d0,v_id)]) in let body = understand Evd.empty env glob_body in it_mkLambda_or_LetIn body context let (declare_fun : identifier -> logical_kind -> constr -> global_reference) = fun f_id kind value -> let ce = {const_entry_body = value; const_entry_secctx = None; const_entry_type = None; const_entry_opaque = false } in ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; let (declare_f : identifier -> logical_kind -> constr list -> global_reference -> global_reference) = fun f_id kind input_type fterm_ref -> declare_fun f_id kind (value_f input_type fterm_ref);; let rec n_x_id ids n = if n = 0 then [] else let x = next_ident_away_in_goal x_id ids in x::n_x_id (x::ids) (n-1);; let start_equation (f:global_reference) (term_f:global_reference) (cont_tactic:identifier list -> tactic) g = let ids = pf_ids_of_hyps g in let terminate_constr = constr_of_global term_f in let nargs = nb_prod (type_of_const terminate_constr) in let x = n_x_id ids nargs in tclTHENLIST [ h_intros x; unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference f)]; observe_tac "simplest_case" (simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x)))); observe_tac "prove_eq" (cont_tactic x)] g;; let base_leaf_eq func eqs f_id g = let ids = pf_ids_of_hyps g in let k = next_ident_away_in_goal k_id ids in let p = next_ident_away_in_goal p_id (k::ids) in let v = next_ident_away_in_goal v_id (p::k::ids) in let heq = next_ident_away_in_goal heq_id (v::p::k::ids) in let heq1 = next_ident_away_in_goal heq_id (heq::v::p::k::ids) in let hex = next_ident_away_in_goal hex_id (heq1::heq::v::p::k::ids) in tclTHENLIST [ h_intros [v; hex]; simplest_elim (mkVar hex); h_intros [p;heq1]; tclTRY (rewriteRL (mkApp(mkVar heq1, [|mkApp (delayed_force coq_S, [|mkVar p|]); mkApp(delayed_force lt_n_Sn, [|mkVar p|]); f_id|]))); simpl_iter onConcl; tclTRY (unfold_in_concl [((true,[1]), evaluable_of_global_reference func)]); observe_tac "list_revrite" (list_rewrite true eqs); apply (delayed_force refl_equal)] g;; let f_S t = mkApp(delayed_force coq_S, [|t|]);; let rec introduce_all_values_eq cont_tac functional termine f p heq1 pmax bounds le_proofs eqs ids = function [] -> let heq2 = next_ident_away_in_goal heq_id ids in tclTHENLIST [pose_proof (Name heq2) (mkApp(mkVar heq1, [|f_S(f_S(mkVar pmax))|])); simpl_iter (onHyp heq2); unfold_in_hyp [((true,[1]), evaluable_of_global_reference (global_of_constr functional))] (heq2, Termops.InHyp); tclTHENS (fun gls -> let t_eq = compute_renamed_type gls (mkVar heq2) in let def_id = let _,_,t = destProd t_eq in let def_na,_,_ = destProd t in Nameops.out_name def_na in observe_tac "rewrite heq" (general_rewrite_bindings false Termops.all_occurrences true (* dep proofs also: *) true (mkVar heq2, ExplicitBindings[dummy_loc,NamedHyp def_id, f]) false) gls) [tclTHENLIST [observe_tac "list_rewrite" (list_rewrite true eqs); cont_tac pmax le_proofs]; tclTHENLIST[apply (delayed_force le_lt_SS); compute_le_proofs le_proofs]]] | arg::args -> let v' = next_ident_away_in_goal v_id ids in let ids = v'::ids in let hex' = next_ident_away_in_goal hex_id ids in let ids = hex'::ids in let p' = next_ident_away_in_goal p_id ids in let ids = p'::ids in let new_pmax = next_ident_away_in_goal pmax_id ids in let ids = pmax::ids in let hle1 = next_ident_away_in_goal hle_id ids in let ids = hle1::ids in let hle2 = next_ident_away_in_goal hle_id ids in let ids = hle2::ids in let heq = next_ident_away_in_goal heq_id ids in let ids = heq::ids in let heq2 = next_ident_away_in_goal heq_id ids in let ids = heq2::ids in tclTHENLIST [mkCaseEq(mkApp(termine, Array.of_list arg)); h_intros [v'; hex']; simplest_elim(mkVar hex'); h_intros [p']; simplest_elim(mkApp(delayed_force max_constr, [|mkVar pmax; mkVar p'|])); h_intros [new_pmax;hle1;hle2]; introduce_all_values_eq (fun pmax' le_proofs'-> tclTHENLIST [cont_tac pmax' le_proofs'; h_intros [heq;heq2]; observe_tac ("rewriteRL " ^ (string_of_id heq2)) (tclTRY (rewriteLR (mkVar heq2))); tclTRY (tclTHENS ( fun g -> let t_eq = compute_renamed_type g (mkVar heq) in let k_id,def_id = let k_na,_,t = destProd t_eq in let _,_,t = destProd t in let def_na,_,_ = destProd t in Nameops.out_name k_na,Nameops.out_name def_na in let c_b = (mkVar heq, ExplicitBindings [dummy_loc, NamedHyp k_id, f_S(mkVar pmax'); dummy_loc, NamedHyp def_id, f]) in observe_tac "general_rewrite_bindings" ( (general_rewrite_bindings false Termops.all_occurrences true (* dep proofs also: *) true c_b false)) g ) [tclIDTAC; tclTHENLIST [apply (delayed_force le_lt_n_Sm); compute_le_proofs le_proofs']])]) functional termine f p heq1 new_pmax (p'::bounds)((mkVar pmax)::le_proofs) eqs (heq2::heq::hle2::hle1::new_pmax::p'::hex'::v'::ids) args] let rec_leaf_eq termine f ids functional eqs expr fn args = let p = next_ident_away_in_goal p_id ids in let ids = p::ids in let v = next_ident_away_in_goal v_id ids in let ids = v::ids in let hex = next_ident_away_in_goal hex_id ids in let ids = hex::ids in let heq1 = next_ident_away_in_goal heq_id ids in let ids = heq1::ids in let hle1 = next_ident_away_in_goal hle_id ids in let ids = hle1::ids in tclTHENLIST [observe_tac "intros v hex" (h_intros [v;hex]); simplest_elim (mkVar hex); h_intros [p;heq1]; h_generalize [mkApp(delayed_force le_n,[|mkVar p|])]; h_intros [hle1]; observe_tac "introduce_all_values_eq" (introduce_all_values_eq (fun _ _ -> tclIDTAC) functional termine f p heq1 p [] [] eqs ids args); observe_tac "failing here" (apply (delayed_force refl_equal))] let rec prove_eq nb_arg (termine:constr) (f:constr)(functional:global_reference) (eqs:constr list) (expr:constr) = (* tclTRY *) observe_tac "prove_eq" (match kind_of_term expr with Case(ci,t,a,l) -> (match find_call_occs nb_arg 0 f a with _,[] -> (fun g -> let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in tclTHENS destruct_tac (list_map_i (fun i -> mk_intros_and_continue (List.rev rev_to_thin_intro) true (prove_eq nb_arg termine f functional) eqs ci.ci_cstr_ndecls.(i)) 0 (Array.to_list l)) g) | _,_::_ -> (match find_call_occs nb_arg 0 f expr with _,[] -> observe_tac "base_leaf_eq(1)" (base_leaf_eq functional eqs f) | fn,args -> fun g -> let ids = Termops.ids_of_named_context (pf_hyps g) in observe_tac "rec_leaf_eq" (rec_leaf_eq termine f ids (constr_of_global functional) eqs expr fn args) g)) | _ -> (match find_call_occs nb_arg 0 f expr with _,[] -> observe_tac "base_leaf_eq(2)" ( base_leaf_eq functional eqs f) | fn,args -> fun g -> let ids = Termops.ids_of_named_context (pf_hyps g) in observe_tac "rec_leaf_eq" (rec_leaf_eq termine f ids (constr_of_global functional) eqs expr fn args) g));; let (com_eqn : int -> identifier -> global_reference -> global_reference -> global_reference -> constr -> unit) = fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type -> let opacity = match terminate_ref with | ConstRef c -> is_opaque_constant c | _ -> anomaly "terminate_lemma: not a constant" in let (evmap, env) = Lemmas.get_current_context() in let f_constr = (constr_of_global f_ref) in let equation_lemma_type = subst1 f_constr equation_lemma_type in (start_proof eq_name (Global, Proof Lemma) (Environ.named_context_val env) equation_lemma_type (fun _ _ -> ()); by (start_equation f_ref terminate_ref (fun x -> prove_eq nb_arg (constr_of_global terminate_ref) f_constr functional_ref [] (instantiate_lambda (def_of_const (constr_of_global functional_ref)) (f_constr::List.map mkVar x) ) ) ); (* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *) (* Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *) Flags.silently (fun () -> Lemmas.save_named opacity) () ; (* Pp.msgnl (str "eqn finished"); *) );; let nf_zeta env = Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) env Evd.empty let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) let clos_norm_flags flgs env sigma t = Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in clos_norm_flags Closure.betaiotazeta Environ.empty_env Evd.empty let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : unit = let previous_label = Lib.current_command_label () in let function_type = interp_constr Evd.empty (Global.env()) type_of_f in let env = push_named (function_name,None,function_type) (Global.env()) in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) let equation_lemma_type = nf_betaiotazeta (interp_gen (OfType None) Evd.empty env ~impls:rec_impls eq) in (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) let res_vars,eq' = decompose_prod equation_lemma_type in let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> (x,None,y)) res_vars) env in let eq' = nf_zeta env_eq' eq' in let res = (* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) (* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *) (* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *) match kind_of_term eq' with | App(e,[|_;_;eq_fix|]) -> mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars eq_fix)) | _ -> failwith "Recursive Definition (res not eq)" in let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in let (_, rec_arg_type, _) = destProd function_type_before_rec_arg in let arg_types = List.rev_map snd (fst (decompose_prod_n (List.length res_vars) function_type)) in let equation_id = add_suffix function_name "_equation" in let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) res in let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in let relation = interp_constr Evd.empty env_with_pre_rec_args r in let tcc_lemma_name = add_suffix function_name "_tcc" in let tcc_lemma_constr = ref None in (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) let hook _ _ = let term_ref = Nametab.locate (qualid_of_ident term_id) in let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in let _ = Table.extraction_inline true [Ident (dummy_loc,term_id)] in (* message "start second proof"; *) let stop = ref false in begin try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type) with e when Errors.noncritical e -> begin if Tacinterp.get_debug () <> Tactic_debug.DebugOff then pperrnl (str "Cannot create equation Lemma " ++ Errors.print e) else anomaly "Cannot create equation Lemma" ; stop := true; end end; if not !stop then let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in let f_ref = destConst (constr_of_global f_ref) and functional_ref = destConst (constr_of_global functional_ref) and eq_ref = destConst (constr_of_global eq_ref) in generate_induction_principle f_ref tcc_lemma_constr functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation; if Flags.is_verbose () then msgnl (h 1 (Ppconstr.pr_id function_name ++ spc () ++ str"is defined" )++ fnl () ++ h 1 (Ppconstr.pr_id equation_id ++ spc () ++ str"is defined" ) ) in try com_terminate tcc_lemma_name tcc_lemma_constr is_mes functional_ref rec_arg_type relation rec_arg_num term_id using_lemmas (List.length res_vars) hook with reraise -> begin (try ignore (Backtrack.backto previous_label) with e when Errors.noncritical e -> ()); (* anomaly "Cannot create termination Lemma" *) raise reraise end coq-8.4pl4/plugins/funind/glob_termops.mli0000644000175000017500000001076212326224777020004 0ustar stephstephopen Glob_term (* Ocaml 3.06 Map.S does not handle is_empty *) val idmap_is_empty : 'a Names.Idmap.t -> bool (* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *) val get_pattern_id : cases_pattern -> Names.identifier list (* [pattern_to_term pat] returns a glob_constr corresponding to [pat]. [pat] must not contain occurences of anonymous pattern *) val pattern_to_term : cases_pattern -> glob_constr (* Some basic functions to rebuild glob_constr In each of them the location is Util.dummy_loc *) val mkGRef : Libnames.global_reference -> glob_constr val mkGVar : Names.identifier -> glob_constr val mkGApp : glob_constr*(glob_constr list) -> glob_constr val mkGLambda : Names.name * glob_constr * glob_constr -> glob_constr val mkGProd : Names.name * glob_constr * glob_constr -> glob_constr val mkGLetIn : Names.name * glob_constr * glob_constr -> glob_constr val mkGCases : glob_constr option * tomatch_tuples * cases_clauses -> glob_constr val mkGSort : glob_sort -> glob_constr val mkGHole : unit -> glob_constr (* we only build Evd.BinderType Anonymous holes *) val mkGCast : glob_constr* glob_constr -> glob_constr (* Some basic functions to decompose glob_constrs These are analogous to the ones constrs *) val glob_decompose_prod : glob_constr -> (Names.name*glob_constr) list * glob_constr val glob_decompose_prod_or_letin : glob_constr -> (Names.name*glob_constr option*glob_constr option) list * glob_constr val glob_decompose_prod_n : int -> glob_constr -> (Names.name*glob_constr) list * glob_constr val glob_decompose_prod_or_letin_n : int -> glob_constr -> (Names.name*glob_constr option*glob_constr option) list * glob_constr val glob_compose_prod : glob_constr -> (Names.name*glob_constr) list -> glob_constr val glob_compose_prod_or_letin: glob_constr -> (Names.name*glob_constr option*glob_constr option) list -> glob_constr val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list) (* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *) val glob_make_eq : ?typ:glob_constr -> glob_constr -> glob_constr -> glob_constr (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) val glob_make_neq : glob_constr -> glob_constr -> glob_constr (* [glob_make_or P1 P2] build the glob_constr corresponding to [P1 \/ P2] *) val glob_make_or : glob_constr -> glob_constr -> glob_constr (* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding to [P1 \/ ( .... \/ Pn)] *) val glob_make_or_list : glob_constr list -> glob_constr (* alpha_conversion functions *) (* Replace the var mapped in the glob_constr/context *) val change_vars : Names.identifier Names.Idmap.t -> glob_constr -> glob_constr (* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. the result does not share variables with [avoid]. This function create a fresh variable for each occurence of the anonymous pattern. Also returns a mapping from old variables to new ones and the concatenation of [avoid] with the variables appearing in the result. *) val alpha_pat : Names.Idmap.key list -> Glob_term.cases_pattern -> Glob_term.cases_pattern * Names.Idmap.key list * Names.identifier Names.Idmap.t (* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt conventions and does not share bound variables with avoid *) val alpha_rt : Names.identifier list -> glob_constr -> glob_constr (* same as alpha_rt but for case branches *) val alpha_br : Names.identifier list -> Util.loc * Names.identifier list * Glob_term.cases_pattern list * Glob_term.glob_constr -> Util.loc * Names.identifier list * Glob_term.cases_pattern list * Glob_term.glob_constr (* Reduction function *) val replace_var_by_term : Names.identifier -> Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) val is_free_in : Names.identifier -> glob_constr -> bool val are_unifiable : cases_pattern -> cases_pattern -> bool val eq_cases_pattern : cases_pattern -> cases_pattern -> bool (* ids_of_pat : cases_pattern -> Idset.t returns the set of variables appearing in a pattern *) val ids_of_pat : cases_pattern -> Names.Idset.t (* TODO: finish this function (Fix not treated) *) val ids_of_glob_constr: glob_constr -> Names.Idset.t (* removing let_in construction in a glob_constr *) val zeta_normalize : Glob_term.glob_constr -> Glob_term.glob_constr val expand_as : glob_constr -> glob_constr coq-8.4pl4/plugins/funind/recdef_plugin.mllib0000644000175000017500000000024012326224777020422 0ustar stephstephIndfun_common Glob_termops Recdef Glob_term_to_relation Functional_principles_proofs Functional_principles_types Invfun Indfun Merge G_indfun Recdef_plugin_mod coq-8.4pl4/plugins/funind/indfun.ml0000644000175000017500000007250012326224777016420 0ustar stephstephopen Util open Names open Term open Pp open Indfun_common open Libnames open Glob_term open Declarations let is_rec_info scheme_info = let test_branche min acc (_,_,br) = acc || ( let new_branche = it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum br)) in let free_rels_in_br = Termops.free_rels new_branche in let max = min + scheme_info.Tactics.npredicates in Util.Intset.exists (fun i -> i >= min && i< max) free_rels_in_br ) in Util.list_fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches) let choose_dest_or_ind scheme_info = if is_rec_info scheme_info then Tactics.new_induct false else Tactics.new_destruct false let functional_induction with_clean c princl pat = Dumpglob.pause (); let res = let f,args = decompose_app c in fun g -> let princ,bindings, princ_type = match princl with | None -> (* No principle is given let's find the good one *) begin match kind_of_term f with | Const c' -> let princ_option = let finfo = (* we first try to find out a graph on f *) try find_Function_infos c' with Not_found -> errorlabstrm "" (str "Cannot find induction information on "++ Printer.pr_lconstr (mkConst c') ) in match Tacticals.elimination_sort_of_goal g with | InProp -> finfo.prop_lemma | InSet -> finfo.rec_lemma | InType -> finfo.rect_lemma in let princ = (* then we get the principle *) try mkConst (Option.get princ_option ) with Option.IsNone -> (*i If there is not default lemma defined then, we cross our finger and try to find a lemma named f_ind (or f_rec, f_rect) i*) let princ_name = Indrec.make_elimination_ident (id_of_label (con_label c')) (Tacticals.elimination_sort_of_goal g) in try mkConst(const_of_id princ_name ) with Not_found -> (* This one is neither defined ! *) errorlabstrm "" (str "Cannot find induction principle for " ++Printer.pr_lconstr (mkConst c') ) in (princ,Glob_term.NoBindings, Tacmach.pf_type_of g princ) | _ -> raise (UserError("",str "functional induction must be used with a function" )) end | Some ((princ,binding)) -> princ,binding,Tacmach.pf_type_of g princ in let princ_infos = Tactics.compute_elim_sig princ_type in let args_as_induction_constr = let c_list = if princ_infos.Tactics.farg_in_concl then [c] else [] in List.map (fun c -> Tacexpr.ElimOnConstr (Evd.empty,(c,NoBindings))) (args@c_list) in let princ' = Some (princ,bindings) in let princ_vars = List.fold_right (fun a acc -> try Idset.add (destVar a) acc with e when Errors.noncritical e -> acc ) args Idset.empty in let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in let old_idl = Idset.diff old_idl princ_vars in let subst_and_reduce g = if with_clean then let idl = map_succeed (fun id -> if Idset.mem id old_idl then failwith "subst_and_reduce"; id ) (Tacmach.pf_ids_of_hyps g) in let flag = Glob_term.Cbv {Glob_term.all_flags with Glob_term.rDelta = false; } in Tacticals.tclTHEN (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst_gen (do_rewrite_dependent ()) [id])) idl ) (Hiddentac.h_reduce flag Tacticals.allHypsAndConcl) g else Tacticals.tclIDTAC g in Tacticals.tclTHEN (choose_dest_or_ind princ_infos args_as_induction_constr princ' (None,pat) None) subst_and_reduce g in Dumpglob.continue (); res let rec abstract_glob_constr c = function | [] -> c | Topconstr.LocalRawDef (x,b)::bl -> Topconstr.mkLetInC(x,b,abstract_glob_constr c bl) | Topconstr.LocalRawAssum (idl,k,t)::bl -> List.fold_right (fun x b -> Topconstr.mkLambdaC([x],k,t,b)) idl (abstract_glob_constr c bl) let interp_casted_constr_with_implicits sigma env impls c = Constrintern.intern_gen false sigma env ~impls ~allow_patvar:false ~ltacvars:([],[]) c (* Construct a fixpoint as a Glob_term and not as a constr *) let build_newrecursive lnameargsardef = let env0 = Global.env() and sigma = Evd.empty in let (rec_sign,rec_impls) = List.fold_left (fun (env,impls) ((_,recname),bl,arityc,_) -> let arityc = Topconstr.prod_constr_expr arityc bl in let arity = Constrintern.interp_type sigma env0 arityc in let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity [] in (Environ.push_named (recname,None,arity) env, Idmap.add recname impl impls)) (env0,Constrintern.empty_internalization_env) lnameargsardef in let recdef = (* Declare local notations *) let fs = States.freeze() in let def = try List.map (fun (_,bl,_,def) -> let def = abstract_glob_constr def bl in interp_casted_constr_with_implicits sigma rec_sign rec_impls def ) lnameargsardef with reraise -> States.unfreeze fs; raise reraise in States.unfreeze fs; def in recdef,rec_impls let build_newrecursive l = let l' = List.map (fun ((fixna,_,bll,ar,body_opt),lnot) -> match body_opt with | Some body -> (fixna,bll,ar,body) | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") ) l in build_newrecursive l' (* Checks whether or not the mutual bloc is recursive *) let rec is_rec names = let names = List.fold_right Idset.add names Idset.empty in let check_id id names = Idset.mem id names in let rec lookup names = function | GVar(_,id) -> check_id id names | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> false | GCast(_,b,_) -> lookup names b | GRec _ -> error "GRec not handled" | GIf(_,b,_,lhs,rhs) -> (lookup names b) || (lookup names lhs) || (lookup names rhs) | GLetIn(_,na,t,b) | GLambda(_,na,_,t,b) | GProd(_,na,_,t,b) -> lookup names t || lookup (Nameops.name_fold Idset.remove na names) b | GLetTuple(_,nal,_,t,b) -> lookup names t || lookup (List.fold_left (fun acc na -> Nameops.name_fold Idset.remove na acc) names nal ) b | GApp(_,f,args) -> List.exists (lookup names) (f::args) | GCases(_,_,_,el,brl) -> List.exists (fun (e,_) -> lookup names e) el || List.exists (lookup_br names) brl and lookup_br names (_,idl,_,rt) = let new_names = List.fold_right Idset.remove idl names in lookup new_names rt in lookup names let rec local_binders_length = function (* Assume that no `{ ... } contexts occur *) | [] -> 0 | Topconstr.LocalRawDef _::bl -> 1 + local_binders_length bl | Topconstr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl let prepare_body ((name,_,args,types,_),_) rt = let n = local_binders_length args in (* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_glob_constr rt); *) let fun_args,rt' = chop_rlambda_n n rt in (fun_args,rt') let derive_inversion fix_names = try (* we first transform the fix_names identifier into their corresponding constant *) let fix_names_as_constant = List.map (fun id -> destConst (Constrintern.global_reference id)) fix_names in (* Then we check that the graphs have been defined If one of the graphs haven't been defined we do nothing *) List.iter (fun c -> ignore (find_Function_infos c)) fix_names_as_constant ; try Invfun.derive_correctness Functional_principles_types.make_scheme functional_induction fix_names_as_constant (*i The next call to mk_rel_id is valid since we have just construct the graph Ensures by : register_built i*) (List.map (fun id -> destInd (Constrintern.global_reference (mk_rel_id id))) fix_names ) with e when Errors.noncritical e -> let e' = Cerrors.process_vernac_interp_error e in msg_warning (str "Cannot build inversion information" ++ if do_observe () then (fnl() ++ Errors.print e') else mt ()) with e when Errors.noncritical e -> () let warning_error names e = let e = Cerrors.process_vernac_interp_error e in let e_explain e = match e with | ToShow e -> spc () ++ Errors.print e | _ -> if do_observe () then (spc () ++ Errors.print e) else mt () in match e with | Building_graph e -> Pp.msg_warning (str "Cannot define graph(s) for " ++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ e_explain e) | Defining_principle e -> Pp.msg_warning (str "Cannot define principle(s) for "++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ e_explain e) | _ -> raise e let error_error names e = let e = Cerrors.process_vernac_interp_error e in let e_explain e = match e with | ToShow e -> spc () ++ Errors.print e | _ -> if do_observe () then (spc () ++ Errors.print e) else mt () in match e with | Building_graph e -> errorlabstrm "" (str "Cannot define graph(s) for " ++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ e_explain e) | _ -> raise e let generate_principle on_error is_general do_built (fix_rec_l:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) recdefs interactive_proof (continue_proof : int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic) : unit = let names = List.map (function ((_, name),_,_,_,_),_ -> name) fix_rec_l in let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in let funs_args = List.map fst fun_bodies in let funs_types = List.map (function ((_,_,_,types,_),_) -> types) fix_rec_l in try (* We then register the Inductive graphs of the functions *) Glob_term_to_relation.build_inductive names funs_args funs_types recdefs; if do_built then begin (*i The next call to mk_rel_id is valid since we have just construct the graph Ensures by : do_built i*) let f_R_mut = Ident (dummy_loc,mk_rel_id (List.nth names 0)) in let ind_kn = fst (locate_with_msg (pr_reference f_R_mut++str ": Not an inductive type!") locate_ind f_R_mut) in let fname_kn ((fname,_,_,_,_),_) = let f_ref = Ident fname in locate_with_msg (pr_reference f_ref++str ": Not an inductive type!") locate_constant f_ref in let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in let _ = list_map_i (fun i x -> let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in let princ_type = Typeops.type_of_constant (Global.env()) princ in Functional_principles_types.generate_functional_principle interactive_proof princ_type None None funs_kn i (continue_proof 0 [|funs_kn.(i)|]) ) 0 fix_rec_l in Array.iter (add_Function is_general) funs_kn; () end with e when Errors.noncritical e -> on_error names e let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = match fixpoint_exprl with | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in let ce,imps = Command.interp_definition bl None body (Some ret_type) in Command.declare_definition fname (Decl_kinds.Global,Decl_kinds.Definition) ce imps (fun _ _ -> ()) | _ -> Command.do_fixpoint fixpoint_exprl let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic = Functional_principles_proofs.prove_principle_for_gen (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body pre_hook = let type_of_f = Topconstr.prod_constr_expr ret_type args in let rec_arg_num = let names = List.map snd (Topconstr.names_of_local_assums args) in match wf_arg with | None -> if List.length names = 1 then 1 else error "Recursive argument must be specified" | Some wf_arg -> list_index (Name wf_arg) names in let unbounded_eq = let f_app_args = Topconstr.CAppExpl (dummy_loc, (None,(Ident (dummy_loc,fname))) , (List.map (function | _,Anonymous -> assert false | _,Name e -> (Topconstr.mkIdentC e) ) (Topconstr.names_of_local_assums args) ) ) in Topconstr.CApp (dummy_loc,(None,Topconstr.mkRefC (Qualid (dummy_loc,(qualid_of_string "Logic.eq")))), [(f_app_args,None);(body,None)]) in let eq = Topconstr.prod_constr_expr unbounded_eq args in let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation = try pre_hook (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation ); derive_inversion [fname] with e when Errors.noncritical e -> (* No proof done *) () in Recdef.recursive_definition is_mes fname rec_impls type_of_f wf_rel_expr rec_arg_num eq hook using_lemmas let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas args ret_type body = let wf_arg_type,wf_arg = match wf_arg with | None -> begin match args with | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x | _ -> error "Recursive argument must be specified" end | Some wf_args -> try match List.find (function | Topconstr.LocalRawAssum(l,k,t) -> List.exists (function (_,Name id) -> id = wf_args | _ -> false) l | _ -> false ) args with | Topconstr.LocalRawAssum(_,k,t) -> t,wf_args | _ -> assert false with Not_found -> assert false in let wf_rel_from_mes,is_mes = match wf_rel_expr_opt with | None -> let ltof = let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in Libnames.Qualid (dummy_loc,Libnames.qualid_of_path (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (id_of_string "ltof"))) in let fun_from_mes = let applied_mes = Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg]) in Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,applied_mes) in let wf_rel_from_mes = Topconstr.mkAppC(Topconstr.mkRefC ltof,[wf_arg_type;fun_from_mes]) in wf_rel_from_mes,true | Some wf_rel_expr -> let wf_rel_with_mes = let a = Names.id_of_string "___a" in let b = Names.id_of_string "___b" in Topconstr.mkLambdaC( [dummy_loc,Name a;dummy_loc,Name b], Topconstr.Default Lib.Explicit, wf_arg_type, Topconstr.mkAppC(wf_rel_expr, [ Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC a]); Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC b]) ]) ) in wf_rel_with_mes,false in register_wf ~is_mes:is_mes fname rec_impls wf_rel_from_mes (Some wf_arg) using_lemmas args ret_type body let map_option f = function | None -> None | Some v -> Some (f v) let decompose_lambda_n_assum_constr_expr = let rec decompose_lambda_n_assum_constr_expr acc n e = if n = 0 then (List.rev acc,e) else match e with | Topconstr.CLambdaN(_, [],e') -> decompose_lambda_n_assum_constr_expr acc n e' | Topconstr.CLambdaN(lambda_loc,(nal,bk,nal_type)::bl,e') -> let nal_length = List.length nal in if nal_length <= n then decompose_lambda_n_assum_constr_expr (Topconstr.LocalRawAssum(nal,bk,nal_type)::acc) (n - nal_length) (Topconstr.CLambdaN(lambda_loc,bl,e')) else let nal_keep,nal_expr = list_chop n nal in (List.rev (Topconstr.LocalRawAssum(nal_keep,bk,nal_type)::acc), Topconstr.CLambdaN(lambda_loc,(nal_expr,bk,nal_type)::bl,e') ) | Topconstr.CLetIn(_, na,nav,e') -> decompose_lambda_n_assum_constr_expr (Topconstr.LocalRawDef(na,nav)::acc) (pred n) e' | _ -> error "Not enough product or assumption" in decompose_lambda_n_assum_constr_expr [] let decompose_prod_n_assum_constr_expr = let rec decompose_prod_n_assum_constr_expr acc n e = (* Pp.msgnl (str "n := " ++ int n ++ fnl ()++ *) (* str "e := " ++ Ppconstr.pr_lconstr_expr e); *) if n = 0 then (* let _ = Pp.msgnl (str "return_type := " ++ Ppconstr.pr_lconstr_expr e) in *) (List.rev acc,e) else match e with | Topconstr.CProdN(_, [],e') -> decompose_prod_n_assum_constr_expr acc n e' | Topconstr.CProdN(lambda_loc,(nal,bk,nal_type)::bl,e') -> let nal_length = List.length nal in if nal_length <= n then (* let _ = Pp.msgnl (str "first case") in *) decompose_prod_n_assum_constr_expr (Topconstr.LocalRawAssum(nal,bk,nal_type)::acc) (n - nal_length) (if bl = [] then e' else (Topconstr.CLambdaN(lambda_loc,bl,e'))) else (* let _ = Pp.msgnl (str "second case") in *) let nal_keep,nal_expr = list_chop n nal in (List.rev (Topconstr.LocalRawAssum(nal_keep,bk,nal_type)::acc), Topconstr.CLambdaN(lambda_loc,(nal_expr,bk,nal_type)::bl,e') ) | Topconstr.CArrow(_,premisse,concl) -> (* let _ = Pp.msgnl (str "arrow case") in *) decompose_prod_n_assum_constr_expr (Topconstr.LocalRawAssum([dummy_loc,Names.Anonymous], Topconstr.Default Lib.Explicit,premisse) ::acc) (pred n) concl | Topconstr.CLetIn(_, na,nav,e') -> decompose_prod_n_assum_constr_expr (Topconstr.LocalRawDef(na,nav)::acc) (pred n) e' | _ -> error "Not enough product or assumption" in decompose_prod_n_assum_constr_expr [] open Topconstr let id_of_name = function | Name id -> id | _ -> assert false let rec rebuild_bl (aux,assoc) bl typ = match bl,typ with | [], _ -> (List.rev aux,replace_vars_constr_expr assoc typ,assoc) | (Topconstr.LocalRawAssum(nal,bk,_))::bl',typ -> rebuild_nal (aux,assoc) bk bl' nal (List.length nal) typ | (Topconstr.LocalRawDef(na,_))::bl',CLetIn(_,_,nat,typ') -> rebuild_bl ((Topconstr.LocalRawDef(na,replace_vars_constr_expr assoc nat)::aux),assoc) bl' typ' | _ -> assert false and rebuild_nal (aux,assoc) bk bl' nal lnal typ = match nal,typ with | [], _ -> rebuild_bl (aux,assoc) bl' typ | na::nal,CArrow(_,nat,typ') -> rebuild_nal ((LocalRawAssum([na],bk,replace_vars_constr_expr assoc nat))::aux,assoc) bk bl' nal (pred lnal) typ' | _,CProdN(_,[],typ) -> rebuild_nal (aux,assoc) bk bl' nal lnal typ | _,CProdN(_,(nal',bk',nal't)::rest,typ') -> let lnal' = List.length nal' in if lnal' >= lnal then let old_nal',new_nal' = list_chop lnal nal' in rebuild_bl ((LocalRawAssum(nal,bk,replace_vars_constr_expr assoc nal't)::aux),(List.rev_append (List.combine (List.map id_of_name (List.map snd old_nal')) (List.map id_of_name (List.map snd nal))) assoc)) bl' (if new_nal' = [] && rest = [] then typ' else if new_nal' = [] then CProdN(dummy_loc,rest,typ') else CProdN(dummy_loc,((new_nal',bk',nal't)::rest),typ')) else let captured_nal,non_captured_nal = list_chop lnal' nal in rebuild_nal ((LocalRawAssum(captured_nal,bk,replace_vars_constr_expr assoc nal't)::aux), (List.rev_append (List.combine (List.map id_of_name (List.map snd captured_nal)) ((List.map id_of_name (List.map snd nal)))) assoc)) bk bl' non_captured_nal (lnal - lnal') (CProdN(dummy_loc,rest,typ')) | _ -> assert false let rebuild_bl (aux,assoc) bl typ = rebuild_bl (aux,assoc) bl typ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in let ((_,_,typel),_) = Command.interp_fixpoint fixl ntns in let constr_expr_typel = with_full_print (List.map (Constrextern.extern_constr false (Global.env ()))) typel in let fixpoint_exprl_with_new_bl = List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> let new_bl',new_ret_type,_ = rebuild_bl ([],[]) bl fix_typ in (((lna,(rec_arg_opt,rec_order),new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) fixpoint_exprl constr_expr_typel in fixpoint_exprl_with_new_bl let do_generate_principle on_error register_built interactive_proof (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) :unit = List.iter (fun (_,l) -> if l <> [] then error "Function does not support notations for now") fixpoint_exprl; let _is_struct = match fixpoint_exprl with | [((_,(wf_x,Topconstr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] -> let ((((_,name),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false in let fixpoint_exprl = [fixpoint_expr] in let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in let pre_hook = generate_principle on_error true register_built fixpoint_exprl recdefs true in if register_built then register_wf name rec_impls wf_rel (map_option snd wf_x) using_lemmas args types body pre_hook; false |[((_,(wf_x,Topconstr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] -> let ((((_,name),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false in let fixpoint_exprl = [fixpoint_expr] in let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in let pre_hook = generate_principle on_error true register_built fixpoint_exprl recdefs true in if register_built then register_mes name rec_impls wf_mes wf_rel_opt (map_option snd wf_x) using_lemmas args types body pre_hook; true | _ -> List.iter (function ((_na,(_,ord),_args,_body,_type),_not) -> match ord with | Topconstr.CMeasureRec _ | Topconstr.CWfRec _ -> error ("Cannot use mutual definition with well-founded recursion or measure") | _ -> () ) fixpoint_exprl; let fixpoint_exprl = recompute_binder_list fixpoint_exprl in let fix_names = List.map (function (((_,name),_,_,_,_),_) -> name) fixpoint_exprl in (* ok all the expressions are structural *) let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let is_rec = List.exists (is_rec fix_names) recdefs in if register_built then register_struct is_rec fixpoint_exprl; generate_principle on_error false register_built fixpoint_exprl recdefs interactive_proof (Functional_principles_proofs.prove_princ_for_struct interactive_proof); if register_built then derive_inversion fix_names; true; in () open Topconstr let rec add_args id new_args b = match b with | CRef r -> begin match r with | Libnames.Ident(loc,fname) when fname = id -> CAppExpl(dummy_loc,(None,r),new_args) | _ -> b end | CFix _ | CCoFix _ -> anomaly "add_args : todo" | CArrow(loc,b1,b2) -> CArrow(loc,add_args id new_args b1, add_args id new_args b2) | CProdN(loc,nal,b1) -> CProdN(loc, List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, add_args id new_args b1) | CLambdaN(loc,nal,b1) -> CLambdaN(loc, List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, add_args id new_args b1) | CLetIn(loc,na,b1,b2) -> CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2) | CAppExpl(loc,(pf,r),exprl) -> begin match r with | Libnames.Ident(loc,fname) when fname = id -> CAppExpl(loc,(pf,r),new_args@(List.map (add_args id new_args) exprl)) | _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl) end | CApp(loc,(pf,b),bl) -> CApp(loc,(pf,add_args id new_args b), List.map (fun (e,o) -> add_args id new_args e,o) bl) | CCases(loc,sty,b_option,cel,cal) -> CCases(loc,sty,Option.map (add_args id new_args) b_option, List.map (fun (b,(na,b_option)) -> add_args id new_args b, (na,Option.map (add_args id new_args) b_option)) cel, List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal ) | CLetTuple(loc,nal,(na,b_option),b1,b2) -> CLetTuple(loc,nal,(na,Option.map (add_args id new_args) b_option), add_args id new_args b1, add_args id new_args b2 ) | CIf(loc,b1,(na,b_option),b2,b3) -> CIf(loc,add_args id new_args b1, (na,Option.map (add_args id new_args) b_option), add_args id new_args b2, add_args id new_args b3 ) | CHole _ -> b | CPatVar _ -> b | CEvar _ -> b | CSort _ -> b | CCast(loc,b1,CastConv(ck,b2)) -> CCast(loc,add_args id new_args b1,CastConv(ck,add_args id new_args b2)) | CCast(loc,b1,CastCoerce) -> CCast(loc,add_args id new_args b1,CastCoerce) | CRecord (loc, w, pars) -> CRecord (loc, (match w with Some w -> Some (add_args id new_args w) | _ -> None), List.map (fun (e,o) -> e, add_args id new_args o) pars) | CNotation _ -> anomaly "add_args : CNotation" | CGeneralization _ -> anomaly "add_args : CGeneralization" | CPrim _ -> b | CDelimiters _ -> anomaly "add_args : CDelimiters" exception Stop of Topconstr.constr_expr (* [chop_n_arrow n t] chops the [n] first arrows in [t] Acts on Topconstr.constr_expr *) let rec chop_n_arrow n t = if n <= 0 then t (* If we have already removed all the arrows then return the type *) else (* If not we check the form of [t] *) match t with | Topconstr.CArrow(_,_,t) -> (* If we have an arrow, we discard it and recall [chop_n_arrow] *) chop_n_arrow (n-1) t | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible : either we need to discard more than the number of arrows contained in this product declaration then we just recall [chop_n_arrow] on the remaining number of arrow to chop and [t'] we discard it and recall [chop_n_arrow], either this product contains more arrows than the number we need to chop and then we return the new type *) begin try let new_n = let rec aux (n:int) = function [] -> n | (nal,k,t'')::nal_ta' -> let nal_l = List.length nal in if n >= nal_l then aux (n - nal_l) nal_ta' else let new_t' = Topconstr.CProdN(dummy_loc, ((snd (list_chop n nal)),k,t'')::nal_ta',t') in raise (Stop new_t') in aux n nal_ta' in chop_n_arrow new_n t' with Stop t -> t end | _ -> anomaly "Not enough products" let rec get_args b t : Topconstr.local_binder list * Topconstr.constr_expr * Topconstr.constr_expr = match b with | Topconstr.CLambdaN (loc, (nal_ta), b') -> begin let n = (List.fold_left (fun n (nal,_,_) -> n+List.length nal) 0 nal_ta ) in let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in (List.map (fun (nal,k,ta) -> (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' end | _ -> [],b,t let make_graph (f_ref:global_reference) = let c,c_body = match f_ref with | ConstRef c -> begin try c,Global.lookup_constant c with Not_found -> raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) end | _ -> raise (UserError ("", str "Not a function reference") ) in Dumpglob.pause (); (match body_of_constant c_body with | None -> error "Cannot build a graph over an axiom !" | Some b -> let env = Global.env () in let body = (force b) in let extern_body,extern_type = with_full_print (fun () -> (Constrextern.extern_constr false env body, Constrextern.extern_type false env (Typeops.type_of_constant_type env c_body.const_type) ) ) () in let (nal_tas,b,t) = get_args extern_body extern_type in let expr_list = match b with | Topconstr.CFix(loc,l_id,fixexprl) -> let l = List.map (fun (id,(n,recexp),bl,t,b) -> let loc, rec_id = Option.get n in let new_args = List.flatten (List.map (function | Topconstr.LocalRawDef (na,_)-> [] | Topconstr.LocalRawAssum (nal,_,_) -> List.map (fun (loc,n) -> CRef(Libnames.Ident(loc, Nameops.out_name n))) nal ) nal_tas ) in let b' = add_args (snd id) new_args b in (((id, ( Some (dummy_loc,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) fixexprl in l | _ -> let id = id_of_label (con_label c) in [((dummy_loc,id),(None,Topconstr.CStructRec),nal_tas,t,Some b),[]] in do_generate_principle error_error false false expr_list; (* We register the infos *) let mp,dp,_ = repr_con c in List.iter (fun (((_,id),_,_,_,_),_) -> add_Function false (make_con mp dp (label_of_id id))) expr_list); Dumpglob.continue () let do_generate_principle = do_generate_principle warning_error true coq-8.4pl4/plugins/funind/glob_term_to_relation.ml0000644000175000017500000013716112326224777021513 0ustar stephstephopen Printer open Pp open Names open Term open Glob_term open Libnames open Indfun_common open Util open Glob_termops let observe strm = if do_observe () then Pp.msgnl strm else () let observennl strm = if do_observe () then Pp.msg strm else () type binder_type = | Lambda of name | Prod of name | LetIn of name type glob_context = (binder_type*glob_constr) list (* compose_glob_context [(bt_1,n_1,t_1);......] rt returns b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the binders corresponding to the bt_i's *) let compose_glob_context = let compose_binder (bt,t) acc = match bt with | Lambda n -> mkGLambda(n,t,acc) | Prod n -> mkGProd(n,t,acc) | LetIn n -> mkGLetIn(n,t,acc) in List.fold_right compose_binder (* The main part deals with building a list of globalized constructor expressions from the rhs of a fixpoint equation. *) type 'a build_entry_pre_return = { context : glob_context; (* the binding context of the result *) value : 'a; (* The value *) } type 'a build_entry_return = { result : 'a build_entry_pre_return list; to_avoid : identifier list } (* [combine_results combine_fun res1 res2] combine two results [res1] and [res2] w.r.t. [combine_fun]. Informally, both [res1] and [res2] are lists of "constructors" [res1_1;...] and [res2_1,....] and we need to produce [combine_fun res1_1 res2_1;combine_fun res1_1 res2_2;........] *) let combine_results (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return -> 'c build_entry_pre_return ) (res1: 'a build_entry_return) (res2 : 'b build_entry_return) : 'c build_entry_return = let pre_result = List.map ( fun res1 -> (* for each result in arg_res *) List.map (* we add it in each args_res *) (fun res2 -> combine_fun res1 res2 ) res2.result ) res1.result in (* and then we flatten the map *) { result = List.concat pre_result; to_avoid = list_union res1.to_avoid res2.to_avoid } (* The combination function for an argument with a list of argument *) let combine_args arg args = { context = arg.context@args.context; (* Note that the binding context of [arg] MUST be placed before the one of [args] in order to preserve possible type dependencies *) value = arg.value::args.value; } let ids_of_binder = function | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> [] | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> [id] let rec change_vars_in_binder mapping = function [] -> [] | (bt,t)::l -> let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in (bt,change_vars mapping t):: (if idmap_is_empty new_mapping then l else change_vars_in_binder new_mapping l ) let rec replace_var_by_term_in_binder x_id term = function | [] -> [] | (bt,t)::l -> (bt,replace_var_by_term x_id term t):: if List.mem x_id (ids_of_binder bt) then l else replace_var_by_term_in_binder x_id term l let add_bt_names bt = List.append (ids_of_binder bt) let apply_args ctxt body args = let need_convert_id avoid id = List.exists (is_free_in id) args || List.mem id avoid in let need_convert avoid bt = List.exists (need_convert_id avoid) (ids_of_binder bt) in let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) = match na with | Name id when List.mem id avoid -> let new_id = Namegen.next_ident_away id avoid in Name new_id,Idmap.add id new_id mapping,new_id::avoid | _ -> na,mapping,avoid in let next_bt_away bt (avoid:identifier list) = match bt with | LetIn na -> let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in LetIn new_na,mapping,new_avoid | Prod na -> let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in Prod new_na,mapping,new_avoid | Lambda na -> let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in Lambda new_na,mapping,new_avoid in let rec do_apply avoid ctxt body args = match ctxt,args with | _,[] -> (* No more args *) (ctxt,body) | [],_ -> (* no more fun *) let f,args' = glob_decompose_app body in (ctxt,mkGApp(f,args'@args)) | (Lambda Anonymous,t)::ctxt',arg::args' -> do_apply avoid ctxt' body args' | (Lambda (Name id),t)::ctxt',arg::args' -> let new_avoid,new_ctxt',new_body,new_id = if need_convert_id avoid id then let new_avoid = id::avoid in let new_id = Namegen.next_ident_away id new_avoid in let new_avoid' = new_id :: new_avoid in let mapping = Idmap.add id new_id Idmap.empty in let new_ctxt' = change_vars_in_binder mapping ctxt' in let new_body = change_vars mapping body in new_avoid',new_ctxt',new_body,new_id else id::avoid,ctxt',body,id in let new_body = replace_var_by_term new_id arg new_body in let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in do_apply avoid new_ctxt' new_body args' | (bt,t)::ctxt',_ -> let new_avoid,new_ctxt',new_body,new_bt = let new_avoid = add_bt_names bt avoid in if need_convert avoid bt then let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in ( new_avoid, change_vars_in_binder mapping ctxt', change_vars mapping body, new_bt ) else new_avoid,ctxt',body,bt in let new_ctxt',new_body = do_apply new_avoid new_ctxt' new_body args in (new_bt,t)::new_ctxt',new_body in do_apply [] ctxt body args let combine_app f args = let new_ctxt,new_value = apply_args f.context f.value args.value in { (* Note that the binding context of [args] MUST be placed before the one of the applied value in order to preserve possible type dependencies *) context = args.context@new_ctxt; value = new_value; } let combine_lam n t b = { context = []; value = mkGLambda(n, compose_glob_context t.context t.value, compose_glob_context b.context b.value ) } let combine_prod n t b = { context = t.context@((Prod n,t.value)::b.context); value = b.value} let combine_letin n t b = { context = t.context@((LetIn n,t.value)::b.context); value = b.value} let mk_result ctxt value avoid = { result = [{context = ctxt; value = value}] ; to_avoid = avoid } (************************************************* Some functions to deal with overlapping patterns **************************************************) let coq_True_ref = lazy (Coqlib.gen_reference "" ["Init";"Logic"] "True") let coq_False_ref = lazy (Coqlib.gen_reference "" ["Init";"Logic"] "False") (* [make_discr_match_el \[e1,...en\]] builds match e1,...,en with (the list of expresions on which we will do the matching) *) let make_discr_match_el = List.map (fun e -> (e,(Anonymous,None))) (* [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression. that is. match ?????? with \\ | pat_1 => False \\ | pat_{i-1} => False \\ | pat_i => True \\ | pat_{i+1} => False \\ \vdots | pat_n => False end *) let make_discr_match_brl i = list_map_i (fun j (_,idl,patl,_) -> if j=i then (dummy_loc,idl,patl, mkGRef (Lazy.force coq_True_ref)) else (dummy_loc,idl,patl, mkGRef (Lazy.force coq_False_ref)) ) 0 (* [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff brl_{i} is the first branch matched by [el] Used when we want to simulate the coq pattern matching algorithm *) let make_discr_match brl = fun el i -> mkGCases(None, make_discr_match_el el, make_discr_match_brl i brl) let pr_name = function | Name id -> Ppconstr.pr_id id | Anonymous -> str "_" (**********************************************************************) (* functions used to build case expression from lettuple and if ones *) (**********************************************************************) (* [build_constructors_of_type] construct the array of pattern of its inductive argument*) let build_constructors_of_type ind' argl = let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in let npar = mib.Declarations.mind_nparams in Array.mapi (fun i _ -> let construct = ind',i+1 in let constructref = ConstructRef(construct) in let _implicit_positions_of_cst = Impargs.implicits_of_global constructref in let cst_narg = Inductiveops.mis_constructor_nargs_env (Global.env ()) construct in let argl = match argl with | None -> Array.to_list (Array.init cst_narg (fun _ -> mkGHole ()) ) | Some l -> Array.to_list (Array.init npar (fun _ -> mkGHole ()))@l in let pat_as_term = mkGApp(mkGRef (ConstructRef(ind',i+1)),argl) in cases_pattern_of_glob_constr Anonymous pat_as_term ) ind.Declarations.mind_consnames (* [find_type_of] very naive attempts to discover the type of an if or a letin *) let rec find_type_of nb b = let f,_ = glob_decompose_app b in match f with | GRef(_,ref) -> begin let ind_type = match ref with | VarRef _ | ConstRef _ -> let constr_of_ref = constr_of_global ref in let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in let ret_type,_ = decompose_app ret_type in if not (isInd ret_type) then begin (* Pp.msgnl (str "not an inductive" ++ pr_lconstr ret_type); *) raise (Invalid_argument "not an inductive") end; destInd ret_type | IndRef ind -> ind | ConstructRef c -> fst c in let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in if not (Array.length ind_type_info.Declarations.mind_consnames = nb ) then raise (Invalid_argument "find_type_of : not a valid inductive"); ind_type end | GCast(_,b,_) -> find_type_of nb b | GApp _ -> assert false (* we have decomposed any application via glob_decompose_app *) | _ -> raise (Invalid_argument "not a ref") (******************) (* Main functions *) (******************) let raw_push_named (na,raw_value,raw_typ) env = match na with | Anonymous -> env | Name id -> let value = Option.map (Pretyping.Default.understand Evd.empty env) raw_value in let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in Environ.push_named (id,value,typ) env let add_pat_variables pat typ env : Environ.env = let rec add_pat_variables env pat typ : Environ.env = observe (str "new rel env := " ++ Printer.pr_rel_context_of env); match pat with | PatVar(_,na) -> Environ.push_rel (na,None,typ) env | PatCstr(_,c,patl,na) -> let Inductiveops.IndType(indf,indargs) = try Inductiveops.find_rectype env Evd.empty typ with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in let new_env = add_pat_variables env pat typ in let res = fst ( Sign.fold_rel_context (fun (na,v,t) (env,ctxt) -> match na with | Anonymous -> assert false | Name id -> let new_t = substl ctxt t in let new_v = Option.map (substl ctxt) v in observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++ str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++ Option.fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++ Option.fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ()) ); (Environ.push_named (id,new_v,new_t) env,mkVar id::ctxt) ) (Environ.rel_context new_env) ~init:(env,[]) ) in observe (str "new var env := " ++ Printer.pr_named_context_of res); res let rec pattern_to_term_and_type env typ = function | PatVar(loc,Anonymous) -> assert false | PatVar(loc,Name id) -> mkGVar id | PatCstr(loc,constr,patternl,_) -> let cst_narg = Inductiveops.mis_constructor_nargs_env (Global.env ()) constr in let Inductiveops.IndType(indf,indargs) = try Inductiveops.find_rectype env Evd.empty typ with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in let constructor = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in let _,cstl = Inductiveops.dest_ind_family indf in let csta = Array.of_list cstl in let implicit_args = Array.to_list (Array.init (cst_narg - List.length patternl) (fun i -> Detyping.detype false [] (Termops.names_of_rel_context env) csta.(i)) ) in let patl_as_term = List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl in mkGApp(mkGRef(ConstructRef constr), implicit_args@patl_as_term ) (* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the corresponding graphs. The idea to transform a term [t] into a list of constructors [lc] is the following: \begin{itemize} \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding to [body] and add (bind x. _) to each elements of [lc] \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames) then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn], [g c1 ... cn] is an element of [lc] \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], then compute those lists and [f] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn] create a new variable [res] and [forall res, R_f c1 ... cn res] is in [lc] \item if the term is a cast just treat its body part \item if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case and concatenate them (informally, each branch of a match produces a new constructor) \end{itemize} WARNING: The terms constructed here are only USING the glob_constr syntax but are highly bad formed. We must wait to have complete all the current calculi to set the recursive calls. At this point, each term [f t1 ... tn] (where f appears in [funnames]) is replaced by a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later. We in fact not create a constructor list since then end of each constructor has not the expected form but only the value of the function *) let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = observe (str " Entering : " ++ Printer.pr_glob_constr rt); match rt with | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> (* do nothing (except changing type of course) *) mk_result [] rt avoid | GApp(_,_,_) -> let f,args = glob_decompose_app rt in let args_res : (glob_constr list) build_entry_return = List.fold_right (* create the arguments lists of constructors and combine them *) (fun arg ctxt_argsl -> let arg_res = build_entry_lc env funnames ctxt_argsl.to_avoid arg in combine_results combine_args arg_res ctxt_argsl ) args (mk_result [] [] avoid) in begin match f with | GLambda _ -> let rec aux t l = match l with | [] -> t | u::l -> match t with | GLambda(loc,na,_,nat,b) -> GLetIn(dummy_loc,na,u,aux b l) | _ -> GApp(dummy_loc,t,l) in build_entry_lc env funnames avoid (aux f args) | GVar(_,id) when Idset.mem id funnames -> (* if we have [f t1 ... tn] with [f]$\in$[fnames] then we create a fresh variable [res], add [res] and its "value" (i.e. [res v1 ... vn]) to each pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and a pseudo value "v1 ... vn". The "value" of this branch is then simply [res] *) let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in let rt_typ = Typing.type_of env Evd.empty rt_as_constr in let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in let res = fresh_id args_res.to_avoid "res" in let new_avoid = res::args_res.to_avoid in let res_rt = mkGVar res in let new_result = List.map (fun arg_res -> let new_hyps = [Prod (Name res),res_raw_type; Prod Anonymous,mkGApp(res_rt,(mkGVar id)::arg_res.value)] in {context = arg_res.context@new_hyps; value = res_rt } ) args_res.result in { result = new_result; to_avoid = new_avoid } | GVar _ | GEvar _ | GPatVar _ | GHole _ | GSort _ | GRef _ -> (* if have [g t1 ... tn] with [g] not appearing in [funnames] then foreach [ctxt,v1 ... vn] in [args_res] we return [ctxt, g v1 .... vn] *) { args_res with result = List.map (fun args_res -> {args_res with value = mkGApp(f,args_res.value)}) args_res.result } | GApp _ -> assert false (* we have collected all the app in [glob_decompose_app] *) | GLetIn(_,n,t,b) -> (* if we have [(let x := v in b) t1 ... tn] , we discard our work and compute the list of constructor for [let x = v in (b t1 ... tn)] up to alpha conversion *) let new_n,new_b,new_avoid = match n with | Name id when List.exists (is_free_in id) args -> (* need to alpha-convert the name *) let new_id = Namegen.next_ident_away id avoid in let new_avoid = id:: avoid in let new_b = replace_var_by_term id (GVar(dummy_loc,id)) b in (Name new_id,new_b,new_avoid) | _ -> n,b,avoid in build_entry_lc env funnames avoid (mkGLetIn(new_n,t,mkGApp(new_b,args))) | GCases _ | GIf _ | GLetTuple _ -> (* we have [(match e1, ...., en with ..... end) t1 tn] we first compute the result from the case and then combine each of them with each of args one *) let f_res = build_entry_lc env funnames args_res.to_avoid f in combine_results combine_app f_res args_res | GCast(_,b,_) -> (* for an applied cast we just trash the cast part and restart the work. WARNING: We need to restart since [b] itself should be an application term *) build_entry_lc env funnames avoid (mkGApp(b,args)) | GRec _ -> error "Not handled GRec" | GProd _ -> error "Cannot apply a type" end (* end of the application treatement *) | GLambda(_,n,_,t,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the type and combine the two result *) let t_res = build_entry_lc env funnames avoid t in let new_n = match n with | Name _ -> n | Anonymous -> Name (Indfun_common.fresh_id [] "_x") in let new_env = raw_push_named (new_n,None,t) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_lam new_n) t_res b_res | GProd(_,n,_,t,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the type and combine the two result *) let t_res = build_entry_lc env funnames avoid t in let new_env = raw_push_named (n,None,t) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_prod n) t_res b_res | GLetIn(_,n,v,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the value [t] and combine the two result *) let v_res = build_entry_lc env funnames avoid v in let v_as_constr = Pretyping.Default.understand Evd.empty env v in let v_type = Typing.type_of env Evd.empty v_as_constr in let new_env = match n with Anonymous -> env | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_letin n) v_res b_res | GCases(_,_,_,el,brl) -> (* we create the discrimination function and treat the case itself *) let make_discr = make_discr_match brl in build_entry_lc_from_case env funnames make_discr el brl avoid | GIf(_,b,(na,e_option),lhs,rhs) -> let b_as_constr = Pretyping.Default.understand Evd.empty env b in let b_typ = Typing.type_of env Evd.empty b_as_constr in let (ind,_) = try Inductiveops.find_inductive env Evd.empty b_typ with Not_found -> errorlabstrm "" (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in let case_pats = build_constructors_of_type ind None in assert (Array.length case_pats = 2); let brl = list_map_i (fun i x -> (dummy_loc,[],[case_pats.(i)],x)) 0 [lhs;rhs] in let match_expr = mkGCases(None,[(b,(Anonymous,None))],brl) in (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) build_entry_lc env funnames avoid match_expr | GLetTuple(_,nal,_,b,e) -> begin let nal_as_glob_constr = Some (List.map (function Name id -> mkGVar id | Anonymous -> mkGHole () ) nal) in let b_as_constr = Pretyping.Default.understand Evd.empty env b in let b_typ = Typing.type_of env Evd.empty b_as_constr in let (ind,_) = try Inductiveops.find_inductive env Evd.empty b_typ with Not_found -> errorlabstrm "" (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in let case_pats = build_constructors_of_type ind nal_as_glob_constr in assert (Array.length case_pats = 1); let br = (dummy_loc,[],[case_pats.(0)],e) in let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in build_entry_lc env funnames avoid match_expr end | GRec _ -> error "Not handled GRec" | GCast(_,b,_) -> build_entry_lc env funnames avoid b and build_entry_lc_from_case env funname make_discr (el:tomatch_tuples) (brl:Glob_term.cases_clauses) avoid : glob_constr build_entry_return = match el with | [] -> assert false (* this case correspond to match with .... !*) | el -> (* this case correspond to match el with brl end we first compute the list of lists corresponding to [el] and combine them . Then for each elemeent of the combinations, we compute the result we compute one list per branch in [brl] and finally we just concatenate those list *) let case_resl = List.fold_right (fun (case_arg,_) ctxt_argsl -> let arg_res = build_entry_lc env funname avoid case_arg in combine_results combine_args arg_res ctxt_argsl ) el (mk_result [] [] avoid) in let types = List.map (fun (case_arg,_) -> let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in Typing.type_of env Evd.empty case_arg_as_constr ) el in (****** The next works only if the match is not dependent ****) let results = List.map (fun ca -> let res = build_entry_lc_from_case_term env types funname (make_discr) [] brl case_resl.to_avoid ca in res ) case_resl.result in { result = List.concat (List.map (fun r -> r.result) results); to_avoid = List.fold_left (fun acc r -> list_union acc r.to_avoid) [] results } and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid matched_expr = match brl with | [] -> (* computed_branches *) {result = [];to_avoid = avoid} | br::brl' -> (* alpha convertion to prevent name clashes *) let _,idl,patl,return = alpha_br avoid br in let new_avoid = idl@avoid in (* for now we can no more use idl as an indentifier *) (* building a list of precondition stating that we are not in this branch (will be used in the following recursive calls) *) let new_env = List.fold_right2 add_pat_variables patl types env in let not_those_patterns : (identifier list -> glob_constr -> glob_constr) list = List.map2 (fun pat typ -> fun avoid pat'_as_term -> let renamed_pat,_,_ = alpha_pat avoid pat in let pat_ids = get_pattern_id renamed_pat in let env_with_pat_ids = add_pat_variables pat typ new_env in List.fold_right (fun id acc -> let typ_of_id = Typing.type_of env_with_pat_ids Evd.empty (mkVar id) in let raw_typ_of_id = Detyping.detype false [] (Termops.names_of_rel_context env_with_pat_ids) typ_of_id in mkGProd (Name id,raw_typ_of_id,acc)) pat_ids (glob_make_neq pat'_as_term (pattern_to_term renamed_pat)) ) patl types in (* Checking if we can be in this branch (will be used in the following recursive calls) *) let unify_with_those_patterns : (cases_pattern -> bool*bool) list = List.map (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') patl in (* we first compute the other branch result (in ordrer to keep the order of the matching as much as possible) *) let brl'_res = build_entry_lc_from_case_term env types funname make_discr ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent) brl' avoid matched_expr in (* We now create the precondition of this branch i.e. 1- the list of variable appearing in the different patterns of this branch and the list of equation stating than el = patl (List.flatten ...) 2- If there exists a previous branch which pattern unify with the one of this branch then a discrimination precond stating that we are not in a previous branch (if List.exists ...) *) let those_pattern_preconds = (List.flatten ( list_map3 (fun pat e typ_as_constr -> let this_pat_ids = ids_of_pat pat in let typ = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_as_constr in let pat_as_term = pattern_to_term pat in List.fold_right (fun id acc -> if Idset.mem id this_pat_ids then (Prod (Name id), let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in let raw_typ_of_id = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_of_id in raw_typ_of_id )::acc else acc ) idl [(Prod Anonymous,glob_make_eq ~typ pat_as_term e)] ) patl matched_expr.value types ) ) @ (if List.exists (function (unifl,_) -> let (unif,_) = List.split (List.map2 (fun x y -> x y) unifl patl) in List.for_all (fun x -> x) unif) patterns_to_prevent then let i = List.length patterns_to_prevent in let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in [(Prod Anonymous,make_discr pats_as_constr i )] else [] ) in (* We compute the result of the value returned by the branch*) let return_res = build_entry_lc new_env funname new_avoid return in (* and combine it with the preconds computed for this branch *) let this_branch_res = List.map (fun res -> { context = matched_expr.context@those_pattern_preconds@res.context ; value = res.value} ) return_res.result in { brl'_res with result = this_branch_res@brl'_res.result } let is_res id = try String.sub (string_of_id id) 0 3 = "res" with Invalid_argument _ -> false let same_raw_term rt1 rt2 = match rt1,rt2 with | GRef(_,r1), GRef (_,r2) -> r1=r2 | GHole _, GHole _ -> true | _ -> false let decompose_raw_eq lhs rhs = let rec decompose_raw_eq lhs rhs acc = observe (str "decomposing eq for " ++ pr_glob_constr lhs ++ str " " ++ pr_glob_constr rhs); let (rhd,lrhs) = glob_decompose_app rhs in let (lhd,llhs) = glob_decompose_app lhs in observe (str "lhd := " ++ pr_glob_constr lhd); observe (str "rhd := " ++ pr_glob_constr rhd); observe (str "llhs := " ++ int (List.length llhs)); observe (str "lrhs := " ++ int (List.length lrhs)); let sllhs = List.length llhs in let slrhs = List.length lrhs in if same_raw_term lhd rhd && sllhs = slrhs then (* let _ = assert false in *) List.fold_right2 decompose_raw_eq llhs lrhs acc else (lhs,rhs)::acc in decompose_raw_eq lhs rhs [] exception Continue (* The second phase which reconstruct the real type of the constructor. rebuild the globalized constructors expression. eliminates some meaningless equalities, applies some rewrites...... *) let rec rebuild_cons env nb_args relname args crossed_types depth rt = observe (str "rebuilding : " ++ pr_glob_constr rt); match rt with | GProd(_,n,k,t,b) -> let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t::crossed_types in begin match t with | GApp(_,(GVar(_,res_id) as res_rt),args') when is_res res_id -> begin match args' with | (GVar(_,this_relname))::args' -> (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious i*) let new_t = mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt]) in let t' = Pretyping.Default.understand Evd.empty env new_t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args new_crossed_types (depth + 1) b in mkGProd(n,new_t,new_b), Idset.filter not_free_in_t id_to_exclude | _ -> (* the first args is the name of the function! *) assert false end | GApp(loc1,GRef(loc2,eq_as_ref),[ty;GVar(loc3,id);rt]) when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous -> begin try observe (str "computing new type for eq : " ++ pr_glob_constr rt); let t' = try Pretyping.Default.understand Evd.empty env t with e when Errors.noncritical e -> raise Continue in let is_in_b = is_free_in id b in let _keep_eq = not (List.exists (is_free_in id) args) || is_in_b || List.exists (is_free_in id) crossed_types in let new_args = List.map (replace_var_by_term id rt) args in let subst_b = if is_in_b then b else replace_var_by_term id rt b in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname new_args new_crossed_types (depth + 1) subst_b in mkGProd(n,t,new_b),id_to_exclude with Continue -> let jmeq = Libnames.IndRef (destInd (jmeq ())) in let ty' = Pretyping.Default.understand Evd.empty env ty in let ind,args' = Inductive.find_inductive env ty' in let mib,_ = Global.lookup_inductive ind in let nparam = mib.Declarations.mind_nparams in let params,arg' = ((Util.list_chop nparam args')) in let rt_typ = GApp(Util.dummy_loc, GRef (Util.dummy_loc,Libnames.IndRef ind), (List.map (fun p -> Detyping.detype false [] (Termops.names_of_rel_context env) p) params)@(Array.to_list (Array.make (List.length args' - nparam) (mkGHole ())))) in let eq' = GApp(loc1,GRef(loc2,jmeq),[ty;GVar(loc3,id);rt_typ;rt]) in observe (str "computing new type for jmeq : " ++ pr_glob_constr eq'); let eq'_as_constr = Pretyping.Default.understand Evd.empty env eq' in observe (str " computing new type for jmeq : done") ; let new_args = match kind_of_term eq'_as_constr with | App(_,[|_;_;ty;_|]) -> let ty = Array.to_list (snd (destApp ty)) in let ty' = snd (Util.list_chop nparam ty) in List.fold_left2 (fun acc var_as_constr arg -> if isRel var_as_constr then let (na,_,_) = Environ.lookup_rel (destRel var_as_constr) env in match na with | Anonymous -> acc | Name id' -> (id',Detyping.detype false [] (Termops.names_of_rel_context env) arg)::acc else if isVar var_as_constr then (destVar var_as_constr,Detyping.detype false [] (Termops.names_of_rel_context env) arg)::acc else acc ) [] arg' ty' | _ -> assert false in let is_in_b = is_free_in id b in let _keep_eq = not (List.exists (is_free_in id) args) || is_in_b || List.exists (is_free_in id) crossed_types in let new_args = List.fold_left (fun args (id,rt) -> List.map (replace_var_by_term id rt) args ) args ((id,rt)::new_args) in let subst_b = if is_in_b then b else replace_var_by_term id rt b in let new_env = let t' = Pretyping.Default.understand Evd.empty env eq' in Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname new_args new_crossed_types (depth + 1) subst_b in mkGProd(n,eq',new_b),id_to_exclude end (* J.F:. keep this comment it explain how to remove some meaningless equalities if keep_eq then mkGProd(n,t,new_b),id_to_exclude else new_b, Idset.add id id_to_exclude *) | GApp(loc1,GRef(loc2,eq_as_ref),[ty;rt1;rt2]) when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous -> begin try let l = decompose_raw_eq rt1 rt2 in if List.length l > 1 then let new_rt = List.fold_left (fun acc (lhs,rhs) -> mkGProd(Anonymous, mkGApp(mkGRef(eq_as_ref),[mkGHole ();lhs;rhs]),acc) ) b l in rebuild_cons env nb_args relname args crossed_types depth new_rt else raise Continue with Continue -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); let t' = Pretyping.Default.understand Evd.empty env t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args new_crossed_types (depth + 1) b in match n with | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude end | _ -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); let t' = Pretyping.Default.understand Evd.empty env t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args new_crossed_types (depth + 1) b in match n with | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude end | GLambda(_,n,k,t,b) -> begin let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t :: crossed_types in observe (str "computing new type for lambda : " ++ pr_glob_constr rt); let t' = Pretyping.Default.understand Evd.empty env t in match n with | Name id -> let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname (args@[mkGVar id])new_crossed_types (depth + 1 ) b in if Idset.mem id id_to_exclude && depth >= nb_args then new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude) else GProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude | _ -> anomaly "Should not have an anonymous function here" (* We have renamed all the anonymous functions during alpha_renaming phase *) end | GLetIn(_,n,t,b) -> begin let not_free_in_t id = not (is_free_in id t) in let t' = Pretyping.Default.understand Evd.empty env t in let type_t' = Typing.type_of env Evd.empty t' in let new_env = Environ.push_rel (n,Some t',type_t') env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args (t::crossed_types) (depth + 1 ) b in match n with | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) | _ -> GLetIn(dummy_loc,n,t,new_b), Idset.filter not_free_in_t id_to_exclude end | GLetTuple(_,nal,(na,rto),t,b) -> assert (rto=None); begin let not_free_in_t id = not (is_free_in id t) in let new_t,id_to_exclude' = rebuild_cons env nb_args relname args (crossed_types) depth t in let t' = Pretyping.Default.understand Evd.empty env new_t in let new_env = Environ.push_rel (na,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args (t::crossed_types) (depth + 1) b in (* match n with *) (* | Name id when Idset.mem id id_to_exclude -> *) (* new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) *) (* | _ -> *) GLetTuple(dummy_loc,nal,(na,None),t,new_b), Idset.filter not_free_in_t (Idset.union id_to_exclude id_to_exclude') end | _ -> mkGApp(mkGVar relname,args@[rt]),Idset.empty (* debuging wrapper *) let rebuild_cons env nb_args relname args crossed_types rt = (* observennl (str "rebuild_cons : rt := "++ pr_glob_constr rt ++ *) (* str "nb_args := " ++ str (string_of_int nb_args)); *) let res = rebuild_cons env nb_args relname args crossed_types 0 rt in (* observe (str " leads to "++ pr_glob_constr (fst res)); *) res (* naive implementation of parameter detection. A parameter is an argument which is only preceded by parameters and whose calls are all syntaxically equal. TODO: Find a valid way to deal with implicit arguments here! *) let rec compute_cst_params relnames params = function | GRef _ | GVar _ | GEvar _ | GPatVar _ -> params | GApp(_,GVar(_,relname'),rtl) when Idset.mem relname' relnames -> compute_cst_params_from_app [] (params,rtl) | GApp(_,f,args) -> List.fold_left (compute_cst_params relnames) params (f::args) | GLambda(_,_,_,t,b) | GProd(_,_,_,t,b) | GLetIn(_,_,t,b) | GLetTuple(_,_,_,t,b) -> let t_params = compute_cst_params relnames params t in compute_cst_params relnames t_params b | GCases _ -> params (* If there is still cases at this point they can only be discriminitation ones *) | GSort _ -> params | GHole _ -> params | GIf _ | GRec _ | GCast _ -> raise (UserError("compute_cst_params", str "Not handled case")) and compute_cst_params_from_app acc (params,rtl) = match params,rtl with | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) | ((Name id,_,is_defined) as param)::params',(GVar(_,id'))::rtl' when id_ord id id' == 0 && not is_defined -> compute_cst_params_from_app (param::acc) (params',rtl') | _ -> List.rev acc let compute_params_name relnames (args : (Names.name * Glob_term.glob_constr * bool) list array) csts = let rels_params = Array.mapi (fun i args -> List.fold_left (fun params (_,cst) -> compute_cst_params relnames params cst) args csts.(i) ) args in let l = ref [] in let _ = try list_iter_i (fun i ((n,nt,is_defined) as param) -> if array_for_all (fun l -> let (n',nt',is_defined') = List.nth l i in n = n' && Topconstr.eq_glob_constr nt nt' && is_defined = is_defined') rels_params then l := param::!l ) rels_params.(0) with e when Errors.noncritical e -> () in List.rev !l let rec rebuild_return_type rt = match rt with | Topconstr.CProdN(loc,n,t') -> Topconstr.CProdN(loc,n,rebuild_return_type t') | Topconstr.CArrow(loc,t,t') -> Topconstr.CArrow(loc,t,rebuild_return_type t') | Topconstr.CLetIn(loc,na,t,t') -> Topconstr.CLetIn(loc,na,t,rebuild_return_type t') | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,GType None)) let do_build_inductive funnames (funsargs: (Names.name * glob_constr * bool) list list) returned_types (rtl:glob_constr list) = let _time1 = System.get_time () in (* Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *) let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in let funnames = Array.of_list funnames in let funsargs = Array.of_list funsargs in let returned_types = Array.of_list returned_types in (* alpha_renaming of the body to prevent variable capture during manipulation *) let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in let rta = Array.of_list rtl_alpha in (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious i*) let relnames = Array.map mk_rel_id funnames in let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in (* Construction of the pseudo constructors *) let env = Array.fold_right (fun id env -> Environ.push_named (id,None,Typing.type_of env Evd.empty (Constrintern.global_reference id)) env ) funnames (Global.env ()) in let resa = Array.map (build_entry_lc env funnames_as_set []) rta in let env_with_graphs = let rel_arity i funargs = (* Reduilding arities (with parameters) *) let rel_first_args :(Names.name * Glob_term.glob_constr * bool ) list = funargs in List.fold_right (fun (n,t,is_defined) acc -> if is_defined then Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_glob_constr Idset.empty t, acc) else Topconstr.CProdN (dummy_loc, [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t], acc ) ) rel_first_args (rebuild_return_type returned_types.(i)) in (* We need to lift back our work topconstr but only with all information We mimick a Set Printing All. Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in Util.array_fold_left2 (fun env rel_name rel_ar -> Environ.push_named (rel_name,None, Constrintern.interp_constr Evd.empty env rel_ar) env) env relnames rel_arities in (* and of the real constructors*) let constr i res = List.map (function result (* (args',concl') *) -> let rt = compose_glob_context result.context result.value in let nb_args = List.length funsargs.(i) in (* with_full_print (fun rt -> Pp.msgnl (str "glob constr " ++ pr_glob_constr rt)) rt; *) fst ( rebuild_cons env_with_graphs nb_args relnames.(i) [] [] rt ) ) res.result in (* adding names to constructors *) let next_constructor_id = ref (-1) in let mk_constructor_id i = incr next_constructor_id; (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious i*) id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) in let rel_constructors i rt : (identifier*glob_constr) list = next_constructor_id := (-1); List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) in let rel_constructors = Array.mapi rel_constructors resa in (* Computing the set of parameters if asked *) let rels_params = compute_params_name relnames_as_set funsargs rel_constructors in let nrel_params = List.length rels_params in let rel_constructors = (* Taking into account the parameters in constructors *) Array.map (List.map (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt)))) rel_constructors in let rel_arity i funargs = (* Reduilding arities (with parameters) *) let rel_first_args :(Names.name * Glob_term.glob_constr * bool ) list = (snd (list_chop nrel_params funargs)) in List.fold_right (fun (n,t,is_defined) acc -> if is_defined then Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_glob_constr Idset.empty t, acc) else Topconstr.CProdN (dummy_loc, [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t], acc ) ) rel_first_args (rebuild_return_type returned_types.(i)) in (* We need to lift back our work topconstr but only with all information We mimick a Set Printing All. Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in let rel_params = List.map (fun (n,t,is_defined) -> if is_defined then Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_glob_constr Idset.empty t) else Topconstr.LocalRawAssum ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_glob_constr Idset.empty t) ) rels_params in let ext_rels_constructors = Array.map (List.map (fun (id,t) -> false,((dummy_loc,id), Flags.with_option Flags.raw_print (Constrextern.extern_glob_type Idset.empty) ((* zeta_normalize *) t) ) )) (rel_constructors) in let rel_ind i ext_rel_constructors = ((dummy_loc,relnames.(i)), rel_params, Some rel_arities.(i), ext_rel_constructors),[] in let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in let rel_inds = Array.to_list ext_rel_constructors in (* let _ = *) (* Pp.msgnl (\* observe *\) ( *) (* str "Inductive" ++ spc () ++ *) (* prlist_with_sep *) (* (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) *) (* (function ((_,id),_,params,ar,constr) -> *) (* Ppconstr.pr_id id ++ spc () ++ *) (* Ppconstr.pr_binders params ++ spc () ++ *) (* str ":" ++ spc () ++ *) (* Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *) (* prlist_with_sep *) (* (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *) (* (function (_,((_,id),t)) -> *) (* Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *) (* Ppconstr.pr_lconstr_expr t) *) (* constr *) (* ) *) (* rel_inds *) (* ) *) (* in *) let _time2 = System.get_time () in try with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds)) true with | UserError(s,msg) as e -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) let repacked_rel_inds = List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) rel_inds in let msg = str "while trying to define"++ spc () ++ Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) ++ fnl () ++ msg in observe (msg); raise e | reraise -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) let repacked_rel_inds = List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) rel_inds in let msg = str "while trying to define"++ spc () ++ Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) ++ fnl () ++ Errors.print reraise in observe msg; raise reraise let build_inductive funnames funsargs returned_types rtl = try do_build_inductive funnames funsargs returned_types rtl with e when Errors.noncritical e -> raise (Building_graph e) coq-8.4pl4/plugins/funind/indfun_common.ml0000644000175000017500000003773712326224777020005 0ustar stephstephopen Names open Pp open Libnames let mk_prefix pre id = id_of_string (pre^(string_of_id id)) let mk_rel_id = mk_prefix "R_" let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct" let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete" let mk_equation_id id = Nameops.add_suffix id "_equation" let msgnl m = () let invalid_argument s = raise (Invalid_argument s) let fresh_id avoid s = Namegen.next_ident_away_in_goal (id_of_string s) avoid let fresh_name avoid s = Name (fresh_id avoid s) let get_name avoid ?(default="H") = function | Anonymous -> fresh_name avoid default | Name n -> Name n let array_get_start a = try Array.init (Array.length a - 1) (fun i -> a.(i)) with Invalid_argument "index out of bounds" -> invalid_argument "array_get_start" let id_of_name = function Name id -> id | _ -> raise Not_found let locate ref = let (loc,qid) = qualid_of_reference ref in Nametab.locate qid let locate_ind ref = match locate ref with | IndRef x -> x | _ -> raise Not_found let locate_constant ref = match locate ref with | ConstRef x -> x | _ -> raise Not_found let locate_with_msg msg f x = try f x with | Not_found -> raise (Util.UserError("", msg)) let filter_map filter f = let rec it = function | [] -> [] | e::l -> if filter e then (f e) :: it l else it l in it let chop_rlambda_n = let rec chop_lambda_n acc n rt = if n == 0 then List.rev acc,rt else match rt with | Glob_term.GLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b | Glob_term.GLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b | _ -> raise (Util.UserError("chop_rlambda_n", str "chop_rlambda_n: Not enough Lambdas")) in chop_lambda_n [] let chop_rprod_n = let rec chop_prod_n acc n rt = if n == 0 then List.rev acc,rt else match rt with | Glob_term.GProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b | _ -> raise (Util.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products")) in chop_prod_n [] let list_union_eq eq_fun l1 l2 = let rec urec = function | [] -> l2 | a::l -> if List.exists (eq_fun a) l2 then urec l else a::urec l in urec l1 let list_add_set_eq eq_fun x l = if List.exists (eq_fun x) l then l else x::l let const_of_id id = let _,princ_ref = qualid_of_reference (Libnames.Ident (Util.dummy_loc,id)) in try Nametab.locate_constant princ_ref with Not_found -> Util.error ("cannot find "^ string_of_id id) let def_of_const t = match (Term.kind_of_term t) with Term.Const sp -> (try (match Declarations.body_of_constant (Global.lookup_constant sp) with | Some c -> Declarations.force c | _ -> assert false) with e when Errors.noncritical e -> assert false) |_ -> assert false let coq_constant s = Coqlib.gen_constant_in_modules "RecursiveDefinition" Coqlib.init_modules s;; let constant sl s = constr_of_global (Nametab.locate (make_qualid(Names.make_dirpath (List.map id_of_string (List.rev sl))) (id_of_string s)));; let find_reference sl s = (Nametab.locate (make_qualid(Names.make_dirpath (List.map id_of_string (List.rev sl))) (id_of_string s)));; let eq = lazy(coq_constant "eq") let refl_equal = lazy(coq_constant "eq_refl") (*****************************************************************) (* Copy of the standart save mechanism but without the much too *) (* slow reduction function *) (*****************************************************************) open Declarations open Entries open Decl_kinds open Declare let definition_message id = Flags.if_verbose message ((string_of_id id) ^ " is defined") let save with_clean id const (locality,kind) hook = let {const_entry_body = pft; const_entry_secctx = _; const_entry_type = tpo; const_entry_opaque = opacity } = const in let l,r = match locality with | Local when Lib.sections_are_opened () -> let k = logical_kind_of_goal_kind kind in let c = SectionLocalDef (pft, tpo, opacity) in let _ = declare_variable id (Lib.cwd(), c, k) in (Local, VarRef id) | Local -> let k = logical_kind_of_goal_kind kind in let kn = declare_constant id (DefinitionEntry const, k) in (Global, ConstRef kn) | Global -> let k = logical_kind_of_goal_kind kind in let kn = declare_constant id (DefinitionEntry const, k) in (Global, ConstRef kn) in if with_clean then Pfedit.delete_current_proof (); hook l r; definition_message id let cook_proof _ = let (id,(entry,_,strength,hook)) = Pfedit.cook_proof (fun _ -> ()) in (id,(entry,strength,hook)) let new_save_named opacity = let id,(const,persistence,hook) = cook_proof true in let const = { const with const_entry_opaque = opacity } in save true id const persistence hook let get_proof_clean do_reduce = let result = cook_proof do_reduce in Pfedit.delete_current_proof (); result let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () and old_strict_implicit_args = Impargs.is_strict_implicit_args () and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in let old_rawprint = !Flags.raw_print in Flags.raw_print := true; Impargs.make_implicit_args false; Impargs.make_strict_implicit_args false; Impargs.make_contextual_implicit_args false; Impargs.make_contextual_implicit_args false; Dumpglob.pause (); try let res = f a in Impargs.make_implicit_args old_implicit_args; Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; Dumpglob.continue (); res with | reraise -> Impargs.make_implicit_args old_implicit_args; Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; Dumpglob.continue (); raise reraise (**********************) type function_info = { function_constant : constant; graph_ind : inductive; equation_lemma : constant option; correctness_lemma : constant option; completeness_lemma : constant option; rect_lemma : constant option; rec_lemma : constant option; prop_lemma : constant option; is_general : bool; (* Has this function been defined using general recursive definition *) } (* type function_db = function_info list *) (* let function_table = ref ([] : function_db) *) let from_function = ref Cmap.empty let from_graph = ref Indmap.empty (* let rec do_cache_info finfo = function | [] -> raise Not_found | (finfo'::finfos as l) -> if finfo' == finfo then l else if finfo'.function_constant = finfo.function_constant then finfo::finfos else let res = do_cache_info finfo finfos in if res == finfos then l else finfo'::l let cache_Function (_,(finfos)) = let new_tbl = try do_cache_info finfos !function_table with Not_found -> finfos::!function_table in if new_tbl != !function_table then function_table := new_tbl *) let cache_Function (_,finfos) = from_function := Cmap.add finfos.function_constant finfos !from_function; from_graph := Indmap.add finfos.graph_ind finfos !from_graph let load_Function _ = cache_Function let open_Function _ = cache_Function let subst_Function (subst,finfos) = let do_subst_con c = fst (Mod_subst.subst_con subst c) and do_subst_ind (kn,i) = (Mod_subst.subst_ind subst kn,i) in let function_constant' = do_subst_con finfos.function_constant in let graph_ind' = do_subst_ind finfos.graph_ind in let equation_lemma' = Option.smartmap do_subst_con finfos.equation_lemma in let correctness_lemma' = Option.smartmap do_subst_con finfos.correctness_lemma in let completeness_lemma' = Option.smartmap do_subst_con finfos.completeness_lemma in let rect_lemma' = Option.smartmap do_subst_con finfos.rect_lemma in let rec_lemma' = Option.smartmap do_subst_con finfos.rec_lemma in let prop_lemma' = Option.smartmap do_subst_con finfos.prop_lemma in if function_constant' == finfos.function_constant && graph_ind' == finfos.graph_ind && equation_lemma' == finfos.equation_lemma && correctness_lemma' == finfos.correctness_lemma && completeness_lemma' == finfos.completeness_lemma && rect_lemma' == finfos.rect_lemma && rec_lemma' == finfos.rec_lemma && prop_lemma' == finfos.prop_lemma then finfos else { function_constant = function_constant'; graph_ind = graph_ind'; equation_lemma = equation_lemma' ; correctness_lemma = correctness_lemma' ; completeness_lemma = completeness_lemma' ; rect_lemma = rect_lemma' ; rec_lemma = rec_lemma'; prop_lemma = prop_lemma'; is_general = finfos.is_general } let classify_Function infos = Libobject.Substitute infos let discharge_Function (_,finfos) = let function_constant' = Lib.discharge_con finfos.function_constant and graph_ind' = Lib.discharge_inductive finfos.graph_ind and equation_lemma' = Option.smartmap Lib.discharge_con finfos.equation_lemma and correctness_lemma' = Option.smartmap Lib.discharge_con finfos.correctness_lemma and completeness_lemma' = Option.smartmap Lib.discharge_con finfos.completeness_lemma and rect_lemma' = Option.smartmap Lib.discharge_con finfos.rect_lemma and rec_lemma' = Option.smartmap Lib.discharge_con finfos.rec_lemma and prop_lemma' = Option.smartmap Lib.discharge_con finfos.prop_lemma in if function_constant' == finfos.function_constant && graph_ind' == finfos.graph_ind && equation_lemma' == finfos.equation_lemma && correctness_lemma' == finfos.correctness_lemma && completeness_lemma' == finfos.completeness_lemma && rect_lemma' == finfos.rect_lemma && rec_lemma' == finfos.rec_lemma && prop_lemma' == finfos.prop_lemma then Some finfos else Some { function_constant = function_constant' ; graph_ind = graph_ind' ; equation_lemma = equation_lemma' ; correctness_lemma = correctness_lemma' ; completeness_lemma = completeness_lemma'; rect_lemma = rect_lemma'; rec_lemma = rec_lemma'; prop_lemma = prop_lemma' ; is_general = finfos.is_general } open Term let pr_info f_info = str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++ str "function_constant_type := " ++ (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) with e when Errors.noncritical e -> mt ()) ++ fnl () ++ str "equation_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++ str "completeness_lemma :=" ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++ str "correctness_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++ str "rect_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++ str "rec_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++ str "prop_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++ str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () let pr_table tb = let l = Cmap.fold (fun k v acc -> v::acc) tb [] in Util.prlist_with_sep fnl pr_info l let in_Function : function_info -> Libobject.obj = Libobject.declare_object {(Libobject.default_object "FUNCTIONS_DB") with Libobject.cache_function = cache_Function; Libobject.load_function = load_Function; Libobject.classify_function = classify_Function; Libobject.subst_function = subst_Function; Libobject.discharge_function = discharge_Function (* Libobject.open_function = open_Function; *) } (* Synchronisation with reset *) let freeze () = !from_function,!from_graph let unfreeze (functions,graphs) = (* Pp.msgnl (str "unfreezing function_table : " ++ pr_table l); *) from_function := functions; from_graph := graphs let init () = (* Pp.msgnl (str "reseting function_table"); *) from_function := Cmap.empty; from_graph := Indmap.empty let _ = Summary.declare_summary "functions_db_sum" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = init } let find_or_none id = try Some (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant" ) with Not_found -> None let find_Function_infos f = Cmap.find f !from_function let find_Function_of_graph ind = Indmap.find ind !from_graph let update_Function finfo = (* Pp.msgnl (pr_info finfo); *) Lib.add_anonymous_leaf (in_Function finfo) let add_Function is_general f = let f_id = id_of_label (con_label f) in let equation_lemma = find_or_none (mk_equation_id f_id) and correctness_lemma = find_or_none (mk_correct_id f_id) and completeness_lemma = find_or_none (mk_complete_id f_id) and rect_lemma = find_or_none (Nameops.add_suffix f_id "_rect") and rec_lemma = find_or_none (Nameops.add_suffix f_id "_rec") and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind") and graph_ind = match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) with | IndRef ind -> ind | _ -> Util.anomaly "Not an inductive" in let finfos = { function_constant = f; equation_lemma = equation_lemma; completeness_lemma = completeness_lemma; correctness_lemma = correctness_lemma; rect_lemma = rect_lemma; rec_lemma = rec_lemma; prop_lemma = prop_lemma; graph_ind = graph_ind; is_general = is_general } in update_Function finfos let pr_table () = pr_table !from_function (*********************************) (* Debuging *) let functional_induction_rewrite_dependent_proofs = ref true let function_debug = ref false open Goptions let functional_induction_rewrite_dependent_proofs_sig = { optsync = false; optdepr = false; optname = "Functional Induction Rewrite Dependent"; optkey = ["Functional";"Induction";"Rewrite";"Dependent"]; optread = (fun () -> !functional_induction_rewrite_dependent_proofs); optwrite = (fun b -> functional_induction_rewrite_dependent_proofs := b) } let _ = declare_bool_option functional_induction_rewrite_dependent_proofs_sig let do_rewrite_dependent () = !functional_induction_rewrite_dependent_proofs = true let function_debug_sig = { optsync = false; optdepr = false; optname = "Function debug"; optkey = ["Function_debug"]; optread = (fun () -> !function_debug); optwrite = (fun b -> function_debug := b) } let _ = declare_bool_option function_debug_sig let do_observe () = !function_debug = true let strict_tcc = ref false let is_strict_tcc () = !strict_tcc let strict_tcc_sig = { optsync = false; optdepr = false; optname = "Raw Function Tcc"; optkey = ["Function_raw_tcc"]; optread = (fun () -> !strict_tcc); optwrite = (fun b -> strict_tcc := b) } let _ = declare_bool_option strict_tcc_sig exception Building_graph of exn exception Defining_principle of exn exception ToShow of exn let init_constant dir s = try Coqlib.gen_constant "Function" dir s with e when Errors.noncritical e -> raise (ToShow e) let jmeq () = try (Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq") with e when Errors.noncritical e -> raise (ToShow e) let jmeq_rec () = try Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq_rec" with e when Errors.noncritical e -> raise (ToShow e) let jmeq_refl () = try Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq_refl" with e when Errors.noncritical e -> raise (ToShow e) coq-8.4pl4/plugins/funind/indfun_common.mli0000644000175000017500000000620712326224777020142 0ustar stephstephopen Names open Pp (* The mk_?_id function build different name w.r.t. a function Each of their use is justified in the code *) val mk_rel_id : identifier -> identifier val mk_correct_id : identifier -> identifier val mk_complete_id : identifier -> identifier val mk_equation_id : identifier -> identifier val msgnl : std_ppcmds -> unit val invalid_argument : string -> 'a val fresh_id : identifier list -> string -> identifier val fresh_name : identifier list -> string -> name val get_name : identifier list -> ?default:string -> name -> name val array_get_start : 'a array -> 'a array val id_of_name : name -> identifier val locate_ind : Libnames.reference -> inductive val locate_constant : Libnames.reference -> constant val locate_with_msg : Pp.std_ppcmds -> (Libnames.reference -> 'a) -> Libnames.reference -> 'a val filter_map : ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list val list_union_eq : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list val list_add_set_eq : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list val chop_rlambda_n : int -> Glob_term.glob_constr -> (name*Glob_term.glob_constr*bool) list * Glob_term.glob_constr val chop_rprod_n : int -> Glob_term.glob_constr -> (name*Glob_term.glob_constr) list * Glob_term.glob_constr val def_of_const : Term.constr -> Term.constr val eq : Term.constr Lazy.t val refl_equal : Term.constr Lazy.t val const_of_id: identifier -> constant val jmeq : unit -> Term.constr val jmeq_refl : unit -> Term.constr (* [save_named] is a copy of [Command.save_named] but uses [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast] *) val new_save_named : bool -> unit val save : bool -> identifier -> Entries.definition_entry -> Decl_kinds.goal_kind -> Tacexpr.declaration_hook -> unit (* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and abort the proof *) val get_proof_clean : bool -> Names.identifier * (Entries.definition_entry * Decl_kinds.goal_kind * Tacexpr.declaration_hook) (* [with_full_print f a] applies [f] to [a] in full printing environment This function preserves the print settings *) val with_full_print : ('a -> 'b) -> 'a -> 'b (*****************) type function_info = { function_constant : constant; graph_ind : inductive; equation_lemma : constant option; correctness_lemma : constant option; completeness_lemma : constant option; rect_lemma : constant option; rec_lemma : constant option; prop_lemma : constant option; is_general : bool; } val find_Function_infos : constant -> function_info val find_Function_of_graph : inductive -> function_info (* WARNING: To be used just after the graph definition !!! *) val add_Function : bool -> constant -> unit val update_Function : function_info -> unit (** debugging *) val pr_info : function_info -> Pp.std_ppcmds val pr_table : unit -> Pp.std_ppcmds (* val function_debug : bool ref *) val do_observe : unit -> bool val do_rewrite_dependent : unit -> bool (* To localize pb *) exception Building_graph of exn exception Defining_principle of exn exception ToShow of exn val is_strict_tcc : unit -> bool coq-8.4pl4/plugins/funind/indfun.mli0000644000175000017500000000100012326224777016554 0ustar stephstephopen Util open Names open Term open Pp open Indfun_common open Libnames open Glob_term open Declarations val do_generate_principle : bool -> (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> unit val functional_induction : bool -> Term.constr -> (Term.constr * Term.constr Glob_term.bindings) option -> Genarg.intro_pattern_expr Util.located option -> Proof_type.goal Tacmach.sigma -> Proof_type.goal list Evd.sigma val make_graph : Libnames.global_reference -> unit coq-8.4pl4/plugins/xml/0000755000175000017500000000000012326224777014114 5ustar stephstephcoq-8.4pl4/plugins/xml/doubleTypeInference.ml0000644000175000017500000002511412326224777020404 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Some {Environ.utj_val = j.Environ.uj_val; Environ.utj_type = s } | _ -> None (* None means the CProp constant *) ;; let double_type_of env sigma cstr expectedty subterms_to_types = (*CSC: the code is inefficient because judgments are created just to be *) (*CSC: destroyed using Environ.j_type. Moreover I am pretty sure that the *) (*CSC: functions used do checks that we do not need *) let rec execute env sigma cstr expectedty = let module T = Term in let module E = Environ in (* the type part is the synthesized type *) let judgement = match T.kind_of_term cstr with T.Meta n -> Util.error "DoubleTypeInference.double_type_of: found a non-instanciated goal" | T.Evar ((n,l) as ev) -> let ty = Unshare.unshare (Evd.existential_type sigma ev) in let jty = execute env sigma ty None in let jty = assumption_of_judgment env sigma jty in let evar_context = E.named_context_of_val (Evd.find sigma n).Evd.evar_hyps in let rec iter actual_args evar_context = match actual_args,evar_context with [],[] -> () | he1::tl1,(n,_,ty)::tl2 -> (* for side-effects *) let _ = execute env sigma he1 (Some ty) in let tl2' = List.map (function (m,bo,ty) -> (* Warning: the substitution should be performed also on bo *) (* This is not done since bo is not used later yet *) (m,bo,Unshare.unshare (T.replace_vars [n,he1] ty)) ) tl2 in iter tl1 tl2' | _,_ -> assert false in (* for side effects only *) iter (List.rev (Array.to_list l)) (List.rev evar_context) ; E.make_judge cstr jty | T.Rel n -> Typeops.judge_of_relative env n | T.Var id -> Typeops.judge_of_variable env id | T.Const c -> E.make_judge cstr (Typeops.type_of_constant env c) | T.Ind ind -> E.make_judge cstr (Inductiveops.type_of_inductive env ind) | T.Construct cstruct -> E.make_judge cstr (Inductiveops.type_of_constructor env cstruct) | T.Case (ci,p,c,lf) -> let expectedtype = Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma c) in let cj = execute env sigma c (Some expectedtype) in let pj = execute env sigma p None in let (expectedtypes,_,_) = let indspec = Inductive.find_rectype env cj.Environ.uj_type in Inductive.type_case_branches env indspec pj cj.Environ.uj_val in let lfj = execute_array env sigma lf (Array.map (function x -> Some x) expectedtypes) in let (j,_) = Typeops.judge_of_case env ci pj cj lfj in j | T.Fix ((vn,i as vni),recdef) -> let (_,tys,_ as recdef') = execute_recdef env sigma recdef in let fix = (vni,recdef') in E.make_judge (T.mkFix fix) tys.(i) | T.CoFix (i,recdef) -> let (_,tys,_ as recdef') = execute_recdef env sigma recdef in let cofix = (i,recdef') in E.make_judge (T.mkCoFix cofix) tys.(i) | T.Sort (T.Prop c) -> Typeops.judge_of_prop_contents c | T.Sort (T.Type u) -> (*CSC: In case of need, I refresh the universe. But exportation of the *) (*CSC: right universe level information is destroyed. It must be changed *) (*CSC: again once Judicael will introduce his non-bugged algebraic *) (*CSC: universes. *) (try Typeops.judge_of_type u with e when e <> Sys.Break -> (* Successor of a non universe-variable universe anomaly *) (Pp.ppnl (Pp.str "Warning: universe refresh performed!!!") ; flush stdout ) ; Typeops.judge_of_type (Termops.new_univ ()) ) | T.App (f,args) -> let expected_head = Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma f) in let j = execute env sigma f (Some expected_head) in let expected_args = let rec aux typ = function [] -> [] | hj::restjl -> match T.kind_of_term (Reduction.whd_betadeltaiota env typ) with T.Prod (_,c1,c2) -> (Some (Reductionops.nf_beta sigma c1)) :: (aux (T.subst1 hj c2) restjl) | _ -> assert false in Array.of_list (aux j.Environ.uj_type (Array.to_list args)) in let jl = execute_array env sigma args expected_args in let (j,_) = Typeops.judge_of_apply env j jl in j | T.Lambda (name,c1,c2) -> let j = execute env sigma c1 None in let var = type_judgment env sigma j in let env1 = E.push_rel (name,None,var.E.utj_val) env in let expectedc2type = match expectedty with None -> None | Some ety -> match T.kind_of_term (Reduction.whd_betadeltaiota env ety) with T.Prod (_,_,expected_target_type) -> Some (Reductionops.nf_beta sigma expected_target_type) | _ -> assert false in let j' = execute env1 sigma c2 expectedc2type in Typeops.judge_of_abstraction env1 name var j' | T.Prod (name,c1,c2) -> let j = execute env sigma c1 None in let varj = type_judgment env sigma j in let env1 = E.push_rel (name,None,varj.E.utj_val) env in let j' = execute env1 sigma c2 None in (match type_judgment_cprop env1 sigma j' with Some varj' -> Typeops.judge_of_product env name varj varj' | None -> (* CProp found *) { Environ.uj_val = T.mkProd (name, j.Environ.uj_val, j'.Environ.uj_val); Environ.uj_type = T.mkConst cprop }) | T.LetIn (name,c1,c2,c3) -> (*CSC: What are the right expected types for the source and *) (*CSC: target of a LetIn? None used. *) let j1 = execute env sigma c1 None in let j2 = execute env sigma c2 None in let j2 = type_judgment env sigma j2 in let env1 = E.push_rel (name,Some j1.E.uj_val,j2.E.utj_val) env in let j3 = execute env1 sigma c3 None in Typeops.judge_of_letin env name j1 j2 j3 | T.Cast (c,k,t) -> let cj = execute env sigma c (Some (Reductionops.nf_beta sigma t)) in let tj = execute env sigma t None in let tj = type_judgment env sigma tj in let j, _ = Typeops.judge_of_cast env cj k tj in j in let synthesized = E.j_type judgement in let synthesized' = Reductionops.nf_beta sigma synthesized in let types,res = match expectedty with None -> (* No expected type *) {synthesized = synthesized' ; expected = None}, synthesized | Some ty when Term.eq_constr synthesized' ty -> (* The expected type is synthactically equal to the *) (* synthesized type. Let's forget it. *) (* Note: since eq_constr is up to casts, it is better *) (* to keep the expected type, since it can bears casts *) (* that change the innersort to CProp *) {synthesized = ty ; expected = None}, ty | Some expectedty' -> {synthesized = synthesized' ; expected = Some expectedty'}, expectedty' in (*CSC: debugging stuff to be removed *) if Acic.CicHash.mem subterms_to_types cstr then (Pp.ppnl (Pp.(++) (Pp.str "DUPLICATE INSERTION: ") (Printer.pr_lconstr cstr)) ; flush stdout ) ; Acic.CicHash.add subterms_to_types cstr types ; E.make_judge cstr res and execute_recdef env sigma (names,lar,vdef) = let length = Array.length lar in let larj = execute_array env sigma lar (Array.make length None) in let lara = Array.map (assumption_of_judgment env sigma) larj in let env1 = Environ.push_rec_types (names,lara,vdef) env in let expectedtypes = Array.map (function i -> Some (Term.lift length i)) lar in let vdefj = execute_array env1 sigma vdef expectedtypes in let vdefv = Array.map Environ.j_val vdefj in (names,lara,vdefv) and execute_array env sigma v expectedtypes = let jl = execute_list env sigma (Array.to_list v) (Array.to_list expectedtypes) in Array.of_list jl and execute_list env sigma = List.map2 (execute env sigma) in ignore (execute env sigma cstr expectedty) ;; coq-8.4pl4/plugins/xml/cic.dtd0000644000175000017500000001644012326224777015354 0ustar stephsteph coq-8.4pl4/plugins/xml/xml.ml40000644000175000017500000000615412326224777015340 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ] let xml_nempty name attrs content = [< 'NEmpty(name,attrs,content) >] let xml_cdata str = [< 'Str str >] (* Usage: *) (* pp tokens None pretty prints the output on stdout *) (* pp tokens (Some filename) pretty prints the output on the file filename *) let pp_ch strm channel = let rec pp_r m = parser [< 'Str a ; s >] -> print_spaces m ; fprint_string (a ^ "\n") ; pp_r m s | [< 'Empty(n,l) ; s >] -> print_spaces m ; fprint_string ("<" ^ n) ; List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l; fprint_string "/>\n" ; pp_r m s | [< 'NEmpty(n,l,c) ; s >] -> print_spaces m ; fprint_string ("<" ^ n) ; List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l; fprint_string ">\n" ; pp_r (m+1) c ; print_spaces m ; fprint_string ("\n") ; pp_r m s | [< >] -> () and print_spaces m = for i = 1 to m do fprint_string " " done and fprint_string str = output_string channel str in pp_r 0 strm ;; let pp strm fn = match fn with Some filename -> let filename = filename ^ ".xml" in let ch = open_out filename in pp_ch strm ch; close_out ch ; print_string ("\nWriting on file \"" ^ filename ^ "\" was successful\n"); flush stdout | None -> pp_ch strm stdout ;; coq-8.4pl4/plugins/xml/xmlentries.ml40000644000175000017500000000261512326224777016730 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ Some fn ] | [ ] -> [ None ] END (* Print XML and Show XML *) VERNAC COMMAND EXTEND Xml | [ "Print" "XML" filename(fn) global(qid) ] -> [ Xmlcommand.print_ref qid fn ] | [ "Show" "XML" filename(fn) "Proof" ] -> [ Xmlcommand.show fn ] END coq-8.4pl4/plugins/xml/README0000644000175000017500000002630012326224777014775 0ustar stephsteph(******************************************************************************) (* Copyright (C) 2000-2004, Claudio Sacerdoti Coen *) (* Project Helm (http://helm.cs.unibo.it) *) (* Project MoWGLI (http://mowgli.cs.unibo.it) *) (* *) (* Coq Exportation to XML *) (* *) (******************************************************************************) This module provides commands to export a piece of Coq library in XML format. Only the information relevant to proof-checking and proof-rendering is exported, i.e. only the CIC proof objects (lambda-terms). This document is tructured in the following way: 1. User documentation 1.1. New vernacular commands available 1.2. New coqc/coqtop flags and suggested usage 1.3. How to exploit the XML files 2. Technical informations 2.1. Inner-types 2.2. CIC with Explicit Named Substitutions 2.3. The CIC with Explicit Named Substitutions XML DTD ================================================================================ USER DOCUMENTATION ================================================================================ ======================================= 1.1. New vernacular commands available: ======================================= The new commands are: Print XML qualid. It prints in XML (to standard output) the object whose qualified name is qualid and its inner-types (see Sect. 2.1). The inner-types are always printed in their own XML file. If the object is a constant, its type and body are also printed as two distinct XML files. The object printed is always the most discharged form of the object (see the Section command of the Coq manual). Print XML File "filename" qualid. Similar to "Print XML qualid". The generated files are stored on the hard-disk using the base file name "filename". Show XML Proof. It prints in XML the current proof in progress. Its inner-types are also printed. Show XML File "filename" Proof. Similar to "Show XML Proof". The generated files are stored on the hard-disk using the base file name "filename". The verbosity of the previous commands is raised if the configuration parameter verbose of xmlcommand.ml is set to true at compile time. ============================================== 1.2. New coqc/coqtop flags and suggested usage ============================================== The following flag has been added to coqc and coqtop: -xml export XML files either to the hierarchy rooted in the directory $COQ_XML_LIBRARY_ROOT (if the environment variable is set) or to stdout (if unset) If the flag is set, every definition or declaration is immediately exported to XML. The XML files describe the user-provided non-discharged form of the definition or declaration. The coq_makefile utility has also been modified to easily allow XML exportation: make COQ_XML=-xml (or, equivalently, setting the environment variable COQ_XML) The suggested usage of the module is the following: 1. add to your own contribution a valid Make file and use coq_makefile to generate the Makefile from the Make file. *WARNING:* Since logical names are used to structure the XML hierarchy, always add to the Make file at least one "-R" option to map physical file names to logical module paths. See the Coq manual for further informations on the -R flag. 2. set $COQ_XML_LIBRARY_ROOT to the directory where the XML file hierarchy must be physically rooted. 3. compile your contribution with "make COQ_XML=-xml" ================================= 1.3. How to exploit the XML files ================================= Once the information is exported to XML, it becomes possible to implement services that are completely Coq-independent. Projects HELM and MoWGLI already provide rendering, searching and data mining functionalities. In particular, the standard library and contributions of Coq can be browsed and searched on the HELM web site: http://helm.cs.unibo.it/library.html If you want to publish your own contribution so that it is included in the HELM library, use the MoWGLI prototype upload form: http://mowgli.cs.unibo.it ================================================================================ TECHNICAL INFORMATIONS ================================================================================ ========================== 2.1. Inner-types ========================== In order to do proof-rendering (for example in natural language), some redundant typing information is required, i.e. the type of at least some of the subterms of the bodies and types. So, each new command described in section 1.1 print not only the object, but also another XML file in which you can find the type of all the subterms of the terms of the printed object which respect the following conditions: 1. It's sort is Prop or CProp (the "sort"-like definition used in CoRN to type computationally relevant predicative propositions). 2. It is not a cast or an atomic term, i.e. it's root is not a CAST, REL, VAR, MUTCONSTR or CONST. 3. If it's root is a LAMBDA, then the root's parent node is not a LAMBDA, i.e. only the type of the outer LAMBDA of a block of nested LAMBDAs is printed. The rationale for the 3rd condition is that the type of the inner LAMBDAs could be easily computed starting from the type of the outer LAMBDA; moreover, the types of the inner LAMBDAs requires a lot of disk/memory space: removing the 3rd condition leads to XML file that are two times as big as the ones exported appling the 3rd condition. ========================================== 2.2. CIC with Explicit Named Substitutions ========================================== The exported files are and XML encoding of the lambda-terms used by the Coq system. The implementative details of the Coq system are hidden as much as possible, so that the XML DTD is a straightforward encoding of the Calculus of (Co)Inductive Constructions. Nevertheless, there is a feature of the Coq system that can not be hidden in a completely satisfactory way: discharging. In Coq it is possible to open a section, declare variables and use them in the rest of the section as if they were axiom declarations. Once the section is closed, every definition and theorem in the section is discharged by abstracting it over the section variables. Variable declarations as well as section declarations are entirely dropped. Since we are interested in an XML encoding of definitions and theorems as close as possible to those directly provided the user, we do not want to export discharged forms. Exporting non-discharged theorem and definitions together with theorems that rely on the discharged forms obliges the tools that work on the XML encoding to implement discharging to achieve logical consistency. Moreover, the rendering of the files can be misleading, since hyperlinks can be shown between occurrences of the discharge form of a definition and the non-discharged definition, that are different objects. To overcome the previous limitations, Claudio Sacerdoti Coen developed in his PhD. thesis an extension of CIC, called Calculus of (Co)Inductive Constructions with Explicit Named Substitutions, that is a slight extension of CIC where discharging is not necessary. The DTD of the exported XML files describes constants, inductive types and variables of the Calculus of (Co)Inductive Constructions with Explicit Named Substitions. The conversion to the new calculus is performed during the exportation phase. The following example shows a very small Coq development together with its version in CIC with Explicit Named Substitutions. # CIC version: # Section S. Variable A : Prop. Definition impl := A -> A. Theorem t : impl. (* uses the undischarged form of impl *) Proof. exact (fun (a:A) => a). Qed. End S. Theorem t' : (impl False). (* uses the discharged form of impl *) Proof. exact (t False). (* uses the discharged form of t *) Qed. # Corresponding CIC with Explicit Named Substitutions version: # Section S. Variable A : Prop. Definition impl(A) := A -> A. (* theorems and definitions are explicitly abstracted over the variables. The name is sufficient to completely describe the abstraction *) Theorem t(A) : impl. (* impl where A is not instantiated *) Proof. exact (fun (a:A) => a). Qed. End S. Theorem t'() : impl{False/A}. (* impl where A is instantiated with False Notice that t' does not depend on A *) Proof. exact t{False/A}. (* t where A is instantiated with False *) Qed. Further details on the typing and reduction rules of the calculus can be found in Claudio Sacerdoti Coen PhD. dissertation, where the consistency of the calculus is also proved. ====================================================== 2.3. The CIC with Explicit Named Substitutions XML DTD ====================================================== A copy of the DTD can be found in the file "cic.dtd". is the root element of the files that correspond to constant types. is the root element of the files that correspond to constant bodies. It is used only for closed definitions and theorems (i.e. when no metavariable occurs in the body or type of the constant) is the root element of the file that correspond to the body of a constant that depends on metavariables (e.g. unfinished proofs) is the root element of the files that correspond to variables is the root element of the files that correspond to blocks of mutually defined inductive definitions The elements ,,,,,,,, ,, ,,,, and are used to encode the constructors of CIC. The sort or type attribute of the element, if present, is respectively the sort or the type of the term, that is a sort because of the typing rules of CIC. The element correspond to the application of an explicit named substitution to its first argument, that is a reference to a definition or declaration in the environment. All the other elements are just syntactic sugar. coq-8.4pl4/plugins/xml/xmlcommand.mli0000644000175000017500000000434512326224777016764 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string option -> unit (* show dest *) (* where dest is either None (for stdout) or (Some filename) *) (* pretty prints via Xml.pp the proof in progress on dest *) val show : string option -> unit (* set_print_proof_tree f *) (* sets a callback function f to export the proof_tree to XML *) val set_print_proof_tree : (string -> Evd.evar_map -> Proof_type.proof_tree -> Term.constr Proof2aproof.ProofTreeHash.t -> Proof_type.proof_tree Proof2aproof.ProofTreeHash.t -> string Acic.CicHash.t -> Xml.token Stream.t) -> unit coq-8.4pl4/plugins/xml/proof2aproof.ml0000644000175000017500000000571612326224777017075 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t | T.Cast (c1,k,c2) -> T.mkCast (aux c1, k, aux c2) | T.Prod (na,c1,c2) -> T.mkProd (na, aux c1, aux c2) | T.Lambda (na,t,c) -> T.mkLambda (na, aux t, aux c) | T.LetIn (na,b,t,c) -> T.mkLetIn (na, aux b, aux t, aux c) | T.App (c,l) -> let c' = aux c in let l' = Array.map aux l in (match T.kind_of_term c' with T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l') | T.Cast (he,_,_) -> (match T.kind_of_term he with T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l') | _ -> T.mkApp (c', l') ) | _ -> T.mkApp (c', l')) | T.Evar (e,l) when Evd.mem sigma e & Evd.is_defined sigma e -> aux (Evd.existential_value sigma (e,l)) | T.Evar (e,l) -> T.mkEvar (e, Array.map aux l) | T.Case (ci,p,c,bl) -> T.mkCase (ci, aux p, aux c, Array.map aux bl) | T.Fix (ln,(lna,tl,bl)) -> T.mkFix (ln,(lna,Array.map aux tl,Array.map aux bl)) | T.CoFix(ln,(lna,tl,bl)) -> T.mkCoFix (ln,(lna,Array.map aux tl,Array.map aux bl)) in aux ;; module ProofTreeHash = Hashtbl.Make (struct type t = Proof_type.proof_tree let equal = (==) let hash = Hashtbl.hash end) ;; let extract_open_proof sigma pf = (* Deactivated and candidate for removal. (Apr. 2010) *) () let extract_open_pftreestate pts = (* Deactivated and candidate for removal. (Apr. 2010) *) () coq-8.4pl4/plugins/xml/proofTree2Xml.ml40000644000175000017500000001717112326224777017251 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* not (List.mem n real_named_context)) named_context in let idrefs = List.map (function x,_,_ -> idref_of_id (Names.string_of_id x)) named_context' in let rel_context = Sign.push_named_to_rel_context named_context' [] in let rel_env = Environ.push_rel_context rel_context (Environ.reset_with_named_context (Environ.val_of_named_context real_named_context) env) in let obj' = Term.subst_vars (List.map (function (i,_,_) -> i) named_context') obj in let seed = ref 0 in try let annobj = Cic2acic.acic_of_cic_context' false seed ids_to_terms constr_to_ids ids_to_father_ids ids_to_inner_sorts ids_to_inner_types rel_env idrefs sigma (Unshare.unshare obj') None in Acic2Xml.print_term ids_to_inner_sorts annobj with e -> Util.anomaly ("Problem during the conversion of constr into XML: " ^ Printexc.to_string e) (* CSC: debugging stuff Pp.ppnl (Pp.str "Problem during the conversion of constr into XML") ; Pp.ppnl (Pp.str "ENVIRONMENT:") ; Pp.ppnl (Printer.pr_context_of rel_env) ; Pp.ppnl (Pp.str "TERM:") ; Pp.ppnl (Printer.pr_lconstr_env rel_env obj') ; Pp.ppnl (Pp.str "RAW-TERM:") ; Pp.ppnl (Printer.pr_lconstr obj') ; Xml.xml_empty "MISSING TERM" [] (*; raise e*) *) ;; let first_word s = try let i = String.index s ' ' in String.sub s 0 i with _ -> s ;; let string_of_prim_rule x = match x with | Proof_type.Intro _-> "Intro" | Proof_type.Cut _ -> "Cut" | Proof_type.FixRule _ -> "FixRule" | Proof_type.Cofix _ -> "Cofix" | Proof_type.Refine _ -> "Refine" | Proof_type.Convert_concl _ -> "Convert_concl" | Proof_type.Convert_hyp _->"Convert_hyp" | Proof_type.Thin _ -> "Thin" | Proof_type.ThinBody _-> "ThinBody" | Proof_type.Move (_,_,_) -> "Move" | Proof_type.Order _ -> "Order" | Proof_type.Rename (_,_) -> "Rename" | Proof_type.Change_evars -> "Change_evars" let print_proof_tree curi sigma pf proof_tree_to_constr proof_tree_to_flattened_proof_tree constr_to_ids = let module PT = Proof_type in let module L = Logic in let module X = Xml in let module T = Tacexpr in let ids_of_node node = let constr = Proof2aproof.ProofTreeHash.find proof_tree_to_constr node in (* let constr = try Proof2aproof.ProofTreeHash.find proof_tree_to_constr node with _ -> Pp.ppnl (Pp.(++) (Pp.str "Node of the proof-tree that generated no lambda-term: ") (Refiner.print_script true (Evd.empty) (Global.named_context ()) node)) ; assert false (* Closed bug, should not happen any more *) in *) try Some (Acic.CicHash.find constr_to_ids constr) with _ -> Pp.ppnl (Pp.(++) (Pp.str "The_generated_term_is_not_a_subterm_of_the_final_lambda_term") (Printer.pr_lconstr constr)) ; None in let rec aux node old_hyps = let of_attribute = match ids_of_node node with None -> [] | Some id -> ["of",id] in match node with {PT.ref=Some(PT.Prim tactic_expr,nodes)} -> let tac = string_of_prim_rule tactic_expr in let of_attribute = ("name",tac)::of_attribute in if nodes = [] then X.xml_empty "Prim" of_attribute else X.xml_nempty "Prim" of_attribute (List.fold_left (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes) | {PT.goal=goal; PT.ref=Some(PT.Nested (PT.Tactic(tactic_expr,_),hidden_proof),nodes)} -> (* [hidden_proof] is the proof of the tactic; *) (* [nodes] are the proof of the subgoals generated by the tactic; *) (* [flat_proof] if the proof-tree obtained substituting [nodes] *) (* for the holes in [hidden_proof] *) let flat_proof = Proof2aproof.ProofTreeHash.find proof_tree_to_flattened_proof_tree node in begin match tactic_expr with | T.TacArg (_,T.Tacexp _) -> (* We don't need to keep the level of abstraction introduced at *) (* user-level invocation of tactic... (see Tacinterp.hide_interp)*) aux flat_proof old_hyps | _ -> (****** la tactique employee *) let prtac = Pptactic.pr_tactic (Global.env()) in let tac = Pp.string_of_ppcmds (prtac tactic_expr) in let tacname= first_word tac in let of_attribute = ("name",tacname)::("script",tac)::of_attribute in (****** le but *) let concl = Goal.V82.concl sigma goal in let hyps = Goal.V82.hyps sigma goal in let env = Global.env_of_context hyps in let xgoal = X.xml_nempty "Goal" [] (constr_to_xml concl sigma env) in let rec build_hyps = function | [] -> xgoal | (id,c,tid)::hyps1 -> let id' = Names.string_of_id id in [< build_hyps hyps1; (X.xml_nempty "Hypothesis" ["id",idref_of_id id' ; "name",id'] (constr_to_xml tid sigma env)) >] in let old_names = List.map (fun (id,c,tid)->id) old_hyps in let nhyps = Environ.named_context_of_val hyps in let new_hyps = List.filter (fun (id,c,tid)-> not (List.mem id old_names)) nhyps in X.xml_nempty "Tactic" of_attribute [<(build_hyps new_hyps) ; (aux flat_proof nhyps)>] end | {PT.ref=Some(PT.Daimon,_)} -> X.xml_empty "Hidden_open_goal" of_attribute | {PT.ref=None;PT.goal=goal} -> X.xml_empty "Open_goal" of_attribute | {PT.ref=Some(PT.Decl_proof _, _)} -> failwith "TODO: xml and decl_proof" in [< X.xml_cdata "\n" ; X.xml_cdata ("\n\n"); X.xml_nempty "ProofTree" ["of",curi] (aux pf []) >] ;; (* Hook registration *) (* CSC: debranched since it is bugged Xmlcommand.set_print_proof_tree print_proof_tree;; *) coq-8.4pl4/plugins/xml/acic2Xml.ml40000644000175000017500000003432612326224777016204 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Util.anomaly "find_last_id: empty list" | [id,_,_] -> id | _::tl -> find_last_id tl ;; let export_existential = string_of_int let print_term ids_to_inner_sorts = let rec aux = let module A = Acic in let module N = Names in let module X = Xml in function A.ARel (id,n,idref,b) -> let sort = Hashtbl.find ids_to_inner_sorts id in X.xml_empty "REL" ["value",(string_of_int n) ; "binder",(N.string_of_id b) ; "id",id ; "idref",idref; "sort",sort] | A.AVar (id,uri) -> let sort = Hashtbl.find ids_to_inner_sorts id in X.xml_empty "VAR" ["uri", uri ; "id",id ; "sort",sort] | A.AEvar (id,n,l) -> let sort = Hashtbl.find ids_to_inner_sorts id in X.xml_nempty "META" ["no",(export_existential n) ; "id",id ; "sort",sort] (List.fold_left (fun i t -> [< i ; X.xml_nempty "substitution" [] (aux t) >] ) [< >] (List.rev l)) | A.ASort (id,s) -> let string_of_sort = match Term.family_of_sort s with Term.InProp -> "Prop" | Term.InSet -> "Set" | Term.InType -> "Type" in X.xml_empty "SORT" ["value",string_of_sort ; "id",id] | A.AProds (prods,t) -> let last_id = find_last_id prods in let sort = Hashtbl.find ids_to_inner_sorts last_id in X.xml_nempty "PROD" ["type",sort] [< List.fold_left (fun i (id,binder,s) -> let sort = Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id) in let attrs = ("id",id)::("type",sort):: match binder with Names.Anonymous -> [] | Names.Name b -> ["binder",Names.string_of_id b] in [< X.xml_nempty "decl" attrs (aux s) ; i >] ) [< >] prods ; X.xml_nempty "target" [] (aux t) >] | A.ACast (id,v,t) -> let sort = Hashtbl.find ids_to_inner_sorts id in X.xml_nempty "CAST" ["id",id ; "sort",sort] [< X.xml_nempty "term" [] (aux v) ; X.xml_nempty "type" [] (aux t) >] | A.ALambdas (lambdas,t) -> let last_id = find_last_id lambdas in let sort = Hashtbl.find ids_to_inner_sorts last_id in X.xml_nempty "LAMBDA" ["sort",sort] [< List.fold_left (fun i (id,binder,s) -> let sort = Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id) in let attrs = ("id",id)::("type",sort):: match binder with Names.Anonymous -> [] | Names.Name b -> ["binder",Names.string_of_id b] in [< X.xml_nempty "decl" attrs (aux s) ; i >] ) [< >] lambdas ; X.xml_nempty "target" [] (aux t) >] | A.ALetIns (letins,t) -> let last_id = find_last_id letins in let sort = Hashtbl.find ids_to_inner_sorts last_id in X.xml_nempty "LETIN" ["sort",sort] [< List.fold_left (fun i (id,binder,s) -> let sort = Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id) in let attrs = ("id",id)::("sort",sort):: match binder with Names.Anonymous -> assert false | Names.Name b -> ["binder",Names.string_of_id b] in [< X.xml_nempty "def" attrs (aux s) ; i >] ) [< >] letins ; X.xml_nempty "target" [] (aux t) >] | A.AApp (id,li) -> let sort = Hashtbl.find ids_to_inner_sorts id in X.xml_nempty "APPLY" ["id",id ; "sort",sort] [< (List.fold_left (fun i x -> [< i ; (aux x) >]) [<>] li) >] | A.AConst (id,subst,uri) -> let sort = Hashtbl.find ids_to_inner_sorts id in let attrs = ["uri", uri ; "id",id ; "sort",sort] in aux_subst (X.xml_empty "CONST" attrs) subst | A.AInd (id,subst,uri,i) -> let attrs = ["uri", uri ; "noType",(string_of_int i) ; "id",id] in aux_subst (X.xml_empty "MUTIND" attrs) subst | A.AConstruct (id,subst,uri,i,j) -> let sort = Hashtbl.find ids_to_inner_sorts id in let attrs = ["uri", uri ; "noType",(string_of_int i) ; "noConstr",(string_of_int j) ; "id",id ; "sort",sort] in aux_subst (X.xml_empty "MUTCONSTRUCT" attrs) subst | A.ACase (id,uri,typeno,ty,te,patterns) -> let sort = Hashtbl.find ids_to_inner_sorts id in X.xml_nempty "MUTCASE" ["uriType", uri ; "noType", (string_of_int typeno) ; "id", id ; "sort",sort] [< X.xml_nempty "patternsType" [] [< (aux ty) >] ; X.xml_nempty "inductiveTerm" [] [< (aux te) >] ; List.fold_left (fun i x -> [< i ; X.xml_nempty "pattern" [] [< aux x >] >]) [<>] patterns >] | A.AFix (id, no, funs) -> let sort = Hashtbl.find ids_to_inner_sorts id in X.xml_nempty "FIX" ["noFun", (string_of_int no) ; "id",id ; "sort",sort] [< List.fold_left (fun i (id,fi,ai,ti,bi) -> [< i ; X.xml_nempty "FixFunction" ["id",id ; "name", (Names.string_of_id fi) ; "recIndex", (string_of_int ai)] [< X.xml_nempty "type" [] [< aux ti >] ; X.xml_nempty "body" [] [< aux bi >] >] >] ) [<>] funs >] | A.ACoFix (id,no,funs) -> let sort = Hashtbl.find ids_to_inner_sorts id in X.xml_nempty "COFIX" ["noFun", (string_of_int no) ; "id",id ; "sort",sort] [< List.fold_left (fun i (id,fi,ti,bi) -> [< i ; X.xml_nempty "CofixFunction" ["id",id ; "name", Names.string_of_id fi] [< X.xml_nempty "type" [] [< aux ti >] ; X.xml_nempty "body" [] [< aux bi >] >] >] ) [<>] funs >] and aux_subst target (id,subst) = if subst = [] then target else Xml.xml_nempty "instantiate" (match id with None -> [] | Some id -> ["id",id]) [< target ; List.fold_left (fun i (uri,arg) -> [< i ; Xml.xml_nempty "arg" ["relUri", uri] (aux arg) >] ) [<>] subst >] in aux ;; let param_attribute_of_params params = List.fold_right (fun (path,l) i -> List.fold_right (fun x i ->path ^ "/" ^ x ^ ".var" ^ match i with "" -> "" | i' -> " " ^ i' ) l "" ^ match i with "" -> "" | i' -> " " ^ i' ) params "" ;; let print_object uri ids_to_inner_sorts = let rec aux = let module A = Acic in let module X = Xml in function A.ACurrentProof (id,n,conjectures,bo,ty) -> let xml_for_current_proof_body = (*CSC: Should the CurrentProof also have the list of variables it depends on? *) (*CSC: I think so. Not implemented yet. *) X.xml_nempty "CurrentProof" ["of",uri ; "id", id] [< List.fold_left (fun i (cid,n,canonical_context,t) -> [< i ; X.xml_nempty "Conjecture" ["id", cid ; "no",export_existential n] [< List.fold_left (fun i (hid,t) -> [< (match t with n,A.Decl t -> X.xml_nempty "Decl" ["id",hid;"name",Names.string_of_id n] (print_term ids_to_inner_sorts t) | n,A.Def (t,_) -> X.xml_nempty "Def" ["id",hid;"name",Names.string_of_id n] (print_term ids_to_inner_sorts t) ) ; i >] ) [< >] canonical_context ; X.xml_nempty "Goal" [] (print_term ids_to_inner_sorts t) >] >]) [<>] (List.rev conjectures) ; X.xml_nempty "body" [] (print_term ids_to_inner_sorts bo) >] in let xml_for_current_proof_type = X.xml_nempty "ConstantType" ["name",n ; "id", id] (print_term ids_to_inner_sorts ty) in let xmlbo = [< X.xml_cdata "\n" ; X.xml_cdata ("\n"); xml_for_current_proof_body >] in let xmlty = [< X.xml_cdata "\n" ; X.xml_cdata ("\n"); xml_for_current_proof_type >] in xmlty, Some xmlbo | A.AConstant (id,n,bo,ty,params) -> let params' = param_attribute_of_params params in let xmlbo = match bo with None -> None | Some bo -> Some [< X.xml_cdata "\n" ; X.xml_cdata ("\n") ; X.xml_nempty "ConstantBody" ["for",uri ; "params",params' ; "id", id] [< print_term ids_to_inner_sorts bo >] >] in let xmlty = [< X.xml_cdata "\n" ; X.xml_cdata ("\n"); X.xml_nempty "ConstantType" ["name",n ; "params",params' ; "id", id] [< print_term ids_to_inner_sorts ty >] >] in xmlty, xmlbo | A.AVariable (id,n,bo,ty,params) -> let params' = param_attribute_of_params params in [< X.xml_cdata "\n" ; X.xml_cdata ("\n") ; X.xml_nempty "Variable" ["name",n ; "params",params' ; "id", id] [< (match bo with None -> [<>] | Some bo -> X.xml_nempty "body" [] (print_term ids_to_inner_sorts bo) ) ; X.xml_nempty "type" [] (print_term ids_to_inner_sorts ty) >] >], None | A.AInductiveDefinition (id,tys,params,nparams) -> let params' = param_attribute_of_params params in [< X.xml_cdata "\n" ; X.xml_cdata ("\n") ; X.xml_nempty "InductiveDefinition" ["noParams",string_of_int nparams ; "id",id ; "params",params'] [< (List.fold_left (fun i (id,typename,finite,arity,cons) -> [< i ; X.xml_nempty "InductiveType" ["id",id ; "name",Names.string_of_id typename ; "inductive",(string_of_bool finite) ] [< X.xml_nempty "arity" [] (print_term ids_to_inner_sorts arity) ; (List.fold_left (fun i (name,lc) -> [< i ; X.xml_nempty "Constructor" ["name",Names.string_of_id name] (print_term ids_to_inner_sorts lc) >]) [<>] cons ) >] >] ) [< >] tys ) >] >], None in aux ;; let print_inner_types curi ids_to_inner_sorts ids_to_inner_types = let module C2A = Cic2acic in let module X = Xml in [< X.xml_cdata "\n" ; X.xml_cdata ("\n"); X.xml_nempty "InnerTypes" ["of",curi] (Hashtbl.fold (fun id {C2A.annsynthesized = synty ; C2A.annexpected = expty} x -> [< x ; X.xml_nempty "TYPE" ["of",id] [< X.xml_nempty "synthesized" [] (print_term ids_to_inner_sorts synty) ; match expty with None -> [<>] | Some expty' -> X.xml_nempty "expected" [] (print_term ids_to_inner_sorts expty') >] >] ) ids_to_inner_types [<>] ) >] ;; coq-8.4pl4/plugins/xml/dumptree.ml40000644000175000017500000001024512326224777016361 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* try if Sign.lookup_named id osign = (id,c,ty) then sign else raise Different with Not_found | Different -> Environ.push_named_context_val d sign) sign ~init:Environ.empty_named_context_val ;; let pr_tactic_xml = function | TacArg (_,Tacexp t) -> str "" | t -> str "" ;; let pr_proof_instr_xml instr = Ppdecl_proof.pr_proof_instr (Global.env()) instr ;; let pr_rule_xml pr = function | Prim r -> str "" | Nested(cmpd, subtree) -> hov 2 (str "" ++ fnl () ++ begin match cmpd with Tactic (texp, _) -> pr_tactic_xml texp end ++ fnl () ++ pr subtree ) ++ fnl () ++ str "" | Daimon -> str "" | Decl_proof _ -> str "" ;; let pr_var_decl_xml env (id,c,typ) = let ptyp = print_constr_env env typ in match c with | None -> (str "") | Some c -> (* Force evaluation *) let pb = print_constr_env env c in (str "") ;; let pr_rel_decl_xml env (na,c,typ) = let pbody = match c with | None -> mt () | Some c -> (* Force evaluation *) let pb = print_constr_env env c in (str" body=\"" ++ xmlstream pb ++ str "\"") in let ptyp = print_constr_env env typ in let pid = match na with | Anonymous -> mt () | Name id -> str " id=\"" ++ pr_id id ++ str "\"" in (str "") ;; let pr_context_xml env = let sign_env = fold_named_context (fun env d pp -> pp ++ pr_var_decl_xml env d) env ~init:(mt ()) in let db_env = fold_rel_context (fun env d pp -> pp ++ pr_rel_decl_xml env d) env ~init:(mt ()) in (sign_env ++ db_env) ;; let pr_subgoal_metas_xml metas env= let pr_one (meta, typ) = fnl () ++ str "" in List.fold_left (++) (mt ()) (List.map pr_one metas) ;; let pr_goal_xml sigma g = let env = try Goal.V82.unfiltered_env sigma g with _ -> empty_env in if Decl_mode.try_get_info sigma g = None then (hov 2 (str "" ++ fnl () ++ str "" ++ (pr_context_xml env)) ++ fnl () ++ str "") else (hov 2 (str "" ++ (pr_context_xml env)) ++ fnl () ++ str "") ;; let print_proof_xml () = Util.anomaly "Dump Tree command not supported in this version." VERNAC COMMAND EXTEND DumpTree [ "Dump" "Tree" ] -> [ print_proof_xml () ] END coq-8.4pl4/plugins/xml/unshare.mli0000644000175000017500000000253312326224777016267 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool) -> 'a -> 'a coq-8.4pl4/plugins/xml/theoryobject.dtd0000644000175000017500000000540612326224777017317 0ustar stephsteph coq-8.4pl4/plugins/xml/xmlcommand.ml0000644000175000017500000006124312326224777016613 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* None) in (fun () -> !print_proof_tree), (fun f -> print_proof_tree := fun curi sigma0 pf proof_tree_to_constr proof_tree_to_flattened_proof_tree constr_to_ids -> Some (f curi sigma0 pf proof_tree_to_constr proof_tree_to_flattened_proof_tree constr_to_ids)) ;; (* UTILITY FUNCTIONS *) let print_if_verbose s = if !verbose then print_string s;; (* Next exception is used only inside print_coq_object and tag_of_string_tag *) exception Uninteresting;; (* NOT USED anymore, we back to the V6 point of view with global parameters (* Internally, for Coq V7, params of inductive types are associated *) (* not to the whole block of mutual inductive (as it was in V6) but to *) (* each member of the block; but externally, all params are required *) (* to be the same; the following function checks that the parameters *) (* of each inductive of a same block are all the same, then returns *) (* this number; it fails otherwise *) let extract_nparams pack = let module D = Declarations in let module U = Util in let module S = Sign in let {D.mind_nparams=nparams0} = pack.(0) in let arity0 = pack.(0).D.mind_user_arity in let params0, _ = S.decompose_prod_n_assum nparams0 arity0 in for i = 1 to Array.length pack - 1 do let {D.mind_nparams=nparamsi} = pack.(i) in let arityi = pack.(i).D.mind_user_arity in let paramsi, _ = S.decompose_prod_n_assum nparamsi arityi in if params0 <> paramsi then U.error "Cannot convert a block of inductive definitions with parameters specific to each inductive to a block of mutual inductive definitions with parameters global to the whole block" done; nparams0 *) (* could_have_namesakes sp = true iff o is an object that could be cooked and *) (* than that could exists in cooked form with the same name in a super *) (* section of the actual section *) let could_have_namesakes o sp = (* namesake = omonimo in italian *) let module DK = Decl_kinds in let module D = Declare in let tag = Libobject.object_tag o in print_if_verbose ("Object tag: " ^ tag ^ "\n") ; match tag with "CONSTANT" -> true (* constants/parameters are non global *) | "INDUCTIVE" -> true (* mutual inductive types are never local *) | "VARIABLE" -> false (* variables are local, so no namesakes *) | _ -> false (* uninteresting thing that won't be printed*) ;; (* filter_params pvars hyps *) (* filters out from pvars (which is a list of lists) all the variables *) (* that does not belong to hyps (which is a simple list) *) (* It returns a list of couples relative section path -- list of *) (* variable names. *) let filter_params pvars hyps = let rec aux ids = function [] -> [] | (id,he)::tl -> let ids' = id::ids in let ids'' = "cic:/" ^ String.concat "/" (List.rev (List.map Names.string_of_id ids')) in let he' = ids'', List.rev (List.filter (function x -> List.mem x hyps) he) in let tl' = aux ids' tl in match he' with _,[] -> tl' | _,_ -> he'::tl' in let cwd = Lib.cwd () in let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in let modulepath = Cic2acic.get_module_path_of_full_path cwdsp in aux (Names.repr_dirpath modulepath) (List.rev pvars) ;; type variables_type = Definition of string * Term.constr * Term.types | Assumption of string * Term.constr ;; (* The computation is very inefficient, but we can't do anything *) (* better unless this function is reimplemented in the Declare *) (* module. *) let search_variables () = let module N = Names in let cwd = Lib.cwd () in let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in let modulepath = Cic2acic.get_module_path_of_full_path cwdsp in let rec aux = function [] -> [] | he::tl as modules -> let one_section_variables = let dirpath = N.make_dirpath (modules @ N.repr_dirpath modulepath) in let t = List.map N.string_of_id (Decls.last_section_hyps dirpath) in [he,t] in one_section_variables @ aux tl in aux (Cic2acic.remove_module_dirpath_from_dirpath ~basedir:modulepath cwd) ;; (* FUNCTIONS TO PRINT A SINGLE OBJECT OF COQ *) let rec join_dirs cwd = function [] -> cwd | he::tail -> (try Unix.mkdir cwd 0o775 with e when e <> Sys.Break -> () (* Let's ignore the errors on mkdir *) ) ; let newcwd = cwd ^ "/" ^ he in join_dirs newcwd tail ;; let filename_of_path xml_library_root tag = let module N = Names in match xml_library_root with None -> None (* stdout *) | Some xml_library_root' -> let tokens = Cic2acic.token_list_of_kernel_name tag in Some (join_dirs xml_library_root' tokens) ;; let body_filename_of_filename = function Some f -> Some (f ^ ".body") | None -> None ;; let types_filename_of_filename = function Some f -> Some (f ^ ".types") | None -> None ;; let prooftree_filename_of_filename = function Some f -> Some (f ^ ".proof_tree") | None -> None ;; let theory_filename xml_library_root = let module N = Names in match xml_library_root with None -> None (* stdout *) | Some xml_library_root' -> let toks = List.map N.string_of_id (N.repr_dirpath (Lib.library_dp ())) in (* theory from A/B/C/F.v goes into A/B/C/F.theory *) let alltoks = List.rev toks in Some (join_dirs xml_library_root' alltoks ^ ".theory") let print_object uri obj sigma proof_tree_infos filename = (* function to pretty print and compress an XML file *) (*CSC: Unix.system "gzip ..." is an horrible non-portable solution. *) let pp xml filename = Xml.pp xml filename ; match filename with None -> () | Some fn -> let fn' = let rec escape s n = try let p = String.index_from s n '\'' in String.sub s n (p - n) ^ "\\'" ^ escape s (p+1) with Not_found -> String.sub s n (String.length s - n) in escape fn 0 in ignore (Unix.system ("gzip " ^ fn' ^ ".xml")) in let (annobj,_,constr_to_ids,_,ids_to_inner_sorts,ids_to_inner_types,_,_) = Cic2acic.acic_object_of_cic_object sigma obj in let (xml, xml') = Acic2Xml.print_object uri ids_to_inner_sorts annobj in let xmltypes = Acic2Xml.print_inner_types uri ids_to_inner_sorts ids_to_inner_types in pp xml filename ; begin match xml' with None -> () | Some xml' -> pp xml' (body_filename_of_filename filename) end ; pp xmltypes (types_filename_of_filename filename) ; match proof_tree_infos with None -> () | Some (sigma0,proof_tree,proof_tree_to_constr, proof_tree_to_flattened_proof_tree) -> let xmlprooftree = print_proof_tree () uri sigma0 proof_tree proof_tree_to_constr proof_tree_to_flattened_proof_tree constr_to_ids in match xmlprooftree with None -> () | Some xmlprooftree -> pp xmlprooftree (prooftree_filename_of_filename filename) ;; let string_list_of_named_context_list = List.map (function (n,_,_) -> Names.string_of_id n) ;; (* Function to collect the variables that occur in a term. *) (* Used only for variables (since for constants and mutual *) (* inductive types this information is already available. *) let find_hyps t = let module T = Term in let rec aux l t = match T.kind_of_term t with T.Var id when not (List.mem id l) -> let (_,bo,ty) = Global.lookup_named id in let boids = match bo with Some bo' -> aux l bo' | None -> l in id::(aux boids ty) | T.Var _ | T.Rel _ | T.Meta _ | T.Evar _ | T.Sort _ -> l | T.Cast (te,_, ty) -> aux (aux l te) ty | T.Prod (_,s,t) -> aux (aux l s) t | T.Lambda (_,s,t) -> aux (aux l s) t | T.LetIn (_,s,_,t) -> aux (aux l s) t | T.App (he,tl) -> Array.fold_left (fun i x -> aux i x) (aux l he) tl | T.Const con -> let hyps = (Global.lookup_constant con).Declarations.const_hyps in map_and_filter l hyps @ l | T.Ind ind | T.Construct (ind,_) -> let hyps = (fst (Global.lookup_inductive ind)).Declarations.mind_hyps in map_and_filter l hyps @ l | T.Case (_,t1,t2,b) -> Array.fold_left (fun i x -> aux i x) (aux (aux l t1) t2) b | T.Fix (_,(_,tys,bodies)) | T.CoFix (_,(_,tys,bodies)) -> let r = Array.fold_left (fun i x -> aux i x) l tys in Array.fold_left (fun i x -> aux i x) r bodies and map_and_filter l = function [] -> [] | (n,_,_)::tl when not (List.mem n l) -> n::(map_and_filter l tl) | _::tl -> map_and_filter l tl in aux [] t ;; (* Functions to construct an object *) let mk_variable_obj id body typ = let hyps,unsharedbody = match body with None -> [],None | Some bo -> find_hyps bo, Some (Unshare.unshare bo) in let hyps' = find_hyps typ @ hyps in let hyps'' = List.map Names.string_of_id hyps' in let variables = search_variables () in let params = filter_params variables hyps'' in Acic.Variable (Names.string_of_id id, unsharedbody, Unshare.unshare typ, params) ;; (* Unsharing is not performed on the body, that must be already unshared. *) (* The evar map and the type, instead, are unshared by this function. *) let mk_current_proof_obj is_a_variable id bo ty evar_map env = let unshared_ty = Unshare.unshare ty in let metasenv = List.map (function (n, {Evd.evar_concl = evar_concl ; Evd.evar_hyps = evar_hyps} ) -> (* We map the named context to a rel context and every Var to a Rel *) let final_var_ids,context = let rec aux var_ids = function [] -> var_ids,[] | (n,None,t)::tl -> let final_var_ids,tl' = aux (n::var_ids) tl in let t' = Term.subst_vars var_ids t in final_var_ids,(n, Acic.Decl (Unshare.unshare t'))::tl' | (n,Some b,t)::tl -> let final_var_ids,tl' = aux (n::var_ids) tl in let b' = Term.subst_vars var_ids b in (* t will not be exported to XML. Thus no unsharing performed *) final_var_ids,(n, Acic.Def (Unshare.unshare b',t))::tl' in aux [] (List.rev (Environ.named_context_of_val evar_hyps)) in (* We map the named context to a rel context and every Var to a Rel *) (n,context,Unshare.unshare (Term.subst_vars final_var_ids evar_concl)) ) (Evarutil.non_instantiated evar_map) in let id' = Names.string_of_id id in if metasenv = [] then let ids = Names.Idset.union (Environ.global_vars_set env bo) (Environ.global_vars_set env ty) in let hyps0 = Environ.keep_hyps env ids in let hyps = string_list_of_named_context_list hyps0 in (* Variables are the identifiers of the variables in scope *) let variables = search_variables () in let params = filter_params variables hyps in if is_a_variable then Acic.Variable (id',Some bo,unshared_ty,params) else Acic.Constant (id',Some bo,unshared_ty,params) else Acic.CurrentProof (id',metasenv,bo,unshared_ty) ;; let mk_constant_obj id bo ty variables hyps = let hyps = string_list_of_named_context_list hyps in let ty = Unshare.unshare ty in let params = filter_params variables hyps in match bo with None -> Acic.Constant (Names.string_of_id id,None,ty,params) | Some c -> Acic.Constant (Names.string_of_id id, Some (Unshare.unshare (Declarations.force c)), ty,params) ;; let mk_inductive_obj sp mib packs variables nparams hyps finite = let module D = Declarations in let hyps = string_list_of_named_context_list hyps in let params = filter_params variables hyps in (* let nparams = extract_nparams packs in *) let tys = let tyno = ref (Array.length packs) in Array.fold_right (fun p i -> decr tyno ; let {D.mind_consnames=consnames ; D.mind_typename=typename } = p in let arity = Inductive.type_of_inductive (Global.env()) (mib,p) in let lc = Inductiveops.arities_of_constructors (Global.env ()) (sp,!tyno) in let cons = (Array.fold_right (fun (name,lc) i -> (name,lc)::i) (Array.mapi (fun j x ->(x,Unshare.unshare lc.(j))) consnames) [] ) in (typename,finite,Unshare.unshare arity,cons)::i ) packs [] in Acic.InductiveDefinition (tys,params,nparams) ;; (* The current channel for .theory files *) let theory_buffer = Buffer.create 4000;; let theory_output_string ?(do_not_quote = false) s = (* prepare for coqdoc post-processing *) let s = if do_not_quote then s else "(** #"^s^"\n#*)\n" in print_if_verbose s; Buffer.add_string theory_buffer s ;; let kind_of_global_goal = function | Decl_kinds.Global, Decl_kinds.DefinitionBody _ -> "DEFINITION","InteractiveDefinition" | Decl_kinds.Global, (Decl_kinds.Proof k) -> "THEOREM",Decl_kinds.string_of_theorem_kind k | Decl_kinds.Local, _ -> assert false let kind_of_inductive isrecord kn = "DEFINITION", if (fst (Global.lookup_inductive (kn,0))).Declarations.mind_finite then begin match isrecord with | Declare.KernelSilent -> "Record" | _ -> "Inductive" end else "CoInductive" ;; let kind_of_variable id = let module DK = Decl_kinds in match Decls.variable_kind id with | DK.IsAssumption DK.Definitional -> "VARIABLE","Assumption" | DK.IsAssumption DK.Logical -> "VARIABLE","Hypothesis" | DK.IsAssumption DK.Conjectural -> "VARIABLE","Conjecture" | DK.IsDefinition DK.Definition -> "VARIABLE","LocalDefinition" | DK.IsProof _ -> "VARIABLE","LocalFact" | _ -> Util.anomaly "Unsupported variable kind" ;; let kind_of_constant kn = let module DK = Decl_kinds in match Decls.constant_kind kn with | DK.IsAssumption DK.Definitional -> "AXIOM","Declaration" | DK.IsAssumption DK.Logical -> "AXIOM","Axiom" | DK.IsAssumption DK.Conjectural -> Pp.msg_warn "Conjecture not supported in dtd (used Declaration instead)"; "AXIOM","Declaration" | DK.IsDefinition DK.Definition -> "DEFINITION","Definition" | DK.IsDefinition DK.Example -> Pp.msg_warn "Example not supported in dtd (used Definition instead)"; "DEFINITION","Definition" | DK.IsDefinition DK.Coercion -> Pp.msg_warn "Coercion not supported in dtd (used Definition instead)"; "DEFINITION","Definition" | DK.IsDefinition DK.SubClass -> Pp.msg_warn "SubClass not supported in dtd (used Definition instead)"; "DEFINITION","Definition" | DK.IsDefinition DK.CanonicalStructure -> Pp.msg_warn "CanonicalStructure not supported in dtd (used Definition instead)"; "DEFINITION","Definition" | DK.IsDefinition DK.Fixpoint -> Pp.msg_warn "Fixpoint not supported in dtd (used Definition instead)"; "DEFINITION","Definition" | DK.IsDefinition DK.CoFixpoint -> Pp.msg_warn "CoFixpoint not supported in dtd (used Definition instead)"; "DEFINITION","Definition" | DK.IsDefinition DK.Scheme -> Pp.msg_warn "Scheme not supported in dtd (used Definition instead)"; "DEFINITION","Definition" | DK.IsDefinition DK.StructureComponent -> Pp.msg_warn "StructureComponent not supported in dtd (used Definition instead)"; "DEFINITION","Definition" | DK.IsDefinition DK.IdentityCoercion -> Pp.msg_warn "IdentityCoercion not supported in dtd (used Definition instead)"; "DEFINITION","Definition" | DK.IsDefinition DK.Instance -> Pp.msg_warn "Instance not supported in dtd (used Definition instead)"; "DEFINITION","Definition" | DK.IsDefinition DK.Method -> Pp.msg_warn "Method not supported in dtd (used Definition instead)"; "DEFINITION","Definition" | DK.IsProof (DK.Theorem|DK.Lemma|DK.Corollary|DK.Fact|DK.Remark as thm) -> "THEOREM",DK.string_of_theorem_kind thm | DK.IsProof _ -> Pp.msg_warn "Unsupported theorem kind (used Theorem instead)"; "THEOREM",DK.string_of_theorem_kind DK.Theorem ;; let kind_of_global r = let module Ln = Libnames in let module DK = Decl_kinds in match r with | Ln.IndRef kn | Ln.ConstructRef (kn,_) -> let isrecord = try let _ = Recordops.lookup_projections kn in Declare.KernelSilent with Not_found -> Declare.KernelVerbose in kind_of_inductive isrecord (fst kn) | Ln.VarRef id -> kind_of_variable id | Ln.ConstRef kn -> kind_of_constant kn ;; let print_object_kind uri (xmltag,variation) = let s = Printf.sprintf "\n" xmltag uri variation in theory_output_string s ;; (* print id dest *) (* where sp is the qualified identifier (section path) of a *) (* definition/theorem, variable or inductive definition *) (* and dest is either None (for stdout) or (Some filename) *) (* pretty prints via Xml.pp the object whose identifier is id on dest *) (* Note: it is printed only (and directly) the most cooked available *) (* form of the definition (all the parameters are *) (* lambda-abstracted, but the object can still refer to variables) *) let print internal glob_ref kind xml_library_root = let module D = Declarations in let module De = Declare in let module G = Global in let module N = Names in let module Nt = Nametab in let module T = Term in let module X = Xml in let module Ln = Libnames in (* Variables are the identifiers of the variables in scope *) let variables = search_variables () in let tag,obj = match glob_ref with Ln.VarRef id -> (* this kn is fake since it is not provided by Coq *) let kn = let (mod_path,dir_path) = Lib.current_prefix () in N.make_kn mod_path dir_path (N.label_of_id id) in let (_,body,typ) = G.lookup_named id in Cic2acic.Variable kn,mk_variable_obj id body typ | Ln.ConstRef kn -> let id = N.id_of_label (N.con_label kn) in let cb = G.lookup_constant kn in let val0 = D.body_of_constant cb in let typ = cb.D.const_type in let hyps = cb.D.const_hyps in let typ = Typeops.type_of_constant_type (Global.env()) typ in Cic2acic.Constant kn,mk_constant_obj id val0 typ variables hyps | Ln.IndRef (kn,_) -> let mib = G.lookup_mind kn in let {D.mind_nparams=nparams; D.mind_packets=packs ; D.mind_hyps=hyps; D.mind_finite=finite} = mib in Cic2acic.Inductive kn,mk_inductive_obj kn mib packs variables nparams hyps finite | Ln.ConstructRef _ -> Util.error ("a single constructor cannot be printed in XML") in let fn = filename_of_path xml_library_root tag in let uri = Cic2acic.uri_of_kernel_name tag in (match internal with | Declare.KernelSilent -> () | _ -> print_object_kind uri kind); print_object uri obj Evd.empty None fn ;; let print_ref qid fn = let ref = Nametab.global qid in print Declare.UserVerbose ref (kind_of_global ref) fn (* show dest *) (* where dest is either None (for stdout) or (Some filename) *) (* pretty prints via Xml.pp the proof in progress on dest *) let show_pftreestate internal fn (kind,pftst) id = if true then Util.anomaly "Xmlcommand.show_pftreestate is not supported in this version." let show fn = let pftst = Pfedit.get_pftreestate () in let (id,kind,_,_) = Pfedit.current_proof_statement () in show_pftreestate false fn (kind,pftst) id ;; (* Let's register the callbacks *) let xml_library_root = try Some (Sys.getenv "COQ_XML_LIBRARY_ROOT") with Not_found -> None ;; let proof_to_export = ref None (* holds the proof-tree to export *) ;; let _ = Pfedit.set_xml_cook_proof (function pftreestate -> proof_to_export := Some pftreestate) ;; let _ = Declare.set_xml_declare_variable (function (sp,kn) -> let id = Libnames.basename sp in print Declare.UserVerbose (Libnames.VarRef id) (kind_of_variable id) xml_library_root ; proof_to_export := None) ;; let _ = Declare.set_xml_declare_constant (function (internal,kn) -> match !proof_to_export with None -> print internal (Libnames.ConstRef kn) (kind_of_constant kn) xml_library_root | Some pftreestate -> (* It is a proof. Let's export it starting from the proof-tree *) (* I saved in the Pfedit.set_xml_cook_proof callback. *) let fn = filename_of_path xml_library_root (Cic2acic.Constant kn) in show_pftreestate internal fn pftreestate (Names.id_of_label (Names.con_label kn)) ; proof_to_export := None) ;; let _ = Declare.set_xml_declare_inductive (function (isrecord,(sp,kn)) -> print Declare.UserVerbose (Libnames.IndRef (Names.mind_of_kn kn,0)) (kind_of_inductive isrecord (Names.mind_of_kn kn)) xml_library_root) ;; let _ = Vernac.set_xml_start_library (function () -> Buffer.reset theory_buffer; theory_output_string "\n"; theory_output_string ("\n" ^ "\n" ^ "\n\n" ^ "%xhtml-lat1.ent;\n" ^ "%xhtml-special.ent;\n" ^ "%xhtml-symbol.ent;\n" ^ "]>\n\n"); theory_output_string "\n"; theory_output_string "\n\n") ;; let _ = Vernac.set_xml_end_library (function () -> theory_output_string "\n\n"; let ofn = theory_filename xml_library_root in begin match ofn with None -> Buffer.output_buffer stdout theory_buffer ; | Some fn -> let ch = open_out (fn ^ ".v") in Buffer.output_buffer ch theory_buffer ; close_out ch; (* dummy glob file *) let ch = open_out (fn ^ ".glob") in close_out ch end ; Option.iter (fun fn -> let coqdoc = Filename.concat Envars.coqbin ("coqdoc" ^ Coq_config.exec_extension) in let options = " --html -s --body-only --no-index --latin1 --raw-comments" in let command cmd = if Sys.command cmd <> 0 then Util.anomaly ("Error executing \"" ^ cmd ^ "\"") in command (coqdoc^options^" -o "^fn^".xml "^fn^".v"); command ("rm "^fn^".v "^fn^".glob"); print_string("\nWriting on file \"" ^ fn ^ ".xml\" was successful\n")) ofn) ;; let _ = Lexer.set_xml_output_comment (theory_output_string ~do_not_quote:true) ;; let uri_of_dirpath dir = "/" ^ String.concat "/" (List.map Names.string_of_id (List.rev (Names.repr_dirpath dir))) ;; let _ = Lib.set_xml_open_section (fun _ -> let s = "cic:" ^ uri_of_dirpath (Lib.cwd ()) in theory_output_string ("")) ;; let _ = Lib.set_xml_close_section (fun _ -> theory_output_string "") ;; let _ = Library.set_xml_require (fun d -> theory_output_string (Printf.sprintf "Require %s.
    " (uri_of_dirpath d) (Names.string_of_dirpath d))) ;; coq-8.4pl4/plugins/xml/COPYRIGHT0000644000175000017500000000247012326224777015412 0ustar stephsteph(******************************************************************************) (* Copyright (C) 2000-2004, Claudio Sacerdoti Coen *) (* Project Helm (http://helm.cs.unibo.it) *) (* Project MoWGLI (http://mowgli.cs.unibo.it) *) (* *) (* Coq Exportation to XML *) (* *) (******************************************************************************) This Coq module has been developed by Claudio Sacerdoti Coen as a developer of projects HELM and MoWGLI. Project HELM (for Hypertextual Electronic Library of Mathematics) is a project developed at the Department of Computer Science, University of Bologna; http://helm.cs.unibo.it Project MoWGLI (Mathematics on the Web: Get It by Logics and Interfaces) is a UE IST project that generalizes and extends the HELM project; http://mowgli.cs.unibo.it The author is interested in any possible usage of the module. So, if you plan to use the module, please send him an e-mail. The licensing policy applied to the module is the same as for the whole Coq distribution. coq-8.4pl4/plugins/xml/unshare.ml0000644000175000017500000000406212326224777016115 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* false) t = let obj = Obj.repr t in let rec aux obj = if already_unshared (Obj.obj obj) then obj else (if Obj.is_int obj then obj else if Obj.is_block obj then begin let tag = Obj.tag obj in if tag < Obj.no_scan_tag then begin let size = Obj.size obj in let new_obj = Obj.new_block 0 size in Obj.set_tag new_obj tag ; for i = 0 to size - 1 do Obj.set_field new_obj i (aux (Obj.field obj i)) done ; new_obj end else if tag = Obj.string_tag then obj else raise CanNotUnshare end else raise CanNotUnshare ) in Obj.obj (aux obj) ;; coq-8.4pl4/plugins/xml/cic2acic.ml0000644000175000017500000011164612326224777016117 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Libnames.is_dirpath_prefix_of modul dirpath) modules with [] -> Pp.msg_warn ("Modules not supported: reference to "^ Libnames.string_of_path path^" will be wrong"); dirpath | [modul] -> modul | _ -> raise TwoModulesWhoseDirPathIsOneAPrefixOfTheOther ;; (*CSC: Problem: here we are using the wrong (???) hypothesis that there do *) (*CSC: not exist two modules whose dir_paths are one a prefix of the other *) let remove_module_dirpath_from_dirpath ~basedir dir = let module Ln = Libnames in if Ln.is_dirpath_prefix_of basedir dir then let ids = Names.repr_dirpath dir in let rec remove_firsts n l = match n,l with (0,l) -> l | (n,he::tl) -> remove_firsts (n-1) tl | _ -> assert false in let ids' = List.rev (remove_firsts (List.length (Names.repr_dirpath basedir)) (List.rev ids)) in ids' else Names.repr_dirpath dir ;; let get_uri_of_var v pvars = let module D = Decls in let module N = Names in let rec search_in_open_sections = function [] -> Util.error ("Variable "^v^" not found") | he::tl as modules -> let dirpath = N.make_dirpath modules in if List.mem (N.id_of_string v) (D.last_section_hyps dirpath) then modules else search_in_open_sections tl in let path = if List.mem v pvars then [] else search_in_open_sections (N.repr_dirpath (Lib.cwd ())) in "cic:" ^ List.fold_left (fun i x -> "/" ^ N.string_of_id x ^ i) "" path ;; type tag = Constant of Names.constant | Inductive of Names.mutual_inductive | Variable of Names.kernel_name ;; type etag = TConstant | TInductive | TVariable ;; let etag_of_tag = function Constant _ -> TConstant | Inductive _ -> TInductive | Variable _ -> TVariable let ext_of_tag = function TConstant -> "con" | TInductive -> "ind" | TVariable -> "var" ;; exception FunctorsXMLExportationNotImplementedYet;; let subtract l1 l2 = let l1' = List.rev (Names.repr_dirpath l1) in let l2' = List.rev (Names.repr_dirpath l2) in let rec aux = function he::tl when tl = l2' -> [he] | he::tl -> he::(aux tl) | [] -> assert (l2' = []) ; [] in Names.make_dirpath (List.rev (aux l1')) ;; let token_list_of_path dir id tag = let module N = Names in let token_list_of_dirpath dirpath = List.rev_map N.string_of_id (N.repr_dirpath dirpath) in token_list_of_dirpath dir @ [N.string_of_id id ^ "." ^ (ext_of_tag tag)] let token_list_of_kernel_name tag = let module N = Names in let module LN = Libnames in let id,dir = match tag with | Variable kn -> N.id_of_label (N.label kn), Lib.cwd () | Constant con -> N.id_of_label (N.con_label con), Lib.remove_section_part (LN.ConstRef con) | Inductive kn -> N.id_of_label (N.mind_label kn), Lib.remove_section_part (LN.IndRef (kn,0)) in token_list_of_path dir id (etag_of_tag tag) ;; let uri_of_kernel_name tag = let tokens = token_list_of_kernel_name tag in "cic:/" ^ String.concat "/" tokens let uri_of_declaration id tag = let module LN = Libnames in let dir = LN.pop_dirpath_n (Lib.sections_depth ()) (Lib.cwd ()) in let tokens = token_list_of_path dir id tag in "cic:/" ^ String.concat "/" tokens (* Special functions for handling of CCorn's CProp "sort" *) type sort = Coq_sort of Term.sorts_family | CProp ;; let prerr_endline _ = ();; let family_of_term ty = match Term.kind_of_term ty with Term.Sort s -> Coq_sort (Term.family_of_sort s) | Term.Const _ -> CProp (* I could check that the constant is CProp *) | _ -> Util.anomaly "family_of_term" ;; module CPropRetyping = struct module T = Term let outsort env sigma t = family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma t) let rec subst_type env sigma typ = function | [] -> typ | h::rest -> match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma typ) with | T.Prod (na,c1,c2) -> subst_type env sigma (T.subst1 h c2) rest | _ -> Util.anomaly "Non-functional construction" let sort_of_atomic_type env sigma ft args = let rec concl_of_arity env ar = match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma ar) with | T.Prod (na, t, b) -> concl_of_arity (Environ.push_rel (na,None,t) env) b | T.Sort s -> Coq_sort (T.family_of_sort s) | _ -> outsort env sigma (subst_type env sigma ft (Array.to_list args)) in concl_of_arity env ft let typeur sigma metamap = let rec type_of env cstr= match Term.kind_of_term cstr with | T.Meta n -> (try T.strip_outer_cast (List.assoc n metamap) with Not_found -> Util.anomaly "type_of: this is not a well-typed term") | T.Rel n -> let (_,_,ty) = Environ.lookup_rel n env in T.lift n ty | T.Var id -> (try let (_,_,ty) = Environ.lookup_named id env in ty with Not_found -> Util.anomaly ("type_of: variable "^(Names.string_of_id id)^" unbound")) | T.Const c -> let cb = Environ.lookup_constant c env in Typeops.type_of_constant_type env (cb.Declarations.const_type) | T.Evar ev -> Evd.existential_type sigma ev | T.Ind ind -> Inductiveops.type_of_inductive env ind | T.Construct cstr -> Inductiveops.type_of_constructor env cstr | T.Case (_,p,c,lf) -> let Inductiveops.IndType(_,realargs) = try Inductiveops.find_rectype env sigma (type_of env c) with Not_found -> Util.anomaly "type_of: Bad recursive type" in let t = Reductionops.whd_beta sigma (T.applist (p, realargs)) in (match Term.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma (type_of env t)) with | T.Prod _ -> Reductionops.whd_beta sigma (T.applist (t, [c])) | _ -> t) | T.Lambda (name,c1,c2) -> T.mkProd (name, c1, type_of (Environ.push_rel (name,None,c1) env) c2) | T.LetIn (name,b,c1,c2) -> T.subst1 b (type_of (Environ.push_rel (name,Some b,c1) env) c2) | T.Fix ((_,i),(_,tys,_)) -> tys.(i) | T.CoFix (i,(_,tys,_)) -> tys.(i) | T.App(f,args)-> T.strip_outer_cast (subst_type env sigma (type_of env f) (Array.to_list args)) | T.Cast (c,_, t) -> t | T.Sort _ | T.Prod _ -> match sort_of env cstr with Coq_sort T.InProp -> T.mkProp | Coq_sort T.InSet -> T.mkSet | Coq_sort T.InType -> T.mkType Univ.type1_univ (* ERROR HERE *) | CProp -> T.mkConst DoubleTypeInference.cprop and sort_of env t = match Term.kind_of_term t with | T.Cast (c,_, s) when T.isSort s -> family_of_term s | T.Sort (T.Prop c) -> Coq_sort T.InType | T.Sort (T.Type u) -> Coq_sort T.InType | T.Prod (name,t,c2) -> (match sort_of env t,sort_of (Environ.push_rel (name,None,t) env) c2 with | _, (Coq_sort T.InProp as s) -> s | Coq_sort T.InProp, (Coq_sort T.InSet as s) | Coq_sort T.InSet, (Coq_sort T.InSet as s) -> s | Coq_sort T.InType, (Coq_sort T.InSet as s) | CProp, (Coq_sort T.InSet as s) when Environ.engagement env = Some Declarations.ImpredicativeSet -> s | Coq_sort T.InType, Coq_sort T.InSet | CProp, Coq_sort T.InSet -> Coq_sort T.InType | _, (Coq_sort T.InType as s) -> s (*Type Univ.dummy_univ*) | _, (CProp as s) -> s) | T.App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args | T.Lambda _ | T.Fix _ | T.Construct _ -> Util.anomaly "sort_of: Not a type (1)" | _ -> outsort env sigma (type_of env t) and sort_family_of env t = match T.kind_of_term t with | T.Cast (c,_, s) when T.isSort s -> family_of_term s | T.Sort (T.Prop c) -> Coq_sort T.InType | T.Sort (T.Type u) -> Coq_sort T.InType | T.Prod (name,t,c2) -> sort_family_of (Environ.push_rel (name,None,t) env) c2 | T.App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args | T.Lambda _ | T.Fix _ | T.Construct _ -> Util.anomaly "sort_of: Not a type (1)" | _ -> outsort env sigma (type_of env t) in type_of, sort_of, sort_family_of let get_type_of env sigma c = let f,_,_ = typeur sigma [] in f env c let get_sort_family_of env sigma c = let _,_,f = typeur sigma [] in f env c end ;; let get_sort_family_of env evar_map ty = CPropRetyping.get_sort_family_of env evar_map ty ;; let type_as_sort env evar_map ty = (* CCorn code *) family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env evar_map ty) ;; let is_a_Prop = function "Prop" | "CProp" -> true | _ -> false ;; (* Main Functions *) type anntypes = {annsynthesized : Acic.aconstr ; annexpected : Acic.aconstr option} ;; let gen_id seed = let res = "i" ^ string_of_int !seed in incr seed ; res ;; let fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids = fun father t -> let res = gen_id seed in Hashtbl.add ids_to_father_ids res father ; Hashtbl.add ids_to_terms res t ; Acic.CicHash.add constr_to_ids t res ; res ;; let source_id_of_id id = "#source#" ^ id;; let acic_of_cic_context' computeinnertypes seed ids_to_terms constr_to_ids ids_to_father_ids ids_to_inner_sorts ids_to_inner_types ?(fake_dependent_products=false) env idrefs evar_map t expectedty = let module D = DoubleTypeInference in let module E = Environ in let module N = Names in let module A = Acic in let module T = Term in let fresh_id' = fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids in (* CSC: do you have any reasonable substitute for 503? *) let terms_to_types = Acic.CicHash.create 503 in D.double_type_of env evar_map t expectedty terms_to_types ; let rec aux computeinnertypes father passed_lambdas_or_prods_or_letins env idrefs ?(subst=None,[]) tt = let fresh_id'' = fresh_id' father tt in let aux' = aux computeinnertypes (Some fresh_id'') [] in let string_of_sort_family = function Coq_sort T.InProp -> "Prop" | Coq_sort T.InSet -> "Set" | Coq_sort T.InType -> "Type" | CProp -> "CProp" in let string_of_sort t = string_of_sort_family (type_as_sort env evar_map t) in let ainnertypes,innertype,innersort,expected_available = let {D.synthesized = synthesized; D.expected = expected} = if computeinnertypes then try Acic.CicHash.find terms_to_types tt with e when e <> Sys.Break -> (*CSC: Warning: it really happens, for example in Ring_theory!!! *) Pp.ppnl (Pp.(++) (Pp.str "BUG: this subterm was not visited during the double-type-inference: ") (Printer.pr_lconstr tt)) ; assert false else (* We are already in an inner-type and Coscoy's double *) (* type inference algorithm has not been applied. *) (* We need to refresh the universes because we are doing *) (* type inference on an already inferred type. *) {D.synthesized = Reductionops.nf_beta evar_map (CPropRetyping.get_type_of env evar_map (Termops.refresh_universes tt)) ; D.expected = None} in (* Debugging only: print_endline "TERMINE:" ; flush stdout ; Pp.ppnl (Printer.pr_lconstr tt) ; flush stdout ; print_endline "TIPO:" ; flush stdout ; Pp.ppnl (Printer.pr_lconstr synthesized) ; flush stdout ; print_endline "ENVIRONMENT:" ; flush stdout ; Pp.ppnl (Printer.pr_context_of env) ; flush stdout ; print_endline "FINE_ENVIRONMENT" ; flush stdout ; *) let innersort = let synthesized_innersort = get_sort_family_of env evar_map synthesized in match expected with None -> synthesized_innersort | Some ty -> let expected_innersort = get_sort_family_of env evar_map ty in match expected_innersort, synthesized_innersort with CProp, _ | _, CProp -> CProp | _, _ -> expected_innersort in (* Debugging only: print_endline "PASSATO" ; flush stdout ; *) let ainnertypes,expected_available = if computeinnertypes then let annexpected,expected_available = match expected with None -> None,false | Some expectedty' -> Some (aux false (Some fresh_id'') [] env idrefs expectedty'), true in Some {annsynthesized = aux false (Some fresh_id'') [] env idrefs synthesized ; annexpected = annexpected }, expected_available else None,false in ainnertypes,synthesized, string_of_sort_family innersort, expected_available in let add_inner_type id = match ainnertypes with None -> () | Some ainnertypes -> Hashtbl.add ids_to_inner_types id ainnertypes in (* explicit_substitute_and_eta_expand_if_required h t t' *) (* where [t] = [] and [tt] = [h]{[t']} ("{.}" denotes explicit *) (* named substitution) or [tt] = (App [h]::[t]) (and [t'] = []) *) (* check if [h] is a term that requires an explicit named *) (* substitution and, in that case, uses the first arguments of *) (* [t] as the actual arguments of the substitution. If there *) (* are not enough parameters in the list [t], then eta-expansion *) (* is performed. *) let explicit_substitute_and_eta_expand_if_required h t t' compute_result_if_eta_expansion_not_required = let subst,residual_args,uninst_vars = let variables,basedir = try let g = Libnames.global_of_constr h in let sp = match g with Libnames.ConstructRef ((induri,_),_) | Libnames.IndRef (induri,_) -> Nametab.path_of_global (Libnames.IndRef (induri,0)) | Libnames.VarRef id -> (* Invariant: variables are never cooked in Coq *) raise Not_found | _ -> Nametab.path_of_global g in Dischargedhypsmap.get_discharged_hyps sp, get_module_path_of_full_path sp with Not_found -> (* no explicit substitution *) [], Libnames.dirpath_of_string "dummy" in (* returns a triple whose first element is *) (* an explicit named substitution of "type" *) (* (variable * argument) list, whose *) (* second element is the list of residual *) (* arguments and whose third argument is *) (* the list of uninstantiated variables *) let rec get_explicit_subst variables arguments = match variables,arguments with [],_ -> [],arguments,[] | _,[] -> [],[],variables | he1::tl1,he2::tl2 -> let subst,extra_args,uninst = get_explicit_subst tl1 tl2 in let (he1_sp, he1_id) = Libnames.repr_path he1 in let he1' = remove_module_dirpath_from_dirpath ~basedir he1_sp in let he1'' = String.concat "/" (List.map Names.string_of_id (List.rev he1')) ^ "/" ^ (Names.string_of_id he1_id) ^ ".var" in (he1'',he2)::subst, extra_args, uninst in get_explicit_subst variables t' in let uninst_vars_length = List.length uninst_vars in if uninst_vars_length > 0 then (* Not enough arguments provided. We must eta-expand! *) let un_args,_ = T.decompose_prod_n uninst_vars_length (CPropRetyping.get_type_of env evar_map tt) in let eta_expanded = let arguments = List.map (T.lift uninst_vars_length) t @ Termops.rel_list 0 uninst_vars_length in Unshare.unshare (T.lamn uninst_vars_length un_args (T.applistc h arguments)) in D.double_type_of env evar_map eta_expanded None terms_to_types ; Hashtbl.remove ids_to_inner_types fresh_id'' ; aux' env idrefs eta_expanded else compute_result_if_eta_expansion_not_required subst residual_args in (* Now that we have all the auxiliary functions we *) (* can finally proceed with the main case analysis. *) match T.kind_of_term tt with T.Rel n -> let id = match List.nth (E.rel_context env) (n - 1) with (N.Name id,_,_) -> id | (N.Anonymous,_,_) -> Nameops.make_ident "_" None in Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort && expected_available then add_inner_type fresh_id'' ; A.ARel (fresh_id'', n, List.nth idrefs (n-1), id) | T.Var id -> let pvars = Termops.ids_of_named_context (E.named_context env) in let pvars = List.map N.string_of_id pvars in let path = get_uri_of_var (N.string_of_id id) pvars in Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort && expected_available then add_inner_type fresh_id'' ; A.AVar (fresh_id'', path ^ "/" ^ (N.string_of_id id) ^ ".var") | T.Evar (n,l) -> Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort && expected_available then add_inner_type fresh_id'' ; A.AEvar (fresh_id'', n, Array.to_list (Array.map (aux' env idrefs) l)) | T.Meta _ -> Util.anomaly "Meta met during exporting to XML" | T.Sort s -> A.ASort (fresh_id'', s) | T.Cast (v,_, t) -> Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort then add_inner_type fresh_id'' ; A.ACast (fresh_id'', aux' env idrefs v, aux' env idrefs t) | T.Prod (n,s,t) -> let n' = match n with N.Anonymous -> N.Anonymous | _ -> if not fake_dependent_products && T.noccurn 1 t then N.Anonymous else N.Name (Namegen.next_name_away n (Termops.ids_of_context env)) in Hashtbl.add ids_to_inner_sorts fresh_id'' (string_of_sort innertype) ; let sourcetype = CPropRetyping.get_type_of env evar_map s in Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'') (string_of_sort sourcetype) ; let new_passed_prods = let father_is_prod = match father with None -> false | Some father' -> match Term.kind_of_term (Hashtbl.find ids_to_terms father') with T.Prod _ -> true | _ -> false in (fresh_id'', n', aux' env idrefs s):: (if father_is_prod then passed_lambdas_or_prods_or_letins else []) in let new_env = E.push_rel (n', None, s) env in let new_idrefs = fresh_id''::idrefs in (match Term.kind_of_term t with T.Prod _ -> aux computeinnertypes (Some fresh_id'') new_passed_prods new_env new_idrefs t | _ -> A.AProds (new_passed_prods, aux' new_env new_idrefs t)) | T.Lambda (n,s,t) -> let n' = match n with N.Anonymous -> N.Anonymous | _ -> N.Name (Namegen.next_name_away n (Termops.ids_of_context env)) in Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; let sourcetype = CPropRetyping.get_type_of env evar_map s in Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'') (string_of_sort sourcetype) ; let father_is_lambda = match father with None -> false | Some father' -> match Term.kind_of_term (Hashtbl.find ids_to_terms father') with T.Lambda _ -> true | _ -> false in if is_a_Prop innersort && ((not father_is_lambda) || expected_available) then add_inner_type fresh_id'' ; let new_passed_lambdas = (fresh_id'',n', aux' env idrefs s):: (if father_is_lambda then passed_lambdas_or_prods_or_letins else []) in let new_env = E.push_rel (n', None, s) env in let new_idrefs = fresh_id''::idrefs in (match Term.kind_of_term t with T.Lambda _ -> aux computeinnertypes (Some fresh_id'') new_passed_lambdas new_env new_idrefs t | _ -> let t' = aux' new_env new_idrefs t in (* eta-expansion for explicit named substitutions *) (* can create nested Lambdas. Here we perform the *) (* flattening. *) match t' with A.ALambdas (lambdas, t'') -> A.ALambdas (lambdas@new_passed_lambdas, t'') | _ -> A.ALambdas (new_passed_lambdas, t') ) | T.LetIn (n,s,t,d) -> let id = match n with N.Anonymous -> N.id_of_string "_X" | N.Name id -> id in let n' = N.Name (Namegen.next_ident_away id (Termops.ids_of_context env)) in Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; let sourcesort = get_sort_family_of env evar_map (CPropRetyping.get_type_of env evar_map s) in Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'') (string_of_sort_family sourcesort) ; let father_is_letin = match father with None -> false | Some father' -> match Term.kind_of_term (Hashtbl.find ids_to_terms father') with T.LetIn _ -> true | _ -> false in if is_a_Prop innersort then add_inner_type fresh_id'' ; let new_passed_letins = (fresh_id'',n', aux' env idrefs s):: (if father_is_letin then passed_lambdas_or_prods_or_letins else []) in let new_env = E.push_rel (n', Some s, t) env in let new_idrefs = fresh_id''::idrefs in (match Term.kind_of_term d with T.LetIn _ -> aux computeinnertypes (Some fresh_id'') new_passed_letins new_env new_idrefs d | _ -> A.ALetIns (new_passed_letins, aux' new_env new_idrefs d)) | T.App (h,t) -> Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort then add_inner_type fresh_id'' ; let compute_result_if_eta_expansion_not_required subst residual_args = let residual_args_not_empty = residual_args <> [] in let h' = if residual_args_not_empty then aux' env idrefs ~subst:(None,subst) h else aux' env idrefs ~subst:(Some fresh_id'',subst) h in (* maybe all the arguments were used for the explicit *) (* named substitution *) if residual_args_not_empty then A.AApp (fresh_id'', h'::residual_args) else h' in let t' = Array.fold_right (fun x i -> (aux' env idrefs x)::i) t [] in explicit_substitute_and_eta_expand_if_required h (Array.to_list t) t' compute_result_if_eta_expansion_not_required | T.Const kn -> Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort && expected_available then add_inner_type fresh_id'' ; let compute_result_if_eta_expansion_not_required _ _ = A.AConst (fresh_id'', subst, (uri_of_kernel_name (Constant kn))) in let (_,subst') = subst in explicit_substitute_and_eta_expand_if_required tt [] (List.map snd subst') compute_result_if_eta_expansion_not_required | T.Ind (kn,i) -> let compute_result_if_eta_expansion_not_required _ _ = A.AInd (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i) in let (_,subst') = subst in explicit_substitute_and_eta_expand_if_required tt [] (List.map snd subst') compute_result_if_eta_expansion_not_required | T.Construct ((kn,i),j) -> Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort && expected_available then add_inner_type fresh_id'' ; let compute_result_if_eta_expansion_not_required _ _ = A.AConstruct (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i, j) in let (_,subst') = subst in explicit_substitute_and_eta_expand_if_required tt [] (List.map snd subst') compute_result_if_eta_expansion_not_required | T.Case ({T.ci_ind=(kn,i)},ty,term,a) -> Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort then add_inner_type fresh_id'' ; let a' = Array.fold_right (fun x i -> (aux' env idrefs x)::i) a [] in A.ACase (fresh_id'', (uri_of_kernel_name (Inductive kn)), i, aux' env idrefs ty, aux' env idrefs term, a') | T.Fix ((ai,i),(f,t,b)) -> Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort then add_inner_type fresh_id'' ; let fresh_idrefs = Array.init (Array.length t) (function _ -> gen_id seed) in let new_idrefs = (List.rev (Array.to_list fresh_idrefs)) @ idrefs in let f' = let ids = ref (Termops.ids_of_context env) in Array.map (function N.Anonymous -> Util.error "Anonymous fix function met" | N.Name id as n -> let res = N.Name (Namegen.next_name_away n !ids) in ids := id::!ids ; res ) f in A.AFix (fresh_id'', i, Array.fold_right (fun (id,fi,ti,bi,ai) i -> let fi' = match fi with N.Name fi -> fi | N.Anonymous -> Util.error "Anonymous fix function met" in (id, fi', ai, aux' env idrefs ti, aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i) (Array.mapi (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j),ai.(j))) f' ) [] ) | T.CoFix (i,(f,t,b)) -> Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort then add_inner_type fresh_id'' ; let fresh_idrefs = Array.init (Array.length t) (function _ -> gen_id seed) in let new_idrefs = (List.rev (Array.to_list fresh_idrefs)) @ idrefs in let f' = let ids = ref (Termops.ids_of_context env) in Array.map (function N.Anonymous -> Util.error "Anonymous fix function met" | N.Name id as n -> let res = N.Name (Namegen.next_name_away n !ids) in ids := id::!ids ; res ) f in A.ACoFix (fresh_id'', i, Array.fold_right (fun (id,fi,ti,bi) i -> let fi' = match fi with N.Name fi -> fi | N.Anonymous -> Util.error "Anonymous fix function met" in (id, fi', aux' env idrefs ti, aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i) (Array.mapi (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j)) ) f' ) [] ) in aux computeinnertypes None [] env idrefs t ;; (* Obsolete [HH 1/2009] let acic_of_cic_context metasenv context t = let ids_to_terms = Hashtbl.create 503 in let constr_to_ids = Acic.CicHash.create 503 in let ids_to_father_ids = Hashtbl.create 503 in let ids_to_inner_sorts = Hashtbl.create 503 in let ids_to_inner_types = Hashtbl.create 503 in let seed = ref 0 in acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids ids_to_inner_sorts ids_to_inner_types metasenv context t, ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, ids_to_inner_types ;; *) let acic_object_of_cic_object sigma obj = let module A = Acic in let ids_to_terms = Hashtbl.create 503 in let constr_to_ids = Acic.CicHash.create 503 in let ids_to_father_ids = Hashtbl.create 503 in let ids_to_inner_sorts = Hashtbl.create 503 in let ids_to_inner_types = Hashtbl.create 503 in let ids_to_conjectures = Hashtbl.create 11 in let ids_to_hypotheses = Hashtbl.create 127 in let hypotheses_seed = ref 0 in let conjectures_seed = ref 0 in let seed = ref 0 in let acic_term_of_cic_term_context' = acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids ids_to_inner_sorts ids_to_inner_types in (*CSC: is this the right env to use? Hhmmm. There is a problem: in *) (*CSC: Global.env () the object we are exporting is already defined, *) (*CSC: either in the environment or in the named context (in the case *) (*CSC: of variables. Is this a problem? *) let env = Global.env () in let acic_term_of_cic_term' ?fake_dependent_products = acic_term_of_cic_term_context' ?fake_dependent_products env [] sigma in (*CSC: the fresh_id is not stored anywhere. This _MUST_ be fixed using *) (*CSC: a modified version of the already existent fresh_id function *) let fresh_id () = let res = "i" ^ string_of_int !seed in incr seed ; res in let aobj = match obj with A.Constant (id,bo,ty,params) -> let abo = match bo with None -> None | Some bo' -> Some (acic_term_of_cic_term' bo' (Some ty)) in let aty = acic_term_of_cic_term' ty None in A.AConstant (fresh_id (),id,abo,aty,params) | A.Variable (id,bo,ty,params) -> let abo = match bo with Some bo -> Some (acic_term_of_cic_term' bo (Some ty)) | None -> None in let aty = acic_term_of_cic_term' ty None in A.AVariable (fresh_id (),id,abo,aty,params) | A.CurrentProof (id,conjectures,bo,ty) -> let aconjectures = List.map (function (i,canonical_context,term) as conjecture -> let cid = "c" ^ string_of_int !conjectures_seed in Hashtbl.add ids_to_conjectures cid conjecture ; incr conjectures_seed ; let canonical_env,idrefs',acanonical_context = let rec aux env idrefs = function [] -> env,idrefs,[] | ((n,decl_or_def) as hyp)::tl -> let hid = "h" ^ string_of_int !hypotheses_seed in let new_idrefs = hid::idrefs in Hashtbl.add ids_to_hypotheses hid hyp ; incr hypotheses_seed ; match decl_or_def with A.Decl t -> let final_env,final_idrefs,atl = aux (Environ.push_rel (Names.Name n,None,t) env) new_idrefs tl in let at = acic_term_of_cic_term_context' env idrefs sigma t None in final_env,final_idrefs,(hid,(n,A.Decl at))::atl | A.Def (t,ty) -> let final_env,final_idrefs,atl = aux (Environ.push_rel (Names.Name n,Some t,ty) env) new_idrefs tl in let at = acic_term_of_cic_term_context' env idrefs sigma t None in let dummy_never_used = let s = "dummy_never_used" in A.ARel (s,99,s,Names.id_of_string s) in final_env,final_idrefs, (hid,(n,A.Def (at,dummy_never_used)))::atl in aux env [] canonical_context in let aterm = acic_term_of_cic_term_context' canonical_env idrefs' sigma term None in (cid,i,List.rev acanonical_context,aterm) ) conjectures in let abo = acic_term_of_cic_term_context' env [] sigma bo (Some ty) in let aty = acic_term_of_cic_term_context' env [] sigma ty None in A.ACurrentProof (fresh_id (),id,aconjectures,abo,aty) | A.InductiveDefinition (tys,params,paramsno) -> let env' = List.fold_right (fun (name,_,arity,_) env -> Environ.push_rel (Names.Name name, None, arity) env ) (List.rev tys) env in let idrefs = List.map (function _ -> gen_id seed) tys in let atys = List.map2 (fun id (name,inductive,ty,cons) -> let acons = List.map (function (name,ty) -> (name, acic_term_of_cic_term_context' ~fake_dependent_products:true env' idrefs Evd.empty ty None) ) cons in let aty = acic_term_of_cic_term' ~fake_dependent_products:true ty None in (id,name,inductive,aty,acons) ) (List.rev idrefs) tys in A.AInductiveDefinition (fresh_id (),atys,params,paramsno) in aobj,ids_to_terms,constr_to_ids,ids_to_father_ids,ids_to_inner_sorts, ids_to_inner_types,ids_to_conjectures,ids_to_hypotheses ;; coq-8.4pl4/plugins/xml/cic2Xml.ml0000644000175000017500000000115212326224777015746 0ustar stephstephlet print_xml_term ch env sigma cic = let ids_to_terms = Hashtbl.create 503 in let constr_to_ids = Acic.CicHash.create 503 in let ids_to_father_ids = Hashtbl.create 503 in let ids_to_inner_sorts = Hashtbl.create 503 in let ids_to_inner_types = Hashtbl.create 503 in let seed = ref 0 in let acic = Cic2acic.acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids ids_to_inner_sorts ids_to_inner_types env [] sigma (Unshare.unshare cic) None in let xml = Acic2Xml.print_term ids_to_inner_sorts acic in Xml.pp_ch xml ch ;; Tacinterp.declare_xml_printer print_xml_term ;; coq-8.4pl4/plugins/xml/acic.ml0000644000175000017500000001161412326224777015350 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Evd.evar_map -> Term.constr -> Term.constr val double_type_of : Environ.env -> Evd.evar_map -> Term.constr -> Term.constr option -> types Acic.CicHash.t -> unit coq-8.4pl4/plugins/xml/xml_plugin.mllib0000644000175000017500000000021012326224777017304 0ustar stephstephUnshare Xml Acic DoubleTypeInference Cic2acic Acic2Xml Proof2aproof Xmlcommand ProofTree2Xml Xmlentries Cic2Xml Dumptree Xml_plugin_mod coq-8.4pl4/plugins/xml/xml.mli0000644000175000017500000000433012326224777015417 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (string * string) list -> token Stream.t val xml_nempty : string -> (string * string) list -> token Stream.t -> token Stream.t val xml_cdata : string -> token Stream.t val pp_ch : token Stream.t -> out_channel -> unit (* The pretty printer for streams of token *) (* Usage: *) (* pp tokens None pretty prints the output on stdout *) (* pp tokens (Some filename) pretty prints the output on the file filename *) val pp : token Stream.t -> string option -> unit coq-8.4pl4/plugins/syntax/0000755000175000017500000000000012365131025014624 5ustar stephstephcoq-8.4pl4/plugins/syntax/ascii_syntax.ml0000644000175000017500000000520312326224777017672 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 | GRef (_,k)::l when k = glob_true -> 1+2*(uninterp_bool_list (n-1) l) | GRef (_,k)::l when k = glob_false -> 2*(uninterp_bool_list (n-1) l) | _ -> raise Non_closed_ascii in try let rec aux = function | GApp (_,GRef (_,k),l) when k = force glob_Ascii -> uninterp_bool_list 8 l | _ -> raise Non_closed_ascii in Some (aux r) with Non_closed_ascii -> None let make_ascii_string n = if n>=32 && n<=126 then String.make 1 (char_of_int n) else Printf.sprintf "%03d" n let uninterp_ascii_string r = Option.map make_ascii_string (uninterp_ascii r) let _ = Notation.declare_string_interpreter "char_scope" (ascii_path,ascii_module) interp_ascii_string ([GRef (dummy_loc,static_glob_Ascii)], uninterp_ascii_string, true) coq-8.4pl4/plugins/syntax/r_syntax_plugin.mllib0000644000175000017500000000003512326224777021106 0ustar stephstephR_syntax R_syntax_plugin_mod coq-8.4pl4/plugins/syntax/nat_syntax_plugin.mllib0000644000175000017500000000004112326224777021424 0ustar stephstephNat_syntax Nat_syntax_plugin_mod coq-8.4pl4/plugins/syntax/numbers_syntax_plugin.mllib0000644000175000017500000000005112326224777022316 0ustar stephstephNumbers_syntax Numbers_syntax_plugin_mod coq-8.4pl4/plugins/syntax/string_syntax.ml0000644000175000017500000000407112326224777020112 0ustar stephsteph(***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (match uninterp_ascii a with | Some c -> Buffer.add_char b (Char.chr c); aux s | _ -> raise Non_closed_string) | GRef (_,z) when z = force glob_EmptyString -> Some (Buffer.contents b) | _ -> raise Non_closed_string in aux r with Non_closed_string -> None let _ = Notation.declare_string_interpreter "string_scope" (string_path,["Coq";"Strings";"String"]) interp_string ([GRef (dummy_loc,static_glob_String); GRef (dummy_loc,static_glob_EmptyString)], uninterp_string, true) coq-8.4pl4/plugins/syntax/nat_syntax.ml0000644000175000017500000000451312326224777017367 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* > *) let threshold = of_int 5000 let nat_of_int dloc n = if is_pos_or_zero n then begin if less_than threshold n then Flags.if_warn msg_warning (strbrk "Stack overflow or segmentation fault happens when " ++ strbrk "working with large numbers in nat (observed threshold " ++ strbrk "may vary from 5000 to 70000 depending on your system " ++ strbrk "limits and on the command executed)."); let ref_O = GRef (dloc, glob_O) in let ref_S = GRef (dloc, glob_S) in let rec mk_nat acc n = if n <> zero then mk_nat (GApp (dloc,ref_S, [acc])) (sub_1 n) else acc in mk_nat ref_O n end else user_err_loc (dloc, "nat_of_int", str "Cannot interpret a negative number as a number of type nat") (************************************************************************) (* Printing via scopes *) exception Non_closed_number let rec int_of_nat = function | GApp (_,GRef (_,s),[a]) when s = glob_S -> add_1 (int_of_nat a) | GRef (_,z) when z = glob_O -> zero | _ -> raise Non_closed_number let uninterp_nat p = try Some (int_of_nat p) with Non_closed_number -> None (************************************************************************) (* Declare the primitive parsers and printers *) let _ = Notation.declare_numeral_interpreter "nat_scope" (nat_path,["Coq";"Init";"Datatypes"]) nat_of_int ([GRef (dummy_loc,glob_S); GRef (dummy_loc,glob_O)], uninterp_nat, true) coq-8.4pl4/plugins/syntax/numbers_syntax.ml0000644000175000017500000002155112326224777020261 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* cur | (GRef (_,b))::l when b = int31_0 -> args_parsing l (mult_2 cur) | (GRef (_,b))::l when b = int31_1 -> args_parsing l (add_1 (mult_2 cur)) | _ -> raise Non_closed in function | GApp (_, GRef (_, c), args) when c=int31_construct -> args_parsing args zero | _ -> raise Non_closed let uninterp_int31 i = try Some (bigint_of_int31 i) with Non_closed -> None (* Actually declares the interpreter for int31 *) let _ = Notation.declare_numeral_interpreter int31_scope (int31_path, int31_module) interp_int31 ([GRef (Util.dummy_loc, int31_construct)], uninterp_int31, true) (*** Parsing for bigN in digital notation ***) (* the base for bigN (in Coq) that is 2^31 in our case *) let base = pow two 31 (* base of the bigN of height N : (2^31)^(2^n) *) let rank n = let rec rk n pow2 = if n <= 0 then pow2 else rk (n-1) (mult pow2 pow2) in rk n base (* splits a number bi at height n, that is the rest needs 2^n int31 to be stored it is expected to be used only when the quotient would also need 2^n int31 to be stored *) let split_at n bi = euclid bi (rank (n-1)) (* search the height of the Coq bigint needed to represent the integer bi *) let height bi = let rec hght n pow2 = if less_than bi pow2 then n else hght (n+1) (mult pow2 pow2) in hght 0 base (* n must be a non-negative integer (from bigint.ml) *) let word_of_pos_bigint dloc hght n = let ref_W0 = GRef (dloc, zn2z_W0) in let ref_WW = GRef (dloc, zn2z_WW) in let rec decomp hgt n = if hgt <= 0 then int31_of_pos_bigint dloc n else if equal n zero then GApp (dloc, ref_W0, [GHole (dloc, Evd.InternalHole)]) else let (h,l) = split_at hgt n in GApp (dloc, ref_WW, [GHole (dloc, Evd.InternalHole); decomp (hgt-1) h; decomp (hgt-1) l]) in decomp hght n let bigN_of_pos_bigint dloc n = let h = height n in let ref_constructor = GRef (dloc, bigN_constructor h) in let word = word_of_pos_bigint dloc h n in let args = if h < n_inlined then [word] else [Nat_syntax.nat_of_int dloc (of_int (h-n_inlined));word] in GApp (dloc, ref_constructor, args) let bigN_error_negative dloc = Util.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.") let interp_bigN dloc n = if is_pos_or_zero n then bigN_of_pos_bigint dloc n else bigN_error_negative dloc (* Pretty prints a bigN *) let bigint_of_word = let rec get_height rc = match rc with | GApp (_,GRef(_,c), [_;lft;rght]) when c = zn2z_WW -> 1+max (get_height lft) (get_height rght) | _ -> 0 in let rec transform hght rc = match rc with | GApp (_,GRef(_,c),_) when c = zn2z_W0-> zero | GApp (_,GRef(_,c), [_;lft;rght]) when c=zn2z_WW-> let new_hght = hght-1 in add (mult (rank new_hght) (transform new_hght lft)) (transform new_hght rght) | _ -> bigint_of_int31 rc in fun rc -> let hght = get_height rc in transform hght rc let bigint_of_bigN rc = match rc with | GApp (_,_,[one_arg]) -> bigint_of_word one_arg | GApp (_,_,[_;second_arg]) -> bigint_of_word second_arg | _ -> raise Non_closed let uninterp_bigN rc = try Some (bigint_of_bigN rc) with Non_closed -> None (* declare the list of constructors of bigN used in the declaration of the numeral interpreter *) let bigN_list_of_constructors = let rec build i = if i < n_inlined+1 then GRef (Util.dummy_loc, bigN_constructor i)::(build (i+1)) else [] in build 0 (* Actually declares the interpreter for bigN *) let _ = Notation.declare_numeral_interpreter bigN_scope (bigN_path, bigN_module) interp_bigN (bigN_list_of_constructors, uninterp_bigN, true) (*** Parsing for bigZ in digital notation ***) let interp_bigZ dloc n = let ref_pos = GRef (dloc, bigZ_pos) in let ref_neg = GRef (dloc, bigZ_neg) in if is_pos_or_zero n then GApp (dloc, ref_pos, [bigN_of_pos_bigint dloc n]) else GApp (dloc, ref_neg, [bigN_of_pos_bigint dloc (neg n)]) (* pretty printing functions for bigZ *) let bigint_of_bigZ = function | GApp (_, GRef(_,c), [one_arg]) when c = bigZ_pos -> bigint_of_bigN one_arg | GApp (_, GRef(_,c), [one_arg]) when c = bigZ_neg -> let opp_val = bigint_of_bigN one_arg in if equal opp_val zero then raise Non_closed else neg opp_val | _ -> raise Non_closed let uninterp_bigZ rc = try Some (bigint_of_bigZ rc) with Non_closed -> None (* Actually declares the interpreter for bigZ *) let _ = Notation.declare_numeral_interpreter bigZ_scope (bigZ_path, bigZ_module) interp_bigZ ([GRef (Util.dummy_loc, bigZ_pos); GRef (Util.dummy_loc, bigZ_neg)], uninterp_bigZ, true) (*** Parsing for bigQ in digital notation ***) let interp_bigQ dloc n = let ref_z = GRef (dloc, bigQ_z) in GApp (dloc, ref_z, [interp_bigZ dloc n]) let uninterp_bigQ rc = try match rc with | GApp (_, GRef(_,c), [one_arg]) when c = bigQ_z -> Some (bigint_of_bigZ one_arg) | _ -> None (* we don't pretty-print yet fractions *) with Non_closed -> None (* Actually declares the interpreter for bigQ *) let _ = Notation.declare_numeral_interpreter bigQ_scope (bigQ_path, bigQ_module) interp_bigQ ([GRef (Util.dummy_loc, bigQ_z)], uninterp_bigQ, true) coq-8.4pl4/plugins/syntax/z_syntax.ml0000644000175000017500000001450312326224777017056 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* GApp (dloc, ref_xO,[pos_of q]) | (q,true) when q <> zero -> GApp (dloc,ref_xI,[pos_of q]) | (q,true) -> ref_xH in pos_of x let error_non_positive dloc = user_err_loc (dloc, "interp_positive", str "Only strictly positive numbers in type \"positive\".") let interp_positive dloc n = if is_strictly_pos n then pos_of_bignat dloc n else error_non_positive dloc (**********************************************************************) (* Printing positive via scopes *) (**********************************************************************) let rec bignat_of_pos = function | GApp (_, GRef (_,b),[a]) when b = glob_xO -> mult_2(bignat_of_pos a) | GApp (_, GRef (_,b),[a]) when b = glob_xI -> add_1(mult_2(bignat_of_pos a)) | GRef (_, a) when a = glob_xH -> Bigint.one | _ -> raise Non_closed_number let uninterp_positive p = try Some (bignat_of_pos p) with Non_closed_number -> None (************************************************************************) (* Declaring interpreters and uninterpreters for positive *) (************************************************************************) let _ = Notation.declare_numeral_interpreter "positive_scope" (positive_path,binnums) interp_positive ([GRef (dummy_loc, glob_xI); GRef (dummy_loc, glob_xO); GRef (dummy_loc, glob_xH)], uninterp_positive, true) (**********************************************************************) (* Parsing N via scopes *) (**********************************************************************) let n_kn = make_kn (make_dir binnums) (id_of_string "N") let glob_n = IndRef (n_kn,0) let path_of_N0 = ((n_kn,0),1) let path_of_Npos = ((n_kn,0),2) let glob_N0 = ConstructRef path_of_N0 let glob_Npos = ConstructRef path_of_Npos let n_path = make_path binnums "N" let n_of_binnat dloc pos_or_neg n = if n <> zero then GApp(dloc, GRef (dloc,glob_Npos), [pos_of_bignat dloc n]) else GRef (dloc, glob_N0) let error_negative dloc = user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\".") let n_of_int dloc n = if is_pos_or_zero n then n_of_binnat dloc true n else error_negative dloc (**********************************************************************) (* Printing N via scopes *) (**********************************************************************) let bignat_of_n = function | GApp (_, GRef (_,b),[a]) when b = glob_Npos -> bignat_of_pos a | GRef (_, a) when a = glob_N0 -> Bigint.zero | _ -> raise Non_closed_number let uninterp_n p = try Some (bignat_of_n p) with Non_closed_number -> None (************************************************************************) (* Declaring interpreters and uninterpreters for N *) let _ = Notation.declare_numeral_interpreter "N_scope" (n_path,binnums) n_of_int ([GRef (dummy_loc, glob_N0); GRef (dummy_loc, glob_Npos)], uninterp_n, true) (**********************************************************************) (* Parsing Z via scopes *) (**********************************************************************) let z_path = make_path binnums "Z" let z_kn = make_kn (make_dir binnums) (id_of_string "Z") let glob_z = IndRef (z_kn,0) let path_of_ZERO = ((z_kn,0),1) let path_of_POS = ((z_kn,0),2) let path_of_NEG = ((z_kn,0),3) let glob_ZERO = ConstructRef path_of_ZERO let glob_POS = ConstructRef path_of_POS let glob_NEG = ConstructRef path_of_NEG let z_of_int dloc n = if n <> zero then let sgn, n = if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in GApp(dloc, GRef (dloc,sgn), [pos_of_bignat dloc n]) else GRef (dloc, glob_ZERO) (**********************************************************************) (* Printing Z via scopes *) (**********************************************************************) let bigint_of_z = function | GApp (_, GRef (_,b),[a]) when b = glob_POS -> bignat_of_pos a | GApp (_, GRef (_,b),[a]) when b = glob_NEG -> Bigint.neg (bignat_of_pos a) | GRef (_, a) when a = glob_ZERO -> Bigint.zero | _ -> raise Non_closed_number let uninterp_z p = try Some (bigint_of_z p) with Non_closed_number -> None (************************************************************************) (* Declaring interpreters and uninterpreters for Z *) let _ = Notation.declare_numeral_interpreter "Z_scope" (z_path,binnums) z_of_int ([GRef (dummy_loc, glob_ZERO); GRef (dummy_loc, glob_POS); GRef (dummy_loc, glob_NEG)], uninterp_z, true) coq-8.4pl4/plugins/syntax/r_syntax.ml0000644000175000017500000001013012326224777017036 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* zero then r_of_pos n else GRef(dloc,glob_R0) let r_of_int dloc z = if is_strictly_neg z then GApp (dloc, GRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)]) else r_of_posint dloc z (**********************************************************************) (* Printing R via scopes *) (**********************************************************************) let bignat_of_r = (* for numbers > 1 *) let rec bignat_of_pos = function (* 1+1 *) | GApp (_,GRef (_,p), [GRef (_,o1); GRef (_,o2)]) when p = glob_Rplus & o1 = glob_R1 & o2 = glob_R1 -> two (* 1+(1+1) *) | GApp (_,GRef (_,p1), [GRef (_,o1); GApp(_,GRef (_,p2),[GRef(_,o2);GRef(_,o3)])]) when p1 = glob_Rplus & p2 = glob_Rplus & o1 = glob_R1 & o2 = glob_R1 & o3 = glob_R1 -> three (* (1+1)*b *) | GApp (_,GRef (_,p), [a; b]) when p = glob_Rmult -> if bignat_of_pos a <> two then raise Non_closed_number; mult_2 (bignat_of_pos b) (* 1+(1+1)*b *) | GApp (_,GRef (_,p1), [GRef (_,o); GApp (_,GRef (_,p2),[a;b])]) when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1 -> if bignat_of_pos a <> two then raise Non_closed_number; add_1 (mult_2 (bignat_of_pos b)) | _ -> raise Non_closed_number in let bignat_of_r = function | GRef (_,a) when a = glob_R0 -> zero | GRef (_,a) when a = glob_R1 -> one | r -> bignat_of_pos r in bignat_of_r let bigint_of_r = function | GApp (_,GRef (_,o), [a]) when o = glob_Ropp -> let n = bignat_of_r a in if n = zero then raise Non_closed_number; neg n | a -> bignat_of_r a let uninterp_r p = try Some (bigint_of_r p) with Non_closed_number -> None let _ = Notation.declare_numeral_interpreter "R_scope" (r_path,["Coq";"Reals";"Rdefinitions"]) r_of_int ([GRef(dummy_loc,glob_Ropp);GRef(dummy_loc,glob_R0); GRef(dummy_loc,glob_Rplus);GRef(dummy_loc,glob_Rmult); GRef(dummy_loc,glob_R1)], uninterp_r, false) coq-8.4pl4/plugins/syntax/string_syntax_plugin.mllib0000644000175000017500000000004712326224777022156 0ustar stephstephString_syntax String_syntax_plugin_mod coq-8.4pl4/plugins/syntax/z_syntax_plugin.mllib0000644000175000017500000000003512326224777021116 0ustar stephstephZ_syntax Z_syntax_plugin_mod coq-8.4pl4/plugins/syntax/ascii_syntax_plugin.mllib0000644000175000017500000000004512326224777021736 0ustar stephstephAscii_syntax Ascii_syntax_plugin_mod coq-8.4pl4/plugins/subtac/0000755000175000017500000000000012365131025014557 5ustar stephstephcoq-8.4pl4/plugins/subtac/subtac.mli0000644000175000017500000000013412326224777016557 0ustar stephstephval require_library : string -> unit val subtac : Util.loc * Vernacexpr.vernac_expr -> unit coq-8.4pl4/plugins/subtac/subtac_pretyping.ml0000644000175000017500000001154312326224777020515 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* A -> Prop *) wf_proof: constr; (* : well_founded R *) f_type: types; (* f: A -> Set *) f_fulltype: types; (* Type with argument and wf proof product first *) } let my_print_rec_info env t = str "Name: " ++ Nameops.pr_name t.arg_name ++ spc () ++ str "Arg type: " ++ my_print_constr env t.arg_type ++ spc () ++ str "Wf relation: " ++ my_print_constr env t.wf_relation ++ spc () ++ str "Wf proof: " ++ my_print_constr env t.wf_proof ++ spc () ++ str "Abbreviated Type: " ++ my_print_constr env t.f_type ++ spc () ++ str "Full type: " ++ my_print_constr env t.f_fulltype (* trace (str "pretype for " ++ (my_print_glob_constr env c) ++ *) (* str " and tycon "++ my_print_tycon env tycon ++ *) (* str " in environment: " ++ my_print_env env); *) let interp env isevars c tycon = let j = pretype true tycon env isevars ([],[]) c in let _ = isevars := Evarutil.nf_evar_map !isevars in let evd = consider_remaining_unif_problems env !isevars in (* let unevd = undefined_evars evd in *) let unevd' = Typeclasses.resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~split:true ~fail:true env evd in let unevd' = Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~split:true ~fail:false env unevd' in let evm = unevd' in isevars := unevd'; nf_evar evm j.uj_val, nf_evar evm j.uj_type let find_with_index x l = let rec aux i = function (y, _, _) as t :: tl -> if x = y then i, t else aux (succ i) tl | [] -> raise Not_found in aux 0 l open Vernacexpr let coqintern_constr evd env : Topconstr.constr_expr -> Glob_term.glob_constr = Constrintern.intern_constr evd env let coqintern_type evd env : Topconstr.constr_expr -> Glob_term.glob_constr = Constrintern.intern_type evd env let env_with_binders env isevars l = let rec aux ((env, rels) as acc) = function Topconstr.LocalRawDef ((loc, name), def) :: tl -> let rawdef = coqintern_constr !isevars env def in let coqdef, deftyp = interp env isevars rawdef empty_tycon in let reldecl = (name, Some coqdef, deftyp) in aux (push_rel reldecl env, reldecl :: rels) tl | Topconstr.LocalRawAssum (bl, k, typ) :: tl -> let rawtyp = coqintern_type !isevars env typ in let coqtyp, typtyp = interp env isevars rawtyp empty_tycon in let acc = List.fold_left (fun (env, rels) (loc, name) -> let reldecl = (name, None, coqtyp) in (push_rel reldecl env, reldecl :: rels)) (env, rels) bl in aux acc tl | [] -> acc in aux (env, []) l let subtac_process ?(is_type=false) env isevars id bl c tycon = let c = Topconstr.abstract_constr_expr c bl in let tycon, imps = match tycon with None -> empty_tycon, None | Some t -> let t = Topconstr.prod_constr_expr t bl in let t = coqintern_type !isevars env t in let imps = Implicit_quantifiers.implicits_of_glob_constr t in let coqt, ttyp = interp env isevars t empty_tycon in mk_tycon coqt, Some imps in let c = coqintern_constr !isevars env c in let imps = match imps with | Some i -> i | None -> Implicit_quantifiers.implicits_of_glob_constr ~with_products:is_type c in let coqc, ctyp = interp env isevars c tycon in let evm = non_instanciated_map env isevars !isevars in let ty = nf_evar !isevars (match tycon with Some (None, c) -> c | _ -> ctyp) in evm, coqc, ty, imps open Subtac_obligations let subtac_proof kind hook env isevars id bl c tycon = let evm, coqc, coqt, imps = subtac_process env isevars id bl c tycon in let evm' = Subtac_utils.evars_of_term evm Evd.empty coqc in let evm' = Subtac_utils.evars_of_term evm evm' coqt in let evars, _, def, ty = Eterm.eterm_obligations env id !isevars evm' 0 coqc coqt in add_definition id ~term:def ty ~implicits:imps ~kind ~hook evars coq-8.4pl4/plugins/subtac/subtac_errors.mli0000644000175000017500000000116712326224777020162 0ustar stephstephtype term_pp = Pp.std_ppcmds type subtyping_error = UncoercibleInferType of Util.loc * term_pp * term_pp | UncoercibleInferTerm of Util.loc * term_pp * term_pp * term_pp * term_pp | UncoercibleRewrite of term_pp * term_pp type typing_error = NonFunctionalApp of Util.loc * term_pp * term_pp * term_pp | NonConvertible of Util.loc * term_pp * term_pp | NonSigma of Util.loc * term_pp | IllSorted of Util.loc * term_pp exception Subtyping_error of subtyping_error exception Typing_error of typing_error exception Debug_msg of string val typing_error : typing_error -> 'a val subtyping_error : subtyping_error -> 'a coq-8.4pl4/plugins/subtac/subtac_classes.ml0000644000175000017500000001602612326224777020132 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* SPretyping.understand_tcc_evars evdref env IsType t) (SPretyping.understand_judgment_tcc evdref) !evdref env params in bl let interp_type_evars_impls ~evdref ?(impls=empty_internalization_env) env c = let c = intern_gen true ~impls !evdref env c in let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in SPretyping.understand_tcc_evars ~fail_evar:false evdref env IsType c, imps let type_ctx_instance evars env ctx inst subst = let rec aux (subst, instctx) l = function (na, b, t) :: ctx -> let t' = substl subst t in let c', l = match b with | None -> interp_casted_constr_evars evars env (List.hd l) t', List.tl l | Some b -> substl subst b, l in evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars; let d = na, Some c', t' in aux (c' :: subst, d :: instctx) l ctx | [] -> subst in aux (subst, []) inst (List.rev ctx) let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) pri = let env = Global.env() in let evars = ref Evd.empty in let tclass, _ = match bk with | Implicit -> Implicit_quantifiers.implicit_application Idset.empty (* need no avoid *) ~allow_partial:false (fun avoid (clname, (id, _, t)) -> match clname with | Some (cl, b) -> let t = if b then let _k = class_info cl in CHole (Util.dummy_loc, Some Evd.InternalHole) else CHole (Util.dummy_loc, None) in t, avoid | None -> failwith ("new instance: under-applied typeclass")) cl | Explicit -> cl, Idset.empty in let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in let k, cty, ctx', ctx, len, imps, subst = let (env', ctx), imps = interp_context_evars evars env ctx in let c', imps' = interp_type_evars_impls ~evdref:evars env' tclass in let len = List.length ctx in let imps = imps @ Impargs.lift_implicits len imps' in let ctx', c = decompose_prod_assum c' in let ctx'' = ctx' @ ctx in let cl, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in let _, args = List.fold_right (fun (na, b, t) (args, args') -> match b with | None -> (List.tl args, List.hd args :: args') | Some b -> (args, substl args' b :: args')) (snd cl.cl_context) (args, []) in cl, c', ctx', ctx, len, imps, args in let id = match snd instid with | Name id -> let sp = Lib.make_path id in if Nametab.exists_cci sp then errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists"); id | Anonymous -> let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in Namegen.next_global_ident_away i (Termops.ids_of_context env) in evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars; let ctx = Evarutil.nf_rel_context_evar !evars ctx and ctx' = Evarutil.nf_rel_context_evar !evars ctx' in let env' = push_rel_context ctx env in let sigma = !evars in let subst = List.map (Evarutil.nf_evar sigma) subst in let props = match props with | Some (CRecord (loc, _, fs)) -> if List.length fs > List.length k.cl_props then Classes.mismatched_props env' (List.map snd fs) k.cl_props; Inl fs | Some p -> Inr p | None -> Inl [] in let subst = match props with | Inr term -> let c = interp_casted_constr_evars evars env' term cty in Inr c | Inl props -> let get_id = function | Ident id' -> id' | _ -> errorlabstrm "new_instance" (Pp.str "Only local structures are handled") in let props, rest = List.fold_left (fun (props, rest) (id,b,_) -> if b = None then try let (loc_mid, c) = List.find (fun (id', _) -> Name (snd (get_id id')) = id) rest in let rest' = List.filter (fun (id', _) -> Name (snd (get_id id')) <> id) rest in let (loc, mid) = get_id loc_mid in List.iter (fun (n, _, x) -> if n = Name mid then Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) x) k.cl_projs; c :: props, rest' with Not_found -> (CHole (Util.dummy_loc, None) :: props), rest else props, rest) ([], props) k.cl_props in if rest <> [] then unbound_method env' k.cl_impl (get_id (fst (List.hd rest))) else Inl (type_ctx_instance evars (push_rel_context ctx' env') k.cl_props props subst) in evars := Evarutil.nf_evar_map !evars; evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars; evars := resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:false env !evars; let term, termtype = match subst with | Inl subst -> let subst = List.fold_left2 (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst') [] subst (k.cl_props @ snd k.cl_context) in let app, ty_constr = instance_constructor k subst in let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in let term = Termops.it_mkLambda_or_LetIn (Option.get app) (ctx' @ ctx) in term, termtype | Inr def -> let termtype = it_mkProd_or_LetIn cty ctx in let term = Termops.it_mkLambda_or_LetIn def ctx in term, termtype in let termtype = Evarutil.nf_evar !evars termtype in let term = Evarutil.nf_evar !evars term in evars := undefined_evars !evars; Evarutil.check_evars env Evd.empty !evars termtype; let hook vis gr = let cst = match gr with ConstRef kn -> kn | _ -> assert false in Impargs.declare_manual_implicits false gr ~enriching:false [imps]; Typeclasses.declare_instance pri (not global) (ConstRef cst) in let evm = Subtac_utils.evars_of_term !evars Evd.empty term in let obls, _, constr, typ = Eterm.eterm_obligations env id !evars evm 0 term termtype in id, Subtac_obligations.add_definition id ~term:constr typ ~kind:(Global,Instance) ~hook obls coq-8.4pl4/plugins/subtac/subtac_obligations.ml0000644000175000017500000005506512326224777021015 0ustar stephstephopen Printf open Pp open Subtac_utils open Command open Environ open Term open Names open Libnames open Summary open Libobject open Entries open Decl_kinds open Util open Evd open Declare open Proof_type open Compat let ppwarn cmd = Pp.warn (str"Program:" ++ cmd) let pperror cmd = Util.errorlabstrm "Program" cmd let error s = pperror (str s) let reduce c = Reductionops.clos_norm_flags Closure.betaiota (Global.env ()) Evd.empty c exception NoObligations of identifier option let explain_no_obligations = function Some ident -> str "No obligations for program " ++ str (string_of_id ident) | None -> str "No obligations remaining" type obligation_info = (Names.identifier * Term.types * hole_kind located * obligation_definition_status * Intset.t * tactic option) array type obligation = { obl_name : identifier; obl_type : types; obl_location : hole_kind located; obl_body : constr option; obl_status : obligation_definition_status; obl_deps : Intset.t; obl_tac : tactic option; } type obligations = (obligation array * int) type fixpoint_kind = | IsFixpoint of (identifier located option * Topconstr.recursion_order_expr) list | IsCoFixpoint type notations = (Vernacexpr.lstring * Topconstr.constr_expr * Topconstr.scope_name option) list type program_info = { prg_name: identifier; prg_body: constr; prg_type: constr; prg_obligations: obligations; prg_deps : identifier list; prg_fixkind : fixpoint_kind option ; prg_implicits : (Topconstr.explicitation * (bool * bool * bool)) list; prg_notations : notations ; prg_kind : definition_kind; prg_reduce : constr -> constr; prg_hook : Tacexpr.declaration_hook; } let assumption_message id = Flags.if_verbose message ((string_of_id id) ^ " is assumed") let (set_default_tactic, get_default_tactic, print_default_tactic) = Tactic_option.declare_tactic_option "Program tactic" (* true = All transparent, false = Opaque if possible *) let proofs_transparency = ref true let set_proofs_transparency = (:=) proofs_transparency let get_proofs_transparency () = !proofs_transparency open Goptions let _ = declare_bool_option { optsync = true; optdepr = false; optname = "transparency of Program obligations"; optkey = ["Transparent";"Obligations"]; optread = get_proofs_transparency; optwrite = set_proofs_transparency; } (* true = hide obligations *) let hide_obligations = ref false let set_hide_obligations = (:=) hide_obligations let get_hide_obligations () = !hide_obligations open Goptions let _ = declare_bool_option { optsync = true; optdepr = false; optname = "Hidding of Program obligations"; optkey = ["Hide";"Obligations"]; optread = get_hide_obligations; optwrite = set_hide_obligations; } let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type let get_obligation_body expand obl = let c = Option.get obl.obl_body in if expand && obl.obl_status = Expand then match kind_of_term c with | Const c -> constant_value (Global.env ()) c | _ -> c else c let obl_substitution expand obls deps = Intset.fold (fun x acc -> let xobl = obls.(x) in let oblb = try get_obligation_body expand xobl with e when Errors.noncritical e -> assert(false) in (xobl.obl_name, (xobl.obl_type, oblb)) :: acc) deps [] let subst_deps expand obls deps t = let subst = obl_substitution expand obls deps in Term.replace_vars (List.map (fun (n, (_, b)) -> n, b) subst) t let rec prod_app t n = match kind_of_term (strip_outer_cast t) with | Prod (_,_,b) -> subst1 n b | LetIn (_, b, t, b') -> prod_app (subst1 b b') n | _ -> errorlabstrm "prod_app" (str"Needed a product, but didn't find one" ++ fnl ()) (* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) let prod_applist t nL = List.fold_left prod_app t nL let replace_appvars subst = let rec aux c = let f, l = decompose_app c in if isVar f then try let c' = List.map (map_constr aux) l in let (t, b) = List.assoc (destVar f) subst in mkApp (delayed_force hide_obligation, [| prod_applist t c'; applistc b c' |]) with Not_found -> map_constr aux c else map_constr aux c in map_constr aux let subst_prog expand obls ints prg = let subst = obl_substitution expand obls ints in if get_hide_obligations () then (replace_appvars subst prg.prg_body, replace_appvars subst (Termops.refresh_universes prg.prg_type)) else let subst' = List.map (fun (n, (_, b)) -> n, b) subst in (Term.replace_vars subst' prg.prg_body, Term.replace_vars subst' (Termops.refresh_universes prg.prg_type)) let subst_deps_obl obls obl = let t' = subst_deps true obls obl.obl_deps obl.obl_type in { obl with obl_type = t' } module ProgMap = Map.Make(struct type t = identifier let compare = compare end) let map_replace k v m = ProgMap.add k v (ProgMap.remove k m) let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m [] let map_cardinal m = let i = ref 0 in ProgMap.iter (fun _ _ -> incr i) m; !i exception Found of program_info let map_first m = try ProgMap.iter (fun _ v -> raise (Found v)) m; assert(false) with Found x -> x let from_prg : program_info ProgMap.t ref = ref ProgMap.empty let freeze () = !from_prg let unfreeze v = from_prg := v let init () = from_prg := ProgMap.empty (** Beware: if this code is dynamically loaded via dynlink after the start of Coq, then this [init] function will not be run by [Lib.init ()]. Luckily, here we can launch [init] at load-time. *) let _ = init () let _ = Summary.declare_summary "program-tcc-table" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = init } let progmap_union = ProgMap.fold ProgMap.add let close sec = if not (ProgMap.is_empty !from_prg) then let keys = map_keys !from_prg in errorlabstrm "Program" (str "Unsolved obligations when closing " ++ str sec ++ str":" ++ spc () ++ prlist_with_sep spc (fun x -> Nameops.pr_id x) keys ++ (str (if List.length keys = 1 then " has " else "have ") ++ str "unsolved obligations")) let input : program_info ProgMap.t -> obj = declare_object { (default_object "Program state") with cache_function = (fun (na, pi) -> from_prg := pi); load_function = (fun _ (_, pi) -> from_prg := pi); discharge_function = (fun _ -> close "section"; None); classify_function = (fun _ -> close "module"; Dispose) } open Evd let progmap_remove prg = Lib.add_anonymous_leaf (input (ProgMap.remove prg.prg_name !from_prg)) let progmap_add n prg = Lib.add_anonymous_leaf (input (ProgMap.add n prg !from_prg)) let progmap_replace prg' = Lib.add_anonymous_leaf (input (map_replace prg'.prg_name prg' !from_prg)) let rec intset_to = function -1 -> Intset.empty | n -> Intset.add n (intset_to (pred n)) let subst_body expand prg = let obls, _ = prg.prg_obligations in let ints = intset_to (pred (Array.length obls)) in subst_prog expand obls ints prg let declare_definition prg = let body, typ = subst_body true prg in let (local, kind) = prg.prg_kind in let ce = { const_entry_body = body; const_entry_secctx = None; const_entry_type = Some typ; const_entry_opaque = false } in (Command.get_declare_definition_hook ()) ce; match local with | Local when Lib.sections_are_opened () -> let c = SectionLocalDef(ce.const_entry_body,ce.const_entry_type,false) in let _ = declare_variable prg.prg_name (Lib.cwd(),c,IsDefinition kind) in print_message (Subtac_utils.definition_message prg.prg_name); if Pfedit.refining () then Flags.if_verbose msg_warning (str"Local definition " ++ Nameops.pr_id prg.prg_name ++ str" is not visible from current goals"); progmap_remove prg; VarRef prg.prg_name | (Global|Local) -> let c = Declare.declare_constant prg.prg_name (DefinitionEntry ce,IsDefinition (snd prg.prg_kind)) in let gr = ConstRef c in if Impargs.is_implicit_args () || prg.prg_implicits <> [] then Impargs.declare_manual_implicits false gr [prg.prg_implicits]; print_message (Subtac_utils.definition_message prg.prg_name); progmap_remove prg; prg.prg_hook local gr; gr open Pp open Ppconstr let rec lam_index n t acc = match kind_of_term t with | Lambda (na, _, b) -> if na = Name n then acc else lam_index n b (succ acc) | _ -> raise Not_found let compute_possible_guardness_evidences (n,_) fixbody fixtype = match n with | Some (loc, n) -> [lam_index n fixbody 0] | None -> (* If recursive argument was not given by user, we try all args. An earlier approach was to look only for inductive arguments, but doing it properly involves delta-reduction, and it finally doesn't seem to worth the effort (except for huge mutual fixpoints ?) *) let m = Term.nb_prod fixtype in let ctx = fst (decompose_prod_n_assum m fixtype) in list_map_i (fun i _ -> i) 0 ctx let declare_mutual_definition l = let len = List.length l in let first = List.hd l in let fixdefs, fixtypes, fiximps = list_split3 (List.map (fun x -> let subs, typ = (subst_body true x) in let term = snd (Reductionops.splay_lam_n (Global.env ()) Evd.empty len subs) in let typ = snd (Reductionops.splay_prod_n (Global.env ()) Evd.empty len typ) in x.prg_reduce term, x.prg_reduce typ, x.prg_implicits) l) in (* let fixdefs = List.map reduce_fix fixdefs in *) let fixkind = Option.get first.prg_fixkind in let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in let (local,kind) = first.prg_kind in let fixnames = first.prg_deps in let kind = if fixkind <> IsCoFixpoint then Fixpoint else CoFixpoint in let indexes, fixdecls = match fixkind with | IsFixpoint wfl -> let possible_indexes = list_map3 compute_possible_guardness_evidences wfl fixdefs fixtypes in let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in Some indexes, list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 l | IsCoFixpoint -> None, list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 l in (* Declare the recursive definitions *) let kns = list_map4 (declare_fix kind) fixnames fixdecls fixtypes fiximps in (* Declare notations *) List.iter Metasyntax.add_notation_interpretation first.prg_notations; Declare.recursive_message (fixkind<>IsCoFixpoint) indexes fixnames; let gr = List.hd kns in let kn = match gr with ConstRef kn -> kn | _ -> assert false in first.prg_hook local gr; List.iter progmap_remove l; kn let declare_obligation prg obl body = let body = prg.prg_reduce body in let ty = prg.prg_reduce obl.obl_type in match obl.obl_status with | Expand -> { obl with obl_body = Some body } | Define opaque -> let opaque = if get_proofs_transparency () then false else opaque in let ce = { const_entry_body = body; const_entry_secctx = None; const_entry_type = Some ty; const_entry_opaque = opaque } in let constant = Declare.declare_constant obl.obl_name (DefinitionEntry ce,IsProof Property) in if not opaque then Auto.add_hints false [string_of_id prg.prg_name] (Auto.HintsUnfoldEntry [EvalConstRef constant]); print_message (Subtac_utils.definition_message obl.obl_name); { obl with obl_body = Some (mkConst constant) } let init_prog_info n b t deps fixkind notations obls impls kind reduce hook = let obls', b = match b with | None -> assert(obls = [||]); let n = Nameops.add_suffix n "_obligation" in [| { obl_name = n; obl_body = None; obl_location = dummy_loc, InternalHole; obl_type = t; obl_status = Expand; obl_deps = Intset.empty; obl_tac = None } |], mkVar n | Some b -> Array.mapi (fun i (n, t, l, o, d, tac) -> { obl_name = n ; obl_body = None; obl_location = l; obl_type = reduce t; obl_status = o; obl_deps = d; obl_tac = tac }) obls, b in { prg_name = n ; prg_body = b; prg_type = reduce t; prg_obligations = (obls', Array.length obls'); prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; prg_hook = hook; } let get_prog name = let prg_infos = !from_prg in match name with Some n -> (try ProgMap.find n prg_infos with Not_found -> raise (NoObligations (Some n))) | None -> (let n = map_cardinal prg_infos in match n with 0 -> raise (NoObligations None) | 1 -> map_first prg_infos | _ -> error "More than one program with unsolved obligations") let get_prog_err n = try get_prog n with NoObligations id -> pperror (explain_no_obligations id) let obligations_solved prg = (snd prg.prg_obligations) = 0 let all_programs () = ProgMap.fold (fun k p l -> p :: l) !from_prg [] type progress = | Remain of int | Dependent | Defined of global_reference let obligations_message rem = if rem > 0 then if rem = 1 then Flags.if_verbose msgnl (int rem ++ str " obligation remaining") else Flags.if_verbose msgnl (int rem ++ str " obligations remaining") else Flags.if_verbose msgnl (str "No more obligations remaining") let update_obls prg obls rem = let prg' = { prg with prg_obligations = (obls, rem) } in progmap_replace prg'; obligations_message rem; if rem > 0 then Remain rem else ( match prg'.prg_deps with | [] -> let kn = declare_definition prg' in progmap_remove prg'; Defined kn | l -> let progs = List.map (fun x -> ProgMap.find x !from_prg) prg'.prg_deps in if List.for_all (fun x -> obligations_solved x) progs then let kn = declare_mutual_definition progs in Defined (ConstRef kn) else Dependent) let is_defined obls x = obls.(x).obl_body <> None let deps_remaining obls deps = Intset.fold (fun x acc -> if is_defined obls x then acc else x :: acc) deps [] let dependencies obls n = let res = ref Intset.empty in Array.iteri (fun i obl -> if i <> n && Intset.mem n obl.obl_deps then res := Intset.add i !res) obls; !res let kind_of_opacity o = match o with | Define false | Expand -> Subtac_utils.goal_kind | _ -> Subtac_utils.goal_proof_kind let not_transp_msg = str "Obligation should be transparent but was declared opaque." ++ spc () ++ str"Use 'Defined' instead." let warn_not_transp () = ppwarn not_transp_msg let error_not_transp () = pperror not_transp_msg let rec solve_obligation prg num tac = let user_num = succ num in let obls, rem = prg.prg_obligations in let obl = obls.(num) in if obl.obl_body <> None then pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.") else match deps_remaining obls obl.obl_deps with | [] -> let obl = subst_deps_obl obls obl in Lemmas.start_proof obl.obl_name (kind_of_opacity obl.obl_status) obl.obl_type (fun strength gr -> let cst = match gr with ConstRef cst -> cst | _ -> assert false in let obl = let transparent = evaluable_constant cst (Global.env ()) in let body = match obl.obl_status with | Expand -> if not transparent then error_not_transp () else constant_value (Global.env ()) cst | Define opaque -> if not opaque && not transparent then error_not_transp () else Libnames.constr_of_global gr in if transparent then Auto.add_hints true [string_of_id prg.prg_name] (Auto.HintsUnfoldEntry [EvalConstRef cst]); { obl with obl_body = Some body } in let obls = Array.copy obls in let _ = obls.(num) <- obl in let res = try update_obls prg obls (pred rem) with e when Errors.noncritical e -> pperror (Errors.print (Cerrors.process_vernac_interp_error e)) in match res with | Remain n when n > 0 -> let deps = dependencies obls num in if deps <> Intset.empty then ignore(auto_solve_obligations (Some prg.prg_name) None ~oblset:deps) | _ -> ()); trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ Subtac_utils.my_print_constr (Global.env ()) obl.obl_type); Pfedit.by (snd (get_default_tactic ())); Option.iter (fun tac -> Pfedit.set_end_tac (Tacinterp.interp tac)) tac; Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l)) and subtac_obligation (user_num, name, typ) tac = let num = pred user_num in let prg = get_prog_err name in let obls, rem = prg.prg_obligations in if num < Array.length obls then let obl = obls.(num) in match obl.obl_body with None -> solve_obligation prg num tac | Some r -> error "Obligation already solved" else error (sprintf "Unknown obligation number %i" (succ num)) and solve_obligation_by_tac prg obls i tac = let obl = obls.(i) in match obl.obl_body with | Some _ -> false | None -> try if deps_remaining obls obl.obl_deps = [] then let obl = subst_deps_obl obls obl in let tac = match tac with | Some t -> t | None -> match obl.obl_tac with | Some t -> t | None -> snd (get_default_tactic ()) in let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in obls.(i) <- declare_obligation prg obl t; true else false with | Loc.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s))) | Loc.Exc_located(_, Refiner.FailError (_, s)) | Refiner.FailError (_, s) -> user_err_loc (fst obl.obl_location, "solve_obligation", Lazy.force s) | Util.Anomaly _ as e -> raise e | e when Errors.noncritical e -> false and solve_prg_obligations prg ?oblset tac = let obls, rem = prg.prg_obligations in let rem = ref rem in let obls' = Array.copy obls in let set = ref Intset.empty in let p = match oblset with | None -> (fun _ -> true) | Some s -> set := s; (fun i -> Intset.mem i !set) in let _ = Array.iteri (fun i x -> if p i && solve_obligation_by_tac prg obls' i tac then let deps = dependencies obls i in (set := Intset.union !set deps; decr rem)) obls' in update_obls prg obls' !rem and solve_obligations n tac = let prg = get_prog_err n in solve_prg_obligations prg tac and solve_all_obligations tac = ProgMap.iter (fun k v -> ignore(solve_prg_obligations v tac)) !from_prg and try_solve_obligation n prg tac = let prg = get_prog prg in let obls, rem = prg.prg_obligations in let obls' = Array.copy obls in if solve_obligation_by_tac prg obls' n tac then ignore(update_obls prg obls' (pred rem)); and try_solve_obligations n tac = try ignore (solve_obligations n tac) with NoObligations _ -> () and auto_solve_obligations n ?oblset tac : progress = Flags.if_verbose msgnl (str "Solving obligations automatically..."); try solve_prg_obligations (get_prog_err n) ?oblset tac with NoObligations _ -> Dependent open Pp let show_obligations_of_prg ?(msg=true) prg = let n = prg.prg_name in let obls, rem = prg.prg_obligations in let showed = ref 5 in if msg then msgnl (int rem ++ str " obligation(s) remaining: "); Array.iteri (fun i x -> match x.obl_body with | None -> if !showed > 0 then ( decr showed; msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ hov 1 (my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ()))) | Some _ -> ()) obls let show_obligations ?(msg=true) n = let progs = match n with | None -> all_programs () | Some n -> try [ProgMap.find n !from_prg] with Not_found -> raise (NoObligations (Some n)) in List.iter (show_obligations_of_prg ~msg) progs let show_term n = let prg = get_prog_err n in let n = prg.prg_name in msgnl (str (string_of_id n) ++ spc () ++ str":" ++ spc () ++ my_print_constr (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl () ++ my_print_constr (Global.env ()) prg.prg_body) let add_definition n ?term t ?(implicits=[]) ?(kind=Global,Definition) ?tactic ?(reduce=reduce) ?(hook=fun _ _ -> ()) obls = Flags.if_verbose pp (str (string_of_id n) ++ str " has type-checked"); let prg = init_prog_info n term t [] None [] obls implicits kind reduce hook in let obls,_ = prg.prg_obligations in if Array.length obls = 0 then ( Flags.if_verbose ppnl (str "."); let cst = declare_definition prg in Defined cst) else ( let len = Array.length obls in let _ = Flags.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in progmap_add n prg; let res = auto_solve_obligations (Some n) tactic in match res with | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res | _ -> res) let add_mutual_definitions l ?tactic ?(kind=Global,Definition) ?(reduce=reduce) ?(hook=fun _ _ -> ()) notations fixkind = let deps = List.map (fun (n, b, t, imps, obls) -> n) l in List.iter (fun (n, b, t, imps, obls) -> let prg = init_prog_info n (Some b) t deps (Some fixkind) notations obls imps kind reduce hook in progmap_add n prg) l; let _defined = List.fold_left (fun finished x -> if finished then finished else let res = auto_solve_obligations (Some x) tactic in match res with | Defined _ -> (* If one definition is turned into a constant, the whole block is defined. *) true | _ -> false) false deps in () let admit_obligations n = let prg = get_prog_err n in let obls, rem = prg.prg_obligations in let obls = Array.copy obls in Array.iteri (fun i x -> match x.obl_body with | None -> let x = subst_deps_obl obls x in let kn = Declare.declare_constant x.obl_name (ParameterEntry (None, x.obl_type,None), IsAssumption Conjectural) in assumption_message x.obl_name; obls.(i) <- { x with obl_body = Some (mkConst kn) } | Some _ -> ()) obls; ignore(update_obls prg obls 0) exception Found of int let array_find f arr = try Array.iteri (fun i x -> if f x then raise (Found i)) arr; raise Not_found with Found i -> i let next_obligation n tac = let prg = get_prog_err n in let obls, rem = prg.prg_obligations in let i = try array_find (fun x -> x.obl_body = None && deps_remaining obls x.obl_deps = []) obls with Not_found -> anomaly "Could not find a solvable obligation." in solve_obligation prg i tac coq-8.4pl4/plugins/subtac/g_subtac.ml40000644000175000017500000001362512326224777017011 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* *) module Gram = Pcoq.Gram module Vernac = Pcoq.Vernac_ module Tactic = Pcoq.Tactic module SubtacGram = struct let gec s = Gram.entry_create ("Subtac."^s) (* types *) let subtac_gallina_loc : Vernacexpr.vernac_expr located Gram.entry = gec "subtac_gallina_loc" let subtac_withtac : Tacexpr.raw_tactic_expr option Gram.entry = gec "subtac_withtac" end open Glob_term open SubtacGram open Util open Pcoq open Prim open Constr let sigref = mkRefC (Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Init.Specif.sig")) GEXTEND Gram GLOBAL: subtac_gallina_loc typeclass_constraint subtac_withtac; subtac_gallina_loc: [ [ g = Vernac.gallina -> loc, g | g = Vernac.gallina_ext -> loc, g ] ] ; subtac_withtac: [ [ "with"; t = Tactic.tactic -> Some t | -> None ] ] ; Constr.closed_binder: [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in [LocalRawAssum ([id], default_binder_kind, typ)] ] ]; END type 'a gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a) Genarg.abstract_argument_type let (wit_subtac_gallina_loc : Genarg.tlevel gallina_loc_argtype), (globwit_subtac_gallina_loc : Genarg.glevel gallina_loc_argtype), (rawwit_subtac_gallina_loc : Genarg.rlevel gallina_loc_argtype) = Genarg.create_arg None "subtac_gallina_loc" type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type let (wit_subtac_withtac : Genarg.tlevel withtac_argtype), (globwit_subtac_withtac : Genarg.glevel withtac_argtype), (rawwit_subtac_withtac : Genarg.rlevel withtac_argtype) = Genarg.create_arg None "subtac_withtac" VERNAC COMMAND EXTEND Subtac [ "Program" subtac_gallina_loc(g) ] -> [ Subtac.subtac g ] END let try_catch_exn f e = try f e with exn when Errors.noncritical exn -> errorlabstrm "Program" (Errors.print exn) let subtac_obligation e = try_catch_exn Subtac_obligations.subtac_obligation e let next_obligation e = try_catch_exn Subtac_obligations.next_obligation e let try_solve_obligation e = try_catch_exn Subtac_obligations.try_solve_obligation e let try_solve_obligations e = try_catch_exn Subtac_obligations.try_solve_obligations e let solve_all_obligations e = try_catch_exn Subtac_obligations.solve_all_obligations e let admit_obligations e = try_catch_exn Subtac_obligations.admit_obligations e VERNAC COMMAND EXTEND Subtac_Obligations | [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) subtac_withtac(tac) ] -> [ subtac_obligation (num, Some name, Some t) tac ] | [ "Obligation" integer(num) "of" ident(name) subtac_withtac(tac) ] -> [ subtac_obligation (num, Some name, None) tac ] | [ "Obligation" integer(num) ":" lconstr(t) subtac_withtac(tac) ] -> [ subtac_obligation (num, None, Some t) tac ] | [ "Obligation" integer(num) subtac_withtac(tac) ] -> [ subtac_obligation (num, None, None) tac ] | [ "Next" "Obligation" "of" ident(name) subtac_withtac(tac) ] -> [ next_obligation (Some name) tac ] | [ "Next" "Obligation" subtac_withtac(tac) ] -> [ next_obligation None tac ] END VERNAC COMMAND EXTEND Subtac_Solve_Obligation | [ "Solve" "Obligation" integer(num) "of" ident(name) "using" tactic(t) ] -> [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] | [ "Solve" "Obligation" integer(num) "using" tactic(t) ] -> [ try_solve_obligation num None (Some (Tacinterp.interp t)) ] END VERNAC COMMAND EXTEND Subtac_Solve_Obligations | [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] | [ "Solve" "Obligations" "using" tactic(t) ] -> [ try_solve_obligations None (Some (Tacinterp.interp t)) ] | [ "Solve" "Obligations" ] -> [ try_solve_obligations None None ] END VERNAC COMMAND EXTEND Subtac_Solve_All_Obligations | [ "Solve" "All" "Obligations" "using" tactic(t) ] -> [ solve_all_obligations (Some (Tacinterp.interp t)) ] | [ "Solve" "All" "Obligations" ] -> [ solve_all_obligations None ] END VERNAC COMMAND EXTEND Subtac_Admit_Obligations | [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] | [ "Admit" "Obligations" ] -> [ admit_obligations None ] END VERNAC COMMAND EXTEND Subtac_Set_Solver | [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ Subtac_obligations.set_default_tactic (Vernacexpr.use_section_locality ()) (Tacinterp.glob_tactic t) ] END open Pp VERNAC COMMAND EXTEND Subtac_Show_Solver | [ "Show" "Obligation" "Tactic" ] -> [ msgnl (str"Program obligation tactic is " ++ Subtac_obligations.print_default_tactic ()) ] END VERNAC COMMAND EXTEND Subtac_Show_Obligations | [ "Obligations" "of" ident(name) ] -> [ Subtac_obligations.show_obligations (Some name) ] | [ "Obligations" ] -> [ Subtac_obligations.show_obligations None ] END VERNAC COMMAND EXTEND Subtac_Show_Preterm | [ "Preterm" "of" ident(name) ] -> [ Subtac_obligations.show_term (Some name) ] | [ "Preterm" ] -> [ Subtac_obligations.show_term None ] END coq-8.4pl4/plugins/subtac/subtac_obligations.mli0000644000175000017500000000520412326224777021154 0ustar stephstephopen Names open Util open Libnames open Evd open Proof_type open Vernacexpr type obligation_info = (identifier * Term.types * hole_kind located * obligation_definition_status * Intset.t * tactic option) array (* ident, type, location, (opaque or transparent, expand or define), dependencies, tactic to solve it *) type progress = (* Resolution status of a program *) | Remain of int (* n obligations remaining *) | Dependent (* Dependent on other definitions *) | Defined of global_reference (* Defined as id *) val set_default_tactic : bool -> Tacexpr.glob_tactic_expr -> unit val get_default_tactic : unit -> locality_flag * Proof_type.tactic val print_default_tactic : unit -> Pp.std_ppcmds val set_proofs_transparency : bool -> unit (* true = All transparent, false = Opaque if possible *) val get_proofs_transparency : unit -> bool val add_definition : Names.identifier -> ?term:Term.constr -> Term.types -> ?implicits:(Topconstr.explicitation * (bool * bool * bool)) list -> ?kind:Decl_kinds.definition_kind -> ?tactic:Proof_type.tactic -> ?reduce:(Term.constr -> Term.constr) -> ?hook:(Tacexpr.declaration_hook) -> obligation_info -> progress type notations = (Vernacexpr.lstring * Topconstr.constr_expr * Topconstr.scope_name option) list type fixpoint_kind = | IsFixpoint of (identifier located option * Topconstr.recursion_order_expr) list | IsCoFixpoint val add_mutual_definitions : (Names.identifier * Term.constr * Term.types * (Topconstr.explicitation * (bool * bool * bool)) list * obligation_info) list -> ?tactic:Proof_type.tactic -> ?kind:Decl_kinds.definition_kind -> ?reduce:(Term.constr -> Term.constr) -> ?hook:Tacexpr.declaration_hook -> notations -> fixpoint_kind -> unit val subtac_obligation : int * Names.identifier option * Topconstr.constr_expr option -> Tacexpr.raw_tactic_expr option -> unit val next_obligation : Names.identifier option -> Tacexpr.raw_tactic_expr option -> unit val solve_obligations : Names.identifier option -> Proof_type.tactic option -> progress (* Number of remaining obligations to be solved for this program *) val solve_all_obligations : Proof_type.tactic option -> unit val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic option -> unit val try_solve_obligations : Names.identifier option -> Proof_type.tactic option -> unit val show_obligations : ?msg:bool -> Names.identifier option -> unit val show_term : Names.identifier option -> unit val admit_obligations : Names.identifier option -> unit exception NoObligations of Names.identifier option val explain_no_obligations : Names.identifier option -> Pp.std_ppcmds coq-8.4pl4/plugins/subtac/subtac_plugin.mllib0000644000175000017500000000026512326224777020460 0ustar stephstephSubtac_utils Eterm Subtac_errors Subtac_coercion Subtac_obligations Subtac_cases Subtac_pretyping_F Subtac_pretyping Subtac_command Subtac_classes Subtac G_subtac Subtac_plugin_mod coq-8.4pl4/plugins/subtac/subtac_command.ml0000644000175000017500000004736112326224777020121 0ustar stephstephopen Closure open RedFlags open Declarations open Entries open Libobject open Pattern open Matching open Pp open Glob_term open Sign open Tacred open Util open Names open Nameops open Libnames open Nametab open Pfedit open Proof_type open Refiner open Tacmach open Tactic_debug open Topconstr open Term open Tacexpr open Safe_typing open Typing open Hiddentac open Genarg open Decl_kinds open Mod_subst open Printer open Inductiveops open Syntax_def open Environ open Tactics open Tacticals open Tacinterp open Vernacexpr open Notation open Evd open Evarutil module SPretyping = Subtac_pretyping.Pretyping open Subtac_utils open Pretyping open Subtac_obligations (*********************************************************************) (* Functions to parse and interpret constructions *) let evar_nf isevars c = Evarutil.nf_evar !isevars c let interp_gen kind isevars env ?(impls=Constrintern.empty_internalization_env) ?(allow_patvar=false) ?(ltacvars=([],[])) c = let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars ( !isevars) env c in let c' = SPretyping.understand_tcc_evars isevars env kind c' in evar_nf isevars c' let interp_constr isevars env c = interp_gen (OfType None) isevars env c let interp_type_evars isevars env ?(impls=Constrintern.empty_internalization_env) c = interp_gen IsType isevars env ~impls c let interp_casted_constr isevars env ?(impls=Constrintern.empty_internalization_env) c typ = interp_gen (OfType (Some typ)) isevars env ~impls c let interp_casted_constr_evars isevars env ?(impls=Constrintern.empty_internalization_env) c typ = interp_gen (OfType (Some typ)) isevars env ~impls c let interp_open_constr isevars env c = msgnl (str "Pretyping " ++ my_print_constr_expr c); let c = Constrintern.intern_constr ( !isevars) env c in let c' = SPretyping.understand_tcc_evars isevars env (OfType None) c in evar_nf isevars c' let interp_constr_judgment isevars env c = let j = SPretyping.understand_judgment_tcc isevars env (Constrintern.intern_constr ( !isevars) env c) in { uj_val = evar_nf isevars j.uj_val; uj_type = evar_nf isevars j.uj_type } let locate_if_isevar loc na = function | GHole _ -> (try match na with | Name id -> glob_constr_of_aconstr loc (Reserve.find_reserved_type id) | Anonymous -> raise Not_found with Not_found -> GHole (loc, Evd.BinderType na)) | x -> x let interp_binder sigma env na t = let t = Constrintern.intern_gen true ( !sigma) env t in SPretyping.understand_tcc_evars sigma env IsType (locate_if_isevar (loc_of_glob_constr t) na t) let interp_context_evars evdref env params = let int_env, bl = Constrintern.intern_context false !evdref env Constrintern.empty_internalization_env params in let (env, par, _, impls) = List.fold_left (fun (env,params,n,impls) (na, k, b, t) -> match b with None -> let t' = locate_if_isevar (loc_of_glob_constr t) na t in let t = SPretyping.understand_tcc_evars evdref env IsType t' in let d = (na,None,t) in let impls = if k = Implicit then let na = match na with Name n -> Some n | Anonymous -> None in (ExplByPos (n, na), (true, true, true)) :: impls else impls in (push_rel d env, d::params, succ n, impls) | Some b -> let c = SPretyping.understand_judgment_tcc evdref env b in let d = (na, Some c.uj_val, c.uj_type) in (push_rel d env,d::params, succ n, impls)) (env,[],1,[]) (List.rev bl) in (env, par), impls (* try to find non recursive definitions *) let list_chop_hd i l = match list_chop i l with | (l1,x::l2) -> (l1,x,l2) | (x :: [], l2) -> ([], x, []) | _ -> assert(false) let collect_non_rec env = let rec searchrec lnonrec lnamerec ldefrec larrec nrec = try let i = list_try_find_i (fun i f -> if List.for_all (fun (_, def) -> not (Termops.occur_var env f def)) ldefrec then i else failwith "try_find_i") 0 lnamerec in let (lf1,f,lf2) = list_chop_hd i lnamerec in let (ldef1,def,ldef2) = list_chop_hd i ldefrec in let (lar1,ar,lar2) = list_chop_hd i larrec in let newlnv = try match list_chop i nrec with | (lnv1,_::lnv2) -> (lnv1@lnv2) | _ -> [] (* nrec=[] for cofixpoints *) with Failure "list_chop" -> [] in searchrec ((f,def,ar)::lnonrec) (lf1@lf2) (ldef1@ldef2) (lar1@lar2) newlnv with Failure "try_find_i" -> (List.rev lnonrec, (Array.of_list lnamerec, Array.of_list ldefrec, Array.of_list larrec, Array.of_list nrec)) in searchrec [] let list_of_local_binders l = let rec aux acc = function Topconstr.LocalRawDef (n, c) :: tl -> aux ((n, Some c, None) :: acc) tl | Topconstr.LocalRawAssum (nl, k, c) :: tl -> aux (List.fold_left (fun acc n -> (n, None, Some c) :: acc) acc nl) tl | [] -> List.rev acc in aux [] l let lift_binders k n l = let rec aux n = function | (id, t, c) :: tl -> (id, Option.map (liftn k n) t, liftn k n c) :: aux (pred n) tl | [] -> [] in aux n l let rec gen_rels = function 0 -> [] | n -> mkRel n :: gen_rels (pred n) let split_args n rel = match list_chop ((List.length rel) - n) rel with (l1, x :: l2) -> l1, x, l2 | _ -> assert(false) open Coqlib let sigT = Lazy.lazy_from_fun build_sigma_type let sigT_info = lazy { ci_ind = destInd (Lazy.force sigT).typ; ci_npar = 2; ci_cstr_ndecls = [|2|]; ci_pp_info = { ind_nargs = 0; style = LetStyle } } let rec telescope = function | [] -> assert false | [(n, None, t)] -> t, [n, Some (mkRel 1), t], mkRel 1 | (n, None, t) :: tl -> let ty, tys, (k, constr) = List.fold_left (fun (ty, tys, (k, constr)) (n, b, t) -> let pred = mkLambda (n, t, ty) in let sigty = mkApp ((Lazy.force sigT).typ, [|t; pred|]) in let intro = mkApp ((Lazy.force sigT).intro, [|lift k t; lift k pred; mkRel k; constr|]) in (sigty, pred :: tys, (succ k, intro))) (t, [], (2, mkRel 1)) tl in let (last, subst) = List.fold_right2 (fun pred (n, b, t) (prev, subst) -> let proj1 = applistc (Lazy.force sigT).proj1 [t; pred; prev] in let proj2 = applistc (Lazy.force sigT).proj2 [t; pred; prev] in (lift 1 proj2, (n, Some proj1, t) :: subst)) (List.rev tys) tl (mkRel 1, []) in ty, ((n, Some last, t) :: subst), constr | (n, Some b, t) :: tl -> let ty, subst, term = telescope tl in ty, ((n, Some b, t) :: subst), lift 1 term let nf_evar_context isevars ctx = List.map (fun (n, b, t) -> (n, Option.map (Evarutil.nf_evar isevars) b, Evarutil.nf_evar isevars t)) ctx let build_wellfounded (recname,n,bl,arityc,body) r measure notation = Coqlib.check_required_library ["Coq";"Program";"Wf"]; let sigma = Evd.empty in let isevars = ref (Evd.create_evar_defs sigma) in let env = Global.env() in let _pr c = my_print_constr env c in let _prr = Printer.pr_rel_context env in let _prn = Printer.pr_named_context env in let _pr_rel env = Printer.pr_rel_context env in let (env', binders_rel), impls = interp_context_evars isevars env bl in let len = List.length binders_rel in let top_env = push_rel_context binders_rel env in let top_arity = interp_type_evars isevars top_env arityc in let full_arity = it_mkProd_or_LetIn top_arity binders_rel in let argtyp, letbinders, make = telescope binders_rel in let argname = id_of_string "recarg" in let arg = (Name argname, None, argtyp) in let binders = letbinders @ [arg] in let binders_env = push_rel_context binders_rel env in let rel = interp_constr isevars env r in let relty = type_of env !isevars rel in let relargty = let error () = user_err_loc (constr_loc r, "Subtac_command.build_wellfounded", my_print_constr env rel ++ str " is not an homogeneous binary relation.") in try let ctx, ar = Reductionops.splay_prod_n env !isevars 2 relty in match ctx, kind_of_term ar with | [(_, None, t); (_, None, u)], Sort (Prop Null) when Reductionops.is_conv env !isevars t u -> t | _, _ -> error () with e when Errors.noncritical e -> error () in let measure = interp_casted_constr isevars binders_env measure relargty in let wf_rel, wf_rel_fun, measure_fn = let measure_body, measure = it_mkLambda_or_LetIn measure letbinders, it_mkLambda_or_LetIn measure binders in let comb = constr_of_global (delayed_force measure_on_R_ref) in let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in let wf_rel_fun x y = mkApp (rel, [| subst1 x measure_body; subst1 y measure_body |]) in wf_rel, wf_rel_fun, measure in let wf_proof = mkApp (delayed_force well_founded, [| argtyp ; wf_rel |]) in let argid' = id_of_string (string_of_id argname ^ "'") in let wfarg len = (Name argid', None, mkSubset (Name argid') argtyp (wf_rel_fun (mkRel 1) (mkRel (len + 1)))) in let intern_bl = wfarg 1 :: [arg] in let _intern_env = push_rel_context intern_bl env in let proj = (delayed_force sig_).Coqlib.proj1 in let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in let projection = (* in wfarg :: arg :: before *) mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |]) in let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in let intern_arity = substl [projection] top_arity_let in (* substitute the projection of wfarg for something, now intern_arity is in wfarg :: arg *) let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in let intern_fun_binder = (Name (add_suffix recname "'"), None, intern_fun_arity_prod) in let curry_fun = let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in let arg = mkApp ((delayed_force sig_).intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in let rcurry = mkApp (rel, [| measure; lift len measure |]) in let lam = (Name (id_of_string "recproof"), None, rcurry) in let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in (Name recname, Some body, ty) in let fun_bl = intern_fun_binder :: [arg] in let lift_lets = Termops.lift_rel_context 1 letbinders in let intern_body = let ctx = (Name recname, None, pi3 curry_fun) :: binders_rel in let (r, l, impls, scopes) = Constrintern.compute_internalization_data env Constrintern.Recursive full_arity impls in let newimpls = Idmap.singleton recname (r, l, impls @ [(Some (id_of_string "recproof", Impargs.Manual, (true, false)))], scopes @ [None]) in interp_casted_constr isevars ~impls:newimpls (push_rel_context ctx env) body (lift 1 top_arity) in let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in let prop = mkLambda (Name argname, argtyp, top_arity_let) in let def = mkApp (constr_of_global (delayed_force fix_sub_ref), [| argtyp ; wf_rel ; make_existential dummy_loc ~opaque:(Define false) env isevars wf_proof ; prop ; intern_body_lam |]) in let _ = isevars := Evarutil.nf_evar_map !isevars in let binders_rel = nf_evar_context !isevars binders_rel in let binders = nf_evar_context !isevars binders in let top_arity = Evarutil.nf_evar !isevars top_arity in let hook, recname, typ = if List.length binders_rel > 1 then let name = add_suffix recname "_func" in let hook l gr = let body = it_mkLambda_or_LetIn (mkApp (constr_of_global gr, [|make|])) binders_rel in let ty = it_mkProd_or_LetIn top_arity binders_rel in let ce = { const_entry_body = Evarutil.nf_evar !isevars body; const_entry_secctx = None; const_entry_type = Some ty; const_entry_opaque = false } in let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in let gr = ConstRef c in if Impargs.is_implicit_args () || impls <> [] then Impargs.declare_manual_implicits false gr [impls] in let typ = it_mkProd_or_LetIn top_arity binders in hook, name, typ else let typ = it_mkProd_or_LetIn top_arity binders_rel in let hook l gr = if Impargs.is_implicit_args () || impls <> [] then Impargs.declare_manual_implicits false gr [impls] in hook, recname, typ in let fullcoqc = Evarutil.nf_evar !isevars def in let fullctyp = Evarutil.nf_evar !isevars typ in let evm = evars_of_term !isevars Evd.empty fullctyp in let evm = evars_of_term !isevars evm fullcoqc in let evm = non_instanciated_map env isevars evm in let evars, _, evars_def, evars_typ = Eterm.eterm_obligations env recname !isevars evm 0 fullcoqc fullctyp in Subtac_obligations.add_definition recname ~term:evars_def evars_typ evars ~hook let interp_fix_context evdref env fix = interp_context_evars evdref env fix.Command.fix_binders let interp_fix_ccl evdref (env,_) fix = interp_type_evars evdref env fix.Command.fix_type let interp_fix_body evdref env_rec impls (_,ctx) fix ccl = let env = push_rel_context ctx env_rec in let body = Option.map (fun c -> interp_casted_constr_evars evdref env ~impls c ccl) fix.Command.fix_body in Option.map (fun c -> it_mkLambda_or_LetIn c ctx) body let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx let prepare_recursive_declaration fixnames fixtypes fixdefs = let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in let names = List.map (fun id -> Name id) fixnames in (Array.of_list names, Array.of_list fixtypes, Array.of_list defs) let rel_index n ctx = list_index0 (Name n) (List.rev_map pi1 (List.filter (fun x -> pi2 x = None) ctx)) let rec unfold f b = match f b with | Some (x, b') -> x :: unfold f b' | None -> [] let find_annot loc id ctx = try rel_index id ctx with Not_found -> user_err_loc(loc,"", str "No parameter named " ++ Nameops.pr_id id ++ str".") let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype = match n with | Some (loc, id) -> [find_annot loc id fixctx] | None -> (* If recursive argument was not given by user, we try all args. An earlier approach was to look only for inductive arguments, but doing it properly involves delta-reduction, and it finally doesn't seem to worth the effort (except for huge mutual fixpoints ?) *) let len = List.length fixctx in unfold (function x when x = len -> None | n -> Some (n, succ n)) 0 let push_named_context = List.fold_right push_named let check_evars env initial_sigma evd c = let sigma = evd in let c = nf_evar sigma c in let rec proc_rec c = match kind_of_term c with | Evar (evk,args) -> assert (Evd.mem sigma evk); if not (Evd.mem initial_sigma evk) then let (loc,k) = evar_source evk evd in (match k with | QuestionMark _ | ImplicitArg (_, _, false) -> () | _ -> let evi = nf_evar_info sigma (Evd.find sigma evk) in Pretype_errors.error_unsolvable_implicit loc env sigma evi k None) | _ -> iter_constr proc_rec c in proc_rec c let out_def = function | Some def -> def | None -> error "Program Fixpoint needs defined bodies." let interp_recursive fixkind l = let env = Global.env() in let fixl, ntnl = List.split l in let kind = fixkind <> IsCoFixpoint in let fixnames = List.map (fun fix -> fix.Command.fix_name) fixl in (* Interp arities allowing for unresolved types *) let evdref = ref Evd.empty in let fixctxs, fiximps = List.split (List.map (interp_fix_context evdref env) fixl) in let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in let fixtypes = List.map2 build_fix_type fixctxs fixccls in let rec_sign = List.fold_left2 (fun env' id t -> let sort = Retyping.get_type_of env !evdref t in let fixprot = try mkApp (delayed_force Subtac_utils.fix_proto, [|sort; t|]) with e when Errors.noncritical e -> t in (id,None,fixprot) :: env') [] fixnames fixtypes in let env_rec = push_named_context rec_sign env in (* Get interpretation metadatas *) let impls = Constrintern.compute_internalization_env env Constrintern.Recursive fixnames fixtypes fiximps in let notations = List.flatten ntnl in (* Interp bodies with rollback because temp use of notations/implicit *) let fixdefs = States.with_state_protection (fun () -> List.iter (Metasyntax.set_notation_for_interpretation impls) notations; list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls) () in let fixdefs = List.map out_def fixdefs in (* Instantiate evars and check all are resolved *) let evd = Evarconv.consider_remaining_unif_problems env_rec !evdref in let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~split:true ~fail:false env_rec evd in let evd = Evarutil.nf_evar_map evd in let fixdefs = List.map (nf_evar evd) fixdefs in let fixtypes = List.map (nf_evar evd) fixtypes in let rec_sign = nf_named_context_evar evd rec_sign in let recdefs = List.length rec_sign in List.iter (check_evars env_rec Evd.empty evd) fixdefs; List.iter (check_evars env Evd.empty evd) fixtypes; Command.check_mutuality env kind (List.combine fixnames fixdefs); (* Russell-specific code *) (* Get the interesting evars, those that were not instanciated *) let isevars = Evd.undefined_evars evd in let evm = isevars in (* Solve remaining evars *) let rec collect_evars id def typ imps = (* Generalize by the recursive prototypes *) let def = Termops.it_mkNamedLambda_or_LetIn def rec_sign and typ = Termops.it_mkNamedProd_or_LetIn typ rec_sign in let evm' = Subtac_utils.evars_of_term evm Evd.empty def in let evm' = Subtac_utils.evars_of_term evm evm' typ in let evars, _, def, typ = Eterm.eterm_obligations env id isevars evm' recdefs def typ in (id, def, typ, imps, evars) in let defs = list_map4 collect_evars fixnames fixdefs fixtypes fiximps in (match fixkind with | IsFixpoint wfl -> let possible_indexes = list_map3 compute_possible_guardness_evidences wfl fixctxs fixtypes in let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames), Array.of_list fixtypes, Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs) in let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in list_iter_i (fun i _ -> Inductive.check_fix env ((indexes,i),fixdecls)) l | IsCoFixpoint -> ()); Subtac_obligations.add_mutual_definitions defs notations fixkind let out_n = function Some n -> n | None -> raise Not_found let build_recursive l = let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in match g, l with [(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] -> ignore(build_wellfounded (id, n, bl, typ, out_def def) r (match n with Some n -> mkIdentC (snd n) | None -> errorlabstrm "Subtac_command.build_recursive" (str "Recursive argument required for well-founded fixpoints")) ntn) | [(n, CMeasureRec (m, r))], [(((_,id),_,bl,typ,def),ntn)] -> ignore(build_wellfounded (id, n, bl, typ, out_def def) (Option.default (CRef lt_ref) r) m ntn) | _, _ when List.for_all (fun (n, ro) -> ro = CStructRec) g -> let fixl = List.map (fun (((_,id),(n,ro),bl,typ,def),ntn) -> ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_annot = n; Command.fix_body = def; Command.fix_type = typ},ntn)) l in interp_recursive (IsFixpoint g) fixl | _, _ -> errorlabstrm "Subtac_command.build_recursive" (str "Well-founded fixpoints not allowed in mutually recursive blocks") let build_corecursive l = let fixl = List.map (fun (((_,id),bl,typ,def),ntn) -> ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_annot = None; Command.fix_body = def; Command.fix_type = typ},ntn)) l in interp_recursive IsCoFixpoint fixl coq-8.4pl4/plugins/subtac/subtac_cases.ml0000644000175000017500000022460112326224777017573 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* PatVar (dummy_loc,Anonymous)) (* Environment management *) let push_rels vars env = List.fold_right push_rel vars env (* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *) let regeneralize_rel i k j = if j = i+k then k else if j < i+k then j else j let rec regeneralize_index i k t = match kind_of_term t with | Rel j when j = i+k -> mkRel (k+1) | Rel j when j < i+k -> t | Rel j when j > i+k -> t | _ -> map_constr_with_binders succ (regeneralize_index i) k t type alias_constr = | DepAlias | NonDepAlias let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) = { uj_val = (match d with | DepAlias -> mkLetIn (na,deppat,t,j.uj_val) | NonDepAlias -> if (not (dependent (mkRel 1) j.uj_type)) or (* A leaf: *) isRel deppat then (* The body of pat is not needed to type j - see *) (* insert_aliases - and both deppat and nondeppat have the *) (* same type, then one can freely substitute one by the other *) subst1 nondeppat j.uj_val else (* The body of pat is not needed to type j but its value *) (* is dependent in the type of j; our choice is to *) (* enforce this dependency *) mkLetIn (na,deppat,t,j.uj_val)); uj_type = subst1 deppat j.uj_type } (**********************************************************************) (* Structures used in compiling pattern-matching *) type rhs = { rhs_env : env; avoid_ids : identifier list; it : glob_constr; } type equation = { patterns : cases_pattern list; rhs : rhs; alias_stack : name list; eqn_loc : loc; used : bool ref } type matrix = equation list (* 1st argument of IsInd is the original ind before extracting the summary *) type tomatch_type = | IsInd of types * inductive_type | NotInd of constr option * types type tomatch_status = | Pushed of ((constr * tomatch_type) * int list) | Alias of (constr * constr * alias_constr * constr) | Abstract of rel_declaration type tomatch_stack = tomatch_status list (* The type [predicate_signature] types the terms to match and the rhs: - [PrLetIn (names,dep,pred)] types a pushed term ([Pushed]), if dep<>Anonymous, the term is dependent, let n=|names|, if n<>0 then the type of the pushed term is necessarily an inductive with n real arguments. Otherwise, it may be non inductive, or inductive without real arguments, or inductive originating from a subterm in which case real args are not dependent; it accounts for n+1 binders if dep or n binders if not dep - [PrProd] types abstracted term ([Abstract]); it accounts for one binder - [PrCcl] types the right-hand side - Aliases [Alias] have no trace in [predicate_signature] *) type predicate_signature = | PrLetIn of (name list * name) * predicate_signature | PrProd of predicate_signature | PrCcl of constr (* We keep a constr for aliases and a cases_pattern for error message *) type alias_builder = | AliasLeaf | AliasConstructor of constructor type pattern_history = | Top | MakeAlias of alias_builder * pattern_continuation and pattern_continuation = | Continuation of int * cases_pattern list * pattern_history | Result of cases_pattern list let start_history n = Continuation (n, [], Top) let feed_history arg = function | Continuation (n, l, h) when n>=1 -> Continuation (n-1, arg :: l, h) | Continuation (n, _, _) -> anomaly ("Bad number of expected remaining patterns: "^(string_of_int n)) | Result _ -> anomaly "Exhausted pattern history" (* This is for non exhaustive error message *) let rec glob_pattern_of_partial_history args2 = function | Continuation (n, args1, h) -> let args3 = make_anonymous_patvars (n - (List.length args2)) in build_glob_pattern (List.rev_append args1 (args2@args3)) h | Result pl -> pl and build_glob_pattern args = function | Top -> args | MakeAlias (AliasLeaf, rh) -> assert (args = []); glob_pattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh | MakeAlias (AliasConstructor pci, rh) -> glob_pattern_of_partial_history [PatCstr (dummy_loc, pci, args, Anonymous)] rh let complete_history = glob_pattern_of_partial_history [] (* This is to build glued pattern-matching history and alias bodies *) let rec simplify_history = function | Continuation (0, l, Top) -> Result (List.rev l) | Continuation (0, l, MakeAlias (f, rh)) -> let pargs = List.rev l in let pat = match f with | AliasConstructor pci -> PatCstr (dummy_loc,pci,pargs,Anonymous) | AliasLeaf -> assert (l = []); PatVar (dummy_loc, Anonymous) in feed_history pat rh | h -> h (* Builds a continuation expecting [n] arguments and building [ci] applied to this [n] arguments *) let push_history_pattern n current cont = Continuation (n, [], MakeAlias (current, cont)) (* A pattern-matching problem has the following form: env, isevars |- Cases tomatch of mat end where tomatch is some sequence of "instructions" (t1 ... tn) and mat is some matrix (p11 ... p1n -> rhs1) ( ... ) (pm1 ... pmn -> rhsm) Terms to match: there are 3 kinds of instructions - "Pushed" terms to match are typed in [env]; these are usually just Rel(n) except for the initial terms given by user and typed in [env] - "Abstract" instructions means an abstraction has to be inserted in the current branch to build (this means a pattern has been detected dependent in another one and generalisation is necessary to ensure well-typing) - "Alias" instructions means an alias has to be inserted (this alias is usually removed at the end, except when its type is not the same as the type of the matched term from which it comes - typically because the inductive types are "real" parameters) Right-hand-sides: They consist of a raw term to type in an environment specific to the clause they belong to: the names of declarations are those of the variables present in the patterns. Therefore, they come with their own [rhs_env] (actually it is the same as [env] except for the names of variables). *) type pattern_matching_problem = { env : env; isevars : Evd.evar_map ref; pred : predicate_signature option; tomatch : tomatch_stack; history : pattern_continuation; mat : matrix; caseloc : loc; casestyle: case_style; typing_function: type_constraint -> env -> glob_constr -> unsafe_judgment } (*--------------------------------------------------------------------------* * A few functions to infer the inductive type from the patterns instead of * * checking that the patterns correspond to the ind. type of the * * destructurated object. Allows type inference of examples like * * match n with O => true | _ => false end * * match x in I with C => true | _ => false end * *--------------------------------------------------------------------------*) (* Computing the inductive type from the matrix of patterns *) (* We use the "in I" clause to coerce the terms to match and otherwise use the constructor to know in which type is the matching problem Note that insertion of coercions inside nested patterns is done each time the matrix is expanded *) let rec find_row_ind = function [] -> None | PatVar _ :: l -> find_row_ind l | PatCstr(loc,c,_,_) :: _ -> Some (loc,c) let inductive_template isevars env tmloc ind = let arsign = get_full_arity_sign env ind in let hole_source = match tmloc with | Some loc -> fun i -> (loc, Evd.TomatchTypeParameter (ind,i)) | None -> fun _ -> (dummy_loc, Evd.InternalHole) in let (_,evarl,_) = List.fold_right (fun (na,b,ty) (subst,evarl,n) -> match b with | None -> let ty' = substl subst ty in let e = e_new_evar isevars env ~src:(hole_source n) ty' in (e::subst,e::evarl,n+1) | Some b -> (b::subst,evarl,n+1)) arsign ([],[],1) in applist (mkInd ind,List.rev evarl) (************************************************************************) (* Utils *) let mkExistential env ?(src=(dummy_loc,Evd.InternalHole)) isevars = e_new_evar isevars env ~src:src (new_Type ()) let evd_comb2 f isevars x y = let (evd',y) = f !isevars x y in isevars := evd'; y let context_of_arsign l = let (x, _) = List.fold_right (fun c (x, n) -> (lift_rel_context n c @ x, List.length c + n)) l ([], 0) in x (* We put the tycon inside the arity signature, possibly discovering dependencies. *) let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c = let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in let subst, len = List.fold_left2 (fun (subst, len) (tm, tmtype) sign -> let signlen = List.length sign in match kind_of_term tm with | Rel n when dependent tm c && signlen = 1 (* The term to match is not of a dependent type itself *) -> ((n, len) :: subst, len - signlen) | Rel n when signlen > 1 (* The term is of a dependent type, maybe some variable in its type appears in the tycon. *) -> (match tmtype with | NotInd _ -> (* len - signlen, subst*) assert false (* signlen > 1 *) | IsInd (_, IndType(indf,realargs)) -> let subst = if dependent tm c && List.for_all isRel realargs then (n, 1) :: subst else subst in List.fold_left (fun (subst, len) arg -> match kind_of_term arg with | Rel n when dependent arg c -> ((n, len) :: subst, pred len) | _ -> (subst, pred len)) (subst, len) realargs) | _ -> (subst, len - signlen)) ([], nar) tomatchs arsign in let rec predicate lift c = match kind_of_term c with | Rel n when n > lift -> (try (* Make the predicate dependent on the matched variable *) let idx = List.assoc (n - lift) subst in mkRel (idx + lift) with Not_found -> (* A variable that is not matched, lift over the arsign. *) mkRel (n + nar)) | _ -> map_constr_with_binders succ predicate lift c in try (* The tycon may be ill-typed after abstraction. *) let pred = predicate 0 c in let env' = push_rel_context (context_of_arsign arsign) env in ignore(Typing.sort_of env' evm pred); pred with e when Errors.noncritical e -> lift nar c module Cases_F(Coercion : Coercion.S) : S = struct let inh_coerce_to_ind isevars env ty tyi = let expected_typ = inductive_template isevars env None tyi in (* devrait ętre indifférent d'exiger leq ou pas puisque pour un inductif cela doit ętre égal *) let _ = e_cumul env isevars expected_typ ty in () let unify_tomatch_with_patterns isevars env loc typ pats = match find_row_ind pats with | None -> NotInd (None,typ) | Some (_,(ind,_)) -> inh_coerce_to_ind isevars env typ ind; try IsInd (typ,find_rectype env ( !isevars) typ) with Not_found -> NotInd (None,typ) let find_tomatch_tycon isevars env loc = function (* Try if some 'in I ...' is present and can be used as a constraint *) | Some (_,ind,_,_) -> mk_tycon (inductive_template isevars env loc ind) | None -> empty_tycon let coerce_row typing_fun isevars env pats (tomatch,(_,indopt)) = let loc = Some (loc_of_glob_constr tomatch) in let tycon = find_tomatch_tycon isevars env loc indopt in let j = typing_fun tycon env tomatch in let evd, j = Coercion.inh_coerce_to_base (loc_of_glob_constr tomatch) env !isevars j in isevars := evd; let typ = nf_evar ( !isevars) j.uj_type in let t = try IsInd (typ,find_rectype env ( !isevars) typ) with Not_found -> unify_tomatch_with_patterns isevars env loc typ pats in (j.uj_val,t) let coerce_to_indtype typing_fun isevars env matx tomatchl = let pats = List.map (fun r -> r.patterns) matx in let matx' = match matrix_transpose pats with | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *) | m -> m in List.map2 (coerce_row typing_fun isevars env) matx' tomatchl let adjust_tomatch_to_pattern pb ((current,typ),deps) = (* Ideally, we could find a common inductive type to which both the term to match and the patterns coerce *) (* In practice, we coerce the term to match if it is not already an inductive type and it is not dependent; moreover, we use only the first pattern type and forget about the others *) let typ = match typ with IsInd (t,_) -> t | NotInd (_,t) -> t in let typ = try IsInd (typ,find_rectype pb.env ( !(pb.isevars)) typ) with Not_found -> NotInd (None,typ) in let tomatch = ((current,typ),deps) in match typ with | NotInd (None,typ) -> let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in (match find_row_ind tm1 with | None -> tomatch | Some (_,(ind,_)) -> let indt = inductive_template pb.isevars pb.env None ind in let current = if deps = [] & isEvar typ then (* Don't insert coercions if dependent; only solve evars *) let _ = e_cumul pb.env pb.isevars indt typ in current else (evd_comb2 (Coercion.inh_conv_coerce_to true dummy_loc pb.env) pb.isevars (make_judge current typ) (mk_tycon_type indt)).uj_val in let sigma = !(pb.isevars) in let typ = IsInd (indt,find_rectype pb.env sigma indt) in ((current,typ),deps)) | _ -> tomatch (* extract some ind from [t], possibly coercing from constructors in [tm] *) let to_mutind env isevars tm c t = (* match c with | Some body -> *) NotInd (c,t) (* | None -> unify_tomatch_with_patterns isevars env t tm*) let type_of_tomatch = function | IsInd (t,_) -> t | NotInd (_,t) -> t let mkDeclTomatch na = function | IsInd (t,_) -> (na,None,t) | NotInd (c,t) -> (na,c,t) let map_tomatch_type f = function | IsInd (t,ind) -> IsInd (f t,map_inductive_type f ind) | NotInd (c,t) -> NotInd (Option.map f c, f t) let liftn_tomatch_type n depth = map_tomatch_type (liftn n depth) let lift_tomatch_type n = liftn_tomatch_type n 1 (**********************************************************************) (* Utilities on patterns *) let current_pattern eqn = match eqn.patterns with | pat::_ -> pat | [] -> anomaly "Empty list of patterns" let alias_of_pat = function | PatVar (_,name) -> name | PatCstr(_,_,_,name) -> name let remove_current_pattern eqn = match eqn.patterns with | pat::pats -> { eqn with patterns = pats; alias_stack = alias_of_pat pat :: eqn.alias_stack } | [] -> anomaly "Empty list of patterns" let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns } (**********************************************************************) (* Well-formedness tests *) (* Partial check on patterns *) exception NotAdjustable let rec adjust_local_defs loc = function | (pat :: pats, (_,None,_) :: decls) -> pat :: adjust_local_defs loc (pats,decls) | (pats, (_,Some _,_) :: decls) -> PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls) | [], [] -> [] | _ -> raise NotAdjustable let check_and_adjust_constructor env ind cstrs = function | PatVar _ as pat -> pat | PatCstr (loc,((_,i) as cstr),args,alias) as pat -> (* Check it is constructor of the right type *) let ind' = inductive_of_constructor cstr in if Names.eq_ind ind' ind then (* Check the constructor has the right number of args *) let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in if List.length args = nb_args_constr then pat else try let args' = adjust_local_defs loc (args, List.rev ci.cs_args) in PatCstr (loc, cstr, args', alias) with NotAdjustable -> error_wrong_numarg_constructor_loc loc (Global.env()) cstr nb_args_constr else (* Try to insert a coercion *) try Coercion.inh_pattern_coerce_to loc pat ind' ind with Not_found -> error_bad_constructor_loc loc cstr ind let check_all_variables typ mat = List.iter (fun eqn -> match current_pattern eqn with | PatVar (_,id) -> () | PatCstr (loc,cstr_sp,_,_) -> error_bad_pattern_loc loc cstr_sp typ) mat let check_unused_pattern env eqn = if not !(eqn.used) then raise_pattern_matching_error (eqn.eqn_loc, env, UnusedClause eqn.patterns) let set_used_pattern eqn = eqn.used := true let extract_rhs pb = match pb.mat with | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion()) | eqn::_ -> set_used_pattern eqn; eqn.rhs (**********************************************************************) (* Functions to deal with matrix factorization *) let occur_in_rhs na rhs = match na with | Anonymous -> false | Name id -> occur_glob_constr id rhs.it let is_dep_patt eqn = function | PatVar (_,name) -> occur_in_rhs name eqn.rhs | PatCstr _ -> true let dependencies_in_rhs nargs eqns = if eqns = [] then list_tabulate (fun _ -> false) nargs (* Only "_" patts *) else let deps = List.map (fun (tms,eqn) -> List.map (is_dep_patt eqn) tms) eqns in let columns = matrix_transpose deps in List.map (List.exists ((=) true)) columns let dependent_decl a = function | (na,None,t) -> dependent a t | (na,Some c,t) -> dependent a t || dependent a c (* Computing the matrix of dependencies *) (* We are in context d1...dn |- and [find_dependencies k 1 nextlist] computes for declaration [k+1] in which of declarations in [nextlist] (which corresponds to d(k+2)...dn) it depends; declarations are expressed by index, e.g. in dependency list [n-2;1], [1] points to [dn] and [n-2] to [d3] *) let rec find_dependency_list k n = function | [] -> [] | (used,tdeps,d)::rest -> let deps = find_dependency_list k (n+1) rest in if used && dependent_decl (mkRel n) d then list_add_set (List.length rest + 1) (list_union deps tdeps) else deps let find_dependencies is_dep_or_cstr_in_rhs d (k,nextlist) = let deps = find_dependency_list k 1 nextlist in if is_dep_or_cstr_in_rhs || deps <> [] then (k-1,(true ,deps,d)::nextlist) else (k-1,(false,[] ,d)::nextlist) let find_dependencies_signature deps_in_rhs typs = let k = List.length deps_in_rhs in let _,l = List.fold_right2 find_dependencies deps_in_rhs typs (k,[]) in List.map (fun (_,deps,_) -> deps) l (******) (* A Pushed term to match has just been substituted by some constructor t = (ci x1...xn) and the terms x1 ... xn have been added to match - all terms to match and to push (dependent on t by definition) must have (Rel depth) substituted by t and Rel's>depth lifted by n - all pushed terms to match (non dependent on t by definition) must be lifted by n We start with depth=1 *) let regeneralize_index_tomatch n = let rec genrec depth = function | [] -> [] | Pushed ((c,tm),l)::rest -> let c = regeneralize_index n depth c in let tm = map_tomatch_type (regeneralize_index n depth) tm in let l = List.map (regeneralize_rel n depth) l in Pushed ((c,tm),l)::(genrec depth rest) | Alias (c1,c2,d,t)::rest -> Alias (regeneralize_index n depth c1,c2,d,t)::(genrec depth rest) | Abstract d::rest -> Abstract (map_rel_declaration (regeneralize_index n depth) d) ::(genrec (depth+1) rest) in genrec 0 let rec replace_term n c k t = if isRel t && destRel t = n+k then lift k c else map_constr_with_binders succ (replace_term n c) k t let replace_tomatch n c = let rec replrec depth = function | [] -> [] | Pushed ((b,tm),l)::rest -> let b = replace_term n c depth b in let tm = map_tomatch_type (replace_term n c depth) tm in List.iter (fun i -> if i=n+depth then anomaly "replace_tomatch") l; Pushed ((b,tm),l)::(replrec depth rest) | Alias (c1,c2,d,t)::rest -> Alias (replace_term n c depth c1,c2,d,t)::(replrec depth rest) | Abstract d::rest -> Abstract (map_rel_declaration (replace_term n c depth) d) ::(replrec (depth+1) rest) in replrec 0 let rec liftn_tomatch_stack n depth = function | [] -> [] | Pushed ((c,tm),l)::rest -> let c = liftn n depth c in let tm = liftn_tomatch_type n depth tm in let l = List.map (fun i -> if i Alias (liftn n depth c1,liftn n depth c2,d,liftn n depth t) ::(liftn_tomatch_stack n depth rest) | Abstract d::rest -> Abstract (map_rel_declaration (liftn n depth) d) ::(liftn_tomatch_stack n (depth+1) rest) let lift_tomatch_stack n = liftn_tomatch_stack n 1 (* if [current] has type [I(p1...pn u1...um)] and we consider the case of constructor [ci] of type [I(p1...pn u'1...u'm)], then the default variable [name] is expected to have which type? Rem: [current] is [(Rel i)] except perhaps for initial terms to match *) (************************************************************************) (* Some heuristics to get names for variables pushed in pb environment *) (* Typical requirement: [match y with (S (S x)) => x | x => x end] should be compiled into [match y with O => y | (S n) => match n with O => y | (S x) => x end end] and [match y with (S (S n)) => n | n => n end] into [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end] i.e. user names should be preserved and created names should not interfere with user names *) let merge_name get_name obj = function | Anonymous -> get_name obj | na -> na let merge_names get_name = List.map2 (merge_name get_name) let get_names env sign eqns = let names1 = list_tabulate (fun _ -> Anonymous) (List.length sign) in (* If any, we prefer names used in pats, from top to bottom *) let names2 = List.fold_right (fun (pats,eqn) names -> merge_names alias_of_pat pats names) eqns names1 in (* Otherwise, we take names from the parameters of the constructor but avoiding conflicts with user ids *) let allvars = List.fold_left (fun l (_,eqn) -> list_union l eqn.rhs.avoid_ids) [] eqns in let names4,_ = List.fold_left2 (fun (l,avoid) d na -> let na = merge_name (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid)) d na in (na::l,(out_name na)::avoid)) ([],allvars) (List.rev sign) names2 in names4 (************************************************************************) (* Recovering names for variables pushed to the rhs' environment *) let recover_alias_names get_name = List.map2 (fun x (_,c,t) ->(get_name x,c,t)) let all_name sign = List.map (fun (n, b, t) -> let n = match n with Name _ -> n | Anonymous -> Name (id_of_string "Anonymous") in (n, b, t)) sign let push_rels_eqn sign eqn = let sign = all_name sign in {eqn with rhs = {eqn.rhs with rhs_env = push_rels sign eqn.rhs.rhs_env; } } let push_rels_eqn_with_names sign eqn = let pats = List.rev (list_firstn (List.length sign) eqn.patterns) in let sign = recover_alias_names alias_of_pat pats sign in push_rels_eqn sign eqn let build_aliases_context env sigma names allpats pats = (* pats is the list of bodies to push as an alias *) (* They all are defined in env and we turn them into a sign *) (* cuts in sign need to be done in allpats *) let rec insert env sign1 sign2 n newallpats oldallpats = function | (deppat,_,_,_)::pats, Anonymous::names when not (isRel deppat) -> (* Anonymous leaves must be considered named and treated in the *) (* next clause because they may occur in implicit arguments *) insert env sign1 sign2 n newallpats (List.map List.tl oldallpats) (pats,names) | (deppat,nondeppat,d,t)::pats, na::names -> let nondeppat = lift n nondeppat in let deppat = lift n deppat in let newallpats = List.map2 (fun l1 l2 -> List.hd l2::l1) newallpats oldallpats in let oldallpats = List.map List.tl oldallpats in let decl = (na,Some deppat,t) in let a = (deppat,nondeppat,d,t) in insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) newallpats oldallpats (pats,names) | [], [] -> newallpats, sign1, sign2, env | _ -> anomaly "Inconsistent alias and name lists" in let allpats = List.map (fun x -> [x]) allpats in insert env [] [] 0 (List.map (fun _ -> []) allpats) allpats (pats, names) let insert_aliases_eqn sign eqnnames alias_rest eqn = let thissign = List.map2 (fun na (_,c,t) -> (na,c,t)) eqnnames sign in push_rels_eqn thissign { eqn with alias_stack = alias_rest; } let insert_aliases env sigma alias eqns = (* Lā, y a une faiblesse, si un alias est utilisé dans un cas par *) (* défaut présent mais inutile, ce qui est le cas général, l'alias *) (* est introduit męme s'il n'est pas utilisé dans les cas réguliers *) let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in (* names2 takes the meet of all needed aliases *) let names2 = List.fold_right (merge_name (fun x -> x)) eqnsnames Anonymous in (* Only needed aliases are kept by build_aliases_context *) let eqnsnames, sign1, sign2, env = build_aliases_context env sigma [names2] eqnsnames [alias] in let eqns = list_map3 (insert_aliases_eqn sign1) eqnsnames alias_rests eqns in sign2, env, eqns (**********************************************************************) (* Functions to deal with elimination predicate *) exception Occur let noccur_between_without_evar n m term = let rec occur_rec n c = match kind_of_term c with | Rel p -> if n<=p && p () | _ -> iter_constr_with_binders succ occur_rec n c in try occur_rec n term; true with Occur -> false (* Inferring the predicate *) let prepare_unif_pb typ cs = let n = List.length (assums_of_rel_context cs.cs_args) in (* We may need to invert ci if its parameters occur in typ *) let typ' = if noccur_between_without_evar 1 n typ then lift (-n) typ else (* TODO4-1 *) error "Unable to infer return clause of this pattern-matching problem" in let args = extended_rel_list (-n) cs.cs_args in let ci = applist (mkConstruct cs.cs_cstr, cs.cs_params@args) in (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = typ' *) (Array.map (lift (-n)) cs.cs_concl_realargs, ci, typ') (* Infering the predicate *) (* The problem to solve is the following: We match Gamma |- t : I(u01..u0q) against the following constructors: Gamma, x11...x1p1 |- C1(x11..x1p1) : I(u11..u1q) ... Gamma, xn1...xnpn |- Cn(xn1..xnp1) : I(un1..unq) Assume the types in the branches are the following Gamma, x11...x1p1 |- branch1 : T1 ... Gamma, xn1...xnpn |- branchn : Tn Assume the type of the global case expression is Gamma |- T The predicate has the form phi = [y1..yq][z:I(y1..yq)]? and must satisfy the following n+1 equations: Gamma, x11...x1p1 |- (phi u11..u1q (C1 x11..x1p1)) = T1 ... Gamma, xn1...xnpn |- (phi un1..unq (Cn xn1..xnpn)) = Tn Gamma |- (phi u01..u0q t) = T Some hints: - Clearly, if xij occurs in Ti, then, a "match z with (Ci xi1..xipi) => ..." should be inserted somewhere in Ti. - If T is undefined, an easy solution is to insert a "match z with (Ci xi1..xipi) => ..." in front of each Ti - Otherwise, T1..Tn and T must be step by step unified, if some of them diverge, then try to replace the diverging subterm by one of y1..yq or z. - The main problem is what to do when an existential variables is encountered let prepare_unif_pb typ cs = let n = cs.cs_nargs in let _,p = decompose_prod_n n typ in let ci = build_dependent_constructor cs in (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = p *) (n, cs.cs_concl_realargs, ci, p) let eq_operator_lift k (n,n') = function | OpRel p, OpRel p' when p > k & p' > k -> if p < k+n or p' < k+n' then false else p - n = p' - n' | op, op' -> op = op' let rec transpose_args n = if n=0 then [] else (Array.map (fun l -> List.hd l) lv):: (transpose_args (m-1) (Array.init (fun l -> List.tl l))) let shift_operator k = function OpLambda _ | OpProd _ -> k+1 | _ -> k let reloc_operator (k,n) = function OpRel p when p > k -> let rec unify_clauses k pv = let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) ( isevars)) p) pv in let n1,op1 = let (n1,(op1,args1)) = pv'.(0) in n1,op1 in if Array.for_all (fun (ni,(opi,_)) -> eq_operator_lift k (n1,ni) (op1,opi)) pv' then let argvl = transpose_args (List.length args1) pv' in let k' = shift_operator k op1 in let argl = List.map (unify_clauses k') argvl in gather_constr (reloc_operator (k,n1) op1) argl *) let abstract_conclusion typ cs = let n = List.length (assums_of_rel_context cs.cs_args) in let (sign,p) = decompose_prod_n n typ in it_mkLambda p sign let infer_predicate loc env isevars typs cstrs indf = (* Il faudra substituer les isevars a un certain moment *) if Array.length cstrs = 0 then (* "TODO4-3" *) error "Inference of annotation for empty inductive types not implemented" else (* Empiric normalization: p may depend in a irrelevant way on args of the*) (* cstr as in [c:{_:Alpha & Beta}] match c with (existS a b)=>(a,b) end *) let typs = Array.map (local_strong whd_beta ( !isevars)) typs in let eqns = array_map2 prepare_unif_pb typs cstrs in (* First strategy: no dependencies at all *) (* let (mis,_) = dest_ind_family indf in let (cclargs,_,typn) = eqns.(mis_nconstr mis -1) in *) let (sign,_) = get_arity env indf in let mtyp = if array_exists is_Type typs then (* Heuristic to avoid comparison between non-variables algebric univs*) new_Type () else mkExistential env ~src:(loc, Evd.CasesType) isevars in if array_for_all (fun (_,_,typ) -> e_cumul env isevars typ mtyp) eqns then (* Non dependent case -> turn it into a (dummy) dependent one *) let sign = (Anonymous,None,build_dependent_inductive env indf)::sign in let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in (true,pred) (* true = dependent -- par défaut *) else (* let s = get_sort_of env ( isevars) typs.(0) in let predpred = it_mkLambda_or_LetIn (mkSort s) sign in let caseinfo = make_default_case_info mis in let brs = array_map2 abstract_conclusion typs cstrs in let predbody = mkCase (caseinfo, (nf_betaiota predpred), mkRel 1, brs) in let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in *) (* "TODO4-2" *) (* We skip parameters *) let cis = Array.map (fun cs -> applist (mkConstruct cs.cs_cstr, extended_rel_list 0 cs.cs_args)) cstrs in let ct = array_map2 (fun ci (_,_,t) -> (ci,t)) cis eqns in raise_pattern_matching_error (loc,env, CannotInferPredicate ct) (* (true,pred) *) (* Propagation of user-provided predicate through compilation steps *) let rec map_predicate f k = function | PrCcl ccl -> PrCcl (f k ccl) | PrProd pred -> PrProd (map_predicate f (k+1) pred) | PrLetIn ((names,dep as tm),pred) -> let k' = List.length names + (if dep<>Anonymous then 1 else 0) in PrLetIn (tm, map_predicate f (k+k') pred) let rec noccurn_predicate k = function | PrCcl ccl -> noccurn k ccl | PrProd pred -> noccurn_predicate (k+1) pred | PrLetIn ((names,dep),pred) -> let k' = List.length names + (if dep<>Anonymous then 1 else 0) in noccurn_predicate (k+k') pred let liftn_predicate n = map_predicate (liftn n) let lift_predicate n = liftn_predicate n 1 let regeneralize_index_predicate n = map_predicate (regeneralize_index n) 0 let substnl_predicate sigma = map_predicate (substnl sigma) (* This is parallel bindings *) let subst_predicate (args,copt) pred = let sigma = match copt with | None -> List.rev args | Some c -> c::(List.rev args) in substnl_predicate sigma 0 pred let specialize_predicate_var (cur,typ) = function | PrProd _ | PrCcl _ -> anomaly "specialize_predicate_var: a pattern-variable must be pushed" | PrLetIn (([],dep),pred) -> subst_predicate ([],if dep<>Anonymous then Some cur else None) pred | PrLetIn ((_,dep),pred) -> (match typ with | IsInd (_,IndType (_,realargs)) -> subst_predicate (realargs,if dep<>Anonymous then Some cur else None) pred | _ -> anomaly "specialize_predicate_var") let ungeneralize_predicate = function | PrLetIn _ | PrCcl _ -> anomaly "ungeneralize_predicate: expects a product" | PrProd pred -> pred (*****************************************************************************) (* We have pred = [X:=realargs;x:=c]P typed in Gamma1, x:I(realargs), Gamma2 *) (* and we want to abstract P over y:t(x) typed in the same context to get *) (* *) (* pred' = [X:=realargs;x':=c](y':t(x'))P[y:=y'] *) (* *) (* We first need to lift t(x) s.t. it is typed in Gamma, X:=rargs, x' *) (* then we have to replace x by x' in t(x) and y by y' in P *) (*****************************************************************************) let generalize_predicate ny d = function | PrLetIn ((names,dep as tm),pred) -> if dep=Anonymous then anomaly "Undetected dependency"; let p = List.length names + 1 in let pred = lift_predicate 1 pred in let pred = regeneralize_index_predicate (ny+p+1) pred in PrLetIn (tm, PrProd pred) | PrProd _ | PrCcl _ -> anomaly "generalize_predicate: expects a non trivial pattern" let rec extract_predicate l = function | pred, Alias (deppat,nondeppat,_,_)::tms -> let tms' = match kind_of_term nondeppat with | Rel i -> replace_tomatch i deppat tms | _ -> (* initial terms are not dependent *) tms in extract_predicate l (pred,tms') | PrProd pred, Abstract d'::tms -> let d' = map_rel_declaration (lift (List.length l)) d' in substl l (mkProd_or_LetIn d' (extract_predicate [] (pred,tms))) | PrLetIn (([],dep),pred), Pushed ((cur,_),_)::tms -> extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms) | PrLetIn ((_,dep),pred), Pushed ((cur,IsInd (_,(IndType(_,realargs)))),_)::tms -> let l = List.rev realargs@l in extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms) | PrCcl ccl, [] -> substl l ccl | _ -> anomaly"extract_predicate: predicate inconsistent with terms to match" let abstract_predicate env sigma indf cur tms = function | (PrProd _ | PrCcl _) -> anomaly "abstract_predicate: must be some LetIn" | PrLetIn ((names,dep),pred) -> let sign = make_arity_signature env true indf in (* n is the number of real args + 1 *) let n = List.length sign in let tms = lift_tomatch_stack n tms in let tms = match kind_of_term cur with | Rel i -> regeneralize_index_tomatch (i+n) tms | _ -> (* Initial case *) tms in (* Depending on whether the predicate is dependent or not, and has real args or not, we lift it to make room for [sign] *) (* Even if not intrinsically dep, we move the predicate into a dep one *) let sign,k = if names = [] & n <> 1 then (* Real args were not considered *) (if dep<>Anonymous then ((let (_,c,t) = List.hd sign in (dep,c,t)::List.tl sign),n-1) else (sign,n)) else (* Real args are OK *) (List.map2 (fun na (_,c,t) -> (na,c,t)) (dep::names) sign, if dep<>Anonymous then 0 else 1) in let pred = lift_predicate k pred in let pred = extract_predicate [] (pred,tms) in (true, it_mkLambda_or_LetIn_name env pred sign) let rec known_dependent = function | None -> false | Some (PrLetIn ((_,dep),_)) -> dep<>Anonymous | Some (PrCcl _) -> false | Some (PrProd _) -> anomaly "known_dependent: can only be used when patterns remain" (* [expand_arg] is used by [specialize_predicate] it replaces gamma, x1...xn, x1...xk |- pred by gamma, x1...xn, x1...xk-1 |- [X=realargs,xk=xk]pred (if dep) or by gamma, x1...xn, x1...xk-1 |- [X=realargs]pred (if not dep) *) let expand_arg n alreadydep (na,t) deps (k,pred) = (* current can occur in pred even if the original problem is not dependent *) let dep = if alreadydep<>Anonymous then alreadydep else if deps = [] && noccurn_predicate 1 pred then Anonymous else Name (id_of_string "x") in let pred = if dep<>Anonymous then pred else lift_predicate (-1) pred in (* There is no dependency in realargs for subpattern *) (k-1, PrLetIn (([],dep), pred)) (*****************************************************************************) (* pred = [X:=realargs;x:=c]P types the following problem: *) (* *) (* Gamma |- match Pushed(c:I(realargs)) rest with...end: pred *) (* *) (* where the branch with constructor Ci:(x1:T1)...(xn:Tn)->I(realargsi) *) (* is considered. Assume each Ti is some Ii(argsi). *) (* We let e=Ci(x1,...,xn) and replace pred by *) (* *) (* pred' = [X1:=rargs1,x1:=x1']...[Xn:=rargsn,xn:=xn'](P[X:=realargsi;x:=e]) *) (* *) (* s.t Gamma,x1'..xn' |- match Pushed(x1')..Pushed(xn') rest with..end :pred'*) (* *) (*****************************************************************************) let specialize_predicate tomatchs deps cs = function | (PrProd _ | PrCcl _) -> anomaly "specialize_predicate: a matched pattern must be pushed" | PrLetIn ((names,isdep),pred) -> (* Assume some gamma st: gamma, (X,x:=realargs,copt) |- pred *) let nrealargs = List.length names in let k = nrealargs + (if isdep<>Anonymous then 1 else 0) in (* We adjust pred st: gamma, x1..xn, (X,x:=realargs,copt) |- pred' *) let n = cs.cs_nargs in let pred' = liftn_predicate n (k+1) pred in let argsi = if nrealargs <> 0 then Array.to_list cs.cs_concl_realargs else [] in let copti = if isdep<>Anonymous then Some (build_dependent_constructor cs) else None in (* The substituends argsi, copti are all defined in gamma, x1...xn *) (* We need _parallel_ bindings to get gamma, x1...xn |- pred'' *) let pred'' = subst_predicate (argsi, copti) pred' in (* We adjust pred st: gamma, x1..xn, x1..xn |- pred'' *) let pred''' = liftn_predicate n (n+1) pred'' in (* We finally get gamma,x1..xn |- [X1,x1:=R1,x1]..[Xn,xn:=Rn,xn]pred'''*) snd (List.fold_right2 (expand_arg n isdep) tomatchs deps (n,pred''')) let find_predicate loc env isevars p typs cstrs current (IndType (indf,realargs)) tms = let (dep,pred) = match p with | Some p -> abstract_predicate env ( !isevars) indf current tms p | None -> infer_predicate loc env isevars typs cstrs indf in let typ = whd_beta ( !isevars) (applist (pred, realargs)) in if dep then (pred, whd_beta ( !isevars) (applist (typ, [current])), new_Type ()) else (pred, typ, new_Type ()) (************************************************************************) (* Sorting equations by constructor *) type inversion_problem = (* the discriminating arg in some Ind and its order in Ind *) | Incompatible of int * (int * int) | Constraints of (int * constr) list let solve_constraints constr_info indt = (* TODO *) Constraints [] let rec irrefutable env = function | PatVar (_,name) -> true | PatCstr (_,cstr,args,_) -> let ind = inductive_of_constructor cstr in let (_,mip) = Inductive.lookup_mind_specif env ind in let one_constr = Array.length mip.mind_user_lc = 1 in one_constr & List.for_all (irrefutable env) args let first_clause_irrefutable env = function | eqn::mat -> List.for_all (irrefutable env) eqn.patterns | _ -> false let group_equations pb ind current cstrs mat = let mat = if first_clause_irrefutable pb.env mat then [List.hd mat] else mat in let brs = Array.create (Array.length cstrs) [] in let only_default = ref true in let _ = List.fold_right (* To be sure it's from bottom to top *) (fun eqn () -> let rest = remove_current_pattern eqn in let pat = current_pattern eqn in match check_and_adjust_constructor pb.env ind cstrs pat with | PatVar (_,name) -> (* This is a default clause that we expand *) for i=1 to Array.length cstrs do let n = cstrs.(i-1).cs_nargs in let args = make_anonymous_patvars n in brs.(i-1) <- (args, rest) :: brs.(i-1) done | PatCstr (loc,((_,i)),args,_) -> (* This is a regular clause *) only_default := false; brs.(i-1) <- (args,rest) :: brs.(i-1)) mat () in (brs,!only_default) (************************************************************************) (* Here starts the pattern-matching compilation algorithm *) (* Abstracting over dependent subterms to match *) let rec generalize_problem pb = function | [] -> pb | i::l -> let d = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in let pb' = generalize_problem pb l in let tomatch = lift_tomatch_stack 1 pb'.tomatch in let tomatch = regeneralize_index_tomatch (i+1) tomatch in { pb with tomatch = Abstract d :: tomatch; pred = Option.map (generalize_predicate i d) pb'.pred } (* No more patterns: typing the right-hand side of equations *) let build_leaf pb = let rhs = extract_rhs pb in let tycon = match pb.pred with | None -> anomaly "Predicate not found" | Some (PrCcl typ) -> mk_tycon typ | Some _ -> anomaly "not all parameters of pred have been consumed" in pb.typing_function tycon rhs.rhs_env rhs.it (* Building the sub-problem when all patterns are variables *) let shift_problem (current,t) pb = {pb with tomatch = Alias (current,current,NonDepAlias,type_of_tomatch t)::pb.tomatch; pred = Option.map (specialize_predicate_var (current,t)) pb.pred; history = push_history_pattern 0 AliasLeaf pb.history; mat = List.map remove_current_pattern pb.mat } (* Building the sub-pattern-matching problem for a given branch *) let build_branch current deps pb eqns const_info = (* We remember that we descend through a constructor *) let alias_type = if Array.length const_info.cs_concl_realargs = 0 & not (known_dependent pb.pred) & deps = [] then NonDepAlias else DepAlias in let history = push_history_pattern const_info.cs_nargs (AliasConstructor const_info.cs_cstr) pb.history in (* We find matching clauses *) let cs_args = (*assums_of_rel_context*) const_info.cs_args in let names = get_names pb.env cs_args eqns in let submat = List.map (fun (tms,eqn) -> prepend_pattern tms eqn) eqns in if submat = [] then raise_pattern_matching_error (dummy_loc, pb.env, NonExhaustive (complete_history history)); let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in let _,typs',_ = List.fold_right (fun (na,c,t as d) (env,typs,tms) -> let tm1 = List.map List.hd tms in let tms = List.map List.tl tms in (push_rel d env, (na,to_mutind env pb.isevars tm1 c t)::typs,tms)) typs (pb.env,[],List.map fst eqns) in let dep_sign = find_dependencies_signature (dependencies_in_rhs const_info.cs_nargs eqns) (List.rev typs) in (* The dependent term to subst in the types of the remaining UnPushed terms is relative to the current context enriched by topushs *) let ci = build_dependent_constructor const_info in (* We replace [(mkRel 1)] by its expansion [ci] *) (* and context "Gamma = Gamma1, current, Gamma2" by "Gamma;typs;curalias" *) (* This is done in two steps : first from "Gamma |- tms" *) (* into "Gamma; typs; curalias |- tms" *) let tomatch = lift_tomatch_stack const_info.cs_nargs pb.tomatch in let currents = list_map2_i (fun i (na,t) deps -> Pushed ((mkRel i, lift_tomatch_type i t), deps)) 1 typs' (List.rev dep_sign) in let sign = List.map (fun (na,t) -> mkDeclTomatch na t) typs' in let ind = appvect ( applist (mkInd (inductive_of_constructor const_info.cs_cstr), List.map (lift const_info.cs_nargs) const_info.cs_params), const_info.cs_concl_realargs) in let cur_alias = lift (List.length sign) current in let currents = Alias (ci,cur_alias,alias_type,ind) :: currents in let env' = push_rels sign pb.env in let pred' = Option.map (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred in sign, { pb with env = env'; tomatch = List.rev_append currents tomatch; pred = pred'; history = history; mat = List.map (push_rels_eqn_with_names sign) submat } (********************************************************************** INVARIANT: pb = { env, subst, tomatch, mat, ...} tomatch = list of Pushed (c:T) or Abstract (na:T) or Alias (c:T) "Pushed" terms and types are relative to env "Abstract" types are relative to env enriched by the previous terms to match *) (**********************************************************************) (* Main compiling descent *) let rec compile pb = match pb.tomatch with | (Pushed cur)::rest -> match_current { pb with tomatch = rest } cur | (Alias x)::rest -> compile_alias pb x rest | (Abstract d)::rest -> compile_generalization pb d rest | [] -> build_leaf pb and match_current pb tomatch = let ((current,typ as ct),deps) = adjust_tomatch_to_pattern pb tomatch in match typ with | NotInd (_,typ) -> check_all_variables typ pb.mat; compile (shift_problem ct pb) | IsInd (_,(IndType(indf,realargs) as indt)) -> let mind,_ = dest_ind_family indf in let cstrs = get_constructors pb.env indf in let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in if (Array.length cstrs <> 0 or pb.mat <> []) & onlydflt then compile (shift_problem ct pb) else let _constraints = Array.map (solve_constraints indt) cstrs in (* We generalize over terms depending on current term to match *) let pb = generalize_problem pb deps in (* We compile branches *) let brs = array_map2 (compile_branch current deps pb) eqns cstrs in (* We build the (elementary) case analysis *) let brvals = Array.map (fun (v,_) -> v) brs in let brtyps = Array.map (fun (_,t) -> t) brs in let (pred,typ,s) = find_predicate pb.caseloc pb.env pb.isevars pb.pred brtyps cstrs current indt pb.tomatch in let ci = make_case_info pb.env mind pb.casestyle in let case = mkCase (ci,nf_betaiota Evd.empty pred,current,brvals) in let inst = List.map mkRel deps in { uj_val = applist (case, inst); uj_type = substl inst typ } and compile_branch current deps pb eqn cstr = let sign, pb = build_branch current deps pb eqn cstr in let j = compile pb in (it_mkLambda_or_LetIn j.uj_val sign, j.uj_type) and compile_generalization pb d rest = let pb = { pb with env = push_rel d pb.env; tomatch = rest; pred = Option.map ungeneralize_predicate pb.pred; mat = List.map (push_rels_eqn [d]) pb.mat } in let j = compile pb in { uj_val = mkLambda_or_LetIn d j.uj_val; uj_type = mkProd_or_LetIn d j.uj_type } and compile_alias pb (deppat,nondeppat,d,t) rest = let history = simplify_history pb.history in let sign, newenv, mat = insert_aliases pb.env ( !(pb.isevars)) (deppat,nondeppat,d,t) pb.mat in let n = List.length sign in (* We had Gamma1; x:current; Gamma2 |- tomatch(x) and we rebind x to get *) (* Gamma1; x:current; Gamma2; typs; x':=curalias |- tomatch(x') *) let tomatch = lift_tomatch_stack n rest in let tomatch = match kind_of_term nondeppat with | Rel i -> if n = 1 then regeneralize_index_tomatch (i+n) tomatch else replace_tomatch i deppat tomatch | _ -> (* initial terms are not dependent *) tomatch in let pb = {pb with env = newenv; tomatch = tomatch; pred = Option.map (lift_predicate n) pb.pred; history = history; mat = mat } in let j = compile pb in List.fold_left mkSpecialLetInJudge j sign (* pour les alias des initiaux, enrichir les env de ce qu'il faut et substituer aprčs par les initiaux *) (**************************************************************************) (* Preparation of the pattern-matching problem *) (* builds the matrix of equations testing that each eqn has n patterns * and linearizing the _ patterns. * Syntactic correctness has already been done in astterm *) let matx_of_eqns env eqns = let build_eqn (loc,ids,lpat,rhs) = let rhs = { rhs_env = env; avoid_ids = ids@(ids_of_named_context (named_context env)); it = rhs; } in { patterns = lpat; alias_stack = []; eqn_loc = loc; used = ref false; rhs = rhs } in List.map build_eqn eqns (************************************************************************) (* preparing the elimination predicate if any *) let oldprepare_predicate_from_tycon loc dep env isevars tomatchs sign c = let cook (n, l, env, signs) = function | c,IsInd (_,IndType(indf,realargs)) -> let indf' = lift_inductive_family n indf in let sign = make_arity_signature env dep indf' in let p = List.length realargs in if dep then (n + p + 1, c::(List.rev realargs)@l, push_rels sign env,sign::signs) else (n + p, (List.rev realargs)@l, push_rels sign env,sign::signs) | c,NotInd _ -> (n, l, env, []::signs) in let n, allargs, env, signs = List.fold_left cook (0, [], env, []) tomatchs in let names = List.rev (List.map (List.map pi1) signs) in let allargs = List.map (fun c -> lift n (nf_betadeltaiota env ( !isevars) c)) allargs in let rec build_skeleton env c = (* Don't put into normal form, it has effects on the synthesis of evars *) (* let c = whd_betadeltaiota env ( isevars) c in *) (* We turn all subterms possibly dependent into an evar with maximum ctxt*) if isEvar c or List.exists (eq_constr c) allargs then e_new_evar isevars env ~src:(loc, Evd.CasesType) (Retyping.get_type_of env ( !isevars) c) else map_constr_with_full_binders push_rel build_skeleton env c in names, build_skeleton env (lift n c) (* Here, [pred] is assumed to be in the context built from all *) (* realargs and terms to match *) let build_initial_predicate isdep allnames pred = let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in let rec buildrec n pred = function | [] -> PrCcl pred | names::lnames -> let names' = if isdep then List.tl names else names in let n' = n + List.length names' in let pred, p, user_p = if isdep then if dependent (mkRel (nar-n')) pred then pred, 1, 1 else liftn (-1) (nar-n') pred, 0, 1 else pred, 0, 0 in let na = if p=1 then let na = List.hd names in if na = Anonymous then (* peut arriver en raison des evars *) Name (id_of_string "x") (*Hum*) else na else Anonymous in PrLetIn ((names',na), buildrec (n'+user_p) pred lnames) in buildrec 0 pred allnames let extract_arity_signature env0 tomatchl tmsign = let get_one_sign n tm (na,t) = match tm with | NotInd (bo,typ) -> (match t with | None -> [na,Option.map (lift n) bo,lift n typ] | Some (loc,_,_,_) -> user_err_loc (loc,"", str "Unexpected type annotation for a term of non inductive type")) | IsInd (_,IndType(indf,realargs)) -> let indf' = lift_inductive_family n indf in let (ind,params) = dest_ind_family indf' in let nrealargs = List.length realargs in let realnal = match t with | Some (loc,ind',nparams,realnal) -> if ind <> ind' then user_err_loc (loc,"",str "Wrong inductive type"); if List.length params <> nparams or nrealargs <> List.length realnal then anomaly "Ill-formed 'in' clause in cases"; List.rev realnal | None -> list_tabulate (fun _ -> Anonymous) nrealargs in let arsign = fst (get_arity env0 indf') in (na,None,build_dependent_inductive env0 indf') ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in let rec buildrec n = function | [],[] -> [] | (_,tm)::ltm, x::tmsign -> let l = get_one_sign n tm x in l :: buildrec (n + List.length l) (ltm,tmsign) | _ -> assert false in List.rev (buildrec 0 (tomatchl,tmsign)) let extract_arity_signatures env0 tomatchl tmsign = let get_one_sign tm (na,t) = match tm with | NotInd (bo,typ) -> (match t with | None -> [na,bo,typ] | Some (loc,_,_,_) -> user_err_loc (loc,"", str "Unexpected type annotation for a term of non inductive type")) | IsInd (_,IndType(indf,realargs)) -> let (ind,params) = dest_ind_family indf in let nrealargs = List.length realargs in let realnal = match t with | Some (loc,ind',nparams,realnal) -> if ind <> ind' then user_err_loc (loc,"",str "Wrong inductive type"); if List.length params <> nparams or nrealargs <> List.length realnal then anomaly "Ill-formed 'in' clause in cases"; List.rev realnal | None -> list_tabulate (fun _ -> Anonymous) nrealargs in let arsign = fst (get_arity env0 indf) in (na,None,build_dependent_inductive env0 indf) ::(try List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign with e when Errors.noncritical e -> assert false) in let rec buildrec = function | [],[] -> [] | (_,tm)::ltm, x::tmsign -> let l = get_one_sign tm x in l :: buildrec (ltm,tmsign) | _ -> assert false in List.rev (buildrec (tomatchl,tmsign)) let inh_conv_coerce_to_tycon loc env isevars j tycon = match tycon with | Some p -> let (evd',j) = Coercion.inh_conv_coerce_to true loc env !isevars j p in isevars := evd'; j | None -> j let out_ind = function IsInd (_, IndType(x, y)) -> (x, y) | _ -> assert(false) let string_of_name name = match name with | Anonymous -> "anonymous" | Name n -> string_of_id n let id_of_name n = id_of_string (string_of_name n) let make_prime_id name = let str = string_of_name name in id_of_string str, id_of_string (str ^ "'") let prime avoid name = let previd, id = make_prime_id name in previd, next_ident_away id avoid let make_prime avoid prevname = let previd, id = prime !avoid prevname in avoid := id :: !avoid; previd, id let eq_id avoid id = let hid = id_of_string ("Heq_" ^ string_of_id id) in let hid' = next_ident_away hid avoid in hid' let mk_eq typ x y = mkApp (delayed_force eq_ind, [| typ; x ; y |]) let mk_eq_refl typ x = mkApp (delayed_force eq_refl, [| typ; x |]) let mk_JMeq typ x typ' y = mkApp (delayed_force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |]) let mk_JMeq_refl typ x = mkApp (delayed_force Subtac_utils.jmeq_refl, [| typ; x |]) let hole = GHole (dummy_loc, Evd.QuestionMark (Evd.Define true)) let constr_of_pat env isevars arsign pat avoid = let rec typ env (ty, realargs) pat avoid = match pat with | PatVar (l,name) -> let name, avoid = match name with Name n -> name, avoid | Anonymous -> let previd, id = prime avoid (Name (id_of_string "wildcard")) in Name id, id :: avoid in PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid | PatCstr (l,((_, i) as cstr),args,alias) -> let cind = inductive_of_constructor cstr in let IndType (indf, _) = try find_rectype env ( !isevars) (lift (-(List.length realargs)) ty) with Not_found -> error_case_not_inductive env {uj_val = ty; uj_type = Typing.type_of env !isevars ty} in let ind, params = dest_ind_family indf in if ind <> cind then error_bad_constructor_loc l cstr ind; let cstrs = get_constructors env indf in let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in assert(nb_args_constr = List.length args); let patargs, args, sign, env, n, m, avoid = List.fold_right2 (fun (na, c, t) ua (patargs, args, sign, env, n, m, avoid) -> let pat', sign', arg', typ', argtypargs, n', avoid = typ env (substl args (liftn (List.length sign) (succ (List.length args)) t), []) ua avoid in let args' = arg' :: List.map (lift n') args in let env' = push_rels sign' env in (pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, avoid)) ci.cs_args (List.rev args) ([], [], [], env, 0, 0, avoid) in let args = List.rev args in let patargs = List.rev patargs in let pat' = PatCstr (l, cstr, patargs, alias) in let cstr = mkConstruct ci.cs_cstr in let app = applistc cstr (List.map (lift (List.length sign)) params) in let app = applistc app args in let apptype = Retyping.get_type_of env ( !isevars) app in let IndType (indf, realargs) = find_rectype env ( !isevars) apptype in match alias with Anonymous -> pat', sign, app, apptype, realargs, n, avoid | Name id -> let sign = (alias, None, lift m ty) :: sign in let avoid = id :: avoid in let sign, i, avoid = try let env = push_rels sign env in isevars := the_conv_x_leq (push_rels sign env) (lift (succ m) ty) (lift 1 apptype) !isevars; let eq_t = mk_eq (lift (succ m) ty) (mkRel 1) (* alias *) (lift 1 app) (* aliased term *) in let neq = eq_id avoid id in (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid with Reduction.NotConvertible -> sign, 1, avoid in (* Mark the equality as a hole *) pat', sign, lift i app, lift i apptype, realargs, n + i, avoid in let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid (* shadows functional version *) let eq_id avoid id = let hid = id_of_string ("Heq_" ^ string_of_id id) in let hid' = next_ident_away hid !avoid in avoid := hid' :: !avoid; hid' let rels_of_patsign = List.map (fun ((na, b, t) as x) -> match b with | Some t' when kind_of_term t' = Rel 0 -> (na, None, t) | _ -> x) let vars_of_ctx ctx = let _, y = List.fold_right (fun (na, b, t) (prev, vars) -> match b with | Some t' when kind_of_term t' = Rel 0 -> prev, (GApp (dummy_loc, (GRef (dummy_loc, delayed_force refl_ref)), [hole; GVar (dummy_loc, prev)])) :: vars | _ -> match na with Anonymous -> raise (Invalid_argument "vars_of_ctx") | Name n -> n, GVar (dummy_loc, n) :: vars) ctx (id_of_string "vars_of_ctx_error", []) in List.rev y let rec is_included x y = match x, y with | PatVar _, _ -> true | _, PatVar _ -> true | PatCstr (l, (_, i), args, alias), PatCstr (l', (_, i'), args', alias') -> if i = i' then List.for_all2 is_included args args' else false (* liftsign is the current pattern's complete signature length. Hence pats is already typed in its full signature. However prevpatterns are in the original one signature per pattern form. *) let build_ineqs prevpatterns pats liftsign = let _tomatchs = List.length pats in let diffs = List.fold_left (fun c eqnpats -> let acc = List.fold_left2 (* ppat is the pattern we are discriminating against, curpat is the current one. *) (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat) (curpat_sign, curpat_c, (curpat_ty, curpat_tyargs), curpat) -> match acc with None -> None | Some (sign, len, n, c) -> (* FixMe: do not work with ppat_args *) if is_included curpat ppat then (* Length of previous pattern's signature *) let lens = List.length ppat_sign in (* Accumulated length of previous pattern's signatures *) let len' = lens + len in let acc = ((* Jump over previous prevpat signs *) lift_rel_context len ppat_sign @ sign, len', succ n, (* nth pattern *) mkApp (delayed_force eq_ind, [| lift (len' + liftsign) curpat_ty; liftn (len + liftsign) (succ lens) ppat_c ; lift len' curpat_c |]) :: List.map (lift lens (* Jump over this prevpat signature *)) c) in Some acc else None) (Some ([], 0, 0, [])) eqnpats pats in match acc with None -> c | Some (sign, len, _, c') -> let conj = it_mkProd_or_LetIn (mk_not (mk_conj c')) (lift_rel_context liftsign sign) in conj :: c) [] prevpatterns in match diffs with [] -> None | _ -> Some (mk_conj diffs) let subst_rel_context k ctx subst = let (_, ctx') = List.fold_right (fun (n, b, t) (k, acc) -> (succ k, (n, Option.map (substnl subst k) b, substnl subst k t) :: acc)) ctx (k, []) in ctx' let lift_rel_contextn n k sign = let rec liftrec k = function | (na,c,t)::sign -> (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) | [] -> [] in liftrec (rel_context_length sign + k) sign let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity = let i = ref 0 in let (x, y, z) = List.fold_left (fun (branches, eqns, prevpatterns) eqn -> let _, newpatterns, pats = List.fold_left2 (fun (idents, newpatterns, pats) pat arsign -> let pat', cpat, idents = constr_of_pat env isevars arsign pat idents in (idents, pat' :: newpatterns, cpat :: pats)) ([], [], []) eqn.patterns sign in let newpatterns = List.rev newpatterns and opats = List.rev pats in let rhs_rels, pats, signlen = List.fold_left (fun (renv, pats, n) (sign,c, (s, args), p) -> (* Recombine signatures and terms of all of the row's patterns *) let sign' = lift_rel_context n sign in let len = List.length sign' in (sign' @ renv, (* lift to get outside of previous pattern's signatures. *) (sign', liftn n (succ len) c, (s, List.map (liftn n (succ len)) args), p) :: pats, len + n)) ([], [], 0) opats in let pats, _ = List.fold_left (* lift to get outside of past patterns to get terms in the combined environment. *) (fun (pats, n) (sign, c, (s, args), p) -> let len = List.length sign in ((rels_of_patsign sign, lift n c, (s, List.map (lift n) args), p) :: pats, len + n)) ([], 0) pats in let ineqs = build_ineqs prevpatterns pats signlen in let rhs_rels' = rels_of_patsign rhs_rels in let _signenv = push_rel_context rhs_rels' env in let arity = let args, nargs = List.fold_right (fun (sign, c, (_, args), _) (allargs,n) -> (args @ c :: allargs, List.length args + succ n)) pats ([], 0) in let args = List.rev args in substl args (liftn signlen (succ nargs) arity) in let rhs_rels', tycon = let neqs_rels, arity = match ineqs with | None -> [], arity | Some ineqs -> [Anonymous, None, ineqs], lift 1 arity in let eqs_rels, arity = decompose_prod_n_assum neqs arity in eqs_rels @ neqs_rels @ rhs_rels', arity in let rhs_env = push_rels rhs_rels' env in let j = typing_fun (mk_tycon tycon) rhs_env eqn.rhs.it in let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels' and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in let branch_name = id_of_string ("program_branch_" ^ (string_of_int !i)) in let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in let branch = let bref = GVar (dummy_loc, branch_name) in match vars_of_ctx rhs_rels with [] -> bref | l -> GApp (dummy_loc, bref, l) in let branch = match ineqs with Some _ -> GApp (dummy_loc, branch, [ hole ]) | None -> branch in incr i; let rhs = { eqn.rhs with it = branch } in (branch_decl :: branches, { eqn with patterns = newpatterns; rhs = rhs } :: eqns, opats :: prevpatterns)) ([], [], []) eqns in x, y (* Builds the predicate. If the predicate is dependent, its context is * made of 1+nrealargs assumptions for each matched term in an inductive * type and 1 assumption for each term not _syntactically_ in an * inductive type. * Each matched terms are independently considered dependent or not. * A type constraint but no annotation case: it is assumed non dependent. *) let lift_ctx n ctx = let ctx', _ = List.fold_right (fun (c, t) (ctx, n') -> (liftn n n' c, liftn_tomatch_type n n' t) :: ctx, succ n') ctx ([], 0) in ctx' (* Turn matched terms into variables. *) let abstract_tomatch env tomatchs tycon = let prev, ctx, names, tycon = List.fold_left (fun (prev, ctx, names, tycon) (c, t) -> let lenctx = List.length ctx in match kind_of_term c with Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names, tycon | _ -> let tycon = Option.map (fun t -> subst_term (lift 1 c) (lift 1 t)) tycon in let name = next_ident_away (id_of_string "filtered_var") names in (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx, name :: names, tycon) ([], [], [], tycon) tomatchs in List.rev prev, ctx, tycon let is_dependent_ind = function IsInd (_, IndType (indf, args)) when List.length args > 0 -> true | _ -> false let build_dependent_signature env evars avoid tomatchs arsign = let avoid = ref avoid in let arsign = List.rev arsign in let allnames = List.rev (List.map (List.map pi1) arsign) in let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in let eqs, neqs, refls, slift, arsign' = List.fold_left2 (fun (eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign -> (* The accumulator: previous eqs, number of previous eqs, lift to get outside eqs and in the introduced variables ('as' and 'in'), new arity signatures *) match ty with IsInd (ty, IndType (indf, args)) when List.length args > 0 -> (* Build the arity signature following the names in matched terms as much as possible *) let argsign = List.tl arsign in (* arguments in inverse application order *) let (appn, appb, appt) as _appsign = List.hd arsign in (* The matched argument *) let argsign = List.rev argsign in (* arguments in application order *) let env', nargeqs, argeqs, refl_args, slift, argsign' = List.fold_left2 (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) -> let argt = Retyping.get_type_of env evars arg in let eq, refl_arg = if Reductionops.is_conv env evars argt t then (mk_eq (lift (nargeqs + slift) argt) (mkRel (nargeqs + slift)) (lift (nargeqs + nar) arg), mk_eq_refl argt arg) else (mk_JMeq (lift (nargeqs + slift) t) (mkRel (nargeqs + slift)) (lift (nargeqs + nar) argt) (lift (nargeqs + nar) arg), mk_JMeq_refl argt arg) in let previd, id = let name = match kind_of_term arg with Rel n -> pi1 (lookup_rel n env) | _ -> name in make_prime avoid name in (env, succ nargeqs, (Name (eq_id avoid previd), None, eq) :: argeqs, refl_arg :: refl_args, pred slift, (Name id, b, t) :: argsign')) (env, neqs, [], [], slift, []) args argsign in let eq = mk_JMeq (lift (nargeqs + slift) appt) (mkRel (nargeqs + slift)) (lift (nargeqs + nar) ty) (lift (nargeqs + nar) tm) in let refl_eq = mk_JMeq_refl ty tm in let previd, id = make_prime avoid appn in (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs, succ nargeqs, refl_eq :: refl_args, pred slift, (((Name id, appb, appt) :: argsign') :: arsigns)) | _ -> (* Non dependent inductive or not inductive, just use a regular equality *) let (name, b, typ) = match arsign with [x] -> x | _ -> assert(false) in let previd, id = make_prime avoid name in let arsign' = (Name id, b, typ) in let tomatch_ty = type_of_tomatch ty in let eq = mk_eq (lift nar tomatch_ty) (mkRel slift) (lift nar tm) in ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs, (mk_eq_refl tomatch_ty tm) :: refl_args, pred slift, (arsign' :: []) :: arsigns)) ([], 0, [], nar, []) tomatchs arsign in let arsign'' = List.rev arsign' in assert(slift = 0); (* we must have folded over all elements of the arity signature *) arsign'', allnames, nar, eqs, neqs, refls (**************************************************************************) (* Main entry of the matching compilation *) let liftn_rel_context n k sign = let rec liftrec k = function | (na,c,t)::sign -> (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) | [] -> [] in liftrec (k + rel_context_length sign) sign let nf_evars_env sigma (env : env) : env = let nf t = nf_evar sigma t in let env0 : env = reset_context env in let f e (na, b, t) e' : env = Environ.push_named (na, Option.map nf b, nf t) e' in let env' = Environ.fold_named_context f ~init:env0 env in Environ.fold_rel_context (fun e (na, b, t) e' -> Environ.push_rel (na, Option.map nf b, nf t) e') ~init:env' env let prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs sign tycon rtntyp = (* We extract the signature of the arity *) let arsign = extract_arity_signature env tomatchs sign in let newenv = List.fold_right push_rels arsign env in let allnames = List.rev (List.map (List.map pi1) arsign) in match rtntyp with | Some rtntyp -> let predcclj = typing_fun (mk_tycon (new_Type ())) newenv rtntyp in let predccl = (j_nf_evar !isevars predcclj).uj_val in Some (build_initial_predicate true allnames predccl) | None -> match valcon_of_tycon tycon with | Some ty -> let pred = prepare_predicate_from_arsign_tycon loc env !isevars tomatchs arsign ty in Some (build_initial_predicate true allnames pred) | None -> None let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns) = let typing_fun tycon env = typing_fun tycon env isevars in (* We build the matrix of patterns and right-hand side *) let matx = matx_of_eqns env eqns in (* We build the vector of terms to match consistently with the *) (* constructors found in patterns *) let tomatchs = coerce_to_indtype typing_fun isevars env matx tomatchl in let _isdep = List.exists (fun (x, y) -> is_dependent_ind y) tomatchs in if predopt = None then let tycon = valcon_of_tycon tycon in let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env tomatchs tycon in let env = push_rel_context tomatchs_lets env in let len = List.length eqns in let sign, allnames, signlen, eqs, neqs, args = (* The arity signature *) let arsign = extract_arity_signatures env tomatchs (List.map snd tomatchl) in (* Build the dependent arity signature, the equalities which makes the first part of the predicate and their instantiations. *) let avoid = [] in build_dependent_signature env ( !isevars) avoid tomatchs arsign in let tycon, arity = match tycon' with | None -> let ev = mkExistential env isevars in ev, ev | Some t -> Option.get tycon, prepare_predicate_from_arsign_tycon loc env ( !isevars) tomatchs sign t in let neqs, arity = let ctx = context_of_arsign eqs in let neqs = List.length ctx in neqs, it_mkProd_or_LetIn (lift neqs arity) ctx in let lets, matx = (* Type the rhs under the assumption of equations *) constrs_of_pats typing_fun env isevars matx tomatchs sign neqs arity in let matx = List.rev matx in let _ = assert(len = List.length lets) in let env = push_rels lets env in let matx = List.map (fun eqn -> { eqn with rhs = { eqn.rhs with rhs_env = env } }) matx in let tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in let args = List.rev_map (lift len) args in let pred = liftn len (succ signlen) arity in let pred = build_initial_predicate true allnames pred in (* We push the initial terms to match and push their alias to rhs' envs *) (* names of aliases will be recovered from patterns (hence Anonymous here) *) let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in let pb = { env = env; isevars = isevars; pred = Some pred; tomatch = initial_pushed; history = start_history (List.length initial_pushed); mat = matx; caseloc = loc; casestyle= style; typing_function = typing_fun } in let j = compile pb in (* We check for unused patterns *) List.iter (check_unused_pattern env) matx; let body = it_mkLambda_or_LetIn (applistc j.uj_val args) lets in let j = { uj_val = it_mkLambda_or_LetIn body tomatchs_lets; uj_type = nf_evar !isevars tycon; } in j else (* We build the elimination predicate if any and check its consistency *) (* with the type of arguments to match *) let tmsign = List.map snd tomatchl in let pred = prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs tmsign tycon predopt in (* We push the initial terms to match and push their alias to rhs' envs *) (* names of aliases will be recovered from patterns (hence Anonymous here) *) let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in let pb = { env = env; isevars = isevars; pred = pred; tomatch = initial_pushed; history = start_history (List.length initial_pushed); mat = matx; caseloc = loc; casestyle= style; typing_function = typing_fun } in let j = compile pb in (* We check for unused patterns *) List.iter (check_unused_pattern env) matx; inh_conv_coerce_to_tycon loc env isevars j tycon end coq-8.4pl4/plugins/subtac/subtac_cases.mli0000644000175000017500000000133612326224777017742 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Environ.env -> ('a * Term.constr option * Term.constr) list -> Topconstr.constr_expr list -> Term.constr list -> Term.constr list val new_instance : ?global:bool -> local_binder list -> typeclass_constraint -> constr_expr option -> ?generalize:bool -> int option -> identifier * Subtac_obligations.progress coq-8.4pl4/plugins/subtac/eterm.mli0000644000175000017500000000315012326224777016413 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr list val evar_dependencies : evar_map -> int -> Intset.t val sort_dependencies : (int * evar_info * Intset.t) list -> (int * evar_info * Intset.t) list (* env, id, evars, number of function prototypes to try to clear from evars contexts, object and type *) val eterm_obligations : env -> identifier -> evar_map -> evar_map -> int -> ?status:obligation_definition_status -> constr -> types -> (identifier * types * hole_kind located * obligation_definition_status * Intset.t * tactic option) array (* Existential key, obl. name, type as product, location of the original evar, associated tactic, status and dependencies as indexes into the array *) * ((existential_key * identifier) list * ((identifier -> constr) -> constr -> constr)) * constr * types (* Translations from existential identifiers to obligation identifiers and for terms with existentials to closed terms, given a translation from obligation identifiers to constrs, new term, new type *) coq-8.4pl4/plugins/subtac/subtac_pretyping_F.ml0000644000175000017500000005776512326224777021002 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* j | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc loc env) evdref j t let push_rels vars env = List.fold_right push_rel vars env (* let evar_type_case evdref env ct pt lft p c = let (mind,bty,rslty) = type_case_branches env ( evdref) ct pt p c in check_branches_message evdref env mind (c,ct) (bty,lft); (mind,rslty) *) let strip_meta id = (* For Grammar v7 compatibility *) let s = string_of_id id in if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1)) else id let invert_ltac_bound_name env id0 id = try mkRel (pi1 (Termops.lookup_rel_id id (rel_context env))) with Not_found -> errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++ str " depends on pattern variable name " ++ pr_id id ++ str " which is not bound in current context") let pretype_id loc env sigma (lvar,unbndltacvars) id = let id = strip_meta id in (* May happen in tactics defined by Grammar *) try let (n,_,typ) = Termops.lookup_rel_id id (rel_context env) in { uj_val = mkRel n; uj_type = lift n typ } with Not_found -> try let (ids,c) = List.assoc id lvar in let subst = List.map (invert_ltac_bound_name env id) ids in let c = substl subst c in { uj_val = c; uj_type = Retyping.get_type_of env sigma c } with Not_found -> try let (_,_,typ) = lookup_named id env in { uj_val = mkVar id; uj_type = typ } with Not_found -> try (* To build a nicer ltac error message *) match List.assoc id unbndltacvars with | None -> user_err_loc (loc,"", str "variable " ++ pr_id id ++ str " should be bound to a term") | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0 with Not_found -> error_var_not_found_loc loc id (* make a dependent predicate from an undependent one *) let make_dep_of_undep env (IndType (indf,realargs)) pj = let n = List.length realargs in let rec decomp n p = if n=0 then p else match kind_of_term p with | Lambda (_,_,c) -> decomp (n-1) c | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) in let sign,s = decompose_prod_n n pj.uj_type in let ind = build_dependent_inductive env indf in let s' = mkProd (Anonymous, ind, s) in let ccl = lift 1 (decomp n pj.uj_val) in let ccl' = mkLambda (Anonymous, ind, ccl) in {uj_val=Termops.it_mkLambda ccl' sign; uj_type=Termops.it_mkProd s' sign} (*************************************************************************) (* Main pretyping function *) let pretype_ref evdref env ref = let c = constr_of_global ref in make_judge c (Retyping.get_type_of env Evd.empty c) let pretype_sort evdref = function | GProp c -> judge_of_prop_contents c | GType _ -> evd_comb0 judge_of_new_Type evdref let split_tycon_lam loc env evd tycon = let rec real_split evd c = let t = whd_betadeltaiota env evd c in match kind_of_term t with | Prod (na,dom,rng) -> evd, (na, dom, rng) | Evar ev when not (Evd.is_defined_evar evd ev) -> let (evd',prod) = define_evar_as_product evd ev in let (_,dom,rng) = destProd prod in evd',(Anonymous, dom, rng) | _ -> error_not_product_loc loc env evd c in match tycon with | None -> evd,(Anonymous,None,None) | Some (abs, c) -> (match abs with | None -> let evd', (n, dom, rng) = real_split evd c in evd', (n, mk_tycon dom, mk_tycon rng) | Some (init, cur) -> evd, (Anonymous, None, Some (Some (init, succ cur), c))) (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *) (* in environment [env], with existential variables [( evdref)] and *) (* the type constraint tycon *) let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar c = (* let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_glob_constr env c ++ *) (* str " with tycon " ++ Evarutil.pr_tycon env tycon) *) (* with _ -> () *) (* in *) let pretype = pretype resolve_tc in let pretype_type = pretype_type resolve_tc in let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in match c with | GRef (loc,ref) -> inh_conv_coerce_to_tycon loc env evdref (pretype_ref evdref env ref) tycon | GVar (loc, id) -> inh_conv_coerce_to_tycon loc env evdref (pretype_id loc env !evdref lvar id) tycon | GEvar (loc, ev, instopt) -> (* Ne faudrait-il pas s'assurer que hyps est bien un sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *) let hyps = evar_context (Evd.find !evdref ev) in let args = match instopt with | None -> instance_from_named_context hyps | Some inst -> failwith "Evar subtitutions not implemented" in let c = mkEvar (ev, args) in let j = (Retyping.get_judgment_of env !evdref c) in inh_conv_coerce_to_tycon loc env evdref j tycon | GPatVar (loc,(someta,n)) -> anomaly "Found a pattern variable in a glob_constr to type" | GHole (loc,k) -> let ty = match tycon with | Some (None, ty) -> ty | None | Some _ -> e_new_evar evdref env ~src:(loc, InternalHole) (Termops.new_Type ()) in { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty } | GRec (loc,fixkind,names,bl,lar,vdef) -> let rec type_bl env ctxt = function [] -> ctxt | (na,k,None,ty)::bl -> let ty' = pretype_type empty_valcon env evdref lvar ty in let dcl = (na,None,ty'.utj_val) in type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl | (na,k,Some bd,ty)::bl -> let ty' = pretype_type empty_valcon env evdref lvar ty in let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar ty in let dcl = (na,Some bd'.uj_val,ty'.utj_val) in type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in let ctxtv = Array.map (type_bl env empty_rel_context) bl in let larj = array_map2 (fun e ar -> pretype_type empty_valcon (push_rel_context e env) evdref lvar ar) ctxtv lar in let lara = Array.map (fun a -> a.utj_val) larj in let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in let nbfix = Array.length lar in let names = Array.map (fun id -> Name id) names in (* Note: bodies are not used by push_rec_types, so [||] is safe *) let newenv = let marked_ftys = Array.map (fun ty -> let sort = Retyping.get_type_of env !evdref ty in mkApp (delayed_force Subtac_utils.fix_proto, [| sort; ty |])) ftys in push_rec_types (names,marked_ftys,[||]) env in let fixi = match fixkind with GFix (vn, i) -> i | GCoFix i -> i in let vdefj = array_map2_i (fun i ctxt def -> let fty = let ty = ftys.(i) in if i = fixi then ( Option.iter (fun tycon -> evdref := Coercion.inh_conv_coerces_to loc env !evdref ftys.(i) tycon) tycon; nf_evar !evdref ty) else ty in (* we lift nbfix times the type in tycon, because of * the nbfix variables pushed to newenv *) let (ctxt,ty) = decompose_prod_n_assum (rel_context_length ctxt) (lift nbfix fty) in let nenv = push_rel_context ctxt newenv in let j = pretype (mk_tycon ty) nenv evdref lvar def in { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) ctxtv vdef in evar_type_fixpoint loc env evdref names ftys vdefj; let ftys = Array.map (nf_evar !evdref) ftys in let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in let fixj = match fixkind with | GFix (vn,i) -> (* First, let's find the guard indexes. *) (* If recursive argument was not given by user, we try all args. An earlier approach was to look only for inductive arguments, but doing it properly involves delta-reduction, and it finally doesn't seem worth the effort (except for huge mutual fixpoints ?) *) let possible_indexes = Array.to_list (Array.mapi (fun i (n,_) -> match n with | Some n -> [n] | None -> list_map_i (fun i _ -> i) 0 ctxtv.(i)) vn) in let fixdecls = (names,ftys,fdefs) in let indexes = search_guard loc env possible_indexes fixdecls in make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) | GCoFix i -> let cofix = (i,(names,ftys,fdefs)) in (try check_cofix env cofix with e when Errors.noncritical e -> Loc.raise loc e); make_judge (mkCoFix cofix) ftys.(i) in inh_conv_coerce_to_tycon loc env evdref fixj tycon | GSort (loc,s) -> let s' = pretype_sort evdref s in inh_conv_coerce_to_tycon loc env evdref s' tycon | GApp (loc,f,args) -> let length = List.length args in let ftycon = let ty = if length > 0 then match tycon with | None -> None | Some (None, ty) -> mk_abstr_tycon length ty | Some (Some (init, cur), ty) -> Some (Some (length + init, length + cur), ty) else tycon in match ty with | Some (_, t) -> if Subtac_coercion.disc_subset (whd_betadeltaiota env !evdref t) = None then ty else None | _ -> None in let fj = pretype ftycon env evdref lvar f in let floc = loc_of_glob_constr f in let rec apply_rec env n resj tycon = function | [] -> resj | c::rest -> let argloc = loc_of_glob_constr c in let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env) evdref resj in let resty = whd_betadeltaiota env !evdref resj.uj_type in match kind_of_term resty with | Prod (na,c1,c2) -> Option.iter (fun ty -> evdref := Coercion.inh_conv_coerces_to loc env !evdref resty ty) tycon; let evd, (_, _, tycon) = split_tycon loc env !evdref tycon in evdref := evd; let hj = pretype (mk_tycon c1) env evdref lvar c in let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in apply_rec env (n+1) { uj_val = value; uj_type = typ } (Option.map (fun (abs, c) -> abs, c) tycon) rest | _ -> let hj = pretype empty_tycon env evdref lvar c in error_cant_apply_not_functional_loc (join_loc floc argloc) env !evdref resj [hj] in let resj = apply_rec env 1 fj ftycon args in let resj = match kind_of_term (whd_evar !evdref resj.uj_val) with | App (f,args) when isInd f or isConst f -> let sigma = !evdref in let c = mkApp (f,Array.map (whd_evar sigma) args) in let t = Retyping.get_type_of env sigma c in make_judge c t | _ -> resj in inh_conv_coerce_to_tycon loc env evdref resj tycon | GLambda(loc,name,k,c1,c2) -> let tycon' = evd_comb1 (fun evd tycon -> match tycon with | None -> evd, tycon | Some ty -> let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in evd, Some ty') evdref tycon in let (name',dom,rng) = evd_comb1 (split_tycon_lam loc env) evdref tycon' in let dom_valcon = valcon_of_tycon dom in let j = pretype_type dom_valcon env evdref lvar c1 in let var = (name,None,j.utj_val) in let j' = pretype rng (push_rel var env) evdref lvar c2 in let resj = judge_of_abstraction env name j j' in inh_conv_coerce_to_tycon loc env evdref resj tycon | GProd(loc,name,k,c1,c2) -> let j = pretype_type empty_valcon env evdref lvar c1 in let var = (name,j.utj_val) in let env' = Termops.push_rel_assum var env in let j' = pretype_type empty_valcon env' evdref lvar c2 in let resj = try judge_of_product env name j j' with TypeError _ as e -> Loc.raise loc e in inh_conv_coerce_to_tycon loc env evdref resj tycon | GLetIn(loc,name,c1,c2) -> let j = pretype empty_tycon env evdref lvar c1 in let t = Termops.refresh_universes j.uj_type in let var = (name,Some j.uj_val,t) in let tycon = lift_tycon 1 tycon in let j' = pretype tycon (push_rel var env) evdref lvar c2 in { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; uj_type = subst1 j.uj_val j'.uj_type } | GLetTuple (loc,nal,(na,po),c,d) -> let cj = pretype empty_tycon env evdref lvar c in let (IndType (indf,realargs)) = try find_rectype env !evdref cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in error_case_not_inductive_loc cloc env !evdref cj in let cstrs = get_constructors env indf in if Array.length cstrs <> 1 then user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor"); let cs = cstrs.(0) in if List.length nal <> cs.cs_nargs then user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables"); let fsign = List.map2 (fun na (_,c,t) -> (na,c,t)) (List.rev nal) cs.cs_args in let env_f = push_rels fsign env in (* Make dependencies from arity signature impossible *) let arsgn = let arsgn,_ = get_arity env indf in if not !allow_anonymous_refs then List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn else arsgn in let psign = (na,None,build_dependent_inductive env indf)::arsgn in let nar = List.length arsgn in (match po with | Some p -> let env_p = push_rels psign env in let pj = pretype_type empty_valcon env_p evdref lvar p in let ccl = nf_evar !evdref pj.utj_val in let psign = make_arity_signature env true indf in (* with names *) let p = it_mkLambda_or_LetIn ccl psign in let inst = (Array.to_list cs.cs_concl_realargs) @[build_dependent_constructor cs] in let lp = lift cs.cs_nargs p in let fty = hnf_lam_applist env !evdref lp inst in let fj = pretype (mk_tycon fty) env_f evdref lvar d in let f = it_mkLambda_or_LetIn fj.uj_val fsign in let v = let mis,_ = dest_ind_family indf in let ci = make_case_info env mis LetStyle in mkCase (ci, p, cj.uj_val,[|f|]) in { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } | None -> let tycon = lift_tycon cs.cs_nargs tycon in let fj = pretype tycon env_f evdref lvar d in let f = it_mkLambda_or_LetIn fj.uj_val fsign in let ccl = nf_evar !evdref fj.uj_type in let ccl = if noccur_between 1 cs.cs_nargs ccl then lift (- cs.cs_nargs) ccl else error_cant_find_case_type_loc loc env !evdref cj.uj_val in let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in let v = let mis,_ = dest_ind_family indf in let ci = make_case_info env mis LetStyle in mkCase (ci, p, cj.uj_val,[|f|] ) in { uj_val = v; uj_type = ccl }) | GIf (loc,c,(na,po),b1,b2) -> let cj = pretype empty_tycon env evdref lvar c in let (IndType (indf,realargs)) = try find_rectype env !evdref cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in error_case_not_inductive_loc cloc env !evdref cj in let cstrs = get_constructors env indf in if Array.length cstrs <> 2 then user_err_loc (loc,"", str "If is only for inductive types with two constructors."); let arsgn = let arsgn,_ = get_arity env indf in if not !allow_anonymous_refs then (* Make dependencies from arity signature impossible *) List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn else arsgn in let nar = List.length arsgn in let psign = (na,None,build_dependent_inductive env indf)::arsgn in let pred,p = match po with | Some p -> let env_p = push_rels psign env in let pj = pretype_type empty_valcon env_p evdref lvar p in let ccl = nf_evar !evdref pj.utj_val in let pred = it_mkLambda_or_LetIn ccl psign in let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in let jtyp = inh_conv_coerce_to_tycon loc env evdref {uj_val = pred; uj_type = typ} tycon in jtyp.uj_val, jtyp.uj_type | None -> let p = match tycon with | Some (None, ty) -> ty | None | Some _ -> e_new_evar evdref env ~src:(loc,InternalHole) (Termops.new_Type ()) in it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in let pred = nf_evar !evdref pred in let p = nf_evar !evdref p in let f cs b = let n = rel_context_length cs.cs_args in let pi = lift n pred in let pi = beta_applist (pi, [build_dependent_constructor cs]) in let csgn = if not !allow_anonymous_refs then List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args else List.map (fun (n, b, t) -> match n with Name _ -> (n, b, t) | Anonymous -> (Name (id_of_string "H"), b, t)) cs.cs_args in let env_c = push_rels csgn env in let bj = pretype (mk_tycon pi) env_c evdref lvar b in it_mkLambda_or_LetIn bj.uj_val cs.cs_args in let b1 = f cstrs.(0) b1 in let b2 = f cstrs.(1) b2 in let v = let mis,_ = dest_ind_family indf in let ci = make_case_info env mis IfStyle in mkCase (ci, pred, cj.uj_val, [|b1;b2|]) in { uj_val = v; uj_type = p } | GCases (loc,sty,po,tml,eqns) -> Cases.compile_cases loc sty ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref) tycon env (* loc *) (po,tml,eqns) | GCast (loc,c,k) -> let cj = match k with CastCoerce -> let cj = pretype empty_tycon env evdref lvar c in evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj | CastConv (k,t) -> let tj = pretype_type empty_valcon env evdref lvar t in let cj = pretype (mk_tycon tj.utj_val) env evdref lvar c in let v = mkCast (cj.uj_val, k, tj.utj_val) in { uj_val = v; uj_type = tj.utj_val } in inh_conv_coerce_to_tycon loc env evdref cj tycon (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *) and pretype_type resolve_tc valcon env evdref lvar = function | GHole loc -> (match valcon with | Some v -> let s = let sigma = !evdref in let t = Retyping.get_type_of env sigma v in match kind_of_term (whd_betadeltaiota env sigma t) with | Sort s -> s | Evar ev when is_Type (existential_type sigma ev) -> evd_comb1 (define_evar_as_sort) evdref ev | _ -> anomaly "Found a type constraint which is not a type" in { utj_val = v; utj_type = s } | None -> let s = Termops.new_Type_sort () in { utj_val = e_new_evar evdref env ~src:loc (mkSort s); utj_type = s}) | c -> let j = pretype resolve_tc empty_tycon env evdref lvar c in let loc = loc_of_glob_constr c in let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) evdref j in match valcon with | None -> tj | Some v -> if e_cumul env evdref v tj.utj_val then tj else error_unexpected_type_loc (loc_of_glob_constr c) env !evdref tj.utj_val v let pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c = let c' = match kind with | OfType exptyp -> let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in (pretype resolve_classes tycon env evdref lvar c).uj_val | IsType -> (pretype_type resolve_classes empty_valcon env evdref lvar c).utj_val in if resolve_classes then (try evdref := Typeclasses.resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~split:true ~fail:true env !evdref; evdref := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~split:true ~fail:false env !evdref with e when Errors.noncritical e -> if fail_evar then raise e else ()); evdref := consider_remaining_unif_problems env !evdref; let c = if expand_evar then nf_evar !evdref c' else c' in if fail_evar then check_evars env Evd.empty !evdref c; c (* TODO: comment faire remonter l'information si le typage a resolu des variables du sigma original. il faudrait que la fonction de typage retourne aussi le nouveau sigma... *) let understand_judgment sigma env c = let evdref = ref (create_evar_defs sigma) in let j = pretype true empty_tycon env evdref ([],[]) c in let evd = consider_remaining_unif_problems env !evdref in let j = j_nf_evar evd j in check_evars env sigma evd (mkCast(j.uj_val,DEFAULTcast, j.uj_type)); j let understand_judgment_tcc evdref env c = let j = pretype true empty_tycon env evdref ([],[]) c in j_nf_evar !evdref j (* Raw calls to the unsafe inference machine: boolean says if we must fail on unresolved evars; the unsafe_judgment list allows us to extend env with some bindings *) let ise_pretype_gen expand_evar fail_evar resolve_classes sigma env lvar kind c = let evdref = ref (Evd.create_evar_defs sigma) in let c = pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c in !evdref, c (** Entry points of the high-level type synthesis algorithm *) let understand_gen kind sigma env c = snd (ise_pretype_gen true true true sigma env ([],[]) kind c) let understand sigma env ?expected_type:exptyp c = snd (ise_pretype_gen true true true sigma env ([],[]) (OfType exptyp) c) let understand_type sigma env c = snd (ise_pretype_gen true false true sigma env ([],[]) IsType c) let understand_ltac ?(resolve_classes=false) expand_evar sigma env lvar kind c = ise_pretype_gen expand_evar false resolve_classes sigma env lvar kind c let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c = ise_pretype_gen true false resolve_classes sigma env ([],[]) (OfType exptyp) c let understand_tcc_evars ?(fail_evar=false) ?(resolve_classes=true) evdref env kind c = pretype_gen true fail_evar resolve_classes evdref env ([],[]) kind c end module Default : S = SubtacPretyping_F(Coercion.Default) coq-8.4pl4/plugins/subtac/subtac_coercion.mli0000644000175000017500000000013212326224777020436 0ustar stephstephopen Term val disc_subset : types -> (types * types) option module Coercion : Coercion.S coq-8.4pl4/plugins/subtac/subtac_coercion.ml0000644000175000017500000004046512326224777020302 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (match kind_of_term c with Ind i -> let len = Array.length l in let sig_ = delayed_force sig_ in if len = 2 && i = Term.destInd sig_.typ then let (a, b) = pair_of_array l in Some (a, b) else None | _ -> None) | _ -> None and disc_exist env x = match kind_of_term x with | App (c, l) -> (match kind_of_term c with Construct c -> if c = Term.destConstruct (delayed_force sig_).intro then Some (l.(0), l.(1), l.(2), l.(3)) else None | _ -> None) | _ -> None module Coercion = struct exception NoSubtacCoercion let disc_proj_exist env x = match kind_of_term x with | App (c, l) -> (if Term.eq_constr c (delayed_force sig_).proj1 && Array.length l = 3 then disc_exist env l.(2) else None) | _ -> None let sort_rel s1 s2 = match s1, s2 with Prop Pos, Prop Pos -> Prop Pos | Prop Pos, Prop Null -> Prop Null | Prop Null, Prop Null -> Prop Null | Prop Null, Prop Pos -> Prop Pos | Type _, Prop Pos -> Prop Pos | Type _, Prop Null -> Prop Null | _, Type _ -> s2 let hnf env isevars c = whd_betadeltaiota env isevars c let hnf_nodelta env evars c = whd_betaiota evars c let lift_args n sign = let rec liftrec k = function | t::sign -> liftn n k t :: (liftrec (k-1) sign) | [] -> [] in liftrec (List.length sign) sign let rec mu env isevars t = let rec aux v = let v = hnf env !isevars v in match disc_subset v with Some (u, p) -> let f, ct = aux u in let p = hnf env !isevars p in (Some (fun x -> app_opt env isevars f (mkApp ((delayed_force sig_).proj1, [| u; p; x |]))), ct) | None -> (None, v) in aux t and coerce loc env isevars (x : Term.constr) (y : Term.constr) : (Term.constr -> Term.constr) option = let rec coerce_unify env x y = let x = hnf env !isevars x and y = hnf env !isevars y in try isevars := the_conv_x_leq env x y !isevars; None with Reduction.NotConvertible -> coerce' env x y and coerce' env x y : (Term.constr -> Term.constr) option = let subco () = subset_coerce env isevars x y in let dest_prod c = match Reductionops.splay_prod_n env ( !isevars) 1 c with | [(na,b,t)], c -> (na,t), c | _ -> raise NoSubtacCoercion in let rec coerce_application typ typ' c c' l l' = let len = Array.length l in let rec aux tele typ typ' i co = if i < len then let hdx = l.(i) and hdy = l'.(i) in try isevars := the_conv_x_leq env hdx hdy !isevars; let (n, eqT), restT = dest_prod typ in let (n', eqT'), restT' = dest_prod typ' in aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co with Reduction.NotConvertible -> let (n, eqT), restT = dest_prod typ in let (n', eqT'), restT' = dest_prod typ' in let _ = try isevars := the_conv_x_leq env eqT eqT' !isevars with Reduction.NotConvertible -> raise NoSubtacCoercion in (* Disallow equalities on arities *) if Reduction.is_arity env eqT then raise NoSubtacCoercion; let restargs = lift_args 1 (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i))))) in let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in let eq = mkApp (delayed_force eq_ind, [| eqT; hdx; hdy |]) in let evar = make_existential loc env isevars eq in let eq_app x = mkApp (delayed_force eq_rect, [| eqT; hdx; pred; x; hdy; evar|]) in aux (hdy :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) (fun x -> eq_app (co x)) else Some co in if isEvar c || isEvar c' then (* Second-order unification needed. *) raise NoSubtacCoercion; aux [] typ typ' 0 (fun x -> x) in match (kind_of_term x, kind_of_term y) with | Sort s, Sort s' -> (match s, s' with Prop x, Prop y when x = y -> None | Prop _, Type _ -> None | Type x, Type y when x = y -> None (* false *) | _ -> subco ()) | Prod (name, a, b), Prod (name', a', b') -> let name' = Name (Namegen.next_ident_away (id_of_string "x") (Termops.ids_of_context env)) in let env' = push_rel (name', None, a') env in let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in (* env, x : a' |- c1 : lift 1 a' > lift 1 a *) let coec1 = app_opt env' isevars c1 (mkRel 1) in (* env, x : a' |- c1[x] : lift 1 a *) let c2 = coerce_unify env' (subst1 coec1 (liftn 1 2 b)) b' in (* env, x : a' |- c2 : b[c1[x]/x]] > b' *) (match c1, c2 with | None, None -> None | _, _ -> Some (fun f -> mkLambda (name', a', app_opt env' isevars c2 (mkApp (Term.lift 1 f, [| coec1 |]))))) | App (c, l), App (c', l') -> (match kind_of_term c, kind_of_term c' with Ind i, Ind i' -> (* Inductive types *) let len = Array.length l in let existS = delayed_force existS in let prod = delayed_force prod in (* Sigma types *) if len = Array.length l' && len = 2 && i = i' && (i = Term.destInd existS.typ || i = Term.destInd prod.typ) then if i = Term.destInd existS.typ then begin let (a, pb), (a', pb') = pair_of_array l, pair_of_array l' in let c1 = coerce_unify env a a' in let rec remove_head a c = match kind_of_term c with | Lambda (n, t, t') -> c, t' (*| Prod (n, t, t') -> t'*) | Evar (k, args) -> let (evs, t) = Evarutil.define_evar_as_lambda env !isevars (k,args) in isevars := evs; let (n, dom, rng) = destLambda t in let (domk, args) = destEvar dom in isevars := define domk a !isevars; t, rng | _ -> raise NoSubtacCoercion in let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in let env' = push_rel (make_name "x", None, a) env in let c2 = coerce_unify env' b b' in match c1, c2 with None, None -> None | _, _ -> Some (fun x -> let x, y = app_opt env' isevars c1 (mkApp (existS.proj1, [| a; pb; x |])), app_opt env' isevars c2 (mkApp (existS.proj2, [| a; pb; x |])) in mkApp (existS.intro, [| a'; pb'; x ; y |])) end else begin let (a, b), (a', b') = pair_of_array l, pair_of_array l' in let c1 = coerce_unify env a a' in let c2 = coerce_unify env b b' in match c1, c2 with None, None -> None | _, _ -> Some (fun x -> let x, y = app_opt env isevars c1 (mkApp (prod.proj1, [| a; b; x |])), app_opt env isevars c2 (mkApp (prod.proj2, [| a; b; x |])) in mkApp (prod.intro, [| a'; b'; x ; y |])) end else if i = i' && len = Array.length l' then let evm = !isevars in (try subco () with NoSubtacCoercion -> let typ = Typing.type_of env evm c in let typ' = Typing.type_of env evm c' in (* if not (is_arity env evm typ) then *) coerce_application typ typ' c c' l l') (* else subco () *) else subco () | x, y when x = y -> if Array.length l = Array.length l' then let evm = !isevars in let lam_type = Typing.type_of env evm c in let lam_type' = Typing.type_of env evm c' in (* if not (is_arity env evm lam_type) then ( *) coerce_application lam_type lam_type' c c' l l' (* ) else subco () *) else subco () | _ -> subco ()) | _, _ -> subco () and subset_coerce env isevars x y = match disc_subset x with Some (u, p) -> let c = coerce_unify env u y in let f x = app_opt env isevars c (mkApp ((delayed_force sig_).proj1, [| u; p; x |])) in Some f | None -> match disc_subset y with Some (u, p) -> let c = coerce_unify env x u in Some (fun x -> let cx = app_opt env isevars c x in let evar = make_existential loc env isevars (mkApp (p, [| cx |])) in (mkApp ((delayed_force sig_).intro, [| u; p; cx; evar |]))) | None -> raise NoSubtacCoercion (*isevars := Evd.add_conv_pb (Reduction.CONV, x, y) !isevars; None*) in coerce_unify env x y let coerce_itf loc env isevars v t c1 = let evars = ref isevars in let coercion = coerce loc env evars t c1 in let t = Option.map (app_opt env evars coercion) v in !evars, t (* Taken from pretyping/coercion.ml *) (* Typing operations dealing with coercions *) (* Here, funj is a coercion therefore already typed in global context *) let apply_coercion_args env argl funj = let rec apply_rec acc typ = function | [] -> { uj_val = applist (j_val funj,argl); uj_type = typ } | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *) match kind_of_term (whd_betadeltaiota env Evd.empty typ) with | Prod (_,c1,c2) -> (* Typage garanti par l'appel à app_coercion*) apply_rec (h::acc) (subst1 h c2) restl | _ -> anomaly "apply_coercion_args" in apply_rec [] funj.uj_type argl (* appliquer le chemin de coercions de patterns p *) exception NoCoercion let apply_pattern_coercion loc pat p = List.fold_left (fun pat (co,n) -> let f i = if i let fv,isid = coercion_value i in let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in let jres = apply_coercion_args env argl fv in (if isid then { uj_val = ja.uj_val; uj_type = jres.uj_type } else jres), jres.uj_type) (hj,typ_cl) p) with e when Errors.noncritical e -> anomaly "apply_coercion" let inh_app_fun _ env isevars j = let isevars = ref isevars in let t = hnf env !isevars j.uj_type in match kind_of_term t with | Prod (_,_,_) -> (!isevars,j) | Evar ev when not (is_defined_evar !isevars ev) -> let (isevars',t) = define_evar_as_product !isevars ev in (isevars',{ uj_val = j.uj_val; uj_type = t }) | _ -> (try let t,p = lookup_path_to_fun_from env !isevars j.uj_type in (!isevars,apply_coercion env !isevars p j t) with Not_found -> try let coercef, t = mu env isevars t in let res = { uj_val = app_opt env isevars coercef j.uj_val; uj_type = t } in (!isevars, res) with NoSubtacCoercion | NoCoercion -> (!isevars,j)) let inh_tosort_force loc env isevars j = try let t,p = lookup_path_to_sort_from env ( isevars) j.uj_type in let j1 = apply_coercion env ( isevars) p j t in (isevars, type_judgment env (j_nf_evar ( isevars) j1)) with Not_found -> error_not_a_type_loc loc env ( isevars) j let inh_coerce_to_sort loc env isevars j = let typ = hnf env isevars j.uj_type in match kind_of_term typ with | Sort s -> (isevars,{ utj_val = j.uj_val; utj_type = s }) | Evar ev when not (is_defined_evar isevars ev) -> let (isevars',s) = define_evar_as_sort isevars ev in (isevars',{ utj_val = j.uj_val; utj_type = s }) | _ -> inh_tosort_force loc env isevars j let inh_coerce_to_base loc env isevars j = let isevars = ref isevars in let typ = hnf env !isevars j.uj_type in let ct, typ' = mu env isevars typ in let res = { uj_val = app_opt env isevars ct j.uj_val; uj_type = typ' } in !isevars, res let inh_coerce_to_prod loc env isevars t = let isevars = ref isevars in let typ = hnf env !isevars (snd t) in let _, typ' = mu env isevars typ in !isevars, (fst t, typ') let inh_coerce_to_fail env evd rigidonly v t c1 = if rigidonly & not (Heads.is_rigid env c1 && Heads.is_rigid env t) then raise NoCoercion else let v', t' = try let t2,t1,p = lookup_path_between env evd (t,c1) in match v with Some v -> let j = apply_coercion env evd p {uj_val = v; uj_type = t} t2 in Some j.uj_val, j.uj_type | None -> None, t with Not_found -> raise NoCoercion in try (the_conv_x_leq env t' c1 evd, v') with Reduction.NotConvertible -> raise NoCoercion let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = try (the_conv_x_leq env t c1 evd, v) with Reduction.NotConvertible -> try inh_coerce_to_fail env evd rigidonly v t c1 with NoCoercion -> match kind_of_term (whd_betadeltaiota env evd t), kind_of_term (whd_betadeltaiota env evd c1) with | Prod (name,t1,t2), Prod (_,u1,u2) -> (* Conversion did not work, we may succeed with a coercion. *) (* We eta-expand (hence possibly modifying the original term!) *) (* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *) (* has type forall (x:u1), u2 (with v' recursively obtained) *) let name = match name with | Anonymous -> Name (id_of_string "x") | _ -> name in let env1 = push_rel (name,None,u1) env in let (evd', v1) = inh_conv_coerce_to_fail loc env1 evd rigidonly (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in let v1 = Option.get v1 in let v2 = Option.map (fun v -> beta_applist (lift 1 v,[v1])) v in let t2 = Termops.subst_term v1 t2 in let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') | _ -> raise NoCoercion (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) let inh_conv_coerce_to_gen rigidonly loc env evd cj ((n, t) as _tycon) = match n with | None -> let cj = { cj with uj_type = hnf_nodelta env evd cj.uj_type } and t = hnf_nodelta env evd t in let (evd', val') = try inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t with NoCoercion -> (try coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t with NoSubtacCoercion -> error_actual_type_loc loc env evd cj t) in let val' = match val' with Some v -> v | None -> assert(false) in (evd',{ uj_val = val'; uj_type = t }) | Some (init, cur) -> (evd, cj) let inh_conv_coerce_to _ = inh_conv_coerce_to_gen false let inh_conv_coerce_rigid_to _ = inh_conv_coerce_to_gen true let inh_conv_coerces_to loc env isevars t ((abs, t') as _tycon) = let nabsinit, nabs = match abs with None -> 0, 0 | Some (init, cur) -> init, cur in try let rels, rng = Reductionops.splay_prod_n env ( isevars) nabs t in (* The final range free variables must have been replaced by evars, we accept only that evars in rng are applied to free vars. *) if noccur_with_meta 1 (succ nabs) rng then ( let env', t, t' = let env' = push_rel_context rels env in env', rng, lift nabs t' in try fst (try inh_conv_coerce_to_fail loc env' isevars false None t t' with NoCoercion -> coerce_itf loc env' isevars None t t') with NoSubtacCoercion -> error_cannot_coerce env' isevars (t, t')) else isevars with e when Errors.noncritical e -> isevars end coq-8.4pl4/plugins/subtac/eterm.ml0000644000175000017500000002043212326224777016244 0ustar stephsteph(** - Get types of existentials ; - Flatten dependency tree (prefix order) ; - Replace existentials by De Bruijn indices in term, applied to the right arguments ; - Apply term prefixed by quantification on "existentials". *) open Term open Sign open Names open Evd open List open Pp open Util open Subtac_utils open Proof_type let trace s = if !Flags.debug then (msgnl s; msgerr s) else () let succfix (depth, fixrels) = (succ depth, List.map succ fixrels) type oblinfo = { ev_name: int * identifier; ev_hyps: named_context; ev_status: obligation_definition_status; ev_chop: int option; ev_src: hole_kind located; ev_typ: types; ev_tac: tactic option; ev_deps: Intset.t } (* spiwack: Store field for internalizing ev_tac in evar_infos' evar_extra. *) open Store.Field let evar_tactic = Store.field () (** Substitute evar references in t using De Bruijn indices, where n binders were passed through. *) let subst_evar_constr evs n idf t = let seen = ref Intset.empty in let transparent = ref Idset.empty in let evar_info id = List.assoc id evs in let rec substrec (depth, fixrels) c = match kind_of_term c with | Evar (k, args) -> let { ev_name = (id, idstr) ; ev_hyps = hyps ; ev_chop = chop } = try evar_info k with Not_found -> anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found") in seen := Intset.add id !seen; (* Evar arguments are created in inverse order, and we must not apply to defined ones (i.e. LetIn's) *) let args = let n = match chop with None -> 0 | Some c -> c in let (l, r) = list_chop n (List.rev (Array.to_list args)) in List.rev r in let args = let rec aux hyps args acc = match hyps, args with ((_, None, _) :: tlh), (c :: tla) -> aux tlh tla ((substrec (depth, fixrels) c) :: acc) | ((_, Some _, _) :: tlh), (_ :: tla) -> aux tlh tla acc | [], [] -> acc | _, _ -> acc (*failwith "subst_evars: invalid argument"*) in aux hyps args [] in if List.exists (fun x -> match kind_of_term x with Rel n -> List.mem n fixrels | _ -> false) args then transparent := Idset.add idstr !transparent; mkApp (idf idstr, Array.of_list args) | Fix _ -> map_constr_with_binders succfix substrec (depth, 1 :: fixrels) c | _ -> map_constr_with_binders succfix substrec (depth, fixrels) c in let t' = substrec (0, []) t in t', !seen, !transparent (** Substitute variable references in t using De Bruijn indices, where n binders were passed through. *) let subst_vars acc n t = let var_index id = Util.list_index id acc in let rec substrec depth c = match kind_of_term c with | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c) | _ -> map_constr_with_binders succ substrec depth c in substrec 0 t (** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ]) to a product : forall H1 : t1, ..., forall Hn : tn, concl. Changes evars and hypothesis references to variable references. *) let etype_of_evar evs hyps concl = let rec aux acc n = function (id, copt, t) :: tl -> let t', s, trans = subst_evar_constr evs n mkVar t in let t'' = subst_vars acc 0 t' in let rest, s', trans' = aux (id :: acc) (succ n) tl in let s' = Intset.union s s' in let trans' = Idset.union trans trans' in (match copt with Some c -> let c', s'', trans'' = subst_evar_constr evs n mkVar c in let c' = subst_vars acc 0 c' in mkNamedProd_or_LetIn (id, Some c', t'') rest, Intset.union s'' s', Idset.union trans'' trans' | None -> mkNamedProd_or_LetIn (id, None, t'') rest, s', trans') | [] -> let t', s, trans = subst_evar_constr evs n mkVar concl in subst_vars acc 0 t', s, trans in aux [] 0 (rev hyps) open Tacticals let trunc_named_context n ctx = let len = List.length ctx in list_firstn (len - n) ctx let rec chop_product n t = if n = 0 then Some t else match kind_of_term t with | Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None | _ -> None let evars_of_evar_info evi = Intset.union (Evarutil.evars_of_term evi.evar_concl) (Intset.union (match evi.evar_body with | Evar_empty -> Intset.empty | Evar_defined b -> Evarutil.evars_of_term b) (Evarutil.evars_of_named_context (evar_filtered_context evi))) let evar_dependencies evm oev = let one_step deps = Intset.fold (fun ev s -> let evi = Evd.find evm ev in let deps' = evars_of_evar_info evi in if Intset.mem oev deps' then raise (Invalid_argument ("Ill-formed evar map: cycle detected for evar " ^ string_of_int oev)) else Intset.union deps' s) deps deps in let rec aux deps = let deps' = one_step deps in if Intset.equal deps deps' then deps else aux deps' in aux (Intset.singleton oev) let move_after (id, ev, deps as obl) l = let rec aux restdeps = function | (id', _, _) as obl' :: tl -> let restdeps' = Intset.remove id' restdeps in if Intset.is_empty restdeps' then obl' :: obl :: tl else obl' :: aux restdeps' tl | [] -> [obl] in aux (Intset.remove id deps) l let sort_dependencies evl = let rec aux l found list = match l with | (id, ev, deps) as obl :: tl -> let found' = Intset.union found (Intset.singleton id) in if Intset.subset deps found' then aux tl found' (obl :: list) else aux (move_after obl tl) found list | [] -> List.rev list in aux evl Intset.empty [] let map_evar_body f = function | Evar_empty -> Evar_empty | Evar_defined c -> Evar_defined (f c) open Environ let map_evar_info f evi = { evi with evar_hyps = val_of_named_context (map_named_context f (named_context_of_val evi.evar_hyps)); evar_concl = f evi.evar_concl; evar_body = map_evar_body f evi.evar_body } let eterm_obligations env name isevars evm fs ?status t ty = (* 'Serialize' the evars *) let nc = Environ.named_context env in let nc_len = Sign.named_context_length nc in let evl = List.rev (to_list evm) in let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in let sevl = sort_dependencies evl in let evl = List.map (fun (id, ev, _) -> id, ev) sevl in let evn = let i = ref (-1) in List.rev_map (fun (id, ev) -> incr i; (id, (!i, id_of_string (string_of_id name ^ "_obligation_" ^ string_of_int (succ !i))), ev)) evl in let evts = (* Remove existential variables in types and build the corresponding products *) fold_right (fun (id, (n, nstr), ev) l -> let hyps = Evd.evar_filtered_context ev in let hyps = trunc_named_context nc_len hyps in let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in let evtyp, hyps, chop = match chop_product fs evtyp with | Some t -> t, trunc_named_context fs hyps, fs | None -> evtyp, hyps, 0 in let loc, k = evar_source id isevars in let status = match k with QuestionMark o -> Some o | _ -> status in let status, chop = match status with | Some (Define true as stat) -> if chop <> fs then Define false, None else stat, Some chop | Some s -> s, None | None -> Define true, None in let tac = match evar_tactic.get ev.evar_extra with | Some t -> if Dyn.tag t = "tactic" then Some (Tacinterp.interp (Tacinterp.globTacticIn (Tacinterp.tactic_out t))) else None | None -> None in let info = { ev_name = (n, nstr); ev_hyps = hyps; ev_status = status; ev_chop = chop; ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = tac } in (id, info) :: l) evn [] in let t', _, transparent = (* Substitute evar refs in the term by variables *) subst_evar_constr evts 0 mkVar t in let ty, _, _ = subst_evar_constr evts 0 mkVar ty in let evars = List.map (fun (ev, info) -> let { ev_name = (_, name); ev_status = status; ev_src = src; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info in let status = match status with | Define true when Idset.mem name transparent -> Define false | _ -> status in name, typ, src, status, deps, tac) evts in let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in let evmap f c = pi1 (subst_evar_constr evts 0 f c) in Array.of_list (List.rev evars), (evnames, evmap), t', ty let mkMetas n = list_tabulate (fun _ -> Evarutil.mk_new_meta ()) n coq-8.4pl4/plugins/subtac/subtac_command.mli0000644000175000017500000000274312326224777020265 0ustar stephstephopen Pretyping open Evd open Environ open Term open Topconstr open Names open Libnames open Pp open Vernacexpr open Constrintern val interp_gen : typing_constraint -> evar_map ref -> env -> ?impls:internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign -> constr_expr -> constr val interp_constr : evar_map ref -> env -> constr_expr -> constr val interp_type_evars : evar_map ref -> env -> ?impls:internalization_env -> constr_expr -> constr val interp_casted_constr_evars : evar_map ref -> env -> ?impls:internalization_env -> constr_expr -> types -> constr val interp_open_constr : evar_map ref -> env -> constr_expr -> constr val interp_constr_judgment : evar_map ref -> env -> constr_expr -> unsafe_judgment val list_chop_hd : int -> 'a list -> 'a list * 'a * 'a list val interp_binder : Evd.evar_map ref -> Environ.env -> Names.name -> Topconstr.constr_expr -> Term.constr val telescope : (Names.name * Term.types option * Term.types) list -> Term.types * (Names.name * Term.types option * Term.types) list * Term.constr val build_wellfounded : Names.identifier * 'a * Topconstr.local_binder list * Topconstr.constr_expr * Topconstr.constr_expr -> Topconstr.constr_expr -> Topconstr.constr_expr -> 'b -> Subtac_obligations.progress val build_recursive : (fixpoint_expr * decl_notation list) list -> unit val build_corecursive : (cofixpoint_expr * decl_notation list) list -> unit coq-8.4pl4/plugins/subtac/subtac_errors.ml0000644000175000017500000000121212326224777020000 0ustar stephstephopen Util open Pp open Printer type term_pp = Pp.std_ppcmds type subtyping_error = | UncoercibleInferType of loc * term_pp * term_pp | UncoercibleInferTerm of loc * term_pp * term_pp * term_pp * term_pp | UncoercibleRewrite of term_pp * term_pp type typing_error = | NonFunctionalApp of loc * term_pp * term_pp * term_pp | NonConvertible of loc * term_pp * term_pp | NonSigma of loc * term_pp | IllSorted of loc * term_pp exception Subtyping_error of subtyping_error exception Typing_error of typing_error exception Debug_msg of string let typing_error e = raise (Typing_error e) let subtyping_error e = raise (Subtyping_error e) coq-8.4pl4/plugins/subtac/subtac.ml0000644000175000017500000001730312326224777016414 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constant_value (Global.env()) (match cst with ConstRef kn -> kn | _ -> assert false) | _ -> errorlabstrm "start_proof" (str "The statement obligations could not be resolved automatically, " ++ spc () ++ str "write a statement definition first.") else let _ = Typeops.infer_type env c in c let start_proof_com env isevars sopt kind (bl,t) hook = let id = match sopt with | Some (loc,id) -> (* We check existence here: it's a bit late at Qed time *) if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then user_err_loc (loc,"start_proof",pr_id id ++ str " already exists"); id | None -> next_global_ident_away (id_of_string "Unnamed_thm") (Pfedit.get_all_proof_names ()) in let evm, c, typ, imps = Subtac_pretyping.subtac_process ~is_type:true env isevars id [] (Topconstr.prod_constr_expr t bl) None in let c = solve_tccs_in_type env id isevars evm c typ in Lemmas.start_proof id kind c (fun loc gr -> Impargs.declare_manual_implicits (loc = Local) gr ~enriching:true [imps]; hook loc gr) let start_proof_and_print env isevars idopt k t hook = start_proof_com env isevars idopt k t hook; Vernacentries.print_subgoals () let _ = Detyping.set_detype_anonymous (fun loc n -> GVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n))) let assumption_message id = Flags.if_verbose message ((string_of_id id) ^ " is assumed") let declare_assumptions env isevars idl is_coe k bl c nl = if not (Pfedit.refining ()) then let id = snd (List.hd idl) in let evm, c, typ, imps = Subtac_pretyping.subtac_process env isevars id [] (Topconstr.prod_constr_expr c bl) None in let c = solve_tccs_in_type env id isevars evm c typ in List.iter (Command.declare_assumption is_coe k c imps false nl) idl else errorlabstrm "Command.Assumption" (str "Cannot declare an assumption while in proof editing mode.") let dump_constraint ty ((loc, n), _, _) = match n with | Name id -> Dumpglob.dump_definition (loc, id) false ty | Anonymous -> () let dump_variable lid = () let vernac_assumption env isevars kind l nl = let global = fst kind = Global in List.iter (fun (is_coe,(idl,c)) -> if Dumpglob.dump () then List.iter (fun lid -> if global then Dumpglob.dump_definition lid (not global) "ax" else dump_variable lid) idl; declare_assumptions env isevars idl is_coe kind [] c nl) l let check_fresh (loc,id) = if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then user_err_loc (loc,"",pr_id id ++ str " already exists") let subtac (loc, command) = check_required_library ["Coq";"Init";"Datatypes"]; check_required_library ["Coq";"Init";"Specif"]; let env = Global.env () in let isevars = ref (create_evar_defs Evd.empty) in try match command with | VernacDefinition (defkind, (_, id as lid), expr, hook) -> check_fresh lid; Dumpglob.dump_definition lid false "def"; (match expr with | ProveBody (bl, t) -> start_proof_and_print env isevars (Some lid) (Global, DefinitionBody Definition) (bl,t) (fun _ _ -> ()) | DefineBody (bl, _, c, tycon) -> ignore(Subtac_pretyping.subtac_proof defkind hook env isevars id bl c tycon)) | VernacFixpoint l -> List.iter (fun ((lid, _, _, _, _), _) -> check_fresh lid; Dumpglob.dump_definition lid false "fix") l; let _ = trace (str "Building fixpoint") in ignore(Subtac_command.build_recursive l) | VernacStartTheoremProof (thkind, [Some id, (bl,t,guard)], lettop, hook) -> if guard <> None then error "Do not support building theorems as a fixpoint."; Dumpglob.dump_definition id false "prf"; if not(Pfedit.refining ()) then if lettop then errorlabstrm "Subtac_command.StartProof" (str "Let declarations can only be used in proof editing mode"); if Lib.is_modtype () then errorlabstrm "Subtac_command.StartProof" (str "Proof editing mode not supported in module types"); check_fresh id; start_proof_and_print env isevars (Some id) (Global, Proof thkind) (bl,t) hook | VernacAssumption (stre,nl,l) -> vernac_assumption env isevars stre l nl | VernacInstance (abst, glob, sup, is, props, pri) -> dump_constraint "inst" is; if abst then error "Declare Instance not supported here."; ignore(Subtac_classes.new_instance ~global:glob sup is props pri) | VernacCoFixpoint l -> if Dumpglob.dump () then List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "cofix") l; ignore(Subtac_command.build_corecursive l) (*| VernacEndProof e -> subtac_end_proof e*) | _ -> user_err_loc (loc,"", str ("Invalid Program command")) with | Typing_error e -> msg_warning (str "Type error in Program tactic:"); let cmds = (match e with | NonFunctionalApp (loc, x, mux, e) -> str "non functional application of term " ++ e ++ str " to function " ++ x ++ str " of (mu) type " ++ mux | NonSigma (loc, t) -> str "Term is not of Sigma type: " ++ t | NonConvertible (loc, x, y) -> str "Unconvertible terms:" ++ spc () ++ x ++ spc () ++ str "and" ++ spc () ++ y | IllSorted (loc, t) -> str "Term is ill-sorted:" ++ spc () ++ t ) in msg_warning cmds | Subtyping_error e -> msg_warning (str "(Program tactic) Subtyping error:"); let cmds = match e with | UncoercibleInferType (loc, x, y) -> str "Uncoercible terms:" ++ spc () ++ x ++ spc () ++ str "and" ++ spc () ++ y | UncoercibleInferTerm (loc, x, y, tx, ty) -> str "Uncoercible terms:" ++ spc () ++ tx ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ x ++ str "and" ++ spc() ++ ty ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ y | UncoercibleRewrite (x, y) -> str "Uncoercible terms:" ++ spc () ++ x ++ spc () ++ str "and" ++ spc () ++ y in msg_warning cmds | Cases.PatternMatchingError (env, exn) as e -> raise e | Type_errors.TypeError (env, exn) as e -> raise e | Pretype_errors.PretypeError (env, _, exn) as e -> raise e | (Loc.Exc_located (loc, Proof_type.LtacLocated (_,e')) | Loc.Exc_located (loc, e') as e) -> raise e | reraise -> (* msg_warning (str "Uncaught exception: " ++ Errors.print e); *) raise reraise coq-8.4pl4/plugins/subtac/subtac_pretyping.mli0000644000175000017500000000126012326224777020661 0ustar stephstephopen Term open Environ open Names open Sign open Evd open Global open Topconstr open Implicit_quantifiers open Impargs module Pretyping : Pretyping.S val interp : Environ.env -> Evd.evar_map ref -> Glob_term.glob_constr -> Evarutil.type_constraint -> Term.constr * Term.constr val subtac_process : ?is_type:bool -> env -> evar_map ref -> identifier -> local_binder list -> constr_expr -> constr_expr option -> evar_map * constr * types * manual_explicitation list val subtac_proof : Decl_kinds.definition_kind -> Tacexpr.declaration_hook -> env -> evar_map ref -> identifier -> local_binder list -> constr_expr -> constr_expr option -> Subtac_obligations.progress coq-8.4pl4/plugins/subtac/test/0000755000175000017500000000000012326224777015554 5ustar stephstephcoq-8.4pl4/plugins/subtac/test/take.v0000644000175000017500000000115012326224777016664 0ustar stephsteph(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *) Require Import JMeq. Require Import List. Require Import Program. Set Implicit Arguments. Obligations Tactic := idtac. Print cons. Program Fixpoint take (A : Set) (l : list A) (n : nat | n <= length l) { struct l } : { l' : list A | length l' = n } := match n with | 0 => nil | S p => match l with | cons hd tl => let rest := take tl p in cons hd rest | nil => ! end end. Require Import Omega. Solve All Obligations. Next Obligation. destruct_call take ; program_simpl. Defined. Next Obligation. intros. inversion H. Defined. coq-8.4pl4/plugins/subtac/test/measure.v0000644000175000017500000000064312326224777017407 0ustar stephstephNotation "( x & y )" := (@existS _ _ x y) : core_scope. Unset Printing All. Require Import Coq.Arith.Compare_dec. Require Import Coq.Program.Program. Fixpoint size (a : nat) : nat := match a with 0 => 1 | S n => S (size n) end. Program Fixpoint test_measure (a : nat) {measure size a} : nat := match a with | S (S n) => S (test_measure n) | 0 | S 0 => a end. Check test_measure. Print test_measure.coq-8.4pl4/plugins/subtac/test/ListDep.v0000644000175000017500000000212412326224777017306 0ustar stephsteph(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *) Require Import List. Require Import Coq.Program.Program. Set Implicit Arguments. Definition sub_list (A : Set) (l' l : list A) := (forall v, In v l' -> In v l) /\ length l' <= length l. Lemma sub_list_tl : forall A : Set, forall x (l l' : list A), sub_list (x :: l) l' -> sub_list l l'. Proof. intros. inversion H. split. intros. apply H0. auto with datatypes. auto with arith. Qed. Section Map_DependentRecursor. Variable U V : Set. Variable l : list U. Variable f : { x : U | In x l } -> V. Obligations Tactic := unfold sub_list in * ; program_simpl ; intuition. Program Fixpoint map_rec ( l' : list U | sub_list l' l ) { measure length l' } : { r : list V | length r = length l' } := match l' with | nil => nil | cons x tl => let tl' := map_rec tl in f x :: tl' end. Next Obligation. destruct_call map_rec. simpl in *. subst l'. simpl ; auto with arith. Qed. Program Definition map : list V := map_rec l. End Map_DependentRecursor. Extraction map. Extraction map_rec. coq-8.4pl4/plugins/subtac/test/wf.v0000644000175000017500000000241212326224777016356 0ustar stephstephNotation "( x & y )" := (@existS _ _ x y) : core_scope. Unset Printing All. Require Import Coq.Arith.Compare_dec. Require Import Coq.subtac.Utils. Ltac one_simpl_hyp := match goal with | [H : (`exist _ _ _) = _ |- _] => simpl in H | [H : _ = (`exist _ _ _) |- _] => simpl in H | [H : (`exist _ _ _) < _ |- _] => simpl in H | [H : _ < (`exist _ _ _) |- _] => simpl in H | [H : (`exist _ _ _) <= _ |- _] => simpl in H | [H : _ <= (`exist _ _ _) |- _] => simpl in H | [H : (`exist _ _ _) > _ |- _] => simpl in H | [H : _ > (`exist _ _ _) |- _] => simpl in H | [H : (`exist _ _ _) >= _ |- _] => simpl in H | [H : _ >= (`exist _ _ _) |- _] => simpl in H end. Ltac one_simpl_subtac := destruct_exists ; repeat one_simpl_hyp ; simpl. Ltac simpl_subtac := do 3 one_simpl_subtac ; simpl. Require Import Omega. Require Import Wf_nat. Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf a lt} : { q : nat & { r : nat | a = b * q + r /\ r < b } } := if le_lt_dec b a then let (q', r) := euclid (a - b) b in (S q' & r) else (O & a). destruct b ; simpl_subtac. omega. simpl_subtac. assert(x0 * S q' = x0 + x0 * q'). rewrite <- mult_n_Sm. omega. rewrite H2 ; omega. simpl_subtac. split ; auto with arith. omega. apply lt_wf. Defined. Check euclid_evars_proof.coq-8.4pl4/plugins/subtac/test/euclid.v0000644000175000017500000000127212326224777017212 0ustar stephstephRequire Import Coq.Program.Program. Require Import Coq.Arith.Compare_dec. Notation "( x & y )" := (existS _ x y) : core_scope. Require Import Omega. Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf lt a} : { q : nat & { r : nat | a = b * q + r /\ r < b } } := if le_lt_dec b a then let (q', r) := euclid (a - b) b in (S q' & r) else (O & a). Next Obligation. assert(b * S q' = b * q' + b) by auto with arith ; omega. Defined. Program Definition test_euclid : (prod nat nat) := let (q, r) := euclid 4 2 in (q, q). Eval lazy beta zeta delta iota in test_euclid. Program Definition testsig (a : nat) : { x : nat & { y : nat | x < y } } := (a & S a). Check testsig. coq-8.4pl4/plugins/subtac/test/Mutind.v0000644000175000017500000000034512326224777017205 0ustar stephstephRequire Import List. Program Fixpoint f a : { x : nat | x > 0 } := match a with | 0 => 1 | S a' => g a a' end with g a b : { x : nat | x > 0 } := match b with | 0 => 1 | S b' => f b' end. Check f. Check g. coq-8.4pl4/plugins/subtac/test/rec.v0000644000175000017500000000236212326224777016517 0ustar stephstephRequire Import Coq.Arith.Arith. Require Import Lt. Require Import Omega. Axiom lt_ge_dec : forall x y : nat, { x < y } + { x >= y }. (*Proof. intros. elim (le_lt_dec y x) ; intros ; auto with arith. Defined. *) Require Import Coq.subtac.FixSub. Require Import Wf_nat. Lemma preda_lt_a : forall a, 0 < a -> pred a < a. auto with arith. Qed. Program Fixpoint id_struct (a : nat) : nat := match a with 0 => 0 | S n => S (id_struct n) end. Check struct_rec. if (lt_ge_dec O a) then S (wfrec (pred a)) else O. Program Fixpoint wfrec (a : nat) { wf a lt } : nat := if (lt_ge_dec O a) then S (wfrec (pred a)) else O. intros. apply preda_lt_a ; auto. Defined. Extraction wfrec. Extraction Inline proj1_sig. Extract Inductive bool => "bool" [ "true" "false" ]. Extract Inductive sumbool => "bool" [ "true" "false" ]. Extract Inlined Constant lt_ge_dec => "<". Extraction wfrec. Extraction Inline lt_ge_dec le_lt_dec. Extraction wfrec. Program Fixpoint structrec (a : nat) { wf a lt } : nat := match a with S n => S (structrec n) | 0 => 0 end. intros. unfold n0. omega. Defined. Print structrec. Extraction structrec. Extraction structrec. Definition structrec_fun (a : nat) : nat := structrec a (lt_wf a). Print structrec_fun. coq-8.4pl4/plugins/subtac/test/id.v0000644000175000017500000000151512326224777016341 0ustar stephstephRequire Coq.Arith.Arith. Require Import Coq.subtac.Utils. Program Fixpoint id (n : nat) : { x : nat | x = n } := match n with | O => O | S p => S (id p) end. intros ; auto. pose (subset_simpl (id p)). simpl in e. unfold p0. rewrite e. auto. Defined. Check id. Print id. Extraction id. Axiom le_gt_dec : forall n m, { n <= m } + { n > m }. Require Import Omega. Program Fixpoint id_if (n : nat) { wf n lt }: { x : nat | x = n } := if le_gt_dec n 0 then 0 else S (id_if (pred n)). intros. auto with arith. intros. pose (subset_simpl (id_if (pred n))). simpl in e. rewrite e. induction n ; auto with arith. Defined. Print id_if_instance. Extraction id_if_instance. Notation "( x & y )" := (@existS _ _ x y) : core_scope. Program Definition testsig ( a : nat ) : { x : nat & { y : nat | x = y }} := (a & a). intros. auto. Qed. coq-8.4pl4/plugins/subtac/test/Test1.v0000644000175000017500000000043212326224777016742 0ustar stephstephProgram Definition test (a b : nat) : { x : nat | x = a + b } := ((a + b) : { x : nat | x = a + b }). Proof. intros. reflexivity. Qed. Print test. Require Import List. Program hd_opt (l : list nat) : { x : nat | x <> 0 } := match l with nil => 1 | a :: l => a end. coq-8.4pl4/plugins/subtac/test/ListsTest.v0000644000175000017500000000361712326224777017710 0ustar stephsteph(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *) Require Import Coq.Program.Program. Require Import List. Set Implicit Arguments. Section Accessors. Variable A : Set. Program Definition myhd : forall (l : list A | length l <> 0), A := fun l => match l with | nil => ! | hd :: tl => hd end. Program Definition mytail (l : list A | length l <> 0) : list A := match l with | nil => ! | hd :: tl => tl end. End Accessors. Program Definition test_hd : nat := myhd (cons 1 nil). (*Eval compute in test_hd*) (*Program Definition test_tail : list A := mytail nil.*) Section app. Variable A : Set. Program Fixpoint app (l : list A) (l' : list A) { struct l } : { r : list A | length r = length l + length l' } := match l with | nil => l' | hd :: tl => hd :: (tl ++ l') end where "x ++ y" := (app x y). Next Obligation. intros. destruct_call app ; program_simpl. Defined. Program Lemma app_id_l : forall l : list A, l = nil ++ l. Proof. simpl ; auto. Qed. Program Lemma app_id_r : forall l : list A, l = l ++ nil. Proof. induction l ; simpl in * ; auto. rewrite <- IHl ; auto. Qed. End app. Extraction app. Section Nth. Variable A : Set. Program Fixpoint nth (l : list A) (n : nat | n < length l) { struct l } : A := match n, l with | 0, hd :: _ => hd | S n', _ :: tl => nth tl n' | _, nil => ! end. Next Obligation. Proof. simpl in *. auto with arith. Defined. Next Obligation. Proof. inversion H. Qed. Program Fixpoint nth' (l : list A) (n : nat | n < length l) { struct l } : A := match l, n with | hd :: _, 0 => hd | _ :: tl, S n' => nth' tl n' | nil, _ => ! end. Next Obligation. Proof. simpl in *. auto with arith. Defined. Next Obligation. Proof. intros. inversion H. Defined. End Nth. coq-8.4pl4/plugins/subtac/subtac_utils.ml0000644000175000017500000003444112326224777017636 0ustar stephsteph(** -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *) open Evd open Libnames open Coqlib open Term open Names open Util let ($) f x = f x (****************************************************************************) (* Library linking *) let contrib_name = "Program" let subtac_dir = [contrib_name] let fixsub_module = subtac_dir @ ["Wf"] let utils_module = subtac_dir @ ["Utils"] let tactics_module = subtac_dir @ ["Tactics"] let init_constant dir s () = gen_constant contrib_name dir s let init_reference dir s () = gen_reference contrib_name dir s let safe_init_constant md name () = check_required_library ("Coq"::md); init_constant md name () let ex_pi1 = init_constant utils_module "ex_pi1" let ex_pi2 = init_constant utils_module "ex_pi2" let make_ref l s = init_reference l s let well_founded_ref = make_ref ["Init";"Wf"] "Well_founded" let acc_ref = make_ref ["Init";"Wf"] "Acc" let acc_inv_ref = make_ref ["Init";"Wf"] "Acc_inv" let fix_sub_ref = make_ref fixsub_module "Fix_sub" let measure_on_R_ref = make_ref fixsub_module "MR" let fix_measure_sub_ref = make_ref fixsub_module "Fix_measure_sub" let refl_ref = make_ref ["Init";"Logic"] "refl_equal" let make_ref s = Qualid (dummy_loc, qualid_of_string s) let lt_ref = make_ref "Init.Peano.lt" let sig_ref = make_ref "Init.Specif.sig" let proj1_sig_ref = make_ref "Init.Specif.proj1_sig" let proj2_sig_ref = make_ref "Init.Specif.proj2_sig" let build_sig () = { proj1 = init_constant ["Init"; "Specif"] "proj1_sig" (); proj2 = init_constant ["Init"; "Specif"] "proj2_sig" (); elim = init_constant ["Init"; "Specif"] "sig_rec" (); intro = init_constant ["Init"; "Specif"] "exist" (); typ = init_constant ["Init"; "Specif"] "sig" () } let sig_ = build_sig let fix_proto = safe_init_constant tactics_module "fix_proto" let hide_obligation = safe_init_constant tactics_module "obligation" let eq_ind = init_constant ["Init"; "Logic"] "eq" let eq_rec = init_constant ["Init"; "Logic"] "eq_rec" let eq_rect = init_constant ["Init"; "Logic"] "eq_rect" let eq_refl = init_constant ["Init"; "Logic"] "refl_equal" let eq_ind_ref = init_reference ["Init"; "Logic"] "eq" let refl_equal_ref = init_reference ["Init"; "Logic"] "refl_equal" let not_ref = init_constant ["Init"; "Logic"] "not" let and_typ = Coqlib.build_coq_and let eqdep_ind = init_constant [ "Logic";"Eqdep"] "eq_dep" let eqdep_rec = init_constant ["Logic";"Eqdep"] "eq_dep_rec" let eqdep_ind_ref = init_reference [ "Logic";"Eqdep"] "eq_dep" let eqdep_intro_ref = init_reference [ "Logic";"Eqdep"] "eq_dep_intro" let jmeq_ind = safe_init_constant ["Logic";"JMeq"] "JMeq" let jmeq_rec = init_constant ["Logic";"JMeq"] "JMeq_rec" let jmeq_refl = init_constant ["Logic";"JMeq"] "JMeq_refl" let ex_ind = init_constant ["Init"; "Logic"] "ex" let ex_intro = init_reference ["Init"; "Logic"] "ex_intro" let proj1 = init_constant ["Init"; "Logic"] "proj1" let proj2 = init_constant ["Init"; "Logic"] "proj2" let existS = build_sigma_type let prod = build_prod (* orders *) let well_founded = init_constant ["Init"; "Wf"] "well_founded" let fix = init_constant ["Init"; "Wf"] "Fix" let acc = init_constant ["Init"; "Wf"] "Acc" let acc_inv = init_constant ["Init"; "Wf"] "Acc_inv" let extconstr = Constrextern.extern_constr true (Global.env ()) let extsort s = Constrextern.extern_constr true (Global.env ()) (mkSort s) open Pp let my_print_constr = Termops.print_constr_env let my_print_constr_expr = Ppconstr.pr_constr_expr let my_print_rel_context env ctx = Printer.pr_rel_context env ctx let my_print_context = Termops.print_rel_context let my_print_named_context = Termops.print_named_context let my_print_env = Termops.print_env let my_print_glob_constr = Printer.pr_glob_constr_env let my_print_evardefs = Evd.pr_evar_map None let my_print_tycon_type = Evarutil.pr_tycon_type let debug_level = 2 let debug_on = true let debug n s = if debug_on then if !Flags.debug && n >= debug_level then msgnl s else () else () let debug_msg n s = if debug_on then if !Flags.debug && n >= debug_level then s else mt () else mt () let trace s = if debug_on then if !Flags.debug && debug_level > 0 then msgnl s else () else () let rec pp_list f = function [] -> mt() | x :: y -> f x ++ spc () ++ pp_list f y let wf_relations = Hashtbl.create 10 let std_relations () = let add k v = Hashtbl.add wf_relations k v in add (init_constant ["Init"; "Peano"] "lt" ()) (init_constant ["Arith"; "Wf_nat"] "lt_wf") let std_relations = Lazy.lazy_from_fun std_relations type binders = Topconstr.local_binder list let app_opt c e = match c with Some constr -> constr e | None -> e let print_args env args = Array.fold_right (fun a acc -> my_print_constr env a ++ spc () ++ acc) args (str "") let make_existential loc ?(opaque = Define true) env isevars c = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c let no_goals_or_obligations = function | GoalEvar | QuestionMark _ -> false | _ -> true let make_existential_expr loc env c = let key = Evarutil.new_untyped_evar () in let evar = Topconstr.CEvar (loc, key, None) in debug 2 (str "Constructed evar " ++ int key); evar let string_of_hole_kind = function | ImplicitArg _ -> "ImplicitArg" | BinderType _ -> "BinderType" | QuestionMark _ -> "QuestionMark" | CasesType -> "CasesType" | InternalHole -> "InternalHole" | TomatchTypeParameter _ -> "TomatchTypeParameter" | GoalEvar -> "GoalEvar" | ImpossibleCase -> "ImpossibleCase" | MatchingVar _ -> "MatchingVar" let evars_of_term evc init c = let rec evrec acc c = match kind_of_term c with | Evar (n, _) when Evd.mem evc n -> Evd.add acc n (Evd.find evc n) | Evar (n, _) -> assert(false) | _ -> fold_constr evrec acc c in evrec init c let non_instanciated_map env evd evm = List.fold_left (fun evm (key, evi) -> let (loc,k) = evar_source key !evd in debug 2 (str "evar " ++ int key ++ str " has kind " ++ str (string_of_hole_kind k)); match k with | QuestionMark _ -> Evd.add evm key evi | ImplicitArg (_,_,false) -> Evd.add evm key evi | _ -> debug 2 (str " and is an implicit"); Pretype_errors.error_unsolvable_implicit loc env evm (Evarutil.nf_evar_info evm evi) k None) Evd.empty (Evarutil.non_instantiated evm) let global_kind = Decl_kinds.IsDefinition Decl_kinds.Definition let goal_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Definition let global_proof_kind = Decl_kinds.IsProof Decl_kinds.Lemma let goal_proof_kind = Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma let global_fix_kind = Decl_kinds.IsDefinition Decl_kinds.Fixpoint let goal_fix_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Fixpoint open Tactics open Tacticals let filter_map f l = let rec aux acc = function hd :: tl -> (match f hd with Some t -> aux (t :: acc) tl | None -> aux acc tl) | [] -> List.rev acc in aux [] l let build_dependent_sum l = let rec aux names conttac conttype = function (n, t) :: ((_ :: _) as tl) -> let hyptype = substl names t in trace (spc () ++ str ("treating evar " ^ string_of_id n)); (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype) with e when Errors.noncritical e -> ()); let tac = assert_tac (Name n) hyptype in let conttac = (fun cont -> conttac (tclTHENS tac ([intros; (tclTHENSEQ [constructor_tac false (Some 1) 1 (Glob_term.ImplicitBindings [mkVar n]); cont]); ]))) in let conttype = (fun typ -> let tex = mkLambda (Name n, t, typ) in conttype (mkApp (ex_ind (), [| t; tex |]))) in aux (mkVar n :: names) conttac conttype tl | (n, t) :: [] -> (conttac intros, conttype t) | [] -> raise (Invalid_argument "build_dependent_sum") in aux [] identity identity (List.rev l) open Proof_type open Tacexpr let mkProj1 a b c = mkApp (delayed_force proj1, [| a; b; c |]) let mkProj2 a b c = mkApp (delayed_force proj2, [| a; b; c |]) let mk_ex_pi1 a b c = mkApp (delayed_force ex_pi1, [| a; b; c |]) let mk_ex_pi2 a b c = mkApp (delayed_force ex_pi2, [| a; b; c |]) let mkSubset name typ prop = mkApp ((delayed_force sig_).typ, [| typ; mkLambda (name, typ, prop) |]) let mk_eq typ x y = mkApp (delayed_force eq_ind, [| typ; x ; y |]) let mk_eq_refl typ x = mkApp (delayed_force eq_refl, [| typ; x |]) let mk_JMeq typ x typ' y = mkApp (delayed_force jmeq_ind, [| typ; x ; typ'; y |]) let mk_JMeq_refl typ x = mkApp (delayed_force jmeq_refl, [| typ; x |]) let unsafe_fold_right f = function hd :: tl -> List.fold_right f tl hd | [] -> raise (Invalid_argument "unsafe_fold_right") let mk_conj l = let conj_typ = delayed_force and_typ in unsafe_fold_right (fun c conj -> mkApp (conj_typ, [| c ; conj |])) l let mk_not c = let notc = delayed_force not_ref in mkApp (notc, [| c |]) let and_tac l hook = let andc = Coqlib.build_coq_and () in let rec aux ((accid, goal, tac, extract) as acc) = function | [] -> (* Singleton *) acc | (id, x, elgoal, eltac) :: tl -> let tac' = tclTHEN simplest_split (tclTHENLIST [tac; eltac]) in let proj = fun c -> mkProj2 goal elgoal c in let extract = List.map (fun (id, x, y, f) -> (id, x, y, (fun c -> f (mkProj1 goal elgoal c)))) extract in aux ((string_of_id id) ^ "_" ^ accid, mkApp (andc, [| goal; elgoal |]), tac', (id, x, elgoal, proj) :: extract) tl in let and_proof_id, and_goal, and_tac, and_extract = match l with | [] -> raise (Invalid_argument "and_tac: empty list of goals") | (hdid, x, hdg, hdt) :: tl -> aux (string_of_id hdid, hdg, hdt, [hdid, x, hdg, (fun c -> c)]) tl in let and_proofid = id_of_string (and_proof_id ^ "_and_proof") in Lemmas.start_proof and_proofid goal_kind and_goal (hook (fun c -> List.map (fun (id, x, t, f) -> (id, x, t, f c)) and_extract)); trace (str "Started and proof"); Pfedit.by and_tac; trace (str "Applied and tac") let destruct_ex ext ex = let rec aux c acc = match kind_of_term c with App (f, args) -> (match kind_of_term f with Ind i when i = Term.destInd (delayed_force ex_ind) && Array.length args = 2 -> let (dom, rng) = try (args.(0), args.(1)) with e when Errors.noncritical e -> assert(false) in let pi1 = (mk_ex_pi1 dom rng acc) in let rng_body = match kind_of_term rng with Lambda (_, _, t) -> subst1 pi1 t | t -> rng in pi1 :: aux rng_body (mk_ex_pi2 dom rng acc) | _ -> [acc]) | _ -> [acc] in aux ex ext open Glob_term let id_of_name = function Name n -> n | Anonymous -> raise (Invalid_argument "id_of_name") let definition_message id = Nameops.pr_id id ++ str " is defined" let recursive_message v = match Array.length v with | 0 -> error "no recursive definition" | 1 -> (Printer.pr_constant (Global.env ()) v.(0) ++ str " is recursively defined") | _ -> hov 0 (prvect_with_sep pr_comma (Printer.pr_constant (Global.env ())) v ++ spc () ++ str "are recursively defined") let print_message m = Flags.if_verbose ppnl m (* Solve an obligation using tactics, return the corresponding proof term *) let solve_by_tac evi t = let id = id_of_string "H" in try Pfedit.start_proof id goal_kind evi.evar_hyps evi.evar_concl (fun _ _ -> ()); Pfedit.by (tclCOMPLETE t); let _,(const,_,_,_) = Pfedit.cook_proof ignore in Pfedit.delete_current_proof (); Inductiveops.control_only_guard (Global.env ()) const.Entries.const_entry_body; const.Entries.const_entry_body with reraise -> Pfedit.delete_current_proof(); raise reraise (* let apply_tac t goal = t goal *) (* let solve_by_tac evi t = *) (* let ev = 1 in *) (* let evm = Evd.add Evd.empty ev evi in *) (* let goal = {it = evi; sigma = evm } in *) (* let (res, valid) = apply_tac t goal in *) (* if res.it = [] then *) (* let prooftree = valid [] in *) (* let proofterm, obls = Refiner.extract_open_proof res.sigma prooftree in *) (* if obls = [] then proofterm *) (* else raise Exit *) (* else raise Exit *) let rec string_of_list sep f = function [] -> "" | x :: [] -> f x | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl let string_of_intset d = string_of_list "," string_of_int (Intset.elements d) (**********************************************************) (* Pretty-printing *) open Printer open Ppconstr open Nameops open Evd let pr_meta_map evd = let ml = meta_list evd in let pr_name = function Name id -> str"[" ++ pr_id id ++ str"]" | _ -> mt() in let pr_meta_binding = function | (mv,Cltyp (na,b)) -> hov 0 (pr_meta mv ++ pr_name na ++ str " : " ++ Termops.print_constr b.rebus ++ fnl ()) | (mv,Clval(na,b,_)) -> hov 0 (pr_meta mv ++ pr_name na ++ str " := " ++ Termops.print_constr (fst b).rebus ++ fnl ()) in prlist pr_meta_binding ml let pr_idl idl = prlist_with_sep pr_spc pr_id idl let pr_evar_info evi = let phyps = (*pr_idl (List.rev (ids_of_named_context (evar_context evi))) *) Printer.pr_named_context (Global.env()) (evar_context evi) in let pty = Termops.print_constr evi.evar_concl in let pb = match evi.evar_body with | Evar_empty -> mt () | Evar_defined c -> spc() ++ str"=> " ++ Termops.print_constr c in hov 2 (str"[" ++ phyps ++ spc () ++ str"|- " ++ pty ++ pb ++ str"]") let pr_evar_map sigma = h 0 (prlist_with_sep pr_fnl (fun (ev,evi) -> h 0 (str(string_of_existential ev)++str"=="++ pr_evar_info evi)) (to_list sigma)) let pr_constraints pbs = h 0 (prlist_with_sep pr_fnl (fun (pbty,t1,t2) -> Termops.print_constr t1 ++ spc() ++ str (match pbty with | Reduction.CONV -> "==" | Reduction.CUMUL -> "<=") ++ spc() ++ Termops.print_constr t2) pbs) let pr_evar_map evd = let pp_evm = let evars = evd in if evars = empty then mt() else str"EVARS:"++brk(0,1)++pr_evar_map evars++fnl() in let pp_met = if meta_list evd = [] then mt() else str"METAS:"++brk(0,1)++pr_meta_map evd in v 0 (pp_evm ++ pp_met) let contrib_tactics_path = make_dirpath (List.map id_of_string ["Tactics";contrib_name;"Coq"]) let tactics_tac s = lazy(make_kn (MPfile contrib_tactics_path) (make_dirpath []) (mk_label s)) let tactics_call tac args = TacArg(dummy_loc,TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (tactics_tac tac)),args)) coq-8.4pl4/plugins/subtac/subtac_utils.mli0000644000175000017500000001034712326224777020006 0ustar stephstephopen Term open Libnames open Coqlib open Environ open Pp open Evd open Decl_kinds open Topconstr open Glob_term open Util open Evarutil open Names open Sign val ($) : ('a -> 'b) -> 'a -> 'b val contrib_name : string val subtac_dir : string list val fixsub_module : string list val init_constant : string list -> string -> constr delayed val init_reference : string list -> string -> global_reference delayed val well_founded_ref : global_reference delayed val acc_ref : global_reference delayed val acc_inv_ref : global_reference delayed val fix_sub_ref : global_reference delayed val measure_on_R_ref : global_reference delayed val fix_measure_sub_ref : global_reference delayed val refl_ref : global_reference delayed val lt_ref : reference val sig_ref : reference val proj1_sig_ref : reference val proj2_sig_ref : reference val build_sig : unit -> coq_sigma_data val sig_ : coq_sigma_data delayed val fix_proto : constr delayed val hide_obligation : constr delayed val eq_ind : constr delayed val eq_rec : constr delayed val eq_rect : constr delayed val eq_refl : constr delayed val not_ref : constr delayed val and_typ : constr delayed val eqdep_ind : constr delayed val eqdep_rec : constr delayed val jmeq_ind : constr delayed val jmeq_rec : constr delayed val jmeq_refl : constr delayed val existS : coq_sigma_data delayed val prod : coq_sigma_data delayed val well_founded : constr delayed val fix : constr delayed val acc : constr delayed val acc_inv : constr delayed val extconstr : constr -> constr_expr val extsort : sorts -> constr_expr val my_print_constr : env -> constr -> std_ppcmds val my_print_constr_expr : constr_expr -> std_ppcmds val my_print_evardefs : evar_map -> std_ppcmds val my_print_context : env -> std_ppcmds val my_print_rel_context : env -> rel_context -> std_ppcmds val my_print_named_context : env -> std_ppcmds val my_print_env : env -> std_ppcmds val my_print_glob_constr : env -> glob_constr -> std_ppcmds val my_print_tycon_type : env -> type_constraint_type -> std_ppcmds val debug : int -> std_ppcmds -> unit val debug_msg : int -> std_ppcmds -> std_ppcmds val trace : std_ppcmds -> unit val wf_relations : (constr, constr delayed) Hashtbl.t type binders = local_binder list val app_opt : ('a -> 'a) option -> 'a -> 'a val print_args : env -> constr array -> std_ppcmds val make_existential : loc -> ?opaque:obligation_definition_status -> env -> evar_map ref -> types -> constr val no_goals_or_obligations : Typeclasses.evar_filter val make_existential_expr : loc -> 'a -> 'b -> constr_expr val string_of_hole_kind : hole_kind -> string val evars_of_term : evar_map -> evar_map -> constr -> evar_map val non_instanciated_map : env -> evar_map ref -> evar_map -> evar_map val global_kind : logical_kind val goal_kind : locality * goal_object_kind val global_proof_kind : logical_kind val goal_proof_kind : locality * goal_object_kind val global_fix_kind : logical_kind val goal_fix_kind : locality * goal_object_kind val mkSubset : name -> constr -> constr -> constr val mkProj1 : constr -> constr -> constr -> constr val mkProj1 : constr -> constr -> constr -> constr val mk_ex_pi1 : constr -> constr -> constr -> constr val mk_ex_pi1 : constr -> constr -> constr -> constr val mk_eq : types -> constr -> constr -> types val mk_eq_refl : types -> constr -> constr val mk_JMeq : types -> constr-> types -> constr -> types val mk_JMeq_refl : types -> constr -> constr val mk_conj : types list -> types val mk_not : types -> types val build_dependent_sum : (identifier * types) list -> Proof_type.tactic * types val and_tac : (identifier * 'a * constr * Proof_type.tactic) list -> ((constr -> (identifier * 'a * constr * constr) list) -> Tacexpr.declaration_hook) -> unit val destruct_ex : constr -> constr -> constr list val id_of_name : name -> identifier val definition_message : identifier -> std_ppcmds val recursive_message : constant array -> std_ppcmds val print_message : std_ppcmds -> unit val solve_by_tac : evar_info -> Tacmach.tactic -> constr val string_of_list : string -> ('a -> string) -> 'a list -> string val string_of_intset : Intset.t -> string val pr_evar_map : evar_map -> Pp.std_ppcmds val tactics_call : string -> Tacexpr.glob_tactic_arg list -> Tacexpr.glob_tactic_expr val pp_list : ('a -> Pp.std_ppcmds) -> 'a list -> Pp.std_ppcmds coq-8.4pl4/plugins/firstorder/0000755000175000017500000000000012365131025015461 5ustar stephstephcoq-8.4pl4/plugins/firstorder/ground.mli0000644000175000017500000000116612326224777017504 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic coq-8.4pl4/plugins/firstorder/sequent.mli0000644000175000017500000000340112326224777017664 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* global_reference -> global_reference list CM.t -> global_reference list CM.t val cm_remove : constr -> global_reference -> global_reference list CM.t -> global_reference list CM.t module HP: Heap.S with type elt=Formula.t type t = {redexes:HP.t; context: global_reference list CM.t; latoms:constr list; gl:types; glatom:constr option; cnt:counter; history:History.t; depth:int} val deepen: t -> t val record: h_item -> t -> t val lookup: h_item -> t -> bool val add_formula : side -> global_reference -> constr -> t -> Proof_type.goal sigma -> t val re_add_formula_list : Formula.t list -> t -> t val find_left : constr -> t -> global_reference val take_formula : t -> Formula.t * t val empty_seq : int -> t val extend_with_ref_list : global_reference list -> t -> Proof_type.goal sigma -> t val extend_with_auto_hints : Auto.hint_db_name list -> t -> Proof_type.goal sigma -> t val print_cmap: global_reference list CM.t -> unit coq-8.4pl4/plugins/firstorder/ground.ml0000644000175000017500000000733312326224777017335 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* () in List.iter f (Classops.coercions ()); red_flags:= Closure.RedFlags.red_add_transparent Closure.betaiotazeta (Names.Idpred.full,Names.Cpred.complement !predref) let ground_tac solver startseq gl= update_flags (); let rec toptac skipped seq gl= if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 then Pp.msgnl (Printer.pr_goal gl); tclORELSE (axiom_tac seq.gl seq) begin try let (hd,seq1)=take_formula seq and re_add s=re_add_formula_list skipped s in let continue=toptac [] and backtrack gl=toptac (hd::skipped) seq1 gl in match hd.pat with Right rpat-> begin match rpat with Rand-> and_tac backtrack continue (re_add seq1) | Rforall-> let backtrack1= if !qflag then tclFAIL 0 (Pp.str "reversible in 1st order mode") else backtrack in forall_tac backtrack1 continue (re_add seq1) | Rarrow-> arrow_tac backtrack continue (re_add seq1) | Ror-> or_tac backtrack continue (re_add seq1) | Rfalse->backtrack | Rexists(i,dom,triv)-> let (lfp,seq2)=collect_quantified seq in let backtrack2=toptac (lfp@skipped) seq2 in if !qflag && seq.depth>0 then quantified_tac lfp backtrack2 continue (re_add seq) else backtrack2 (* need special backtracking *) end | Left lpat-> begin match lpat with Lfalse-> left_false_tac hd.id | Land ind-> left_and_tac ind backtrack hd.id continue (re_add seq1) | Lor ind-> left_or_tac ind backtrack hd.id continue (re_add seq1) | Lforall (_,_,_)-> let (lfp,seq2)=collect_quantified seq in let backtrack2=toptac (lfp@skipped) seq2 in if !qflag && seq.depth>0 then quantified_tac lfp backtrack2 continue (re_add seq) else backtrack2 (* need special backtracking *) | Lexists ind -> if !qflag then left_exists_tac ind backtrack hd.id continue (re_add seq1) else backtrack | LA (typ,lap)-> let la_tac= begin match lap with LLatom -> backtrack | LLand (ind,largs) | LLor(ind,largs) | LLfalse (ind,largs)-> (ll_ind_tac ind largs backtrack hd.id continue (re_add seq1)) | LLforall p -> if seq.depth>0 && !qflag then (ll_forall_tac p backtrack hd.id continue (re_add seq1)) else backtrack | LLexists (ind,l) -> if !qflag then ll_ind_tac ind l backtrack hd.id continue (re_add seq1) else backtrack | LLarrow (a,b,c) -> (ll_arrow_tac a b c backtrack hd.id continue (re_add seq1)) end in ll_atom_tac typ la_tac hd.id continue (re_add seq1) end with Heap.EmptyHeap->solver end gl in wrap (List.length (pf_hyps gl)) true (toptac []) (startseq gl) gl coq-8.4pl4/plugins/firstorder/g_ground.ml40000644000175000017500000001110612326224777017720 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Some !ground_depth); optwrite= (function None->ground_depth:=3 | Some i->ground_depth:=(max i 0))} in declare_int_option gdopt let congruence_depth=ref 100 let _= let gdopt= { optsync=true; optdepr=false; optname="Congruence Depth"; optkey=["Congruence";"Depth"]; optread=(fun ()->Some !congruence_depth); optwrite= (function None->congruence_depth:=0 | Some i->congruence_depth:=(max i 0))} in declare_int_option gdopt let (set_default_solver, default_solver, print_default_solver) = Tactic_option.declare_tactic_option ~default:(<:tactic>) "Firstorder default solver" VERNAC COMMAND EXTEND Firstorder_Set_Solver | [ "Set" "Firstorder" "Solver" tactic(t) ] -> [ set_default_solver (Vernacexpr.use_section_locality ()) (Tacinterp.glob_tactic t) ] END VERNAC COMMAND EXTEND Firstorder_Print_Solver | [ "Print" "Firstorder" "Solver" ] -> [ Pp.msgnl (Pp.(++) (Pp.str"Firstorder solver tactic is ") (print_default_solver ())) ] END let fail_solver=tclFAIL 0 (Pp.str "GTauto failed") let gen_ground_tac flag taco ids bases gl= let backup= !qflag in try qflag:=flag; let solver= match taco with Some tac-> tac | None-> snd (default_solver ()) in let startseq gl= let seq=empty_seq !ground_depth in extend_with_auto_hints bases (extend_with_ref_list ids seq gl) gl in let result=ground_tac solver startseq gl in qflag:=backup;result with reraise ->qflag:=backup;raise reraise (* special for compatibility with Intuition let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str let defined_connectives=lazy [[],EvalConstRef (destConst (constant "not")); [],EvalConstRef (destConst (constant "iff"))] let normalize_evaluables= onAllHypsAndConcl (function None->unfold_in_concl (Lazy.force defined_connectives) | Some id-> unfold_in_hyp (Lazy.force defined_connectives) (Tacexpr.InHypType id)) *) open Genarg open Ppconstr open Printer let pr_firstorder_using_raw _ _ _ = prlist_with_sep pr_comma pr_reference let pr_firstorder_using_glob _ _ _ = prlist_with_sep pr_comma (pr_or_var (pr_located pr_global)) let pr_firstorder_using_typed _ _ _ = prlist_with_sep pr_comma pr_global ARGUMENT EXTEND firstorder_using PRINTED BY pr_firstorder_using_typed RAW_TYPED AS reference_list RAW_PRINTED BY pr_firstorder_using_raw GLOB_TYPED AS reference_list GLOB_PRINTED BY pr_firstorder_using_glob | [ "using" reference(a) ] -> [ [a] ] | [ "using" reference(a) "," ne_reference_list_sep(l,",") ] -> [ a::l ] | [ "using" reference(a) reference(b) reference_list(l) ] -> [ Flags.if_verbose Pp.msg_warning (Pp.str "Deprecated syntax; use \",\" as separator"); a::b::l ] | [ ] -> [ [] ] END TACTIC EXTEND firstorder [ "firstorder" tactic_opt(t) firstorder_using(l) ] -> [ gen_ground_tac true (Option.map eval_tactic t) l [] ] | [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] -> [ gen_ground_tac true (Option.map eval_tactic t) [] l ] | [ "firstorder" tactic_opt(t) firstorder_using(l) "with" ne_preident_list(l') ] -> [ gen_ground_tac true (Option.map eval_tactic t) l l' ] END TACTIC EXTEND gintuition [ "gintuition" tactic_opt(t) ] -> [ gen_ground_tac false (Option.map eval_tactic t) [] [] ] END let default_declarative_automation gls = tclORELSE (tclORELSE (Auto.h_trivial [] None) (Cctac.congruence_tac !congruence_depth [])) (gen_ground_tac true (Some (tclTHEN (snd (default_solver ())) (Cctac.congruence_tac !congruence_depth []))) [] []) gls let () = Decl_proof_instr.register_automation_tac default_declarative_automation coq-8.4pl4/plugins/firstorder/instances.ml0000644000175000017500000001351212326224777020022 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (OrderedConstr.compare d1 d2) | Real((m1,c1),n1),Real((m2,c2),n2)-> ((-) =? (-) ==? OrderedConstr.compare) m2 m1 n1 n2 c1 c2 | Phantom(_),Real((m,_),_)-> if m=0 then -1 else 1 | Real((m,_),_),Phantom(_)-> if m=0 then 1 else -1 let compare_gr id1 id2 = if id1==id2 then 0 else if id1==dummy_id then 1 else if id2==dummy_id then -1 else Libnames.RefOrdered.compare id1 id2 module OrderedInstance= struct type t=instance * Libnames.global_reference let compare (inst1,id1) (inst2,id2)= (compare_instance =? compare_gr) inst2 inst1 id2 id1 (* we want a __decreasing__ total order *) end module IS=Set.Make(OrderedInstance) let make_simple_atoms seq= let ratoms= match seq.glatom with Some t->[t] | None->[] in {negative=seq.latoms;positive=ratoms} let do_sequent setref triv id seq i dom atoms= let flag=ref true in let phref=ref triv in let do_atoms a1 a2 = let do_pair t1 t2 = match unif_atoms i dom t1 t2 with None->() | Some (Phantom _) ->phref:=true | Some c ->flag:=false;setref:=IS.add (c,id) !setref in List.iter (fun t->List.iter (do_pair t) a2.negative) a1.positive; List.iter (fun t->List.iter (do_pair t) a2.positive) a1.negative in HP.iter (fun lf->do_atoms atoms lf.atoms) seq.redexes; do_atoms atoms (make_simple_atoms seq); !flag && !phref let match_one_quantified_hyp setref seq lf= match lf.pat with Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))-> if do_sequent setref triv lf.id seq i dom lf.atoms then setref:=IS.add ((Phantom dom),lf.id) !setref | _ ->anomaly "can't happen" let give_instances lf seq= let setref=ref IS.empty in List.iter (match_one_quantified_hyp setref seq) lf; IS.elements !setref (* collector for the engine *) let rec collect_quantified seq= try let hd,seq1=take_formula seq in (match hd.pat with Left(Lforall(_,_,_)) | Right(Rexists(_,_,_)) -> let (q,seq2)=collect_quantified seq1 in ((hd::q),seq2) | _->[],seq) with Heap.EmptyHeap -> [],seq (* open instances processor *) let dummy_constr=mkMeta (-1) let dummy_bvid=id_of_string "x" let mk_open_instance id gl m t= let env=pf_env gl in let evmap=Refiner.project gl in let var_id= if id==dummy_id then dummy_bvid else let typ=pf_type_of gl (constr_of_global id) in (* since we know we will get a product, reduction is not too expensive *) let (nam,_,_)=destProd (whd_betadeltaiota env evmap typ) in match nam with Name id -> id | Anonymous -> dummy_bvid in let revt=substl (list_tabulate (fun i->mkRel (m-i)) m) t in let rec aux n avoid= if n=0 then [] else let nid=(fresh_id avoid var_id gl) in (Name nid,None,dummy_constr)::(aux (n-1) (nid::avoid)) in let nt=it_mkLambda_or_LetIn revt (aux m []) in let rawt=Detyping.detype false [] [] nt in let rec raux n t= if n=0 then t else match t with GLambda(loc,name,k,_,t0)-> let t1=raux (n-1) t0 in GLambda(loc,name,k,GHole (dummy_loc,Evd.BinderType name),t1) | _-> anomaly "can't happen" in let ntt=try Pretyping.Default.understand evmap env (raux m rawt) with e when Errors.noncritical e -> error "Untypable instance, maybe higher-order non-prenex quantification" in decompose_lam_n_assum m ntt (* tactics *) let left_instance_tac (inst,id) continue seq= match inst with Phantom dom-> if lookup (id,None) seq then tclFAIL 0 (Pp.str "already done") else tclTHENS (cut dom) [tclTHENLIST [introf; (fun gls->generalize [mkApp(constr_of_global id, [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls); introf; tclSOLVE [wrap 1 false continue (deepen (record (id,None) seq))]]; tclTRY assumption] | Real((m,t) as c,_)-> if lookup (id,Some c) seq then tclFAIL 0 (Pp.str "already done") else let special_generalize= if m>0 then fun gl-> let (rc,ot)= mk_open_instance id gl m t in let gt= it_mkLambda_or_LetIn (mkApp(constr_of_global id,[|ot|])) rc in generalize [gt] gl else generalize [mkApp(constr_of_global id,[|t|])] in tclTHENLIST [special_generalize; introf; tclSOLVE [wrap 1 false continue (deepen (record (id,Some c) seq))]] let right_instance_tac inst continue seq= match inst with Phantom dom -> tclTHENS (cut dom) [tclTHENLIST [introf; (fun gls-> split (Glob_term.ImplicitBindings [mkVar (Tacmach.pf_nth_hyp_id gls 1)]) gls); tclSOLVE [wrap 0 true continue (deepen seq)]]; tclTRY assumption] | Real ((0,t),_) -> (tclTHEN (split (Glob_term.ImplicitBindings [t])) (tclSOLVE [wrap 0 true continue (deepen seq)])) | Real ((m,t),_) -> tclFAIL 0 (Pp.str "not implemented ... yet") let instance_tac inst= if (snd inst)==dummy_id then right_instance_tac (fst inst) else left_instance_tac inst let quantified_tac lf backtrack continue seq gl= let insts=give_instances lf seq in tclORELSE (tclFIRST (List.map (fun inst->instance_tac inst continue seq) insts)) backtrack gl coq-8.4pl4/plugins/firstorder/rules.ml0000644000175000017500000001404012326224777017162 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* tactic) -> Sequent.t -> tactic type lseqtac= global_reference -> seqtac type 'a with_backtracking = tactic -> 'a let wrap n b continue seq gls= check_for_interrupt (); let nc=pf_hyps gls in let env=pf_env gls in let rec aux i nc ctx= if i<=0 then seq else match nc with []->anomaly "Not the expected number of hyps" | ((id,_,typ) as nd)::q-> if occur_var env id (pf_concl gls) || List.exists (occur_var_in_decl env id) ctx then (aux (i-1) q (nd::ctx)) else add_formula Hyp (VarRef id) typ (aux (i-1) q (nd::ctx)) gls in let seq1=aux n nc [] in let seq2=if b then add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in continue seq2 gls let basename_of_global=function VarRef id->id | _->assert false let clear_global=function VarRef id->clear [id] | _->tclIDTAC (* connection rules *) let axiom_tac t seq= try exact_no_check (constr_of_global (find_left t seq)) with Not_found->tclFAIL 0 (Pp.str "No axiom link") let ll_atom_tac a backtrack id continue seq= tclIFTHENELSE (try tclTHENLIST [generalize [mkApp(constr_of_global id, [|constr_of_global (find_left a seq)|])]; clear_global id; intro] with Not_found->tclFAIL 0 (Pp.str "No link")) (wrap 1 false continue seq) backtrack (* right connectives rules *) let and_tac backtrack continue seq= tclIFTHENELSE simplest_split (wrap 0 true continue seq) backtrack let or_tac backtrack continue seq= tclORELSE (any_constructor false (Some (tclCOMPLETE (wrap 0 true continue seq)))) backtrack let arrow_tac backtrack continue seq= tclIFTHENELSE intro (wrap 1 true continue seq) (tclORELSE (tclTHEN introf (tclCOMPLETE (wrap 1 true continue seq))) backtrack) (* left connectives rules *) let left_and_tac ind backtrack id continue seq gls= let n=(construct_nhyps ind gls).(0) in tclIFTHENELSE (tclTHENLIST [simplest_elim (constr_of_global id); clear_global id; tclDO n intro]) (wrap n false continue seq) backtrack gls let left_or_tac ind backtrack id continue seq gls= let v=construct_nhyps ind gls in let f n= tclTHENLIST [clear_global id; tclDO n intro; wrap n false continue seq] in tclIFTHENSVELSE (simplest_elim (constr_of_global id)) (Array.map f v) backtrack gls let left_false_tac id= simplest_elim (constr_of_global id) (* left arrow connective rules *) (* We use this function for false, and, or, exists *) let ll_ind_tac ind largs backtrack id continue seq gl= let rcs=ind_hyps 0 ind largs gl in let vargs=Array.of_list largs in (* construire le terme H->B, le generaliser etc *) let myterm i= let rc=rcs.(i) in let p=List.length rc in let cstr=mkApp ((mkConstruct (ind,(i+1))),vargs) in let vars=Array.init p (fun j->mkRel (p-j)) in let capply=mkApp ((lift p cstr),vars) in let head=mkApp ((lift p (constr_of_global id)),[|capply|]) in it_mkLambda_or_LetIn head rc in let lp=Array.length rcs in let newhyps=list_tabulate myterm lp in tclIFTHENELSE (tclTHENLIST [generalize newhyps; clear_global id; tclDO lp intro]) (wrap lp false continue seq) backtrack gl let ll_arrow_tac a b c backtrack id continue seq= let cc=mkProd(Anonymous,a,(lift 1 b)) in let d=mkLambda (Anonymous,b, mkApp ((constr_of_global id), [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in tclORELSE (tclTHENS (cut c) [tclTHENLIST [introf; clear_global id; wrap 1 false continue seq]; tclTHENS (cut cc) [exact_no_check (constr_of_global id); tclTHENLIST [generalize [d]; clear_global id; introf; introf; tclCOMPLETE (wrap 2 true continue seq)]]]) backtrack (* quantifier rules (easy side) *) let forall_tac backtrack continue seq= tclORELSE (tclIFTHENELSE intro (wrap 0 true continue seq) (tclORELSE (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq))) backtrack)) (if !qflag then tclFAIL 0 (Pp.str "reversible in 1st order mode") else backtrack) let left_exists_tac ind backtrack id continue seq gls= let n=(construct_nhyps ind gls).(0) in tclIFTHENELSE (simplest_elim (constr_of_global id)) (tclTHENLIST [clear_global id; tclDO n intro; (wrap (n-1) false continue seq)]) backtrack gls let ll_forall_tac prod backtrack id continue seq= tclORELSE (tclTHENS (cut prod) [tclTHENLIST [intro; (fun gls-> let id0=pf_nth_hyp_id gls 1 in let term=mkApp((constr_of_global id),[|mkVar(id0)|]) in tclTHEN (generalize [term]) (clear [id0]) gls); clear_global id; intro; tclCOMPLETE (wrap 1 false continue (deepen seq))]; tclCOMPLETE (wrap 0 true continue (deepen seq))]) backtrack (* rules for instantiation with unification moved to instances.ml *) (* special for compatibility with old Intuition *) let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str let defined_connectives=lazy [all_occurrences,EvalConstRef (destConst (constant "not")); all_occurrences,EvalConstRef (destConst (constant "iff"))] let normalize_evaluables= onAllHypsAndConcl (function None->unfold_in_concl (Lazy.force defined_connectives) | Some id -> unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly)) coq-8.4pl4/plugins/firstorder/unify.mli0000644000175000017500000000160712326224777017340 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> (int*constr) list type instance= Real of (int*constr)*int (* nb trous*terme*valeur heuristique *) | Phantom of constr (* domaine de quantification *) val unif_atoms : metavariable -> constr -> constr -> constr -> instance option val more_general : (int*constr) -> (int*constr) -> bool coq-8.4pl4/plugins/firstorder/unify.ml0000644000175000017500000001023312326224777017162 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (n,subst_meta [i,t] tn)) !sigma) in let rec head_reduce t= (* forbids non-sigma-normal meta in head position*) match kind_of_term t with Meta i-> (try head_reduce (List.assoc i !sigma) with Not_found->t) | _->t in Queue.add (t1,t2) bige; try while true do let t1,t2=Queue.take bige in let nt1=head_reduce (whd_betaiotazeta Evd.empty t1) and nt2=head_reduce (whd_betaiotazeta Evd.empty t2) in match (kind_of_term nt1),(kind_of_term nt2) with Meta i,Meta j-> if i<>j then if i let t=subst_meta !sigma nt2 in if Intset.is_empty (free_rels t) && not (occur_term (mkMeta i) t) then bind i t else raise (UFAIL(nt1,nt2)) | _,Meta i -> let t=subst_meta !sigma nt1 in if Intset.is_empty (free_rels t) && not (occur_term (mkMeta i) t) then bind i t else raise (UFAIL(nt1,nt2)) | Cast(_,_,_),_->Queue.add (strip_outer_cast nt1,nt2) bige | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast nt2) bige | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> Queue.add (a,c) bige;Queue.add (pop b,pop d) bige | Case (_,pa,ca,va),Case (_,pb,cb,vb)-> Queue.add (pa,pb) bige; Queue.add (ca,cb) bige; let l=Array.length va in if l<>(Array.length vb) then raise (UFAIL (nt1,nt2)) else for i=0 to l-1 do Queue.add (va.(i),vb.(i)) bige done | App(ha,va),App(hb,vb)-> Queue.add (ha,hb) bige; let l=Array.length va in if l<>(Array.length vb) then raise (UFAIL (nt1,nt2)) else for i=0 to l-1 do Queue.add (va.(i),vb.(i)) bige done | _->if not (eq_constr nt1 nt2) then raise (UFAIL (nt1,nt2)) done; assert false (* this place is unreachable but needed for the sake of typing *) with Queue.Empty-> !sigma let value i t= let add x y= if x<0 then y else if y<0 then x else x+y in let rec vaux term= if isMeta term && destMeta term = i then 0 else let f v t=add v (vaux t) in let vr=fold_constr f (-1) term in if vr<0 then -1 else vr+1 in vaux t type instance= Real of (int*constr)*int | Phantom of constr let mk_rel_inst t= let new_rel=ref 1 in let rel_env=ref [] in let rec renum_rec d t= match kind_of_term t with Meta n-> (try mkRel (d+(List.assoc n !rel_env)) with Not_found-> let m= !new_rel in incr new_rel; rel_env:=(n,m) :: !rel_env; mkRel (m+d)) | _ -> map_constr_with_binders succ renum_rec d t in let nt=renum_rec 0 t in (!new_rel - 1,nt) let unif_atoms i dom t1 t2= try let t=List.assoc i (unif t1 t2) in if isMeta t then Some (Phantom dom) else Some (Real(mk_rel_inst t,value i t1)) with UFAIL(_,_) ->None | Not_found ->Some (Phantom dom) let renum_metas_from k n t= (* requires n = max (free_rels t) *) let l=list_tabulate (fun i->mkMeta (k+i)) n in substl l t let more_general (m1,t1) (m2,t2)= let mt1=renum_metas_from 0 m1 t1 and mt2=renum_metas_from m1 m2 t2 in try let sigma=unif mt1 mt2 in let p (n,t)= nfalse coq-8.4pl4/plugins/firstorder/formula.mli0000644000175000017500000000404212326224777017647 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a -> int) -> ('b -> 'b -> int) -> 'a -> 'a -> 'b -> 'b -> int val (==?) : ('a -> 'a -> 'b ->'b -> int) -> ('c -> 'c -> int) -> 'a -> 'a -> 'b -> 'b -> 'c ->'c -> int type ('a,'b) sum = Left of 'a | Right of 'b type counter = bool -> metavariable val construct_nhyps : inductive -> Proof_type.goal Tacmach.sigma -> int array val ind_hyps : int -> inductive -> constr list -> Proof_type.goal Tacmach.sigma -> rel_context array type atoms = {positive:constr list;negative:constr list} type side = Hyp | Concl | Hint val dummy_id: global_reference val build_atoms : Proof_type.goal Tacmach.sigma -> counter -> side -> constr -> bool * atoms type right_pattern = Rarrow | Rand | Ror | Rfalse | Rforall | Rexists of metavariable*constr*bool type left_arrow_pattern= LLatom | LLfalse of inductive*constr list | LLand of inductive*constr list | LLor of inductive*constr list | LLforall of constr | LLexists of inductive*constr list | LLarrow of constr*constr*constr type left_pattern= Lfalse | Land of inductive | Lor of inductive | Lforall of metavariable*constr*bool | Lexists of inductive | LA of constr*left_arrow_pattern type t={id: global_reference; constr: constr; pat: (left_pattern,right_pattern) sum; atoms: atoms} (*exception Is_atom of constr*) val build_formula : side -> global_reference -> types -> Proof_type.goal Tacmach.sigma -> counter -> (t,types) sum coq-8.4pl4/plugins/firstorder/sequent.ml0000644000175000017500000001350312326224777017517 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* if b then incr cnt;!cnt let priority = (* pure heuristics, <=0 for non reversible *) function Right rf-> begin match rf with Rarrow -> 100 | Rand -> 40 | Ror -> -15 | Rfalse -> -50 | Rforall -> 100 | Rexists (_,_,_) -> -29 end | Left lf -> match lf with Lfalse -> 999 | Land _ -> 90 | Lor _ -> 40 | Lforall (_,_,_) -> -30 | Lexists _ -> 60 | LA(_,lap) -> match lap with LLatom -> 0 | LLfalse (_,_) -> 100 | LLand (_,_) -> 80 | LLor (_,_) -> 70 | LLforall _ -> -20 | LLexists (_,_) -> 50 | LLarrow (_,_,_) -> -10 let left_reversible lpat=(priority lpat)>0 module OrderedFormula= struct type t=Formula.t let compare e1 e2= (priority e1.pat) - (priority e2.pat) end module OrderedConstr= struct type t=constr let compare=constr_ord end type h_item = global_reference * (int*constr) option module Hitem= struct type t = h_item let compare (id1,co1) (id2,co2)= (Libnames.RefOrdered.compare =? (fun oc1 oc2 -> match oc1,oc2 with Some (m1,c1),Some (m2,c2) -> ((-) =? OrderedConstr.compare) m1 m2 c1 c2 | _,_->Pervasives.compare oc1 oc2)) id1 id2 co1 co2 end module CM=Map.Make(OrderedConstr) module History=Set.Make(Hitem) let cm_add typ nam cm= try let l=CM.find typ cm in CM.add typ (nam::l) cm with Not_found->CM.add typ [nam] cm let cm_remove typ nam cm= try let l=CM.find typ cm in let l0=List.filter (fun id->id<>nam) l in match l0 with []->CM.remove typ cm | _ ->CM.add typ l0 cm with Not_found ->cm module HP=Heap.Functional(OrderedFormula) type t= {redexes:HP.t; context:(global_reference list) CM.t; latoms:constr list; gl:types; glatom:constr option; cnt:counter; history:History.t; depth:int} let deepen seq={seq with depth=seq.depth-1} let record item seq={seq with history=History.add item seq.history} let lookup item seq= History.mem item seq.history || match item with (_,None)->false | (id,Some ((m,t) as c))-> let p (id2,o)= match o with None -> false | Some ((m2,t2) as c2)->id=id2 && m2>m && more_general c2 c in History.exists p seq.history let rec add_formula side nam t seq gl= match build_formula side nam t gl seq.cnt with Left f-> begin match side with Concl -> {seq with redexes=HP.add f seq.redexes; gl=f.constr; glatom=None} | _ -> {seq with redexes=HP.add f seq.redexes; context=cm_add f.constr nam seq.context} end | Right t-> match side with Concl -> {seq with gl=t;glatom=Some t} | _ -> {seq with context=cm_add t nam seq.context; latoms=t::seq.latoms} let re_add_formula_list lf seq= let do_one f cm= if f.id == dummy_id then cm else cm_add f.constr f.id cm in {seq with redexes=List.fold_right HP.add lf seq.redexes; context=List.fold_right do_one lf seq.context} let find_left t seq=List.hd (CM.find t seq.context) (*let rev_left seq= try let lpat=(HP.maximum seq.redexes).pat in left_reversible lpat with Heap.EmptyHeap -> false *) let no_formula seq= seq.redexes=HP.empty let rec take_formula seq= let hd=HP.maximum seq.redexes and hp=HP.remove seq.redexes in if hd.id == dummy_id then let nseq={seq with redexes=hp} in if seq.gl==hd.constr then hd,nseq else take_formula nseq (* discarding deprecated goal *) else hd,{seq with redexes=hp; context=cm_remove hd.constr hd.id seq.context} let empty_seq depth= {redexes=HP.empty; context=CM.empty; latoms=[]; gl=(mkMeta 1); glatom=None; cnt=newcnt (); history=History.empty; depth=depth} let expand_constructor_hints = list_map_append (function | IndRef ind -> list_tabulate (fun i -> ConstructRef (ind,i+1)) (Inductiveops.nconstructors ind) | gr -> [gr]) let extend_with_ref_list l seq gl= let l = expand_constructor_hints l in let f gr seq= let c=constr_of_global gr in let typ=(pf_type_of gl c) in add_formula Hyp gr typ seq gl in List.fold_right f l seq open Auto let extend_with_auto_hints l seq gl= let seqref=ref seq in let f p_a_t = match p_a_t.code with Res_pf (c,_) | Give_exact c | Res_pf_THEN_trivial_fail (c,_) -> (try let gr=global_of_constr c in let typ=(pf_type_of gl c) in seqref:=add_formula Hint gr typ !seqref gl with Not_found->()) | _-> () in let g _ l = List.iter f l in let h dbname= let hdb= try searchtable_map dbname with Not_found-> error ("Firstorder: "^dbname^" : No such Hint database") in Hint_db.iter g hdb in List.iter h l; !seqref let print_cmap map= let print_entry c l s= let xc=Constrextern.extern_constr false (Global.env ()) c in str "| " ++ Util.prlist Printer.pr_global l ++ str " : " ++ Ppconstr.pr_constr_expr xc ++ cut () ++ s in msgnl (v 0 (str "-----" ++ cut () ++ CM.fold print_entry map (mt ()) ++ str "-----")) coq-8.4pl4/plugins/firstorder/instances.mli0000644000175000017500000000146012326224777020172 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Formula.t list * Sequent.t val give_instances : Formula.t list -> Sequent.t -> (Unify.instance * global_reference) list val quantified_tac : Formula.t list -> seqtac with_backtracking coq-8.4pl4/plugins/firstorder/formula.ml0000644000175000017500000001677212326224777017513 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* metavariable exception Is_atom of constr let meta_succ m = m+1 let rec nb_prod_after n c= match kind_of_term c with | Prod (_,_,b) ->if n>0 then nb_prod_after (n-1) b else 1+(nb_prod_after 0 b) | _ -> 0 let construct_nhyps ind gls = let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in let hyp = nb_prod_after nparams in Array.map hyp constr_types (* indhyps builds the array of arrays of constructor hyps for (ind largs)*) let ind_hyps nevar ind largs gls= let types= Inductiveops.arities_of_constructors (pf_env gls) ind in let lp=Array.length types in let myhyps i= let t1=Term.prod_applist types.(i) largs in let t2=snd (decompose_prod_n_assum nevar t1) in fst (decompose_prod_assum t2) in Array.init lp myhyps let special_nf gl= let infos=Closure.create_clos_infos !red_flags (pf_env gl) in (fun t -> Closure.norm_val infos (Closure.inject t)) let special_whd gl= let infos=Closure.create_clos_infos !red_flags (pf_env gl) in (fun t -> Closure.whd_val infos (Closure.inject t)) type kind_of_formula= Arrow of constr*constr | False of inductive*constr list | And of inductive*constr list*bool | Or of inductive*constr list*bool | Exists of inductive*constr list | Forall of constr*constr | Atom of constr let rec kind_of_formula gl term = let normalize=special_nf gl in let cciterm=special_whd gl term in match match_with_imp_term cciterm with Some (a,b)-> Arrow(a,(pop b)) |_-> match match_with_forall_term cciterm with Some (_,a,b)-> Forall(a,b) |_-> match match_with_nodep_ind cciterm with Some (i,l,n)-> let ind=destInd i in let (mib,mip) = Global.lookup_inductive ind in let nconstr=Array.length mip.mind_consnames in if nconstr=0 then False(ind,l) else let has_realargs=(n>0) in let is_trivial= let is_constant c = nb_prod c = mib.mind_nparams in array_exists is_constant mip.mind_nf_lc in if Inductiveops.mis_is_recursive (ind,mib,mip) || (has_realargs && not is_trivial) then Atom cciterm else if nconstr=1 then And(ind,l,is_trivial) else Or(ind,l,is_trivial) | _ -> match match_with_sigma_type cciterm with Some (i,l)-> Exists((destInd i),l) |_-> Atom (normalize cciterm) type atoms = {positive:constr list;negative:constr list} type side = Hyp | Concl | Hint let no_atoms = (false,{positive=[];negative=[]}) let dummy_id=VarRef (id_of_string "_") (* "_" cannot be parsed *) let build_atoms gl metagen side cciterm = let trivial =ref false and positive=ref [] and negative=ref [] in let normalize=special_nf gl in let rec build_rec env polarity cciterm= match kind_of_formula gl cciterm with False(_,_)->if not polarity then trivial:=true | Arrow (a,b)-> build_rec env (not polarity) a; build_rec env polarity b | And(i,l,b) | Or(i,l,b)-> if b then begin let unsigned=normalize (substnl env 0 cciterm) in if polarity then positive:= unsigned :: !positive else negative:= unsigned :: !negative end; let v = ind_hyps 0 i l gl in let g i _ (_,_,t) = build_rec env polarity (lift i t) in let f l = list_fold_left_i g (1-(List.length l)) () l in if polarity && (* we have a constant constructor *) array_exists (function []->true|_->false) v then trivial:=true; Array.iter f v | Exists(i,l)-> let var=mkMeta (metagen true) in let v =(ind_hyps 1 i l gl).(0) in let g i _ (_,_,t) = build_rec (var::env) polarity (lift i t) in list_fold_left_i g (2-(List.length l)) () v | Forall(_,b)-> let var=mkMeta (metagen true) in build_rec (var::env) polarity b | Atom t-> let unsigned=substnl env 0 t in if not (isMeta unsigned) then (* discarding wildcard atoms *) if polarity then positive:= unsigned :: !positive else negative:= unsigned :: !negative in begin match side with Concl -> build_rec [] true cciterm | Hyp -> build_rec [] false cciterm | Hint -> let rels,head=decompose_prod cciterm in let env=List.rev (List.map (fun _->mkMeta (metagen true)) rels) in build_rec env false head;trivial:=false (* special for hints *) end; (!trivial, {positive= !positive; negative= !negative}) type right_pattern = Rarrow | Rand | Ror | Rfalse | Rforall | Rexists of metavariable*constr*bool type left_arrow_pattern= LLatom | LLfalse of inductive*constr list | LLand of inductive*constr list | LLor of inductive*constr list | LLforall of constr | LLexists of inductive*constr list | LLarrow of constr*constr*constr type left_pattern= Lfalse | Land of inductive | Lor of inductive | Lforall of metavariable*constr*bool | Lexists of inductive | LA of constr*left_arrow_pattern type t={id:global_reference; constr:constr; pat:(left_pattern,right_pattern) sum; atoms:atoms} let build_formula side nam typ gl metagen= let normalize = special_nf gl in try let m=meta_succ(metagen false) in let trivial,atoms= if !qflag then build_atoms gl metagen side typ else no_atoms in let pattern= match side with Concl -> let pat= match kind_of_formula gl typ with False(_,_) -> Rfalse | Atom a -> raise (Is_atom a) | And(_,_,_) -> Rand | Or(_,_,_) -> Ror | Exists (i,l) -> let (_,_,d)=list_last (ind_hyps 0 i l gl).(0) in Rexists(m,d,trivial) | Forall (_,a) -> Rforall | Arrow (a,b) -> Rarrow in Right pat | _ -> let pat= match kind_of_formula gl typ with False(i,_) -> Lfalse | Atom a -> raise (Is_atom a) | And(i,_,b) -> if b then let nftyp=normalize typ in raise (Is_atom nftyp) else Land i | Or(i,_,b) -> if b then let nftyp=normalize typ in raise (Is_atom nftyp) else Lor i | Exists (ind,_) -> Lexists ind | Forall (d,_) -> Lforall(m,d,trivial) | Arrow (a,b) -> let nfa=normalize a in LA (nfa, match kind_of_formula gl a with False(i,l)-> LLfalse(i,l) | Atom t-> LLatom | And(i,l,_)-> LLand(i,l) | Or(i,l,_)-> LLor(i,l) | Arrow(a,c)-> LLarrow(a,c,b) | Exists(i,l)->LLexists(i,l) | Forall(_,_)->LLforall a) in Left pat in Left {id=nam; constr=normalize typ; pat=pattern; atoms=atoms} with Is_atom a-> Right a (* already in nf *) coq-8.4pl4/plugins/firstorder/ground_plugin.mllib0000644000175000017500000000011012326224777021364 0ustar stephstephFormula Unify Sequent Rules Instances Ground G_ground Ground_plugin_mod coq-8.4pl4/plugins/firstorder/rules.mli0000644000175000017500000000306212326224777017335 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* tactic) -> Sequent.t -> tactic type lseqtac= global_reference -> seqtac type 'a with_backtracking = tactic -> 'a val wrap : int -> bool -> seqtac val basename_of_global: global_reference -> identifier val clear_global: global_reference -> tactic val axiom_tac : constr -> Sequent.t -> tactic val ll_atom_tac : constr -> lseqtac with_backtracking val and_tac : seqtac with_backtracking val or_tac : seqtac with_backtracking val arrow_tac : seqtac with_backtracking val left_and_tac : inductive -> lseqtac with_backtracking val left_or_tac : inductive -> lseqtac with_backtracking val left_false_tac : global_reference -> tactic val ll_ind_tac : inductive -> constr list -> lseqtac with_backtracking val ll_arrow_tac : constr -> constr -> constr -> lseqtac with_backtracking val forall_tac : seqtac with_backtracking val left_exists_tac : inductive -> lseqtac with_backtracking val ll_forall_tac : types -> lseqtac with_backtracking val normalize_evaluables : tactic coq-8.4pl4/plugins/ring/0000755000175000017500000000000012365131025014235 5ustar stephstephcoq-8.4pl4/plugins/ring/Ring_normalize.v0000644000175000017500000006272712326224777017437 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* n = m. Proof. intros. apply index_eq_prop. generalize H. case (index_eq n m); simpl; trivial; intros. contradiction. Qed. Section semi_rings. Variable A : Type. Variable Aplus : A -> A -> A. Variable Amult : A -> A -> A. Variable Aone : A. Variable Azero : A. Variable Aeq : A -> A -> bool. (* Section definitions. *) (******************************************) (* Normal abtract Polynomials *) (******************************************) (* DEFINITIONS : - A varlist is a sorted product of one or more variables : x, x*y*z - A monom is a constant, a varlist or the product of a constant by a varlist variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT. - A canonical sum is either a monom or an ordered sum of monoms (the order on monoms is defined later) - A normal polynomial it either a constant or a canonical sum or a constant plus a canonical sum *) (* varlist is isomorphic to (list var), but we built a special inductive for efficiency *) Inductive varlist : Type := | Nil_var : varlist | Cons_var : index -> varlist -> varlist. Inductive canonical_sum : Type := | Nil_monom : canonical_sum | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum | Cons_varlist : varlist -> canonical_sum -> canonical_sum. (* Order on monoms *) (* That's the lexicographic order on varlist, extended by : - A constant is less than every monom - The relation between two varlist is preserved by multiplication by a constant. Examples : 3 < x < y x*y < x*y*y*z 2*x*y < x*y*y*z x*y < 54*x*y*y*z 4*x*y < 59*x*y*y*z *) Fixpoint varlist_eq (x y:varlist) {struct y} : bool := match x, y with | Nil_var, Nil_var => true | Cons_var i xrest, Cons_var j yrest => andb (index_eq i j) (varlist_eq xrest yrest) | _, _ => false end. Fixpoint varlist_lt (x y:varlist) {struct y} : bool := match x, y with | Nil_var, Cons_var _ _ => true | Cons_var i xrest, Cons_var j yrest => if index_lt i j then true else andb (index_eq i j) (varlist_lt xrest yrest) | _, _ => false end. (* merges two variables lists *) Fixpoint varlist_merge (l1:varlist) : varlist -> varlist := match l1 with | Cons_var v1 t1 => (fix vm_aux (l2:varlist) : varlist := match l2 with | Cons_var v2 t2 => if index_lt v1 v2 then Cons_var v1 (varlist_merge t1 l2) else Cons_var v2 (vm_aux t2) | Nil_var => l1 end) | Nil_var => fun l2 => l2 end. (* returns the sum of two canonical sums *) Fixpoint canonical_sum_merge (s1:canonical_sum) : canonical_sum -> canonical_sum := match s1 with | Cons_monom c1 l1 t1 => (fix csm_aux (s2:canonical_sum) : canonical_sum := match s2 with | Cons_monom c2 l2 t2 => if varlist_eq l1 l2 then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2) else if varlist_lt l1 l2 then Cons_monom c1 l1 (canonical_sum_merge t1 s2) else Cons_monom c2 l2 (csm_aux t2) | Cons_varlist l2 t2 => if varlist_eq l1 l2 then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2) else if varlist_lt l1 l2 then Cons_monom c1 l1 (canonical_sum_merge t1 s2) else Cons_varlist l2 (csm_aux t2) | Nil_monom => s1 end) | Cons_varlist l1 t1 => (fix csm_aux2 (s2:canonical_sum) : canonical_sum := match s2 with | Cons_monom c2 l2 t2 => if varlist_eq l1 l2 then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2) else if varlist_lt l1 l2 then Cons_varlist l1 (canonical_sum_merge t1 s2) else Cons_monom c2 l2 (csm_aux2 t2) | Cons_varlist l2 t2 => if varlist_eq l1 l2 then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2) else if varlist_lt l1 l2 then Cons_varlist l1 (canonical_sum_merge t1 s2) else Cons_varlist l2 (csm_aux2 t2) | Nil_monom => s1 end) | Nil_monom => fun s2 => s2 end. (* Insertion of a monom in a canonical sum *) Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} : canonical_sum := match s2 with | Cons_monom c2 l2 t2 => if varlist_eq l1 l2 then Cons_monom (Aplus c1 c2) l1 t2 else if varlist_lt l1 l2 then Cons_monom c1 l1 s2 else Cons_monom c2 l2 (monom_insert c1 l1 t2) | Cons_varlist l2 t2 => if varlist_eq l1 l2 then Cons_monom (Aplus c1 Aone) l1 t2 else if varlist_lt l1 l2 then Cons_monom c1 l1 s2 else Cons_varlist l2 (monom_insert c1 l1 t2) | Nil_monom => Cons_monom c1 l1 Nil_monom end. Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} : canonical_sum := match s2 with | Cons_monom c2 l2 t2 => if varlist_eq l1 l2 then Cons_monom (Aplus Aone c2) l1 t2 else if varlist_lt l1 l2 then Cons_varlist l1 s2 else Cons_monom c2 l2 (varlist_insert l1 t2) | Cons_varlist l2 t2 => if varlist_eq l1 l2 then Cons_monom (Aplus Aone Aone) l1 t2 else if varlist_lt l1 l2 then Cons_varlist l1 s2 else Cons_varlist l2 (varlist_insert l1 t2) | Nil_monom => Cons_varlist l1 Nil_monom end. (* Computes c0*s *) Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} : canonical_sum := match s with | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t) | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t) | Nil_monom => Nil_monom end. (* Computes l0*s *) Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} : canonical_sum := match s with | Cons_monom c l t => monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t) | Cons_varlist l t => varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t) | Nil_monom => Nil_monom end. (* Computes c0*l0*s *) Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) (s:canonical_sum) {struct s} : canonical_sum := match s with | Cons_monom c l t => monom_insert (Amult c0 c) (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t) | Cons_varlist l t => monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t) | Nil_monom => Nil_monom end. (* returns the product of two canonical sums *) Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} : canonical_sum := match s1 with | Cons_monom c1 l1 t1 => canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2) (canonical_sum_prod t1 s2) | Cons_varlist l1 t1 => canonical_sum_merge (canonical_sum_scalar2 l1 s2) (canonical_sum_prod t1 s2) | Nil_monom => Nil_monom end. (* The type to represent concrete semi-ring polynomials *) Inductive spolynomial : Type := | SPvar : index -> spolynomial | SPconst : A -> spolynomial | SPplus : spolynomial -> spolynomial -> spolynomial | SPmult : spolynomial -> spolynomial -> spolynomial. Fixpoint spolynomial_normalize (p:spolynomial) : canonical_sum := match p with | SPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom | SPconst c => Cons_monom c Nil_var Nil_monom | SPplus l r => canonical_sum_merge (spolynomial_normalize l) (spolynomial_normalize r) | SPmult l r => canonical_sum_prod (spolynomial_normalize l) (spolynomial_normalize r) end. (* Deletion of useless 0 and 1 in canonical sums *) Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum := match s with | Cons_monom c l t => if Aeq c Azero then canonical_sum_simplify t else if Aeq c Aone then Cons_varlist l (canonical_sum_simplify t) else Cons_monom c l (canonical_sum_simplify t) | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t) | Nil_monom => Nil_monom end. Definition spolynomial_simplify (x:spolynomial) := canonical_sum_simplify (spolynomial_normalize x). (* End definitions. *) (* Section interpretation. *) (*** Here a variable map is defined and the interpetation of a spolynom acording to a certain variables map. Once again the choosen definition is generic and could be changed ****) Variable vm : varmap A. (* Interpretation of list of variables * [x1; ... ; xn ] is interpreted as (find v x1)* ... *(find v xn) * The unbound variables are mapped to 0. Normally this case sould * never occur. Since we want only to prove correctness theorems, which form * is : for any varmap and any spolynom ... this is a safe and pain-saving * choice *) Definition interp_var (i:index) := varmap_find Azero i vm. (* Local *) Definition ivl_aux := (fix ivl_aux (x:index) (t:varlist) {struct t} : A := match t with | Nil_var => interp_var x | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t') end). Definition interp_vl (l:varlist) := match l with | Nil_var => Aone | Cons_var x t => ivl_aux x t end. (* Local *) Definition interp_m (c:A) (l:varlist) := match l with | Nil_var => c | Cons_var x t => Amult c (ivl_aux x t) end. (* Local *) Definition ics_aux := (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A := match s with | Nil_monom => a | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t) | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t) end). (* Interpretation of a canonical sum *) Definition interp_cs (s:canonical_sum) : A := match s with | Nil_monom => Azero | Cons_varlist l t => ics_aux (interp_vl l) t | Cons_monom c l t => ics_aux (interp_m c l) t end. Fixpoint interp_sp (p:spolynomial) : A := match p with | SPconst c => c | SPvar i => interp_var i | SPplus p1 p2 => Aplus (interp_sp p1) (interp_sp p2) | SPmult p1 p2 => Amult (interp_sp p1) (interp_sp p2) end. (* End interpretation. *) Unset Implicit Arguments. (* Section properties. *) Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq. Hint Resolve (SR_plus_comm T). Hint Resolve (SR_plus_assoc T). Hint Resolve (SR_plus_assoc2 T). Hint Resolve (SR_mult_comm T). Hint Resolve (SR_mult_assoc T). Hint Resolve (SR_mult_assoc2 T). Hint Resolve (SR_plus_zero_left T). Hint Resolve (SR_plus_zero_left2 T). Hint Resolve (SR_mult_one_left T). Hint Resolve (SR_mult_one_left2 T). Hint Resolve (SR_mult_zero_left T). Hint Resolve (SR_mult_zero_left2 T). Hint Resolve (SR_distr_left T). Hint Resolve (SR_distr_left2 T). (*Hint Resolve (SR_plus_reg_left T).*) Hint Resolve (SR_plus_permute T). Hint Resolve (SR_mult_permute T). Hint Resolve (SR_distr_right T). Hint Resolve (SR_distr_right2 T). Hint Resolve (SR_mult_zero_right T). Hint Resolve (SR_mult_zero_right2 T). Hint Resolve (SR_plus_zero_right T). Hint Resolve (SR_plus_zero_right2 T). Hint Resolve (SR_mult_one_right T). Hint Resolve (SR_mult_one_right2 T). (*Hint Resolve (SR_plus_reg_right T).*) Hint Resolve eq_refl eq_sym eq_trans. Hint Immediate T. Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y. Proof. simple induction x; simple induction y; contradiction || (try reflexivity). simpl; intros. generalize (andb_prop2 _ _ H1); intros; elim H2; intros. rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity. Qed. Remark ivl_aux_ok : forall (v:varlist) (i:index), ivl_aux i v = Amult (interp_var i) (interp_vl v). Proof. simple induction v; simpl; intros. trivial. rewrite H; trivial. Qed. Lemma varlist_merge_ok : forall x y:varlist, interp_vl (varlist_merge x y) = Amult (interp_vl x) (interp_vl y). Proof. simple induction x. simpl; trivial. simple induction y. simpl; trivial. simpl; intros. elim (index_lt i i0); simpl; intros. repeat rewrite ivl_aux_ok. rewrite H. simpl. rewrite ivl_aux_ok. eauto. repeat rewrite ivl_aux_ok. rewrite H0. rewrite ivl_aux_ok. eauto. Qed. Remark ics_aux_ok : forall (x:A) (s:canonical_sum), ics_aux x s = Aplus x (interp_cs s). Proof. simple induction s; simpl; intros. trivial. reflexivity. reflexivity. Qed. Remark interp_m_ok : forall (x:A) (l:varlist), interp_m x l = Amult x (interp_vl l). Proof. destruct l as [| i v]. simpl; trivial. reflexivity. Qed. Lemma canonical_sum_merge_ok : forall x y:canonical_sum, interp_cs (canonical_sum_merge x y) = Aplus (interp_cs x) (interp_cs y). simple induction x; simpl. trivial. simple induction y; simpl; intros. (* monom and nil *) eauto. (* monom and monom *) generalize (varlist_eq_prop v v0). elim (varlist_eq v v0). intros; rewrite (H1 I). simpl; repeat rewrite ics_aux_ok; rewrite H. repeat rewrite interp_m_ok. rewrite (SR_distr_left T). repeat rewrite <- (SR_plus_assoc T). apply f_equal with (f := Aplus (Amult a (interp_vl v0))). trivial. elim (varlist_lt v v0); simpl. repeat rewrite ics_aux_ok. rewrite H; simpl; rewrite ics_aux_ok; eauto. rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl; eauto. (* monom and varlist *) generalize (varlist_eq_prop v v0). elim (varlist_eq v v0). intros; rewrite (H1 I). simpl; repeat rewrite ics_aux_ok; rewrite H. repeat rewrite interp_m_ok. rewrite (SR_distr_left T). repeat rewrite <- (SR_plus_assoc T). apply f_equal with (f := Aplus (Amult a (interp_vl v0))). rewrite (SR_mult_one_left T). trivial. elim (varlist_lt v v0); simpl. repeat rewrite ics_aux_ok. rewrite H; simpl; rewrite ics_aux_ok; eauto. rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl; eauto. simple induction y; simpl; intros. (* varlist and nil *) trivial. (* varlist and monom *) generalize (varlist_eq_prop v v0). elim (varlist_eq v v0). intros; rewrite (H1 I). simpl; repeat rewrite ics_aux_ok; rewrite H. repeat rewrite interp_m_ok. rewrite (SR_distr_left T). repeat rewrite <- (SR_plus_assoc T). rewrite (SR_mult_one_left T). apply f_equal with (f := Aplus (interp_vl v0)). trivial. elim (varlist_lt v v0); simpl. repeat rewrite ics_aux_ok. rewrite H; simpl; rewrite ics_aux_ok; eauto. rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl; eauto. (* varlist and varlist *) generalize (varlist_eq_prop v v0). elim (varlist_eq v v0). intros; rewrite (H1 I). simpl; repeat rewrite ics_aux_ok; rewrite H. repeat rewrite interp_m_ok. rewrite (SR_distr_left T). repeat rewrite <- (SR_plus_assoc T). rewrite (SR_mult_one_left T). apply f_equal with (f := Aplus (interp_vl v0)). trivial. elim (varlist_lt v v0); simpl. repeat rewrite ics_aux_ok. rewrite H; simpl; rewrite ics_aux_ok; eauto. rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl; eauto. Qed. Lemma monom_insert_ok : forall (a:A) (l:varlist) (s:canonical_sum), interp_cs (monom_insert a l s) = Aplus (Amult a (interp_vl l)) (interp_cs s). intros; generalize s; simple induction s0. simpl; rewrite interp_m_ok; trivial. simpl; intros. generalize (varlist_eq_prop l v); elim (varlist_eq l v). intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok; repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T); eauto. elim (varlist_lt l v); simpl; [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; rewrite ics_aux_ok; eauto ]. simpl; intros. generalize (varlist_eq_prop l v); elim (varlist_eq l v). intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok; repeat rewrite ics_aux_ok; rewrite (SR_distr_left T); rewrite (SR_mult_one_left T); eauto. elim (varlist_lt l v); simpl; [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; rewrite ics_aux_ok; eauto ]. Qed. Lemma varlist_insert_ok : forall (l:varlist) (s:canonical_sum), interp_cs (varlist_insert l s) = Aplus (interp_vl l) (interp_cs s). intros; generalize s; simple induction s0. simpl; trivial. simpl; intros. generalize (varlist_eq_prop l v); elim (varlist_eq l v). intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok; repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T); rewrite (SR_mult_one_left T); eauto. elim (varlist_lt l v); simpl; [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; rewrite ics_aux_ok; eauto ]. simpl; intros. generalize (varlist_eq_prop l v); elim (varlist_eq l v). intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok; repeat rewrite ics_aux_ok; rewrite (SR_distr_left T); rewrite (SR_mult_one_left T); eauto. elim (varlist_lt l v); simpl; [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; rewrite ics_aux_ok; eauto ]. Qed. Lemma canonical_sum_scalar_ok : forall (a:A) (s:canonical_sum), interp_cs (canonical_sum_scalar a s) = Amult a (interp_cs s). simple induction s. simpl; eauto. simpl; intros. repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. rewrite H. rewrite (SR_distr_right T). repeat rewrite <- (SR_mult_assoc T). reflexivity. simpl; intros. repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. rewrite H. rewrite (SR_distr_right T). repeat rewrite <- (SR_mult_assoc T). reflexivity. Qed. Lemma canonical_sum_scalar2_ok : forall (l:varlist) (s:canonical_sum), interp_cs (canonical_sum_scalar2 l s) = Amult (interp_vl l) (interp_cs s). simple induction s. simpl; trivial. simpl; intros. rewrite monom_insert_ok. repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. rewrite H. rewrite varlist_merge_ok. repeat rewrite (SR_distr_right T). repeat rewrite <- (SR_mult_assoc T). repeat rewrite <- (SR_plus_assoc T). rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)). reflexivity. simpl; intros. rewrite varlist_insert_ok. repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. rewrite H. rewrite varlist_merge_ok. repeat rewrite (SR_distr_right T). repeat rewrite <- (SR_mult_assoc T). repeat rewrite <- (SR_plus_assoc T). reflexivity. Qed. Lemma canonical_sum_scalar3_ok : forall (c:A) (l:varlist) (s:canonical_sum), interp_cs (canonical_sum_scalar3 c l s) = Amult c (Amult (interp_vl l) (interp_cs s)). simple induction s. simpl; repeat rewrite (SR_mult_zero_right T); reflexivity. simpl; intros. rewrite monom_insert_ok. repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. rewrite H. rewrite varlist_merge_ok. repeat rewrite (SR_distr_right T). repeat rewrite <- (SR_mult_assoc T). repeat rewrite <- (SR_plus_assoc T). rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)). reflexivity. simpl; intros. rewrite monom_insert_ok. repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. rewrite H. rewrite varlist_merge_ok. repeat rewrite (SR_distr_right T). repeat rewrite <- (SR_mult_assoc T). repeat rewrite <- (SR_plus_assoc T). rewrite (SR_mult_permute T c (interp_vl l) (interp_vl v)). reflexivity. Qed. Lemma canonical_sum_prod_ok : forall x y:canonical_sum, interp_cs (canonical_sum_prod x y) = Amult (interp_cs x) (interp_cs y). simple induction x; simpl; intros. trivial. rewrite canonical_sum_merge_ok. rewrite canonical_sum_scalar3_ok. rewrite ics_aux_ok. rewrite interp_m_ok. rewrite H. rewrite (SR_mult_assoc T a (interp_vl v) (interp_cs y)). symmetry . eauto. rewrite canonical_sum_merge_ok. rewrite canonical_sum_scalar2_ok. rewrite ics_aux_ok. rewrite H. trivial. Qed. Theorem spolynomial_normalize_ok : forall p:spolynomial, interp_cs (spolynomial_normalize p) = interp_sp p. simple induction p; simpl; intros. reflexivity. reflexivity. rewrite canonical_sum_merge_ok. rewrite H; rewrite H0. reflexivity. rewrite canonical_sum_prod_ok. rewrite H; rewrite H0. reflexivity. Qed. Lemma canonical_sum_simplify_ok : forall s:canonical_sum, interp_cs (canonical_sum_simplify s) = interp_cs s. simple induction s. reflexivity. (* cons_monom *) simpl; intros. generalize (SR_eq_prop T a Azero). elim (Aeq a Azero). intro Heq; rewrite (Heq I). rewrite H. rewrite ics_aux_ok. rewrite interp_m_ok. rewrite (SR_mult_zero_left T). trivial. intros; simpl. generalize (SR_eq_prop T a Aone). elim (Aeq a Aone). intro Heq; rewrite (Heq I). simpl. repeat rewrite ics_aux_ok. rewrite interp_m_ok. rewrite H. rewrite (SR_mult_one_left T). reflexivity. simpl. repeat rewrite ics_aux_ok. rewrite interp_m_ok. rewrite H. reflexivity. (* cons_varlist *) simpl; intros. repeat rewrite ics_aux_ok. rewrite H. reflexivity. Qed. Theorem spolynomial_simplify_ok : forall p:spolynomial, interp_cs (spolynomial_simplify p) = interp_sp p. intro. unfold spolynomial_simplify. rewrite canonical_sum_simplify_ok. apply spolynomial_normalize_ok. Qed. (* End properties. *) End semi_rings. Arguments Cons_varlist : default implicits. Arguments Cons_monom : default implicits. Arguments SPconst : default implicits. Arguments SPplus : default implicits. Arguments SPmult : default implicits. Section rings. (* Here the coercion between Ring and Semi-Ring will be useful *) Set Implicit Arguments. Variable A : Type. Variable Aplus : A -> A -> A. Variable Amult : A -> A -> A. Variable Aone : A. Variable Azero : A. Variable Aopp : A -> A. Variable Aeq : A -> A -> bool. Variable vm : varmap A. Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq. Hint Resolve (Th_plus_comm T). Hint Resolve (Th_plus_assoc T). Hint Resolve (Th_plus_assoc2 T). Hint Resolve (Th_mult_comm T). Hint Resolve (Th_mult_assoc T). Hint Resolve (Th_mult_assoc2 T). Hint Resolve (Th_plus_zero_left T). Hint Resolve (Th_plus_zero_left2 T). Hint Resolve (Th_mult_one_left T). Hint Resolve (Th_mult_one_left2 T). Hint Resolve (Th_mult_zero_left T). Hint Resolve (Th_mult_zero_left2 T). Hint Resolve (Th_distr_left T). Hint Resolve (Th_distr_left2 T). (*Hint Resolve (Th_plus_reg_left T).*) Hint Resolve (Th_plus_permute T). Hint Resolve (Th_mult_permute T). Hint Resolve (Th_distr_right T). Hint Resolve (Th_distr_right2 T). Hint Resolve (Th_mult_zero_right T). Hint Resolve (Th_mult_zero_right2 T). Hint Resolve (Th_plus_zero_right T). Hint Resolve (Th_plus_zero_right2 T). Hint Resolve (Th_mult_one_right T). Hint Resolve (Th_mult_one_right2 T). (*Hint Resolve (Th_plus_reg_right T).*) Hint Resolve eq_refl eq_sym eq_trans. Hint Immediate T. (*** Definitions *) Inductive polynomial : Type := | Pvar : index -> polynomial | Pconst : A -> polynomial | Pplus : polynomial -> polynomial -> polynomial | Pmult : polynomial -> polynomial -> polynomial | Popp : polynomial -> polynomial. Fixpoint polynomial_normalize (x:polynomial) : canonical_sum A := match x with | Pplus l r => canonical_sum_merge Aplus Aone (polynomial_normalize l) (polynomial_normalize r) | Pmult l r => canonical_sum_prod Aplus Amult Aone (polynomial_normalize l) (polynomial_normalize r) | Pconst c => Cons_monom c Nil_var (Nil_monom A) | Pvar i => Cons_varlist (Cons_var i Nil_var) (Nil_monom A) | Popp p => canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var (polynomial_normalize p) end. Definition polynomial_simplify (x:polynomial) := canonical_sum_simplify Aone Azero Aeq (polynomial_normalize x). Fixpoint spolynomial_of (x:polynomial) : spolynomial A := match x with | Pplus l r => SPplus (spolynomial_of l) (spolynomial_of r) | Pmult l r => SPmult (spolynomial_of l) (spolynomial_of r) | Pconst c => SPconst c | Pvar i => SPvar A i | Popp p => SPmult (SPconst (Aopp Aone)) (spolynomial_of p) end. (*** Interpretation *) Fixpoint interp_p (p:polynomial) : A := match p with | Pconst c => c | Pvar i => varmap_find Azero i vm | Pplus p1 p2 => Aplus (interp_p p1) (interp_p p2) | Pmult p1 p2 => Amult (interp_p p1) (interp_p p2) | Popp p1 => Aopp (interp_p p1) end. (*** Properties *) Unset Implicit Arguments. Lemma spolynomial_of_ok : forall p:polynomial, interp_p p = interp_sp Aplus Amult Azero vm (spolynomial_of p). simple induction p; reflexivity || (simpl; intros). rewrite H; rewrite H0; reflexivity. rewrite H; rewrite H0; reflexivity. rewrite H. rewrite (Th_opp_mult_left2 T). rewrite (Th_mult_one_left T). reflexivity. Qed. Theorem polynomial_normalize_ok : forall p:polynomial, polynomial_normalize p = spolynomial_normalize Aplus Amult Aone (spolynomial_of p). simple induction p; reflexivity || (simpl; intros). rewrite H; rewrite H0; reflexivity. rewrite H; rewrite H0; reflexivity. rewrite H; simpl. elim (canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var (spolynomial_normalize Aplus Amult Aone (spolynomial_of p0))); [ reflexivity | simpl; intros; rewrite H0; reflexivity | simpl; intros; rewrite H0; reflexivity ]. Qed. Theorem polynomial_simplify_ok : forall p:polynomial, interp_cs Aplus Amult Aone Azero vm (polynomial_simplify p) = interp_p p. intro. unfold polynomial_simplify. rewrite spolynomial_of_ok. rewrite polynomial_normalize_ok. rewrite (canonical_sum_simplify_ok A Aplus Amult Aone Azero Aeq vm T). rewrite (spolynomial_normalize_ok A Aplus Amult Aone Azero Aeq vm T). reflexivity. Qed. End rings. Infix "+" := Pplus : ring_scope. Infix "*" := Pmult : ring_scope. Notation "- x" := (Popp x) : ring_scope. Notation "[ x ]" := (Pvar x) (at level 0) : ring_scope. Delimit Scope ring_scope with ring. coq-8.4pl4/plugins/ring/LegacyArithRing.v0000644000175000017500000000477112326224777017467 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | S n', S m' => nateq n' m' | _, _ => false end. Lemma nateq_prop : forall n m:nat, Is_true (nateq n m) -> n = m. Proof. simple induction n; simple induction m; intros; try contradiction. trivial. unfold Is_true in H1. rewrite (H n1 H1). trivial. Qed. Hint Resolve nateq_prop: arithring. Definition NatTheory : Semi_Ring_Theory plus mult 1 0 nateq. split; intros; auto with arith arithring. (* apply (fun n m p:nat => plus_reg_l m p n) with (n := n). trivial.*) Defined. Add Legacy Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ]. Goal forall n:nat, S n = 1 + n. intro; reflexivity. Save S_to_plus_one. (* Replace all occurrences of (S exp) by (plus (S O) exp), except when exp is already O and only for those occurrences than can be reached by going down plus and mult operations *) Ltac rewrite_S_to_plus_term t := match constr:t with | 1 => constr:1 | (S ?X1) => let t1 := rewrite_S_to_plus_term X1 in constr:(1 + t1) | (?X1 + ?X2) => let t1 := rewrite_S_to_plus_term X1 with t2 := rewrite_S_to_plus_term X2 in constr:(t1 + t2) | (?X1 * ?X2) => let t1 := rewrite_S_to_plus_term X1 with t2 := rewrite_S_to_plus_term X2 in constr:(t1 * t2) | _ => constr:t end. (* Apply S_to_plus on both sides of an equality *) Ltac rewrite_S_to_plus := match goal with | |- (?X1 = ?X2) => try let t1 := (**) (**) rewrite_S_to_plus_term X1 with t2 := rewrite_S_to_plus_term X2 in change (t1 = t2) | |- (?X1 = ?X2) => try let t1 := (**) (**) rewrite_S_to_plus_term X1 with t2 := rewrite_S_to_plus_term X2 in change (t1 = t2) end. Ltac ring_nat := rewrite_S_to_plus; ring. coq-8.4pl4/plugins/ring/ring_plugin.mllib0000644000175000017500000000003412326224777017606 0ustar stephstephRing G_ring Ring_plugin_mod coq-8.4pl4/plugins/ring/g_ring.ml40000644000175000017500000000730712326224777016145 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ polynom l ] END (* The vernac commands "Add Ring" and co *) let cset_of_constrarg_list l = List.fold_right ConstrSet.add (List.map constr_of l) ConstrSet.empty VERNAC COMMAND EXTEND AddRing [ "Add" "Legacy" "Ring" constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aopp) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] -> [ add_theory true false false (constr_of a) None None None (constr_of aplus) (constr_of amult) (constr_of aone) (constr_of azero) (Some (constr_of aopp)) (constr_of aeq) (constr_of t) (cset_of_constrarg_list l) ] | [ "Add" "Legacy" "Semi" "Ring" constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] -> [ add_theory false false false (constr_of a) None None None (constr_of aplus) (constr_of amult) (constr_of aone) (constr_of azero) None (constr_of aeq) (constr_of t) (cset_of_constrarg_list l) ] | [ "Add" "Legacy" "Abstract" "Ring" constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aopp) constr(aeq) constr(t) ] -> [ add_theory true true false (constr_of a) None None None (constr_of aplus) (constr_of amult) (constr_of aone) (constr_of azero) (Some (constr_of aopp)) (constr_of aeq) (constr_of t) ConstrSet.empty ] | [ "Add" "Legacy" "Abstract" "Semi" "Ring" constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aeq) constr(t) ] -> [ add_theory false true false (constr_of a) None None None (constr_of aplus) (constr_of amult) (constr_of aone) (constr_of azero) None (constr_of aeq) (constr_of t) ConstrSet.empty ] | [ "Add" "Legacy" "Setoid" "Ring" constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aopp) constr(aeq) constr(pm) constr(mm) constr(om) constr(t) "[" ne_constr_list(l) "]" ] -> [ add_theory true false true (constr_of a) (Some (constr_of aequiv)) (Some (constr_of asetth)) (Some { plusm = (constr_of pm); multm = (constr_of mm); oppm = Some (constr_of om) }) (constr_of aplus) (constr_of amult) (constr_of aone) (constr_of azero) (Some (constr_of aopp)) (constr_of aeq) (constr_of t) (cset_of_constrarg_list l) ] | [ "Add" "Legacy" "Semi" "Setoid" "Ring" constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aeq) constr(pm) constr(mm) constr(t) "[" ne_constr_list(l) "]" ] -> [ add_theory false false true (constr_of a) (Some (constr_of aequiv)) (Some (constr_of asetth)) (Some { plusm = (constr_of pm); multm = (constr_of mm); oppm = None }) (constr_of aplus) (constr_of amult) (constr_of aone) (constr_of azero) None (constr_of aeq) (constr_of t) (cset_of_constrarg_list l) ] END coq-8.4pl4/plugins/ring/vo.itarget0000644000175000017500000000027712326224777016266 0ustar stephstephLegacyArithRing.vo LegacyNArithRing.vo LegacyRing_theory.vo LegacyRing.vo LegacyZArithRing.vo Ring_abstract.vo Ring_normalize.vo Setoid_ring_normalize.vo Setoid_ring_theory.vo Setoid_ring.vo coq-8.4pl4/plugins/ring/Ring_abstract.v0000644000175000017500000004562012326224777017233 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* aspolynomial | ASP0 : aspolynomial | ASP1 : aspolynomial | ASPplus : aspolynomial -> aspolynomial -> aspolynomial | ASPmult : aspolynomial -> aspolynomial -> aspolynomial. Inductive abstract_sum : Type := | Nil_acs : abstract_sum | Cons_acs : varlist -> abstract_sum -> abstract_sum. Fixpoint abstract_sum_merge (s1:abstract_sum) : abstract_sum -> abstract_sum := match s1 with | Cons_acs l1 t1 => (fix asm_aux (s2:abstract_sum) : abstract_sum := match s2 with | Cons_acs l2 t2 => if varlist_lt l1 l2 then Cons_acs l1 (abstract_sum_merge t1 s2) else Cons_acs l2 (asm_aux t2) | Nil_acs => s1 end) | Nil_acs => fun s2 => s2 end. Fixpoint abstract_varlist_insert (l1:varlist) (s2:abstract_sum) {struct s2} : abstract_sum := match s2 with | Cons_acs l2 t2 => if varlist_lt l1 l2 then Cons_acs l1 s2 else Cons_acs l2 (abstract_varlist_insert l1 t2) | Nil_acs => Cons_acs l1 Nil_acs end. Fixpoint abstract_sum_scalar (l1:varlist) (s2:abstract_sum) {struct s2} : abstract_sum := match s2 with | Cons_acs l2 t2 => abstract_varlist_insert (varlist_merge l1 l2) (abstract_sum_scalar l1 t2) | Nil_acs => Nil_acs end. Fixpoint abstract_sum_prod (s1 s2:abstract_sum) {struct s1} : abstract_sum := match s1 with | Cons_acs l1 t1 => abstract_sum_merge (abstract_sum_scalar l1 s2) (abstract_sum_prod t1 s2) | Nil_acs => Nil_acs end. Fixpoint aspolynomial_normalize (p:aspolynomial) : abstract_sum := match p with | ASPvar i => Cons_acs (Cons_var i Nil_var) Nil_acs | ASP1 => Cons_acs Nil_var Nil_acs | ASP0 => Nil_acs | ASPplus l r => abstract_sum_merge (aspolynomial_normalize l) (aspolynomial_normalize r) | ASPmult l r => abstract_sum_prod (aspolynomial_normalize l) (aspolynomial_normalize r) end. Variable A : Type. Variable Aplus : A -> A -> A. Variable Amult : A -> A -> A. Variable Aone : A. Variable Azero : A. Variable Aeq : A -> A -> bool. Variable vm : varmap A. Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq. Fixpoint interp_asp (p:aspolynomial) : A := match p with | ASPvar i => interp_var Azero vm i | ASP0 => Azero | ASP1 => Aone | ASPplus l r => Aplus (interp_asp l) (interp_asp r) | ASPmult l r => Amult (interp_asp l) (interp_asp r) end. (* Local *) Definition iacs_aux := (fix iacs_aux (a:A) (s:abstract_sum) {struct s} : A := match s with | Nil_acs => a | Cons_acs l t => Aplus a (iacs_aux (interp_vl Amult Aone Azero vm l) t) end). Definition interp_acs (s:abstract_sum) : A := match s with | Cons_acs l t => iacs_aux (interp_vl Amult Aone Azero vm l) t | Nil_acs => Azero end. Hint Resolve (SR_plus_comm T). Hint Resolve (SR_plus_assoc T). Hint Resolve (SR_plus_assoc2 T). Hint Resolve (SR_mult_comm T). Hint Resolve (SR_mult_assoc T). Hint Resolve (SR_mult_assoc2 T). Hint Resolve (SR_plus_zero_left T). Hint Resolve (SR_plus_zero_left2 T). Hint Resolve (SR_mult_one_left T). Hint Resolve (SR_mult_one_left2 T). Hint Resolve (SR_mult_zero_left T). Hint Resolve (SR_mult_zero_left2 T). Hint Resolve (SR_distr_left T). Hint Resolve (SR_distr_left2 T). (*Hint Resolve (SR_plus_reg_left T).*) Hint Resolve (SR_plus_permute T). Hint Resolve (SR_mult_permute T). Hint Resolve (SR_distr_right T). Hint Resolve (SR_distr_right2 T). Hint Resolve (SR_mult_zero_right T). Hint Resolve (SR_mult_zero_right2 T). Hint Resolve (SR_plus_zero_right T). Hint Resolve (SR_plus_zero_right2 T). Hint Resolve (SR_mult_one_right T). Hint Resolve (SR_mult_one_right2 T). (*Hint Resolve (SR_plus_reg_right T).*) Hint Resolve eq_refl eq_sym eq_trans. Hint Immediate T. Remark iacs_aux_ok : forall (x:A) (s:abstract_sum), iacs_aux x s = Aplus x (interp_acs s). Proof. simple induction s; simpl; intros. trivial. reflexivity. Qed. Hint Extern 10 (_ = _ :>A) => rewrite iacs_aux_ok: core. Lemma abstract_varlist_insert_ok : forall (l:varlist) (s:abstract_sum), interp_acs (abstract_varlist_insert l s) = Aplus (interp_vl Amult Aone Azero vm l) (interp_acs s). simple induction s. trivial. simpl; intros. elim (varlist_lt l v); simpl. eauto. rewrite iacs_aux_ok. rewrite H; auto. Qed. Lemma abstract_sum_merge_ok : forall x y:abstract_sum, interp_acs (abstract_sum_merge x y) = Aplus (interp_acs x) (interp_acs y). Proof. simple induction x. trivial. simple induction y; intros. auto. simpl; elim (varlist_lt v v0); simpl. repeat rewrite iacs_aux_ok. rewrite H; simpl; auto. simpl in H0. repeat rewrite iacs_aux_ok. rewrite H0. simpl; auto. Qed. Lemma abstract_sum_scalar_ok : forall (l:varlist) (s:abstract_sum), interp_acs (abstract_sum_scalar l s) = Amult (interp_vl Amult Aone Azero vm l) (interp_acs s). Proof. simple induction s. simpl; eauto. simpl; intros. rewrite iacs_aux_ok. rewrite abstract_varlist_insert_ok. rewrite H. rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). auto. Qed. Lemma abstract_sum_prod_ok : forall x y:abstract_sum, interp_acs (abstract_sum_prod x y) = Amult (interp_acs x) (interp_acs y). Proof. simple induction x. intros; simpl; eauto. destruct y as [| v0 a0]; intros. simpl; rewrite H; eauto. unfold abstract_sum_prod; fold abstract_sum_prod. rewrite abstract_sum_merge_ok. rewrite abstract_sum_scalar_ok. rewrite H; simpl; auto. Qed. Theorem aspolynomial_normalize_ok : forall x:aspolynomial, interp_asp x = interp_acs (aspolynomial_normalize x). Proof. simple induction x; simpl; intros; trivial. rewrite abstract_sum_merge_ok. rewrite H; rewrite H0; eauto. rewrite abstract_sum_prod_ok. rewrite H; rewrite H0; eauto. Qed. End abstract_semi_rings. Section abstract_rings. (* In abstract polynomials there is no constants other than 0 and 1. An abstract ring is a ring whose operations plus, and mult are not functions but constructors. In other words, when c1 and c2 are closed, (plus c1 c2) doesn't reduce to a closed term. "closed" mean here "without plus and mult". *) (* this section is not parametrized by a (semi-)ring. Nevertheless, they are two different types for semi-rings and rings and there will be 2 correction theorems *) Inductive apolynomial : Type := | APvar : index -> apolynomial | AP0 : apolynomial | AP1 : apolynomial | APplus : apolynomial -> apolynomial -> apolynomial | APmult : apolynomial -> apolynomial -> apolynomial | APopp : apolynomial -> apolynomial. (* A canonical "abstract" sum is a list of varlist with the sign "+" or "-". Invariant : the list is sorted and there is no varlist is present with both signs. +x +x +x -x is forbidden => the canonical form is +x+x *) Inductive signed_sum : Type := | Nil_varlist : signed_sum | Plus_varlist : varlist -> signed_sum -> signed_sum | Minus_varlist : varlist -> signed_sum -> signed_sum. Fixpoint signed_sum_merge (s1:signed_sum) : signed_sum -> signed_sum := match s1 with | Plus_varlist l1 t1 => (fix ssm_aux (s2:signed_sum) : signed_sum := match s2 with | Plus_varlist l2 t2 => if varlist_lt l1 l2 then Plus_varlist l1 (signed_sum_merge t1 s2) else Plus_varlist l2 (ssm_aux t2) | Minus_varlist l2 t2 => if varlist_eq l1 l2 then signed_sum_merge t1 t2 else if varlist_lt l1 l2 then Plus_varlist l1 (signed_sum_merge t1 s2) else Minus_varlist l2 (ssm_aux t2) | Nil_varlist => s1 end) | Minus_varlist l1 t1 => (fix ssm_aux2 (s2:signed_sum) : signed_sum := match s2 with | Plus_varlist l2 t2 => if varlist_eq l1 l2 then signed_sum_merge t1 t2 else if varlist_lt l1 l2 then Minus_varlist l1 (signed_sum_merge t1 s2) else Plus_varlist l2 (ssm_aux2 t2) | Minus_varlist l2 t2 => if varlist_lt l1 l2 then Minus_varlist l1 (signed_sum_merge t1 s2) else Minus_varlist l2 (ssm_aux2 t2) | Nil_varlist => s1 end) | Nil_varlist => fun s2 => s2 end. Fixpoint plus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} : signed_sum := match s2 with | Plus_varlist l2 t2 => if varlist_lt l1 l2 then Plus_varlist l1 s2 else Plus_varlist l2 (plus_varlist_insert l1 t2) | Minus_varlist l2 t2 => if varlist_eq l1 l2 then t2 else if varlist_lt l1 l2 then Plus_varlist l1 s2 else Minus_varlist l2 (plus_varlist_insert l1 t2) | Nil_varlist => Plus_varlist l1 Nil_varlist end. Fixpoint minus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} : signed_sum := match s2 with | Plus_varlist l2 t2 => if varlist_eq l1 l2 then t2 else if varlist_lt l1 l2 then Minus_varlist l1 s2 else Plus_varlist l2 (minus_varlist_insert l1 t2) | Minus_varlist l2 t2 => if varlist_lt l1 l2 then Minus_varlist l1 s2 else Minus_varlist l2 (minus_varlist_insert l1 t2) | Nil_varlist => Minus_varlist l1 Nil_varlist end. Fixpoint signed_sum_opp (s:signed_sum) : signed_sum := match s with | Plus_varlist l2 t2 => Minus_varlist l2 (signed_sum_opp t2) | Minus_varlist l2 t2 => Plus_varlist l2 (signed_sum_opp t2) | Nil_varlist => Nil_varlist end. Fixpoint plus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} : signed_sum := match s2 with | Plus_varlist l2 t2 => plus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2) | Minus_varlist l2 t2 => minus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2) | Nil_varlist => Nil_varlist end. Fixpoint minus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} : signed_sum := match s2 with | Plus_varlist l2 t2 => minus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2) | Minus_varlist l2 t2 => plus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2) | Nil_varlist => Nil_varlist end. Fixpoint signed_sum_prod (s1 s2:signed_sum) {struct s1} : signed_sum := match s1 with | Plus_varlist l1 t1 => signed_sum_merge (plus_sum_scalar l1 s2) (signed_sum_prod t1 s2) | Minus_varlist l1 t1 => signed_sum_merge (minus_sum_scalar l1 s2) (signed_sum_prod t1 s2) | Nil_varlist => Nil_varlist end. Fixpoint apolynomial_normalize (p:apolynomial) : signed_sum := match p with | APvar i => Plus_varlist (Cons_var i Nil_var) Nil_varlist | AP1 => Plus_varlist Nil_var Nil_varlist | AP0 => Nil_varlist | APplus l r => signed_sum_merge (apolynomial_normalize l) (apolynomial_normalize r) | APmult l r => signed_sum_prod (apolynomial_normalize l) (apolynomial_normalize r) | APopp q => signed_sum_opp (apolynomial_normalize q) end. Variable A : Type. Variable Aplus : A -> A -> A. Variable Amult : A -> A -> A. Variable Aone : A. Variable Azero : A. Variable Aopp : A -> A. Variable Aeq : A -> A -> bool. Variable vm : varmap A. Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq. (* Local *) Definition isacs_aux := (fix isacs_aux (a:A) (s:signed_sum) {struct s} : A := match s with | Nil_varlist => a | Plus_varlist l t => Aplus a (isacs_aux (interp_vl Amult Aone Azero vm l) t) | Minus_varlist l t => Aplus a (isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t) end). Definition interp_sacs (s:signed_sum) : A := match s with | Plus_varlist l t => isacs_aux (interp_vl Amult Aone Azero vm l) t | Minus_varlist l t => isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t | Nil_varlist => Azero end. Fixpoint interp_ap (p:apolynomial) : A := match p with | APvar i => interp_var Azero vm i | AP0 => Azero | AP1 => Aone | APplus l r => Aplus (interp_ap l) (interp_ap r) | APmult l r => Amult (interp_ap l) (interp_ap r) | APopp q => Aopp (interp_ap q) end. Hint Resolve (Th_plus_comm T). Hint Resolve (Th_plus_assoc T). Hint Resolve (Th_plus_assoc2 T). Hint Resolve (Th_mult_comm T). Hint Resolve (Th_mult_assoc T). Hint Resolve (Th_mult_assoc2 T). Hint Resolve (Th_plus_zero_left T). Hint Resolve (Th_plus_zero_left2 T). Hint Resolve (Th_mult_one_left T). Hint Resolve (Th_mult_one_left2 T). Hint Resolve (Th_mult_zero_left T). Hint Resolve (Th_mult_zero_left2 T). Hint Resolve (Th_distr_left T). Hint Resolve (Th_distr_left2 T). (*Hint Resolve (Th_plus_reg_left T).*) Hint Resolve (Th_plus_permute T). Hint Resolve (Th_mult_permute T). Hint Resolve (Th_distr_right T). Hint Resolve (Th_distr_right2 T). Hint Resolve (Th_mult_zero_right2 T). Hint Resolve (Th_plus_zero_right T). Hint Resolve (Th_plus_zero_right2 T). Hint Resolve (Th_mult_one_right T). Hint Resolve (Th_mult_one_right2 T). (*Hint Resolve (Th_plus_reg_right T).*) Hint Resolve eq_refl eq_sym eq_trans. Hint Immediate T. Lemma isacs_aux_ok : forall (x:A) (s:signed_sum), isacs_aux x s = Aplus x (interp_sacs s). Proof. simple induction s; simpl; intros. trivial. reflexivity. reflexivity. Qed. Hint Extern 10 (_ = _ :>A) => rewrite isacs_aux_ok: core. Ltac solve1 v v0 H H0 := simpl; elim (varlist_lt v v0); simpl; rewrite isacs_aux_ok; [ rewrite H; simpl; auto | simpl in H0; rewrite H0; auto ]. Lemma signed_sum_merge_ok : forall x y:signed_sum, interp_sacs (signed_sum_merge x y) = Aplus (interp_sacs x) (interp_sacs y). simple induction x. intro; simpl; auto. simple induction y; intros. auto. solve1 v v0 H H0. simpl; generalize (varlist_eq_prop v v0). elim (varlist_eq v v0); simpl. intro Heq; rewrite (Heq I). rewrite H. repeat rewrite isacs_aux_ok. rewrite (Th_plus_permute T). repeat rewrite (Th_plus_assoc T). rewrite (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v0)) (interp_vl Amult Aone Azero vm v0)). rewrite (Th_opp_def T). rewrite (Th_plus_zero_left T). reflexivity. solve1 v v0 H H0. simple induction y; intros. auto. simpl; generalize (varlist_eq_prop v v0). elim (varlist_eq v v0); simpl. intro Heq; rewrite (Heq I). rewrite H. repeat rewrite isacs_aux_ok. rewrite (Th_plus_permute T). repeat rewrite (Th_plus_assoc T). rewrite (Th_opp_def T). rewrite (Th_plus_zero_left T). reflexivity. solve1 v v0 H H0. solve1 v v0 H H0. Qed. Ltac solve2 l v H := elim (varlist_lt l v); simpl; rewrite isacs_aux_ok; [ auto | rewrite H; auto ]. Lemma plus_varlist_insert_ok : forall (l:varlist) (s:signed_sum), interp_sacs (plus_varlist_insert l s) = Aplus (interp_vl Amult Aone Azero vm l) (interp_sacs s). Proof. simple induction s. trivial. simpl; intros. solve2 l v H. simpl; intros. generalize (varlist_eq_prop l v). elim (varlist_eq l v); simpl. intro Heq; rewrite (Heq I). repeat rewrite isacs_aux_ok. repeat rewrite (Th_plus_assoc T). rewrite (Th_opp_def T). rewrite (Th_plus_zero_left T). reflexivity. solve2 l v H. Qed. Lemma minus_varlist_insert_ok : forall (l:varlist) (s:signed_sum), interp_sacs (minus_varlist_insert l s) = Aplus (Aopp (interp_vl Amult Aone Azero vm l)) (interp_sacs s). Proof. simple induction s. trivial. simpl; intros. generalize (varlist_eq_prop l v). elim (varlist_eq l v); simpl. intro Heq; rewrite (Heq I). repeat rewrite isacs_aux_ok. repeat rewrite (Th_plus_assoc T). rewrite (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v)) (interp_vl Amult Aone Azero vm v)). rewrite (Th_opp_def T). auto. simpl; intros. solve2 l v H. simpl; intros; solve2 l v H. Qed. Lemma signed_sum_opp_ok : forall s:signed_sum, interp_sacs (signed_sum_opp s) = Aopp (interp_sacs s). Proof. simple induction s; simpl; intros. symmetry ; apply (Th_opp_zero T). repeat rewrite isacs_aux_ok. rewrite H. rewrite (Th_plus_opp_opp T). reflexivity. repeat rewrite isacs_aux_ok. rewrite H. rewrite <- (Th_plus_opp_opp T). rewrite (Th_opp_opp T). reflexivity. Qed. Lemma plus_sum_scalar_ok : forall (l:varlist) (s:signed_sum), interp_sacs (plus_sum_scalar l s) = Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s). Proof. simple induction s. trivial. simpl; intros. rewrite plus_varlist_insert_ok. rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). repeat rewrite isacs_aux_ok. rewrite H. auto. simpl; intros. rewrite minus_varlist_insert_ok. repeat rewrite isacs_aux_ok. rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). rewrite H. rewrite (Th_distr_right T). rewrite <- (Th_opp_mult_right T). reflexivity. Qed. Lemma minus_sum_scalar_ok : forall (l:varlist) (s:signed_sum), interp_sacs (minus_sum_scalar l s) = Aopp (Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s)). Proof. simple induction s; simpl; intros. rewrite (Th_mult_zero_right T); symmetry ; apply (Th_opp_zero T). simpl; intros. rewrite minus_varlist_insert_ok. rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). repeat rewrite isacs_aux_ok. rewrite H. rewrite (Th_distr_right T). rewrite (Th_plus_opp_opp T). reflexivity. simpl; intros. rewrite plus_varlist_insert_ok. repeat rewrite isacs_aux_ok. rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). rewrite H. rewrite (Th_distr_right T). rewrite <- (Th_opp_mult_right T). rewrite <- (Th_plus_opp_opp T). rewrite (Th_opp_opp T). reflexivity. Qed. Lemma signed_sum_prod_ok : forall x y:signed_sum, interp_sacs (signed_sum_prod x y) = Amult (interp_sacs x) (interp_sacs y). Proof. simple induction x. simpl; eauto 1. intros; simpl. rewrite signed_sum_merge_ok. rewrite plus_sum_scalar_ok. repeat rewrite isacs_aux_ok. rewrite H. auto. intros; simpl. repeat rewrite isacs_aux_ok. rewrite signed_sum_merge_ok. rewrite minus_sum_scalar_ok. rewrite H. rewrite (Th_distr_left T). rewrite (Th_opp_mult_left T). reflexivity. Qed. Theorem apolynomial_normalize_ok : forall p:apolynomial, interp_sacs (apolynomial_normalize p) = interp_ap p. Proof. simple induction p; simpl; auto 1. intros. rewrite signed_sum_merge_ok. rewrite H; rewrite H0; reflexivity. intros. rewrite signed_sum_prod_ok. rewrite H; rewrite H0; reflexivity. intros. rewrite signed_sum_opp_ok. rewrite H; reflexivity. Qed. End abstract_rings. coq-8.4pl4/plugins/ring/LegacyRing_theory.v0000644000175000017500000002370612326224777020070 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* A -> A. Variable Amult : A -> A -> A. Variable Aone : A. Variable Azero : A. (* There is also a "weakly decidable" equality on A. That means that if (A_eq x y)=true then x=y but x=y can arise when (A_eq x y)=false. On an abstract ring the function [x,y:A]false is a good choice. The proof of A_eq_prop is in this case easy. *) Variable Aeq : A -> A -> bool. Infix "+" := Aplus (at level 50, left associativity). Infix "*" := Amult (at level 40, left associativity). Notation "0" := Azero. Notation "1" := Aone. Record Semi_Ring_Theory : Prop := {SR_plus_comm : forall n m:A, n + m = m + n; SR_plus_assoc : forall n m p:A, n + (m + p) = n + m + p; SR_mult_comm : forall n m:A, n * m = m * n; SR_mult_assoc : forall n m p:A, n * (m * p) = n * m * p; SR_plus_zero_left : forall n:A, 0 + n = n; SR_mult_one_left : forall n:A, 1 * n = n; SR_mult_zero_left : forall n:A, 0 * n = 0; SR_distr_left : forall n m p:A, (n + m) * p = n * p + m * p; (* SR_plus_reg_left : forall n m p:A, n + m = n + p -> m = p;*) SR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}. Variable T : Semi_Ring_Theory. Let plus_comm := SR_plus_comm T. Let plus_assoc := SR_plus_assoc T. Let mult_comm := SR_mult_comm T. Let mult_assoc := SR_mult_assoc T. Let plus_zero_left := SR_plus_zero_left T. Let mult_one_left := SR_mult_one_left T. Let mult_zero_left := SR_mult_zero_left T. Let distr_left := SR_distr_left T. (*Let plus_reg_left := SR_plus_reg_left T.*) Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left mult_one_left mult_zero_left distr_left (*plus_reg_left*). (* Lemmas whose form is x=y are also provided in form y=x because Auto does not symmetry *) Lemma SR_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p). symmetry ; eauto. Qed. Lemma SR_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p). symmetry ; eauto. Qed. Lemma SR_plus_zero_left2 : forall n:A, n = 0 + n. symmetry ; eauto. Qed. Lemma SR_mult_one_left2 : forall n:A, n = 1 * n. symmetry ; eauto. Qed. Lemma SR_mult_zero_left2 : forall n:A, 0 = 0 * n. symmetry ; eauto. Qed. Lemma SR_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p. symmetry ; eauto. Qed. Lemma SR_plus_permute : forall n m p:A, n + (m + p) = m + (n + p). intros. rewrite plus_assoc. elim (plus_comm m n). rewrite <- plus_assoc. reflexivity. Qed. Lemma SR_mult_permute : forall n m p:A, n * (m * p) = m * (n * p). intros. rewrite mult_assoc. elim (mult_comm m n). rewrite <- mult_assoc. reflexivity. Qed. Hint Resolve SR_plus_permute SR_mult_permute. Lemma SR_distr_right : forall n m p:A, n * (m + p) = n * m + n * p. intros. repeat rewrite (mult_comm n). eauto. Qed. Lemma SR_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p). symmetry ; apply SR_distr_right. Qed. Lemma SR_mult_zero_right : forall n:A, n * 0 = 0. intro; rewrite mult_comm; eauto. Qed. Lemma SR_mult_zero_right2 : forall n:A, 0 = n * 0. intro; rewrite mult_comm; eauto. Qed. Lemma SR_plus_zero_right : forall n:A, n + 0 = n. intro; rewrite plus_comm; eauto. Qed. Lemma SR_plus_zero_right2 : forall n:A, n = n + 0. intro; rewrite plus_comm; eauto. Qed. Lemma SR_mult_one_right : forall n:A, n * 1 = n. intro; elim mult_comm; auto. Qed. Lemma SR_mult_one_right2 : forall n:A, n = n * 1. intro; elim mult_comm; auto. Qed. (* Lemma SR_plus_reg_right : forall n m p:A, m + n = p + n -> m = p. intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n); eauto. Qed. *) End Theory_of_semi_rings. Section Theory_of_rings. Variable A : Type. Variable Aplus : A -> A -> A. Variable Amult : A -> A -> A. Variable Aone : A. Variable Azero : A. Variable Aopp : A -> A. Variable Aeq : A -> A -> bool. Infix "+" := Aplus (at level 50, left associativity). Infix "*" := Amult (at level 40, left associativity). Notation "0" := Azero. Notation "1" := Aone. Notation "- x" := (Aopp x). Record Ring_Theory : Prop := {Th_plus_comm : forall n m:A, n + m = m + n; Th_plus_assoc : forall n m p:A, n + (m + p) = n + m + p; Th_mult_comm : forall n m:A, n * m = m * n; Th_mult_assoc : forall n m p:A, n * (m * p) = n * m * p; Th_plus_zero_left : forall n:A, 0 + n = n; Th_mult_one_left : forall n:A, 1 * n = n; Th_opp_def : forall n:A, n + - n = 0; Th_distr_left : forall n m p:A, (n + m) * p = n * p + m * p; Th_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}. Variable T : Ring_Theory. Let plus_comm := Th_plus_comm T. Let plus_assoc := Th_plus_assoc T. Let mult_comm := Th_mult_comm T. Let mult_assoc := Th_mult_assoc T. Let plus_zero_left := Th_plus_zero_left T. Let mult_one_left := Th_mult_one_left T. Let opp_def := Th_opp_def T. Let distr_left := Th_distr_left T. Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left mult_one_left opp_def distr_left. (* Lemmas whose form is x=y are also provided in form y=x because Auto does not symmetry *) Lemma Th_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p). symmetry ; eauto. Qed. Lemma Th_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p). symmetry ; eauto. Qed. Lemma Th_plus_zero_left2 : forall n:A, n = 0 + n. symmetry ; eauto. Qed. Lemma Th_mult_one_left2 : forall n:A, n = 1 * n. symmetry ; eauto. Qed. Lemma Th_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p. symmetry ; eauto. Qed. Lemma Th_opp_def2 : forall n:A, 0 = n + - n. symmetry ; eauto. Qed. Lemma Th_plus_permute : forall n m p:A, n + (m + p) = m + (n + p). intros. rewrite plus_assoc. elim (plus_comm m n). rewrite <- plus_assoc. reflexivity. Qed. Lemma Th_mult_permute : forall n m p:A, n * (m * p) = m * (n * p). intros. rewrite mult_assoc. elim (mult_comm m n). rewrite <- mult_assoc. reflexivity. Qed. Hint Resolve Th_plus_permute Th_mult_permute. Lemma aux1 : forall a:A, a + a = a -> a = 0. intros. generalize (opp_def a). pattern a at 1. rewrite <- H. rewrite <- plus_assoc. rewrite opp_def. elim plus_comm. rewrite plus_zero_left. trivial. Qed. Lemma Th_mult_zero_left : forall n:A, 0 * n = 0. intros. apply aux1. rewrite <- distr_left. rewrite plus_zero_left. reflexivity. Qed. Hint Resolve Th_mult_zero_left. Lemma Th_mult_zero_left2 : forall n:A, 0 = 0 * n. symmetry ; eauto. Qed. Lemma aux2 : forall x y z:A, x + y = 0 -> x + z = 0 -> y = z. intros. rewrite <- (plus_zero_left y). elim H0. elim plus_assoc. elim (plus_comm y z). rewrite plus_assoc. rewrite H. rewrite plus_zero_left. reflexivity. Qed. Lemma Th_opp_mult_left : forall x y:A, - (x * y) = - x * y. intros. apply (aux2 (x:=(x * y))); [ apply opp_def | rewrite <- distr_left; rewrite opp_def; auto ]. Qed. Hint Resolve Th_opp_mult_left. Lemma Th_opp_mult_left2 : forall x y:A, - x * y = - (x * y). symmetry ; eauto. Qed. Lemma Th_mult_zero_right : forall n:A, n * 0 = 0. intro; elim mult_comm; eauto. Qed. Lemma Th_mult_zero_right2 : forall n:A, 0 = n * 0. intro; elim mult_comm; eauto. Qed. Lemma Th_plus_zero_right : forall n:A, n + 0 = n. intro; rewrite plus_comm; eauto. Qed. Lemma Th_plus_zero_right2 : forall n:A, n = n + 0. intro; rewrite plus_comm; eauto. Qed. Lemma Th_mult_one_right : forall n:A, n * 1 = n. intro; elim mult_comm; eauto. Qed. Lemma Th_mult_one_right2 : forall n:A, n = n * 1. intro; elim mult_comm; eauto. Qed. Lemma Th_opp_mult_right : forall x y:A, - (x * y) = x * - y. intros; do 2 rewrite (mult_comm x); auto. Qed. Lemma Th_opp_mult_right2 : forall x y:A, x * - y = - (x * y). intros; do 2 rewrite (mult_comm x); auto. Qed. Lemma Th_plus_opp_opp : forall x y:A, - x + - y = - (x + y). intros. apply (aux2 (x:=(x + y))); [ elim plus_assoc; rewrite (Th_plus_permute y (- x)); rewrite plus_assoc; rewrite opp_def; rewrite plus_zero_left; auto | auto ]. Qed. Lemma Th_plus_permute_opp : forall n m p:A, - m + (n + p) = n + (- m + p). eauto. Qed. Lemma Th_opp_opp : forall n:A, - - n = n. intro; apply (aux2 (x:=(- n))); [ auto | elim plus_comm; auto ]. Qed. Hint Resolve Th_opp_opp. Lemma Th_opp_opp2 : forall n:A, n = - - n. symmetry ; eauto. Qed. Lemma Th_mult_opp_opp : forall x y:A, - x * - y = x * y. intros; rewrite <- Th_opp_mult_left; rewrite <- Th_opp_mult_right; auto. Qed. Lemma Th_mult_opp_opp2 : forall x y:A, x * y = - x * - y. symmetry ; apply Th_mult_opp_opp. Qed. Lemma Th_opp_zero : - 0 = 0. rewrite <- (plus_zero_left (- 0)). auto. Qed. (* Lemma Th_plus_reg_left : forall n m p:A, n + m = n + p -> m = p. intros; generalize (f_equal (fun z => - n + z) H). repeat rewrite plus_assoc. rewrite (plus_comm (- n) n). rewrite opp_def. repeat rewrite Th_plus_zero_left; eauto. Qed. Lemma Th_plus_reg_right : forall n m p:A, m + n = p + n -> m = p. intros. eapply Th_plus_reg_left with n. rewrite (plus_comm n m). rewrite (plus_comm n p). auto. Qed. *) Lemma Th_distr_right : forall n m p:A, n * (m + p) = n * m + n * p. intros. repeat rewrite (mult_comm n). eauto. Qed. Lemma Th_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p). symmetry ; apply Th_distr_right. Qed. End Theory_of_rings. Hint Resolve Th_mult_zero_left (*Th_plus_reg_left*): core. Unset Implicit Arguments. Definition Semi_Ring_Theory_of : forall (A:Type) (Aplus Amult:A -> A -> A) (Aone Azero:A) (Aopp:A -> A) (Aeq:A -> A -> bool), Ring_Theory Aplus Amult Aone Azero Aopp Aeq -> Semi_Ring_Theory Aplus Amult Aone Azero Aeq. intros until 1; case H. split; intros; simpl; eauto. Defined. (* Every ring can be viewed as a semi-ring : this property will be used in Abstract_polynom. *) Coercion Semi_Ring_Theory_of : Ring_Theory >-> Semi_Ring_Theory. Section product_ring. End product_ring. Section power_ring. End power_ring. coq-8.4pl4/plugins/ring/Setoid_ring_normalize.v0000644000175000017500000010767012326224777021003 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* n = m. Proof. simple induction n; simple induction m; simpl; try reflexivity || contradiction. intros; rewrite (H i0); trivial. intros; rewrite (H i0); trivial. Qed. Section setoid. Variable A : Type. Variable Aequiv : A -> A -> Prop. Variable Aplus : A -> A -> A. Variable Amult : A -> A -> A. Variable Aone : A. Variable Azero : A. Variable Aopp : A -> A. Variable Aeq : A -> A -> bool. Variable S : Setoid_Theory A Aequiv. Add Setoid A Aequiv S as Asetoid. Variable plus_morph : forall a a0:A, Aequiv a a0 -> forall a1 a2:A, Aequiv a1 a2 -> Aequiv (Aplus a a1) (Aplus a0 a2). Variable mult_morph : forall a a0:A, Aequiv a a0 -> forall a1 a2:A, Aequiv a1 a2 -> Aequiv (Amult a a1) (Amult a0 a2). Variable opp_morph : forall a a0:A, Aequiv a a0 -> Aequiv (Aopp a) (Aopp a0). Add Morphism Aplus : Aplus_ext. intros; apply plus_morph; assumption. Qed. Add Morphism Amult : Amult_ext. intros; apply mult_morph; assumption. Qed. Add Morphism Aopp : Aopp_ext. exact opp_morph. Qed. Let equiv_refl := Seq_refl A Aequiv S. Let equiv_sym := Seq_sym A Aequiv S. Let equiv_trans := Seq_trans A Aequiv S. Hint Resolve equiv_refl equiv_trans. Hint Immediate equiv_sym. Section semi_setoid_rings. (* Section definitions. *) (******************************************) (* Normal abtract Polynomials *) (******************************************) (* DEFINITIONS : - A varlist is a sorted product of one or more variables : x, x*y*z - A monom is a constant, a varlist or the product of a constant by a varlist variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT. - A canonical sum is either a monom or an ordered sum of monoms (the order on monoms is defined later) - A normal polynomial it either a constant or a canonical sum or a constant plus a canonical sum *) (* varlist is isomorphic to (list var), but we built a special inductive for efficiency *) Inductive varlist : Type := | Nil_var : varlist | Cons_var : index -> varlist -> varlist. Inductive canonical_sum : Type := | Nil_monom : canonical_sum | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum | Cons_varlist : varlist -> canonical_sum -> canonical_sum. (* Order on monoms *) (* That's the lexicographic order on varlist, extended by : - A constant is less than every monom - The relation between two varlist is preserved by multiplication by a constant. Examples : 3 < x < y x*y < x*y*y*z 2*x*y < x*y*y*z x*y < 54*x*y*y*z 4*x*y < 59*x*y*y*z *) Fixpoint varlist_eq (x y:varlist) {struct y} : bool := match x, y with | Nil_var, Nil_var => true | Cons_var i xrest, Cons_var j yrest => andb (index_eq i j) (varlist_eq xrest yrest) | _, _ => false end. Fixpoint varlist_lt (x y:varlist) {struct y} : bool := match x, y with | Nil_var, Cons_var _ _ => true | Cons_var i xrest, Cons_var j yrest => if index_lt i j then true else andb (index_eq i j) (varlist_lt xrest yrest) | _, _ => false end. (* merges two variables lists *) Fixpoint varlist_merge (l1:varlist) : varlist -> varlist := match l1 with | Cons_var v1 t1 => (fix vm_aux (l2:varlist) : varlist := match l2 with | Cons_var v2 t2 => if index_lt v1 v2 then Cons_var v1 (varlist_merge t1 l2) else Cons_var v2 (vm_aux t2) | Nil_var => l1 end) | Nil_var => fun l2 => l2 end. (* returns the sum of two canonical sums *) Fixpoint canonical_sum_merge (s1:canonical_sum) : canonical_sum -> canonical_sum := match s1 with | Cons_monom c1 l1 t1 => (fix csm_aux (s2:canonical_sum) : canonical_sum := match s2 with | Cons_monom c2 l2 t2 => if varlist_eq l1 l2 then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2) else if varlist_lt l1 l2 then Cons_monom c1 l1 (canonical_sum_merge t1 s2) else Cons_monom c2 l2 (csm_aux t2) | Cons_varlist l2 t2 => if varlist_eq l1 l2 then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2) else if varlist_lt l1 l2 then Cons_monom c1 l1 (canonical_sum_merge t1 s2) else Cons_varlist l2 (csm_aux t2) | Nil_monom => s1 end) | Cons_varlist l1 t1 => (fix csm_aux2 (s2:canonical_sum) : canonical_sum := match s2 with | Cons_monom c2 l2 t2 => if varlist_eq l1 l2 then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2) else if varlist_lt l1 l2 then Cons_varlist l1 (canonical_sum_merge t1 s2) else Cons_monom c2 l2 (csm_aux2 t2) | Cons_varlist l2 t2 => if varlist_eq l1 l2 then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2) else if varlist_lt l1 l2 then Cons_varlist l1 (canonical_sum_merge t1 s2) else Cons_varlist l2 (csm_aux2 t2) | Nil_monom => s1 end) | Nil_monom => fun s2 => s2 end. (* Insertion of a monom in a canonical sum *) Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} : canonical_sum := match s2 with | Cons_monom c2 l2 t2 => if varlist_eq l1 l2 then Cons_monom (Aplus c1 c2) l1 t2 else if varlist_lt l1 l2 then Cons_monom c1 l1 s2 else Cons_monom c2 l2 (monom_insert c1 l1 t2) | Cons_varlist l2 t2 => if varlist_eq l1 l2 then Cons_monom (Aplus c1 Aone) l1 t2 else if varlist_lt l1 l2 then Cons_monom c1 l1 s2 else Cons_varlist l2 (monom_insert c1 l1 t2) | Nil_monom => Cons_monom c1 l1 Nil_monom end. Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} : canonical_sum := match s2 with | Cons_monom c2 l2 t2 => if varlist_eq l1 l2 then Cons_monom (Aplus Aone c2) l1 t2 else if varlist_lt l1 l2 then Cons_varlist l1 s2 else Cons_monom c2 l2 (varlist_insert l1 t2) | Cons_varlist l2 t2 => if varlist_eq l1 l2 then Cons_monom (Aplus Aone Aone) l1 t2 else if varlist_lt l1 l2 then Cons_varlist l1 s2 else Cons_varlist l2 (varlist_insert l1 t2) | Nil_monom => Cons_varlist l1 Nil_monom end. (* Computes c0*s *) Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} : canonical_sum := match s with | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t) | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t) | Nil_monom => Nil_monom end. (* Computes l0*s *) Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} : canonical_sum := match s with | Cons_monom c l t => monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t) | Cons_varlist l t => varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t) | Nil_monom => Nil_monom end. (* Computes c0*l0*s *) Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) (s:canonical_sum) {struct s} : canonical_sum := match s with | Cons_monom c l t => monom_insert (Amult c0 c) (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t) | Cons_varlist l t => monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t) | Nil_monom => Nil_monom end. (* returns the product of two canonical sums *) Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} : canonical_sum := match s1 with | Cons_monom c1 l1 t1 => canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2) (canonical_sum_prod t1 s2) | Cons_varlist l1 t1 => canonical_sum_merge (canonical_sum_scalar2 l1 s2) (canonical_sum_prod t1 s2) | Nil_monom => Nil_monom end. (* The type to represent concrete semi-setoid-ring polynomials *) Inductive setspolynomial : Type := | SetSPvar : index -> setspolynomial | SetSPconst : A -> setspolynomial | SetSPplus : setspolynomial -> setspolynomial -> setspolynomial | SetSPmult : setspolynomial -> setspolynomial -> setspolynomial. Fixpoint setspolynomial_normalize (p:setspolynomial) : canonical_sum := match p with | SetSPplus l r => canonical_sum_merge (setspolynomial_normalize l) (setspolynomial_normalize r) | SetSPmult l r => canonical_sum_prod (setspolynomial_normalize l) (setspolynomial_normalize r) | SetSPconst c => Cons_monom c Nil_var Nil_monom | SetSPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom end. Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum := match s with | Cons_monom c l t => if Aeq c Azero then canonical_sum_simplify t else if Aeq c Aone then Cons_varlist l (canonical_sum_simplify t) else Cons_monom c l (canonical_sum_simplify t) | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t) | Nil_monom => Nil_monom end. Definition setspolynomial_simplify (x:setspolynomial) := canonical_sum_simplify (setspolynomial_normalize x). Variable vm : varmap A. Definition interp_var (i:index) := varmap_find Azero i vm. Definition ivl_aux := (fix ivl_aux (x:index) (t:varlist) {struct t} : A := match t with | Nil_var => interp_var x | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t') end). Definition interp_vl (l:varlist) := match l with | Nil_var => Aone | Cons_var x t => ivl_aux x t end. Definition interp_m (c:A) (l:varlist) := match l with | Nil_var => c | Cons_var x t => Amult c (ivl_aux x t) end. Definition ics_aux := (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A := match s with | Nil_monom => a | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t) | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t) end). Definition interp_setcs (s:canonical_sum) : A := match s with | Nil_monom => Azero | Cons_varlist l t => ics_aux (interp_vl l) t | Cons_monom c l t => ics_aux (interp_m c l) t end. Fixpoint interp_setsp (p:setspolynomial) : A := match p with | SetSPconst c => c | SetSPvar i => interp_var i | SetSPplus p1 p2 => Aplus (interp_setsp p1) (interp_setsp p2) | SetSPmult p1 p2 => Amult (interp_setsp p1) (interp_setsp p2) end. (* End interpretation. *) Unset Implicit Arguments. (* Section properties. *) Variable T : Semi_Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aeq. Hint Resolve (SSR_plus_comm T). Hint Resolve (SSR_plus_assoc T). Hint Resolve (SSR_plus_assoc2 S T). Hint Resolve (SSR_mult_comm T). Hint Resolve (SSR_mult_assoc T). Hint Resolve (SSR_mult_assoc2 S T). Hint Resolve (SSR_plus_zero_left T). Hint Resolve (SSR_plus_zero_left2 S T). Hint Resolve (SSR_mult_one_left T). Hint Resolve (SSR_mult_one_left2 S T). Hint Resolve (SSR_mult_zero_left T). Hint Resolve (SSR_mult_zero_left2 S T). Hint Resolve (SSR_distr_left T). Hint Resolve (SSR_distr_left2 S T). Hint Resolve (SSR_plus_reg_left T). Hint Resolve (SSR_plus_permute S plus_morph T). Hint Resolve (SSR_mult_permute S mult_morph T). Hint Resolve (SSR_distr_right S plus_morph T). Hint Resolve (SSR_distr_right2 S plus_morph T). Hint Resolve (SSR_mult_zero_right S T). Hint Resolve (SSR_mult_zero_right2 S T). Hint Resolve (SSR_plus_zero_right S T). Hint Resolve (SSR_plus_zero_right2 S T). Hint Resolve (SSR_mult_one_right S T). Hint Resolve (SSR_mult_one_right2 S T). Hint Resolve (SSR_plus_reg_right S T). Hint Resolve eq_refl eq_sym eq_trans. Hint Immediate T. Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y. Proof. simple induction x; simple induction y; contradiction || (try reflexivity). simpl; intros. generalize (andb_prop2 _ _ H1); intros; elim H2; intros. rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity. Qed. Remark ivl_aux_ok : forall (v:varlist) (i:index), Aequiv (ivl_aux i v) (Amult (interp_var i) (interp_vl v)). Proof. simple induction v; simpl; intros. trivial. rewrite (H i); trivial. Qed. Lemma varlist_merge_ok : forall x y:varlist, Aequiv (interp_vl (varlist_merge x y)) (Amult (interp_vl x) (interp_vl y)). Proof. simple induction x. simpl; trivial. simple induction y. simpl; trivial. simpl; intros. elim (index_lt i i0); simpl; intros. rewrite (ivl_aux_ok v i). rewrite (ivl_aux_ok v0 i0). rewrite (ivl_aux_ok (varlist_merge v (Cons_var i0 v0)) i). rewrite (H (Cons_var i0 v0)). simpl. rewrite (ivl_aux_ok v0 i0). eauto. rewrite (ivl_aux_ok v i). rewrite (ivl_aux_ok v0 i0). rewrite (ivl_aux_ok ((fix vm_aux (l2:varlist) : varlist := match l2 with | Nil_var => Cons_var i v | Cons_var v2 t2 => if index_lt i v2 then Cons_var i (varlist_merge v l2) else Cons_var v2 (vm_aux t2) end) v0) i0). rewrite H0. rewrite (ivl_aux_ok v i). eauto. Qed. Remark ics_aux_ok : forall (x:A) (s:canonical_sum), Aequiv (ics_aux x s) (Aplus x (interp_setcs s)). Proof. simple induction s; simpl; intros; trivial. Qed. Remark interp_m_ok : forall (x:A) (l:varlist), Aequiv (interp_m x l) (Amult x (interp_vl l)). Proof. destruct l as [| i v]; trivial. Qed. Hint Resolve ivl_aux_ok. Hint Resolve ics_aux_ok. Hint Resolve interp_m_ok. (* Hints Resolve ivl_aux_ok ics_aux_ok interp_m_ok. *) Lemma canonical_sum_merge_ok : forall x y:canonical_sum, Aequiv (interp_setcs (canonical_sum_merge x y)) (Aplus (interp_setcs x) (interp_setcs y)). Proof. simple induction x; simpl. trivial. simple induction y; simpl; intros. eauto. generalize (varlist_eq_prop v v0). elim (varlist_eq v v0). intros; rewrite (H1 I). simpl. rewrite (ics_aux_ok (interp_m a v0) c). rewrite (ics_aux_ok (interp_m a0 v0) c0). rewrite (ics_aux_ok (interp_m (Aplus a a0) v0) (canonical_sum_merge c c0)). rewrite (H c0). rewrite (interp_m_ok (Aplus a a0) v0). rewrite (interp_m_ok a v0). rewrite (interp_m_ok a0 v0). setoid_replace (Amult (Aplus a a0) (interp_vl v0)) with (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0))); [ idtac | trivial ]. setoid_replace (Aplus (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0))) (Aplus (interp_setcs c) (interp_setcs c0))) with (Aplus (Amult a (interp_vl v0)) (Aplus (Amult a0 (interp_vl v0)) (Aplus (interp_setcs c) (interp_setcs c0)))); [ idtac | trivial ]. setoid_replace (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c)) (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0))) with (Aplus (Amult a (interp_vl v0)) (Aplus (interp_setcs c) (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0)))); [ idtac | trivial ]. auto. elim (varlist_lt v v0); simpl. intro. rewrite (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_monom a0 v0 c0))) . rewrite (ics_aux_ok (interp_m a v) c). rewrite (ics_aux_ok (interp_m a0 v0) c0). rewrite (H (Cons_monom a0 v0 c0)); simpl. rewrite (ics_aux_ok (interp_m a0 v0) c0); auto. intro. rewrite (ics_aux_ok (interp_m a0 v0) ((fix csm_aux (s2:canonical_sum) : canonical_sum := match s2 with | Nil_monom => Cons_monom a v c | Cons_monom c2 l2 t2 => if varlist_eq v l2 then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2) else if varlist_lt v l2 then Cons_monom a v (canonical_sum_merge c s2) else Cons_monom c2 l2 (csm_aux t2) | Cons_varlist l2 t2 => if varlist_eq v l2 then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2) else if varlist_lt v l2 then Cons_monom a v (canonical_sum_merge c s2) else Cons_varlist l2 (csm_aux t2) end) c0)). rewrite H0. rewrite (ics_aux_ok (interp_m a v) c); rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl; auto. generalize (varlist_eq_prop v v0). elim (varlist_eq v v0). intros; rewrite (H1 I). simpl. rewrite (ics_aux_ok (interp_m (Aplus a Aone) v0) (canonical_sum_merge c c0)); rewrite (ics_aux_ok (interp_m a v0) c); rewrite (ics_aux_ok (interp_vl v0) c0). rewrite (H c0). rewrite (interp_m_ok (Aplus a Aone) v0). rewrite (interp_m_ok a v0). setoid_replace (Amult (Aplus a Aone) (interp_vl v0)) with (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0))); [ idtac | trivial ]. setoid_replace (Aplus (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0))) (Aplus (interp_setcs c) (interp_setcs c0))) with (Aplus (Amult a (interp_vl v0)) (Aplus (Amult Aone (interp_vl v0)) (Aplus (interp_setcs c) (interp_setcs c0)))); [ idtac | trivial ]. setoid_replace (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c)) (Aplus (interp_vl v0) (interp_setcs c0))) with (Aplus (Amult a (interp_vl v0)) (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0)))); [ idtac | trivial ]. setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); [ idtac | trivial ]. auto. elim (varlist_lt v v0); simpl. intro. rewrite (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_varlist v0 c0))) ; rewrite (ics_aux_ok (interp_m a v) c); rewrite (ics_aux_ok (interp_vl v0) c0). rewrite (H (Cons_varlist v0 c0)); simpl. rewrite (ics_aux_ok (interp_vl v0) c0). auto. intro. rewrite (ics_aux_ok (interp_vl v0) ((fix csm_aux (s2:canonical_sum) : canonical_sum := match s2 with | Nil_monom => Cons_monom a v c | Cons_monom c2 l2 t2 => if varlist_eq v l2 then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2) else if varlist_lt v l2 then Cons_monom a v (canonical_sum_merge c s2) else Cons_monom c2 l2 (csm_aux t2) | Cons_varlist l2 t2 => if varlist_eq v l2 then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2) else if varlist_lt v l2 then Cons_monom a v (canonical_sum_merge c s2) else Cons_varlist l2 (csm_aux t2) end) c0)); rewrite H0. rewrite (ics_aux_ok (interp_m a v) c); rewrite (ics_aux_ok (interp_vl v0) c0); simpl. auto. simple induction y; simpl; intros. trivial. generalize (varlist_eq_prop v v0). elim (varlist_eq v v0). intros; rewrite (H1 I). simpl. rewrite (ics_aux_ok (interp_m (Aplus Aone a) v0) (canonical_sum_merge c c0)); rewrite (ics_aux_ok (interp_vl v0) c); rewrite (ics_aux_ok (interp_m a v0) c0); rewrite (H c0). rewrite (interp_m_ok (Aplus Aone a) v0); rewrite (interp_m_ok a v0). setoid_replace (Amult (Aplus Aone a) (interp_vl v0)) with (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0))); [ idtac | trivial ]. setoid_replace (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0))) (Aplus (interp_setcs c) (interp_setcs c0))) with (Aplus (Amult Aone (interp_vl v0)) (Aplus (Amult a (interp_vl v0)) (Aplus (interp_setcs c) (interp_setcs c0)))); [ idtac | trivial ]. setoid_replace (Aplus (Aplus (interp_vl v0) (interp_setcs c)) (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))) with (Aplus (interp_vl v0) (Aplus (interp_setcs c) (Aplus (Amult a (interp_vl v0)) (interp_setcs c0)))); [ idtac | trivial ]. auto. elim (varlist_lt v v0); simpl; intros. rewrite (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_monom a v0 c0))) ; rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_m a v0) c0). rewrite (H (Cons_monom a v0 c0)); simpl. rewrite (ics_aux_ok (interp_m a v0) c0); auto. rewrite (ics_aux_ok (interp_m a v0) ((fix csm_aux2 (s2:canonical_sum) : canonical_sum := match s2 with | Nil_monom => Cons_varlist v c | Cons_monom c2 l2 t2 => if varlist_eq v l2 then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2) else if varlist_lt v l2 then Cons_varlist v (canonical_sum_merge c s2) else Cons_monom c2 l2 (csm_aux2 t2) | Cons_varlist l2 t2 => if varlist_eq v l2 then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2) else if varlist_lt v l2 then Cons_varlist v (canonical_sum_merge c s2) else Cons_varlist l2 (csm_aux2 t2) end) c0)); rewrite H0. rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_m a v0) c0); simpl; auto. generalize (varlist_eq_prop v v0). elim (varlist_eq v v0); intros. rewrite (H1 I); simpl. rewrite (ics_aux_ok (interp_m (Aplus Aone Aone) v0) (canonical_sum_merge c c0)) ; rewrite (ics_aux_ok (interp_vl v0) c); rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H c0). rewrite (interp_m_ok (Aplus Aone Aone) v0). setoid_replace (Amult (Aplus Aone Aone) (interp_vl v0)) with (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0))); [ idtac | trivial ]. setoid_replace (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0))) (Aplus (interp_setcs c) (interp_setcs c0))) with (Aplus (Amult Aone (interp_vl v0)) (Aplus (Amult Aone (interp_vl v0)) (Aplus (interp_setcs c) (interp_setcs c0)))); [ idtac | trivial ]. setoid_replace (Aplus (Aplus (interp_vl v0) (interp_setcs c)) (Aplus (interp_vl v0) (interp_setcs c0))) with (Aplus (interp_vl v0) (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0)))); [ idtac | trivial ]. setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); auto. elim (varlist_lt v v0); simpl. rewrite (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_varlist v0 c0))) ; rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H (Cons_varlist v0 c0)); simpl. rewrite (ics_aux_ok (interp_vl v0) c0); auto. rewrite (ics_aux_ok (interp_vl v0) ((fix csm_aux2 (s2:canonical_sum) : canonical_sum := match s2 with | Nil_monom => Cons_varlist v c | Cons_monom c2 l2 t2 => if varlist_eq v l2 then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2) else if varlist_lt v l2 then Cons_varlist v (canonical_sum_merge c s2) else Cons_monom c2 l2 (csm_aux2 t2) | Cons_varlist l2 t2 => if varlist_eq v l2 then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2) else if varlist_lt v l2 then Cons_varlist v (canonical_sum_merge c s2) else Cons_varlist l2 (csm_aux2 t2) end) c0)); rewrite H0. rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_vl v0) c0); simpl; auto. Qed. Lemma monom_insert_ok : forall (a:A) (l:varlist) (s:canonical_sum), Aequiv (interp_setcs (monom_insert a l s)) (Aplus (Amult a (interp_vl l)) (interp_setcs s)). Proof. simple induction s; intros. simpl; rewrite (interp_m_ok a l); trivial. simpl; generalize (varlist_eq_prop l v); elim (varlist_eq l v). intro Hr; rewrite (Hr I); simpl. rewrite (ics_aux_ok (interp_m (Aplus a a0) v) c); rewrite (ics_aux_ok (interp_m a0 v) c). rewrite (interp_m_ok (Aplus a a0) v); rewrite (interp_m_ok a0 v). setoid_replace (Amult (Aplus a a0) (interp_vl v)) with (Aplus (Amult a (interp_vl v)) (Amult a0 (interp_vl v))); [ idtac | trivial ]. auto. elim (varlist_lt l v); simpl; intros. rewrite (ics_aux_ok (interp_m a0 v) c). rewrite (interp_m_ok a0 v); rewrite (interp_m_ok a l). auto. rewrite (ics_aux_ok (interp_m a0 v) (monom_insert a l c)); rewrite (ics_aux_ok (interp_m a0 v) c); rewrite H. auto. simpl. generalize (varlist_eq_prop l v); elim (varlist_eq l v). intro Hr; rewrite (Hr I); simpl. rewrite (ics_aux_ok (interp_m (Aplus a Aone) v) c); rewrite (ics_aux_ok (interp_vl v) c). rewrite (interp_m_ok (Aplus a Aone) v). setoid_replace (Amult (Aplus a Aone) (interp_vl v)) with (Aplus (Amult a (interp_vl v)) (Amult Aone (interp_vl v))); [ idtac | trivial ]. setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); [ idtac | trivial ]. auto. elim (varlist_lt l v); simpl; intros; auto. rewrite (ics_aux_ok (interp_vl v) (monom_insert a l c)); rewrite H. rewrite (ics_aux_ok (interp_vl v) c); auto. Qed. Lemma varlist_insert_ok : forall (l:varlist) (s:canonical_sum), Aequiv (interp_setcs (varlist_insert l s)) (Aplus (interp_vl l) (interp_setcs s)). Proof. simple induction s; simpl; intros. trivial. generalize (varlist_eq_prop l v); elim (varlist_eq l v). intro Hr; rewrite (Hr I); simpl. rewrite (ics_aux_ok (interp_m (Aplus Aone a) v) c); rewrite (ics_aux_ok (interp_m a v) c). rewrite (interp_m_ok (Aplus Aone a) v); rewrite (interp_m_ok a v). setoid_replace (Amult (Aplus Aone a) (interp_vl v)) with (Aplus (Amult Aone (interp_vl v)) (Amult a (interp_vl v))); [ idtac | trivial ]. setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto. elim (varlist_lt l v); simpl; intros; auto. rewrite (ics_aux_ok (interp_m a v) (varlist_insert l c)); rewrite (ics_aux_ok (interp_m a v) c). rewrite (interp_m_ok a v). rewrite H; auto. generalize (varlist_eq_prop l v); elim (varlist_eq l v). intro Hr; rewrite (Hr I); simpl. rewrite (ics_aux_ok (interp_m (Aplus Aone Aone) v) c); rewrite (ics_aux_ok (interp_vl v) c). rewrite (interp_m_ok (Aplus Aone Aone) v). setoid_replace (Amult (Aplus Aone Aone) (interp_vl v)) with (Aplus (Amult Aone (interp_vl v)) (Amult Aone (interp_vl v))); [ idtac | trivial ]. setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto. elim (varlist_lt l v); simpl; intros; auto. rewrite (ics_aux_ok (interp_vl v) (varlist_insert l c)). rewrite H. rewrite (ics_aux_ok (interp_vl v) c); auto. Qed. Lemma canonical_sum_scalar_ok : forall (a:A) (s:canonical_sum), Aequiv (interp_setcs (canonical_sum_scalar a s)) (Amult a (interp_setcs s)). Proof. simple induction s; simpl; intros. trivial. rewrite (ics_aux_ok (interp_m (Amult a a0) v) (canonical_sum_scalar a c)); rewrite (ics_aux_ok (interp_m a0 v) c). rewrite (interp_m_ok (Amult a a0) v); rewrite (interp_m_ok a0 v). rewrite H. setoid_replace (Amult a (Aplus (Amult a0 (interp_vl v)) (interp_setcs c))) with (Aplus (Amult a (Amult a0 (interp_vl v))) (Amult a (interp_setcs c))); [ idtac | trivial ]. auto. rewrite (ics_aux_ok (interp_m a v) (canonical_sum_scalar a c)); rewrite (ics_aux_ok (interp_vl v) c); rewrite H. rewrite (interp_m_ok a v). auto. Qed. Lemma canonical_sum_scalar2_ok : forall (l:varlist) (s:canonical_sum), Aequiv (interp_setcs (canonical_sum_scalar2 l s)) (Amult (interp_vl l) (interp_setcs s)). Proof. simple induction s; simpl; intros; auto. rewrite (monom_insert_ok a (varlist_merge l v) (canonical_sum_scalar2 l c)). rewrite (ics_aux_ok (interp_m a v) c). rewrite (interp_m_ok a v). rewrite H. rewrite (varlist_merge_ok l v). setoid_replace (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c))) with (Aplus (Amult (interp_vl l) (Amult a (interp_vl v))) (Amult (interp_vl l) (interp_setcs c))); [ idtac | trivial ]. auto. rewrite (varlist_insert_ok (varlist_merge l v) (canonical_sum_scalar2 l c)). rewrite (ics_aux_ok (interp_vl v) c). rewrite H. rewrite (varlist_merge_ok l v). auto. Qed. Lemma canonical_sum_scalar3_ok : forall (c:A) (l:varlist) (s:canonical_sum), Aequiv (interp_setcs (canonical_sum_scalar3 c l s)) (Amult c (Amult (interp_vl l) (interp_setcs s))). Proof. simple induction s; simpl; intros. rewrite (SSR_mult_zero_right S T (interp_vl l)). auto. rewrite (monom_insert_ok (Amult c a) (varlist_merge l v) (canonical_sum_scalar3 c l c0)). rewrite (ics_aux_ok (interp_m a v) c0). rewrite (interp_m_ok a v). rewrite H. rewrite (varlist_merge_ok l v). setoid_replace (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c0))) with (Aplus (Amult (interp_vl l) (Amult a (interp_vl v))) (Amult (interp_vl l) (interp_setcs c0))); [ idtac | trivial ]. setoid_replace (Amult c (Aplus (Amult (interp_vl l) (Amult a (interp_vl v))) (Amult (interp_vl l) (interp_setcs c0)))) with (Aplus (Amult c (Amult (interp_vl l) (Amult a (interp_vl v)))) (Amult c (Amult (interp_vl l) (interp_setcs c0)))); [ idtac | trivial ]. setoid_replace (Amult (Amult c a) (Amult (interp_vl l) (interp_vl v))) with (Amult c (Amult a (Amult (interp_vl l) (interp_vl v)))); [ idtac | trivial ]. auto. rewrite (monom_insert_ok c (varlist_merge l v) (canonical_sum_scalar3 c l c0)) . rewrite (ics_aux_ok (interp_vl v) c0). rewrite H. rewrite (varlist_merge_ok l v). setoid_replace (Aplus (Amult c (Amult (interp_vl l) (interp_vl v))) (Amult c (Amult (interp_vl l) (interp_setcs c0)))) with (Amult c (Aplus (Amult (interp_vl l) (interp_vl v)) (Amult (interp_vl l) (interp_setcs c0)))); [ idtac | trivial ]. auto. Qed. Lemma canonical_sum_prod_ok : forall x y:canonical_sum, Aequiv (interp_setcs (canonical_sum_prod x y)) (Amult (interp_setcs x) (interp_setcs y)). Proof. simple induction x; simpl; intros. trivial. rewrite (canonical_sum_merge_ok (canonical_sum_scalar3 a v y) (canonical_sum_prod c y)). rewrite (canonical_sum_scalar3_ok a v y). rewrite (ics_aux_ok (interp_m a v) c). rewrite (interp_m_ok a v). rewrite (H y). setoid_replace (Amult a (Amult (interp_vl v) (interp_setcs y))) with (Amult (Amult a (interp_vl v)) (interp_setcs y)); [ idtac | trivial ]. setoid_replace (Amult (Aplus (Amult a (interp_vl v)) (interp_setcs c)) (interp_setcs y)) with (Aplus (Amult (Amult a (interp_vl v)) (interp_setcs y)) (Amult (interp_setcs c) (interp_setcs y))); [ idtac | trivial ]. trivial. rewrite (canonical_sum_merge_ok (canonical_sum_scalar2 v y) (canonical_sum_prod c y)) . rewrite (canonical_sum_scalar2_ok v y). rewrite (ics_aux_ok (interp_vl v) c). rewrite (H y). trivial. Qed. Theorem setspolynomial_normalize_ok : forall p:setspolynomial, Aequiv (interp_setcs (setspolynomial_normalize p)) (interp_setsp p). Proof. simple induction p; simpl; intros; trivial. rewrite (canonical_sum_merge_ok (setspolynomial_normalize s) (setspolynomial_normalize s0)). rewrite H; rewrite H0; trivial. rewrite (canonical_sum_prod_ok (setspolynomial_normalize s) (setspolynomial_normalize s0)). rewrite H; rewrite H0; trivial. Qed. Lemma canonical_sum_simplify_ok : forall s:canonical_sum, Aequiv (interp_setcs (canonical_sum_simplify s)) (interp_setcs s). Proof. simple induction s; simpl; intros. trivial. generalize (SSR_eq_prop T a Azero). elim (Aeq a Azero). simpl. intros. rewrite (ics_aux_ok (interp_m a v) c). rewrite (interp_m_ok a v). rewrite (H0 I). setoid_replace (Amult Azero (interp_vl v)) with Azero; [ idtac | trivial ]. rewrite H. trivial. intros; simpl. generalize (SSR_eq_prop T a Aone). elim (Aeq a Aone). intros. rewrite (ics_aux_ok (interp_m a v) c). rewrite (interp_m_ok a v). rewrite (H1 I). simpl. rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)). rewrite H. auto. simpl. intros. rewrite (ics_aux_ok (interp_m a v) (canonical_sum_simplify c)). rewrite (ics_aux_ok (interp_m a v) c). rewrite H; trivial. rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)). rewrite H. auto. Qed. Theorem setspolynomial_simplify_ok : forall p:setspolynomial, Aequiv (interp_setcs (setspolynomial_simplify p)) (interp_setsp p). Proof. intro. unfold setspolynomial_simplify. rewrite (canonical_sum_simplify_ok (setspolynomial_normalize p)). exact (setspolynomial_normalize_ok p). Qed. End semi_setoid_rings. Arguments Cons_varlist : default implicits. Arguments Cons_monom : default implicits. Arguments SetSPconst : default implicits. Arguments SetSPplus : default implicits. Arguments SetSPmult : default implicits. Section setoid_rings. Set Implicit Arguments. Variable vm : varmap A. Variable T : Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aopp Aeq. Hint Resolve (STh_plus_comm T). Hint Resolve (STh_plus_assoc T). Hint Resolve (STh_plus_assoc2 S T). Hint Resolve (STh_mult_comm T). Hint Resolve (STh_mult_assoc T). Hint Resolve (STh_mult_assoc2 S T). Hint Resolve (STh_plus_zero_left T). Hint Resolve (STh_plus_zero_left2 S T). Hint Resolve (STh_mult_one_left T). Hint Resolve (STh_mult_one_left2 S T). Hint Resolve (STh_mult_zero_left S plus_morph mult_morph T). Hint Resolve (STh_mult_zero_left2 S plus_morph mult_morph T). Hint Resolve (STh_distr_left T). Hint Resolve (STh_distr_left2 S T). Hint Resolve (STh_plus_reg_left S plus_morph T). Hint Resolve (STh_plus_permute S plus_morph T). Hint Resolve (STh_mult_permute S mult_morph T). Hint Resolve (STh_distr_right S plus_morph T). Hint Resolve (STh_distr_right2 S plus_morph T). Hint Resolve (STh_mult_zero_right S plus_morph mult_morph T). Hint Resolve (STh_mult_zero_right2 S plus_morph mult_morph T). Hint Resolve (STh_plus_zero_right S T). Hint Resolve (STh_plus_zero_right2 S T). Hint Resolve (STh_mult_one_right S T). Hint Resolve (STh_mult_one_right2 S T). Hint Resolve (STh_plus_reg_right S plus_morph T). Hint Resolve eq_refl eq_sym eq_trans. Hint Immediate T. (*** Definitions *) Inductive setpolynomial : Type := | SetPvar : index -> setpolynomial | SetPconst : A -> setpolynomial | SetPplus : setpolynomial -> setpolynomial -> setpolynomial | SetPmult : setpolynomial -> setpolynomial -> setpolynomial | SetPopp : setpolynomial -> setpolynomial. Fixpoint setpolynomial_normalize (x:setpolynomial) : canonical_sum := match x with | SetPplus l r => canonical_sum_merge (setpolynomial_normalize l) (setpolynomial_normalize r) | SetPmult l r => canonical_sum_prod (setpolynomial_normalize l) (setpolynomial_normalize r) | SetPconst c => Cons_monom c Nil_var Nil_monom | SetPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom | SetPopp p => canonical_sum_scalar3 (Aopp Aone) Nil_var (setpolynomial_normalize p) end. Definition setpolynomial_simplify (x:setpolynomial) := canonical_sum_simplify (setpolynomial_normalize x). Fixpoint setspolynomial_of (x:setpolynomial) : setspolynomial := match x with | SetPplus l r => SetSPplus (setspolynomial_of l) (setspolynomial_of r) | SetPmult l r => SetSPmult (setspolynomial_of l) (setspolynomial_of r) | SetPconst c => SetSPconst c | SetPvar i => SetSPvar i | SetPopp p => SetSPmult (SetSPconst (Aopp Aone)) (setspolynomial_of p) end. (*** Interpretation *) Fixpoint interp_setp (p:setpolynomial) : A := match p with | SetPconst c => c | SetPvar i => varmap_find Azero i vm | SetPplus p1 p2 => Aplus (interp_setp p1) (interp_setp p2) | SetPmult p1 p2 => Amult (interp_setp p1) (interp_setp p2) | SetPopp p1 => Aopp (interp_setp p1) end. (*** Properties *) Unset Implicit Arguments. Lemma setspolynomial_of_ok : forall p:setpolynomial, Aequiv (interp_setp p) (interp_setsp vm (setspolynomial_of p)). simple induction p; trivial; simpl; intros. rewrite H; rewrite H0; trivial. rewrite H; rewrite H0; trivial. rewrite H. rewrite (STh_opp_mult_left2 S plus_morph mult_morph T Aone (interp_setsp vm (setspolynomial_of s))). rewrite (STh_mult_one_left T (interp_setsp vm (setspolynomial_of s))). trivial. Qed. Theorem setpolynomial_normalize_ok : forall p:setpolynomial, setpolynomial_normalize p = setspolynomial_normalize (setspolynomial_of p). simple induction p; trivial; simpl; intros. rewrite H; rewrite H0; reflexivity. rewrite H; rewrite H0; reflexivity. rewrite H; simpl. elim (canonical_sum_scalar3 (Aopp Aone) Nil_var (setspolynomial_normalize (setspolynomial_of s))); [ reflexivity | simpl; intros; rewrite H0; reflexivity | simpl; intros; rewrite H0; reflexivity ]. Qed. Theorem setpolynomial_simplify_ok : forall p:setpolynomial, Aequiv (interp_setcs vm (setpolynomial_simplify p)) (interp_setp p). intro. unfold setpolynomial_simplify. rewrite (setspolynomial_of_ok p). rewrite setpolynomial_normalize_ok. rewrite (canonical_sum_simplify_ok vm (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq plus_morph mult_morph T) (setspolynomial_normalize (setspolynomial_of p))) . rewrite (setspolynomial_normalize_ok vm (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq plus_morph mult_morph T) (setspolynomial_of p)) . trivial. Qed. End setoid_rings. End setoid. coq-8.4pl4/plugins/ring/Setoid_ring_theory.v0000644000175000017500000002530212326224777020304 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* A -> Prop. Infix Local "==" := Aequiv (at level 70, no associativity). Variable S : Setoid_Theory A Aequiv. Add Setoid A Aequiv S as Asetoid. Variable Aplus : A -> A -> A. Variable Amult : A -> A -> A. Variable Aone : A. Variable Azero : A. Variable Aopp : A -> A. Variable Aeq : A -> A -> bool. Infix "+" := Aplus (at level 50, left associativity). Infix "*" := Amult (at level 40, left associativity). Notation "0" := Azero. Notation "1" := Aone. Notation "- x" := (Aopp x). Variable plus_morph : forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a + a1 == a0 + a2. Variable mult_morph : forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a * a1 == a0 * a2. Variable opp_morph : forall a a0:A, a == a0 -> - a == - a0. Add Morphism Aplus : Aplus_ext. intros; apply plus_morph; assumption. Qed. Add Morphism Amult : Amult_ext. intros; apply mult_morph; assumption. Qed. Add Morphism Aopp : Aopp_ext. exact opp_morph. Qed. Section Theory_of_semi_setoid_rings. Record Semi_Setoid_Ring_Theory : Prop := {SSR_plus_comm : forall n m:A, n + m == m + n; SSR_plus_assoc : forall n m p:A, n + (m + p) == n + m + p; SSR_mult_comm : forall n m:A, n * m == m * n; SSR_mult_assoc : forall n m p:A, n * (m * p) == n * m * p; SSR_plus_zero_left : forall n:A, 0 + n == n; SSR_mult_one_left : forall n:A, 1 * n == n; SSR_mult_zero_left : forall n:A, 0 * n == 0; SSR_distr_left : forall n m p:A, (n + m) * p == n * p + m * p; SSR_plus_reg_left : forall n m p:A, n + m == n + p -> m == p; SSR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}. Variable T : Semi_Setoid_Ring_Theory. Let plus_comm := SSR_plus_comm T. Let plus_assoc := SSR_plus_assoc T. Let mult_comm := SSR_mult_comm T. Let mult_assoc := SSR_mult_assoc T. Let plus_zero_left := SSR_plus_zero_left T. Let mult_one_left := SSR_mult_one_left T. Let mult_zero_left := SSR_mult_zero_left T. Let distr_left := SSR_distr_left T. Let plus_reg_left := SSR_plus_reg_left T. Let equiv_refl := Seq_refl A Aequiv S. Let equiv_sym := Seq_sym A Aequiv S. Let equiv_trans := Seq_trans A Aequiv S. Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left mult_one_left mult_zero_left distr_left plus_reg_left equiv_refl (*equiv_sym*). Hint Immediate equiv_sym. (* Lemmas whose form is x=y are also provided in form y=x because Auto does not symmetry *) Lemma SSR_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p). auto. Qed. Lemma SSR_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p). auto. Qed. Lemma SSR_plus_zero_left2 : forall n:A, n == 0 + n. auto. Qed. Lemma SSR_mult_one_left2 : forall n:A, n == 1 * n. auto. Qed. Lemma SSR_mult_zero_left2 : forall n:A, 0 == 0 * n. auto. Qed. Lemma SSR_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p. auto. Qed. Lemma SSR_plus_permute : forall n m p:A, n + (m + p) == m + (n + p). intros. rewrite (plus_assoc n m p). rewrite (plus_comm n m). rewrite <- (plus_assoc m n p). trivial. Qed. Lemma SSR_mult_permute : forall n m p:A, n * (m * p) == m * (n * p). intros. rewrite (mult_assoc n m p). rewrite (mult_comm n m). rewrite <- (mult_assoc m n p). trivial. Qed. Hint Resolve SSR_plus_permute SSR_mult_permute. Lemma SSR_distr_right : forall n m p:A, n * (m + p) == n * m + n * p. intros. rewrite (mult_comm n (m + p)). rewrite (mult_comm n m). rewrite (mult_comm n p). auto. Qed. Lemma SSR_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p). intros. apply equiv_sym. apply SSR_distr_right. Qed. Lemma SSR_mult_zero_right : forall n:A, n * 0 == 0. intro; rewrite (mult_comm n 0); auto. Qed. Lemma SSR_mult_zero_right2 : forall n:A, 0 == n * 0. intro; rewrite (mult_comm n 0); auto. Qed. Lemma SSR_plus_zero_right : forall n:A, n + 0 == n. intro; rewrite (plus_comm n 0); auto. Qed. Lemma SSR_plus_zero_right2 : forall n:A, n == n + 0. intro; rewrite (plus_comm n 0); auto. Qed. Lemma SSR_mult_one_right : forall n:A, n * 1 == n. intro; rewrite (mult_comm n 1); auto. Qed. Lemma SSR_mult_one_right2 : forall n:A, n == n * 1. intro; rewrite (mult_comm n 1); auto. Qed. Lemma SSR_plus_reg_right : forall n m p:A, m + n == p + n -> m == p. intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n). intro; apply plus_reg_left with n; trivial. Qed. End Theory_of_semi_setoid_rings. Section Theory_of_setoid_rings. Record Setoid_Ring_Theory : Prop := {STh_plus_comm : forall n m:A, n + m == m + n; STh_plus_assoc : forall n m p:A, n + (m + p) == n + m + p; STh_mult_comm : forall n m:A, n * m == m * n; STh_mult_assoc : forall n m p:A, n * (m * p) == n * m * p; STh_plus_zero_left : forall n:A, 0 + n == n; STh_mult_one_left : forall n:A, 1 * n == n; STh_opp_def : forall n:A, n + - n == 0; STh_distr_left : forall n m p:A, (n + m) * p == n * p + m * p; STh_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}. Variable T : Setoid_Ring_Theory. Let plus_comm := STh_plus_comm T. Let plus_assoc := STh_plus_assoc T. Let mult_comm := STh_mult_comm T. Let mult_assoc := STh_mult_assoc T. Let plus_zero_left := STh_plus_zero_left T. Let mult_one_left := STh_mult_one_left T. Let opp_def := STh_opp_def T. Let distr_left := STh_distr_left T. Let equiv_refl := Seq_refl A Aequiv S. Let equiv_sym := Seq_sym A Aequiv S. Let equiv_trans := Seq_trans A Aequiv S. Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left mult_one_left opp_def distr_left equiv_refl equiv_sym. (* Lemmas whose form is x=y are also provided in form y=x because Auto does not symmetry *) Lemma STh_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p). auto. Qed. Lemma STh_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p). auto. Qed. Lemma STh_plus_zero_left2 : forall n:A, n == 0 + n. auto. Qed. Lemma STh_mult_one_left2 : forall n:A, n == 1 * n. auto. Qed. Lemma STh_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p. auto. Qed. Lemma STh_opp_def2 : forall n:A, 0 == n + - n. auto. Qed. Lemma STh_plus_permute : forall n m p:A, n + (m + p) == m + (n + p). intros. rewrite (plus_assoc n m p). rewrite (plus_comm n m). rewrite <- (plus_assoc m n p). trivial. Qed. Lemma STh_mult_permute : forall n m p:A, n * (m * p) == m * (n * p). intros. rewrite (mult_assoc n m p). rewrite (mult_comm n m). rewrite <- (mult_assoc m n p). trivial. Qed. Hint Resolve STh_plus_permute STh_mult_permute. Lemma Saux1 : forall a:A, a + a == a -> a == 0. intros. rewrite <- (plus_zero_left a). rewrite (plus_comm 0 a). setoid_replace (a + 0) with (a + (a + - a)) by auto. rewrite (plus_assoc a a (- a)). rewrite H. apply opp_def. Qed. Lemma STh_mult_zero_left : forall n:A, 0 * n == 0. intros. apply Saux1. rewrite <- (distr_left 0 0 n). rewrite (plus_zero_left 0). trivial. Qed. Hint Resolve STh_mult_zero_left. Lemma STh_mult_zero_left2 : forall n:A, 0 == 0 * n. auto. Qed. Lemma Saux2 : forall x y z:A, x + y == 0 -> x + z == 0 -> y == z. intros. rewrite <- (plus_zero_left y). rewrite <- H0. rewrite <- (plus_assoc x z y). rewrite (plus_comm z y). rewrite (plus_assoc x y z). rewrite H. auto. Qed. Lemma STh_opp_mult_left : forall x y:A, - (x * y) == - x * y. intros. apply Saux2 with (x * y); auto. rewrite <- (distr_left x (- x) y). rewrite (opp_def x). auto. Qed. Hint Resolve STh_opp_mult_left. Lemma STh_opp_mult_left2 : forall x y:A, - x * y == - (x * y). auto. Qed. Lemma STh_mult_zero_right : forall n:A, n * 0 == 0. intro; rewrite (mult_comm n 0); auto. Qed. Lemma STh_mult_zero_right2 : forall n:A, 0 == n * 0. intro; rewrite (mult_comm n 0); auto. Qed. Lemma STh_plus_zero_right : forall n:A, n + 0 == n. intro; rewrite (plus_comm n 0); auto. Qed. Lemma STh_plus_zero_right2 : forall n:A, n == n + 0. intro; rewrite (plus_comm n 0); auto. Qed. Lemma STh_mult_one_right : forall n:A, n * 1 == n. intro; rewrite (mult_comm n 1); auto. Qed. Lemma STh_mult_one_right2 : forall n:A, n == n * 1. intro; rewrite (mult_comm n 1); auto. Qed. Lemma STh_opp_mult_right : forall x y:A, - (x * y) == x * - y. intros. rewrite (mult_comm x y). rewrite (mult_comm x (- y)). auto. Qed. Lemma STh_opp_mult_right2 : forall x y:A, x * - y == - (x * y). intros. rewrite (mult_comm x y). rewrite (mult_comm x (- y)). auto. Qed. Lemma STh_plus_opp_opp : forall x y:A, - x + - y == - (x + y). intros. apply Saux2 with (x + y); auto. rewrite (STh_plus_permute (x + y) (- x) (- y)). rewrite <- (plus_assoc x y (- y)). rewrite (opp_def y); rewrite (STh_plus_zero_right x). rewrite (STh_opp_def2 x); trivial. Qed. Lemma STh_plus_permute_opp : forall n m p:A, - m + (n + p) == n + (- m + p). auto. Qed. Lemma STh_opp_opp : forall n:A, - - n == n. intro. apply Saux2 with (- n); auto. rewrite (plus_comm (- n) n); auto. Qed. Hint Resolve STh_opp_opp. Lemma STh_opp_opp2 : forall n:A, n == - - n. auto. Qed. Lemma STh_mult_opp_opp : forall x y:A, - x * - y == x * y. intros. rewrite (STh_opp_mult_left2 x (- y)). rewrite (STh_opp_mult_right2 x y). trivial. Qed. Lemma STh_mult_opp_opp2 : forall x y:A, x * y == - x * - y. intros. apply equiv_sym. apply STh_mult_opp_opp. Qed. Lemma STh_opp_zero : - 0 == 0. rewrite <- (plus_zero_left (- 0)). trivial. Qed. Lemma STh_plus_reg_left : forall n m p:A, n + m == n + p -> m == p. intros. rewrite <- (plus_zero_left m). rewrite <- (plus_zero_left p). rewrite <- (opp_def n). rewrite (plus_comm n (- n)). rewrite <- (plus_assoc (- n) n m). rewrite <- (plus_assoc (- n) n p). auto. Qed. Lemma STh_plus_reg_right : forall n m p:A, m + n == p + n -> m == p. intros. apply STh_plus_reg_left with n. rewrite (plus_comm n m); rewrite (plus_comm n p); assumption. Qed. Lemma STh_distr_right : forall n m p:A, n * (m + p) == n * m + n * p. intros. rewrite (mult_comm n (m + p)). rewrite (mult_comm n m). rewrite (mult_comm n p). trivial. Qed. Lemma STh_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p). intros. apply equiv_sym. apply STh_distr_right. Qed. End Theory_of_setoid_rings. Hint Resolve STh_mult_zero_left STh_plus_reg_left: core. Unset Implicit Arguments. Definition Semi_Setoid_Ring_Theory_of : Setoid_Ring_Theory -> Semi_Setoid_Ring_Theory. intros until 1; case H. split; intros; simpl; eauto. Defined. Coercion Semi_Setoid_Ring_Theory_of : Setoid_Ring_Theory >-> Semi_Setoid_Ring_Theory. Section product_ring. End product_ring. Section power_ring. End power_ring. End Setoid_rings. coq-8.4pl4/plugins/ring/LegacyRing.v0000644000175000017500000000256112326224777016472 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* b) eqb. split; simpl. destruct n; destruct m; reflexivity. destruct n; destruct m; destruct p; reflexivity. destruct n; destruct m; reflexivity. destruct n; destruct m; destruct p; reflexivity. destruct n; reflexivity. destruct n; reflexivity. destruct n; reflexivity. destruct n; destruct m; destruct p; reflexivity. destruct x; destruct y; reflexivity || simpl; tauto. Defined. Add Legacy Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory [ true false ]. coq-8.4pl4/plugins/ring/LegacyNArithRing.v0000644000175000017500000000254512326224777017602 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | _ => false end. Lemma Neq_prop : forall n m:N, Is_true (Neq n m) -> n = m. intros n m H; unfold Neq in H. apply N.compare_eq. destruct (n ?= m)%N; [ reflexivity | contradiction | contradiction ]. Qed. Definition NTheory : Semi_Ring_Theory N.add N.mul 1%N 0%N Neq. split. apply N.add_comm. apply N.add_assoc. apply N.mul_comm. apply N.mul_assoc. apply N.add_0_l. apply N.mul_1_l. apply N.mul_0_l. apply N.mul_add_distr_r. apply Neq_prop. Qed. Add Legacy Semi Ring N N.add N.mul 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ]. coq-8.4pl4/plugins/ring/ring.ml0000644000175000017500000007757212326224777015566 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* to be found in Coqlib *) open Coqlib let mkLApp(fc,v) = mkApp(Lazy.force fc, v) (*********** Useful types and functions ************) module OperSet = Set.Make (struct type t = global_reference let compare = (RefOrdered.compare : t->t->int) end) type morph = { plusm : constr; multm : constr; oppm : constr option; } type theory = { th_ring : bool; (* false for a semi-ring *) th_abstract : bool; th_setoid : bool; (* true for a setoid ring *) th_equiv : constr option; th_setoid_th : constr option; th_morph : morph option; th_a : constr; (* e.g. nat *) th_plus : constr; th_mult : constr; th_one : constr; th_zero : constr; th_opp : constr option; (* None if semi-ring *) th_eq : constr; th_t : constr; (* e.g. NatTheory *) th_closed : ConstrSet.t; (* e.g. [S; O] *) (* Must be empty for an abstract ring *) } (* Theories are stored in a table which is synchronised with the Reset mechanism. *) module Cmap = Map.Make(struct type t = constr let compare = constr_ord end) let theories_map = ref Cmap.empty let theories_map_add (c,t) = theories_map := Cmap.add c t !theories_map let theories_map_find c = Cmap.find c !theories_map let theories_map_mem c = Cmap.mem c !theories_map let _ = Summary.declare_summary "tactic-ring-table" { Summary.freeze_function = (fun () -> !theories_map); Summary.unfreeze_function = (fun t -> theories_map := t); Summary.init_function = (fun () -> theories_map := Cmap.empty) } (* declare a new type of object in the environment, "tactic-ring-theory" The functions theory_to_obj and obj_to_theory do the conversions between theories and environement objects. *) let subst_morph subst morph = let plusm' = subst_mps subst morph.plusm in let multm' = subst_mps subst morph.multm in let oppm' = Option.smartmap (subst_mps subst) morph.oppm in if plusm' == morph.plusm && multm' == morph.multm && oppm' == morph.oppm then morph else { plusm = plusm' ; multm = multm' ; oppm = oppm' ; } let subst_set subst cset = let same = ref true in let copy_subst c newset = let c' = subst_mps subst c in if not (c' == c) then same := false; ConstrSet.add c' newset in let cset' = ConstrSet.fold copy_subst cset ConstrSet.empty in if !same then cset else cset' let subst_theory subst th = let th_equiv' = Option.smartmap (subst_mps subst) th.th_equiv in let th_setoid_th' = Option.smartmap (subst_mps subst) th.th_setoid_th in let th_morph' = Option.smartmap (subst_morph subst) th.th_morph in let th_a' = subst_mps subst th.th_a in let th_plus' = subst_mps subst th.th_plus in let th_mult' = subst_mps subst th.th_mult in let th_one' = subst_mps subst th.th_one in let th_zero' = subst_mps subst th.th_zero in let th_opp' = Option.smartmap (subst_mps subst) th.th_opp in let th_eq' = subst_mps subst th.th_eq in let th_t' = subst_mps subst th.th_t in let th_closed' = subst_set subst th.th_closed in if th_equiv' == th.th_equiv && th_setoid_th' == th.th_setoid_th && th_morph' == th.th_morph && th_a' == th.th_a && th_plus' == th.th_plus && th_mult' == th.th_mult && th_one' == th.th_one && th_zero' == th.th_zero && th_opp' == th.th_opp && th_eq' == th.th_eq && th_t' == th.th_t && th_closed' == th.th_closed then th else { th_ring = th.th_ring ; th_abstract = th.th_abstract ; th_setoid = th.th_setoid ; th_equiv = th_equiv' ; th_setoid_th = th_setoid_th' ; th_morph = th_morph' ; th_a = th_a' ; th_plus = th_plus' ; th_mult = th_mult' ; th_one = th_one' ; th_zero = th_zero' ; th_opp = th_opp' ; th_eq = th_eq' ; th_t = th_t' ; th_closed = th_closed' ; } let subst_th (subst,(c,th as obj)) = let c' = subst_mps subst c in let th' = subst_theory subst th in if c' == c && th' == th then obj else (c',th') let theory_to_obj : constr * theory -> obj = let cache_th (_,(c, th)) = theories_map_add (c,th) in declare_object {(default_object "tactic-ring-theory") with open_function = (fun i o -> if i=1 then cache_th o); cache_function = cache_th; subst_function = subst_th; classify_function = (fun x -> Substitute x) } (* from the set A, guess the associated theory *) (* With this simple solution, the theory to use is automatically guessed *) (* But only one theory can be declared for a given Set *) let guess_theory a = try theories_map_find a with Not_found -> errorlabstrm "Ring" (str "No Declared Ring Theory for " ++ pr_lconstr a ++ fnl () ++ str "Use Add [Semi] Ring to declare it") (* Looks up an option *) let unbox = function | Some w -> w | None -> anomaly "Ring : Not in case of a setoid ring." (* Protects the convertibility test against undue exceptions when using it with untyped terms *) let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with e when Errors.noncritical e -> false (* Add a Ring or a Semi-Ring to the database after a type verification *) let implement_theory env t th args = is_conv env Evd.empty (Typing.type_of env Evd.empty t) (mkLApp (th, args)) (* (\* The following test checks whether the provided morphism is the default *) (* one for the given operation. In principle the test is too strict, since *) (* it should possible to provide another proof for the same fact (proof *) (* irrelevance). In particular, the error message is be not very explicative. *\) *) let states_compatibility_for env plus mult opp morphs = let check op compat = true in (* is_conv env Evd.empty (Setoid_replace.default_morphism op).Setoid_replace.lem *) (* compat in *) check plus morphs.plusm && check mult morphs.multm && (match (opp,morphs.oppm) with None, None -> true | Some opp, Some compat -> check opp compat | _,_ -> assert false) let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus amult aone azero aopp aeq t cset = if theories_map_mem a then errorlabstrm "Add Semi Ring" (str "A (Semi-)(Setoid-)Ring Structure is already declared for " ++ pr_lconstr a); let env = Global.env () in if (want_ring & want_setoid & ( not (implement_theory env t coq_Setoid_Ring_Theory [| a; (unbox aequiv); aplus; amult; aone; azero; (unbox aopp); aeq|]) || not (implement_theory env (unbox asetth) coq_Setoid_Theory [| a; (unbox aequiv) |]) || not (states_compatibility_for env aplus amult aopp (unbox amorph)) )) then errorlabstrm "addring" (str "Not a valid Setoid-Ring theory"); if (not want_ring & want_setoid & ( not (implement_theory env t coq_Semi_Setoid_Ring_Theory [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|]) || not (implement_theory env (unbox asetth) coq_Setoid_Theory [| a; (unbox aequiv) |]) || not (states_compatibility_for env aplus amult aopp (unbox amorph)))) then errorlabstrm "addring" (str "Not a valid Semi-Setoid-Ring theory"); if (want_ring & not want_setoid & not (implement_theory env t coq_Ring_Theory [| a; aplus; amult; aone; azero; (unbox aopp); aeq |])) then errorlabstrm "addring" (str "Not a valid Ring theory"); if (not want_ring & not want_setoid & not (implement_theory env t coq_Semi_Ring_Theory [| a; aplus; amult; aone; azero; aeq |])) then errorlabstrm "addring" (str "Not a valid Semi-Ring theory"); Lib.add_anonymous_leaf (theory_to_obj (a, { th_ring = want_ring; th_abstract = want_abstract; th_setoid = want_setoid; th_equiv = aequiv; th_setoid_th = asetth; th_morph = amorph; th_a = a; th_plus = aplus; th_mult = amult; th_one = aone; th_zero = azero; th_opp = aopp; th_eq = aeq; th_t = t; th_closed = cset })) (******** The tactic itself *********) (* gl : goal sigma th : semi-ring theory (concrete) cl : constr list [c1; c2; ...] Builds - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i *) module Constrhash = Hashtbl.Make (struct type t = constr let equal = eq_constr let hash = hash_constr end) let build_spolynom gl th lc = let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) (* aux creates the spolynom p by a recursive destructuration of c and builds the varmap with side-effects *) let rec aux c = match (kind_of_term (strip_outer_cast c)) with | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_SPplus, [|th.th_a; aux c1; aux c2 |]) | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> mkLApp(coq_SPmult, [|th.th_a; aux c1; aux c2 |]) | _ when closed_under th.th_closed c -> mkLApp(coq_SPconst, [|th.th_a; c |]) | _ -> try Constrhash.find varhash c with Not_found -> let newvar = mkLApp(coq_SPvar, [|th.th_a; (path_of_int !counter) |]) in begin incr counter; varlist := c :: !varlist; Constrhash.add varhash c newvar; newvar end in let lp = List.map aux lc in let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in List.map (fun p -> (mkLApp (coq_interp_sp, [|th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]), mkLApp (coq_interp_cs, [|th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; pf_reduce cbv_betadeltaiota gl (mkLApp (coq_spolynomial_simplify, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; th.th_eq; p|])) |]), mkLApp (coq_spolynomial_simplify_ok, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; th.th_eq; v; th.th_t; p |]))) lp (* gl : goal sigma th : ring theory (concrete) cl : constr list [c1; c2; ...] Builds - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i *) let build_polynom gl th lc = let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) let rec aux c = match (kind_of_term (strip_outer_cast c)) with | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_Pplus, [|th.th_a; aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> mkLApp(coq_Pmult, [|th.th_a; aux c1; aux c2 |]) (* The special case of Z.sub *) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl c (mkApp (th.th_plus, [|c1; mkApp(unbox th.th_opp, [|c2|])|])) -> mkLApp(coq_Pplus, [|th.th_a; aux c1; mkLApp(coq_Popp, [|th.th_a; aux c2|]) |]) | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) -> mkLApp(coq_Popp, [|th.th_a; aux c1|]) | _ when closed_under th.th_closed c -> mkLApp(coq_Pconst, [|th.th_a; c |]) | _ -> try Constrhash.find varhash c with Not_found -> let newvar = mkLApp(coq_Pvar, [|th.th_a; (path_of_int !counter) |]) in begin incr counter; varlist := c :: !varlist; Constrhash.add varhash c newvar; newvar end in let lp = List.map aux lc in let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in List.map (fun p -> (mkLApp(coq_interp_p, [| th.th_a; th.th_plus; th.th_mult; th.th_zero; (unbox th.th_opp); v; p |])), mkLApp(coq_interp_cs, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; pf_reduce cbv_betadeltaiota gl (mkLApp(coq_polynomial_simplify, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; (unbox th.th_opp); th.th_eq; p |])) |]), mkLApp(coq_polynomial_simplify_ok, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; (unbox th.th_opp); th.th_eq; v; th.th_t; p |])) lp (* gl : goal sigma th : semi-ring theory (abstract) cl : constr list [c1; c2; ...] Builds - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i *) let build_aspolynom gl th lc = let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) (* aux creates the aspolynom p by a recursive destructuration of c and builds the varmap with side-effects *) let rec aux c = match (kind_of_term (strip_outer_cast c)) with | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_ASPplus, [| aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> mkLApp(coq_ASPmult, [| aux c1; aux c2 |]) | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_ASP0 | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_ASP1 | _ -> try Constrhash.find varhash c with Not_found -> let newvar = mkLApp(coq_ASPvar, [|(path_of_int !counter) |]) in begin incr counter; varlist := c :: !varlist; Constrhash.add varhash c newvar; newvar end in let lp = List.map aux lc in let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in List.map (fun p -> (mkLApp(coq_interp_asp, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; p |]), mkLApp(coq_interp_acs, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; pf_reduce cbv_betadeltaiota gl (mkLApp(coq_aspolynomial_normalize,[|p|])) |]), mkLApp(coq_spolynomial_simplify_ok, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; th.th_eq; v; th.th_t; p |]))) lp (* gl : goal sigma th : ring theory (abstract) cl : constr list [c1; c2; ...] Builds - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i *) let build_apolynom gl th lc = let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) let rec aux c = match (kind_of_term (strip_outer_cast c)) with | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_APplus, [| aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> mkLApp(coq_APmult, [| aux c1; aux c2 |]) (* The special case of Z.sub *) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl c (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|]) |])) -> mkLApp(coq_APplus, [|aux c1; mkLApp(coq_APopp,[|aux c2|]) |]) | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) -> mkLApp(coq_APopp, [| aux c1 |]) | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_AP0 | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_AP1 | _ -> try Constrhash.find varhash c with Not_found -> let newvar = mkLApp(coq_APvar, [| path_of_int !counter |]) in begin incr counter; varlist := c :: !varlist; Constrhash.add varhash c newvar; newvar end in let lp = List.map aux lc in let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in List.map (fun p -> (mkLApp(coq_interp_ap, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; (unbox th.th_opp); v; p |]), mkLApp(coq_interp_sacs, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; (unbox th.th_opp); v; pf_reduce cbv_betadeltaiota gl (mkLApp(coq_apolynomial_normalize, [|p|])) |]), mkLApp(coq_apolynomial_normalize_ok, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; (unbox th.th_opp); th.th_eq; v; th.th_t; p |]))) lp (* gl : goal sigma th : setoid ring theory (concrete) cl : constr list [c1; c2; ...] Builds - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i *) let build_setpolynom gl th lc = let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) let rec aux c = match (kind_of_term (strip_outer_cast c)) with | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_SetPplus, [|th.th_a; aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> mkLApp(coq_SetPmult, [|th.th_a; aux c1; aux c2 |]) (* The special case of Z.sub *) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl c (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|])|])) -> mkLApp(coq_SetPplus, [| th.th_a; aux c1; mkLApp(coq_SetPopp, [|th.th_a; aux c2|]) |]) | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) -> mkLApp(coq_SetPopp, [| th.th_a; aux c1 |]) | _ when closed_under th.th_closed c -> mkLApp(coq_SetPconst, [| th.th_a; c |]) | _ -> try Constrhash.find varhash c with Not_found -> let newvar = mkLApp(coq_SetPvar, [| th.th_a; path_of_int !counter |]) in begin incr counter; varlist := c :: !varlist; Constrhash.add varhash c newvar; newvar end in let lp = List.map aux lc in let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in List.map (fun p -> (mkLApp(coq_interp_setp, [| th.th_a; th.th_plus; th.th_mult; th.th_zero; (unbox th.th_opp); v; p |]), mkLApp(coq_interp_setcs, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; pf_reduce cbv_betadeltaiota gl (mkLApp(coq_setpolynomial_simplify, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; (unbox th.th_opp); th.th_eq; p |])) |]), mkLApp(coq_setpolynomial_simplify_ok, [| th.th_a; (unbox th.th_equiv); th.th_plus; th.th_mult; th.th_one; th.th_zero;(unbox th.th_opp); th.th_eq; (unbox th.th_setoid_th); (unbox th.th_morph).plusm; (unbox th.th_morph).multm; (unbox (unbox th.th_morph).oppm); v; th.th_t; p |]))) lp (* gl : goal sigma th : semi setoid ring theory (concrete) cl : constr list [c1; c2; ...] Builds - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i *) let build_setspolynom gl th lc = let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) let rec aux c = match (kind_of_term (strip_outer_cast c)) with | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_SetSPplus, [|th.th_a; aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> mkLApp(coq_SetSPmult, [| th.th_a; aux c1; aux c2 |]) | _ when closed_under th.th_closed c -> mkLApp(coq_SetSPconst, [| th.th_a; c |]) | _ -> try Constrhash.find varhash c with Not_found -> let newvar = mkLApp(coq_SetSPvar, [|th.th_a; path_of_int !counter |]) in begin incr counter; varlist := c :: !varlist; Constrhash.add varhash c newvar; newvar end in let lp = List.map aux lc in let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in List.map (fun p -> (mkLApp(coq_interp_setsp, [| th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]), mkLApp(coq_interp_setcs, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; pf_reduce cbv_betadeltaiota gl (mkLApp(coq_setspolynomial_simplify, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; th.th_eq; p |])) |]), mkLApp(coq_setspolynomial_simplify_ok, [| th.th_a; (unbox th.th_equiv); th.th_plus; th.th_mult; th.th_one; th.th_zero; th.th_eq; (unbox th.th_setoid_th); (unbox th.th_morph).plusm; (unbox th.th_morph).multm; v; th.th_t; p |]))) lp module SectionPathSet = Set.Make(struct type t = full_path let compare = Pervasives.compare end) (* Avec l'uniformisation des red_kind, on perd ici sur la structure SectionPathSet; peut-ętre faudra-t-il la déplacer dans Closure *) let constants_to_unfold = (* List.fold_right SectionPathSet.add *) let transform s = let sp = path_of_string s in let dir, id = repr_path sp in Libnames.encode_con dir id in List.map transform [ "Coq.ring.Ring_normalize.interp_cs"; "Coq.ring.Ring_normalize.interp_var"; "Coq.ring.Ring_normalize.interp_vl"; "Coq.ring.Ring_abstract.interp_acs"; "Coq.ring.Ring_abstract.interp_sacs"; "Coq.quote.Quote.varmap_find"; (* anciennement des Local devenus Definition *) "Coq.ring.Ring_normalize.ics_aux"; "Coq.ring.Ring_normalize.ivl_aux"; "Coq.ring.Ring_normalize.interp_m"; "Coq.ring.Ring_abstract.iacs_aux"; "Coq.ring.Ring_abstract.isacs_aux"; "Coq.ring.Setoid_ring_normalize.interp_cs"; "Coq.ring.Setoid_ring_normalize.interp_var"; "Coq.ring.Setoid_ring_normalize.interp_vl"; "Coq.ring.Setoid_ring_normalize.ics_aux"; "Coq.ring.Setoid_ring_normalize.ivl_aux"; "Coq.ring.Setoid_ring_normalize.interp_m"; ] (* SectionPathSet.empty *) (* Unfolds the functions interp and find_btree in the term c of goal gl *) open RedFlags let polynom_unfold_tac = let flags = (mkflags(fBETA::fIOTA::(List.map fCONST constants_to_unfold))) in reduct_in_concl (cbv_norm_flags flags,DEFAULTcast) let polynom_unfold_tac_in_term gl = let flags = (mkflags(fBETA::fIOTA::fZETA::(List.map fCONST constants_to_unfold))) in cbv_norm_flags flags (pf_env gl) (project gl) (* lc : constr list *) (* th : theory associated to t *) (* op : clause (None for conclusion or Some id for hypothesis id) *) (* gl : goal *) (* Does the rewriting c_i -> (interp R RC v (polynomial_simplify p_i)) where the ring R, the Ring theory RC, the varmap v and the polynomials p_i are guessed and such that c_i = (interp R RC v p_i) *) let raw_polynom th op lc gl = (* first we sort the terms : if t' is a subterm of t it must appear after t in the list. This is to avoid that the normalization of t' modifies t in a non-desired way *) let lc = sort_subterm gl lc in let ltriplets = if th.th_setoid then if th.th_ring then build_setpolynom gl th lc else build_setspolynom gl th lc else if th.th_ring then if th.th_abstract then build_apolynom gl th lc else build_polynom gl th lc else if th.th_abstract then build_aspolynom gl th lc else build_spolynom gl th lc in let polynom_tac = List.fold_right2 (fun ci (c'i, c''i, c'i_eq_c''i) tac -> let c'''i = if !term_quality then polynom_unfold_tac_in_term gl c''i else c''i in if !term_quality && safe_pf_conv_x gl c'''i ci then tac (* convertible terms *) else if th.th_setoid then (tclORELSE (tclORELSE (h_exact c'i_eq_c''i) (h_exact (mkLApp(coq_seq_sym, [| th.th_a; (unbox th.th_equiv); (unbox th.th_setoid_th); c'''i; ci; c'i_eq_c''i |])))) (tclTHENS (tclORELSE (Equality.general_rewrite true Termops.all_occurrences true false c'i_eq_c''i) (Equality.general_rewrite false Termops.all_occurrences true false c'i_eq_c''i)) [tac])) else (tclORELSE (tclORELSE (h_exact c'i_eq_c''i) (h_exact (mkApp(build_coq_eq_sym (), [|th.th_a; c'''i; ci; c'i_eq_c''i |])))) (tclTHENS (elim_type (mkApp(build_coq_eq (), [|th.th_a; c'''i; ci |]))) [ tac; h_exact c'i_eq_c''i ])) ) lc ltriplets polynom_unfold_tac in polynom_tac gl let guess_eq_tac th = (tclORELSE reflexivity (tclTHEN polynom_unfold_tac (tclTHEN (* Normalized sums associate on the right *) (tclREPEAT (tclTHENFIRST (apply (mkApp(build_coq_f_equal2 (), [| th.th_a; th.th_a; th.th_a; th.th_plus |]))) reflexivity)) (tclTRY (tclTHENLAST (apply (mkApp(build_coq_f_equal2 (), [| th.th_a; th.th_a; th.th_a; th.th_plus |]))) reflexivity))))) let guess_equiv_tac th = (tclORELSE (apply (mkLApp(coq_seq_refl, [| th.th_a; (unbox th.th_equiv); (unbox th.th_setoid_th)|]))) (tclTHEN polynom_unfold_tac (tclREPEAT (tclORELSE (apply (unbox th.th_morph).plusm) (apply (unbox th.th_morph).multm))))) let match_with_equiv c = match (kind_of_term c) with | App (e,a) -> if (List.mem e []) (* (Setoid_replace.equiv_list ())) *) then Some (decompose_app c) else None | _ -> None let polynom lc gl = Coqlib.check_required_library ["Coq";"ring";"LegacyRing"]; match lc with (* If no argument is given, try to recognize either an equality or a declared relation with arguments c1 ... cn, do "Ring c1 c2 ... cn" and then try to apply the simplification theorems declared for the relation *) | [] -> (try match Hipattern.match_with_equation (pf_concl gl) with | _,_,Hipattern.PolymorphicLeibnizEq (t,c1,c2) -> let th = guess_theory t in (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl | _,_,Hipattern.HeterogenousEq (t1,c1,t2,c2) when safe_pf_conv_x gl t1 t2 -> let th = guess_theory t1 in (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl | _ -> raise Exit with Hipattern.NoEquationFound | Exit -> (match match_with_equiv (pf_concl gl) with | Some (equiv, c1::args) -> let t = (pf_type_of gl c1) in let th = (guess_theory t) in if List.exists (fun c2 -> not (safe_pf_conv_x gl t (pf_type_of gl c2))) args then errorlabstrm "Ring :" (str" All terms must have the same type"); (tclTHEN (raw_polynom th None (c1::args)) (guess_equiv_tac th)) gl | _ -> errorlabstrm "polynom :" (str" This goal is not an equality nor a setoid equivalence"))) (* Elsewhere, guess the theory, check that all terms have the same type and apply raw_polynom *) | c :: lc' -> let t = pf_type_of gl c in let th = guess_theory t in if List.exists (fun c1 -> not (safe_pf_conv_x gl t (pf_type_of gl c1))) lc' then errorlabstrm "Ring :" (str" All terms must have the same type"); (tclTHEN (raw_polynom th None lc) polynom_unfold_tac) gl coq-8.4pl4/plugins/ring/LegacyZArithRing.v0000644000175000017500000000241712326224777017614 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | _ => false end. Lemma Zeq_prop : forall x y:Z, Is_true (Zeq x y) -> x = y. intros x y H; unfold Zeq in H. apply Z.compare_eq. destruct (x ?= y)%Z; [ reflexivity | contradiction | contradiction ]. Qed. Definition ZTheory : Ring_Theory Z.add Z.mul 1%Z 0%Z Z.opp Zeq. split; intros; eauto with zarith. apply Zeq_prop; assumption. Qed. (* NatConstants and NatTheory are defined in Ring_theory.v *) Add Legacy Ring Z Z.add Z.mul 1%Z 0%Z Z.opp Zeq ZTheory [ Zpos Zneg 0%Z xO xI 1%positive ]. coq-8.4pl4/plugins/ring/Setoid_ring.v0000644000175000017500000000121612326224777016710 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* "" | m::_ -> let s = Names.string_of_id m in if List.mem s meaningful_submodule then s^"." else "" in prefix^(Names.string_of_id (Nametab.basename_of_global r)) let destructurate t = let c, args = Term.decompose_app t in match Term.kind_of_term c, args with | Term.Const sp, args -> Kapp (string_of_global (Libnames.ConstRef sp), args) | Term.Construct csp , args -> Kapp (string_of_global (Libnames.ConstructRef csp), args) | Term.Ind isp, args -> Kapp (string_of_global (Libnames.IndRef isp), args) | Term.Var id,[] -> Kvar(Names.string_of_id id) | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body) | Term.Prod (Names.Name _,_,_),[] -> Util.error "Omega: Not a quantifier-free goal" | _ -> Kufo exception Destruct let dest_const_apply t = let f,args = Term.decompose_app t in let ref = match Term.kind_of_term f with | Term.Const sp -> Libnames.ConstRef sp | Term.Construct csp -> Libnames.ConstructRef csp | Term.Ind isp -> Libnames.IndRef isp | _ -> raise Destruct in Nametab.basename_of_global ref, args let logic_dir = ["Coq";"Logic";"Decidable"] let coq_modules = Coqlib.init_modules @ [logic_dir] @ Coqlib.arith_modules @ Coqlib.zarith_base_modules @ [["Coq"; "Lists"; "List"]] @ [module_refl_path] @ [module_refl_path@["ZOmega"]] let bin_module = [["Coq";"Numbers";"BinNums"]] let z_module = [["Coq";"ZArith";"BinInt"]] let init_constant = Coqlib.gen_constant_in_modules "Omega" Coqlib.init_modules let constant = Coqlib.gen_constant_in_modules "Omega" coq_modules let z_constant = Coqlib.gen_constant_in_modules "Omega" z_module let bin_constant = Coqlib.gen_constant_in_modules "Omega" bin_module (* Logic *) let coq_eq = lazy(init_constant "eq") let coq_refl_equal = lazy(init_constant "eq_refl") let coq_and = lazy(init_constant "and") let coq_not = lazy(init_constant "not") let coq_or = lazy(init_constant "or") let coq_True = lazy(init_constant "True") let coq_False = lazy(init_constant "False") let coq_I = lazy(init_constant "I") (* ReflOmegaCore/ZOmega *) let coq_h_step = lazy (constant "h_step") let coq_pair_step = lazy (constant "pair_step") let coq_p_left = lazy (constant "P_LEFT") let coq_p_right = lazy (constant "P_RIGHT") let coq_p_invert = lazy (constant "P_INVERT") let coq_p_step = lazy (constant "P_STEP") let coq_t_int = lazy (constant "Tint") let coq_t_plus = lazy (constant "Tplus") let coq_t_mult = lazy (constant "Tmult") let coq_t_opp = lazy (constant "Topp") let coq_t_minus = lazy (constant "Tminus") let coq_t_var = lazy (constant "Tvar") let coq_proposition = lazy (constant "proposition") let coq_p_eq = lazy (constant "EqTerm") let coq_p_leq = lazy (constant "LeqTerm") let coq_p_geq = lazy (constant "GeqTerm") let coq_p_lt = lazy (constant "LtTerm") let coq_p_gt = lazy (constant "GtTerm") let coq_p_neq = lazy (constant "NeqTerm") let coq_p_true = lazy (constant "TrueTerm") let coq_p_false = lazy (constant "FalseTerm") let coq_p_not = lazy (constant "Tnot") let coq_p_or = lazy (constant "Tor") let coq_p_and = lazy (constant "Tand") let coq_p_imp = lazy (constant "Timp") let coq_p_prop = lazy (constant "Tprop") (* Constructors for shuffle tactic *) let coq_t_fusion = lazy (constant "t_fusion") let coq_f_equal = lazy (constant "F_equal") let coq_f_cancel = lazy (constant "F_cancel") let coq_f_left = lazy (constant "F_left") let coq_f_right = lazy (constant "F_right") (* Constructors for reordering tactics *) let coq_c_do_both = lazy (constant "C_DO_BOTH") let coq_c_do_left = lazy (constant "C_LEFT") let coq_c_do_right = lazy (constant "C_RIGHT") let coq_c_do_seq = lazy (constant "C_SEQ") let coq_c_nop = lazy (constant "C_NOP") let coq_c_opp_plus = lazy (constant "C_OPP_PLUS") let coq_c_opp_opp = lazy (constant "C_OPP_OPP") let coq_c_opp_mult_r = lazy (constant "C_OPP_MULT_R") let coq_c_opp_one = lazy (constant "C_OPP_ONE") let coq_c_reduce = lazy (constant "C_REDUCE") let coq_c_mult_plus_distr = lazy (constant "C_MULT_PLUS_DISTR") let coq_c_opp_left = lazy (constant "C_MULT_OPP_LEFT") let coq_c_mult_assoc_r = lazy (constant "C_MULT_ASSOC_R") let coq_c_plus_assoc_r = lazy (constant "C_PLUS_ASSOC_R") let coq_c_plus_assoc_l = lazy (constant "C_PLUS_ASSOC_L") let coq_c_plus_permute = lazy (constant "C_PLUS_PERMUTE") let coq_c_plus_comm = lazy (constant "C_PLUS_COMM") let coq_c_red0 = lazy (constant "C_RED0") let coq_c_red1 = lazy (constant "C_RED1") let coq_c_red2 = lazy (constant "C_RED2") let coq_c_red3 = lazy (constant "C_RED3") let coq_c_red4 = lazy (constant "C_RED4") let coq_c_red5 = lazy (constant "C_RED5") let coq_c_red6 = lazy (constant "C_RED6") let coq_c_mult_opp_left = lazy (constant "C_MULT_OPP_LEFT") let coq_c_mult_assoc_reduced = lazy (constant "C_MULT_ASSOC_REDUCED") let coq_c_minus = lazy (constant "C_MINUS") let coq_c_mult_comm = lazy (constant "C_MULT_COMM") let coq_s_constant_not_nul = lazy (constant "O_CONSTANT_NOT_NUL") let coq_s_constant_neg = lazy (constant "O_CONSTANT_NEG") let coq_s_div_approx = lazy (constant "O_DIV_APPROX") let coq_s_not_exact_divide = lazy (constant "O_NOT_EXACT_DIVIDE") let coq_s_exact_divide = lazy (constant "O_EXACT_DIVIDE") let coq_s_sum = lazy (constant "O_SUM") let coq_s_state = lazy (constant "O_STATE") let coq_s_contradiction = lazy (constant "O_CONTRADICTION") let coq_s_merge_eq = lazy (constant "O_MERGE_EQ") let coq_s_split_ineq =lazy (constant "O_SPLIT_INEQ") let coq_s_constant_nul =lazy (constant "O_CONSTANT_NUL") let coq_s_negate_contradict =lazy (constant "O_NEGATE_CONTRADICT") let coq_s_negate_contradict_inv =lazy (constant "O_NEGATE_CONTRADICT_INV") (* construction for the [extract_hyp] tactic *) let coq_direction = lazy (constant "direction") let coq_d_left = lazy (constant "D_left") let coq_d_right = lazy (constant "D_right") let coq_d_mono = lazy (constant "D_mono") let coq_e_split = lazy (constant "E_SPLIT") let coq_e_extract = lazy (constant "E_EXTRACT") let coq_e_solve = lazy (constant "E_SOLVE") let coq_interp_sequent = lazy (constant "interp_goal_concl") let coq_do_omega = lazy (constant "do_omega") (* \subsection{Construction d'expressions} *) let do_left t = if Term.eq_constr t (Lazy.force coq_c_nop) then Lazy.force coq_c_nop else Term.mkApp (Lazy.force coq_c_do_left, [|t |] ) let do_right t = if Term.eq_constr t (Lazy.force coq_c_nop) then Lazy.force coq_c_nop else Term.mkApp (Lazy.force coq_c_do_right, [|t |]) let do_both t1 t2 = if Term.eq_constr t1 (Lazy.force coq_c_nop) then do_right t2 else if Term.eq_constr t2 (Lazy.force coq_c_nop) then do_left t1 else Term.mkApp (Lazy.force coq_c_do_both , [|t1; t2 |]) let do_seq t1 t2 = if Term.eq_constr t1 (Lazy.force coq_c_nop) then t2 else if Term.eq_constr t2 (Lazy.force coq_c_nop) then t1 else Term.mkApp (Lazy.force coq_c_do_seq, [|t1; t2 |]) let rec do_list = function | [] -> Lazy.force coq_c_nop | [x] -> x | (x::l) -> do_seq x (do_list l) (* Nat *) let coq_S = lazy(init_constant "S") let coq_O = lazy(init_constant "O") let rec mk_nat = function | 0 -> Lazy.force coq_O | n -> Term.mkApp (Lazy.force coq_S, [| mk_nat (n-1) |]) (* Lists *) let coq_cons = lazy (constant "cons") let coq_nil = lazy (constant "nil") let mk_list typ l = let rec loop = function | [] -> Term.mkApp (Lazy.force coq_nil, [|typ|]) | (step :: l) -> Term.mkApp (Lazy.force coq_cons, [|typ; step; loop l |]) in loop l let mk_plist l = mk_list Term.mkProp l let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l type parse_term = | Tplus of Term.constr * Term.constr | Tmult of Term.constr * Term.constr | Tminus of Term.constr * Term.constr | Topp of Term.constr | Tsucc of Term.constr | Tnum of Bigint.bigint | Tother type parse_rel = | Req of Term.constr * Term.constr | Rne of Term.constr * Term.constr | Rlt of Term.constr * Term.constr | Rle of Term.constr * Term.constr | Rgt of Term.constr * Term.constr | Rge of Term.constr * Term.constr | Rtrue | Rfalse | Rnot of Term.constr | Ror of Term.constr * Term.constr | Rand of Term.constr * Term.constr | Rimp of Term.constr * Term.constr | Riff of Term.constr * Term.constr | Rother let parse_logic_rel c = try match destructurate c with | Kapp("True",[]) -> Rtrue | Kapp("False",[]) -> Rfalse | Kapp("not",[t]) -> Rnot t | Kapp("or",[t1;t2]) -> Ror (t1,t2) | Kapp("and",[t1;t2]) -> Rand (t1,t2) | Kimp(t1,t2) -> Rimp (t1,t2) | Kapp("iff",[t1;t2]) -> Riff (t1,t2) | _ -> Rother with e when Logic.catchable_exception e -> Rother module type Int = sig val typ : Term.constr Lazy.t val plus : Term.constr Lazy.t val mult : Term.constr Lazy.t val opp : Term.constr Lazy.t val minus : Term.constr Lazy.t val mk : Bigint.bigint -> Term.constr val parse_term : Term.constr -> parse_term val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel (* check whether t is built only with numbers and + * - *) val is_scalar : Term.constr -> bool end module Z : Int = struct let typ = lazy (bin_constant "Z") let plus = lazy (z_constant "Z.add") let mult = lazy (z_constant "Z.mul") let opp = lazy (z_constant "Z.opp") let minus = lazy (z_constant "Z.sub") let coq_xH = lazy (bin_constant "xH") let coq_xO = lazy (bin_constant "xO") let coq_xI = lazy (bin_constant "xI") let coq_Z0 = lazy (bin_constant "Z0") let coq_Zpos = lazy (bin_constant "Zpos") let coq_Zneg = lazy (bin_constant "Zneg") let recognize t = let rec loop t = let f,l = dest_const_apply t in match Names.string_of_id f,l with "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t)) | "xO",[t] -> Bigint.mult Bigint.two (loop t) | "xH",[] -> Bigint.one | _ -> failwith "not a number" in let f,l = dest_const_apply t in match Names.string_of_id f,l with "Zpos",[t] -> loop t | "Zneg",[t] -> Bigint.neg (loop t) | "Z0",[] -> Bigint.zero | _ -> failwith "not a number";; let rec mk_positive n = if n=Bigint.one then Lazy.force coq_xH else let (q,r) = Bigint.euclid n Bigint.two in Term.mkApp ((if r = Bigint.zero then Lazy.force coq_xO else Lazy.force coq_xI), [| mk_positive q |]) let mk_Z n = if n = Bigint.zero then Lazy.force coq_Z0 else if Bigint.is_strictly_pos n then Term.mkApp (Lazy.force coq_Zpos, [| mk_positive n |]) else Term.mkApp (Lazy.force coq_Zneg, [| mk_positive (Bigint.neg n) |]) let mk = mk_Z let parse_term t = try match destructurate t with | Kapp("Z.add",[t1;t2]) -> Tplus (t1,t2) | Kapp("Z.sub",[t1;t2]) -> Tminus (t1,t2) | Kapp("Z.mul",[t1;t2]) -> Tmult (t1,t2) | Kapp("Z.opp",[t]) -> Topp t | Kapp("Z.succ",[t]) -> Tsucc t | Kapp("Z.pred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one)) | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> (try Tnum (recognize t) with e when Errors.noncritical e -> Tother) | _ -> Tother with e when Logic.catchable_exception e -> Tother let parse_rel gl t = try match destructurate t with | Kapp("eq",[typ;t1;t2]) when destructurate (Tacmach.pf_nf gl typ) = Kapp("Z",[]) -> Req (t1,t2) | Kapp("Zne",[t1;t2]) -> Rne (t1,t2) | Kapp("Z.le",[t1;t2]) -> Rle (t1,t2) | Kapp("Z.lt",[t1;t2]) -> Rlt (t1,t2) | Kapp("Z.ge",[t1;t2]) -> Rge (t1,t2) | Kapp("Z.gt",[t1;t2]) -> Rgt (t1,t2) | _ -> parse_logic_rel t with e when Logic.catchable_exception e -> Rother let is_scalar t = let rec aux t = match destructurate t with | Kapp(("Z.add"|"Z.sub"|"Z.mul"),[t1;t2]) -> aux t1 & aux t2 | Kapp(("Z.opp"|"Z.succ"|"Z.pred"),[t]) -> aux t | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true | _ -> false in try aux t with e when Errors.noncritical e -> false end coq-8.4pl4/plugins/romega/vo.itarget0000644000175000017500000000003312326224777016567 0ustar stephstephReflOmegaCore.vo ROmega.vo coq-8.4pl4/plugins/romega/README0000644000175000017500000000023012326224777015441 0ustar stephstephThis work was done for the RNRT Project Calife. As such it is distributed under the LGPL licence. Report bugs to : pierre.cregut@francetelecom.com coq-8.4pl4/plugins/romega/g_romega.ml40000644000175000017500000000243212326224777016765 0ustar stephsteph(************************************************************************* PROJET RNRT Calife - 2001 Author: Pierre Crégut - France Télécom R&D Licence : LGPL version 2.1 *************************************************************************) (*i camlp4deps: "parsing/grammar.cma" i*) open Refl_omega open Refiner let romega_tactic l = let tacs = List.map (function | "nat" -> Tacinterp.interp <:tactic> | "positive" -> Tacinterp.interp <:tactic> | "N" -> Tacinterp.interp <:tactic> | "Z" -> Tacinterp.interp <:tactic> | s -> Util.error ("No ROmega knowledge base for type "^s)) (Util.list_uniquize (List.sort compare l)) in tclTHEN (tclREPEAT (tclPROGRESS (tclTHENLIST tacs))) (tclTHEN (* because of the contradiction process in (r)omega, we'd better leave as little as possible in the conclusion, for an easier decidability argument. *) Tactics.intros total_reflexive_omega_tactic) TACTIC EXTEND romega | [ "romega" ] -> [ romega_tactic [] ] END TACTIC EXTEND romega' | [ "romega" "with" ne_ident_list(l) ] -> [ romega_tactic (List.map Names.string_of_id l) ] | [ "romega" "with" "*" ] -> [ romega_tactic ["nat";"positive";"N";"Z"] ] END coq-8.4pl4/plugins/romega/ReflOmegaCore.v0000644000175000017500000027424312326224777017443 0ustar stephsteph(* -*- coding: utf-8 -*- *) (************************************************************************* PROJET RNRT Calife - 2001 Author: Pierre CrÃĐgut - France TÃĐlÃĐcom R&D Licence du projet : LGPL version 2.1 *************************************************************************) Require Import List Bool Sumbool EqNat Setoid Ring_theory Decidable ZArith_base. Delimit Scope Int_scope with I. (* Abstract Integers. *) Module Type Int. Parameter t : Set. Parameter zero : t. Parameter one : t. Parameter plus : t -> t -> t. Parameter opp : t -> t. Parameter minus : t -> t -> t. Parameter mult : t -> t -> t. Notation "0" := zero : Int_scope. Notation "1" := one : Int_scope. Infix "+" := plus : Int_scope. Infix "-" := minus : Int_scope. Infix "*" := mult : Int_scope. Notation "- x" := (opp x) : Int_scope. Open Scope Int_scope. (* First, int is a ring: *) Axiom ring : @ring_theory t 0 1 plus mult minus opp (@eq t). (* int should also be ordered: *) Parameter le : t -> t -> Prop. Parameter lt : t -> t -> Prop. Parameter ge : t -> t -> Prop. Parameter gt : t -> t -> Prop. Notation "x <= y" := (le x y): Int_scope. Notation "x < y" := (lt x y) : Int_scope. Notation "x >= y" := (ge x y) : Int_scope. Notation "x > y" := (gt x y): Int_scope. Axiom le_lt_iff : forall i j, (i<=j) <-> ~(j=j) <-> (j<=i). Axiom gt_lt_iff : forall i j, (i>j) <-> (j j i i<>j. (* Compatibilities *) Axiom lt_0_1 : 0<1. Axiom plus_le_compat : forall i j k l, i<=j -> k<=l -> i+k<=j+l. Axiom opp_le_compat : forall i j, i<=j -> (-j)<=(-i). Axiom mult_lt_compat_l : forall i j k, 0 < k -> i < j -> k*i t -> comparison. Infix "?=" := compare (at level 70, no associativity) : Int_scope. Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j. Axiom compare_Lt : forall i j, compare i j = Lt <-> i i>j. (* Up to here, these requirements could be fulfilled by any totally ordered ring. Let's now be int-specific: *) Axiom le_lt_int : forall x y, x x<=y+-(1). (* Btw, lt_0_1 could be deduced from this last axiom *) End Int. (* Of course, Z is a model for our abstract int *) Module Z_as_Int <: Int. Open Scope Z_scope. Definition t := Z. Definition zero := 0. Definition one := 1. Definition plus := Z.add. Definition opp := Z.opp. Definition minus := Z.sub. Definition mult := Z.mul. Lemma ring : @ring_theory t zero one plus mult minus opp (@eq t). Proof. constructor. exact Z.add_0_l. exact Z.add_comm. exact Z.add_assoc. exact Z.mul_1_l. exact Z.mul_comm. exact Z.mul_assoc. exact Z.mul_add_distr_r. unfold minus, Z.sub; auto. exact Z.add_opp_diag_r. Qed. Definition le := Z.le. Definition lt := Z.lt. Definition ge := Z.ge. Definition gt := Z.gt. Definition le_lt_iff := Z.le_ngt. Definition ge_le_iff := Z.ge_le_iff. Definition gt_lt_iff := Z.gt_lt_iff. Definition lt_trans := Z.lt_trans. Definition lt_not_eq := Z.lt_neq. Definition lt_0_1 := Z.lt_0_1. Definition plus_le_compat := Z.add_le_mono. Definition mult_lt_compat_l := Zmult_lt_compat_l. Lemma opp_le_compat i j : i<=j -> (-j)<=(-i). Proof. apply -> Z.opp_le_mono. Qed. Definition compare := Z.compare. Definition compare_Eq := Z.compare_eq_iff. Lemma compare_Lt i j : compare i j = Lt <-> i i>j. Proof. reflexivity. Qed. Definition le_lt_int := Z.lt_le_pred. End Z_as_Int. Module IntProperties (I:Int). Import I. Local Notation int := I.t. (* Primo, some consequences of being a ring theory... *) Definition two := 1+1. Notation "2" := two : Int_scope. (* Aliases for properties packed in the ring record. *) Definition plus_assoc := ring.(Radd_assoc). Definition plus_comm := ring.(Radd_comm). Definition plus_0_l := ring.(Radd_0_l). Definition mult_assoc := ring.(Rmul_assoc). Definition mult_comm := ring.(Rmul_comm). Definition mult_1_l := ring.(Rmul_1_l). Definition mult_plus_distr_r := ring.(Rdistr_l). Definition opp_def := ring.(Ropp_def). Definition minus_def := ring.(Rsub_def). Opaque plus_assoc plus_comm plus_0_l mult_assoc mult_comm mult_1_l mult_plus_distr_r opp_def minus_def. (* More facts about plus *) Lemma plus_0_r : forall x, x+0 = x. Proof. intros; rewrite plus_comm; apply plus_0_l. Qed. Lemma plus_0_r_reverse : forall x, x = x+0. Proof. intros; symmetry; apply plus_0_r. Qed. Lemma plus_assoc_reverse : forall x y z, x+y+z = x+(y+z). Proof. intros; symmetry; apply plus_assoc. Qed. Lemma plus_permute : forall x y z, x+(y+z) = y+(x+z). Proof. intros; do 2 rewrite plus_assoc; f_equal; apply plus_comm. Qed. Lemma plus_reg_l : forall x y z, x+y = x+z -> y = z. Proof. intros. rewrite (plus_0_r_reverse y), (plus_0_r_reverse z), <-(opp_def x). now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute. Qed. (* More facts about mult *) Lemma mult_assoc_reverse : forall x y z, x*y*z = x*(y*z). Proof. intros; symmetry; apply mult_assoc. Qed. Lemma mult_plus_distr_l : forall x y z, x*(y+z)=x*y+x*z. Proof. intros. rewrite (mult_comm x (y+z)), (mult_comm x y), (mult_comm x z). apply mult_plus_distr_r. Qed. Lemma mult_0_l : forall x, 0*x = 0. Proof. intros. generalize (mult_plus_distr_r 0 1 x). rewrite plus_0_l, mult_1_l, plus_comm; intros. apply plus_reg_l with x. rewrite <- H. apply plus_0_r_reverse. Qed. (* More facts about opp *) Definition plus_opp_r := opp_def. Lemma plus_opp_l : forall x, -x + x = 0. Proof. intros; now rewrite plus_comm, opp_def. Qed. Lemma mult_opp_comm : forall x y, - x * y = x * - y. Proof. intros. apply plus_reg_l with (x*y). rewrite <- mult_plus_distr_l, <- mult_plus_distr_r. now rewrite opp_def, opp_def, mult_0_l, mult_comm, mult_0_l. Qed. Lemma opp_eq_mult_neg_1 : forall x, -x = x * -(1). Proof. intros; now rewrite mult_comm, mult_opp_comm, mult_1_l. Qed. Lemma opp_involutive : forall x, -(-x) = x. Proof. intros. apply plus_reg_l with (-x). now rewrite opp_def, plus_comm, opp_def. Qed. Lemma opp_plus_distr : forall x y, -(x+y) = -x + -y. Proof. intros. apply plus_reg_l with (x+y). rewrite opp_def. rewrite plus_permute. do 2 rewrite plus_assoc. now rewrite (plus_comm (-x)), opp_def, plus_0_l, opp_def. Qed. Lemma opp_mult_distr_r : forall x y, -(x*y) = x * -y. Proof. intros. rewrite <- mult_opp_comm. apply plus_reg_l with (x*y). now rewrite opp_def, <-mult_plus_distr_r, opp_def, mult_0_l. Qed. Lemma egal_left : forall n m, n=m -> n+-m = 0. Proof. intros; subst; apply opp_def. Qed. Lemma ne_left_2 : forall x y : int, x<>y -> 0<>(x + - y). Proof. intros; contradict H. apply (plus_reg_l (-y)). now rewrite plus_opp_l, plus_comm, H. Qed. (* Special lemmas for factorisation. *) Lemma red_factor0 : forall n, n = n*1. Proof. symmetry; rewrite mult_comm; apply mult_1_l. Qed. Lemma red_factor1 : forall n, n+n = n*2. Proof. intros; unfold two. now rewrite mult_comm, mult_plus_distr_r, mult_1_l. Qed. Lemma red_factor2 : forall n m, n + n*m = n * (1+m). Proof. intros; rewrite mult_plus_distr_l. f_equal; now rewrite mult_comm, mult_1_l. Qed. Lemma red_factor3 : forall n m, n*m + n = n*(1+m). Proof. intros; now rewrite plus_comm, red_factor2. Qed. Lemma red_factor4 : forall n m p, n*m + n*p = n*(m+p). Proof. intros; now rewrite mult_plus_distr_l. Qed. Lemma red_factor5 : forall n m , n * 0 + m = m. Proof. intros; now rewrite mult_comm, mult_0_l, plus_0_l. Qed. Definition red_factor6 := plus_0_r_reverse. (* Specialized distributivities *) Hint Rewrite mult_plus_distr_l mult_plus_distr_r mult_assoc : int. Hint Rewrite <- plus_assoc : int. Lemma OMEGA10 : forall v c1 c2 l1 l2 k1 k2 : int, (v * c1 + l1) * k1 + (v * c2 + l2) * k2 = v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2). Proof. intros; autorewrite with int; f_equal; now rewrite plus_permute. Qed. Lemma OMEGA11 : forall v1 c1 l1 l2 k1 : int, (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2). Proof. intros; now autorewrite with int. Qed. Lemma OMEGA12 : forall v2 c2 l1 l2 k2 : int, l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2). Proof. intros; autorewrite with int; now rewrite plus_permute. Qed. Lemma OMEGA13 : forall v l1 l2 x : int, v * -x + l1 + (v * x + l2) = l1 + l2. Proof. intros; autorewrite with int. rewrite plus_permute; f_equal. rewrite plus_assoc. now rewrite <- mult_plus_distr_l, plus_opp_l, mult_comm, mult_0_l, plus_0_l. Qed. Lemma OMEGA15 : forall v c1 c2 l1 l2 k2 : int, v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2). Proof. intros; autorewrite with int; f_equal; now rewrite plus_permute. Qed. Lemma OMEGA16 : forall v c l k : int, (v * c + l) * k = v * (c * k) + l * k. Proof. intros; now autorewrite with int. Qed. Lemma sum1 : forall a b c d : int, 0 = a -> 0 = b -> 0 = a * c + b * d. Proof. intros; elim H; elim H0; simpl; auto. now rewrite mult_0_l, mult_0_l, plus_0_l. Qed. (* Secondo, some results about order (and equality) *) Lemma lt_irrefl : forall n, ~ n m False. Proof. intros; elim (lt_irrefl _ (lt_trans _ _ _ H H0)); auto. Qed. Lemma lt_le_weak : forall n m, n n<=m. Proof. intros; rewrite le_lt_iff; intro H'; eapply lt_antisym; eauto. Qed. Lemma le_refl : forall n, n<=n. Proof. intros; rewrite le_lt_iff; apply lt_irrefl; auto. Qed. Lemma le_antisym : forall n m, n<=m -> m<=n -> n=m. Proof. intros n m; do 2 rewrite le_lt_iff; intros. rewrite <- compare_Lt in H0. rewrite <- gt_lt_iff, <- compare_Gt in H. rewrite <- compare_Eq. destruct compare; intuition. Qed. Lemma lt_eq_lt_dec : forall n m, { n ~(m<=n). Proof. intros. rewrite le_lt_iff. destruct (lt_dec n m); intuition. Qed. Lemma le_dec : forall n m: int, { n<=m } + { ~n<=m }. Proof. intros; destruct (lt_dec m n); [right|left]; rewrite le_lt_iff; intuition. Qed. Lemma le_lt_dec : forall n m, { n<=m } + { m true | _ => false end. Lemma beq_iff : forall i j, beq i j = true <-> i=j. Proof. intros; unfold beq; generalize (compare_Eq i j). destruct compare; intuition discriminate. Qed. Lemma beq_true : forall i j, beq i j = true -> i=j. Proof. intros. rewrite <- beq_iff; auto. Qed. Lemma beq_false : forall i j, beq i j = false -> i<>j. Proof. intros. intro H'. rewrite <- beq_iff in H'; rewrite H' in H; discriminate. Qed. Lemma eq_dec : forall n m:int, { n=m } + { n<>m }. Proof. intros; generalize (beq_iff n m); destruct beq; [left|right]; intuition. Qed. Definition bgt i j := match compare i j with Gt => true | _ => false end. Lemma bgt_iff : forall i j, bgt i j = true <-> i>j. Proof. intros; unfold bgt; generalize (compare_Gt i j). destruct compare; intuition discriminate. Qed. Lemma bgt_true : forall i j, bgt i j = true -> i>j. Proof. intros; now rewrite <- bgt_iff. Qed. Lemma bgt_false : forall i j, bgt i j = false -> i<=j. Proof. intros. rewrite le_lt_iff, <-gt_lt_iff, <-bgt_iff; intro H'; now rewrite H' in H. Qed. Lemma le_is_lt_or_eq : forall n m, n<=m -> { n n<>m -> n m<=p -> n<=p. Proof. intros n m p; do 3 rewrite le_lt_iff; intros A B C. destruct (lt_eq_lt_dec p m) as [[H|H]|H]; subst; auto. generalize (lt_trans _ _ _ H C); intuition. Qed. (* order and operations *) Lemma le_0_neg : forall n, 0 <= n <-> -n <= 0. Proof. intros. pattern 0 at 2; rewrite <- (mult_0_l (-(1))). rewrite <- opp_eq_mult_neg_1. split; intros. apply opp_le_compat; auto. rewrite <-(opp_involutive 0), <-(opp_involutive n). apply opp_le_compat; auto. Qed. Lemma le_0_neg' : forall n, n <= 0 <-> 0 <= -n. Proof. intros; rewrite le_0_neg, opp_involutive; intuition. Qed. Lemma plus_le_reg_r : forall n m p, n + p <= m + p -> n <= m. Proof. intros. replace n with ((n+p)+-p). replace m with ((m+p)+-p). apply plus_le_compat; auto. apply le_refl. now rewrite <- plus_assoc, opp_def, plus_0_r. now rewrite <- plus_assoc, opp_def, plus_0_r. Qed. Lemma plus_le_lt_compat : forall n m p q, n<=m -> p n+p p n+p -m < -n. Proof. intros n m; do 2 rewrite lt_le_iff; intros H; contradict H. rewrite <-(opp_involutive m), <-(opp_involutive n). apply opp_le_compat; auto. Qed. Lemma lt_0_neg : forall n, 0 < n <-> -n < 0. Proof. intros. pattern 0 at 2; rewrite <- (mult_0_l (-(1))). rewrite <- opp_eq_mult_neg_1. split; intros. apply opp_lt_compat; auto. rewrite <-(opp_involutive 0), <-(opp_involutive n). apply opp_lt_compat; auto. Qed. Lemma lt_0_neg' : forall n, n < 0 <-> 0 < -n. Proof. intros; rewrite lt_0_neg, opp_involutive; intuition. Qed. Lemma mult_lt_0_compat : forall n m, 0 < n -> 0 < m -> 0 < n*m. Proof. intros. rewrite <- (mult_0_l n), mult_comm. apply mult_lt_compat_l; auto. Qed. Lemma mult_integral : forall n m, n * m = 0 -> n = 0 \/ m = 0. Proof. intros. destruct (lt_eq_lt_dec n 0) as [[Hn|Hn]|Hn]; auto; destruct (lt_eq_lt_dec m 0) as [[Hm|Hm]|Hm]; auto; exfalso. rewrite lt_0_neg' in Hn. rewrite lt_0_neg' in Hm. generalize (mult_lt_0_compat _ _ Hn Hm). rewrite <- opp_mult_distr_r, mult_comm, <- opp_mult_distr_r, opp_involutive. rewrite mult_comm, H. exact (lt_irrefl 0). rewrite lt_0_neg' in Hn. generalize (mult_lt_0_compat _ _ Hn Hm). rewrite mult_comm, <- opp_mult_distr_r, mult_comm. rewrite H. rewrite opp_eq_mult_neg_1, mult_0_l. exact (lt_irrefl 0). rewrite lt_0_neg' in Hm. generalize (mult_lt_0_compat _ _ Hn Hm). rewrite <- opp_mult_distr_r. rewrite H. rewrite opp_eq_mult_neg_1, mult_0_l. exact (lt_irrefl 0). generalize (mult_lt_0_compat _ _ Hn Hm). rewrite H. exact (lt_irrefl 0). Qed. Lemma mult_le_compat : forall i j k l, i<=j -> k<=l -> 0<=i -> 0<=k -> i*k<=j*l. Proof. intros. destruct (le_is_lt_or_eq _ _ H1). apply le_trans with (i*l). destruct (le_is_lt_or_eq _ _ H0); [ | subst; apply le_refl]. apply lt_le_weak. apply mult_lt_compat_l; auto. generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. rewrite (mult_comm i), (mult_comm j). destruct (le_is_lt_or_eq _ _ H0); [ | subst; do 2 rewrite mult_0_l; apply le_refl]. destruct (le_is_lt_or_eq _ _ H); [ | subst; apply le_refl]. apply lt_le_weak. apply mult_lt_compat_l; auto. subst i. rewrite mult_0_l. generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. destruct (le_is_lt_or_eq _ _ H); [ | subst; rewrite mult_0_l; apply le_refl]. destruct (le_is_lt_or_eq _ _ H0); [ | subst; rewrite mult_comm, mult_0_l; apply le_refl]. apply lt_le_weak. apply mult_lt_0_compat; auto. Qed. Lemma sum5 : forall a b c d : int, c <> 0 -> 0 <> a -> 0 = b -> 0 <> a * c + b * d. Proof. intros. subst b; rewrite mult_0_l, plus_0_r. contradict H. symmetry in H; destruct (mult_integral _ _ H); congruence. Qed. Lemma one_neq_zero : 1 <> 0. Proof. red; intro. symmetry in H. apply (lt_not_eq 0 1); auto. apply lt_0_1. Qed. Lemma minus_one_neq_zero : -(1) <> 0. Proof. apply lt_not_eq. rewrite <- lt_0_neg. apply lt_0_1. Qed. Lemma le_left : forall n m, n <= m -> 0 <= m + - n. Proof. intros. rewrite <- (opp_def m). apply plus_le_compat. apply le_refl. apply opp_le_compat; auto. Qed. Lemma OMEGA2 : forall x y, 0 <= x -> 0 <= y -> 0 <= x + y. Proof. intros. replace 0 with (0+0). apply plus_le_compat; auto. rewrite plus_0_l; auto. Qed. Lemma OMEGA8 : forall x y, 0 <= x -> 0 <= y -> x = - y -> x = 0. Proof. intros. assert (y=-x). subst x; symmetry; apply opp_involutive. clear H1; subst y. destruct (eq_dec 0 x) as [H'|H']; auto. assert (H'':=le_neq_lt _ _ H H'). generalize (plus_le_lt_compat _ _ _ _ H0 H''). rewrite plus_opp_l, plus_0_l. intros. elim (lt_not_eq _ _ H1); auto. Qed. Lemma sum2 : forall a b c d : int, 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d. Proof. intros. subst a; rewrite mult_0_l, plus_0_l. rewrite <- (mult_0_l 0). apply mult_le_compat; auto; apply le_refl. Qed. Lemma sum3 : forall a b c d : int, 0 <= c -> 0 <= d -> 0 <= a -> 0 <= b -> 0 <= a * c + b * d. Proof. intros. rewrite <- (plus_0_l 0). apply plus_le_compat; auto. rewrite <- (mult_0_l 0). apply mult_le_compat; auto; apply le_refl. rewrite <- (mult_0_l 0). apply mult_le_compat; auto; apply le_refl. Qed. Lemma sum4 : forall k : int, k>0 -> 0 <= k. Proof. intros k; rewrite gt_lt_iff; apply lt_le_weak. Qed. (* Lemmas specific to integers (they use lt_le_int) *) Lemma lt_left : forall n m, n < m -> 0 <= m + -(1) + - n. Proof. intros; apply le_left. now rewrite <- le_lt_int. Qed. Lemma lt_left_inv : forall x y, 0 <= y + -(1) + - x -> x < y. Proof. intros. generalize (plus_le_compat _ _ _ _ H (le_refl x)); clear H. now rewrite plus_0_l, <-plus_assoc, plus_opp_l, plus_0_r, le_lt_int. Qed. Lemma OMEGA4 : forall x y z, x > 0 -> y > x -> z * y + x <> 0. Proof. intros. intro H'. rewrite gt_lt_iff in H,H0. destruct (lt_eq_lt_dec z 0) as [[G|G]|G]. rewrite lt_0_neg' in G. generalize (plus_le_lt_compat _ _ _ _ (le_refl (z*y)) H0). rewrite H'. pattern y at 2; rewrite <-(mult_1_l y), <-mult_plus_distr_r. intros. rewrite le_lt_int in G. rewrite <- opp_plus_distr in G. assert (0 < y) by (apply lt_trans with x; auto). generalize (mult_le_compat _ _ _ _ G (lt_le_weak _ _ H2) (le_refl 0) (le_refl 0)). rewrite mult_0_l, mult_comm, <- opp_mult_distr_r, mult_comm, <-le_0_neg', le_lt_iff. intuition. subst; rewrite mult_0_l, plus_0_l in H'; subst. apply (lt_not_eq _ _ H); auto. apply (lt_not_eq 0 (z*y+x)); auto. rewrite <- (plus_0_l 0). apply plus_lt_compat; auto. apply mult_lt_0_compat; auto. apply lt_trans with x; auto. Qed. Lemma OMEGA19 : forall x, x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1). Proof. intros. do 2 rewrite <- le_lt_int. rewrite <- opp_eq_mult_neg_1. destruct (lt_eq_lt_dec 0 x) as [[H'|H']|H']. auto. congruence. right. rewrite <-(mult_0_l (-(1))), <-(opp_eq_mult_neg_1 0). apply opp_lt_compat; auto. Qed. Lemma mult_le_approx : forall n m p, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m. Proof. intros n m p. do 2 rewrite gt_lt_iff. do 2 rewrite le_lt_iff; intros. contradict H1. rewrite lt_0_neg' in H1. rewrite lt_0_neg'. rewrite opp_plus_distr. rewrite mult_comm, opp_mult_distr_r. rewrite le_lt_int. rewrite <- plus_assoc, (plus_comm (-p)), plus_assoc. apply lt_left. rewrite le_lt_int. rewrite le_lt_int in H0. apply le_trans with (n+-(1)); auto. apply plus_le_compat; [ | apply le_refl ]. rewrite le_lt_int in H1. generalize (mult_le_compat _ _ _ _ (lt_le_weak _ _ H) H1 (le_refl 0) (le_refl 0)). rewrite mult_0_l. rewrite mult_plus_distr_l. rewrite <- opp_eq_mult_neg_1. intros. generalize (plus_le_compat _ _ _ _ (le_refl n) H2). now rewrite plus_permute, opp_def, plus_0_r, plus_0_r. Qed. (* Some decidabilities *) Lemma dec_eq : forall i j:int, decidable (i=j). Proof. red; intros; destruct (eq_dec i j); auto. Qed. Lemma dec_ne : forall i j:int, decidable (i<>j). Proof. red; intros; destruct (eq_dec i j); auto. Qed. Lemma dec_le : forall i j:int, decidable (i<=j). Proof. red; intros; destruct (le_dec i j); auto. Qed. Lemma dec_lt : forall i j:int, decidable (i=j). Proof. red; intros; rewrite ge_le_iff; destruct (le_dec j i); auto. Qed. Lemma dec_gt : forall i j:int, decidable (i>j). Proof. red; intros; rewrite gt_lt_iff; destruct (lt_dec j i); auto. Qed. End IntProperties. Module IntOmega (I:Int). Import I. Module IP:=IntProperties(I). Import IP. Local Notation int := I.t. (* \subsubsection{Definition of reified integer expressions} Terms are either: \begin{itemize} \item integers [Tint] \item variables [Tvar] \item operation over integers (addition, product, opposite, subtraction) The last two are translated in additions and products. *) Inductive term : Set := | Tint : int -> term | Tplus : term -> term -> term | Tmult : term -> term -> term | Tminus : term -> term -> term | Topp : term -> term | Tvar : nat -> term. Delimit Scope romega_scope with term. Arguments Tint _%I. Arguments Tplus (_ _)%term. Arguments Tmult (_ _)%term. Arguments Tminus (_ _)%term. Arguments Topp _%term. Infix "+" := Tplus : romega_scope. Infix "*" := Tmult : romega_scope. Infix "-" := Tminus : romega_scope. Notation "- x" := (Topp x) : romega_scope. Notation "[ x ]" := (Tvar x) (at level 0) : romega_scope. (* \subsubsection{Definition of reified goals} *) (* Very restricted definition of handled predicates that should be extended to cover a wider set of operations. Taking care of negations and disequations require solving more than a goal in parallel. This is a major improvement over previous versions. *) Inductive proposition : Set := | EqTerm : term -> term -> proposition (* equality between terms *) | LeqTerm : term -> term -> proposition (* less or equal on terms *) | TrueTerm : proposition (* true *) | FalseTerm : proposition (* false *) | Tnot : proposition -> proposition (* negation *) | GeqTerm : term -> term -> proposition | GtTerm : term -> term -> proposition | LtTerm : term -> term -> proposition | NeqTerm : term -> term -> proposition | Tor : proposition -> proposition -> proposition | Tand : proposition -> proposition -> proposition | Timp : proposition -> proposition -> proposition | Tprop : nat -> proposition. (* Definition of goals as a list of hypothesis *) Notation hyps := (list proposition). (* Definition of lists of subgoals (set of open goals) *) Notation lhyps := (list hyps). (* a single goal packed in a subgoal list *) Notation singleton := (fun a : hyps => a :: nil). (* an absurd goal *) Definition absurd := FalseTerm :: nil. (* \subsubsection{Traces for merging equations} This inductive type describes how the monomial of two equations should be merged when the equations are added. For [F_equal], both equations have the same head variable and coefficient must be added, furthermore if coefficients are opposite, [F_cancel] should be used to collapse the term. [F_left] and [F_right] indicate which monomial should be put first in the result *) Inductive t_fusion : Set := | F_equal : t_fusion | F_cancel : t_fusion | F_left : t_fusion | F_right : t_fusion. (* \subsubsection{Rewriting steps to normalize terms} *) Inductive step : Set := (* apply the rewriting steps to both subterms of an operation *) | C_DO_BOTH : step -> step -> step (* apply the rewriting step to the first branch *) | C_LEFT : step -> step (* apply the rewriting step to the second branch *) | C_RIGHT : step -> step (* apply two steps consecutively to a term *) | C_SEQ : step -> step -> step (* empty step *) | C_NOP : step (* the following operations correspond to actual rewriting *) | C_OPP_PLUS : step | C_OPP_OPP : step | C_OPP_MULT_R : step | C_OPP_ONE : step (* This is a special step that reduces the term (computation) *) | C_REDUCE : step | C_MULT_PLUS_DISTR : step | C_MULT_OPP_LEFT : step | C_MULT_ASSOC_R : step | C_PLUS_ASSOC_R : step | C_PLUS_ASSOC_L : step | C_PLUS_PERMUTE : step | C_PLUS_COMM : step | C_RED0 : step | C_RED1 : step | C_RED2 : step | C_RED3 : step | C_RED4 : step | C_RED5 : step | C_RED6 : step | C_MULT_ASSOC_REDUCED : step | C_MINUS : step | C_MULT_COMM : step. (* \subsubsection{Omega steps} *) (* The following inductive type describes steps as they can be found in the trace coming from the decision procedure Omega. *) Inductive t_omega : Set := (* n = 0 and n!= 0 *) | O_CONSTANT_NOT_NUL : nat -> t_omega | O_CONSTANT_NEG : nat -> t_omega (* division and approximation of an equation *) | O_DIV_APPROX : int -> int -> term -> nat -> t_omega -> nat -> t_omega (* no solution because no exact division *) | O_NOT_EXACT_DIVIDE : int -> int -> term -> nat -> nat -> t_omega (* exact division *) | O_EXACT_DIVIDE : int -> term -> nat -> t_omega -> nat -> t_omega | O_SUM : int -> nat -> int -> nat -> list t_fusion -> t_omega -> t_omega | O_CONTRADICTION : nat -> nat -> nat -> t_omega | O_MERGE_EQ : nat -> nat -> nat -> t_omega -> t_omega | O_SPLIT_INEQ : nat -> nat -> t_omega -> t_omega -> t_omega | O_CONSTANT_NUL : nat -> t_omega | O_NEGATE_CONTRADICT : nat -> nat -> t_omega | O_NEGATE_CONTRADICT_INV : nat -> nat -> nat -> t_omega | O_STATE : int -> step -> nat -> nat -> t_omega -> t_omega. (* \subsubsection{Rules for normalizing the hypothesis} *) (* These rules indicate how to normalize useful propositions of each useful hypothesis before the decomposition of hypothesis. The rules include the inversion phase for negation removal. *) Inductive p_step : Set := | P_LEFT : p_step -> p_step | P_RIGHT : p_step -> p_step | P_INVERT : step -> p_step | P_STEP : step -> p_step | P_NOP : p_step. (* List of normalizations to perform : with a constructor of type [p_step] allowing to visit both left and right branches, we would be able to restrict to only one normalization by hypothesis. And since all hypothesis are useful (otherwise they wouldn't be included), we would be able to replace [h_step] by a simple list. *) Inductive h_step : Set := pair_step : nat -> p_step -> h_step. (* \subsubsection{Rules for decomposing the hypothesis} *) (* This type allows to navigate in the logical constructors that form the predicats of the hypothesis in order to decompose them. This allows in particular to extract one hypothesis from a conjunction with possibly the right level of negations. *) Inductive direction : Set := | D_left : direction | D_right : direction | D_mono : direction. (* This type allows to extract useful components from hypothesis, either hypothesis generated by splitting a disjonction, or equations. The last constructor indicates how to solve the obtained system via the use of the trace type of Omega [t_omega] *) Inductive e_step : Set := | E_SPLIT : nat -> list direction -> e_step -> e_step -> e_step | E_EXTRACT : nat -> list direction -> e_step -> e_step | E_SOLVE : t_omega -> e_step. (* \subsection{Efficient decidable equality} *) (* For each reified data-type, we define an efficient equality test. It is not the one produced by [Decide Equality]. Then we prove two theorem allowing to eliminate such equalities : \begin{verbatim} (t1,t2: typ) (eq_typ t1 t2) = true -> t1 = t2. (t1,t2: typ) (eq_typ t1 t2) = false -> ~ t1 = t2. \end{verbatim} *) (* \subsubsection{Reified terms} *) Open Scope romega_scope. Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := match t1, t2 with | Tint st1, Tint st2 => beq st1 st2 | (st11 + st12), (st21 + st22) => eq_term st11 st21 && eq_term st12 st22 | (st11 * st12), (st21 * st22) => eq_term st11 st21 && eq_term st12 st22 | (st11 - st12), (st21 - st22) => eq_term st11 st21 && eq_term st12 st22 | (- st1), (- st2) => eq_term st1 st2 | [st1], [st2] => beq_nat st1 st2 | _, _ => false end. Close Scope romega_scope. Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2. Proof. induction t1; destruct t2; simpl in *; try discriminate; (rewrite andb_true_iff; intros (H1,H2)) || intros H; f_equal; auto using beq_true, beq_nat_true. Qed. Theorem eq_term_refl : forall t0 : term, eq_term t0 t0 = true. Proof. induction t0; simpl in *; try (apply andb_true_iff; split); trivial. - now apply beq_iff. - now apply beq_nat_true_iff. Qed. Ltac trivial_case := unfold not; intros; discriminate. Theorem eq_term_false : forall t1 t2 : term, eq_term t1 t2 = false -> t1 <> t2. Proof. intros t1 t2 H E. subst t2. now rewrite eq_term_refl in H. Qed. (* \subsubsection{Tactiques pour ÃĐliminer ces tests} Si on se contente de faire un [Case (eq_typ t1 t2)] on perd totalement dans chaque branche le fait que [t1=t2] ou [~t1=t2]. Initialement, les dÃĐveloppements avaient ÃĐtÃĐ rÃĐalisÃĐs avec les tests rendus par [Decide Equality], c'est à dire un test rendant des termes du type [{t1=t2}+{~t1=t2}]. Faire une ÃĐlimination sur un tel test prÃĐserve bien l'information voulue mais calculatoirement de telles fonctions sont trop lentes. *) (* Les tactiques dÃĐfinies si aprÃĻs se comportent exactement comme si on avait utilisÃĐ le test prÃĐcÃĐdent et fait une elimination dessus. *) Ltac elim_eq_term t1 t2 := pattern (eq_term t1 t2); apply bool_eq_ind; intro Aux; [ generalize (eq_term_true t1 t2 Aux); clear Aux | generalize (eq_term_false t1 t2 Aux); clear Aux ]. Ltac elim_beq t1 t2 := pattern (beq t1 t2); apply bool_eq_ind; intro Aux; [ generalize (beq_true t1 t2 Aux); clear Aux | generalize (beq_false t1 t2 Aux); clear Aux ]. Ltac elim_bgt t1 t2 := pattern (bgt t1 t2); apply bool_eq_ind; intro Aux; [ generalize (bgt_true t1 t2 Aux); clear Aux | generalize (bgt_false t1 t2 Aux); clear Aux ]. (* \subsection{InterprÃĐtations} \subsubsection{InterprÃĐtation des termes dans Z} *) Fixpoint interp_term (env : list int) (t : term) {struct t} : int := match t with | Tint x => x | (t1 + t2)%term => interp_term env t1 + interp_term env t2 | (t1 * t2)%term => interp_term env t1 * interp_term env t2 | (t1 - t2)%term => interp_term env t1 - interp_term env t2 | (- t)%term => - interp_term env t | [n]%term => nth n env 0 end. (* \subsubsection{InterprÃĐtation des prÃĐdicats} *) Fixpoint interp_proposition (envp : list Prop) (env : list int) (p : proposition) {struct p} : Prop := match p with | EqTerm t1 t2 => interp_term env t1 = interp_term env t2 | LeqTerm t1 t2 => interp_term env t1 <= interp_term env t2 | TrueTerm => True | FalseTerm => False | Tnot p' => ~ interp_proposition envp env p' | GeqTerm t1 t2 => interp_term env t1 >= interp_term env t2 | GtTerm t1 t2 => interp_term env t1 > interp_term env t2 | LtTerm t1 t2 => interp_term env t1 < interp_term env t2 | NeqTerm t1 t2 => (interp_term env t1)<>(interp_term env t2) | Tor p1 p2 => interp_proposition envp env p1 \/ interp_proposition envp env p2 | Tand p1 p2 => interp_proposition envp env p1 /\ interp_proposition envp env p2 | Timp p1 p2 => interp_proposition envp env p1 -> interp_proposition envp env p2 | Tprop n => nth n envp True end. (* \subsubsection{InteprÃĐtation des listes d'hypothÃĻses} \paragraph{Sous forme de conjonction} InterprÃĐtation sous forme d'une conjonction d'hypothÃĻses plus faciles à manipuler individuellement *) Fixpoint interp_hyps (envp : list Prop) (env : list int) (l : hyps) {struct l} : Prop := match l with | nil => True | p' :: l' => interp_proposition envp env p' /\ interp_hyps envp env l' end. (* \paragraph{sous forme de but} C'est cette interpÃĐtation que l'on utilise sur le but (car on utilise [Generalize] et qu'une conjonction est forcÃĐment lourde (rÃĐpÃĐtition des types dans les conjonctions intermÃĐdiaires) *) Fixpoint interp_goal_concl (c : proposition) (envp : list Prop) (env : list int) (l : hyps) {struct l} : Prop := match l with | nil => interp_proposition envp env c | p' :: l' => interp_proposition envp env p' -> interp_goal_concl c envp env l' end. Notation interp_goal := (interp_goal_concl FalseTerm). (* Les thÃĐorÃĻmes qui suivent assurent la correspondance entre les deux interprÃĐtations. *) Theorem goal_to_hyps : forall (envp : list Prop) (env : list int) (l : hyps), (interp_hyps envp env l -> False) -> interp_goal envp env l. Proof. simple induction l; [ simpl; auto | simpl; intros a l1 H1 H2 H3; apply H1; intro H4; apply H2; auto ]. Qed. Theorem hyps_to_goal : forall (envp : list Prop) (env : list int) (l : hyps), interp_goal envp env l -> interp_hyps envp env l -> False. Proof. simple induction l; simpl; [ auto | intros; apply H; elim H1; auto ]. Qed. (* \subsection{Manipulations sur les hypothÃĻses} *) (* \subsubsection{DÃĐfinitions de base de stabilitÃĐ pour la rÃĐflexion} *) (* Une opÃĐration laisse un terme stable si l'ÃĐgalitÃĐ est prÃĐservÃĐe *) Definition term_stable (f : term -> term) := forall (e : list int) (t : term), interp_term e t = interp_term e (f t). (* Une opÃĐration est valide sur une hypothÃĻse, si l'hypothÃĻse implique le rÃĐsultat de l'opÃĐration. \emph{Attention : cela ne concerne que des opÃĐrations sur les hypothÃĻses et non sur les buts (contravariance)}. On dÃĐfinit la validitÃĐ pour une opÃĐration prenant une ou deux propositions en argument (cela suffit pour omega). *) Definition valid1 (f : proposition -> proposition) := forall (ep : list Prop) (e : list int) (p1 : proposition), interp_proposition ep e p1 -> interp_proposition ep e (f p1). Definition valid2 (f : proposition -> proposition -> proposition) := forall (ep : list Prop) (e : list int) (p1 p2 : proposition), interp_proposition ep e p1 -> interp_proposition ep e p2 -> interp_proposition ep e (f p1 p2). (* Dans cette notion de validitÃĐ, la fonction prend directement une liste de propositions et rend une nouvelle liste de proposition. On reste contravariant *) Definition valid_hyps (f : hyps -> hyps) := forall (ep : list Prop) (e : list int) (lp : hyps), interp_hyps ep e lp -> interp_hyps ep e (f lp). (* Enfin ce thÃĐorÃĻme ÃĐlimine la contravariance et nous ramÃĻne à une opÃĐration sur les buts *) Theorem valid_goal : forall (ep : list Prop) (env : list int) (l : hyps) (a : hyps -> hyps), valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l. Proof. intros; simpl; apply goal_to_hyps; intro H1; apply (hyps_to_goal ep env (a l) H0); apply H; assumption. Qed. (* \subsubsection{GÃĐnÃĐralisation a des listes de buts (disjonctions)} *) Fixpoint interp_list_hyps (envp : list Prop) (env : list int) (l : lhyps) {struct l} : Prop := match l with | nil => False | h :: l' => interp_hyps envp env h \/ interp_list_hyps envp env l' end. Fixpoint interp_list_goal (envp : list Prop) (env : list int) (l : lhyps) {struct l} : Prop := match l with | nil => True | h :: l' => interp_goal envp env h /\ interp_list_goal envp env l' end. Theorem list_goal_to_hyps : forall (envp : list Prop) (env : list int) (l : lhyps), (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l. Proof. simple induction l; simpl; [ auto | intros h1 l1 H H1; split; [ apply goal_to_hyps; intro H2; apply H1; auto | apply H; intro H2; apply H1; auto ] ]. Qed. Theorem list_hyps_to_goal : forall (envp : list Prop) (env : list int) (l : lhyps), interp_list_goal envp env l -> interp_list_hyps envp env l -> False. Proof. simple induction l; simpl; [ auto | intros h1 l1 H (H1, H2) H3; elim H3; intro H4; [ apply hyps_to_goal with (1 := H1); assumption | auto ] ]. Qed. Definition valid_list_hyps (f : hyps -> lhyps) := forall (ep : list Prop) (e : list int) (lp : hyps), interp_hyps ep e lp -> interp_list_hyps ep e (f lp). Definition valid_list_goal (f : hyps -> lhyps) := forall (ep : list Prop) (e : list int) (lp : hyps), interp_list_goal ep e (f lp) -> interp_goal ep e lp. Theorem goal_valid : forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f. Proof. unfold valid_list_goal; intros f H ep e lp H1; apply goal_to_hyps; intro H2; apply list_hyps_to_goal with (1 := H1); apply (H ep e lp); assumption. Qed. Theorem append_valid : forall (ep : list Prop) (e : list int) (l1 l2 : lhyps), interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 -> interp_list_hyps ep e (l1 ++ l2). Proof. intros ep e; simple induction l1; [ simpl; intros l2 [H| H]; [ contradiction | trivial ] | simpl; intros h1 t1 HR l2 [[H| H]| H]; [ auto | right; apply (HR l2); left; trivial | right; apply (HR l2); right; trivial ] ]. Qed. (* \subsubsection{OpÃĐrateurs valides sur les hypothÃĻses} *) (* Extraire une hypothÃĻse de la liste *) Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm. Theorem nth_valid : forall (ep : list Prop) (e : list int) (i : nat) (l : hyps), interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l). Proof. unfold nth_hyps; simple induction i; [ simple induction l; simpl; [ auto | intros; elim H0; auto ] | intros n H; simple induction l; [ simpl; trivial | intros; simpl; apply H; elim H1; auto ] ]. Qed. (* Appliquer une opÃĐration (valide) sur deux hypothÃĻses extraites de la liste et ajouter le rÃĐsultat à la liste. *) Definition apply_oper_2 (i j : nat) (f : proposition -> proposition -> proposition) (l : hyps) := f (nth_hyps i l) (nth_hyps j l) :: l. Theorem apply_oper_2_valid : forall (i j : nat) (f : proposition -> proposition -> proposition), valid2 f -> valid_hyps (apply_oper_2 i j f). Proof. intros i j f Hf; unfold apply_oper_2, valid_hyps; simpl; intros lp Hlp; split; [ apply Hf; apply nth_valid; assumption | assumption ]. Qed. (* Modifier une hypothÃĻse par application d'une opÃĐration valide *) Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) (l : hyps) {struct i} : hyps := match l with | nil => nil (A:=proposition) | p :: l' => match i with | O => f p :: l' | S j => p :: apply_oper_1 j f l' end end. Theorem apply_oper_1_valid : forall (i : nat) (f : proposition -> proposition), valid1 f -> valid_hyps (apply_oper_1 i f). Proof. unfold valid_hyps; intros i f Hf ep e; elim i; [ intro lp; case lp; [ simpl; trivial | simpl; intros p l' (H1, H2); split; [ apply Hf with (1 := H1) | assumption ] ] | intros n Hrec lp; case lp; [ simpl; auto | simpl; intros p l' (H1, H2); split; [ assumption | apply Hrec; assumption ] ] ]. Qed. (* \subsubsection{Manipulations de termes} *) (* Les fonctions suivantes permettent d'appliquer une fonction de rÃĐÃĐcriture sur un sous terme du terme principal. Avec la composition, cela permet de construire des rÃĐÃĐcritures complexes proches des tactiques de conversion *) Definition apply_left (f : term -> term) (t : term) := match t with | (x + y)%term => (f x + y)%term | (x * y)%term => (f x * y)%term | (- x)%term => (- f x)%term | x => x end. Definition apply_right (f : term -> term) (t : term) := match t with | (x + y)%term => (x + f y)%term | (x * y)%term => (x * f y)%term | x => x end. Definition apply_both (f g : term -> term) (t : term) := match t with | (x + y)%term => (f x + g y)%term | (x * y)%term => (f x * g y)%term | x => x end. (* Les thÃĐorÃĻmes suivants montrent la stabilitÃĐ (conditionnÃĐe) des fonctions. *) Theorem apply_left_stable : forall f : term -> term, term_stable f -> term_stable (apply_left f). Proof. unfold term_stable; intros f H e t; case t; auto; simpl; intros; elim H; trivial. Qed. Theorem apply_right_stable : forall f : term -> term, term_stable f -> term_stable (apply_right f). Proof. unfold term_stable; intros f H e t; case t; auto; simpl; intros t0 t1; elim H; trivial. Qed. Theorem apply_both_stable : forall f g : term -> term, term_stable f -> term_stable g -> term_stable (apply_both f g). Proof. unfold term_stable; intros f g H1 H2 e t; case t; auto; simpl; intros t0 t1; elim H1; elim H2; trivial. Qed. Theorem compose_term_stable : forall f g : term -> term, term_stable f -> term_stable g -> term_stable (fun t : term => f (g t)). Proof. unfold term_stable; intros f g Hf Hg e t; elim Hf; apply Hg. Qed. (* \subsection{Les rÃĻgles de rÃĐÃĐcriture} *) (* Chacune des rÃĻgles de rÃĐÃĐcriture est accompagnÃĐe par sa preuve de stabilitÃĐ. Toutes ces preuves ont la mÊme forme : il faut analyser suivant la forme du terme (ÃĐlimination de chaque Case). On a besoin d'une ÃĐlimination uniquement dans les cas d'utilisation d'ÃĐgalitÃĐ dÃĐcidable. Cette tactique itÃĻre la dÃĐcomposition des Case. Elle est constituÃĐe de deux fonctions s'appelant mutuellement : \begin{itemize} \item une fonction d'enrobage qui lance la recherche sur le but, \item une fonction rÃĐcursive qui dÃĐcompose ce but. Quand elle a trouvÃĐ un Case, elle l'ÃĐlimine. \end{itemize} Les motifs sur les cas sont trÃĻs imparfaits et dans certains cas, il semble que cela ne marche pas. On aimerait plutot un motif de la forme [ Case (?1 :: T) of _ end ] permettant de s'assurer que l'on utilise le bon type. Chaque ÃĐlimination introduit correctement exactement le nombre d'hypothÃĻses nÃĐcessaires et conserve dans le cas d'une ÃĐgalitÃĐ la connaissance du rÃĐsultat du test en faisant la rÃĐÃĐcriture. Pour un test de comparaison, on conserve simplement le rÃĐsultat. Cette fonction dÃĐborde trÃĻs largement la rÃĐsolution des rÃĐÃĐcritures simples et fait une bonne partie des preuves des pas de Omega. *) (* \subsubsection{La tactique pour prouver la stabilitÃĐ} *) Ltac loop t := match t with (* Global *) | (?X1 = ?X2) => loop X1 || loop X2 | (_ -> ?X1) => loop X1 (* Interpretations *) | (interp_hyps _ _ ?X1) => loop X1 | (interp_list_hyps _ _ ?X1) => loop X1 | (interp_proposition _ _ ?X1) => loop X1 | (interp_term _ ?X1) => loop X1 (* Propositions *) | (EqTerm ?X1 ?X2) => loop X1 || loop X2 | (LeqTerm ?X1 ?X2) => loop X1 || loop X2 (* Termes *) | (?X1 + ?X2)%term => loop X1 || loop X2 | (?X1 - ?X2)%term => loop X1 || loop X2 | (?X1 * ?X2)%term => loop X1 || loop X2 | (- ?X1)%term => loop X1 | (Tint ?X1) => loop X1 (* Eliminations *) | match ?X1 with | EqTerm x x0 => _ | LeqTerm x x0 => _ | TrueTerm => _ | FalseTerm => _ | Tnot x => _ | GeqTerm x x0 => _ | GtTerm x x0 => _ | LtTerm x x0 => _ | NeqTerm x x0 => _ | Tor x x0 => _ | Tand x x0 => _ | Timp x x0 => _ | Tprop x => _ end => destruct X1; auto; Simplify | match ?X1 with | Tint x => _ | (x + x0)%term => _ | (x * x0)%term => _ | (x - x0)%term => _ | (- x)%term => _ | [x]%term => _ end => destruct X1; auto; Simplify | (if beq ?X1 ?X2 then _ else _) => let H := fresh "H" in elim_beq X1 X2; intro H; try (rewrite H in *; clear H); simpl; auto; Simplify | (if bgt ?X1 ?X2 then _ else _) => let H := fresh "H" in elim_bgt X1 X2; intro H; simpl; auto; Simplify | (if eq_term ?X1 ?X2 then _ else _) => let H := fresh "H" in elim_eq_term X1 X2; intro H; try (rewrite H in *; clear H); simpl; auto; Simplify | (if _ && _ then _ else _) => rewrite andb_if; Simplify | (if negb _ then _ else _) => rewrite negb_if; Simplify | _ => fail end with Simplify := match goal with | |- ?X1 => try loop X1 | _ => idtac end. Ltac prove_stable x th := match constr:x with | ?X1 => unfold term_stable, X1; intros; Simplify; simpl; apply th end. (* \subsubsection{Les rÃĻgles elle mÊmes} *) Definition Tplus_assoc_l (t : term) := match t with | (n + (m + p))%term => (n + m + p)%term | _ => t end. Theorem Tplus_assoc_l_stable : term_stable Tplus_assoc_l. Proof. prove_stable Tplus_assoc_l (ring.(Radd_assoc)). Qed. Definition Tplus_assoc_r (t : term) := match t with | (n + m + p)%term => (n + (m + p))%term | _ => t end. Theorem Tplus_assoc_r_stable : term_stable Tplus_assoc_r. Proof. prove_stable Tplus_assoc_r plus_assoc_reverse. Qed. Definition Tmult_assoc_r (t : term) := match t with | (n * m * p)%term => (n * (m * p))%term | _ => t end. Theorem Tmult_assoc_r_stable : term_stable Tmult_assoc_r. Proof. prove_stable Tmult_assoc_r mult_assoc_reverse. Qed. Definition Tplus_permute (t : term) := match t with | (n + (m + p))%term => (m + (n + p))%term | _ => t end. Theorem Tplus_permute_stable : term_stable Tplus_permute. Proof. prove_stable Tplus_permute plus_permute. Qed. Definition Tplus_comm (t : term) := match t with | (x + y)%term => (y + x)%term | _ => t end. Theorem Tplus_comm_stable : term_stable Tplus_comm. Proof. prove_stable Tplus_comm plus_comm. Qed. Definition Tmult_comm (t : term) := match t with | (x * y)%term => (y * x)%term | _ => t end. Theorem Tmult_comm_stable : term_stable Tmult_comm. Proof. prove_stable Tmult_comm mult_comm. Qed. Definition T_OMEGA10 (t : term) := match t with | ((v * Tint c1 + l1) * Tint k1 + (v' * Tint c2 + l2) * Tint k2)%term => if eq_term v v' then (v * Tint (c1 * k1 + c2 * k2)%I + (l1 * Tint k1 + l2 * Tint k2))%term else t | _ => t end. Theorem T_OMEGA10_stable : term_stable T_OMEGA10. Proof. prove_stable T_OMEGA10 OMEGA10. Qed. Definition T_OMEGA11 (t : term) := match t with | ((v1 * Tint c1 + l1) * Tint k1 + l2)%term => (v1 * Tint (c1 * k1) + (l1 * Tint k1 + l2))%term | _ => t end. Theorem T_OMEGA11_stable : term_stable T_OMEGA11. Proof. prove_stable T_OMEGA11 OMEGA11. Qed. Definition T_OMEGA12 (t : term) := match t with | (l1 + (v2 * Tint c2 + l2) * Tint k2)%term => (v2 * Tint (c2 * k2) + (l1 + l2 * Tint k2))%term | _ => t end. Theorem T_OMEGA12_stable : term_stable T_OMEGA12. Proof. prove_stable T_OMEGA12 OMEGA12. Qed. Definition T_OMEGA13 (t : term) := match t with | (v * Tint x + l1 + (v' * Tint x' + l2))%term => if eq_term v v' && beq x (-x') then (l1+l2)%term else t | _ => t end. Theorem T_OMEGA13_stable : term_stable T_OMEGA13. Proof. unfold term_stable, T_OMEGA13; intros; Simplify; simpl; apply OMEGA13. Qed. Definition T_OMEGA15 (t : term) := match t with | (v * Tint c1 + l1 + (v' * Tint c2 + l2) * Tint k2)%term => if eq_term v v' then (v * Tint (c1 + c2 * k2)%I + (l1 + l2 * Tint k2))%term else t | _ => t end. Theorem T_OMEGA15_stable : term_stable T_OMEGA15. Proof. prove_stable T_OMEGA15 OMEGA15. Qed. Definition T_OMEGA16 (t : term) := match t with | ((v * Tint c + l) * Tint k)%term => (v * Tint (c * k) + l * Tint k)%term | _ => t end. Theorem T_OMEGA16_stable : term_stable T_OMEGA16. Proof. prove_stable T_OMEGA16 OMEGA16. Qed. Definition Tred_factor5 (t : term) := match t with | (x * Tint c + y)%term => if beq c 0 then y else t | _ => t end. Theorem Tred_factor5_stable : term_stable Tred_factor5. Proof. prove_stable Tred_factor5 red_factor5. Qed. Definition Topp_plus (t : term) := match t with | (- (x + y))%term => (- x + - y)%term | _ => t end. Theorem Topp_plus_stable : term_stable Topp_plus. Proof. prove_stable Topp_plus opp_plus_distr. Qed. Definition Topp_opp (t : term) := match t with | (- - x)%term => x | _ => t end. Theorem Topp_opp_stable : term_stable Topp_opp. Proof. prove_stable Topp_opp opp_involutive. Qed. Definition Topp_mult_r (t : term) := match t with | (- (x * Tint k))%term => (x * Tint (- k))%term | _ => t end. Theorem Topp_mult_r_stable : term_stable Topp_mult_r. Proof. prove_stable Topp_mult_r opp_mult_distr_r. Qed. Definition Topp_one (t : term) := match t with | (- x)%term => (x * Tint (-(1)))%term | _ => t end. Theorem Topp_one_stable : term_stable Topp_one. Proof. prove_stable Topp_one opp_eq_mult_neg_1. Qed. Definition Tmult_plus_distr (t : term) := match t with | ((n + m) * p)%term => (n * p + m * p)%term | _ => t end. Theorem Tmult_plus_distr_stable : term_stable Tmult_plus_distr. Proof. prove_stable Tmult_plus_distr mult_plus_distr_r. Qed. Definition Tmult_opp_left (t : term) := match t with | (- x * Tint y)%term => (x * Tint (- y))%term | _ => t end. Theorem Tmult_opp_left_stable : term_stable Tmult_opp_left. Proof. prove_stable Tmult_opp_left mult_opp_comm. Qed. Definition Tmult_assoc_reduced (t : term) := match t with | (n * Tint m * Tint p)%term => (n * Tint (m * p))%term | _ => t end. Theorem Tmult_assoc_reduced_stable : term_stable Tmult_assoc_reduced. Proof. prove_stable Tmult_assoc_reduced mult_assoc_reverse. Qed. Definition Tred_factor0 (t : term) := (t * Tint 1)%term. Theorem Tred_factor0_stable : term_stable Tred_factor0. Proof. prove_stable Tred_factor0 red_factor0. Qed. Definition Tred_factor1 (t : term) := match t with | (x + y)%term => if eq_term x y then (x * Tint 2)%term else t | _ => t end. Theorem Tred_factor1_stable : term_stable Tred_factor1. Proof. prove_stable Tred_factor1 red_factor1. Qed. Definition Tred_factor2 (t : term) := match t with | (x + y * Tint k)%term => if eq_term x y then (x * Tint (1 + k))%term else t | _ => t end. Theorem Tred_factor2_stable : term_stable Tred_factor2. Proof. prove_stable Tred_factor2 red_factor2. Qed. Definition Tred_factor3 (t : term) := match t with | (x * Tint k + y)%term => if eq_term x y then (x * Tint (1 + k))%term else t | _ => t end. Theorem Tred_factor3_stable : term_stable Tred_factor3. Proof. prove_stable Tred_factor3 red_factor3. Qed. Definition Tred_factor4 (t : term) := match t with | (x * Tint k1 + y * Tint k2)%term => if eq_term x y then (x * Tint (k1 + k2))%term else t | _ => t end. Theorem Tred_factor4_stable : term_stable Tred_factor4. Proof. prove_stable Tred_factor4 red_factor4. Qed. Definition Tred_factor6 (t : term) := (t + Tint 0)%term. Theorem Tred_factor6_stable : term_stable Tred_factor6. Proof. prove_stable Tred_factor6 red_factor6. Qed. Definition Tminus_def (t : term) := match t with | (x - y)%term => (x + - y)%term | _ => t end. Theorem Tminus_def_stable : term_stable Tminus_def. Proof. prove_stable Tminus_def minus_def. Qed. (* \subsection{Fonctions de rÃĐÃĐcriture complexes} *) (* \subsubsection{Fonction de rÃĐduction} *) (* Cette fonction rÃĐduit un terme dont la forme normale est un entier. Il suffit pour cela d'ÃĐchanger le constructeur [Tint] avec les opÃĐrateurs rÃĐifiÃĐs. La rÃĐduction est ``gratuite''. *) Fixpoint reduce (t : term) : term := match t with | (x + y)%term => match reduce x with | Tint x' => match reduce y with | Tint y' => Tint (x' + y') | y' => (Tint x' + y')%term end | x' => (x' + reduce y)%term end | (x * y)%term => match reduce x with | Tint x' => match reduce y with | Tint y' => Tint (x' * y') | y' => (Tint x' * y')%term end | x' => (x' * reduce y)%term end | (x - y)%term => match reduce x with | Tint x' => match reduce y with | Tint y' => Tint (x' - y') | y' => (Tint x' - y')%term end | x' => (x' - reduce y)%term end | (- x)%term => match reduce x with | Tint x' => Tint (- x') | x' => (- x')%term end | _ => t end. Theorem reduce_stable : term_stable reduce. Proof. unfold term_stable; intros e t; elim t; auto; try (intros t0 H0 t1 H1; simpl; rewrite H0; rewrite H1; (case (reduce t0); [ intro z0; case (reduce t1); intros; auto | intros; auto | intros; auto | intros; auto | intros; auto | intros; auto ])); intros t0 H0; simpl; rewrite H0; case (reduce t0); intros; auto. Qed. (* \subsubsection{Fusions} \paragraph{Fusion de deux ÃĐquations} *) (* On donne une somme de deux ÃĐquations qui sont supposÃĐes normalisÃĐes. Cette fonction prend une trace de fusion en argument et transforme le terme en une ÃĐquation normalisÃĐe. C'est une version trÃĻs simplifiÃĐe du moteur de rÃĐÃĐcriture [rewrite]. *) Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term := match trace with | nil => reduce t | step :: trace' => match step with | F_equal => apply_right (fusion trace') (T_OMEGA10 t) | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA10 t)) | F_left => apply_right (fusion trace') (T_OMEGA11 t) | F_right => apply_right (fusion trace') (T_OMEGA12 t) end end. Theorem fusion_stable : forall trace : list t_fusion, term_stable (fusion trace). Proof. simple induction trace; simpl; [ exact reduce_stable | intros stp l H; case stp; [ apply compose_term_stable; [ apply apply_right_stable; assumption | exact T_OMEGA10_stable ] | unfold term_stable; intros e t1; rewrite T_OMEGA10_stable; rewrite Tred_factor5_stable; apply H | apply compose_term_stable; [ apply apply_right_stable; assumption | exact T_OMEGA11_stable ] | apply compose_term_stable; [ apply apply_right_stable; assumption | exact T_OMEGA12_stable ] ] ]. Qed. (* \paragraph{Fusion de deux ÃĐquations dont une sans coefficient} *) Definition fusion_right (trace : list t_fusion) (t : term) : term := match trace with | nil => reduce t (* Il faut mettre un compute *) | step :: trace' => match step with | F_equal => apply_right (fusion trace') (T_OMEGA15 t) | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA15 t)) | F_left => apply_right (fusion trace') (Tplus_assoc_r t) | F_right => apply_right (fusion trace') (T_OMEGA12 t) end end. (* \paragraph{Fusion avec annihilation} *) (* Normalement le rÃĐsultat est une constante *) Fixpoint fusion_cancel (trace : nat) (t : term) {struct trace} : term := match trace with | O => reduce t | S trace' => fusion_cancel trace' (T_OMEGA13 t) end. Theorem fusion_cancel_stable : forall t : nat, term_stable (fusion_cancel t). Proof. unfold term_stable, fusion_cancel; intros trace e; elim trace; [ exact (reduce_stable e) | intros n H t; elim H; exact (T_OMEGA13_stable e t) ]. Qed. (* \subsubsection{OpÃĐrations affines sur une ÃĐquation} *) (* \paragraph{Multiplication scalaire et somme d'une constante} *) Fixpoint scalar_norm_add (trace : nat) (t : term) {struct trace} : term := match trace with | O => reduce t | S trace' => apply_right (scalar_norm_add trace') (T_OMEGA11 t) end. Theorem scalar_norm_add_stable : forall t : nat, term_stable (scalar_norm_add t). Proof. unfold term_stable, scalar_norm_add; intros trace; elim trace; [ exact reduce_stable | intros n H e t; elim apply_right_stable; [ exact (T_OMEGA11_stable e t) | exact H ] ]. Qed. (* \paragraph{Multiplication scalaire} *) Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term := match trace with | O => reduce t | S trace' => apply_right (scalar_norm trace') (T_OMEGA16 t) end. Theorem scalar_norm_stable : forall t : nat, term_stable (scalar_norm t). Proof. unfold term_stable, scalar_norm; intros trace; elim trace; [ exact reduce_stable | intros n H e t; elim apply_right_stable; [ exact (T_OMEGA16_stable e t) | exact H ] ]. Qed. (* \paragraph{Somme d'une constante} *) Fixpoint add_norm (trace : nat) (t : term) {struct trace} : term := match trace with | O => reduce t | S trace' => apply_right (add_norm trace') (Tplus_assoc_r t) end. Theorem add_norm_stable : forall t : nat, term_stable (add_norm t). Proof. unfold term_stable, add_norm; intros trace; elim trace; [ exact reduce_stable | intros n H e t; elim apply_right_stable; [ exact (Tplus_assoc_r_stable e t) | exact H ] ]. Qed. (* \subsection{La fonction de normalisation des termes (moteur de rÃĐÃĐcriture)} *) Fixpoint t_rewrite (s : step) : term -> term := match s with | C_DO_BOTH s1 s2 => apply_both (t_rewrite s1) (t_rewrite s2) | C_LEFT s => apply_left (t_rewrite s) | C_RIGHT s => apply_right (t_rewrite s) | C_SEQ s1 s2 => fun t : term => t_rewrite s2 (t_rewrite s1 t) | C_NOP => fun t : term => t | C_OPP_PLUS => Topp_plus | C_OPP_OPP => Topp_opp | C_OPP_MULT_R => Topp_mult_r | C_OPP_ONE => Topp_one | C_REDUCE => reduce | C_MULT_PLUS_DISTR => Tmult_plus_distr | C_MULT_OPP_LEFT => Tmult_opp_left | C_MULT_ASSOC_R => Tmult_assoc_r | C_PLUS_ASSOC_R => Tplus_assoc_r | C_PLUS_ASSOC_L => Tplus_assoc_l | C_PLUS_PERMUTE => Tplus_permute | C_PLUS_COMM => Tplus_comm | C_RED0 => Tred_factor0 | C_RED1 => Tred_factor1 | C_RED2 => Tred_factor2 | C_RED3 => Tred_factor3 | C_RED4 => Tred_factor4 | C_RED5 => Tred_factor5 | C_RED6 => Tred_factor6 | C_MULT_ASSOC_REDUCED => Tmult_assoc_reduced | C_MINUS => Tminus_def | C_MULT_COMM => Tmult_comm end. Theorem t_rewrite_stable : forall s : step, term_stable (t_rewrite s). Proof. simple induction s; simpl; [ intros; apply apply_both_stable; auto | intros; apply apply_left_stable; auto | intros; apply apply_right_stable; auto | unfold term_stable; intros; elim H0; apply H | unfold term_stable; auto | exact Topp_plus_stable | exact Topp_opp_stable | exact Topp_mult_r_stable | exact Topp_one_stable | exact reduce_stable | exact Tmult_plus_distr_stable | exact Tmult_opp_left_stable | exact Tmult_assoc_r_stable | exact Tplus_assoc_r_stable | exact Tplus_assoc_l_stable | exact Tplus_permute_stable | exact Tplus_comm_stable | exact Tred_factor0_stable | exact Tred_factor1_stable | exact Tred_factor2_stable | exact Tred_factor3_stable | exact Tred_factor4_stable | exact Tred_factor5_stable | exact Tred_factor6_stable | exact Tmult_assoc_reduced_stable | exact Tminus_def_stable | exact Tmult_comm_stable ]. Qed. (* \subsection{tactiques de rÃĐsolution d'un but omega normalisÃĐ} Trace de la procÃĐdure \subsubsection{Tactiques gÃĐnÃĐrant une contradiction} \paragraph{[O_CONSTANT_NOT_NUL]} *) Definition constant_not_nul (i : nat) (h : hyps) := match nth_hyps i h with | EqTerm (Tint Nul) (Tint n) => if beq n Nul then h else absurd | _ => h end. Theorem constant_not_nul_valid : forall i : nat, valid_hyps (constant_not_nul i). Proof. unfold valid_hyps, constant_not_nul; intros i ep e lp H. generalize (nth_valid ep e i lp H); Simplify. Qed. (* \paragraph{[O_CONSTANT_NEG]} *) Definition constant_neg (i : nat) (h : hyps) := match nth_hyps i h with | LeqTerm (Tint Nul) (Tint Neg) => if bgt Nul Neg then absurd else h | _ => h end. Theorem constant_neg_valid : forall i : nat, valid_hyps (constant_neg i). Proof. unfold valid_hyps, constant_neg; intros; generalize (nth_valid ep e i lp); Simplify; simpl. rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. Qed. (* \paragraph{[NOT_EXACT_DIVIDE]} *) Definition not_exact_divide (k1 k2 : int) (body : term) (t i : nat) (l : hyps) := match nth_hyps i l with | EqTerm (Tint Nul) b => if beq Nul 0 && eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && bgt k2 0 && bgt k1 k2 then absurd else l | _ => l end. Theorem not_exact_divide_valid : forall (k1 k2 : int) (body : term) (t0 i : nat), valid_hyps (not_exact_divide k1 k2 body t0 i). Proof. unfold valid_hyps, not_exact_divide; intros; generalize (nth_valid ep e i lp); Simplify. rewrite (scalar_norm_add_stable t0 e), <-H1. do 2 rewrite <- scalar_norm_add_stable; simpl in *; intros. absurd (interp_term e body * k1 + k2 = 0); [ now apply OMEGA4 | symmetry; auto ]. Qed. (* \paragraph{[O_CONTRADICTION]} *) Definition contradiction (t i j : nat) (l : hyps) := match nth_hyps i l with | LeqTerm (Tint Nul) b1 => match nth_hyps j l with | LeqTerm (Tint Nul') b2 => match fusion_cancel t (b1 + b2)%term with | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k then absurd else l | _ => l end | _ => l end | _ => l end. Theorem contradiction_valid : forall t i j : nat, valid_hyps (contradiction t i j). Proof. unfold valid_hyps, contradiction; intros t i j ep e l H; generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); case (nth_hyps i l); auto; intros t1 t2; case t1; auto; case (nth_hyps j l); auto; intros t3 t4; case t3; auto; simpl; intros z z' H1 H2; generalize (eq_refl (interp_term e (fusion_cancel t (t2 + t4)%term))); pattern (fusion_cancel t (t2 + t4)%term) at 2 3; case (fusion_cancel t (t2 + t4)%term); simpl; auto; intro k; elim (fusion_cancel_stable t); simpl. Simplify; intro H3. generalize (OMEGA2 _ _ H2 H1); rewrite H3. rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. Qed. (* \paragraph{[O_NEGATE_CONTRADICT]} *) Definition negate_contradict (i1 i2 : nat) (h : hyps) := match nth_hyps i1 h with | EqTerm (Tint Nul) b1 => match nth_hyps i2 h with | NeqTerm (Tint Nul') b2 => if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 then absurd else h | _ => h end | NeqTerm (Tint Nul) b1 => match nth_hyps i2 h with | EqTerm (Tint Nul') b2 => if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 then absurd else h | _ => h end | _ => h end. Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) := match nth_hyps i1 h with | EqTerm (Tint Nul) b1 => match nth_hyps i2 h with | NeqTerm (Tint Nul') b2 => if beq Nul 0 && beq Nul' 0 && eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) then absurd else h | _ => h end | NeqTerm (Tint Nul) b1 => match nth_hyps i2 h with | EqTerm (Tint Nul') b2 => if beq Nul 0 && beq Nul' 0 && eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) then absurd else h | _ => h end | _ => h end. Theorem negate_contradict_valid : forall i j : nat, valid_hyps (negate_contradict i j). Proof. unfold valid_hyps, negate_contradict; intros i j ep e l H; generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); case (nth_hyps i l); auto; intros t1 t2; case t1; auto; intros z; auto; case (nth_hyps j l); auto; intros t3 t4; case t3; auto; intros z'; auto; simpl; intros H1 H2; Simplify. Qed. Theorem negate_contradict_inv_valid : forall t i j : nat, valid_hyps (negate_contradict_inv t i j). Proof. unfold valid_hyps, negate_contradict_inv; intros t i j ep e l H; generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); case (nth_hyps i l); auto; intros t1 t2; case t1; auto; intros z; auto; case (nth_hyps j l); auto; intros t3 t4; case t3; auto; intros z'; auto; simpl; intros H1 H2; Simplify; [ rewrite <- scalar_norm_stable in H2; simpl in *; elim (mult_integral (interp_term e t4) (-(1))); intuition; elim minus_one_neq_zero; auto | elim H2; clear H2; rewrite <- scalar_norm_stable; simpl in *; now rewrite <- H1, mult_0_l ]. Qed. (* \subsubsection{Tactiques gÃĐnÃĐrant une nouvelle ÃĐquation} *) (* \paragraph{[O_SUM]} C'est une oper2 valide mais elle traite plusieurs cas à la fois (suivant les opÃĐrateurs de comparaison des deux arguments) d'oÃđ une preuve un peu compliquÃĐe. On utilise quelques lemmes qui sont des gÃĐnÃĐralisations des thÃĐorÃĻmes utilisÃĐs par OMEGA. *) Definition sum (k1 k2 : int) (trace : list t_fusion) (prop1 prop2 : proposition) := match prop1 with | EqTerm (Tint Null) b1 => match prop2 with | EqTerm (Tint Null') b2 => if beq Null 0 && beq Null' 0 then EqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) else TrueTerm | LeqTerm (Tint Null') b2 => if beq Null 0 && beq Null' 0 && bgt k2 0 then LeqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) else TrueTerm | _ => TrueTerm end | LeqTerm (Tint Null) b1 => if beq Null 0 && bgt k1 0 then match prop2 with | EqTerm (Tint Null') b2 => if beq Null' 0 then LeqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) else TrueTerm | LeqTerm (Tint Null') b2 => if beq Null' 0 && bgt k2 0 then LeqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) else TrueTerm | _ => TrueTerm end else TrueTerm | NeqTerm (Tint Null) b1 => match prop2 with | EqTerm (Tint Null') b2 => if beq Null 0 && beq Null' 0 && (negb (beq k1 0)) then NeqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) else TrueTerm | _ => TrueTerm end | _ => TrueTerm end. Theorem sum_valid : forall (k1 k2 : int) (t : list t_fusion), valid2 (sum k1 k2 t). Proof. unfold valid2; intros k1 k2 t ep e p1 p2; unfold sum; Simplify; simpl; auto; try elim (fusion_stable t); simpl; intros; [ apply sum1; assumption | apply sum2; try assumption; apply sum4; assumption | rewrite plus_comm; apply sum2; try assumption; apply sum4; assumption | apply sum3; try assumption; apply sum4; assumption | apply sum5; auto ]. Qed. (* \paragraph{[O_EXACT_DIVIDE]} c'est une oper1 valide mais on prÃĐfÃĻre une substitution a ce point la *) Definition exact_divide (k : int) (body : term) (t : nat) (prop : proposition) := match prop with | EqTerm (Tint Null) b => if beq Null 0 && eq_term (scalar_norm t (body * Tint k)%term) b && negb (beq k 0) then EqTerm (Tint 0) body else TrueTerm | NeqTerm (Tint Null) b => if beq Null 0 && eq_term (scalar_norm t (body * Tint k)%term) b && negb (beq k 0) then NeqTerm (Tint 0) body else TrueTerm | _ => TrueTerm end. Theorem exact_divide_valid : forall (k : int) (t : term) (n : nat), valid1 (exact_divide k t n). Proof. unfold valid1, exact_divide; intros k1 k2 t ep e p1; Simplify; simpl; auto; subst; rewrite <- scalar_norm_stable; simpl; intros; [ destruct (mult_integral _ _ (eq_sym H0)); intuition | contradict H0; rewrite <- H0, mult_0_l; auto ]. Qed. (* \paragraph{[O_DIV_APPROX]} La preuve reprend le schÃĐma de la prÃĐcÃĐdente mais on est sur une opÃĐration de type valid1 et non sur une opÃĐration terminale. *) Definition divide_and_approx (k1 k2 : int) (body : term) (t : nat) (prop : proposition) := match prop with | LeqTerm (Tint Null) b => if beq Null 0 && eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && bgt k1 0 && bgt k1 k2 then LeqTerm (Tint 0) body else prop | _ => prop end. Theorem divide_and_approx_valid : forall (k1 k2 : int) (body : term) (t : nat), valid1 (divide_and_approx k1 k2 body t). Proof. unfold valid1, divide_and_approx; intros k1 k2 body t ep e p1; Simplify; simpl; auto; subst; elim (scalar_norm_add_stable t e); simpl. intro H2; apply mult_le_approx with (3 := H2); assumption. Qed. (* \paragraph{[MERGE_EQ]} *) Definition merge_eq (t : nat) (prop1 prop2 : proposition) := match prop1 with | LeqTerm (Tint Null) b1 => match prop2 with | LeqTerm (Tint Null') b2 => if beq Null 0 && beq Null' 0 && eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) then EqTerm (Tint 0) b1 else TrueTerm | _ => TrueTerm end | _ => TrueTerm end. Theorem merge_eq_valid : forall n : nat, valid2 (merge_eq n). Proof. unfold valid2, merge_eq; intros n ep e p1 p2; Simplify; simpl; auto; elim (scalar_norm_stable n e); simpl; intros; symmetry ; apply OMEGA8 with (2 := H0); [ assumption | elim opp_eq_mult_neg_1; trivial ]. Qed. (* \paragraph{[O_CONSTANT_NUL]} *) Definition constant_nul (i : nat) (h : hyps) := match nth_hyps i h with | NeqTerm (Tint Null) (Tint Null') => if beq Null Null' then absurd else h | _ => h end. Theorem constant_nul_valid : forall i : nat, valid_hyps (constant_nul i). Proof. unfold valid_hyps, constant_nul; intros; generalize (nth_valid ep e i lp); Simplify; simpl; intro H1; absurd (0 = 0); intuition. Qed. (* \paragraph{[O_STATE]} *) Definition state (m : int) (s : step) (prop1 prop2 : proposition) := match prop1 with | EqTerm (Tint Null) b1 => match prop2 with | EqTerm b2 b3 => if beq Null 0 then EqTerm (Tint 0) (t_rewrite s (b1 + (- b3 + b2) * Tint m)%term) else TrueTerm | _ => TrueTerm end | _ => TrueTerm end. Theorem state_valid : forall (m : int) (s : step), valid2 (state m s). Proof. unfold valid2; intros m s ep e p1 p2; unfold state; Simplify; simpl; auto; elim (t_rewrite_stable s e); simpl; intros H1 H2; elim H1. now rewrite H2, plus_opp_l, plus_0_l, mult_0_l. Qed. (* \subsubsection{Tactiques gÃĐnÃĐrant plusieurs but} \paragraph{[O_SPLIT_INEQ]} La seule pour le moment (tant que la normalisation n'est pas rÃĐflÃĐchie). *) Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps) (l : hyps) := match nth_hyps i l with | NeqTerm (Tint Null) b1 => if beq Null 0 then f1 (LeqTerm (Tint 0) (add_norm t (b1 + Tint (-(1)))%term) :: l) ++ f2 (LeqTerm (Tint 0) (scalar_norm_add t (b1 * Tint (-(1)) + Tint (-(1)))%term) :: l) else l :: nil | _ => l :: nil end. Theorem split_ineq_valid : forall (i t : nat) (f1 f2 : hyps -> lhyps), valid_list_hyps f1 -> valid_list_hyps f2 -> valid_list_hyps (split_ineq i t f1 f2). Proof. unfold valid_list_hyps, split_ineq; intros i t f1 f2 H1 H2 ep e lp H; generalize (nth_valid _ _ i _ H); case (nth_hyps i lp); simpl; auto; intros t1 t2; case t1; simpl; auto; intros z; simpl; auto; intro H3. Simplify. apply append_valid; elim (OMEGA19 (interp_term e t2)); [ intro H4; left; apply H1; simpl; elim (add_norm_stable t); simpl; auto | intro H4; right; apply H2; simpl; elim (scalar_norm_add_stable t); simpl; auto | generalize H3; unfold not; intros E1 E2; apply E1; symmetry ; trivial ]. Qed. (* \subsection{La fonction de rejeu de la trace} *) Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := match t with | O_CONSTANT_NOT_NUL n => singleton (constant_not_nul n l) | O_CONSTANT_NEG n => singleton (constant_neg n l) | O_DIV_APPROX k1 k2 body t cont n => execute_omega cont (apply_oper_1 n (divide_and_approx k1 k2 body t) l) | O_NOT_EXACT_DIVIDE k1 k2 body t i => singleton (not_exact_divide k1 k2 body t i l) | O_EXACT_DIVIDE k body t cont n => execute_omega cont (apply_oper_1 n (exact_divide k body t) l) | O_SUM k1 i1 k2 i2 t cont => execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2 t) l) | O_CONTRADICTION t i j => singleton (contradiction t i j l) | O_MERGE_EQ t i1 i2 cont => execute_omega cont (apply_oper_2 i1 i2 (merge_eq t) l) | O_SPLIT_INEQ t i cont1 cont2 => split_ineq i t (execute_omega cont1) (execute_omega cont2) l | O_CONSTANT_NUL i => singleton (constant_nul i l) | O_NEGATE_CONTRADICT i j => singleton (negate_contradict i j l) | O_NEGATE_CONTRADICT_INV t i j => singleton (negate_contradict_inv t i j l) | O_STATE m s i1 i2 cont => execute_omega cont (apply_oper_2 i1 i2 (state m s) l) end. Theorem omega_valid : forall tr : t_omega, valid_list_hyps (execute_omega tr). Proof. simple induction tr; simpl; [ unfold valid_list_hyps; simpl; intros; left; apply (constant_not_nul_valid n ep e lp H) | unfold valid_list_hyps; simpl; intros; left; apply (constant_neg_valid n ep e lp H) | unfold valid_list_hyps, valid_hyps; intros k1 k2 body n t' Ht' m ep e lp H; apply Ht'; apply (apply_oper_1_valid m (divide_and_approx k1 k2 body n) (divide_and_approx_valid k1 k2 body n) ep e lp H) | unfold valid_list_hyps; simpl; intros; left; apply (not_exact_divide_valid _ _ _ _ _ ep e lp H) | unfold valid_list_hyps, valid_hyps; intros k body n t' Ht' m ep e lp H; apply Ht'; apply (apply_oper_1_valid m (exact_divide k body n) (exact_divide_valid k body n) ep e lp H) | unfold valid_list_hyps, valid_hyps; intros k1 i1 k2 i2 trace t' Ht' ep e lp H; apply Ht'; apply (apply_oper_2_valid i1 i2 (sum k1 k2 trace) (sum_valid k1 k2 trace) ep e lp H) | unfold valid_list_hyps; simpl; intros; left; apply (contradiction_valid n n0 n1 ep e lp H) | unfold valid_list_hyps, valid_hyps; intros trace i1 i2 t' Ht' ep e lp H; apply Ht'; apply (apply_oper_2_valid i1 i2 (merge_eq trace) (merge_eq_valid trace) ep e lp H) | intros t' i k1 H1 k2 H2; unfold valid_list_hyps; simpl; intros ep e lp H; apply (split_ineq_valid i t' (execute_omega k1) (execute_omega k2) H1 H2 ep e lp H) | unfold valid_list_hyps; simpl; intros i ep e lp H; left; apply (constant_nul_valid i ep e lp H) | unfold valid_list_hyps; simpl; intros i j ep e lp H; left; apply (negate_contradict_valid i j ep e lp H) | unfold valid_list_hyps; simpl; intros n i j ep e lp H; left; apply (negate_contradict_inv_valid n i j ep e lp H) | unfold valid_list_hyps, valid_hyps; intros m s i1 i2 t' Ht' ep e lp H; apply Ht'; apply (apply_oper_2_valid i1 i2 (state m s) (state_valid m s) ep e lp H) ]. Qed. (* \subsection{Les opÃĐrations globales sur le but} \subsubsection{Normalisation} *) Definition move_right (s : step) (p : proposition) := match p with | EqTerm t1 t2 => EqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term) | LeqTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t2 + - t1)%term) | GeqTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term) | LtTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t2 + Tint (-(1)) + - t1)%term) | GtTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t1 + Tint (-(1)) + - t2)%term) | NeqTerm t1 t2 => NeqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term) | p => p end. Theorem move_right_valid : forall s : step, valid1 (move_right s). Proof. unfold valid1, move_right; intros s ep e p; Simplify; simpl; elim (t_rewrite_stable s e); simpl; [ symmetry ; apply egal_left; assumption | intro; apply le_left; assumption | intro; apply le_left; rewrite <- ge_le_iff; assumption | intro; apply lt_left; rewrite <- gt_lt_iff; assumption | intro; apply lt_left; assumption | intro; apply ne_left_2; assumption ]. Qed. Definition do_normalize (i : nat) (s : step) := apply_oper_1 i (move_right s). Theorem do_normalize_valid : forall (i : nat) (s : step), valid_hyps (do_normalize i s). Proof. intros; unfold do_normalize; apply apply_oper_1_valid; apply move_right_valid. Qed. Fixpoint do_normalize_list (l : list step) (i : nat) (h : hyps) {struct l} : hyps := match l with | s :: l' => do_normalize_list l' (S i) (do_normalize i s h) | nil => h end. Theorem do_normalize_list_valid : forall (l : list step) (i : nat), valid_hyps (do_normalize_list l i). Proof. simple induction l; simpl; unfold valid_hyps; [ auto | intros a l' Hl' i ep e lp H; unfold valid_hyps in Hl'; apply Hl'; apply (do_normalize_valid i a ep e lp); assumption ]. Qed. Theorem normalize_goal : forall (s : list step) (ep : list Prop) (env : list int) (l : hyps), interp_goal ep env (do_normalize_list s 0 l) -> interp_goal ep env l. Proof. intros; apply valid_goal with (2 := H); apply do_normalize_list_valid. Qed. (* \subsubsection{ExÃĐcution de la trace} *) Theorem execute_goal : forall (tr : t_omega) (ep : list Prop) (env : list int) (l : hyps), interp_list_goal ep env (execute_omega tr l) -> interp_goal ep env l. Proof. intros; apply (goal_valid (execute_omega tr) (omega_valid tr) ep env l H). Qed. Theorem append_goal : forall (ep : list Prop) (e : list int) (l1 l2 : lhyps), interp_list_goal ep e l1 /\ interp_list_goal ep e l2 -> interp_list_goal ep e (l1 ++ l2). Proof. intros ep e; simple induction l1; [ simpl; intros l2 (H1, H2); assumption | simpl; intros h1 t1 HR l2 ((H1, H2), H3); split; auto ]. Qed. (* A simple decidability checker : if the proposition belongs to the simple grammar describe below then it is decidable. Proof is by induction and uses well known theorem about arithmetic and propositional calculus *) Fixpoint decidability (p : proposition) : bool := match p with | EqTerm _ _ => true | LeqTerm _ _ => true | GeqTerm _ _ => true | GtTerm _ _ => true | LtTerm _ _ => true | NeqTerm _ _ => true | FalseTerm => true | TrueTerm => true | Tnot t => decidability t | Tand t1 t2 => decidability t1 && decidability t2 | Timp t1 t2 => decidability t1 && decidability t2 | Tor t1 t2 => decidability t1 && decidability t2 | Tprop _ => false end. Theorem decidable_correct : forall (ep : list Prop) (e : list int) (p : proposition), decidability p = true -> decidable (interp_proposition ep e p). Proof. simple induction p; simpl; intros; [ apply dec_eq | apply dec_le | left; auto | right; unfold not; auto | apply dec_not; auto | apply dec_ge | apply dec_gt | apply dec_lt | apply dec_ne | apply dec_or; elim andb_prop with (1 := H1); auto | apply dec_and; elim andb_prop with (1 := H1); auto | apply dec_imp; elim andb_prop with (1 := H1); auto | discriminate H ]. Qed. (* An interpretation function for a complete goal with an explicit conclusion. We use an intermediate fixpoint. *) Fixpoint interp_full_goal (envp : list Prop) (env : list int) (c : proposition) (l : hyps) {struct l} : Prop := match l with | nil => interp_proposition envp env c | p' :: l' => interp_proposition envp env p' -> interp_full_goal envp env c l' end. Definition interp_full (ep : list Prop) (e : list int) (lc : hyps * proposition) : Prop := match lc with | (l, c) => interp_full_goal ep e c l end. (* Relates the interpretation of a complete goal with the interpretation of its hypothesis and conclusion *) Theorem interp_full_false : forall (ep : list Prop) (e : list int) (l : hyps) (c : proposition), (interp_hyps ep e l -> interp_proposition ep e c) -> interp_full ep e (l, c). Proof. simple induction l; unfold interp_full; simpl; [ auto | intros a l1 H1 c H2 H3; apply H1; auto ]. Qed. (* Push the conclusion in the list of hypothesis using a double negation If the decidability cannot be "proven", then just forget about the conclusion (equivalent of replacing it with false) *) Definition to_contradict (lc : hyps * proposition) := match lc with | (l, c) => if decidability c then Tnot c :: l else l end. (* The previous operation is valid in the sense that the new list of hypothesis implies the original goal *) Theorem to_contradict_valid : forall (ep : list Prop) (e : list int) (lc : hyps * proposition), interp_goal ep e (to_contradict lc) -> interp_full ep e lc. Proof. intros ep e lc; case lc; intros l c; simpl; pattern (decidability c); apply bool_eq_ind; [ simpl; intros H H1; apply interp_full_false; intros H2; apply not_not; [ apply decidable_correct; assumption | unfold not at 1; intro H3; apply hyps_to_goal with (2 := H2); auto ] | intros H1 H2; apply interp_full_false; intro H3; elim hyps_to_goal with (1 := H2); assumption ]. Qed. (* [map_cons x l] adds [x] at the head of each list in [l] (which is a list of lists *) Fixpoint map_cons (A : Set) (x : A) (l : list (list A)) {struct l} : list (list A) := match l with | nil => nil | l :: ll => (x :: l) :: map_cons A x ll end. (* This function breaks up a list of hypothesis in a list of simpler list of hypothesis that together implie the original one. The goal of all this is to transform the goal in a list of solvable problems. Note that : - we need a way to drive the analysis as some hypotheis may not require a split. - this procedure must be perfectly mimicked by the ML part otherwise hypothesis will get desynchronised and this will be a mess. *) Fixpoint destructure_hyps (nn : nat) (ll : hyps) {struct nn} : lhyps := match nn with | O => ll :: nil | S n => match ll with | nil => nil :: nil | Tor p1 p2 :: l => destructure_hyps n (p1 :: l) ++ destructure_hyps n (p2 :: l) | Tand p1 p2 :: l => destructure_hyps n (p1 :: p2 :: l) | Timp p1 p2 :: l => if decidability p1 then destructure_hyps n (Tnot p1 :: l) ++ destructure_hyps n (p2 :: l) else map_cons _ (Timp p1 p2) (destructure_hyps n l) | Tnot p :: l => match p with | Tnot p1 => if decidability p1 then destructure_hyps n (p1 :: l) else map_cons _ (Tnot (Tnot p1)) (destructure_hyps n l) | Tor p1 p2 => destructure_hyps n (Tnot p1 :: Tnot p2 :: l) | Tand p1 p2 => if decidability p1 then destructure_hyps n (Tnot p1 :: l) ++ destructure_hyps n (Tnot p2 :: l) else map_cons _ (Tnot p) (destructure_hyps n l) | _ => map_cons _ (Tnot p) (destructure_hyps n l) end | x :: l => map_cons _ x (destructure_hyps n l) end end. Theorem map_cons_val : forall (ep : list Prop) (e : list int) (p : proposition) (l : lhyps), interp_proposition ep e p -> interp_list_hyps ep e l -> interp_list_hyps ep e (map_cons _ p l). Proof. simple induction l; simpl; [ auto | intros; elim H1; intro H2; auto ]. Qed. Hint Resolve map_cons_val append_valid decidable_correct. Theorem destructure_hyps_valid : forall n : nat, valid_list_hyps (destructure_hyps n). Proof. simple induction n; [ unfold valid_list_hyps; simpl; auto | unfold valid_list_hyps at 2; intros n1 H ep e lp; case lp; [ simpl; auto | intros p l; case p; try (simpl; intros; apply map_cons_val; simpl; elim H0; auto); [ intro p'; case p'; try (simpl; intros; apply map_cons_val; simpl; elim H0; auto); [ simpl; intros p1 (H1, H2); pattern (decidability p1); apply bool_eq_ind; intro H3; [ apply H; simpl; split; [ apply not_not; auto | assumption ] | auto ] | simpl; intros p1 p2 (H1, H2); apply H; simpl; elim not_or with (1 := H1); auto | simpl; intros p1 p2 (H1, H2); pattern (decidability p1); apply bool_eq_ind; intro H3; [ apply append_valid; elim not_and with (2 := H1); [ intro; left; apply H; simpl; auto | intro; right; apply H; simpl; auto | auto ] | auto ] ] | simpl; intros p1 p2 (H1, H2); apply append_valid; (elim H1; intro H3; simpl; [ left | right ]); apply H; simpl; auto | simpl; intros; apply H; simpl; tauto | simpl; intros p1 p2 (H1, H2); pattern (decidability p1); apply bool_eq_ind; intro H3; [ apply append_valid; elim imp_simp with (2 := H1); [ intro H4; left; simpl; apply H; simpl; auto | intro H4; right; simpl; apply H; simpl; auto | auto ] | auto ] ] ] ]. Qed. Definition prop_stable (f : proposition -> proposition) := forall (ep : list Prop) (e : list int) (p : proposition), interp_proposition ep e p <-> interp_proposition ep e (f p). Definition p_apply_left (f : proposition -> proposition) (p : proposition) := match p with | Timp x y => Timp (f x) y | Tor x y => Tor (f x) y | Tand x y => Tand (f x) y | Tnot x => Tnot (f x) | x => x end. Theorem p_apply_left_stable : forall f : proposition -> proposition, prop_stable f -> prop_stable (p_apply_left f). Proof. unfold prop_stable; intros f H ep e p; split; (case p; simpl; auto; intros p1; elim (H ep e p1); tauto). Qed. Definition p_apply_right (f : proposition -> proposition) (p : proposition) := match p with | Timp x y => Timp x (f y) | Tor x y => Tor x (f y) | Tand x y => Tand x (f y) | Tnot x => Tnot (f x) | x => x end. Theorem p_apply_right_stable : forall f : proposition -> proposition, prop_stable f -> prop_stable (p_apply_right f). Proof. unfold prop_stable; intros f H ep e p; split; (case p; simpl; auto; [ intros p1; elim (H ep e p1); tauto | intros p1 p2; elim (H ep e p2); tauto | intros p1 p2; elim (H ep e p2); tauto | intros p1 p2; elim (H ep e p2); tauto ]). Qed. Definition p_invert (f : proposition -> proposition) (p : proposition) := match p with | EqTerm x y => Tnot (f (NeqTerm x y)) | LeqTerm x y => Tnot (f (GtTerm x y)) | GeqTerm x y => Tnot (f (LtTerm x y)) | GtTerm x y => Tnot (f (LeqTerm x y)) | LtTerm x y => Tnot (f (GeqTerm x y)) | NeqTerm x y => Tnot (f (EqTerm x y)) | x => x end. Theorem p_invert_stable : forall f : proposition -> proposition, prop_stable f -> prop_stable (p_invert f). Proof. unfold prop_stable; intros f H ep e p; split; (case p; simpl; auto; [ intros t1 t2; elim (H ep e (NeqTerm t1 t2)); simpl; generalize (dec_eq (interp_term e t1) (interp_term e t2)); unfold decidable; tauto | intros t1 t2; elim (H ep e (GtTerm t1 t2)); simpl; generalize (dec_gt (interp_term e t1) (interp_term e t2)); unfold decidable; rewrite le_lt_iff, <- gt_lt_iff; tauto | intros t1 t2; elim (H ep e (LtTerm t1 t2)); simpl; generalize (dec_lt (interp_term e t1) (interp_term e t2)); unfold decidable; rewrite ge_le_iff, le_lt_iff; tauto | intros t1 t2; elim (H ep e (LeqTerm t1 t2)); simpl; generalize (dec_gt (interp_term e t1) (interp_term e t2)); unfold decidable; repeat rewrite le_lt_iff; repeat rewrite gt_lt_iff; tauto | intros t1 t2; elim (H ep e (GeqTerm t1 t2)); simpl; generalize (dec_lt (interp_term e t1) (interp_term e t2)); unfold decidable; repeat rewrite ge_le_iff; repeat rewrite le_lt_iff; tauto | intros t1 t2; elim (H ep e (EqTerm t1 t2)); simpl; generalize (dec_eq (interp_term e t1) (interp_term e t2)); unfold decidable; tauto ]). Qed. Theorem move_right_stable : forall s : step, prop_stable (move_right s). Proof. unfold move_right, prop_stable; intros s ep e p; split; [ Simplify; simpl; elim (t_rewrite_stable s e); simpl; [ symmetry ; apply egal_left; assumption | intro; apply le_left; assumption | intro; apply le_left; rewrite <- ge_le_iff; assumption | intro; apply lt_left; rewrite <- gt_lt_iff; assumption | intro; apply lt_left; assumption | intro; apply ne_left_2; assumption ] | case p; simpl; intros; auto; generalize H; elim (t_rewrite_stable s); simpl; intro H1; [ rewrite (plus_0_r_reverse (interp_term e t1)); rewrite H1; rewrite plus_permute; rewrite plus_opp_r; rewrite plus_0_r; trivial | apply (fun a b => plus_le_reg_r a b (- interp_term e t0)); rewrite plus_opp_r; assumption | rewrite ge_le_iff; apply (fun a b => plus_le_reg_r a b (- interp_term e t1)); rewrite plus_opp_r; assumption | rewrite gt_lt_iff; apply lt_left_inv; assumption | apply lt_left_inv; assumption | unfold not; intro H2; apply H1; rewrite H2; rewrite plus_opp_r; trivial ] ]. Qed. Fixpoint p_rewrite (s : p_step) : proposition -> proposition := match s with | P_LEFT s => p_apply_left (p_rewrite s) | P_RIGHT s => p_apply_right (p_rewrite s) | P_STEP s => move_right s | P_INVERT s => p_invert (move_right s) | P_NOP => fun p : proposition => p end. Theorem p_rewrite_stable : forall s : p_step, prop_stable (p_rewrite s). Proof. simple induction s; simpl; [ intros; apply p_apply_left_stable; trivial | intros; apply p_apply_right_stable; trivial | intros; apply p_invert_stable; apply move_right_stable | apply move_right_stable | unfold prop_stable; simpl; intros; split; auto ]. Qed. Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps := match l with | nil => lh | pair_step i s :: r => normalize_hyps r (apply_oper_1 i (p_rewrite s) lh) end. Theorem normalize_hyps_valid : forall l : list h_step, valid_hyps (normalize_hyps l). Proof. simple induction l; unfold valid_hyps; simpl; [ auto | intros n_s r; case n_s; intros n s H ep e lp H1; apply H; apply apply_oper_1_valid; [ unfold valid1; intros ep1 e1 p1 H2; elim (p_rewrite_stable s ep1 e1 p1); auto | assumption ] ]. Qed. Theorem normalize_hyps_goal : forall (s : list h_step) (ep : list Prop) (env : list int) (l : hyps), interp_goal ep env (normalize_hyps s l) -> interp_goal ep env l. Proof. intros; apply valid_goal with (2 := H); apply normalize_hyps_valid. Qed. Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} : proposition := match s with | D_left :: l => match p with | Tand x y => extract_hyp_pos l x | _ => p end | D_right :: l => match p with | Tand x y => extract_hyp_pos l y | _ => p end | D_mono :: l => match p with | Tnot x => extract_hyp_neg l x | _ => p end | _ => p end with extract_hyp_neg (s : list direction) (p : proposition) {struct s} : proposition := match s with | D_left :: l => match p with | Tor x y => extract_hyp_neg l x | Timp x y => if decidability x then extract_hyp_pos l x else Tnot p | _ => Tnot p end | D_right :: l => match p with | Tor x y => extract_hyp_neg l y | Timp x y => extract_hyp_neg l y | _ => Tnot p end | D_mono :: l => match p with | Tnot x => if decidability x then extract_hyp_pos l x else Tnot p | _ => Tnot p end | _ => match p with | Tnot x => if decidability x then x else Tnot p | _ => Tnot p end end. Definition co_valid1 (f : proposition -> proposition) := forall (ep : list Prop) (e : list int) (p1 : proposition), interp_proposition ep e (Tnot p1) -> interp_proposition ep e (f p1). Theorem extract_valid : forall s : list direction, valid1 (extract_hyp_pos s) /\ co_valid1 (extract_hyp_neg s). Proof. unfold valid1, co_valid1; simple induction s; [ split; [ simpl; auto | intros ep e p1; case p1; simpl; auto; intro p; pattern (decidability p); apply bool_eq_ind; [ intro H; generalize (decidable_correct ep e p H); unfold decidable; tauto | simpl; auto ] ] | intros a s' (H1, H2); simpl in H2; split; intros ep e p; case a; auto; case p; auto; simpl; intros; (apply H1; tauto) || (apply H2; tauto) || (pattern (decidability p0); apply bool_eq_ind; [ intro H3; generalize (decidable_correct ep e p0 H3); unfold decidable; intro H4; apply H1; tauto | intro; tauto ]) ]. Qed. Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps := match s with | E_SPLIT i dl s1 s2 => match extract_hyp_pos dl (nth_hyps i h) with | Tor x y => decompose_solve s1 (x :: h) ++ decompose_solve s2 (y :: h) | Tnot (Tand x y) => if decidability x then decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (Tnot y :: h) else h :: nil | Timp x y => if decidability x then decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (y :: h) else h::nil | _ => h :: nil end | E_EXTRACT i dl s1 => decompose_solve s1 (extract_hyp_pos dl (nth_hyps i h) :: h) | E_SOLVE t => execute_omega t h end. Theorem decompose_solve_valid : forall s : e_step, valid_list_goal (decompose_solve s). Proof. intro s; apply goal_valid; unfold valid_list_hyps; elim s; simpl; intros; [ cut (interp_proposition ep e1 (extract_hyp_pos l (nth_hyps n lp))); [ case (extract_hyp_pos l (nth_hyps n lp)); simpl; auto; [ intro p; case p; simpl; auto; intros p1 p2 H2; pattern (decidability p1); apply bool_eq_ind; [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4; apply append_valid; elim H4; intro H5; [ right; apply H0; simpl; tauto | left; apply H; simpl; tauto ] | simpl; auto ] | intros p1 p2 H2; apply append_valid; simpl; elim H2; [ intros H3; left; apply H; simpl; auto | intros H3; right; apply H0; simpl; auto ] | intros p1 p2 H2; pattern (decidability p1); apply bool_eq_ind; [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4; apply append_valid; elim H4; intro H5; [ right; apply H0; simpl; tauto | left; apply H; simpl; tauto ] | simpl; auto ] ] | elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto ] | intros; apply H; simpl; split; [ elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto | auto ] | apply omega_valid with (1 := H) ]. Qed. (* \subsection{La derniÃĻre ÃĐtape qui ÃĐlimine tous les sÃĐquents inutiles} *) Definition valid_lhyps (f : lhyps -> lhyps) := forall (ep : list Prop) (e : list int) (lp : lhyps), interp_list_hyps ep e lp -> interp_list_hyps ep e (f lp). Fixpoint reduce_lhyps (lp : lhyps) : lhyps := match lp with | (FalseTerm :: nil) :: lp' => reduce_lhyps lp' | x :: lp' => x :: reduce_lhyps lp' | nil => nil (A:=hyps) end. Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps. Proof. unfold valid_lhyps; intros ep e lp; elim lp; [ simpl; auto | intros a l HR; elim a; [ simpl; tauto | intros a1 l1; case l1; case a1; simpl; try tauto ] ]. Qed. Theorem do_reduce_lhyps : forall (envp : list Prop) (env : list int) (l : lhyps), interp_list_goal envp env (reduce_lhyps l) -> interp_list_goal envp env l. Proof. intros envp env l H; apply list_goal_to_hyps; intro H1; apply list_hyps_to_goal with (1 := H); apply reduce_lhyps_valid; assumption. Qed. Definition concl_to_hyp (p : proposition) := if decidability p then Tnot p else TrueTerm. Definition do_concl_to_hyp : forall (envp : list Prop) (env : list int) (c : proposition) (l : hyps), interp_goal envp env (concl_to_hyp c :: l) -> interp_goal_concl c envp env l. Proof. simpl; intros envp env c l; induction l as [| a l Hrecl]; [ simpl; unfold concl_to_hyp; pattern (decidability c); apply bool_eq_ind; [ intro H; generalize (decidable_correct envp env c H); unfold decidable; simpl; tauto | simpl; intros H1 H2; elim H2; trivial ] | simpl; tauto ]. Qed. Definition omega_tactic (t1 : e_step) (t2 : list h_step) (c : proposition) (l : hyps) := reduce_lhyps (decompose_solve t1 (normalize_hyps t2 (concl_to_hyp c :: l))). Theorem do_omega : forall (t1 : e_step) (t2 : list h_step) (envp : list Prop) (env : list int) (c : proposition) (l : hyps), interp_list_goal envp env (omega_tactic t1 t2 c l) -> interp_goal_concl c envp env l. Proof. unfold omega_tactic; intros; apply do_concl_to_hyp; apply (normalize_hyps_goal t2); apply (decompose_solve_valid t1); apply do_reduce_lhyps; assumption. Qed. End IntOmega. (* For now, the above modular construction is instanciated on Z, in order to retrieve the initial ROmega. *) Module ZOmega := IntOmega(Z_as_Int). coq-8.4pl4/plugins/romega/const_omega.mli0000644000175000017500000001341212326224777017570 0ustar stephsteph(************************************************************************* PROJET RNRT Calife - 2001 Author: Pierre Crégut - France Télécom R&D Licence : LGPL version 2.1 *************************************************************************) (** Coq objects used in romega *) (* from Logic *) val coq_refl_equal : Term.constr lazy_t val coq_and : Term.constr lazy_t val coq_not : Term.constr lazy_t val coq_or : Term.constr lazy_t val coq_True : Term.constr lazy_t val coq_False : Term.constr lazy_t val coq_I : Term.constr lazy_t (* from ReflOmegaCore/ZOmega *) val coq_h_step : Term.constr lazy_t val coq_pair_step : Term.constr lazy_t val coq_p_left : Term.constr lazy_t val coq_p_right : Term.constr lazy_t val coq_p_invert : Term.constr lazy_t val coq_p_step : Term.constr lazy_t val coq_t_int : Term.constr lazy_t val coq_t_plus : Term.constr lazy_t val coq_t_mult : Term.constr lazy_t val coq_t_opp : Term.constr lazy_t val coq_t_minus : Term.constr lazy_t val coq_t_var : Term.constr lazy_t val coq_proposition : Term.constr lazy_t val coq_p_eq : Term.constr lazy_t val coq_p_leq : Term.constr lazy_t val coq_p_geq : Term.constr lazy_t val coq_p_lt : Term.constr lazy_t val coq_p_gt : Term.constr lazy_t val coq_p_neq : Term.constr lazy_t val coq_p_true : Term.constr lazy_t val coq_p_false : Term.constr lazy_t val coq_p_not : Term.constr lazy_t val coq_p_or : Term.constr lazy_t val coq_p_and : Term.constr lazy_t val coq_p_imp : Term.constr lazy_t val coq_p_prop : Term.constr lazy_t val coq_f_equal : Term.constr lazy_t val coq_f_cancel : Term.constr lazy_t val coq_f_left : Term.constr lazy_t val coq_f_right : Term.constr lazy_t val coq_c_do_both : Term.constr lazy_t val coq_c_do_left : Term.constr lazy_t val coq_c_do_right : Term.constr lazy_t val coq_c_do_seq : Term.constr lazy_t val coq_c_nop : Term.constr lazy_t val coq_c_opp_plus : Term.constr lazy_t val coq_c_opp_opp : Term.constr lazy_t val coq_c_opp_mult_r : Term.constr lazy_t val coq_c_opp_one : Term.constr lazy_t val coq_c_reduce : Term.constr lazy_t val coq_c_mult_plus_distr : Term.constr lazy_t val coq_c_opp_left : Term.constr lazy_t val coq_c_mult_assoc_r : Term.constr lazy_t val coq_c_plus_assoc_r : Term.constr lazy_t val coq_c_plus_assoc_l : Term.constr lazy_t val coq_c_plus_permute : Term.constr lazy_t val coq_c_plus_comm : Term.constr lazy_t val coq_c_red0 : Term.constr lazy_t val coq_c_red1 : Term.constr lazy_t val coq_c_red2 : Term.constr lazy_t val coq_c_red3 : Term.constr lazy_t val coq_c_red4 : Term.constr lazy_t val coq_c_red5 : Term.constr lazy_t val coq_c_red6 : Term.constr lazy_t val coq_c_mult_opp_left : Term.constr lazy_t val coq_c_mult_assoc_reduced : Term.constr lazy_t val coq_c_minus : Term.constr lazy_t val coq_c_mult_comm : Term.constr lazy_t val coq_s_constant_not_nul : Term.constr lazy_t val coq_s_constant_neg : Term.constr lazy_t val coq_s_div_approx : Term.constr lazy_t val coq_s_not_exact_divide : Term.constr lazy_t val coq_s_exact_divide : Term.constr lazy_t val coq_s_sum : Term.constr lazy_t val coq_s_state : Term.constr lazy_t val coq_s_contradiction : Term.constr lazy_t val coq_s_merge_eq : Term.constr lazy_t val coq_s_split_ineq : Term.constr lazy_t val coq_s_constant_nul : Term.constr lazy_t val coq_s_negate_contradict : Term.constr lazy_t val coq_s_negate_contradict_inv : Term.constr lazy_t val coq_direction : Term.constr lazy_t val coq_d_left : Term.constr lazy_t val coq_d_right : Term.constr lazy_t val coq_d_mono : Term.constr lazy_t val coq_e_split : Term.constr lazy_t val coq_e_extract : Term.constr lazy_t val coq_e_solve : Term.constr lazy_t val coq_interp_sequent : Term.constr lazy_t val coq_do_omega : Term.constr lazy_t (** Building expressions *) val do_left : Term.constr -> Term.constr val do_right : Term.constr -> Term.constr val do_both : Term.constr -> Term.constr -> Term.constr val do_seq : Term.constr -> Term.constr -> Term.constr val do_list : Term.constr list -> Term.constr val mk_nat : int -> Term.constr val mk_list : Term.constr -> Term.constr list -> Term.constr val mk_plist : Term.types list -> Term.types val mk_shuffle_list : Term.constr list -> Term.constr (** Analyzing a coq term *) (* The generic result shape of the analysis of a term. One-level depth, except when a number is found *) type parse_term = Tplus of Term.constr * Term.constr | Tmult of Term.constr * Term.constr | Tminus of Term.constr * Term.constr | Topp of Term.constr | Tsucc of Term.constr | Tnum of Bigint.bigint | Tother (* The generic result shape of the analysis of a relation. One-level depth. *) type parse_rel = Req of Term.constr * Term.constr | Rne of Term.constr * Term.constr | Rlt of Term.constr * Term.constr | Rle of Term.constr * Term.constr | Rgt of Term.constr * Term.constr | Rge of Term.constr * Term.constr | Rtrue | Rfalse | Rnot of Term.constr | Ror of Term.constr * Term.constr | Rand of Term.constr * Term.constr | Rimp of Term.constr * Term.constr | Riff of Term.constr * Term.constr | Rother (* A module factorizing what we should now about the number representation *) module type Int = sig (* the coq type of the numbers *) val typ : Term.constr Lazy.t (* the operations on the numbers *) val plus : Term.constr Lazy.t val mult : Term.constr Lazy.t val opp : Term.constr Lazy.t val minus : Term.constr Lazy.t (* building a coq number *) val mk : Bigint.bigint -> Term.constr (* parsing a term (one level, except if a number is found) *) val parse_term : Term.constr -> parse_term (* parsing a relation expression, including = < <= >= > *) val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel (* Is a particular term only made of numbers and + * - ? *) val is_scalar : Term.constr -> bool end (* Currently, we only use Z numbers *) module Z : Int coq-8.4pl4/plugins/romega/ROmega.v0000644000175000017500000000065612326224777016136 0ustar stephsteph(************************************************************************* PROJET RNRT Calife - 2001 Author: Pierre CrÃĐgut - France TÃĐlÃĐcom R&D Licence : LGPL version 2.1 *************************************************************************) Require Import ReflOmegaCore. Require Export Setoid. Require Export PreOmega. Require Export ZArith_base. Require Import OmegaPlugin. Declare ML Module "romega_plugin".coq-8.4pl4/plugins/romega/refl_omega.ml0000644000175000017500000013574712326224777017241 0ustar stephsteph(************************************************************************* PROJET RNRT Calife - 2001 Author: Pierre Crégut - France Télécom R&D Licence : LGPL version 2.1 *************************************************************************) open Util open Const_omega module OmegaSolver = Omega.MakeOmegaSolver (Bigint) open OmegaSolver (* \section{Useful functions and flags} *) (* Especially useful debugging functions *) let debug = ref false let show_goal gl = if !debug then Pp.ppnl (Tacmach.pr_gls gl); Tacticals.tclIDTAC gl let pp i = print_int i; print_newline (); flush stdout (* More readable than the prefix notation *) let (>>) = Tacticals.tclTHEN let mkApp = Term.mkApp (* \section{Types} \subsection{How to walk in a term} To represent how to get to a proposition. Only choice points are kept (branch to choose in a disjunction and identifier of the disjunctive connector) *) type direction = Left of int | Right of int (* Step to find a proposition (operators are at most binary). A list is a path *) type occ_step = O_left | O_right | O_mono type occ_path = occ_step list (* chemin identifiant une proposition sous forme du nom de l'hypothčse et d'une liste de pas ā partir de la racine de l'hypothčse *) type occurence = {o_hyp : Names.identifier; o_path : occ_path} (* \subsection{refiable formulas} *) type oformula = (* integer *) | Oint of Bigint.bigint (* recognized binary and unary operations *) | Oplus of oformula * oformula | Omult of oformula * oformula | Ominus of oformula * oformula | Oopp of oformula (* an atome in the environment *) | Oatom of int (* weird expression that cannot be translated *) | Oufo of oformula (* Operators for comparison recognized by Omega *) type comparaison = Eq | Leq | Geq | Gt | Lt | Neq (* Type des prédicats réifiés (fragment de calcul propositionnel. Les * quantifications sont externes au langage) *) type oproposition = Pequa of Term.constr * oequation | Ptrue | Pfalse | Pnot of oproposition | Por of int * oproposition * oproposition | Pand of int * oproposition * oproposition | Pimp of int * oproposition * oproposition | Pprop of Term.constr (* Les équations ou proposiitions atomiques utiles du calcul *) and oequation = { e_comp: comparaison; (* comparaison *) e_left: oformula; (* formule brute gauche *) e_right: oformula; (* formule brute droite *) e_trace: Term.constr; (* tactique de normalisation *) e_origin: occurence; (* l'hypothčse dont vient le terme *) e_negated: bool; (* vrai si apparait en position nié aprčs normalisation *) e_depends: direction list; (* liste des points de disjonction dont dépend l'accčs ā l'équation avec la direction (branche) pour y accéder *) e_omega: afine (* la fonction normalisée *) } (* \subsection{Proof context} This environment codes \begin{itemize} \item the terms and propositions that are given as parameters of the reified proof (and are represented as variables in the reified goals) \item translation functions linking the decision procedure and the Coq proof \end{itemize} *) type environment = { (* La liste des termes non reifies constituant l'environnement global *) mutable terms : Term.constr list; (* La meme chose pour les propositions *) mutable props : Term.constr list; (* Les variables introduites par omega *) mutable om_vars : (oformula * int) list; (* Traduction des indices utilisés ici en les indices finaux utilisés par * la tactique Omega aprčs dénombrement des variables utiles *) real_indices : (int,int) Hashtbl.t; mutable cnt_connectors : int; equations : (int,oequation) Hashtbl.t; constructors : (int, occurence) Hashtbl.t } (* \subsection{Solution tree} Définition d'une solution trouvée par Omega sous la forme d'un identifiant, d'un ensemble d'équation dont dépend la solution et d'une trace *) (* La liste des dépendances est triée et sans redondance *) type solution = { s_index : int; s_equa_deps : int list; s_trace : action list } (* Arbre de solution résolvant complčtement un ensemble de systčmes *) type solution_tree = Leaf of solution (* un noeud interne représente un point de branchement correspondant ā l'élimination d'un connecteur générant plusieurs buts (typ. disjonction). Le premier argument est l'identifiant du connecteur *) | Tree of int * solution_tree * solution_tree (* Représentation de l'environnement extrait du but initial sous forme de chemins pour extraire des equations ou d'hypothčses *) type context_content = CCHyp of occurence | CCEqua of int (* \section{Specific utility functions to handle base types} *) (* Nom arbitraire de l'hypothčse codant la négation du but final *) let id_concl = Names.id_of_string "__goal__" (* Initialisation de l'environnement de réification de la tactique *) let new_environment () = { terms = []; props = []; om_vars = []; cnt_connectors = 0; real_indices = Hashtbl.create 7; equations = Hashtbl.create 7; constructors = Hashtbl.create 7; } (* Génération d'un nom d'équation *) let new_connector_id env = env.cnt_connectors <- succ env.cnt_connectors; env.cnt_connectors (* Calcul de la branche complémentaire *) let barre = function Left x -> Right x | Right x -> Left x (* Identifiant associé ā une branche *) let indice = function Left x | Right x -> x (* Affichage de l'environnement de réification (termes et propositions) *) let print_env_reification env = let rec loop c i = function [] -> Printf.printf " ===============================\n\n" | t :: l -> Printf.printf " (%c%02d) := " c i; Pp.ppnl (Printer.pr_lconstr t); Pp.flush_all (); loop c (succ i) l in print_newline (); Printf.printf " ENVIRONMENT OF PROPOSITIONS :\n\n"; loop 'P' 0 env.props; Printf.printf " ENVIRONMENT OF TERMS :\n\n"; loop 'V' 0 env.terms (* \subsection{Gestion des environnements de variable pour Omega} *) (* generation d'identifiant d'equation pour Omega *) let new_omega_eq, rst_omega_eq = let cpt = ref 0 in (function () -> incr cpt; !cpt), (function () -> cpt:=0) (* generation d'identifiant de variable pour Omega *) let new_omega_var, rst_omega_var = let cpt = ref 0 in (function () -> incr cpt; !cpt), (function () -> cpt:=0) (* Affichage des variables d'un systčme *) let display_omega_var i = Printf.sprintf "OV%d" i (* Recherche la variable codant un terme pour Omega et crée la variable dans l'environnement si il n'existe pas. Cas ou la variable dans Omega représente le terme d'un monome (le plus souvent un atome) *) let intern_omega env t = begin try List.assoc t env.om_vars with Not_found -> let v = new_omega_var () in env.om_vars <- (t,v) :: env.om_vars; v end (* Ajout forcé d'un lien entre un terme et une variable Cas oų la variable est créée par Omega et oų il faut la lier aprčs coup ā un atome réifié introduit de force *) let intern_omega_force env t v = env.om_vars <- (t,v) :: env.om_vars (* Récupčre le terme associé ā une variable *) let unintern_omega env id = let rec loop = function [] -> failwith "unintern" | ((t,j)::l) -> if id = j then t else loop l in loop env.om_vars (* \subsection{Gestion des environnements de variable pour la réflexion} Gestion des environnements de traduction entre termes des constructions non réifiés et variables des termes reifies. Attention il s'agit de l'environnement initial contenant tout. Il faudra le réduire aprčs calcul des variables utiles. *) let add_reified_atom t env = try list_index0_f Term.eq_constr t env.terms with Not_found -> let i = List.length env.terms in env.terms <- env.terms @ [t]; i let get_reified_atom env = try List.nth env.terms with e when Errors.noncritical e -> failwith "get_reified_atom" (* \subsection{Gestion de l'environnement de proposition pour Omega} *) (* ajout d'une proposition *) let add_prop env t = try list_index0_f Term.eq_constr t env.props with Not_found -> let i = List.length env.props in env.props <- env.props @ [t]; i (* accčs a une proposition *) let get_prop v env = try List.nth v env with e when Errors.noncritical e -> failwith "get_prop" (* \subsection{Gestion du nommage des équations} *) (* Ajout d'une equation dans l'environnement de reification *) let add_equation env e = let id = e.e_omega.id in try let _ = Hashtbl.find env.equations id in () with Not_found -> Hashtbl.add env.equations id e (* accčs a une equation *) let get_equation env id = try Hashtbl.find env.equations id with Not_found as e -> Printf.printf "Omega Equation %d non trouvée\n" id; raise e (* Affichage des termes réifiés *) let rec oprint ch = function | Oint n -> Printf.fprintf ch "%s" (Bigint.to_string n) | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2 | Omult (t1,t2) -> Printf.fprintf ch "(%a * %a)" oprint t1 oprint t2 | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2 | Oopp t1 ->Printf.fprintf ch "~ %a" oprint t1 | Oatom n -> Printf.fprintf ch "V%02d" n | Oufo x -> Printf.fprintf ch "?" let rec pprint ch = function Pequa (_,{ e_comp=comp; e_left=t1; e_right=t2 }) -> let connector = match comp with Eq -> "=" | Leq -> "<=" | Geq -> ">=" | Gt -> ">" | Lt -> "<" | Neq -> "!=" in Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2 | Ptrue -> Printf.fprintf ch "TT" | Pfalse -> Printf.fprintf ch "FF" | Pnot t -> Printf.fprintf ch "not(%a)" pprint t | Por (_,t1,t2) -> Printf.fprintf ch "(%a or %a)" pprint t1 pprint t2 | Pand(_,t1,t2) -> Printf.fprintf ch "(%a and %a)" pprint t1 pprint t2 | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2 | Pprop c -> Printf.fprintf ch "Prop" let rec weight env = function | Oint _ -> -1 | Oopp c -> weight env c | Omult(c,_) -> weight env c | Oplus _ -> failwith "weight" | Ominus _ -> failwith "weight minus" | Oufo _ -> -1 | Oatom _ as c -> (intern_omega env c) (* \section{Passage entre oformules et représentation interne de Omega} *) (* \subsection{Oformula vers Omega} *) let omega_of_oformula env kind = let rec loop accu = function | Oplus(Omult(v,Oint n),r) -> loop ({v=intern_omega env v; c=n} :: accu) r | Oint n -> let id = new_omega_eq () in (*i tag_equation name id; i*) {kind = kind; body = List.rev accu; constant = n; id = id} | t -> print_string "CO"; oprint stdout t; failwith "compile_equation" in loop [] (* \subsection{Omega vers Oformula} *) let rec oformula_of_omega env af = let rec loop = function | ({v=v; c=n}::r) -> Oplus(Omult(unintern_omega env v,Oint n),loop r) | [] -> Oint af.constant in loop af.body let app f v = mkApp(Lazy.force f,v) (* \subsection{Oformula vers COQ reel} *) let rec coq_of_formula env t = let rec loop = function | Oplus (t1,t2) -> app Z.plus [| loop t1; loop t2 |] | Oopp t -> app Z.opp [| loop t |] | Omult(t1,t2) -> app Z.mult [| loop t1; loop t2 |] | Oint v -> Z.mk v | Oufo t -> loop t | Oatom var -> (* attention ne traite pas les nouvelles variables si on ne les * met pas dans env.term *) get_reified_atom env var | Ominus(t1,t2) -> app Z.minus [| loop t1; loop t2 |] in loop t (* \subsection{Oformula vers COQ reifié} *) let reified_of_atom env i = try Hashtbl.find env.real_indices i with Not_found -> Printf.printf "Atome %d non trouvé\n" i; Hashtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices; raise Not_found let rec reified_of_formula env = function | Oplus (t1,t2) -> app coq_t_plus [| reified_of_formula env t1; reified_of_formula env t2 |] | Oopp t -> app coq_t_opp [| reified_of_formula env t |] | Omult(t1,t2) -> app coq_t_mult [| reified_of_formula env t1; reified_of_formula env t2 |] | Oint v -> app coq_t_int [| Z.mk v |] | Oufo t -> reified_of_formula env t | Oatom i -> app coq_t_var [| mk_nat (reified_of_atom env i) |] | Ominus(t1,t2) -> app coq_t_minus [| reified_of_formula env t1; reified_of_formula env t2 |] let reified_of_formula env f = try reified_of_formula env f with reraise -> oprint stderr f; raise reraise let rec reified_of_proposition env = function Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) -> app coq_p_eq [| reified_of_formula env t1; reified_of_formula env t2 |] | Pequa (_,{ e_comp=Leq; e_left=t1; e_right=t2 }) -> app coq_p_leq [| reified_of_formula env t1; reified_of_formula env t2 |] | Pequa(_,{ e_comp=Geq; e_left=t1; e_right=t2 }) -> app coq_p_geq [| reified_of_formula env t1; reified_of_formula env t2 |] | Pequa(_,{ e_comp=Gt; e_left=t1; e_right=t2 }) -> app coq_p_gt [| reified_of_formula env t1; reified_of_formula env t2 |] | Pequa(_,{ e_comp=Lt; e_left=t1; e_right=t2 }) -> app coq_p_lt [| reified_of_formula env t1; reified_of_formula env t2 |] | Pequa(_,{ e_comp=Neq; e_left=t1; e_right=t2 }) -> app coq_p_neq [| reified_of_formula env t1; reified_of_formula env t2 |] | Ptrue -> Lazy.force coq_p_true | Pfalse -> Lazy.force coq_p_false | Pnot t -> app coq_p_not [| reified_of_proposition env t |] | Por (_,t1,t2) -> app coq_p_or [| reified_of_proposition env t1; reified_of_proposition env t2 |] | Pand(_,t1,t2) -> app coq_p_and [| reified_of_proposition env t1; reified_of_proposition env t2 |] | Pimp(_,t1,t2) -> app coq_p_imp [| reified_of_proposition env t1; reified_of_proposition env t2 |] | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |] let reified_of_proposition env f = try reified_of_proposition env f with reraise -> pprint stderr f; raise reraise (* \subsection{Omega vers COQ réifié} *) let reified_of_omega env body constant = let coeff_constant = app coq_t_int [| Z.mk constant |] in let mk_coeff {c=c; v=v} t = let coef = app coq_t_mult [| reified_of_formula env (unintern_omega env v); app coq_t_int [| Z.mk c |] |] in app coq_t_plus [|coef; t |] in List.fold_right mk_coeff body coeff_constant let reified_of_omega env body c = try reified_of_omega env body c with reraise -> display_eq display_omega_var (body,c); raise reraise (* \section{Opérations sur les équations} Ces fonctions préparent les traces utilisées par la tactique réfléchie pour faire des opérations de normalisation sur les équations. *) (* \subsection{Extractions des variables d'une équation} *) (* Extraction des variables d'une équation. *) (* Chaque fonction retourne une liste triée sans redondance *) let (@@) = list_merge_uniq compare let rec vars_of_formula = function | Oint _ -> [] | Oplus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) | Omult (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) | Ominus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) | Oopp e -> vars_of_formula e | Oatom i -> [i] | Oufo _ -> [] let rec vars_of_equations = function | [] -> [] | e::l -> (vars_of_formula e.e_left) @@ (vars_of_formula e.e_right) @@ (vars_of_equations l) let rec vars_of_prop = function | Pequa(_,e) -> vars_of_equations [e] | Pnot p -> vars_of_prop p | Por(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) | Pand(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) | Pimp(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) | Pprop _ | Ptrue | Pfalse -> [] (* \subsection{Multiplication par un scalaire} *) let rec scalar n = function Oplus(t1,t2) -> let tac1,t1' = scalar n t1 and tac2,t2' = scalar n t2 in do_list [Lazy.force coq_c_mult_plus_distr; do_both tac1 tac2], Oplus(t1',t2') | Oopp t -> do_list [Lazy.force coq_c_mult_opp_left], Omult(t,Oint(Bigint.neg n)) | Omult(t1,Oint x) -> do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x)) | Omult(t1,t2) -> Util.error "Omega: Can't solve a goal with non-linear products" | (Oatom _ as t) -> do_list [], Omult(t,Oint n) | Oint i -> do_list [Lazy.force coq_c_reduce],Oint(n*i) | (Oufo _ as t)-> do_list [], Oufo (Omult(t,Oint n)) | Ominus _ -> failwith "scalar minus" (* \subsection{Propagation de l'inversion} *) let rec negate = function Oplus(t1,t2) -> let tac1,t1' = negate t1 and tac2,t2' = negate t2 in do_list [Lazy.force coq_c_opp_plus ; (do_both tac1 tac2)], Oplus(t1',t2') | Oopp t -> do_list [Lazy.force coq_c_opp_opp], t | Omult(t1,Oint x) -> do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (Bigint.neg x)) | Omult(t1,t2) -> Util.error "Omega: Can't solve a goal with non-linear products" | (Oatom _ as t) -> do_list [Lazy.force coq_c_opp_one], Omult(t,Oint(negone)) | Oint i -> do_list [Lazy.force coq_c_reduce] ,Oint(Bigint.neg i) | Oufo c -> do_list [], Oufo (Oopp c) | Ominus _ -> failwith "negate minus" let rec norm l = (List.length l) (* \subsection{Mélange (fusion) de deux équations} *) (* \subsubsection{Version avec coefficients} *) let rec shuffle_path k1 e1 k2 e2 = let rec loop = function (({c=c1;v=v1}::l1) as l1'), (({c=c2;v=v2}::l2) as l2') -> if v1 = v2 then if k1*c1 + k2 * c2 = zero then ( Lazy.force coq_f_cancel :: loop (l1,l2)) else ( Lazy.force coq_f_equal :: loop (l1,l2) ) else if v1 > v2 then ( Lazy.force coq_f_left :: loop(l1,l2')) else ( Lazy.force coq_f_right :: loop(l1',l2)) | ({c=c1;v=v1}::l1), [] -> Lazy.force coq_f_left :: loop(l1,[]) | [],({c=c2;v=v2}::l2) -> Lazy.force coq_f_right :: loop([],l2) | [],[] -> flush stdout; [] in mk_shuffle_list (loop (e1,e2)) (* \subsubsection{Version sans coefficients} *) let rec shuffle env (t1,t2) = match t1,t2 with Oplus(l1,r1), Oplus(l2,r2) -> if weight env l1 > weight env l2 then let l_action,t' = shuffle env (r1,t2) in do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action], Oplus(l1,t') else let l_action,t' = shuffle env (t1,r2) in do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') | Oplus(l1,r1), t2 -> if weight env l1 > weight env t2 then let (l_action,t') = shuffle env (r1,t2) in do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action],Oplus(l1, t') else do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1) | t1,Oplus(l2,r2) -> if weight env l2 > weight env t1 then let (l_action,t') = shuffle env (t1,r2) in do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') else do_list [],Oplus(t1,t2) | Oint t1,Oint t2 -> do_list [Lazy.force coq_c_reduce], Oint(t1+t2) | t1,t2 -> if weight env t1 < weight env t2 then do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1) else do_list [],Oplus(t1,t2) (* \subsection{Fusion avec réduction} *) let shrink_pair f1 f2 = begin match f1,f2 with Oatom v,Oatom _ -> Lazy.force coq_c_red1, Omult(Oatom v,Oint two) | Oatom v, Omult(_,c2) -> Lazy.force coq_c_red2, Omult(Oatom v,Oplus(c2,Oint one)) | Omult (v1,c1),Oatom v -> Lazy.force coq_c_red3, Omult(Oatom v,Oplus(c1,Oint one)) | Omult (Oatom v,c1),Omult (v2,c2) -> Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2)) | t1,t2 -> oprint stdout t1; print_newline (); oprint stdout t2; print_newline (); flush Pervasives.stdout; Util.error "shrink.1" end (* \subsection{Calcul d'une sous formule constante} *) let reduce_factor = function Oatom v -> let r = Omult(Oatom v,Oint one) in [Lazy.force coq_c_red0],r | Omult(Oatom v,Oint n) as f -> [],f | Omult(Oatom v,c) -> let rec compute = function Oint n -> n | Oplus(t1,t2) -> compute t1 + compute t2 | _ -> Util.error "condense.1" in [Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c)) | t -> Util.error "reduce_factor.1" (* \subsection{Réordonnancement} *) let rec condense env = function Oplus(f1,(Oplus(f2,r) as t)) -> if weight env f1 = weight env f2 then begin let shrink_tac,t = shrink_pair f1 f2 in let assoc_tac = Lazy.force coq_c_plus_assoc_l in let tac_list,t' = condense env (Oplus(t,r)) in assoc_tac :: do_left (do_list [shrink_tac]) :: tac_list, t' end else begin let tac,f = reduce_factor f1 in let tac',t' = condense env t in [do_both (do_list tac) (do_list tac')], Oplus(f,t') end | Oplus(f1,Oint n) -> let tac,f1' = reduce_factor f1 in [do_left (do_list tac)],Oplus(f1',Oint n) | Oplus(f1,f2) -> if weight env f1 = weight env f2 then begin let tac_shrink,t = shrink_pair f1 f2 in let tac,t' = condense env t in tac_shrink :: tac,t' end else begin let tac,f = reduce_factor f1 in let tac',t' = condense env f2 in [do_both (do_list tac) (do_list tac')],Oplus(f,t') end | (Oint _ as t)-> [],t | t -> let tac,t' = reduce_factor t in let final = Oplus(t',Oint zero) in tac @ [Lazy.force coq_c_red6], final (* \subsection{Elimination des zéros} *) let rec clear_zero = function Oplus(Omult(Oatom v,Oint n),r) when n=zero -> let tac',t = clear_zero r in Lazy.force coq_c_red5 :: tac',t | Oplus(f,r) -> let tac,t = clear_zero r in (if tac = [] then [] else [do_right (do_list tac)]),Oplus(f,t) | t -> [],t;; (* \subsection{Transformation des hypothčses} *) let rec reduce env = function Oplus(t1,t2) -> let t1', trace1 = reduce env t1 in let t2', trace2 = reduce env t2 in let trace3,t' = shuffle env (t1',t2') in t', do_list [do_both trace1 trace2; trace3] | Ominus(t1,t2) -> let t,trace = reduce env (Oplus(t1, Oopp t2)) in t, do_list [Lazy.force coq_c_minus; trace] | Omult(t1,t2) as t -> let t1', trace1 = reduce env t1 in let t2', trace2 = reduce env t2 in begin match t1',t2' with | (_, Oint n) -> let tac,t' = scalar n t1' in t', do_list [do_both trace1 trace2; tac] | (Oint n,_) -> let tac,t' = scalar n t2' in t', do_list [do_both trace1 trace2; Lazy.force coq_c_mult_comm; tac] | _ -> Oufo t, Lazy.force coq_c_nop end | Oopp t -> let t',trace = reduce env t in let trace',t'' = negate t' in t'', do_list [do_left trace; trace'] | (Oint _ | Oatom _ | Oufo _) as t -> t, Lazy.force coq_c_nop let normalize_linear_term env t = let t1,trace1 = reduce env t in let trace2,t2 = condense env t1 in let trace3,t3 = clear_zero t2 in do_list [trace1; do_list trace2; do_list trace3], t3 (* Cette fonction reproduit trčs exactement le comportement de [p_invert] *) let negate_oper = function Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = let mk_step t1 t2 f kind = let t = f t1 t2 in let trace, oterm = normalize_linear_term env t in let equa = omega_of_oformula env kind oterm in { e_comp = oper; e_left = t1; e_right = t2; e_negated = negated; e_depends = depends; e_origin = { o_hyp = origin; o_path = List.rev path }; e_trace = trace; e_omega = equa } in try match (if negated then (negate_oper oper) else oper) with | Eq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) EQUA | Neq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) DISE | Leq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o2,Oopp o1)) INEQ | Geq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) INEQ | Lt -> mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o2,Oint negone),Oopp o1)) INEQ | Gt -> mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint negone),Oopp o2)) INEQ with e when Logic.catchable_exception e -> raise e (* \section{Compilation des hypothčses} *) let rec oformula_of_constr env t = match Z.parse_term t with | Tplus (t1,t2) -> binop env (fun x y -> Oplus(x,y)) t1 t2 | Tminus (t1,t2) -> binop env (fun x y -> Ominus(x,y)) t1 t2 | Tmult (t1,t2) when Z.is_scalar t1 || Z.is_scalar t2 -> binop env (fun x y -> Omult(x,y)) t1 t2 | Topp t -> Oopp(oformula_of_constr env t) | Tsucc t -> Oplus(oformula_of_constr env t, Oint one) | Tnum n -> Oint n | _ -> Oatom (add_reified_atom t env) and binop env c t1 t2 = let t1' = oformula_of_constr env t1 in let t2' = oformula_of_constr env t2 in c t1' t2' and binprop env (neg2,depends,origin,path) add_to_depends neg1 gl c t1 t2 = let i = new_connector_id env in let depends1 = if add_to_depends then Left i::depends else depends in let depends2 = if add_to_depends then Right i::depends else depends in if add_to_depends then Hashtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path}; let t1' = oproposition_of_constr env (neg1,depends1,origin,O_left::path) gl t1 in let t2' = oproposition_of_constr env (neg2,depends2,origin,O_right::path) gl t2 in (* On numérote le connecteur dans l'environnement. *) c i t1' t2' and mk_equation env ctxt c connector t1 t2 = let t1' = oformula_of_constr env t1 in let t2' = oformula_of_constr env t2 in (* On ajoute l'equation dans l'environnement. *) let omega = normalize_equation env ctxt (connector,t1',t2') in add_equation env omega; Pequa (c,omega) and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = match Z.parse_rel gl c with | Req (t1,t2) -> mk_equation env ctxt c Eq t1 t2 | Rne (t1,t2) -> mk_equation env ctxt c Neq t1 t2 | Rle (t1,t2) -> mk_equation env ctxt c Leq t1 t2 | Rlt (t1,t2) -> mk_equation env ctxt c Lt t1 t2 | Rge (t1,t2) -> mk_equation env ctxt c Geq t1 t2 | Rgt (t1,t2) -> mk_equation env ctxt c Gt t1 t2 | Rtrue -> Ptrue | Rfalse -> Pfalse | Rnot t -> let t' = oproposition_of_constr env (not negated, depends, origin,(O_mono::path)) gl t in Pnot t' | Ror (t1,t2) -> binprop env ctxt (not negated) negated gl (fun i x y -> Por(i,x,y)) t1 t2 | Rand (t1,t2) -> binprop env ctxt negated negated gl (fun i x y -> Pand(i,x,y)) t1 t2 | Rimp (t1,t2) -> binprop env ctxt (not negated) (not negated) gl (fun i x y -> Pimp(i,x,y)) t1 t2 | Riff (t1,t2) -> binprop env ctxt negated negated gl (fun i x y -> Pand(i,x,y)) (Term.mkArrow t1 t2) (Term.mkArrow t2 t1) | _ -> Pprop c (* Destructuration des hypothčses et de la conclusion *) let reify_gl env gl = let concl = Tacmach.pf_concl gl in let t_concl = Pnot (oproposition_of_constr env (true,[],id_concl,[O_mono]) gl concl) in if !debug then begin Printf.printf "REIFED PROBLEM\n\n"; Printf.printf " CONCL: "; pprint stdout t_concl; Printf.printf "\n" end; let rec loop = function (i,t) :: lhyps -> let t' = oproposition_of_constr env (false,[],i,[]) gl t in if !debug then begin Printf.printf " %s: " (Names.string_of_id i); pprint stdout t'; Printf.printf "\n" end; (i,t') :: loop lhyps | [] -> if !debug then print_env_reification env; [] in let t_lhyps = loop (Tacmach.pf_hyps_types gl) in (id_concl,t_concl) :: t_lhyps let rec destructurate_pos_hyp orig list_equations list_depends = function | Pequa (_,e) -> [e :: list_equations] | Ptrue | Pfalse | Pprop _ -> [list_equations] | Pnot t -> destructurate_neg_hyp orig list_equations list_depends t | Por (i,t1,t2) -> let s1 = destructurate_pos_hyp orig list_equations (i::list_depends) t1 in let s2 = destructurate_pos_hyp orig list_equations (i::list_depends) t2 in s1 @ s2 | Pand(i,t1,t2) -> let list_s1 = destructurate_pos_hyp orig list_equations (list_depends) t1 in let rec loop = function le1 :: ll -> destructurate_pos_hyp orig le1 list_depends t2 @ loop ll | [] -> [] in loop list_s1 | Pimp(i,t1,t2) -> let s1 = destructurate_neg_hyp orig list_equations (i::list_depends) t1 in let s2 = destructurate_pos_hyp orig list_equations (i::list_depends) t2 in s1 @ s2 and destructurate_neg_hyp orig list_equations list_depends = function | Pequa (_,e) -> [e :: list_equations] | Ptrue | Pfalse | Pprop _ -> [list_equations] | Pnot t -> destructurate_pos_hyp orig list_equations list_depends t | Pand (i,t1,t2) -> let s1 = destructurate_neg_hyp orig list_equations (i::list_depends) t1 in let s2 = destructurate_neg_hyp orig list_equations (i::list_depends) t2 in s1 @ s2 | Por(_,t1,t2) -> let list_s1 = destructurate_neg_hyp orig list_equations list_depends t1 in let rec loop = function le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll | [] -> [] in loop list_s1 | Pimp(_,t1,t2) -> let list_s1 = destructurate_pos_hyp orig list_equations list_depends t1 in let rec loop = function le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll | [] -> [] in loop list_s1 let destructurate_hyps syst = let rec loop = function (i,t) :: l -> let l_syst1 = destructurate_pos_hyp i [] [] t in let l_syst2 = loop l in list_cartesian (@) l_syst1 l_syst2 | [] -> [[]] in loop syst (* \subsection{Affichage d'un systčme d'équation} *) (* Affichage des dépendances de systčme *) let display_depend = function Left i -> Printf.printf " L%d" i | Right i -> Printf.printf " R%d" i let display_systems syst_list = let display_omega om_e = Printf.printf " E%d : %a %s 0\n" om_e.id (fun _ -> display_eq display_omega_var) (om_e.body, om_e.constant) (operator_of_eq om_e.kind) in let display_equation oformula_eq = pprint stdout (Pequa (Lazy.force coq_c_nop,oformula_eq)); print_newline (); display_omega oformula_eq.e_omega; Printf.printf " Depends on:"; List.iter display_depend oformula_eq.e_depends; Printf.printf "\n Path: %s" (String.concat "" (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M") oformula_eq.e_origin.o_path)); Printf.printf "\n Origin: %s (negated : %s)\n\n" (Names.string_of_id oformula_eq.e_origin.o_hyp) (if oformula_eq.e_negated then "yes" else "no") in let display_system syst = Printf.printf "=SYSTEM===================================\n"; List.iter display_equation syst in List.iter display_system syst_list (* Extraction des prédicats utilisées dans une trace. Permet ensuite le calcul des hypothčses *) let rec hyps_used_in_trace = function | act :: l -> begin match act with | HYP e -> [e.id] @@ (hyps_used_in_trace l) | SPLIT_INEQ (_,(_,act1),(_,act2)) -> hyps_used_in_trace act1 @@ hyps_used_in_trace act2 | _ -> hyps_used_in_trace l end | [] -> [] (* Extraction des variables déclarées dans une équation. Permet ensuite de les déclarer dans l'environnement de la procédure réflexive et éviter les créations de variable au vol *) let rec variable_stated_in_trace = function | act :: l -> begin match act with | STATE action -> (*i nlle_equa: afine, def: afine, eq_orig: afine, i*) (*i coef: int, var:int i*) action :: variable_stated_in_trace l | SPLIT_INEQ (_,(_,act1),(_,act2)) -> variable_stated_in_trace act1 @ variable_stated_in_trace act2 | _ -> variable_stated_in_trace l end | [] -> [] ;; let add_stated_equations env tree = (* Il faut trier les variables par ordre d'introduction pour ne pas risquer de définir dans le mauvais ordre *) let stated_equations = let cmpvar x y = Pervasives.(-) x.st_var y.st_var in let rec loop = function | Tree(_,t1,t2) -> List.merge cmpvar (loop t1) (loop t2) | Leaf s -> List.sort cmpvar (variable_stated_in_trace s.s_trace) in loop tree in let add_env st = (* On retransforme la définition de v en formule reifiée *) let v_def = oformula_of_omega env st.st_def in (* Notez que si l'ordre de création des variables n'est pas respecté, * ca va planter *) let coq_v = coq_of_formula env v_def in let v = add_reified_atom coq_v env in (* Le terme qu'il va falloir introduire *) let term_to_generalize = app coq_refl_equal [|Lazy.force Z.typ; coq_v|] in (* sa représentation sous forme d'équation mais non réifié car on n'a pas * l'environnement pour le faire correctement *) let term_to_reify = (v_def,Oatom v) in (* enregistre le lien entre la variable omega et la variable Coq *) intern_omega_force env (Oatom v) st.st_var; (v, term_to_generalize,term_to_reify,st.st_def.id) in List.map add_env stated_equations (* Calcule la liste des éclatements ā réaliser sur les hypothčses nécessaires pour extraire une liste d'équations donnée *) (* PL: experimentally, the result order of the following function seems _very_ crucial for efficiency. No idea why. Do not remove the List.rev or modify the current semantics of Util.list_union (some elements of first arg, then second arg), unless you know what you're doing. *) let rec get_eclatement env = function i :: r -> let l = try (get_equation env i).e_depends with Not_found -> [] in list_union (List.rev l) (get_eclatement env r) | [] -> [] let select_smaller l = let comp (_,x) (_,y) = Pervasives.(-) (List.length x) (List.length y) in try List.hd (List.sort comp l) with Failure _ -> failwith "select_smaller" let filter_compatible_systems required systems = let rec select = function (x::l) -> if List.mem x required then select l else if List.mem (barre x) required then failwith "Exit" else x :: select l | [] -> [] in map_succeed (function (sol,splits) -> (sol,select splits)) systems let rec equas_of_solution_tree = function Tree(_,t1,t2) -> (equas_of_solution_tree t1)@@(equas_of_solution_tree t2) | Leaf s -> s.s_equa_deps (* [really_useful_prop] pushes useless props in a new Pprop variable *) (* Things get shorter, but may also get wrong, since a Prop is considered to be undecidable in ReflOmegaCore.concl_to_hyp, whereas for instance Pfalse is decidable. So should not be used on conclusion (??) *) let really_useful_prop l_equa c = let rec real_of = function Pequa(t,_) -> t | Ptrue -> app coq_True [||] | Pfalse -> app coq_False [||] | Pnot t1 -> app coq_not [|real_of t1|] | Por(_,t1,t2) -> app coq_or [|real_of t1; real_of t2|] | Pand(_,t1,t2) -> app coq_and [|real_of t1; real_of t2|] (* Attention : implications sur le lifting des variables ā comprendre ! *) | Pimp(_,t1,t2) -> Term.mkArrow (real_of t1) (real_of t2) | Pprop t -> t in let rec loop c = match c with Pequa(_,e) -> if List.mem e.e_omega.id l_equa then Some c else None | Ptrue -> None | Pfalse -> None | Pnot t1 -> begin match loop t1 with None -> None | Some t1' -> Some (Pnot t1') end | Por(i,t1,t2) -> binop (fun (t1,t2) -> Por(i,t1,t2)) t1 t2 | Pand(i,t1,t2) -> binop (fun (t1,t2) -> Pand(i,t1,t2)) t1 t2 | Pimp(i,t1,t2) -> binop (fun (t1,t2) -> Pimp(i,t1,t2)) t1 t2 | Pprop t -> None and binop f t1 t2 = begin match loop t1, loop t2 with None, None -> None | Some t1',Some t2' -> Some (f(t1',t2')) | Some t1',None -> Some (f(t1',Pprop (real_of t2))) | None,Some t2' -> Some (f(Pprop (real_of t1),t2')) end in match loop c with None -> Pprop (real_of c) | Some t -> t let rec display_solution_tree ch = function Leaf t -> output_string ch (Printf.sprintf "%d[%s]" t.s_index (String.concat " " (List.map string_of_int t.s_equa_deps))) | Tree(i,t1,t2) -> Printf.fprintf ch "S%d(%a,%a)" i display_solution_tree t1 display_solution_tree t2 let rec solve_with_constraints all_solutions path = let rec build_tree sol buf = function [] -> Leaf sol | (Left i :: remainder) -> Tree(i, build_tree sol (Left i :: buf) remainder, solve_with_constraints all_solutions (List.rev(Right i :: buf))) | (Right i :: remainder) -> Tree(i, solve_with_constraints all_solutions (List.rev (Left i :: buf)), build_tree sol (Right i :: buf) remainder) in let weighted = filter_compatible_systems path all_solutions in let (winner_sol,winner_deps) = try select_smaller weighted with reraise -> Printf.printf "%d - %d\n" (List.length weighted) (List.length all_solutions); List.iter display_depend path; raise reraise in build_tree winner_sol (List.rev path) winner_deps let find_path {o_hyp=id;o_path=p} env = let rec loop_path = function ([],l) -> Some l | (x1::l1,x2::l2) when x1 = x2 -> loop_path (l1,l2) | _ -> None in let rec loop_id i = function CCHyp{o_hyp=id';o_path=p'} :: l when id = id' -> begin match loop_path (p',p) with Some r -> i,r | None -> loop_id (succ i) l end | _ :: l -> loop_id (succ i) l | [] -> failwith "find_path" in loop_id 0 env let mk_direction_list l = let trans = function O_left -> coq_d_left | O_right -> coq_d_right | O_mono -> coq_d_mono in mk_list (Lazy.force coq_direction) (List.map (fun d-> Lazy.force(trans d)) l) (* \section{Rejouer l'historique} *) let get_hyp env_hyp i = try list_index0 (CCEqua i) env_hyp with Not_found -> failwith (Printf.sprintf "get_hyp %d" i) let replay_history env env_hyp = let rec loop env_hyp t = match t with | CONTRADICTION (e1,e2) :: l -> let trace = mk_nat (List.length e1.body) in mkApp (Lazy.force coq_s_contradiction, [| trace ; mk_nat (get_hyp env_hyp e1.id); mk_nat (get_hyp env_hyp e2.id) |]) | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> mkApp (Lazy.force coq_s_div_approx, [| Z.mk k; Z.mk d; reified_of_omega env e2.body e2.constant; mk_nat (List.length e2.body); loop env_hyp l; mk_nat (get_hyp env_hyp e1.id) |]) | NOT_EXACT_DIVIDE (e1,k) :: l -> let e2_constant = floor_div e1.constant k in let d = e1.constant - e2_constant * k in let e2_body = map_eq_linear (fun c -> c / k) e1.body in mkApp (Lazy.force coq_s_not_exact_divide, [|Z.mk k; Z.mk d; reified_of_omega env e2_body e2_constant; mk_nat (List.length e2_body); mk_nat (get_hyp env_hyp e1.id)|]) | EXACT_DIVIDE (e1,k) :: l -> let e2_body = map_eq_linear (fun c -> c / k) e1.body in let e2_constant = floor_div e1.constant k in mkApp (Lazy.force coq_s_exact_divide, [|Z.mk k; reified_of_omega env e2_body e2_constant; mk_nat (List.length e2_body); loop env_hyp l; mk_nat (get_hyp env_hyp e1.id)|]) | (MERGE_EQ(e3,e1,e2)) :: l -> let n1 = get_hyp env_hyp e1.id and n2 = get_hyp env_hyp e2 in mkApp (Lazy.force coq_s_merge_eq, [| mk_nat (List.length e1.body); mk_nat n1; mk_nat n2; loop (CCEqua e3:: env_hyp) l |]) | SUM(e3,(k1,e1),(k2,e2)) :: l -> let n1 = get_hyp env_hyp e1.id and n2 = get_hyp env_hyp e2.id in let trace = shuffle_path k1 e1.body k2 e2.body in mkApp (Lazy.force coq_s_sum, [| Z.mk k1; mk_nat n1; Z.mk k2; mk_nat n2; trace; (loop (CCEqua e3 :: env_hyp) l) |]) | CONSTANT_NOT_NUL(e,k) :: l -> mkApp (Lazy.force coq_s_constant_not_nul, [| mk_nat (get_hyp env_hyp e) |]) | CONSTANT_NEG(e,k) :: l -> mkApp (Lazy.force coq_s_constant_neg, [| mk_nat (get_hyp env_hyp e) |]) | STATE {st_new_eq=new_eq; st_def =def; st_orig=orig; st_coef=m; st_var=sigma } :: l -> let n1 = get_hyp env_hyp orig.id and n2 = get_hyp env_hyp def.id in let v = unintern_omega env sigma in let o_def = oformula_of_omega env def in let o_orig = oformula_of_omega env orig in let body = Oplus (o_orig,Omult (Oplus (Oopp v,o_def), Oint m)) in let trace,_ = normalize_linear_term env body in mkApp (Lazy.force coq_s_state, [| Z.mk m; trace; mk_nat n1; mk_nat n2; loop (CCEqua new_eq.id :: env_hyp) l |]) | HYP _ :: l -> loop env_hyp l | CONSTANT_NUL e :: l -> mkApp (Lazy.force coq_s_constant_nul, [| mk_nat (get_hyp env_hyp e) |]) | NEGATE_CONTRADICT(e1,e2,true) :: l -> mkApp (Lazy.force coq_s_negate_contradict, [| mk_nat (get_hyp env_hyp e1.id); mk_nat (get_hyp env_hyp e2.id) |]) | NEGATE_CONTRADICT(e1,e2,false) :: l -> mkApp (Lazy.force coq_s_negate_contradict_inv, [| mk_nat (List.length e2.body); mk_nat (get_hyp env_hyp e1.id); mk_nat (get_hyp env_hyp e2.id) |]) | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: l -> let i = get_hyp env_hyp e.id in let r1 = loop (CCEqua e1 :: env_hyp) l1 in let r2 = loop (CCEqua e2 :: env_hyp) l2 in mkApp (Lazy.force coq_s_split_ineq, [| mk_nat (List.length e.body); mk_nat i; r1 ; r2 |]) | (FORGET_C _ | FORGET _ | FORGET_I _) :: l -> loop env_hyp l | (WEAKEN _ ) :: l -> failwith "not_treated" | [] -> failwith "no contradiction" in loop env_hyp let rec decompose_tree env ctxt = function Tree(i,left,right) -> let org = try Hashtbl.find env.constructors i with Not_found -> failwith (Printf.sprintf "Cannot find constructor %d" i) in let (index,path) = find_path org ctxt in let left_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_left]} in let right_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_right]} in app coq_e_split [| mk_nat index; mk_direction_list path; decompose_tree env (left_hyp::ctxt) left; decompose_tree env (right_hyp::ctxt) right |] | Leaf s -> decompose_tree_hyps s.s_trace env ctxt s.s_equa_deps and decompose_tree_hyps trace env ctxt = function [] -> app coq_e_solve [| replay_history env ctxt trace |] | (i::l) -> let equation = try Hashtbl.find env.equations i with Not_found -> failwith (Printf.sprintf "Cannot find equation %d" i) in let (index,path) = find_path equation.e_origin ctxt in let full_path = if equation.e_negated then path @ [O_mono] else path in let cont = decompose_tree_hyps trace env (CCEqua equation.e_omega.id :: ctxt) l in app coq_e_extract [|mk_nat index; mk_direction_list full_path; cont |] (* \section{La fonction principale} *) (* Cette fonction construit la trace pour la procédure de décision réflexive. A partir des résultats de l'extraction des systčmes, elle lance la résolution par Omega, puis l'extraction d'un ensemble minimal de solutions permettant la résolution globale du systčme et enfin construit la trace qui permet de faire rejouer cette solution par la tactique réflexive. *) let resolution env full_reified_goal systems_list = let num = ref 0 in let solve_system list_eq = let index = !num in let system = List.map (fun eq -> eq.e_omega) list_eq in let trace = simplify_strong (new_omega_eq,new_omega_var,display_omega_var) system in (* calcule les hypotheses utilisées pour la solution *) let vars = hyps_used_in_trace trace in let splits = get_eclatement env vars in if !debug then begin Printf.printf "SYSTEME %d\n" index; display_action display_omega_var trace; print_string "\n Depend :"; List.iter (fun i -> Printf.printf " %d" i) vars; print_string "\n Split points :"; List.iter display_depend splits; Printf.printf "\n------------------------------------\n" end; incr num; {s_index = index; s_trace = trace; s_equa_deps = vars}, splits in if !debug then Printf.printf "\n====================================\n"; let all_solutions = List.map solve_system systems_list in let solution_tree = solve_with_constraints all_solutions [] in if !debug then begin display_solution_tree stdout solution_tree; print_newline() end; (* calcule la liste de toutes les hypothčses utilisées dans l'arbre de solution *) let useful_equa_id = equas_of_solution_tree solution_tree in (* recupere explicitement ces equations *) let equations = List.map (get_equation env) useful_equa_id in let l_hyps' = list_uniquize (List.map (fun e -> e.e_origin.o_hyp) equations) in let l_hyps = id_concl :: list_remove id_concl l_hyps' in let useful_hyps = List.map (fun id -> List.assoc id full_reified_goal) l_hyps in let useful_vars = let really_useful_vars = vars_of_equations equations in let concl_vars = vars_of_prop (List.assoc id_concl full_reified_goal) in really_useful_vars @@ concl_vars in (* variables a introduire *) let to_introduce = add_stated_equations env solution_tree in let stated_vars = List.map (fun (v,_,_,_) -> v) to_introduce in let l_generalize_arg = List.map (fun (_,t,_,_) -> t) to_introduce in let hyp_stated_vars = List.map (fun (_,_,_,id) -> CCEqua id) to_introduce in (* L'environnement de base se construit en deux morceaux : - les variables des équations utiles (et de la conclusion) - les nouvelles variables declarées durant les preuves *) let all_vars_env = useful_vars @ stated_vars in let basic_env = let rec loop i = function var :: l -> let t = get_reified_atom env var in Hashtbl.add env.real_indices var i; t :: loop (succ i) l | [] -> [] in loop 0 all_vars_env in let env_terms_reified = mk_list (Lazy.force Z.typ) basic_env in (* On peut maintenant généraliser le but : env est a jour *) let l_reified_stated = List.map (fun (_,_,(l,r),_) -> app coq_p_eq [| reified_of_formula env l; reified_of_formula env r |]) to_introduce in let reified_concl = match useful_hyps with (Pnot p) :: _ -> reified_of_proposition env p | _ -> reified_of_proposition env Pfalse in let l_reified_terms = (List.map (fun p -> reified_of_proposition env (really_useful_prop useful_equa_id p)) (List.tl useful_hyps)) in let env_props_reified = mk_plist env.props in let reified_goal = mk_list (Lazy.force coq_proposition) (l_reified_stated @ l_reified_terms) in let reified = app coq_interp_sequent [| reified_concl;env_props_reified;env_terms_reified;reified_goal|] in let normalize_equation e = let rec loop = function [] -> app (if e.e_negated then coq_p_invert else coq_p_step) [| e.e_trace |] | ((O_left | O_mono) :: l) -> app coq_p_left [| loop l |] | (O_right :: l) -> app coq_p_right [| loop l |] in let correct_index = let i = list_index0 e.e_origin.o_hyp l_hyps in (* PL: it seems that additionnally introduced hyps are in the way during normalization, hence this index shifting... *) if i=0 then 0 else Pervasives.(+) i (List.length to_introduce) in app coq_pair_step [| mk_nat correct_index; loop e.e_origin.o_path |] in let normalization_trace = mk_list (Lazy.force coq_h_step) (List.map normalize_equation equations) in let initial_context = List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) (List.tl l_hyps) in let context = CCHyp{o_hyp=id_concl;o_path=[]} :: hyp_stated_vars @ initial_context in let decompose_tactic = decompose_tree env context solution_tree in Tactics.generalize (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps)) >> Tactics.change_in_concl None reified >> Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|]) >> show_goal >> Tactics.normalise_vm_in_concl >> (*i Alternatives to the previous line: - Normalisation without VM: Tactics.normalise_in_concl - Skip the conversion check and rely directly on the QED: Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >> i*) Tactics.apply (Lazy.force coq_I) let total_reflexive_omega_tactic gl = Coqlib.check_required_library ["Coq";"romega";"ROmega"]; rst_omega_eq (); rst_omega_var (); try let env = new_environment () in let full_reified_goal = reify_gl env gl in let systems_list = destructurate_hyps full_reified_goal in if !debug then display_systems systems_list; resolution env full_reified_goal systems_list gl with NO_CONTRADICTION -> Util.error "ROmega can't solve this system" (*i let tester = Tacmach.hide_atomic_tactic "TestOmega" test_tactic i*) coq-8.4pl4/plugins/cc/0000755000175000017500000000000012365131026013664 5ustar stephstephcoq-8.4pl4/plugins/cc/README0000644000175000017500000000103612326224777014561 0ustar stephsteph cctac: congruence-closure for coq author: Pierre Corbineau, Stage de DEA au LSV, ENS Cachan Thčse au LRI, Université Paris Sud XI Files : - ccalgo.ml : congruence closure algorithm - ccproof.ml : proof generation code - cctac.ml4 : the tactic itself - CCSolve.v : a small Ltac tactic based on congruence Known Bugs : the congruence tactic can fail due to type dependencies. Related documents: Peter J. Downey, Ravi Sethi, and Robert E. Tarjan. Variations on the common subexpression problem. JACM, 27(4):758-771, October 1980. coq-8.4pl4/plugins/cc/g_congruence.ml40000644000175000017500000000172012326224777016755 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ congruence_tac 1000 [] ] |[ "congruence" integer(n) ] -> [ congruence_tac n [] ] |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 1000 l ] |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> [ congruence_tac n l ] END TACTIC EXTEND f_equal [ "f_equal" ] -> [ f_equal ] END coq-8.4pl4/plugins/cc/ccproof.ml0000644000175000017500000001000712326224777015664 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* prefl (Appli (t1,t2)) | _, _ -> {p_lhs=Appli (p1.p_lhs,p2.p_lhs); p_rhs=Appli (p1.p_rhs,p2.p_rhs); p_rule=Congr (p1,p2)} let rec ptrans p1 p3= match p1.p_rule,p3.p_rule with Refl _, _ ->p3 | _, Refl _ ->p1 | Trans(p1,p2), _ ->ptrans p1 (ptrans p2 p3) | Congr(p1,p2), Congr(p3,p4) ->pcongr (ptrans p1 p3) (ptrans p2 p4) | Congr(p1,p2), Trans({p_rule=Congr(p3,p4)},p5) -> ptrans (pcongr (ptrans p1 p3) (ptrans p2 p4)) p5 | _, _ -> if term_equal p1.p_rhs p3.p_lhs then {p_lhs=p1.p_lhs; p_rhs=p3.p_rhs; p_rule=Trans (p1,p3)} else anomaly "invalid cc transitivity" let rec psym p = match p.p_rule with Refl _ -> p | SymAx s -> {p_lhs=p.p_rhs; p_rhs=p.p_lhs; p_rule=Ax s} | Ax s-> {p_lhs=p.p_rhs; p_rhs=p.p_lhs; p_rule=SymAx s} | Inject (p0,c,n,a)-> {p_lhs=p.p_rhs; p_rhs=p.p_lhs; p_rule=Inject (psym p0,c,n,a)} | Trans (p1,p2)-> ptrans (psym p2) (psym p1) | Congr (p1,p2)-> pcongr (psym p1) (psym p2) let pax axioms s = let l,r = Constrhash.find axioms s in {p_lhs=l; p_rhs=r; p_rule=Ax s} let psymax axioms s = let l,r = Constrhash.find axioms s in {p_lhs=r; p_rhs=l; p_rule=SymAx s} let rec nth_arg t n= match t with Appli (t1,t2)-> if n>0 then nth_arg t1 (n-1) else t2 | _ -> anomaly "nth_arg: not enough args" let pinject p c n a = {p_lhs=nth_arg p.p_lhs (n-a); p_rhs=nth_arg p.p_rhs (n-a); p_rule=Inject(p,c,n,a)} let build_proof uf= let axioms = axioms uf in let rec equal_proof i j= if i=j then prefl (term uf i) else let (li,lj)=join_path uf i j in ptrans (path_proof i li) (psym (path_proof j lj)) and edge_proof ((i,j),eq)= let pi=equal_proof i eq.lhs in let pj=psym (equal_proof j eq.rhs) in let pij= match eq.rule with Axiom (s,reversed)-> if reversed then psymax axioms s else pax axioms s | Congruence ->congr_proof eq.lhs eq.rhs | Injection (ti,ipac,tj,jpac,k) -> let p=ind_proof ti ipac tj jpac in let cinfo= get_constructor_info uf ipac.cnode in pinject p cinfo.ci_constr cinfo.ci_nhyps k in ptrans (ptrans pi pij) pj and constr_proof i t ipac= if ipac.args=[] then equal_proof i t else let npac=tail_pac ipac in let (j,arg)=subterms uf t in let targ=term uf arg in let rj=find uf j in let u=find_pac uf rj npac in let p=constr_proof j u npac in ptrans (equal_proof i t) (pcongr p (prefl targ)) and path_proof i=function [] -> prefl (term uf i) | x::q->ptrans (path_proof (snd (fst x)) q) (edge_proof x) and congr_proof i j= let (i1,i2) = subterms uf i and (j1,j2) = subterms uf j in pcongr (equal_proof i1 j1) (equal_proof i2 j2) and ind_proof i ipac j jpac= let p=equal_proof i j and p1=constr_proof i i ipac and p2=constr_proof j j jpac in ptrans (psym p1) (ptrans p p2) in function `Prove (i,j) -> equal_proof i j | `Discr (i,ci,j,cj)-> ind_proof i ci j cj coq-8.4pl4/plugins/cc/ccalgo.mli0000644000175000017500000001177412326224777015646 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* term -> bool type patt_kind = Normal | Trivial of types | Creates_variables type ccpattern = PApp of term * ccpattern list | PVar of int type pa_constructor = { cnode : int; arity : int; args : int list} module PacMap : Map.S with type key = pa_constructor type forest type state type rule= Congruence | Axiom of constr * bool | Injection of int * pa_constructor * int * pa_constructor * int type from= Goal | Hyp of constr | HeqG of constr | HeqnH of constr*constr type 'a eq = {lhs:int;rhs:int;rule:'a} type equality = rule eq type disequality = from eq type explanation = Discrimination of (int*pa_constructor*int*pa_constructor) | Contradiction of disequality | Incomplete module Constrhash : Hashtbl.S with type key = constr module Termhash : Hashtbl.S with type key = term val constr_of_term : term -> constr val debug : (Pp.std_ppcmds -> unit) -> Pp.std_ppcmds -> unit val forest : state -> forest val axioms : forest -> (term * term) Constrhash.t val epsilons : forest -> pa_constructor list val empty : int -> Proof_type.goal Tacmach.sigma -> state val add_term : state -> term -> int val add_equality : state -> constr -> term -> term -> unit val add_disequality : state -> from -> term -> term -> unit val add_quant : state -> identifier -> bool -> int * patt_kind * ccpattern * patt_kind * ccpattern -> unit val tail_pac : pa_constructor -> pa_constructor val find : forest -> int -> int val find_pac : forest -> int -> pa_constructor -> int val term : forest -> int -> term val get_constructor_info : forest -> int -> cinfo val subterms : forest -> int -> int * int val join_path : forest -> int -> int -> ((int * int) * equality) list * ((int * int) * equality) list type quant_eq= {qe_hyp_id: identifier; qe_pol: bool; qe_nvars:int; qe_lhs: ccpattern; qe_lhs_valid:patt_kind; qe_rhs: ccpattern; qe_rhs_valid:patt_kind} type pa_fun= {fsym:int; fnargs:int} type matching_problem module PafMap: Map.S with type key = pa_fun val make_fun_table : state -> Intset.t PafMap.t val do_match : state -> (quant_eq * int array) list ref -> matching_problem Stack.t -> unit val init_pb_stack : state -> matching_problem Stack.t val paf_of_patt : int Termhash.t -> ccpattern -> pa_fun val find_instances : state -> (quant_eq * int array) list val execute : bool -> state -> explanation option (*type pa_constructor module PacMap:Map.S with type key=pa_constructor type term = Symb of Term.constr | Eps | Appli of term * term | Constructor of Names.constructor*int*int type rule = Congruence | Axiom of Names.identifier | Injection of int*int*int*int type equality = {lhs : int; rhs : int; rule : rule} module ST : sig type t val empty : unit -> t val enter : int -> int * int -> t -> unit val query : int * int -> t -> int val delete : int -> t -> unit val delete_list : int list -> t -> unit end module UF : sig type t exception Discriminable of int * int * int * int * t val empty : unit -> t val find : t -> int -> int val size : t -> int -> int val get_constructor : t -> int -> Names.constructor val pac_arity : t -> int -> int * int -> int val mem_node_pac : t -> int -> int * int -> int val add_pacs : t -> int -> pa_constructor PacMap.t -> int list * equality list val term : t -> int -> term val subterms : t -> int -> int * int val add : t -> term -> int val union : t -> int -> int -> equality -> int list * equality list val join_path : t -> int -> int -> ((int*int)*equality) list* ((int*int)*equality) list end val combine_rec : UF.t -> int list -> equality list val process_rec : UF.t -> equality list -> int list val cc : UF.t -> unit val make_uf : (Names.identifier * (term * term)) list -> UF.t val add_one_diseq : UF.t -> (term * term) -> int * int val add_disaxioms : UF.t -> (Names.identifier * (term * term)) list -> (Names.identifier * (int * int)) list val check_equal : UF.t -> int * int -> bool val find_contradiction : UF.t -> (Names.identifier * (int * int)) list -> (Names.identifier * (int * int)) *) coq-8.4pl4/plugins/cc/ccalgo.ml0000644000175000017500000006236112326224777015473 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* !cc_verbose); optwrite=(fun b -> cc_verbose := b)} in declare_bool_option gdopt (* Signature table *) module ST=struct (* l: sign -> term r: term -> sign *) type t = {toterm:(int*int,int) Hashtbl.t; tosign:(int,int*int) Hashtbl.t} let empty ()= {toterm=Hashtbl.create init_size; tosign=Hashtbl.create init_size} let enter t sign st= if Hashtbl.mem st.toterm sign then anomaly "enter: signature already entered" else Hashtbl.replace st.toterm sign t; Hashtbl.replace st.tosign t sign let query sign st=Hashtbl.find st.toterm sign let rev_query term st=Hashtbl.find st.tosign term let delete st t= try let sign=Hashtbl.find st.tosign t in Hashtbl.remove st.toterm sign; Hashtbl.remove st.tosign t with Not_found -> () let rec delete_set st s = Intset.iter (delete st) s end type pa_constructor= { cnode : int; arity : int; args : int list} type pa_fun= {fsym:int; fnargs:int} type pa_mark= Fmark of pa_fun | Cmark of pa_constructor module PacMap=Map.Make(struct type t=pa_constructor let compare=Pervasives.compare end) module PafMap=Map.Make(struct type t=pa_fun let compare=Pervasives.compare end) type cinfo= {ci_constr: constructor; (* inductive type *) ci_arity: int; (* # args *) ci_nhyps: int} (* # projectable args *) type term= Symb of constr | Product of sorts_family * sorts_family | Eps of identifier | Appli of term*term | Constructor of cinfo (* constructor arity + nhyps *) let rec term_equal t1 t2 = match t1, t2 with | Symb c1, Symb c2 -> eq_constr c1 c2 | Product (s1, t1), Product (s2, t2) -> s1 = s2 && t1 = t2 | Eps i1, Eps i2 -> id_ord i1 i2 = 0 | Appli (t1, u1), Appli (t2, u2) -> term_equal t1 t2 && term_equal u1 u2 | Constructor {ci_constr=c1; ci_arity=i1; ci_nhyps=j1}, Constructor {ci_constr=c2; ci_arity=i2; ci_nhyps=j2} -> i1 = i2 && j1 = j2 && eq_constructor c1 c2 | _ -> t1 = t2 open Hashtbl_alt.Combine let rec hash_term = function | Symb c -> combine 1 (hash_constr c) | Product (s1, s2) -> combine3 2 (Hashtbl.hash s1) (Hashtbl.hash s2) | Eps i -> combine 3 (Hashtbl.hash i) | Appli (t1, t2) -> combine3 4 (hash_term t1) (hash_term t2) | Constructor {ci_constr=c; ci_arity=i; ci_nhyps=j} -> combine4 5 (Hashtbl.hash c) i j type ccpattern = PApp of term * ccpattern list (* arguments are reversed *) | PVar of int type rule= Congruence | Axiom of constr * bool | Injection of int * pa_constructor * int * pa_constructor * int type from= Goal | Hyp of constr | HeqG of constr | HeqnH of constr * constr type 'a eq = {lhs:int;rhs:int;rule:'a} type equality = rule eq type disequality = from eq type patt_kind = Normal | Trivial of types | Creates_variables type quant_eq = {qe_hyp_id: identifier; qe_pol: bool; qe_nvars:int; qe_lhs: ccpattern; qe_lhs_valid:patt_kind; qe_rhs: ccpattern; qe_rhs_valid:patt_kind} let swap eq : equality = let swap_rule=match eq.rule with Congruence -> Congruence | Injection (i,pi,j,pj,k) -> Injection (j,pj,i,pi,k) | Axiom (id,reversed) -> Axiom (id,not reversed) in {lhs=eq.rhs;rhs=eq.lhs;rule=swap_rule} type inductive_status = Unknown | Partial of pa_constructor | Partial_applied | Total of (int * pa_constructor) type representative= {mutable weight:int; mutable lfathers:Intset.t; mutable fathers:Intset.t; mutable inductive_status: inductive_status; class_type : Term.types; mutable functions: Intset.t PafMap.t; mutable constructors: int PacMap.t} (*pac -> term = app(constr,t) *) type cl = Rep of representative| Eqto of int*equality type vertex = Leaf| Node of (int*int) type node = {mutable clas:cl; mutable cpath: int; vertex:vertex; term:term} module Constrhash = Hashtbl.Make (struct type t = constr let equal = eq_constr let hash = hash_constr end) module Typehash = Constrhash module Termhash = Hashtbl.Make (struct type t = term let equal = term_equal let hash = hash_term end) module Identhash = Hashtbl.Make (struct type t = identifier let equal = Pervasives.(=) let hash = Hashtbl.hash end) type forest= {mutable max_size:int; mutable size:int; mutable map: node array; axioms: (term*term) Constrhash.t; mutable epsilons: pa_constructor list; syms: int Termhash.t} type state = {uf: forest; sigtable:ST.t; mutable terms: Intset.t; combine: equality Queue.t; marks: (int * pa_mark) Queue.t; mutable diseq: disequality list; mutable quant: quant_eq list; mutable pa_classes: Intset.t; q_history: (int array) Identhash.t; mutable rew_depth:int; mutable changed:bool; by_type: Intset.t Typehash.t; mutable gls:Proof_type.goal Tacmach.sigma} let dummy_node = {clas=Eqto(min_int,{lhs=min_int;rhs=min_int;rule=Congruence}); cpath=min_int; vertex=Leaf; term=Symb (mkRel min_int)} let empty depth gls:state = {uf= {max_size=init_size; size=0; map=Array.create init_size dummy_node; epsilons=[]; axioms=Constrhash.create init_size; syms=Termhash.create init_size}; terms=Intset.empty; combine=Queue.create (); marks=Queue.create (); sigtable=ST.empty (); diseq=[]; quant=[]; pa_classes=Intset.empty; q_history=Identhash.create init_size; rew_depth=depth; by_type=Constrhash.create init_size; changed=false; gls=gls} let forest state = state.uf let compress_path uf i j = uf.map.(j).cpath<-i let rec find_aux uf visited i= let j = uf.map.(i).cpath in if j<0 then let _ = List.iter (compress_path uf i) visited in i else find_aux uf (i::visited) j let find uf i= find_aux uf [] i let get_representative uf i= match uf.map.(i).clas with Rep r -> r | _ -> anomaly "get_representative: not a representative" let find_pac uf i pac = PacMap.find pac (get_representative uf i).constructors let get_constructor_info uf i= match uf.map.(i).term with Constructor cinfo->cinfo | _ -> anomaly "get_constructor: not a constructor" let size uf i= (get_representative uf i).weight let axioms uf = uf.axioms let epsilons uf = uf.epsilons let add_lfather uf i t= let r=get_representative uf i in r.weight<-r.weight+1; r.lfathers<-Intset.add t r.lfathers; r.fathers <-Intset.add t r.fathers let add_rfather uf i t= let r=get_representative uf i in r.weight<-r.weight+1; r.fathers <-Intset.add t r.fathers exception Discriminable of int * pa_constructor * int * pa_constructor let append_pac t p = {p with arity=pred p.arity;args=t::p.args} let tail_pac p= {p with arity=succ p.arity;args=List.tl p.args} let fsucc paf = {paf with fnargs=succ paf.fnargs} let add_pac rep pac t = if not (PacMap.mem pac rep.constructors) then rep.constructors<-PacMap.add pac t rep.constructors let add_paf rep paf t = let already = try PafMap.find paf rep.functions with Not_found -> Intset.empty in rep.functions<- PafMap.add paf (Intset.add t already) rep.functions let term uf i=uf.map.(i).term let subterms uf i= match uf.map.(i).vertex with Node(j,k) -> (j,k) | _ -> anomaly "subterms: not a node" let signature uf i= let j,k=subterms uf i in (find uf j,find uf k) let next uf= let size=uf.size in let nsize= succ size in if nsize=uf.max_size then let newmax=uf.max_size * 3 / 2 + 1 in let newmap=Array.create newmax dummy_node in begin uf.max_size<-newmax; Array.blit uf.map 0 newmap 0 size; uf.map<-newmap end else (); uf.size<-nsize; size let new_representative typ = {weight=0; lfathers=Intset.empty; fathers=Intset.empty; inductive_status=Unknown; class_type=typ; functions=PafMap.empty; constructors=PacMap.empty} (* rebuild a constr from an applicative term *) let _A_ = Name (id_of_string "A") let _B_ = Name (id_of_string "A") let _body_ = mkProd(Anonymous,mkRel 2,mkRel 2) let cc_product s1 s2 = mkLambda(_A_,mkSort(Termops.new_sort_in_family s1), mkLambda(_B_,mkSort(Termops.new_sort_in_family s2),_body_)) let rec constr_of_term = function Symb s->s | Product(s1,s2) -> cc_product s1 s2 | Eps id -> mkVar id | Constructor cinfo -> mkConstruct cinfo.ci_constr | Appli (s1,s2)-> make_app [(constr_of_term s2)] s1 and make_app l=function Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1 | other -> applistc (constr_of_term other) l let rec canonize_name c = let func = canonize_name in match kind_of_term c with | Const kn -> let canon_const = constant_of_kn (canonical_con kn) in (mkConst canon_const) | Ind (kn,i) -> let canon_mind = mind_of_kn (canonical_mind kn) in (mkInd (canon_mind,i)) | Construct ((kn,i),j) -> let canon_mind = mind_of_kn (canonical_mind kn) in mkConstruct ((canon_mind,i),j) | Prod (na,t,ct) -> mkProd (na,func t, func ct) | Lambda (na,t,ct) -> mkLambda (na, func t,func ct) | LetIn (na,b,t,ct) -> mkLetIn (na, func b,func t,func ct) | App (ct,l) -> mkApp (func ct,array_smartmap func l) | _ -> c (* rebuild a term from a pattern and a substitution *) let build_subst uf subst = Array.map (fun i -> try term uf i with e when Errors.noncritical e -> anomaly "incomplete matching") subst let rec inst_pattern subst = function PVar i -> subst.(pred i) | PApp (t, args) -> List.fold_right (fun spat f -> Appli (f,inst_pattern subst spat)) args t let pr_idx_term state i = str "[" ++ int i ++ str ":=" ++ Termops.print_constr (constr_of_term (term state.uf i)) ++ str "]" let pr_term t = str "[" ++ Termops.print_constr (constr_of_term t) ++ str "]" let rec add_term state t= let uf=state.uf in try Termhash.find uf.syms t with Not_found -> let b=next uf in let typ = pf_type_of state.gls (constr_of_term t) in let typ = canonize_name typ in let new_node= match t with Symb _ | Product (_,_) -> let paf = {fsym=b; fnargs=0} in Queue.add (b,Fmark paf) state.marks; {clas= Rep (new_representative typ); cpath= -1; vertex= Leaf; term= t} | Eps id -> {clas= Rep (new_representative typ); cpath= -1; vertex= Leaf; term= t} | Appli (t1,t2) -> let i1=add_term state t1 and i2=add_term state t2 in add_lfather uf (find uf i1) b; add_rfather uf (find uf i2) b; state.terms<-Intset.add b state.terms; {clas= Rep (new_representative typ); cpath= -1; vertex= Node(i1,i2); term= t} | Constructor cinfo -> let paf = {fsym=b; fnargs=0} in Queue.add (b,Fmark paf) state.marks; let pac = {cnode= b; arity= cinfo.ci_arity; args=[]} in Queue.add (b,Cmark pac) state.marks; {clas=Rep (new_representative typ); cpath= -1; vertex=Leaf; term=t} in uf.map.(b)<-new_node; Termhash.add uf.syms t b; Typehash.replace state.by_type typ (Intset.add b (try Typehash.find state.by_type typ with Not_found -> Intset.empty)); b let add_equality state c s t= let i = add_term state s in let j = add_term state t in Queue.add {lhs=i;rhs=j;rule=Axiom(c,false)} state.combine; Constrhash.add state.uf.axioms c (s,t) let add_disequality state from s t = let i = add_term state s in let j = add_term state t in state.diseq<-{lhs=i;rhs=j;rule=from}::state.diseq let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) = state.quant<- {qe_hyp_id= id; qe_pol= pol; qe_nvars=nvars; qe_lhs= patt1; qe_lhs_valid=valid1; qe_rhs= patt2; qe_rhs_valid=valid2}::state.quant let is_redundant state id args = try let norm_args = Array.map (find state.uf) args in let prev_args = Identhash.find_all state.q_history id in List.exists (fun old_args -> Util.array_for_all2 (fun i j -> i = find state.uf j) norm_args old_args) prev_args with Not_found -> false let add_inst state (inst,int_subst) = check_for_interrupt (); if state.rew_depth > 0 then if is_redundant state inst.qe_hyp_id int_subst then debug msgnl (str "discarding redundant (dis)equality") else begin Identhash.add state.q_history inst.qe_hyp_id int_subst; let subst = build_subst (forest state) int_subst in let prfhead= mkVar inst.qe_hyp_id in let args = Array.map constr_of_term subst in let _ = array_rev args in (* highest deBruijn index first *) let prf= mkApp(prfhead,args) in let s = inst_pattern subst inst.qe_lhs and t = inst_pattern subst inst.qe_rhs in state.changed<-true; state.rew_depth<-pred state.rew_depth; if inst.qe_pol then begin debug (fun () -> msgnl (str "Adding new equality, depth="++ int state.rew_depth); msgnl (str " [" ++ Termops.print_constr prf ++ str " : " ++ pr_term s ++ str " == " ++ pr_term t ++ str "]")) (); add_equality state prf s t end else begin debug (fun () -> msgnl (str "Adding new disequality, depth="++ int state.rew_depth); msgnl (str " [" ++ Termops.print_constr prf ++ str " : " ++ pr_term s ++ str " <> " ++ pr_term t ++ str "]")) (); add_disequality state (Hyp prf) s t end end let link uf i j eq = (* links i -> j *) let node=uf.map.(i) in node.clas<-Eqto (j,eq); node.cpath<-j let rec down_path uf i l= match uf.map.(i).clas with Eqto(j,t)->down_path uf j (((i,j),t)::l) | Rep _ ->l let rec min_path=function ([],l2)->([],l2) | (l1,[])->(l1,[]) | (((c1,t1)::q1),((c2,t2)::q2)) when c1=c2 -> min_path (q1,q2) | cpl -> cpl let join_path uf i j= assert (find uf i=find uf j); min_path (down_path uf i [],down_path uf j []) let union state i1 i2 eq= debug (fun () -> msgnl (str "Linking " ++ pr_idx_term state i1 ++ str " and " ++ pr_idx_term state i2 ++ str ".")) (); let r1= get_representative state.uf i1 and r2= get_representative state.uf i2 in link state.uf i1 i2 eq; Constrhash.replace state.by_type r1.class_type (Intset.remove i1 (try Constrhash.find state.by_type r1.class_type with Not_found -> Intset.empty)); let f= Intset.union r1.fathers r2.fathers in r2.weight<-Intset.cardinal f; r2.fathers<-f; r2.lfathers<-Intset.union r1.lfathers r2.lfathers; ST.delete_set state.sigtable r1.fathers; state.terms<-Intset.union state.terms r1.fathers; PacMap.iter (fun pac b -> Queue.add (b,Cmark pac) state.marks) r1.constructors; PafMap.iter (fun paf -> Intset.iter (fun b -> Queue.add (b,Fmark paf) state.marks)) r1.functions; match r1.inductive_status,r2.inductive_status with Unknown,_ -> () | Partial pac,Unknown -> r2.inductive_status<-Partial pac; state.pa_classes<-Intset.remove i1 state.pa_classes; state.pa_classes<-Intset.add i2 state.pa_classes | Partial _ ,(Partial _ |Partial_applied) -> state.pa_classes<-Intset.remove i1 state.pa_classes | Partial_applied,Unknown -> r2.inductive_status<-Partial_applied | Partial_applied,Partial _ -> state.pa_classes<-Intset.remove i2 state.pa_classes; r2.inductive_status<-Partial_applied | Total cpl,Unknown -> r2.inductive_status<-Total cpl; | Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks | _,_ -> () let merge eq state = (* merge and no-merge *) debug (fun () -> msgnl (str "Merging " ++ pr_idx_term state eq.lhs ++ str " and " ++ pr_idx_term state eq.rhs ++ str ".")) (); let uf=state.uf in let i=find uf eq.lhs and j=find uf eq.rhs in if i<>j then if (size uf i)<(size uf j) then union state i j eq else union state j i (swap eq) let update t state = (* update 1 and 2 *) debug (fun () -> msgnl (str "Updating term " ++ pr_idx_term state t ++ str ".")) (); let (i,j) as sign = signature state.uf t in let (u,v) = subterms state.uf t in let rep = get_representative state.uf i in begin match rep.inductive_status with Partial _ -> rep.inductive_status <- Partial_applied; state.pa_classes <- Intset.remove i state.pa_classes | _ -> () end; PacMap.iter (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks) rep.constructors; PafMap.iter (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks) rep.functions; try let s = ST.query sign state.sigtable in Queue.add {lhs=t;rhs=s;rule=Congruence} state.combine with Not_found -> ST.enter t sign state.sigtable let process_function_mark t rep paf state = add_paf rep paf t; state.terms<-Intset.union rep.lfathers state.terms let process_constructor_mark t i rep pac state = match rep.inductive_status with Total (s,opac) -> if pac.cnode <> opac.cnode then (* Conflict *) raise (Discriminable (s,opac,t,pac)) else (* Match *) let cinfo = get_constructor_info state.uf pac.cnode in let rec f n oargs args= if n > 0 then match (oargs,args) with s1::q1,s2::q2-> Queue.add {lhs=s1;rhs=s2;rule=Injection(s,opac,t,pac,n)} state.combine; f (n-1) q1 q2 | _-> anomaly "add_pacs : weird error in injection subterms merge" in f cinfo.ci_nhyps opac.args pac.args | Partial_applied | Partial _ -> add_pac rep pac t; state.terms<-Intset.union rep.lfathers state.terms | Unknown -> if pac.arity = 0 then rep.inductive_status <- Total (t,pac) else begin add_pac rep pac t; state.terms<-Intset.union rep.lfathers state.terms; rep.inductive_status <- Partial pac; state.pa_classes<- Intset.add i state.pa_classes end let process_mark t m state = debug (fun () -> msgnl (str "Processing mark for term " ++ pr_idx_term state t ++ str ".")) (); let i=find state.uf t in let rep=get_representative state.uf i in match m with Fmark paf -> process_function_mark t rep paf state | Cmark pac -> process_constructor_mark t i rep pac state type explanation = Discrimination of (int*pa_constructor*int*pa_constructor) | Contradiction of disequality | Incomplete let check_disequalities state = let uf=state.uf in let rec check_aux = function dis::q -> debug (fun () -> msg (str "Checking if " ++ pr_idx_term state dis.lhs ++ str " = " ++ pr_idx_term state dis.rhs ++ str " ... ")) (); if find uf dis.lhs=find uf dis.rhs then begin debug msgnl (str "Yes");Some dis end else begin debug msgnl (str "No");check_aux q end | [] -> None in check_aux state.diseq let one_step state = try let eq = Queue.take state.combine in merge eq state; true with Queue.Empty -> try let (t,m) = Queue.take state.marks in process_mark t m state; true with Queue.Empty -> try let t = Intset.choose state.terms in state.terms<-Intset.remove t state.terms; update t state; true with Not_found -> false let __eps__ = id_of_string "_eps_" let new_state_var typ state = let id = pf_get_new_id __eps__ state.gls in let {it=gl ; sigma=sigma} = state.gls in let gls = Goal.V82.new_goal_with sigma gl [id,None,typ] in state.gls<- gls; id let complete_one_class state i= match (get_representative state.uf i).inductive_status with Partial pac -> let rec app t typ n = if n<=0 then t else let _,etyp,rest= destProd typ in let id = new_state_var etyp state in app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in let _c = pf_type_of state.gls (constr_of_term (term state.uf pac.cnode)) in let _args = List.map (fun i -> constr_of_term (term state.uf i)) pac.args in let typ = prod_applist _c (List.rev _args) in let ct = app (term state.uf i) typ pac.arity in state.uf.epsilons <- pac :: state.uf.epsilons; ignore (add_term state ct) | _ -> anomaly "wrong incomplete class" let complete state = Intset.iter (complete_one_class state) state.pa_classes type matching_problem = {mp_subst : int array; mp_inst : quant_eq; mp_stack : (ccpattern*int) list } let make_fun_table state = let uf= state.uf in let funtab=ref PafMap.empty in Array.iteri (fun i inode -> if i < uf.size then match inode.clas with Rep rep -> PafMap.iter (fun paf _ -> let elem = try PafMap.find paf !funtab with Not_found -> Intset.empty in funtab:= PafMap.add paf (Intset.add i elem) !funtab) rep.functions | _ -> ()) state.uf.map; !funtab let rec do_match state res pb_stack = let mp=Stack.pop pb_stack in match mp.mp_stack with [] -> res:= (mp.mp_inst,mp.mp_subst) :: !res | (patt,cl)::remains -> let uf=state.uf in match patt with PVar i -> if mp.mp_subst.(pred i)<0 then begin mp.mp_subst.(pred i)<- cl; (* no aliasing problem here *) Stack.push {mp with mp_stack=remains} pb_stack end else if mp.mp_subst.(pred i) = cl then Stack.push {mp with mp_stack=remains} pb_stack else (* mismatch for non-linear variable in pattern *) () | PApp (f,[]) -> begin try let j=Termhash.find uf.syms f in if find uf j =cl then Stack.push {mp with mp_stack=remains} pb_stack with Not_found -> () end | PApp(f, ((last_arg::rem_args) as args)) -> try let j=Termhash.find uf.syms f in let paf={fsym=j;fnargs=List.length args} in let rep=get_representative uf cl in let good_terms = PafMap.find paf rep.functions in let aux i = let (s,t) = signature state.uf i in Stack.push {mp with mp_subst=Array.copy mp.mp_subst; mp_stack= (PApp(f,rem_args),s) :: (last_arg,t) :: remains} pb_stack in Intset.iter aux good_terms with Not_found -> () let paf_of_patt syms = function PVar _ -> invalid_arg "paf_of_patt: pattern is trivial" | PApp (f,args) -> {fsym=Termhash.find syms f; fnargs=List.length args} let init_pb_stack state = let syms= state.uf.syms in let pb_stack = Stack.create () in let funtab = make_fun_table state in let aux inst = begin let good_classes = match inst.qe_lhs_valid with Creates_variables -> Intset.empty | Normal -> begin try let paf= paf_of_patt syms inst.qe_lhs in PafMap.find paf funtab with Not_found -> Intset.empty end | Trivial typ -> begin try Typehash.find state.by_type typ with Not_found -> Intset.empty end in Intset.iter (fun i -> Stack.push {mp_subst = Array.make inst.qe_nvars (-1); mp_inst=inst; mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes end; begin let good_classes = match inst.qe_rhs_valid with Creates_variables -> Intset.empty | Normal -> begin try let paf= paf_of_patt syms inst.qe_rhs in PafMap.find paf funtab with Not_found -> Intset.empty end | Trivial typ -> begin try Typehash.find state.by_type typ with Not_found -> Intset.empty end in Intset.iter (fun i -> Stack.push {mp_subst = Array.make inst.qe_nvars (-1); mp_inst=inst; mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes end in List.iter aux state.quant; pb_stack let find_instances state = let pb_stack= init_pb_stack state in let res =ref [] in let _ = debug msgnl (str "Running E-matching algorithm ... "); try while true do check_for_interrupt (); do_match state res pb_stack done; anomaly "get out of here !" with Stack.Empty -> () in !res let rec execute first_run state = debug msgnl (str "Executing ... "); try while check_for_interrupt (); one_step state do () done; match check_disequalities state with None -> if not(Intset.is_empty state.pa_classes) then begin debug msgnl (str "First run was incomplete, completing ... "); complete state; execute false state end else if state.rew_depth>0 then let l=find_instances state in List.iter (add_inst state) l; if state.changed then begin state.changed <- false; execute true state end else begin debug msgnl (str "Out of instances ... "); None end else begin debug msgnl (str "Out of depth ... "); None end | Some dis -> Some begin if first_run then Contradiction dis else Incomplete end with Discriminable(s,spac,t,tpac) -> Some begin if first_run then Discrimination (s,spac,t,tpac) else Incomplete end coq-8.4pl4/plugins/cc/cctac.mli0000644000175000017500000000135012326224777015460 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Proof_type.tactic val cc_tactic : int -> constr list -> tactic val cc_fail : tactic val congruence_tac : int -> constr list -> tactic val f_equal : tactic coq-8.4pl4/plugins/cc/ccproof.mli0000644000175000017500000000160612326224777016042 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ `Discr of int * pa_constructor * int * pa_constructor | `Prove of int * int ] -> proof coq-8.4pl4/plugins/cc/cctac.ml0000644000175000017500000003760212326224777015320 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Closure.whd_val infos (Closure.inject t)) let whd_delta env= let infos=Closure.create_clos_infos Closure.betadeltaiota env in (fun t -> Closure.whd_val infos (Closure.inject t)) (* decompose member of equality in an applicative format *) let sf_of env sigma c = family_of_sort (sort_of env sigma c) let rec decompose_term env sigma t= match kind_of_term (whd env t) with App (f,args)-> let tf=decompose_term env sigma f in let targs=Array.map (decompose_term env sigma) args in Array.fold_left (fun s t->Appli (s,t)) tf targs | Prod (_,a,_b) when not (Termops.dependent (mkRel 1) _b) -> let b = Termops.pop _b in let sort_b = sf_of env sigma b in let sort_a = sf_of env sigma a in Appli(Appli(Product (sort_a,sort_b) , decompose_term env sigma a), decompose_term env sigma b) | Construct c-> let (mind,i_ind),i_con = c in let canon_mind = mind_of_kn (canonical_mind mind) in let canon_ind = canon_mind,i_ind in let (oib,_)=Global.lookup_inductive (canon_ind) in let nargs=mis_constructor_nargs_env env (canon_ind,i_con) in Constructor {ci_constr= (canon_ind,i_con); ci_arity=nargs; ci_nhyps=nargs-oib.mind_nparams} | Ind c -> let mind,i_ind = c in let canon_mind = mind_of_kn (canonical_mind mind) in let canon_ind = canon_mind,i_ind in (Symb (mkInd canon_ind)) | Const c -> let canon_const = constant_of_kn (canonical_con c) in (Symb (mkConst canon_const)) | _ ->if closed0 t then (Symb t) else raise Not_found (* decompose equality in members and type *) let atom_of_constr env sigma term = let wh = (whd_delta env term) in let kot = kind_of_term wh in match kot with App (f,args)-> if eq_constr f (Lazy.force _eq) && (Array.length args)=3 then `Eq (args.(0), decompose_term env sigma args.(1), decompose_term env sigma args.(2)) else `Other (decompose_term env sigma term) | _ -> `Other (decompose_term env sigma term) let rec pattern_of_constr env sigma c = match kind_of_term (whd env c) with App (f,args)-> let pf = decompose_term env sigma f in let pargs,lrels = List.split (array_map_to_list (pattern_of_constr env sigma) args) in PApp (pf,List.rev pargs), List.fold_left Intset.union Intset.empty lrels | Prod (_,a,_b) when not (Termops.dependent (mkRel 1) _b) -> let b = Termops.pop _b in let pa,sa = pattern_of_constr env sigma a in let pb,sb = pattern_of_constr env sigma b in let sort_b = sf_of env sigma b in let sort_a = sf_of env sigma a in PApp(Product (sort_a,sort_b), [pa;pb]),(Intset.union sa sb) | Rel i -> PVar i,Intset.singleton i | _ -> let pf = decompose_term env sigma c in PApp (pf,[]),Intset.empty let non_trivial = function PVar _ -> false | _ -> true let patterns_of_constr env sigma nrels term= let f,args= try destApp (whd_delta env term) with e when Errors.noncritical e -> raise Not_found in if eq_constr f (Lazy.force _eq) && (Array.length args)=3 then let patt1,rels1 = pattern_of_constr env sigma args.(1) and patt2,rels2 = pattern_of_constr env sigma args.(2) in let valid1 = if Intset.cardinal rels1 <> nrels then Creates_variables else if non_trivial patt1 then Normal else Trivial args.(0) and valid2 = if Intset.cardinal rels2 <> nrels then Creates_variables else if non_trivial patt2 then Normal else Trivial args.(0) in if valid1 <> Creates_variables || valid2 <> Creates_variables then nrels,valid1,patt1,valid2,patt2 else raise Not_found else raise Not_found let rec quantified_atom_of_constr env sigma nrels term = match kind_of_term (whd_delta env term) with Prod (id,atom,ff) -> if eq_constr ff (Lazy.force _False) then let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else quantified_atom_of_constr (Environ.push_rel (id,None,atom) env) sigma (succ nrels) ff | _ -> let patts=patterns_of_constr env sigma nrels term in `Rule patts let litteral_of_constr env sigma term= match kind_of_term (whd_delta env term) with | Prod (id,atom,ff) -> if eq_constr ff (Lazy.force _False) then match (atom_of_constr env sigma atom) with `Eq(t,a,b) -> `Neq(t,a,b) | `Other(p) -> `Nother(p) else begin try quantified_atom_of_constr (Environ.push_rel (id,None,atom) env) sigma 1 ff with Not_found -> `Other (decompose_term env sigma term) end | _ -> atom_of_constr env sigma term (* store all equalities from the context *) let rec make_prb gls depth additionnal_terms = let env=pf_env gls in let sigma=sig_sig gls in let state = empty depth gls in let pos_hyps = ref [] in let neg_hyps =ref [] in List.iter (fun c -> let t = decompose_term env sigma c in ignore (add_term state t)) additionnal_terms; List.iter (fun (id,_,e) -> begin let cid=mkVar id in match litteral_of_constr env sigma e with `Eq (t,a,b) -> add_equality state cid a b | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b | `Other ph -> List.iter (fun (cidn,nh) -> add_disequality state (HeqnH (cid,cidn)) ph nh) !neg_hyps; pos_hyps:=(cid,ph):: !pos_hyps | `Nother nh -> List.iter (fun (cidp,ph) -> add_disequality state (HeqnH (cidp,cid)) ph nh) !pos_hyps; neg_hyps:=(cid,nh):: !neg_hyps | `Rule patts -> add_quant state id true patts | `Nrule patts -> add_quant state id false patts end) (Environ.named_context_of_val (Goal.V82.hyps gls.sigma gls.it)); begin match atom_of_constr env sigma (pf_concl gls) with `Eq (t,a,b) -> add_disequality state Goal a b | `Other g -> List.iter (fun (idp,ph) -> add_disequality state (HeqG idp) ph g) !pos_hyps end; state (* indhyps builds the array of arrays of constructor hyps for (ind largs) *) let build_projection intype outtype (cstr:constructor) special default gls= let env=pf_env gls in let (h,argv) = try destApp intype with Invalid_argument _ -> (intype,[||]) in let ind=destInd h in let types=Inductiveops.arities_of_constructors env ind in let lp=Array.length types in let ci=pred (snd cstr) in let branch i= let ti=Term.prod_appvect types.(i) argv in let rc=fst (decompose_prod_assum ti) in let head= if i=ci then special else default in it_mkLambda_or_LetIn head rc in let branches=Array.init lp branch in let casee=mkRel 1 in let pred=mkLambda(Anonymous,intype,outtype) in let case_info=make_case_info (pf_env gls) ind RegularStyle in let body= mkCase(case_info, pred, casee, branches) in let id=pf_get_new_id (id_of_string "t") gls in mkLambda(Name id,intype,body) (* generate an adhoc tactic following the proof tree *) let _M =mkMeta let rec proof_tac p gls = match p.p_rule with Ax c -> exact_check c gls | SymAx c -> let l=constr_of_term p.p_lhs and r=constr_of_term p.p_rhs in let typ = Termops.refresh_universes (pf_type_of gls l) in exact_check (mkApp(Lazy.force _sym_eq,[|typ;r;l;c|])) gls | Refl t -> let lr = constr_of_term t in let typ = Termops.refresh_universes (pf_type_of gls lr) in exact_check (mkApp(Lazy.force _refl_equal,[|typ;constr_of_term t|])) gls | Trans (p1,p2)-> let t1 = constr_of_term p1.p_lhs and t2 = constr_of_term p1.p_rhs and t3 = constr_of_term p2.p_rhs in let typ = Termops.refresh_universes (pf_type_of gls t2) in let prf = mkApp(Lazy.force _trans_eq,[|typ;t1;t2;t3;_M 1;_M 2|]) in tclTHENS (refine prf) [(proof_tac p1);(proof_tac p2)] gls | Congr (p1,p2)-> let tf1=constr_of_term p1.p_lhs and tx1=constr_of_term p2.p_lhs and tf2=constr_of_term p1.p_rhs and tx2=constr_of_term p2.p_rhs in let typf = Termops.refresh_universes (pf_type_of gls tf1) in let typx = Termops.refresh_universes (pf_type_of gls tx1) in let typfx = Termops.refresh_universes (pf_type_of gls (mkApp (tf1,[|tx1|]))) in let id = pf_get_new_id (id_of_string "f") gls in let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in let lemma1 = mkApp(Lazy.force _f_equal, [|typf;typfx;appx1;tf1;tf2;_M 1|]) in let lemma2= mkApp(Lazy.force _f_equal, [|typx;typfx;tf2;tx1;tx2;_M 1|]) in let prf = mkApp(Lazy.force _trans_eq, [|typfx; mkApp(tf1,[|tx1|]); mkApp(tf2,[|tx1|]); mkApp(tf2,[|tx2|]);_M 2;_M 3|]) in tclTHENS (refine prf) [tclTHEN (refine lemma1) (proof_tac p1); tclFIRST [tclTHEN (refine lemma2) (proof_tac p2); reflexivity; fun gls -> errorlabstrm "Congruence" (Pp.str "I don't know how to handle dependent equality")]] gls | Inject (prf,cstr,nargs,argind) -> let ti=constr_of_term prf.p_lhs in let tj=constr_of_term prf.p_rhs in let default=constr_of_term p.p_lhs in let intype = Termops.refresh_universes (pf_type_of gls ti) in let outtype = Termops.refresh_universes (pf_type_of gls default) in let special=mkRel (1+nargs-argind) in let proj=build_projection intype outtype cstr special default gls in let injt= mkApp (Lazy.force _f_equal,[|intype;outtype;proj;ti;tj;_M 1|]) in tclTHEN (refine injt) (proof_tac prf) gls let refute_tac c t1 t2 p gls = let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let intype = Termops.refresh_universes (pf_type_of gls tt1) in let neweq= mkApp(Lazy.force _eq, [|intype;tt1;tt2|]) in let hid=pf_get_new_id (id_of_string "Heq") gls in let false_t=mkApp (c,[|mkVar hid|]) in tclTHENS (assert_tac (Name hid) neweq) [proof_tac p; simplest_elim false_t] gls let convert_to_goal_tac c t1 t2 p gls = let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let sort = Termops.refresh_universes (pf_type_of gls tt2) in let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in let e=pf_get_new_id (id_of_string "e") gls in let x=pf_get_new_id (id_of_string "X") gls in let identity=mkLambda (Name x,sort,mkRel 1) in let endt=mkApp (Lazy.force _eq_rect, [|sort;tt1;identity;c;tt2;mkVar e|]) in tclTHENS (assert_tac (Name e) neweq) [proof_tac p;exact_check endt] gls let convert_to_hyp_tac c1 t1 c2 t2 p gls = let tt2=constr_of_term t2 in let h=pf_get_new_id (id_of_string "H") gls in let false_t=mkApp (c2,[|mkVar h|]) in tclTHENS (assert_tac (Name h) tt2) [convert_to_goal_tac c1 t1 t2 p; simplest_elim false_t] gls let discriminate_tac cstr p gls = let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in let intype = Termops.refresh_universes (pf_type_of gls t1) in let concl=pf_concl gls in let outsort = mkType (Termops.new_univ ()) in let xid=pf_get_new_id (id_of_string "X") gls in let tid=pf_get_new_id (id_of_string "t") gls in let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in let trivial=pf_type_of gls identity in let outtype = mkType (Termops.new_univ ()) in let pred=mkLambda(Name xid,outtype,mkRel 1) in let hid=pf_get_new_id (id_of_string "Heq") gls in let proj=build_projection intype outtype cstr trivial concl gls in let injt=mkApp (Lazy.force _f_equal, [|intype;outtype;proj;t1;t2;mkVar hid|]) in let endt=mkApp (Lazy.force _eq_rect, [|outtype;trivial;pred;identity;concl;injt|]) in let neweq=mkApp(Lazy.force _eq,[|intype;t1;t2|]) in tclTHENS (assert_tac (Name hid) neweq) [proof_tac p;exact_check endt] gls (* wrap everything *) let build_term_to_complete uf meta pac = let cinfo = get_constructor_info uf pac.cnode in let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in let dummy_args = List.rev (list_tabulate meta pac.arity) in let all_args = List.rev_append real_args dummy_args in applistc (mkConstruct cinfo.ci_constr) all_args let cc_tactic depth additionnal_terms gls= Coqlib.check_required_library ["Coq";"Init";"Logic"]; let _ = debug Pp.msgnl (Pp.str "Reading subgoal ...") in let state = make_prb gls depth additionnal_terms in let _ = debug Pp.msgnl (Pp.str "Problem built, solving ...") in let sol = execute true state in let _ = debug Pp.msgnl (Pp.str "Computation completed.") in let uf=forest state in match sol with None -> tclFAIL 0 (str "congruence failed") gls | Some reason -> debug Pp.msgnl (Pp.str "Goal solved, generating proof ..."); match reason with Discrimination (i,ipac,j,jpac) -> let p=build_proof uf (`Discr (i,ipac,j,jpac)) in let cstr=(get_constructor_info uf ipac.cnode).ci_constr in discriminate_tac cstr p gls | Incomplete -> let metacnt = ref 0 in let newmeta _ = incr metacnt; _M !metacnt in let terms_to_complete = List.map (build_term_to_complete uf newmeta) (epsilons uf) in Pp.msgnl (Pp.str "Goal is solvable by congruence but \ some arguments are missing."); Pp.msgnl (Pp.str " Try " ++ hov 8 begin str "\"congruence with (" ++ prlist_with_sep (fun () -> str ")" ++ pr_spc () ++ str "(") (Termops.print_constr_env (pf_env gls)) terms_to_complete ++ str ")\"," end); Pp.msgnl (Pp.str " replacing metavariables by arbitrary terms."); tclFAIL 0 (str "Incomplete") gls | Contradiction dis -> let p=build_proof uf (`Prove (dis.lhs,dis.rhs)) in let ta=term uf dis.lhs and tb=term uf dis.rhs in match dis.rule with Goal -> proof_tac p gls | Hyp id -> refute_tac id ta tb p gls | HeqG id -> convert_to_goal_tac id ta tb p gls | HeqnH (ida,idb) -> convert_to_hyp_tac ida ta idb tb p gls let cc_fail gls = errorlabstrm "Congruence" (Pp.str "congruence failed.") let congruence_tac depth l = tclORELSE (tclTHEN (tclREPEAT introf) (cc_tactic depth l)) cc_fail (* Beware: reflexivity = constructor 1 = apply refl_equal might be slow now, let's rather do something equivalent to a "simple apply refl_equal" *) let simple_reflexivity () = apply (Lazy.force _refl_equal) (* The [f_equal] tactic. It mimics the use of lemmas [f_equal], [f_equal2], etc. This isn't particularly related with congruence, apart from the fact that congruence is called internally. *) let f_equal gl = let cut_eq c1 c2 = let ty = Termops.refresh_universes (pf_type_of gl c1) in tclTHENTRY (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|]))) (simple_reflexivity ()) in try match kind_of_term (pf_concl gl) with | App (r,[|_;t;t'|]) when eq_constr r (Lazy.force _eq) -> begin match kind_of_term t, kind_of_term t' with | App (f,v), App (f',v') when Array.length v = Array.length v' -> let rec cuts i = if i < 0 then tclTRY (congruence_tac 1000 []) else tclTHENFIRST (cut_eq v.(i) v'.(i)) (cuts (i-1)) in cuts (Array.length v - 1) gl | _ -> tclIDTAC gl end | _ -> tclIDTAC gl with Type_errors.TypeError _ -> tclIDTAC gl coq-8.4pl4/plugins/cc/cc_plugin.mllib0000644000175000017500000000006012326224777016661 0ustar stephstephCcalgo Ccproof Cctac G_congruence Cc_plugin_mod coq-8.4pl4/plugins/micromega/0000755000175000017500000000000012365131025015241 5ustar stephstephcoq-8.4pl4/plugins/micromega/mfourier.ml0000644000175000017500000006722712326224777017457 0ustar stephstephopen Num module Utils = Mutils open Polynomial open Vect let map_option = Utils.map_option let from_option = Utils.from_option let debug = false type ('a,'b) lr = Inl of 'a | Inr of 'b (** Implementation of intervals *) module Itv = struct (** The type of intervals is *) type interval = num option * num option (** None models the absence of bound i.e. infinity *) (** As a result, - None , None -> ]-oo,+oo[ - None , Some v -> ]-oo,v] - Some v, None -> [v,+oo[ - Some v, Some v' -> [v,v'] Intervals needs to be explicitely normalised. *) type who = Left | Right (** if then interval [itv] is empty, [norm_itv itv] returns [None] otherwise, it returns [Some itv] *) let norm_itv itv = match itv with | Some a , Some b -> if a <=/ b then Some itv else None | _ -> Some itv (** [opp_itv itv] computes the opposite interval *) let opp_itv itv = let (l,r) = itv in (map_option minus_num r, map_option minus_num l) (** [inter i1 i2 = None] if the intersection of intervals is empty [inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *) let inter i1 i2 = let (l1,r1) = i1 and (l2,r2) = i2 in let inter f o1 o2 = match o1 , o2 with | None , None -> None | Some _ , None -> o1 | None , Some _ -> o2 | Some n1 , Some n2 -> Some (f n1 n2) in norm_itv (inter max_num l1 l2 , inter min_num r1 r2) let range = function | None,_ | _,None -> None | Some i,Some j -> Some (floor_num j -/ceiling_num i +/ (Int 1)) let smaller_itv i1 i2 = match range i1 , range i2 with | None , _ -> false | _ , None -> true | Some i , Some j -> i <=/ j (** [in_bound bnd v] checks whether [v] is within the bounds [bnd] *) let in_bound bnd v = let (l,r) = bnd in match l , r with | None , None -> true | None , Some a -> v <=/ a | Some a , None -> a <=/ v | Some a , Some b -> a <=/ v && v <=/ b end open Itv type vector = Vect.t (** 'cstr' is the type of constraints. {coeffs = v ; bound = (l,r) } models the constraints l <= v <= r **) module ISet = Set.Make(struct type t = int let compare = Pervasives.compare end) module PSet = ISet module System = Hashtbl.Make(Vect) type proof = | Hyp of int | Elim of var * proof * proof | And of proof * proof type system = { sys : cstr_info ref System.t ; vars : ISet.t } and cstr_info = { bound : interval ; prf : proof ; pos : int ; neg : int ; } (** A system of constraints has the form [{sys = s ; vars = v}]. [s] is a hashtable mapping a normalised vector to a [cstr_info] record where - [bound] is an interval - [prf_idx] is the set of hypothese indexes (i.e. constraints in the initial system) used to obtain the current constraint. In the initial system, each constraint is given an unique singleton proof_idx. When a new constraint c is computed by a function f(c1,...,cn), its proof_idx is ISet.fold union (List.map (fun x -> x.proof_idx) [c1;...;cn] - [pos] is the number of positive values of the vector - [neg] is the number of negative values of the vector ( [neg] + [pos] is therefore the length of the vector) [v] is an upper-bound of the set of variables which appear in [s]. *) (** To be thrown when a system has no solution *) exception SystemContradiction of proof let hyps prf = let rec hyps prf acc = match prf with | Hyp i -> ISet.add i acc | Elim(_,prf1,prf2) | And(prf1,prf2) -> hyps prf1 (hyps prf2 acc) in hyps prf ISet.empty (** Pretty printing *) let rec pp_proof o prf = match prf with | Hyp i -> Printf.fprintf o "H%i" i | Elim(v, prf1,prf2) -> Printf.fprintf o "E(%i,%a,%a)" v pp_proof prf1 pp_proof prf2 | And(prf1,prf2) -> Printf.fprintf o "A(%a,%a)" pp_proof prf1 pp_proof prf2 let pp_bound o = function | None -> output_string o "oo" | Some a -> output_string o (string_of_num a) let pp_itv o (l,r) = Printf.fprintf o "(%a,%a)" pp_bound l pp_bound r let pp_iset o s = output_string o "{" ; ISet.fold (fun i _ -> Printf.fprintf o "%i " i) s (); output_string o "}" let pp_pset o s = output_string o "{" ; PSet.fold (fun i _ -> Printf.fprintf o "%i " i) s (); output_string o "}" let pp_info o i = pp_itv o i.bound let pp_cstr o (vect,bnd) = let (l,r) = bnd in (match l with | None -> () | Some n -> Printf.fprintf o "%s <= " (string_of_num n)) ; pp_vect o vect ; (match r with | None -> output_string o"\n" | Some n -> Printf.fprintf o "<=%s\n" (string_of_num n)) let pp_system o sys= System.iter (fun vect ibnd -> pp_cstr o (vect,(!ibnd).bound)) sys let pp_split_cstr o (vl,v,c,_) = Printf.fprintf o "(val x = %s ,%a,%s)" (string_of_num vl) pp_vect v (string_of_num c) (** [merge_cstr_info] takes: - the intersection of bounds and - the union of proofs - [pos] and [neg] fields should be identical *) let merge_cstr_info i1 i2 = let { pos = p1 ; neg = n1 ; bound = i1 ; prf = prf1 } = i1 and { pos = p2 ; neg = n2 ; bound = i2 ; prf = prf2 } = i2 in assert (p1 = p2 && n1 = n2) ; match inter i1 i2 with | None -> None (* Could directly raise a system contradiction exception *) | Some bnd -> Some { pos = p1 ; neg = n1 ; bound = bnd ; prf = And(prf1,prf2) } (** [xadd_cstr vect cstr_info] loads an constraint into the system. The constraint is neither redundant nor contradictory. @raise SystemContradiction if [cstr_info] returns [None] *) let xadd_cstr vect cstr_info sys = if debug && System.length sys mod 1000 = 0 then (print_string "*" ; flush stdout) ; try let info = System.find sys vect in match merge_cstr_info cstr_info !info with | None -> raise (SystemContradiction (And(cstr_info.prf, (!info).prf))) | Some info' -> info := info' with | Not_found -> System.replace sys vect (ref cstr_info) type cstr_ext = | Contradiction (** The constraint is contradictory. Typically, a [SystemContradiction] exception will be raised. *) | Redundant (** The constrain is redundant. Typically, the constraint will be dropped *) | Cstr of vector * cstr_info (** Taken alone, the constraint is neither contradictory nor redundant. Typically, it will be added to the constraint system. *) (** [normalise_cstr] : vector -> cstr_info -> cstr_ext *) let normalise_cstr vect cinfo = match norm_itv cinfo.bound with | None -> Contradiction | Some (l,r) -> match vect with | [] -> if Itv.in_bound (l,r) (Int 0) then Redundant else Contradiction | (_,n)::_ -> Cstr( (if n <>/ Int 1 then List.map (fun (x,nx) -> (x,nx // n)) vect else vect), let divn x = x // n in if sign_num n = 1 then{cinfo with bound = (map_option divn l , map_option divn r) } else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (map_option divn r , map_option divn l)}) (** For compatibility, there is an external representation of constraints *) let eval_op = function | Eq -> (=/) | Ge -> (>=/) let count v = let rec count n p v = match v with | [] -> (n,p) | (_,vl)::v -> let sg = sign_num vl in assert (sg <> 0) ; if sg = 1 then count n (p+1) v else count (n+1) p v in count 0 0 v let norm_cstr {coeffs = v ; op = o ; cst = c} idx = let (n,p) = count v in normalise_cstr v {pos = p ; neg = n ; bound = (match o with | Eq -> Some c , Some c | Ge -> Some c , None) ; prf = Hyp idx } (** [load_system l] takes a list of constraints of type [cstr_compat] @return a system of constraints @raise SystemContradiction if a contradiction is found *) let load_system l = let sys = System.create 1000 in let li = Mutils.mapi (fun e i -> (e,i)) l in let vars = List.fold_left (fun vrs (cstr,i) -> match norm_cstr cstr i with | Contradiction -> raise (SystemContradiction (Hyp i)) | Redundant -> vrs | Cstr(vect,info) -> xadd_cstr vect info sys ; List.fold_left (fun s (v,_) -> ISet.add v s) vrs cstr.coeffs) ISet.empty li in {sys = sys ;vars = vars} let system_list sys = let { sys = s ; vars = v } = sys in System.fold (fun k bi l -> (k, !bi)::l) s [] (** [add (v1,c1) (v2,c2) ] precondition: (c1 <>/ Int 0 && c2 <>/ Int 0) @return a pair [(v,ln)] such that [v] is the sum of vector [v1] divided by [c1] and vector [v2] divided by [c2] Note that the resulting vector is not normalised. *) let add (v1,c1) (v2,c2) = assert (c1 <>/ Int 0 && c2 <>/ Int 0) ; let rec xadd v1 v2 = match v1 , v2 with | (x1,n1)::v1' , (x2,n2)::v2' -> if x1 = x2 then let n' = (n1 // c1) +/ (n2 // c2) in if n' =/ Int 0 then xadd v1' v2' else let res = xadd v1' v2' in (x1,n') ::res else if x1 < x2 then let res = xadd v1' v2 in (x1, n1 // c1)::res else let res = xadd v1 v2' in (x2, n2 // c2)::res | [] , [] -> [] | [] , _ -> List.map (fun (x,vl) -> (x,vl // c2)) v2 | _ , [] -> List.map (fun (x,vl) -> (x,vl // c1)) v1 in let res = xadd v1 v2 in (res, count res) let add (v1,c1) (v2,c2) = let res = add (v1,c1) (v2,c2) in (* Printf.printf "add(%a,%s,%a,%s) -> %a\n" pp_vect v1 (string_of_num c1) pp_vect v2 (string_of_num c2) pp_vect (fst res) ;*) res type tlr = (num * vector * cstr_info) list type tm = (vector * cstr_info ) list (** To perform Fourier elimination, constraints are categorised depending on the sign of the variable to eliminate. *) (** [split x vect info (l,m,r)] @param v is the variable to eliminate @param l contains constraints such that (e + a*x) // a >= c / a @param r contains constraints such that (e + a*x) // - a >= c / -a @param m contains constraints which do not mention [x] *) let split x (vect: vector) info (l,m,r) = match get x vect with | None -> (* The constraint does not mention [x], store it in m *) (l,(vect,info)::m,r) | Some vl -> (* otherwise *) let cons_bound lst bd = match bd with | None -> lst | Some bnd -> (vl,vect,{info with bound = Some bnd,None})::lst in let lb,rb = info.bound in if sign_num vl = 1 then (cons_bound l lb,m,cons_bound r rb) else (* sign_num vl = -1 *) (cons_bound l rb,m,cons_bound r lb) (** [project vr sys] projects system [sys] over the set of variables [ISet.remove vr sys.vars ]. This is a one step Fourier elimination. *) let project vr sys = let (l,m,r) = System.fold (fun vect rf l_m_r -> split vr vect !rf l_m_r) sys.sys ([],[],[]) in let new_sys = System.create (System.length sys.sys) in (* Constraints in [m] belong to the projection - for those [vr] is already projected out *) List.iter (fun (vect,info) -> System.replace new_sys vect (ref info) ) m ; let elim (v1,vect1,info1) (v2,vect2,info2) = let {neg = n1 ; pos = p1 ; bound = bound1 ; prf = prf1} = info1 and {neg = n2 ; pos = p2 ; bound = bound2 ; prf = prf2} = info2 in let bnd1 = from_option (fst bound1) and bnd2 = from_option (fst bound2) in let bound = (bnd1 // v1) +/ (bnd2 // minus_num v2) in let vres,(n,p) = add (vect1,v1) (vect2,minus_num v2) in (vres,{neg = n ; pos = p ; bound = (Some bound, None); prf = Elim(vr,info1.prf,info2.prf)}) in List.iter(fun l_elem -> List.iter (fun r_elem -> let (vect,info) = elim l_elem r_elem in match normalise_cstr vect info with | Redundant -> () | Contradiction -> raise (SystemContradiction info.prf) | Cstr(vect,info) -> xadd_cstr vect info new_sys) r ) l; {sys = new_sys ; vars = ISet.remove vr sys.vars} (** [project_using_eq] performs elimination by pivoting using an equation. This is the counter_part of the [elim] sub-function of [!project]. @param vr is the variable to be used as pivot @param c is the coefficient of variable [vr] in vector [vect] @param len is the length of the equation @param bound is the bound of the equation @param prf is the proof of the equation *) let project_using_eq vr c vect bound prf (vect',info') = match get vr vect' with | Some c2 -> let c1 = if c2 >=/ Int 0 then minus_num c else c in let c2 = abs_num c2 in let (vres,(n,p)) = add (vect,c1) (vect', c2) in let cst = bound // c1 in let bndres = let f x = cst +/ x // c2 in let (l,r) = info'.bound in (map_option f l , map_option f r) in (vres,{neg = n ; pos = p ; bound = bndres ; prf = Elim(vr,prf,info'.prf)}) | None -> (vect',info') let elim_var_using_eq vr vect cst prf sys = let c = from_option (get vr vect) in let elim_var = project_using_eq vr c vect cst prf in let new_sys = System.create (System.length sys.sys) in System.iter(fun vect iref -> let (vect',info') = elim_var (vect,!iref) in match normalise_cstr vect' info' with | Redundant -> () | Contradiction -> raise (SystemContradiction info'.prf) | Cstr(vect,info') -> xadd_cstr vect info' new_sys) sys.sys ; {sys = new_sys ; vars = ISet.remove vr sys.vars} (** [size sys] computes the number of entries in the system of constraints *) let size sys = System.fold (fun v iref s -> s + (!iref).neg + (!iref).pos) sys 0 module IMap = Map.Make(struct type t = int let compare : int -> int -> int = Pervasives.compare end) let pp_map o map = IMap.fold (fun k elt () -> Printf.fprintf o "%i -> %s\n" k (string_of_num elt)) map () (** [eval_vect map vect] evaluates vector [vect] using the values of [map]. If [map] binds all the variables of [vect], we get [eval_vect map [(x1,v1);...;(xn,vn)] = (IMap.find x1 map * v1) + ... + (IMap.find xn map) * vn , []] The function returns as second argument, a sub-vector consisting in the variables that are not in [map]. *) let eval_vect map vect = let rec xeval_vect vect sum rst = match vect with | [] -> (sum,rst) | (v,vl)::vect -> try let val_v = IMap.find v map in xeval_vect vect (sum +/ (val_v */ vl)) rst with Not_found -> xeval_vect vect sum ((v,vl)::rst) in xeval_vect vect (Int 0) [] (** [restrict_bound n sum itv] returns the interval of [x] given that (fst itv) <= x * n + sum <= (snd itv) *) let restrict_bound n sum (itv:interval) = let f x = (x -/ sum) // n in let l,r = itv in match sign_num n with | 0 -> if in_bound itv sum then (None,None) (* redundant *) else failwith "SystemContradiction" | 1 -> map_option f l , map_option f r | _ -> map_option f r , map_option f l (** [bound_of_variable map v sys] computes the interval of [v] in [sys] given a mapping [map] binding all the other variables *) let bound_of_variable map v sys = System.fold (fun vect iref bnd -> let sum,rst = eval_vect map vect in let vl = match get v rst with | None -> Int 0 | Some v -> v in match inter bnd (restrict_bound vl sum (!iref).bound) with | None -> failwith "bound_of_variable: impossible" | Some itv -> itv) sys (None,None) (** [pick_small_value bnd] picks a value being closed to zero within the interval *) let pick_small_value bnd = match bnd with | None , None -> Int 0 | None , Some i -> if (Int 0) <=/ (floor_num i) then Int 0 else floor_num i | Some i,None -> if i <=/ (Int 0) then Int 0 else ceiling_num i | Some i,Some j -> if i <=/ Int 0 && Int 0 <=/ j then Int 0 else if ceiling_num i <=/ floor_num j then ceiling_num i (* why not *) else i (** [solution s1 sys_l = Some(sn,[(vn-1,sn-1);...; (v1,s1)]@sys_l)] then [sn] is a system which contains only [black_v] -- if it existed in [s1] and [sn+1] is obtained by projecting [vn] out of [sn] @raise SystemContradiction if system [s] has no solution *) let solve_sys black_v choose_eq choose_variable sys sys_l = let rec solve_sys sys sys_l = if debug then Printf.printf "S #%i size %i\n" (System.length sys.sys) (size sys.sys); let eqs = choose_eq sys in try let (v,vect,cst,ln) = fst (List.find (fun ((v,_,_,_),_) -> v <> black_v) eqs) in if debug then (Printf.printf "\nE %a = %s variable %i\n" pp_vect vect (string_of_num cst) v ; flush stdout); let sys' = elim_var_using_eq v vect cst ln sys in solve_sys sys' ((v,sys)::sys_l) with Not_found -> let vars = choose_variable sys in try let (v,est) = (List.find (fun (v,_) -> v <> black_v) vars) in if debug then (Printf.printf "\nV : %i estimate %f\n" v est ; flush stdout) ; let sys' = project v sys in solve_sys sys' ((v,sys)::sys_l) with Not_found -> (* we are done *) Inl (sys,sys_l) in solve_sys sys sys_l let solve black_v choose_eq choose_variable cstrs = try let sys = load_system cstrs in if debug then Printf.printf "solve :\n %a" pp_system sys.sys ; solve_sys black_v choose_eq choose_variable sys [] with SystemContradiction prf -> Inr prf (** The purpose of module [EstimateElimVar] is to try to estimate the cost of eliminating a variable. The output is an ordered list of (variable,cost). *) module EstimateElimVar = struct type sys_list = (vector * cstr_info) list let abstract_partition (v:int) (l: sys_list) = let rec xpart (l:sys_list) (ltl:sys_list) (n:int list) (z:int) (p:int list) = match l with | [] -> (ltl, n,z,p) | (l1,info) ::rl -> match l1 with | [] -> xpart rl (([],info)::ltl) n (info.neg+info.pos+z) p | (vr,vl)::rl1 -> if v = vr then let cons_bound lst bd = match bd with | None -> lst | Some bnd -> info.neg+info.pos::lst in let lb,rb = info.bound in if sign_num vl = 1 then xpart rl ((rl1,info)::ltl) (cons_bound n lb) z (cons_bound p rb) else xpart rl ((rl1,info)::ltl) (cons_bound n rb) z (cons_bound p lb) else (* the variable is greater *) xpart rl ((l1,info)::ltl) n (info.neg+info.pos+z) p in let (sys',n,z,p) = xpart l [] [] 0 [] in let ln = float_of_int (List.length n) in let sn = float_of_int (List.fold_left (+) 0 n) in let lp = float_of_int (List.length p) in let sp = float_of_int (List.fold_left (+) 0 p) in (sys', float_of_int z +. lp *. sn +. ln *. sp -. lp*.ln) let choose_variable sys = let {sys = s ; vars = v} = sys in let sl = system_list sys in let evals = fst (ISet.fold (fun v (eval,s) -> let ts,vl = abstract_partition v s in ((v,vl)::eval, ts)) v ([],sl)) in List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) evals end open EstimateElimVar (** The module [EstimateElimEq] is similar to [EstimateElimVar] but it orders equations. *) module EstimateElimEq = struct let itv_point bnd = match bnd with |(Some a, Some b) -> a =/ b | _ -> false let eq_bound bnd c = match bnd with |(Some a, Some b) -> a =/ b && c =/ b | _ -> false let rec unroll_until v l = match l with | [] -> (false,[]) | (i,_)::rl -> if i = v then (true,rl) else if i < v then unroll_until v rl else (false,l) let rec choose_simple_equation eqs = match eqs with | [] -> None | (vect,a,prf,ln)::eqs -> match vect with | [i,_] -> Some (i,vect,a,prf,ln) | _ -> choose_simple_equation eqs let choose_primal_equation eqs sys_l = (* Counts the number of equations refering to variable [v] -- It looks like nb_cst is dead... *) let is_primal_equation_var v = List.fold_left (fun nb_eq (vect,info) -> if fst (unroll_until v vect) then if itv_point info.bound then nb_eq + 1 else nb_eq else nb_eq) 0 sys_l in let rec find_var vect = match vect with | [] -> None | (i,_)::vect -> let nb_eq = is_primal_equation_var i in if nb_eq = 2 then Some i else find_var vect in let rec find_eq_var eqs = match eqs with | [] -> None | (vect,a,prf,ln)::l -> match find_var vect with | None -> find_eq_var l | Some r -> Some (r,vect,a,prf,ln) in match choose_simple_equation eqs with | None -> find_eq_var eqs | Some res -> Some res let choose_equality_var sys = let sys_l = system_list sys in let equalities = List.fold_left (fun l (vect,info) -> match info.bound with | Some a , Some b -> if a =/ b then (* This an equation *) (vect,a,info.prf,info.neg+info.pos)::l else l | _ -> l ) [] sys_l in let rec estimate_cost v ct sysl acc tlsys = match sysl with | [] -> (acc,tlsys) | (l,info)::rsys -> let ln = info.pos + info.neg in let (b,l) = unroll_until v l in match b with | true -> if itv_point info.bound then estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) (* this is free *) else estimate_cost v ct rsys (acc+ln+ct) ((l,info)::tlsys) (* should be more ? *) | false -> estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) in match choose_primal_equation equalities sys_l with | None -> let cost_eq eq const prf ln acc_costs = let rec cost_eq eqr sysl costs = match eqr with | [] -> costs | (v,_) ::eqr -> let (cst,tlsys) = estimate_cost v (ln-1) sysl 0 [] in cost_eq eqr tlsys (((v,eq,const,prf),cst)::costs) in cost_eq eq sys_l acc_costs in let all_costs = List.fold_left (fun all_costs (vect,const,prf,ln) -> cost_eq vect const prf ln all_costs) [] equalities in (* pp_list (fun o ((v,eq,_,_),cst) -> Printf.fprintf o "((%i,%a),%i)\n" v pp_vect eq cst) stdout all_costs ; *) List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) all_costs | Some (v,vect, const,prf,_) -> [(v,vect,const,prf),0] end open EstimateElimEq module Fourier = struct let optimise vect l = (* We add a dummy (fresh) variable for vector *) let fresh = List.fold_left (fun fr c -> Pervasives.max fr (Vect.fresh c.coeffs)) 0 l in let cstr = { coeffs = Vect.set fresh (Int (-1)) vect ; op = Eq ; cst = (Int 0)} in match solve fresh choose_equality_var choose_variable (cstr::l) with | Inr prf -> None (* This is an unsatisfiability proof *) | Inl (s,_) -> try Some (bound_of_variable IMap.empty fresh s.sys) with x when x <> Sys.Break -> Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None let find_point cstrs = match solve max_int choose_equality_var choose_variable cstrs with | Inr prf -> Inr prf | Inl (_,l) -> let rec rebuild_solution l map = match l with | [] -> map | (v,e)::l -> let itv = bound_of_variable map v e.sys in let map = IMap.add v (pick_small_value itv) map in rebuild_solution l map in let map = rebuild_solution l IMap.empty in let vect = List.rev (IMap.fold (fun v i vect -> (v,i)::vect) map []) in (* Printf.printf "SOLUTION %a" pp_vect vect ; *) let res = Inl vect in res end module Proof = struct (** A proof term in the sense of a ZMicromega.RatProof is a positive combination of the hypotheses which leads to a contradiction. The proofs constructed by Fourier elimination are more like execution traces: - certain facts are recorded but are useless - certain inferences are implicit. The following code implements proof reconstruction. *) let add x y = fst (add x y) let forall_pairs f l1 l2 = List.fold_left (fun acc e1 -> List.fold_left (fun acc e2 -> match f e1 e2 with | None -> acc | Some v -> v::acc) acc l2) [] l1 let add_op x y = match x , y with | Eq , Eq -> Eq | _ -> Ge let pivot v (p1,c1) (p2,c2) = let {coeffs = v1 ; op = op1 ; cst = n1} = c1 and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in match Vect.get v v1 , Vect.get v v2 with | None , _ | _ , None -> None | Some a , Some b -> if (sign_num a) * (sign_num b) = -1 then Some (add (p1,abs_num a) (p2,abs_num b) , {coeffs = add (v1,abs_num a) (v2,abs_num b) ; op = add_op op1 op2 ; cst = n1 // (abs_num a) +/ n2 // (abs_num b) }) else if op1 = Eq then Some (add (p1,minus_num (a // b)) (p2,Int 1), {coeffs = add (v1,minus_num (a// b)) (v2 ,Int 1) ; op = add_op op1 op2; cst = n1 // (minus_num (a// b)) +/ n2 // (Int 1)}) else if op2 = Eq then Some (add (p2,minus_num (b // a)) (p1,Int 1), {coeffs = add (v2,minus_num (b// a)) (v1 ,Int 1) ; op = add_op op1 op2; cst = n2 // (minus_num (b// a)) +/ n1 // (Int 1)}) else None (* op2 could be Eq ... this might happen *) let normalise_proofs l = List.fold_left (fun acc (prf,cstr) -> match acc with | Inr _ -> acc (* I already found a contradiction *) | Inl acc -> match norm_cstr cstr 0 with | Redundant -> Inl acc | Contradiction -> Inr (prf,cstr) | Cstr(v,info) -> Inl ((prf,cstr,v,info)::acc)) (Inl []) l type oproof = (vector * cstr_compat * num) option let merge_proof (oleft:oproof) (prf,cstr,v,info) (oright:oproof) = let (l,r) = info.bound in let keep p ob bd = match ob , bd with | None , None -> None | None , Some b -> Some(prf,cstr,b) | Some _ , None -> ob | Some(prfl,cstrl,bl) , Some b -> if p bl b then Some(prf,cstr, b) else ob in let oleft = keep (<=/) oleft l in let oright = keep (>=/) oright r in (* Now, there might be a contradiction *) match oleft , oright with | None , _ | _ , None -> Inl (oleft,oright) | Some(prfl,cstrl,l) , Some(prfr,cstrr,r) -> if l <=/ r then Inl (oleft,oright) else (* There is a contradiction - it should show up by scaling up the vectors - any pivot should do*) match cstrr.coeffs with | [] -> Inr (add (prfl,Int 1) (prfr,Int 1), cstrr) (* this is wrong *) | (v,_)::_ -> match pivot v (prfl,cstrl) (prfr,cstrr) with | None -> failwith "merge_proof : pivot is not possible" | Some x -> Inr x let mk_proof hyps prf = (* I am keeping list - I might have a proof for the left bound and a proof for the right bound. If I perform aggressive elimination of redundancies, I expect the list to be of length at most 2. For each proof list, all the vectors should be of the form a.v for different constants a. *) let rec mk_proof prf = match prf with | Hyp i -> [ ([i, Int 1] , List.nth hyps i) ] | Elim(v,prf1,prf2) -> let prfsl = mk_proof prf1 and prfsr = mk_proof prf2 in (* I take only the pairs for which the elimination is meaningfull *) forall_pairs (pivot v) prfsl prfsr | And(prf1,prf2) -> let prfsl1 = mk_proof prf1 and prfsl2 = mk_proof prf2 in (* detect trivial redundancies and contradictions *) match normalise_proofs (prfsl1@prfsl2) with | Inr x -> [x] (* This is a contradiction - this should be the end of the proof *) | Inl l -> (* All the vectors are the same *) let prfs = List.fold_left (fun acc e -> match acc with | Inr _ -> acc (* I have a contradiction *) | Inl (oleft,oright) -> merge_proof oleft e oright) (Inl(None,None)) l in match prfs with | Inr x -> [x] | Inl (oleft,oright) -> match oleft , oright with | None , None -> [] | None , Some(prf,cstr,_) | Some(prf,cstr,_) , None -> [prf,cstr] | Some(prf1,cstr1,_) , Some(prf2,cstr2,_) -> [prf1,cstr1;prf2,cstr2] in mk_proof prf end coq-8.4pl4/plugins/micromega/OrderedRing.v0000644000175000017500000003345212326224777017661 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R -> R) (ropp : R -> R). Variable req rle rlt : R -> R -> Prop. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (rplus x y). Notation "x * y " := (rtimes x y). Notation "x - y " := (rminus x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). Notation "x ~= y" := (~ req x y). Notation "x <= y" := (rle x y). Notation "x < y" := (rlt x y). Record SOR : Type := mk_SOR_theory { SORsetoid : Setoid_Theory R req; SORplus_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2; SORtimes_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2; SORopp_wd : forall x1 x2, x1 == x2 -> -x1 == -x2; SORle_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 <= y1 <-> x2 <= y2); SORlt_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 < y1 <-> x2 < y2); SORrt : ring_theory rO rI rplus rtimes rminus ropp req; SORle_refl : forall n : R, n <= n; SORle_antisymm : forall n m : R, n <= m -> m <= n -> n == m; SORle_trans : forall n m p : R, n <= m -> m <= p -> n <= p; SORlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m; SORlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n; SORplus_le_mono_l : forall n m p : R, n <= m -> p + n <= p + m; SORtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m; SORneq_0_1 : 0 ~= 1 }. (* We cannot use Relation_Definitions.order.ord_antisym and Relations_1.Antisymmetric because they refer to Leibniz equality *) End DEFINITIONS. Section STRICT_ORDERED_RING. Variable R : Type. Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R). Variable req rle rlt : R -> R -> Prop. Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (rplus x y). Notation "x * y " := (rtimes x y). Notation "x - y " := (rminus x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). Notation "x ~= y" := (~ req x y). Notation "x <= y" := (rle x y). Notation "x < y" := (rlt x y). Add Relation R req reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ ) symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ ) transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ ) as sor_setoid. Add Morphism rplus with signature req ==> req ==> req as rplus_morph. Proof. exact sor.(SORplus_wd). Qed. Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. Proof. exact sor.(SORtimes_wd). Qed. Add Morphism ropp with signature req ==> req as ropp_morph. Proof. exact sor.(SORopp_wd). Qed. Add Morphism rle with signature req ==> req ==> iff as rle_morph. Proof. exact sor.(SORle_wd). Qed. Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. Proof. exact sor.(SORlt_wd). Qed. Add Ring SOR : sor.(SORrt). Add Morphism rminus with signature req ==> req ==> req as rminus_morph. Proof. intros x1 x2 H1 y1 y2 H2. rewrite (sor.(SORrt).(Rsub_def) x1 y1). rewrite (sor.(SORrt).(Rsub_def) x2 y2). rewrite H1; now rewrite H2. Qed. Theorem Rneq_symm : forall n m : R, n ~= m -> m ~= n. Proof. intros n m H1 H2; rewrite H2 in H1; now apply H1. Qed. (* Propeties of plus, minus and opp *) Theorem Rplus_0_l : forall n : R, 0 + n == n. Proof. intro; ring. Qed. Theorem Rplus_0_r : forall n : R, n + 0 == n. Proof. intro; ring. Qed. Theorem Rtimes_0_r : forall n : R, n * 0 == 0. Proof. intro; ring. Qed. Theorem Rplus_comm : forall n m : R, n + m == m + n. Proof. intros; ring. Qed. Theorem Rtimes_0_l : forall n : R, 0 * n == 0. Proof. intro; ring. Qed. Theorem Rtimes_comm : forall n m : R, n * m == m * n. Proof. intros; ring. Qed. Theorem Rminus_eq_0 : forall n m : R, n - m == 0 <-> n == m. Proof. intros n m. split; intro H. setoid_replace n with ((n - m) + m) by ring. rewrite H. now rewrite Rplus_0_l. rewrite H; ring. Qed. Theorem Rplus_cancel_l : forall n m p : R, p + n == p + m <-> n == m. Proof. intros n m p; split; intro H. setoid_replace n with (- p + (p + n)) by ring. setoid_replace m with (- p + (p + m)) by ring. now rewrite H. now rewrite H. Qed. (* Relations *) Theorem Rle_refl : forall n : R, n <= n. Proof sor.(SORle_refl). Theorem Rle_antisymm : forall n m : R, n <= m -> m <= n -> n == m. Proof sor.(SORle_antisymm). Theorem Rle_trans : forall n m p : R, n <= m -> m <= p -> n <= p. Proof sor.(SORle_trans). Theorem Rlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n. Proof sor.(SORlt_trichotomy). Theorem Rlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m. Proof sor.(SORlt_le_neq). Theorem Rneq_0_1 : 0 ~= 1. Proof sor.(SORneq_0_1). Theorem Req_em : forall n m : R, n == m \/ n ~= m. Proof. intros n m. destruct (Rlt_trichotomy n m) as [H | [H | H]]; try rewrite Rlt_le_neq in H. right; now destruct H. now left. right; apply Rneq_symm; now destruct H. Qed. Theorem Req_dne : forall n m : R, ~ ~ n == m <-> n == m. Proof. intros n m; destruct (Req_em n m) as [H | H]. split; auto. split. intro H1; false_hyp H H1. auto. Qed. Theorem Rle_lt_eq : forall n m : R, n <= m <-> n < m \/ n == m. Proof. intros n m; rewrite Rlt_le_neq. split; [intro H | intros [[H1 H2] | H]]. destruct (Req_em n m) as [H1 | H1]. now right. left; now split. assumption. rewrite H; apply Rle_refl. Qed. Ltac le_less := rewrite Rle_lt_eq; left; try assumption. Ltac le_equal := rewrite Rle_lt_eq; right; try reflexivity; try assumption. Ltac le_elim H := rewrite Rle_lt_eq in H; destruct H as [H | H]. Theorem Rlt_trans : forall n m p : R, n < m -> m < p -> n < p. Proof. intros n m p; repeat rewrite Rlt_le_neq; intros [H1 H2] [H3 H4]; split. now apply Rle_trans with m. intro H. rewrite H in H1. pose proof (Rle_antisymm H3 H1). now apply H4. Qed. Theorem Rle_lt_trans : forall n m p : R, n <= m -> m < p -> n < p. Proof. intros n m p H1 H2; le_elim H1. now apply Rlt_trans with (m := m). now rewrite H1. Qed. Theorem Rlt_le_trans : forall n m p : R, n < m -> m <= p -> n < p. Proof. intros n m p H1 H2; le_elim H2. now apply Rlt_trans with (m := m). now rewrite <- H2. Qed. Theorem Rle_gt_cases : forall n m : R, n <= m \/ m < n. Proof. intros n m; destruct (Rlt_trichotomy n m) as [H | [H | H]]. left; now le_less. left; now le_equal. now right. Qed. Theorem Rlt_neq : forall n m : R, n < m -> n ~= m. Proof. intros n m; rewrite Rlt_le_neq; now intros [_ H]. Qed. Theorem Rle_ngt : forall n m : R, n <= m <-> ~ m < n. Proof. intros n m; split. intros H H1; assert (H2 : n < n) by now apply Rle_lt_trans with m. now apply (Rlt_neq H2). intro H. destruct (Rle_gt_cases n m) as [H1 | H1]. assumption. false_hyp H1 H. Qed. Theorem Rlt_nge : forall n m : R, n < m <-> ~ m <= n. Proof. intros n m; split. intros H H1; assert (H2 : n < n) by now apply Rlt_le_trans with m. now apply (Rlt_neq H2). intro H. destruct (Rle_gt_cases m n) as [H1 | H1]. false_hyp H1 H. assumption. Qed. (* Plus, minus and order *) Theorem Rplus_le_mono_l : forall n m p : R, n <= m <-> p + n <= p + m. Proof. intros n m p; split. apply sor.(SORplus_le_mono_l). intro H. apply (sor.(SORplus_le_mono_l) (p + n) (p + m) (- p)) in H. setoid_replace (- p + (p + n)) with n in H by ring. setoid_replace (- p + (p + m)) with m in H by ring. assumption. Qed. Theorem Rplus_le_mono_r : forall n m p : R, n <= m <-> n + p <= m + p. Proof. intros n m p; rewrite (Rplus_comm n p); rewrite (Rplus_comm m p). apply Rplus_le_mono_l. Qed. Theorem Rplus_lt_mono_l : forall n m p : R, n < m <-> p + n < p + m. Proof. intros n m p; do 2 rewrite Rlt_le_neq. rewrite Rplus_cancel_l. now rewrite <- Rplus_le_mono_l. Qed. Theorem Rplus_lt_mono_r : forall n m p : R, n < m <-> n + p < m + p. Proof. intros n m p. rewrite (Rplus_comm n p); rewrite (Rplus_comm m p); apply Rplus_lt_mono_l. Qed. Theorem Rplus_lt_mono : forall n m p q : R, n < m -> p < q -> n + p < m + q. Proof. intros n m p q H1 H2. apply Rlt_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_lt_mono_l]. Qed. Theorem Rplus_le_mono : forall n m p q : R, n <= m -> p <= q -> n + p <= m + q. Proof. intros n m p q H1 H2. apply Rle_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_le_mono_l]. Qed. Theorem Rplus_lt_le_mono : forall n m p q : R, n < m -> p <= q -> n + p < m + q. Proof. intros n m p q H1 H2. apply Rlt_le_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_le_mono_l]. Qed. Theorem Rplus_le_lt_mono : forall n m p q : R, n <= m -> p < q -> n + p < m + q. Proof. intros n m p q H1 H2. apply Rle_lt_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_lt_mono_l]. Qed. Theorem Rplus_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n + m. Proof. intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_mono. Qed. Theorem Rplus_pos_nonneg : forall n m : R, 0 < n -> 0 <= m -> 0 < n + m. Proof. intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_le_mono. Qed. Theorem Rplus_nonneg_pos : forall n m : R, 0 <= n -> 0 < m -> 0 < n + m. Proof. intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_lt_mono. Qed. Theorem Rplus_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n + m. Proof. intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_mono. Qed. Theorem Rle_le_minus : forall n m : R, n <= m <-> 0 <= m - n. Proof. intros n m. rewrite (@Rplus_le_mono_r n m (- n)). setoid_replace (n + - n) with 0 by ring. now setoid_replace (m + - n) with (m - n) by ring. Qed. Theorem Rlt_lt_minus : forall n m : R, n < m <-> 0 < m - n. Proof. intros n m. rewrite (@Rplus_lt_mono_r n m (- n)). setoid_replace (n + - n) with 0 by ring. now setoid_replace (m + - n) with (m - n) by ring. Qed. Theorem Ropp_lt_mono : forall n m : R, n < m <-> - m < - n. Proof. intros n m. split; intro H. apply -> (@Rplus_lt_mono_l n m (- n - m)) in H. setoid_replace (- n - m + n) with (- m) in H by ring. now setoid_replace (- n - m + m) with (- n) in H by ring. apply -> (@Rplus_lt_mono_l (- m) (- n) (n + m)) in H. setoid_replace (n + m + - m) with n in H by ring. now setoid_replace (n + m + - n) with m in H by ring. Qed. Theorem Ropp_pos_neg : forall n : R, 0 < - n <-> n < 0. Proof. intro n; rewrite (Ropp_lt_mono n 0). now setoid_replace (- 0) with 0 by ring. Qed. (* Times and order *) Theorem Rtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m. Proof sor.(SORtimes_pos_pos). Theorem Rtimes_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n * m. Proof. intros n m H1 H2. le_elim H1. le_elim H2. le_less; now apply Rtimes_pos_pos. rewrite <- H2; rewrite Rtimes_0_r; le_equal. rewrite <- H1; rewrite Rtimes_0_l; le_equal. Qed. Theorem Rtimes_pos_neg : forall n m : R, 0 < n -> m < 0 -> n * m < 0. Proof. intros n m H1 H2. apply -> Ropp_pos_neg. setoid_replace (- (n * m)) with (n * (- m)) by ring. apply Rtimes_pos_pos. assumption. now apply <- Ropp_pos_neg. Qed. Theorem Rtimes_neg_neg : forall n m : R, n < 0 -> m < 0 -> 0 < n * m. Proof. intros n m H1 H2. setoid_replace (n * m) with ((- n) * (- m)) by ring. apply Rtimes_pos_pos; now apply <- Ropp_pos_neg. Qed. Theorem Rtimes_square_nonneg : forall n : R, 0 <= n * n. Proof. intro n; destruct (Rlt_trichotomy 0 n) as [H | [H | H]]. le_less; now apply Rtimes_pos_pos. rewrite <- H, Rtimes_0_l; le_equal. le_less; now apply Rtimes_neg_neg. Qed. Theorem Rtimes_neq_0 : forall n m : R, n ~= 0 /\ m ~= 0 -> n * m ~= 0. Proof. intros n m [H1 H2]. destruct (Rlt_trichotomy n 0) as [H3 | [H3 | H3]]; destruct (Rlt_trichotomy m 0) as [H4 | [H4 | H4]]; try (false_hyp H3 H1); try (false_hyp H4 H2). apply Rneq_symm. apply Rlt_neq. now apply Rtimes_neg_neg. apply Rlt_neq. rewrite Rtimes_comm. now apply Rtimes_pos_neg. apply Rlt_neq. now apply Rtimes_pos_neg. apply Rneq_symm. apply Rlt_neq. now apply Rtimes_pos_pos. Qed. (* The following theorems are used to build a morphism from Z to R and prove its properties in ZCoeff.v. They are not used in RingMicromega.v. *) (* Surprisingly, multilication is needed to prove the following theorem *) Theorem Ropp_neg_pos : forall n : R, - n < 0 <-> 0 < n. Proof. intro n; setoid_replace n with (- - n) by ring. rewrite Ropp_pos_neg. now setoid_replace (- - n) with n by ring. Qed. Theorem Rlt_0_1 : 0 < 1. Proof. apply <- Rlt_le_neq. split. setoid_replace 1 with (1 * 1) by ring. apply Rtimes_square_nonneg. apply Rneq_0_1. Qed. Theorem Rlt_succ_r : forall n : R, n < 1 + n. Proof. intro n. rewrite <- (Rplus_0_l n); setoid_replace (1 + (0 + n)) with (1 + n) by ring. apply -> Rplus_lt_mono_r. apply Rlt_0_1. Qed. Theorem Rlt_lt_succ : forall n m : R, n < m -> n < 1 + m. Proof. intros n m H; apply Rlt_trans with m. assumption. apply Rlt_succ_r. Qed. (*Theorem Rtimes_lt_mono_pos_l : forall n m p : R, 0 < p -> n < m -> p * n < p * m. Proof. intros n m p H1 H2. apply <- Rlt_lt_minus. setoid_replace (p * m - p * n) with (p * (m - n)) by ring. apply Rtimes_pos_pos. assumption. now apply -> Rlt_lt_minus. Qed.*) End STRICT_ORDERED_RING. coq-8.4pl4/plugins/micromega/g_micromega.ml40000644000175000017500000000440312326224777020147 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* anomaly "Unevaluated or_var variable" | ArgArg x -> x TACTIC EXTEND PsatzZ | [ "psatz_Z" int_or_var(i) ] -> [ Coq_micromega.psatz_Z (out_arg i) ] | [ "psatz_Z" ] -> [ Coq_micromega.psatz_Z (-1) ] END TACTIC EXTEND ZOmicron [ "xlia" ] -> [ Coq_micromega.xlia] END TACTIC EXTEND Nlia [ "xnlia" ] -> [ Coq_micromega.xnlia] END TACTIC EXTEND Sos_Z | [ "sos_Z" ] -> [ Coq_micromega.sos_Z] END TACTIC EXTEND Sos_Q | [ "sos_Q" ] -> [ Coq_micromega.sos_Q] END TACTIC EXTEND Sos_R | [ "sos_R" ] -> [ Coq_micromega.sos_R] END TACTIC EXTEND Omicron [ "psatzl_Z" ] -> [ Coq_micromega.psatzl_Z] END TACTIC EXTEND QOmicron [ "psatzl_Q" ] -> [ Coq_micromega.psatzl_Q] END TACTIC EXTEND ROmicron [ "psatzl_R" ] -> [ Coq_micromega.psatzl_R] END TACTIC EXTEND RMicromega | [ "psatz_R" int_or_var(i) ] -> [ Coq_micromega.psatz_R (out_arg i) ] | [ "psatz_R" ] -> [ Coq_micromega.psatz_R (-1) ] END TACTIC EXTEND QMicromega | [ "psatz_Q" int_or_var(i) ] -> [ Coq_micromega.psatz_Q (out_arg i) ] | [ "psatz_Q" ] -> [ Coq_micromega.psatz_Q (-1) ] END coq-8.4pl4/plugins/micromega/sos_lib.ml0000644000175000017500000005347712326224777017263 0ustar stephsteph(* ========================================================================= *) (* - This code originates from John Harrison's HOL LIGHT 2.30 *) (* (see file LICENSE.sos for license, copyright and disclaimer) *) (* This code is the HOL LIGHT library code used by sos.ml *) (* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL *) (* independent bits *) (* - Frédéric Besson (fbesson@irisa.fr) is using it to feed micromega *) (* ========================================================================= *) open Sos_types open Num open List let debugging = ref false;; (* ------------------------------------------------------------------------- *) (* Comparisons that are reflexive on NaN and also short-circuiting. *) (* ------------------------------------------------------------------------- *) let (=?) = fun x y -> Pervasives.compare x y = 0;; let ( Pervasives.compare x y < 0;; let (<=?) = fun x y -> Pervasives.compare x y <= 0;; let (>?) = fun x y -> Pervasives.compare x y > 0;; let (>=?) = fun x y -> Pervasives.compare x y >= 0;; (* ------------------------------------------------------------------------- *) (* Combinators. *) (* ------------------------------------------------------------------------- *) let (o) = fun f g x -> f(g x);; (* ------------------------------------------------------------------------- *) (* Some useful functions on "num" type. *) (* ------------------------------------------------------------------------- *) let num_0 = Int 0 and num_1 = Int 1 and num_2 = Int 2 and num_10 = Int 10;; let pow2 n = power_num num_2 (Int n);; let pow10 n = power_num num_10 (Int n);; let numdom r = let r' = Ratio.normalize_ratio (ratio_of_num r) in num_of_big_int(Ratio.numerator_ratio r'), num_of_big_int(Ratio.denominator_ratio r');; let numerator = (o) fst numdom and denominator = (o) snd numdom;; let gcd_num n1 n2 = num_of_big_int(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2));; let lcm_num x y = if x =/ num_0 & y =/ num_0 then num_0 else abs_num((x */ y) // gcd_num x y);; (* ------------------------------------------------------------------------- *) (* List basics. *) (* ------------------------------------------------------------------------- *) let rec el n l = if n = 0 then hd l else el (n - 1) (tl l);; (* ------------------------------------------------------------------------- *) (* Various versions of list iteration. *) (* ------------------------------------------------------------------------- *) let rec itlist f l b = match l with [] -> b | (h::t) -> f h (itlist f t b);; let rec end_itlist f l = match l with [] -> failwith "end_itlist" | [x] -> x | (h::t) -> f h (end_itlist f t);; let rec itlist2 f l1 l2 b = match (l1,l2) with ([],[]) -> b | (h1::t1,h2::t2) -> f h1 h2 (itlist2 f t1 t2 b) | _ -> failwith "itlist2";; (* ------------------------------------------------------------------------- *) (* All pairs arising from applying a function over two lists. *) (* ------------------------------------------------------------------------- *) let rec allpairs f l1 l2 = match l1 with h1::t1 -> itlist (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2) | [] -> [];; (* ------------------------------------------------------------------------- *) (* String operations (surely there is a better way...) *) (* ------------------------------------------------------------------------- *) let implode l = itlist (^) l "";; let explode s = let rec exap n l = if n < 0 then l else exap (n - 1) ((String.sub s n 1)::l) in exap (String.length s - 1) [];; (* ------------------------------------------------------------------------- *) (* Attempting function or predicate applications. *) (* ------------------------------------------------------------------------- *) let can f x = try (f x; true) with Failure _ -> false;; (* ------------------------------------------------------------------------- *) (* Repetition of a function. *) (* ------------------------------------------------------------------------- *) let rec funpow n f x = if n < 1 then x else funpow (n-1) f (f x);; (* ------------------------------------------------------------------------- *) (* Replication and sequences. *) (* ------------------------------------------------------------------------- *) let rec replicate x n = if n < 1 then [] else x::(replicate x (n - 1));; let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);; (* ------------------------------------------------------------------------- *) (* Various useful list operations. *) (* ------------------------------------------------------------------------- *) let rec forall p l = match l with [] -> true | h::t -> p(h) & forall p t;; let rec tryfind f l = match l with [] -> failwith "tryfind" | (h::t) -> try f h with Failure _ -> tryfind f t;; let index x = let rec ind n l = match l with [] -> failwith "index" | (h::t) -> if x =? h then n else ind (n + 1) t in ind 0;; (* ------------------------------------------------------------------------- *) (* "Set" operations on lists. *) (* ------------------------------------------------------------------------- *) let rec mem x lis = match lis with [] -> false | (h::t) -> x =? h or mem x t;; let insert x l = if mem x l then l else x::l;; let union l1 l2 = itlist insert l1 l2;; let subtract l1 l2 = filter (fun x -> not (mem x l2)) l1;; (* ------------------------------------------------------------------------- *) (* Merging and bottom-up mergesort. *) (* ------------------------------------------------------------------------- *) let rec merge ord l1 l2 = match l1 with [] -> l2 | h1::t1 -> match l2 with [] -> l1 | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2) else h2::(merge ord l1 t2);; (* ------------------------------------------------------------------------- *) (* Common measure predicates to use with "sort". *) (* ------------------------------------------------------------------------- *) let increasing f x y = f x ? f y;; (* ------------------------------------------------------------------------- *) (* Zipping, unzipping etc. *) (* ------------------------------------------------------------------------- *) let rec zip l1 l2 = match (l1,l2) with ([],[]) -> [] | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2) | _ -> failwith "zip";; let rec unzip = function [] -> [],[] | ((a,b)::rest) -> let alist,blist = unzip rest in (a::alist,b::blist);; (* ------------------------------------------------------------------------- *) (* Iterating functions over lists. *) (* ------------------------------------------------------------------------- *) let rec do_list f l = match l with [] -> () | (h::t) -> (f h; do_list f t);; (* ------------------------------------------------------------------------- *) (* Sorting. *) (* ------------------------------------------------------------------------- *) let rec sort cmp lis = match lis with [] -> [] | piv::rest -> let r,l = partition (cmp piv) rest in (sort cmp l) @ (piv::(sort cmp r));; (* ------------------------------------------------------------------------- *) (* Removing adjacent (NB!) equal elements from list. *) (* ------------------------------------------------------------------------- *) let rec uniq l = match l with x::(y::_ as t) -> let t' = uniq t in if x =? y then t' else if t'==t then l else x::t' | _ -> l;; (* ------------------------------------------------------------------------- *) (* Convert list into set by eliminating duplicates. *) (* ------------------------------------------------------------------------- *) let setify s = uniq (sort (<=?) s);; (* ------------------------------------------------------------------------- *) (* Polymorphic finite partial functions via Patricia trees. *) (* *) (* The point of this strange representation is that it is canonical (equal *) (* functions have the same encoding) yet reasonably efficient on average. *) (* *) (* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10). *) (* ------------------------------------------------------------------------- *) type ('a,'b)func = Empty | Leaf of int * ('a*'b)list | Branch of int * int * ('a,'b)func * ('a,'b)func;; (* ------------------------------------------------------------------------- *) (* Undefined function. *) (* ------------------------------------------------------------------------- *) let undefined = Empty;; (* ------------------------------------------------------------------------- *) (* In case of equality comparison worries, better use this. *) (* ------------------------------------------------------------------------- *) let is_undefined f = match f with Empty -> true | _ -> false;; (* ------------------------------------------------------------------------- *) (* Operation analagous to "map" for lists. *) (* ------------------------------------------------------------------------- *) let mapf = let rec map_list f l = match l with [] -> [] | (x,y)::t -> (x,f(y))::(map_list f t) in let rec mapf f t = match t with Empty -> Empty | Leaf(h,l) -> Leaf(h,map_list f l) | Branch(p,b,l,r) -> Branch(p,b,mapf f l,mapf f r) in mapf;; (* ------------------------------------------------------------------------- *) (* Operations analogous to "fold" for lists. *) (* ------------------------------------------------------------------------- *) let foldl = let rec foldl_list f a l = match l with [] -> a | (x,y)::t -> foldl_list f (f a x y) t in let rec foldl f a t = match t with Empty -> a | Leaf(h,l) -> foldl_list f a l | Branch(p,b,l,r) -> foldl f (foldl f a l) r in foldl;; let foldr = let rec foldr_list f l a = match l with [] -> a | (x,y)::t -> f x y (foldr_list f t a) in let rec foldr f t a = match t with Empty -> a | Leaf(h,l) -> foldr_list f l a | Branch(p,b,l,r) -> foldr f l (foldr f r a) in foldr;; (* ------------------------------------------------------------------------- *) (* Redefinition and combination. *) (* ------------------------------------------------------------------------- *) let (|->),combine = let ldb x y = let z = x lxor y in z land (-z) in let newbranch p1 t1 p2 t2 = let b = ldb p1 p2 in let p = p1 land (b - 1) in if p1 land b = 0 then Branch(p,b,t1,t2) else Branch(p,b,t2,t1) in let rec define_list (x,y as xy) l = match l with (a,b as ab)::t -> if x =? a then xy::t else if x [xy] and combine_list op z l1 l2 = match (l1,l2) with [],_ -> l2 | _,[] -> l1 | ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) -> if x1 ) x y = let k = Hashtbl.hash x in let rec upd t = match t with Empty -> Leaf (k,[x,y]) | Leaf(h,l) -> if h = k then Leaf(h,define_list (x,y) l) else newbranch h t k (Leaf(k,[x,y])) | Branch(p,b,l,r) -> if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y])) else if k land b = 0 then Branch(p,b,upd l,r) else Branch(p,b,l,upd r) in upd in let rec combine op z t1 t2 = match (t1,t2) with Empty,_ -> t2 | _,Empty -> t1 | Leaf(h1,l1),Leaf(h2,l2) -> if h1 = h2 then let l = combine_list op z l1 l2 in if l = [] then Empty else Leaf(h1,l) else newbranch h1 t1 h2 t2 | (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) | (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) -> if k land (b - 1) = p then if k land b = 0 then let l' = combine op z lf l in if is_undefined l' then r else Branch(p,b,l',r) else let r' = combine op z lf r in if is_undefined r' then l else Branch(p,b,l,r') else newbranch k lf p br | Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) -> if b1 < b2 then if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2 else if p2 land b1 = 0 then let l = combine op z l1 t2 in if is_undefined l then r1 else Branch(p1,b1,l,r1) else let r = combine op z r1 t2 in if is_undefined r then l1 else Branch(p1,b1,l1,r) else if b2 < b1 then if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2 else if p1 land b2 = 0 then let l = combine op z t1 l2 in if is_undefined l then r2 else Branch(p2,b2,l,r2) else let r = combine op z t1 r2 in if is_undefined r then l2 else Branch(p2,b2,l2,r) else if p1 = p2 then let l = combine op z l1 l2 and r = combine op z r1 r2 in if is_undefined l then r else if is_undefined r then l else Branch(p1,b1,l,r) else newbranch p1 t1 p2 t2 in (|->),combine;; (* ------------------------------------------------------------------------- *) (* Special case of point function. *) (* ------------------------------------------------------------------------- *) let (|=>) = fun x y -> (x |-> y) undefined;; (* ------------------------------------------------------------------------- *) (* Grab an arbitrary element. *) (* ------------------------------------------------------------------------- *) let rec choose t = match t with Empty -> failwith "choose: completely undefined function" | Leaf(h,l) -> hd l | Branch(b,p,t1,t2) -> choose t1;; (* ------------------------------------------------------------------------- *) (* Application. *) (* ------------------------------------------------------------------------- *) let applyd = let rec apply_listd l d x = match l with (a,b)::t -> if x =? a then b else if x >? a then apply_listd t d x else d x | [] -> d x in fun f d x -> let k = Hashtbl.hash x in let rec look t = match t with Leaf(h,l) when h = k -> apply_listd l d x | Branch(p,b,l,r) -> look (if k land b = 0 then l else r) | _ -> d x in look f;; let apply f = applyd f (fun x -> failwith "apply");; let tryapplyd f a d = applyd f (fun x -> d) a;; let defined f x = try apply f x; true with Failure _ -> false;; (* ------------------------------------------------------------------------- *) (* Undefinition. *) (* ------------------------------------------------------------------------- *) let undefine = let rec undefine_list x l = match l with (a,b as ab)::t -> if x =? a then t else if x [] in fun x -> let k = Hashtbl.hash x in let rec und t = match t with Leaf(h,l) when h = k -> let l' = undefine_list x l in if l' == l then t else if l' = [] then Empty else Leaf(h,l') | Branch(p,b,l,r) when k land (b - 1) = p -> if k land b = 0 then let l' = und l in if l' == l then t else if is_undefined l' then r else Branch(p,b,l',r) else let r' = und r in if r' == r then t else if is_undefined r' then l else Branch(p,b,l,r') | _ -> t in und;; (* ------------------------------------------------------------------------- *) (* Mapping to sorted-list representation of the graph, domain and range. *) (* ------------------------------------------------------------------------- *) let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);; let dom f = setify(foldl (fun a x y -> x::a) [] f);; let ran f = setify(foldl (fun a x y -> y::a) [] f);; (* ------------------------------------------------------------------------- *) (* More parser basics. *) (* ------------------------------------------------------------------------- *) exception Noparse;; let isspace,issep,isbra,issymb,isalpha,isnum,isalnum = let charcode s = Char.code(String.get s 0) in let spaces = " \t\n\r" and separators = ",;" and brackets = "()[]{}" and symbs = "\\!@#$%^&*-+|\\<=>/?~.:" and alphas = "'abcdefghijklmnopqrstuvwxyz_ABCDEFGHIJKLMNOPQRSTUVWXYZ" and nums = "0123456789" in let allchars = spaces^separators^brackets^symbs^alphas^nums in let csetsize = itlist ((o) max charcode) (explode allchars) 256 in let ctable = Array.make csetsize 0 in do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces); do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators); do_list (fun c -> Array.set ctable (charcode c) 4) (explode brackets); do_list (fun c -> Array.set ctable (charcode c) 8) (explode symbs); do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas); do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums); let isspace c = Array.get ctable (charcode c) = 1 and issep c = Array.get ctable (charcode c) = 2 and isbra c = Array.get ctable (charcode c) = 4 and issymb c = Array.get ctable (charcode c) = 8 and isalpha c = Array.get ctable (charcode c) = 16 and isnum c = Array.get ctable (charcode c) = 32 and isalnum c = Array.get ctable (charcode c) >= 16 in isspace,issep,isbra,issymb,isalpha,isnum,isalnum;; let (||) parser1 parser2 input = try parser1 input with Noparse -> parser2 input;; let (++) parser1 parser2 input = let result1,rest1 = parser1 input in let result2,rest2 = parser2 rest1 in (result1,result2),rest2;; let rec many prs input = try let result,next = prs input in let results,rest = many prs next in (result::results),rest with Noparse -> [],input;; let (>>) prs treatment input = let result,rest = prs input in treatment(result),rest;; let fix err prs input = try prs input with Noparse -> failwith (err ^ " expected");; let rec listof prs sep err = prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);; let possibly prs input = try let x,rest = prs input in [x],rest with Noparse -> [],input;; let some p = function [] -> raise Noparse | (h::t) -> if p h then (h,t) else raise Noparse;; let a tok = some (fun item -> item = tok);; let rec atleast n prs i = (if n <= 0 then many prs else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;; let finished input = if input = [] then 0,input else failwith "Unparsed input";; (* ------------------------------------------------------------------------- *) let temp_path = ref Filename.temp_dir_name;; (* ------------------------------------------------------------------------- *) (* Convenient conversion between files and (lists of) strings. *) (* ------------------------------------------------------------------------- *) let strings_of_file filename = let fd = try Pervasives.open_in filename with Sys_error _ -> failwith("strings_of_file: can't open "^filename) in let rec suck_lines acc = try let l = Pervasives.input_line fd in suck_lines (l::acc) with End_of_file -> rev acc in let data = suck_lines [] in (Pervasives.close_in fd; data);; let string_of_file filename = end_itlist (fun s t -> s^"\n"^t) (strings_of_file filename);; let file_of_string filename s = let fd = Pervasives.open_out filename in output_string fd s; close_out fd;; (* ------------------------------------------------------------------------- *) (* Iterative deepening. *) (* ------------------------------------------------------------------------- *) let rec deepen f n = try (*print_string "Searching with depth limit "; print_int n; print_newline();*) f n with Failure _ -> deepen f (n + 1);; exception TooDeep let deepen_until limit f n = match compare limit 0 with | 0 -> raise TooDeep | -1 -> deepen f n | _ -> let rec d_until f n = try(* if !debugging then (print_string "Searching with depth limit "; print_int n; print_newline()) ;*) f n with Failure x -> (*if !debugging then (Printf.printf "solver error : %s\n" x) ; *) if n = limit then raise TooDeep else d_until f (n + 1) in d_until f n coq-8.4pl4/plugins/micromega/Env.v0000644000175000017500000000604412326224777016202 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* D. Definition jump (j:positive) (e:Env) := fun x => e (x+j). Definition nth (n:positive) (e:Env) := e n. Definition hd (e:Env) := nth 1 e. Definition tail (e:Env) := jump 1 e. Lemma jump_add i j l x : jump (i + j) l x = jump i (jump j l) x. Proof. unfold jump. f_equal. apply Pos.add_assoc. Qed. Lemma jump_simpl p l x : jump p l x = match p with | xH => tail l x | xO p => jump p (jump p l) x | xI p => jump p (jump p (tail l)) x end. Proof. destruct p; unfold tail; rewrite <- ?jump_add; f_equal; now rewrite Pos.add_diag. Qed. Lemma jump_tl j l x : tail (jump j l) x = jump j (tail l) x. Proof. unfold tail. rewrite <- !jump_add. f_equal. apply Pos.add_comm. Qed. Lemma jump_succ j l x : jump (Pos.succ j) l x = jump 1 (jump j l) x. Proof. rewrite <- jump_add. f_equal. symmetry. apply Pos.add_1_l. Qed. Lemma jump_pred_double i l x : jump (Pos.pred_double i) (tail l) x = jump i (jump i l) x. Proof. unfold tail. rewrite <- !jump_add. f_equal. now rewrite Pos.add_1_r, Pos.succ_pred_double, Pos.add_diag. Qed. Lemma nth_spec p l : nth p l = match p with | xH => hd l | xO p => nth p (jump p l) | xI p => nth p (jump p (tail l)) end. Proof. unfold hd, nth, tail, jump. destruct p; f_equal; now rewrite Pos.add_diag. Qed. Lemma nth_jump p l : nth p (tail l) = hd (jump p l). Proof. unfold hd, nth, tail, jump. f_equal. apply Pos.add_comm. Qed. Lemma nth_pred_double p l : nth (Pos.pred_double p) (tail l) = nth p (jump p l). Proof. unfold nth, tail, jump. f_equal. now rewrite Pos.add_1_r, Pos.succ_pred_double, Pos.add_diag. Qed. End S. Ltac jump_simpl := repeat match goal with | |- appcontext [jump xH] => rewrite (jump_simpl xH) | |- appcontext [jump (xO ?p)] => rewrite (jump_simpl (xO p)) | |- appcontext [jump (xI ?p)] => rewrite (jump_simpl (xI p)) end. coq-8.4pl4/plugins/micromega/vo.itarget0000644000175000017500000000023212326224777017261 0ustar stephstephCheckerMaker.vo EnvRing.vo Env.vo OrderedRing.vo Psatz.vo QMicromega.vo Refl.vo RingMicromega.vo RMicromega.vo Tauto.vo VarMap.vo ZCoeff.vo ZMicromega.vo coq-8.4pl4/plugins/micromega/CheckerMaker.v0000644000175000017500000001144012326224777017772 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Formula -> Prop. Variable Formula' : Type. Variable eval' : Env -> Formula' -> Prop. Variable normalise : Formula -> Formula'. Variable negate : Formula -> Formula'. Hypothesis normalise_sound : forall (env : Env) (t : Formula), eval env t -> eval' env (normalise t). Hypothesis negate_correct : forall (env : Env) (t : Formula), eval env t <-> ~ (eval' env (negate t)). Variable Witness : Type. Variable check_formulas' : list Formula' -> Witness -> bool. Hypothesis check_formulas'_sound : forall (l : list Formula') (w : Witness), check_formulas' l w = true -> forall env : Env, make_impl (eval' env) l False. Definition normalise_list : list Formula -> list Formula' := map normalise. Definition negate_list : list Formula -> list Formula' := map negate. Definition check_formulas (l : list Formula) (w : Witness) : bool := check_formulas' (map normalise l) w. (* Contraposition of normalise_sound for lists *) Lemma normalise_sound_contr : forall (env : Env) (l : list Formula), make_impl (eval' env) (map normalise l) False -> make_impl (eval env) l False. Proof. intros env l; induction l as [| t l IH]; simpl in *. trivial. intros H1 H2. apply IH. apply H1. now apply normalise_sound. Qed. Theorem check_formulas_sound : forall (l : list Formula) (w : Witness), check_formulas l w = true -> forall env : Env, make_impl (eval env) l False. Proof. unfold check_formulas; intros l w H env. destruct l as [| t l]; simpl in *. pose proof (check_formulas'_sound H env) as H1; now simpl in H1. intro H1. apply normalise_sound in H1. pose proof (check_formulas'_sound H env) as H2; simpl in H2. apply H2 in H1. now apply normalise_sound_contr. Qed. (* In check_conj_formulas', t2 is supposed to be a list of negations of formulas. If, for example, t1 = [A1, A2] and t2 = [~ B1, ~ B2], then check_conj_formulas' checks that each of [~ B1, A1, A2] and [~ B2, A1, A2] is inconsistent. This means that A1 /\ A2 -> B1 and A1 /\ A2 -> B1, i.e., that A1 /\ A2 -> B1 /\ B2. *) Fixpoint check_conj_formulas' (t1 : list Formula') (wits : list Witness) (t2 : list Formula') {struct wits} : bool := match t2 with | nil => true | t':: rt2 => match wits with | nil => false | w :: rwits => match check_formulas' (t':: t1) w with | true => check_conj_formulas' t1 rwits rt2 | false => false end end end. (* checks whether the conjunction of t1 implies the conjunction of t2 *) Definition check_conj_formulas (t1 : list Formula) (wits : list Witness) (t2 : list Formula) : bool := check_conj_formulas' (normalise_list t1) wits (negate_list t2). Theorem check_conj_formulas_sound : forall (t1 : list Formula) (t2 : list Formula) (wits : list Witness), check_conj_formulas t1 wits t2 = true -> forall env : Env, make_impl (eval env) t1 (make_conj (eval env) t2). Proof. intro t1; induction t2 as [| a2 t2' IH]. intros; apply make_impl_true. intros wits H env. unfold check_conj_formulas in H; simpl in H. destruct wits as [| w ws]; simpl in H. discriminate. case_eq (check_formulas' (negate a2 :: normalise_list t1) w); intro H1; rewrite H1 in H; [| discriminate]. assert (H2 : make_impl (eval' env) (negate a2 :: normalise_list t1) False) by now apply check_formulas'_sound with (w := w). clear H1. pose proof (IH ws H env) as H1. simpl in H2. assert (H3 : eval' env (negate a2) -> make_impl (eval env) t1 False) by auto using normalise_sound_contr. clear H2. rewrite <- make_conj_impl in *. rewrite make_conj_cons. intro H2. split. apply <- negate_correct. intro; now elim H3. exact (H1 H2). Qed. End CheckerMaker. *)coq-8.4pl4/plugins/micromega/polynomial.ml0000644000175000017500000004573312326224777020010 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ) = add_num let (<->) = minus_num let (<*>) = mult_num module Monomial : sig type t val const : t val is_const : t -> bool val var : var -> t val is_var : t -> bool val find : var -> t -> int val mult : var -> t -> t val prod : t -> t -> t val exp : t -> int -> t val div : t -> t -> t * int val compare : t -> t -> int val pp : out_channel -> t -> unit val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a val sqrt : t -> t option end = struct (* A monomial is represented by a multiset of variables *) module Map = Map.Make(struct type t = var let compare = Pervasives.compare end) open Map type t = int Map.t let pp o m = Map.iter (fun k v -> if v = 1 then Printf.fprintf o "x%i." k else Printf.fprintf o "x%i^%i." k v) m (* The monomial that corresponds to a constant *) let const = Map.empty let sum_degree m = Map.fold (fun _ n s -> s + n) m 0 (* Total ordering of monomials *) let compare: t -> t -> int = fun m1 m2 -> let s1 = sum_degree m1 and s2 = sum_degree m2 in if s1 = s2 then Map.compare Pervasives.compare m1 m2 else Pervasives.compare s1 s2 let is_const m = (m = Map.empty) (* The monomial 'x' *) let var x = Map.add x 1 Map.empty let is_var m = try not (Map.fold (fun _ i fk -> if fk = true (* first key *) then if i = 1 then false else raise Not_found else raise Not_found) m true) with Not_found -> false let sqrt m = if is_const m then None else try Some (Map.fold (fun v i acc -> let i' = i / 2 in if i mod 2 = 0 then add v i' m else raise Not_found) m const) with Not_found -> None (* Get the degre of a variable in a monomial *) let find x m = try find x m with Not_found -> 0 (* Multiply a monomial by a variable *) let mult x m = add x ( (find x m) + 1) m (* Product of monomials *) let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2 let exp m n = let rec exp acc n = if n = 0 then acc else exp (prod acc m) (n - 1) in exp const n (* [div m1 m2 = mr,n] such that mr * (m2)^n = m1 *) let div m1 m2 = let n = fold (fun x i n -> let i' = find x m1 in let nx = i' / i in min n nx) m2 max_int in let mr = fold (fun x i' m -> let i = find x m2 in let ir = i' - i * n in if ir = 0 then m else add x ir m) m1 empty in (mr,n) let fold = fold end module Poly : (* A polynomial is a map of monomials *) (* This is probably a naive implementation (expected to be fast enough - Coq is probably the bottleneck) *The new ring contribution is using a sparse Horner representation. *) sig type t val get : Monomial.t -> t -> num val variable : var -> t val add : Monomial.t -> num -> t -> t val constant : num -> t val mult : Monomial.t -> num -> t -> t val product : t -> t -> t val addition : t -> t -> t val uminus : t -> t val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a val pp : out_channel -> t -> unit val compare : t -> t -> int val is_null : t -> bool val is_linear : t -> bool end = struct (*normalisation bug : 0*x ... *) module P = Map.Make(Monomial) open P type t = num P.t let pp o p = P.iter (fun k v -> if Monomial.compare Monomial.const k = 0 then Printf.fprintf o "%s " (string_of_num v) else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p (* Get the coefficient of monomial mn *) let get : Monomial.t -> t -> num = fun mn p -> try find mn p with Not_found -> (Int 0) (* The polynomial 1.x *) let variable : var -> t = fun x -> add (Monomial.var x) (Int 1) empty (*The constant polynomial *) let constant : num -> t = fun c -> add (Monomial.const) c empty (* The addition of a monomial *) let add : Monomial.t -> num -> t -> t = fun mn v p -> if sign_num v = 0 then p else let vl = (get mn p) <+> v in if sign_num vl = 0 then remove mn p else add mn vl p (** Design choice: empty is not a polynomial I do not remember why .... **) (* The product by a monomial *) let mult : Monomial.t -> num -> t -> t = fun mn v p -> if sign_num v = 0 then constant (Int 0) else fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty let addition : t -> t -> t = fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2 let product : t -> t -> t = fun p1 p2 -> fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty let uminus : t -> t = fun p -> map (fun v -> minus_num v) p let fold = P.fold let is_null p = fold (fun mn vl b -> b & sign_num vl = 0) p true let compare = compare compare_num let is_linear p = P.fold (fun m _ acc -> acc && (Monomial.is_const m || Monomial.is_var m)) p true (* let is_linear p = let res = is_linear p in Printf.printf "is_linear %a = %b\n" pp p res ; res *) end module Vect = struct (** [t] is the type of vectors. A vector [(x1,v1) ; ... ; (xn,vn)] is such that: - variables indexes are ordered (x1 true | [] , _ -> false | _::_ , [] -> false | (i1,n1)::v1 , (i2,n2)::v2 -> (i1 = i2) && n1 =/ n2 && equal v1 v2 let hash v = let rec hash i = function | [] -> i | (vr,vl)::l -> hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in Hashtbl.hash (hash 0 v ) let null = [] let pp_vect o vect = List.iter (fun (v,n) -> Printf.printf "%sx%i + " (string_of_num n) v) vect let from_list (l: num list) = let rec xfrom_list i l = match l with | [] -> [] | e::l -> if e <>/ Int 0 then (i,e)::(xfrom_list (i+1) l) else xfrom_list (i+1) l in xfrom_list 0 l let zero_num = Int 0 let unit_num = Int 1 let to_list m = let rec xto_list i l = match l with | [] -> [] | (x,v)::l' -> if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in xto_list 0 m let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst let rec update i f t = match t with | [] -> cons i (f zero_num) [] | (k,v)::l -> match Pervasives.compare i k with | 0 -> cons k (f v) l | -1 -> cons i (f zero_num) t | 1 -> (k,v) ::(update i f l) | _ -> failwith "compare_num" let rec set i n t = match t with | [] -> cons i n [] | (k,v)::l -> match Pervasives.compare i k with | 0 -> cons k n l | -1 -> cons i n t | 1 -> (k,v) :: (set i n l) | _ -> failwith "compare_num" let gcd m = let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int x (Utils.numerator e)) Big_int.zero_big_int m in if Big_int.compare_big_int res Big_int.zero_big_int = 0 then Big_int.unit_big_int else res let rec mul z t = match z with | Int 0 -> [] | Int 1 -> t | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t let rec add v1 v2 = match v1 , v2 with | (x1,n1)::v1' , (x2,n2)::v2' -> if x1 = x2 then let n' = n1 +/ n2 in if n' =/ Int 0 then add v1' v2' else let res = add v1' v2' in (x1,n') ::res else if x1 < x2 then let res = add v1' v2 in (x1, n1)::res else let res = add v1 v2' in (x2, n2)::res | [] , [] -> [] | [] , _ -> v2 | _ , [] -> v1 let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical [ (fun () -> Pervasives.compare (fst x) (fst y)); (fun () -> compare_num (snd x) (snd y))]) (** [tail v vect] returns - [None] if [v] is not a variable of the vector [vect] - [Some(vl,rst)] where [vl] is the value of [v] in vector [vect] and [rst] is the remaining of the vector We exploit that vectors are ordered lists *) let rec tail (v:var) (vect:t) = match vect with | [] -> None | (v',vl)::vect' -> match Pervasives.compare v' v with | 0 -> Some (vl,vect) (* Ok, found *) | -1 -> tail v vect' (* Might be in the tail *) | _ -> None (* Hopeless *) let get v vect = match tail v vect with | None -> None | Some(vl,_) -> Some vl let rec fresh v = match v with | [] -> 1 | [v,_] -> v + 1 | _::v -> fresh v end type vector = Vect.t type cstr_compat = {coeffs : vector ; op : op ; cst : num} and op = |Eq | Ge let string_of_op = function Eq -> "=" | Ge -> ">=" let output_cstr o {coeffs = coeffs ; op = op ; cst = cst} = Printf.fprintf o "%a %s %s" Vect.pp_vect coeffs (string_of_op op) (string_of_num cst) let opMult o1 o2 = match o1, o2 with | Eq , Eq -> Eq | Eq , Ge | Ge , Eq -> Ge | Ge , Ge -> Ge let opAdd o1 o2 = match o1 , o2 with | Eq , _ | _ , Eq -> Eq | Ge , Ge -> Ge open Big_int type index = int type prf_rule = | Hyp of int | Def of int | Cst of big_int | Zero | Square of (Vect.t * num) | MulC of (Vect.t * num) * prf_rule | Gcd of big_int * prf_rule | MulPrf of prf_rule * prf_rule | AddPrf of prf_rule * prf_rule | CutPrf of prf_rule type proof = | Done | Step of int * prf_rule * proof | Enum of int * prf_rule * Vect.t * prf_rule * proof list let rec output_prf_rule o = function | Hyp i -> Printf.fprintf o "Hyp %i" i | Def i -> Printf.fprintf o "Def %i" i | Cst c -> Printf.fprintf o "Cst %s" (string_of_big_int c) | Zero -> Printf.fprintf o "Zero" | Square _ -> Printf.fprintf o "( )^2" | MulC(p,pr) -> Printf.fprintf o "P * %a" output_prf_rule pr | MulPrf(p1,p2) -> Printf.fprintf o "%a * %a" output_prf_rule p1 output_prf_rule p2 | AddPrf(p1,p2) -> Printf.fprintf o "%a + %a" output_prf_rule p1 output_prf_rule p2 | CutPrf(p) -> Printf.fprintf o "[%a]" output_prf_rule p | Gcd(c,p) -> Printf.fprintf o "(%a)/%s" output_prf_rule p (string_of_big_int c) let rec output_proof o = function | Done -> Printf.fprintf o "." | Step(i,p,pf) -> Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf | Enum(i,p1,v,p2,pl) -> Printf.fprintf o "%i{%a<=%a<=%a}%a" i output_prf_rule p1 Vect.pp_vect v output_prf_rule p2 (pp_list output_proof) pl let rec pr_rule_max_id = function | Hyp i | Def i -> i | Cst _ | Zero | Square _ -> -1 | MulC(_,p) | CutPrf p | Gcd(_,p) -> pr_rule_max_id p | MulPrf(p1,p2)| AddPrf(p1,p2) -> max (pr_rule_max_id p1) (pr_rule_max_id p2) let rec proof_max_id = function | Done -> -1 | Step(i,pr,prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf)) | Enum(i,p1,_,p2,l) -> let m = max (pr_rule_max_id p1) (pr_rule_max_id p2) in List.fold_left (fun i prf -> max i (proof_max_id prf)) (max i m) l let rec pr_rule_def_cut id = function | MulC(p,prf) -> let (bds,id',prf') = pr_rule_def_cut id prf in (bds, id', MulC(p,prf')) | MulPrf(p1,p2) -> let (bds1,id,p1) = pr_rule_def_cut id p1 in let (bds2,id,p2) = pr_rule_def_cut id p2 in (bds2@bds1,id,MulPrf(p1,p2)) | AddPrf(p1,p2) -> let (bds1,id,p1) = pr_rule_def_cut id p1 in let (bds2,id,p2) = pr_rule_def_cut id p2 in (bds2@bds1,id,AddPrf(p1,p2)) | CutPrf p -> let (bds,id,p) = pr_rule_def_cut id p in ((id,p)::bds,id+1,Def id) | Gcd(c,p) -> let (bds,id,p) = pr_rule_def_cut id p in ((id,p)::bds,id+1,Def id) | Square _|Cst _|Def _|Hyp _|Zero as x -> ([],id,x) (* Do not define top-level cuts *) let pr_rule_def_cut id = function | CutPrf p -> let (bds,ids,p') = pr_rule_def_cut id p in bds,ids, CutPrf p' | p -> pr_rule_def_cut id p let rec implicit_cut p = match p with | CutPrf p -> implicit_cut p | _ -> p let rec normalise_proof id prf = match prf with | Done -> (id,Done) | Step(i,Gcd(c,p),Done) -> normalise_proof id (Step(i,p,Done)) | Step(i,p,prf) -> let bds,id,p' = pr_rule_def_cut id p in let (id,prf) = normalise_proof id prf in let prf = List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) (Step(i,p',prf)) bds in (id,prf) | Enum(i,p1,v,p2,pl) -> (* Why do I have top-level cuts ? *) (* let p1 = implicit_cut p1 in let p2 = implicit_cut p2 in let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in (List.fold_left max 0 ids , Enum(i,p1,v,p2,prfs)) *) let bds1,id,p1' = pr_rule_def_cut id (implicit_cut p1) in let bds2,id,p2' = pr_rule_def_cut id (implicit_cut p2) in let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in (List.fold_left max 0 ids , List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) (Enum(i,p1',v,p2',prfs)) (bds2@bds1)) let normalise_proof id prf = let res = normalise_proof id prf in if debug then Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof (snd res) ; res let add_proof x y = match x, y with | Zero , p | p , Zero -> p | _ -> AddPrf(x,y) let mul_proof c p = match sign_big_int c with | 0 -> Zero (* This is likely to be a bug *) | -1 -> MulC(([],Big_int c),p) (* [p] should represent an equality *) | 1 -> if eq_big_int c unit_big_int then p else MulPrf(Cst c,p) | _ -> assert false let mul_proof_ext (p,c) prf = match p with | [] -> mul_proof (numerator c) prf | _ -> MulC((p,c),prf) (* let rec scale_prf_rule = function | Hyp i -> (unit_big_int, Hyp i) | Def i -> (unit_big_int, Def i) | Cst c -> (unit_big_int, Cst i) | Zero -> (unit_big_int, Zero) | Square p -> (unit_big_int,Square p) | Div(c,pr) -> let (bi,pr') = scale_prf_rule pr in (mult_big_int c bi , pr') | MulC(p,pr) -> let bi,pr' = scale_prf_rule pr in (bi,MulC p,pr') | MulPrf(p1,p2) -> let b1,p1 = scale_prf_rule p1 in let b2,p2 = scale_prf_rule p2 in | AddPrf(p1,p2) -> let b1,p1 = scale_prf_rule p1 in let b2,p2 = scale_prf_rule p2 in let g = gcd_big_int *) module LinPoly = struct type t = Vect.t * num module MonT = struct module MonoMap = Map.Make(Monomial) module IntMap = Map.Make(struct type t = int let compare = Pervasives.compare end) (** A hash table might be preferable but requires a hash function. *) let (index_of_monomial : int MonoMap.t ref) = ref (MonoMap.empty) let (monomial_of_index : Monomial.t IntMap.t ref) = ref (IntMap.empty) let fresh = ref 0 let clear () = index_of_monomial := MonoMap.empty; monomial_of_index := IntMap.empty ; fresh := 0 let register m = try MonoMap.find m !index_of_monomial with Not_found -> begin let res = !fresh in index_of_monomial := MonoMap.add m res !index_of_monomial ; monomial_of_index := IntMap.add res m !monomial_of_index ; incr fresh ; res end let retrieve i = IntMap.find i !monomial_of_index end let normalise (v,c) = (List.sort (fun x y -> Pervasives.compare (fst x) (fst y)) v , c) let output_mon o (x,v) = Printf.fprintf o "%s.%a +" (string_of_num v) Monomial.pp (MonT.retrieve x) let output_cstr o {coeffs = coeffs ; op = op ; cst = cst} = Printf.fprintf o "%a %s %s" (pp_list output_mon) coeffs (string_of_op op) (string_of_num cst) let linpol_of_pol p = let (v,c) = Poly.fold (fun mon num (vct,cst) -> if Monomial.is_const mon then (vct,num) else let vr = MonT.register mon in ((vr,num)::vct,cst)) p ([], Int 0) in normalise (v,c) let mult v m (vect,c) = if Monomial.is_const m then (Vect.mul v vect, v <*> c) else if sign_num v <> 0 then let hd = if sign_num c <> 0 then [MonT.register m,v <*> c] else [] in let vect = hd @ (List.map (fun (x,n) -> let x = MonT.retrieve x in let x_m = MonT.register (Monomial.prod m x) in (x_m, v <*> n)) vect ) in normalise (vect , Int 0) else ([],Int 0) let mult v m (vect,c) = let (vect',c') = mult v m (vect,c) in if debug then Printf.printf "mult %s %a (%a,%s) -> (%a,%s)\n" (string_of_num v) Monomial.pp m (pp_list output_mon) vect (string_of_num c) (pp_list output_mon) vect' (string_of_num c') ; (vect',c') let make_lin_pol v mon = if Monomial.is_const mon then [] , v else [MonT.register mon, v],Int 0 let xpivot_eq (c,prf) x v (c',prf') = if debug then Printf.printf "xpivot_eq {%a} %a %s {%a}\n" output_cstr c Monomial.pp (MonT.retrieve x) (string_of_num v) output_cstr c' ; let {coeffs = coeffs ; op = op ; cst = cst} = c' in let m = MonT.retrieve x in let apply_pivot (vqn,q,n) (c',prf') = (* Morally, we have (Vect.get (q*x^n) c'.coeffs) = vmn with n >=0 *) let cc' = abs_num v in let cc_num = Int (- (sign_num v)) <*> vqn in let cc_mon = Monomial.prod q (Monomial.exp m (n-1)) in let (c_coeff,c_cst) = mult cc_num cc_mon (c.coeffs, minus_num c.cst) in let c' = {coeffs = Vect.add (Vect.mul cc' c'.coeffs) c_coeff ; op = op ; cst = (minus_num c_cst) <+> (cc' <*> c'.cst)} in let prf' = add_proof (mul_proof_ext (make_lin_pol cc_num cc_mon) prf) (mul_proof (numerator cc') prf') in if debug then Printf.printf "apply_pivot -> {%a}\n" output_cstr c' ; (c',prf') in let cmp (q,n) (q',n') = if n < n' then -1 else if n = n' then Monomial.compare q q' else 1 in let find_pivot (c',prf') = let (v,q,n) = List.fold_left (fun (v,q,n) (x,v') -> let x = MonT.retrieve x in let (q',n') = Monomial.div x m in if cmp (q,n) (q',n') = -1 then (v',q',n') else (v,q,n)) (Int 0, Monomial.const,0) c'.coeffs in if n > 0 then Some (v,q,n) else None in let rec pivot (q,n) (c',prf') = match find_pivot (c',prf') with | None -> (c',prf') | Some(v,q',n') -> if cmp (q',n') (q,n) = -1 then pivot (q',n') (apply_pivot (v,q',n') (c',prf')) else (c',prf') in pivot (Monomial.const,max_int) (c',prf') let pivot_eq x (c,prf) = match Vect.get x c.coeffs with | None -> (fun x -> None) | Some v -> fun cp' -> Some (xpivot_eq (c,prf) x v cp') end coq-8.4pl4/plugins/micromega/Psatz.v0000644000175000017500000001004312326224777016545 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (sos_Z || psatz_Z d) ; intros __wit __varmap __ff ; change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity | R => (sos_R || psatz_R d) ; (* If csdp is not installed, the previous step might not produce any progress: the rest of the tactical will then fail. Hence the 'try'. *) try (intros __wit __varmap __ff ; change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity) | Q => (sos_Q || psatz_Q d) ; (* If csdp is not installed, the previous step might not produce any progress: the rest of the tactical will then fail. Hence the 'try'. *) try (intros __wit __varmap __ff ; change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity) | _ => fail "Unsupported domain" end in tac. Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n. Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:-1. Ltac psatzl dom := let tac := lazymatch dom with | Z => psatzl_Z ; intros __wit __varmap __ff ; change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity | Q => psatzl_Q ; (* If csdp is not installed, the previous step might not produce any progress: the rest of the tactical will then fail. Hence the 'try'. *) try (intros __wit __varmap __ff ; change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity) | R => unfold Rdiv in * ; psatzl_R ; (* If csdp is not installed, the previous step might not produce any progress: the rest of the tactical will then fail. Hence the 'try'. *) try (intros __wit __varmap __ff ; change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity) | _ => fail "Unsupported domain" end in tac. Ltac lra := first [ psatzl R | psatzl Q ]. Ltac lia := zify ; unfold Z.succ in * ; (*cbv delta - [Z.add Z.sub Z.opp Z.mul Z.pow Z.gt Z.ge Z.le Z.lt iff not] ;*) xlia ; intros __wit __varmap __ff ; change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity. Ltac nia := zify ; unfold Z.succ in * ; xnlia ; intros __wit __varmap __ff ; change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity. (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.4pl4/plugins/micromega/mutils.ml0000644000175000017500000002534612326224777017140 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* () | e::l -> f o e ; output_string o ";" ; pp_list f o l let finally f rst = try let res = f () in rst () ; res with reraise -> (try rst () with any -> raise reraise ); raise reraise let map_option f x = match x with | None -> None | Some v -> Some (f v) let from_option = function | None -> failwith "from_option" | Some v -> v let rec try_any l x = match l with | [] -> None | (f,s)::l -> match f x with | None -> try_any l x | x -> x let iteri f l = let rec xiter i l = match l with | [] -> () | e::l -> f i e ; xiter (i+1) l in xiter 0 l let all_sym_pairs f l = let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in let rec xpairs acc l = match l with | [] -> acc | e::l -> xpairs (pair_with acc e l) l in xpairs [] l let rec map3 f l1 l2 l3 = match l1 , l2 ,l3 with | [] , [] , [] -> [] | e1::l1 , e2::l2 , e3::l3 -> (f e1 e2 e3)::(map3 f l1 l2 l3) | _ -> raise (Invalid_argument "map3") let rec is_sublist l1 l2 = match l1 ,l2 with | [] ,_ -> true | e::l1', [] -> false | e::l1' , e'::l2' -> if e = e' then is_sublist l1' l2' else is_sublist l1 l2' let list_try_find f = let rec try_find_f = function | [] -> failwith "try_find" | h::t -> try f h with Failure _ -> try_find_f t in try_find_f let rec list_fold_right_elements f l = let rec aux = function | [] -> invalid_arg "list_fold_right_elements" | [x] -> x | x::l -> f x (aux l) in aux l let interval n m = let rec interval_n (l,m) = if n > m then l else interval_n (m::l,pred m) in interval_n ([],m) let extract pred l = List.fold_left (fun (fd,sys) e -> match fd with | None -> begin match pred e with | None -> fd, e::sys | Some v -> Some(v,e) , sys end | _ -> (fd, e::sys) ) (None,[]) l open Num open Big_int let ppcm x y = let g = gcd_big_int x y in let x' = div_big_int x g in let y' = div_big_int y g in mult_big_int g (mult_big_int x' y') let denominator = function | Int _ | Big_int _ -> unit_big_int | Ratio r -> Ratio.denominator_ratio r let numerator = function | Ratio r -> Ratio.numerator_ratio r | Int i -> Big_int.big_int_of_int i | Big_int i -> i let rec ppcm_list c l = match l with | [] -> c | e::l -> ppcm_list (ppcm c (denominator e)) l let rec rec_gcd_list c l = match l with | [] -> c | e::l -> rec_gcd_list (gcd_big_int c (numerator e)) l let rec gcd_list l = let res = rec_gcd_list zero_big_int l in if compare_big_int res zero_big_int = 0 then unit_big_int else res let rats_to_ints l = let c = ppcm_list unit_big_int l in List.map (fun x -> (div_big_int (mult_big_int (numerator x) c) (denominator x))) l (* Nasty reordering of lists - useful to trim certificate down *) let mapi f l = let rec xmapi i l = match l with | [] -> [] | e::l -> (f e i)::(xmapi (i+1) l) in xmapi 0 l let concatMapi f l = List.rev (mapi (fun e i -> (i,f e)) l) (* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *) let assoc_pos j l = (mapi (fun e i -> e,i+j) l, j + (List.length l)) let assoc_pos_assoc l = let rec xpos i l = match l with | [] -> [] | (x,l) ::rst -> let (l',j) = assoc_pos i l in (x,l')::(xpos j rst) in xpos 0 l let filter_pos f l = (* Could sort ... take care of duplicates... *) let rec xfilter l = match l with | [] -> [] | (x,e)::l -> if List.exists (fun ee -> List.mem ee f) (List.map snd e) then (x,e)::(xfilter l) else xfilter l in xfilter l let select_pos lpos l = let rec xselect i lpos l = match lpos with | [] -> [] | j::rpos -> match l with | [] -> failwith "select_pos" | e::l -> if i = j then e:: (xselect (i+1) rpos l) else xselect (i+1) lpos l in xselect 0 lpos l (** * MODULE: Coq to Caml data-structure mappings *) module CoqToCaml = struct open Micromega let rec nat = function | O -> 0 | S n -> (nat n) + 1 let rec positive p = match p with | XH -> 1 | XI p -> 1+ 2*(positive p) | XO p -> 2*(positive p) let n nt = match nt with | N0 -> 0 | Npos p -> positive p let rec index i = (* Swap left-right ? *) match i with | XH -> 1 | XI i -> 1+(2*(index i)) | XO i -> 2*(index i) let z x = match x with | Z0 -> 0 | Zpos p -> (positive p) | Zneg p -> - (positive p) open Big_int let rec positive_big_int p = match p with | XH -> unit_big_int | XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p)) | XO p -> (mult_int_big_int 2 (positive_big_int p)) let z_big_int x = match x with | Z0 -> zero_big_int | Zpos p -> (positive_big_int p) | Zneg p -> minus_big_int (positive_big_int p) let num x = Num.Big_int (z_big_int x) let q_to_num {qnum = x ; qden = y} = Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y))) end (** * MODULE: Caml to Coq data-structure mappings *) module CamlToCoq = struct open Micromega let rec nat = function | 0 -> O | n -> S (nat (n-1)) let rec positive n = if n=1 then XH else if n land 1 = 1 then XI (positive (n lsr 1)) else XO (positive (n lsr 1)) let n nt = if nt < 0 then assert false else if nt = 0 then N0 else Npos (positive nt) let rec index n = if n=1 then XH else if n land 1 = 1 then XI (index (n lsr 1)) else XO (index (n lsr 1)) let idx n = (*a.k.a path_of_int *) (* returns the list of digits of n in reverse order with initial 1 removed *) let rec digits_of_int n = if n=1 then [] else (n mod 2 = 1)::(digits_of_int (n lsr 1)) in List.fold_right (fun b c -> (if b then XI c else XO c)) (List.rev (digits_of_int n)) (XH) let z x = match compare x 0 with | 0 -> Z0 | 1 -> Zpos (positive x) | _ -> (* this should be -1 *) Zneg (positive (-x)) open Big_int let positive_big_int n = let two = big_int_of_int 2 in let rec _pos n = if eq_big_int n unit_big_int then XH else let (q,m) = quomod_big_int n two in if eq_big_int unit_big_int m then XI (_pos q) else XO (_pos q) in _pos n let bigint x = match sign_big_int x with | 0 -> Z0 | 1 -> Zpos (positive_big_int x) | _ -> Zneg (positive_big_int (minus_big_int x)) let q n = {Micromega.qnum = bigint (numerator n) ; Micromega.qden = positive_big_int (denominator n)} end (** * MODULE: Comparisons on lists: by evaluating the elements in a single list, * between two lists given an ordering, and using a hash computation *) module Cmp = struct let rec compare_lexical l = match l with | [] -> 0 (* Equal *) | f::l -> let cmp = f () in if cmp = 0 then compare_lexical l else cmp let rec compare_list cmp l1 l2 = match l1 , l2 with | [] , [] -> 0 | [] , _ -> -1 | _ , [] -> 1 | e1::l1 , e2::l2 -> let c = cmp e1 e2 in if c = 0 then compare_list cmp l1 l2 else c (** * hash_list takes a hash function and a list, and computes an integer which * is the hash value of the list. *) let hash_list hash l = let rec _hash_list l h = match l with | [] -> h lxor (Hashtbl.hash []) | e::l -> _hash_list l ((hash e) lxor h) in _hash_list l 0 end (** * MODULE: Labels for atoms in propositional formulas. * Tags are used to identify unused atoms in CNFs, and propagate them back to * the original formula. The translation back to Coq then ignores these * superfluous items, which speeds the translation up a bit. *) module type Tag = sig type t val from : int -> t val next : t -> t val pp : out_channel -> t -> unit val compare : t -> t -> int end module Tag : Tag = struct type t = int let from i = i let next i = i + 1 let pp o i = output_string o (string_of_int i) let compare : int -> int -> int = Pervasives.compare end (** * MODULE: Ordered sets of tags. *) module TagSet = Set.Make(Tag) (** * Forking routine, plumbing the appropriate pipes where needed. *) let command exe_path args vl = (* creating pipes for stdin, stdout, stderr *) let (stdin_read,stdin_write) = Unix.pipe () and (stdout_read,stdout_write) = Unix.pipe () and (stderr_read,stderr_write) = Unix.pipe () in (* Create the process *) let pid = Unix.create_process exe_path args stdin_read stdout_write stderr_write in (* Write the data on the stdin of the created process *) let outch = Unix.out_channel_of_descr stdin_write in output_value outch vl ; flush outch ; (* Wait for its completion *) let _pid,status = Unix.waitpid [] pid in finally (* Recover the result *) (fun () -> match status with | Unix.WEXITED 0 -> let inch = Unix.in_channel_of_descr stdout_read in begin try Marshal.from_channel inch with x when x <> Sys.Break -> failwith (Printf.sprintf "command \"%s\" exited %s" exe_path (Printexc.to_string x)) end | Unix.WEXITED i -> failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i) | Unix.WSIGNALED i -> failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i) | Unix.WSTOPPED i -> failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i)) (* Cleanup *) (fun () -> List.iter (fun x -> try Unix.close x with e when e <> Sys.Break -> ()) [stdin_read; stdin_write; stdout_read; stdout_write; stderr_read; stderr_write]) (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.4pl4/plugins/micromega/EnvRing.v0000644000175000017500000007451412326224777017031 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R->R) (ropp : R->R). Variable req : R -> R -> Prop. (* Ring properties *) Variable Rsth : Equivalence req. Variable Reqe : ring_eq_ext radd rmul ropp req. Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. (* Coefficients *) Variable C: Type. Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). Variable ceqb : C->C->bool. Variable phi : C -> R. Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. (* Power coefficients *) Variable Cpow : Type. Variable Cp_phi : N -> Cpow. Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory rI rmul req Cp_phi rpow. (* R notations *) Notation "0" := rO. Notation "1" := rI. Infix "+" := radd. Infix "*" := rmul. Infix "-" := rsub. Notation "- x" := (ropp x). Infix "==" := req. Infix "^" := (pow_pos rmul). (* C notations *) Infix "+!" := cadd. Infix "*!" := cmul. Infix "-! " := csub. Notation "-! x" := (copp x). Infix "?=!" := ceqb. Notation "[ x ]" := (phi x). (* Useful tactics *) Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac rsimpl := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth. Ltac add_permut_rec t := match t with | ?x + ?y => add_permut_rec y || add_permut_rec x | _ => add_push t; apply (Radd_ext Reqe); [|reflexivity] end. Ltac add_permut := repeat (reflexivity || match goal with |- ?t == _ => add_permut_rec t end). Ltac mul_permut_rec t := match t with | ?x * ?y => mul_permut_rec y || mul_permut_rec x | _ => mul_push t; apply (Rmul_ext Reqe); [|reflexivity] end. Ltac mul_permut := repeat (reflexivity || match goal with |- ?t == _ => mul_permut_rec t end). (* Definition of multivariable polynomials with coefficients in C : Type [Pol] represents [X1 ... Xn]. The representation is Horner's where a [n] variable polynomial (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients are polynomials with [n-1] variables (C[X2..Xn]). There are several optimisations to make the repr compacter: - [Pc c] is the constant polynomial of value c == c*X1^0*..*Xn^0 - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. variable indices are shifted of j in Q. == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} - [PX P i Q] is an optimised Horner form of P*X^i + Q with P not the null polynomial == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} In addition: - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden since they can be represented by the simpler form (PX P (i+j) Q) - (Pinj i (Pinj j P)) is (Pinj (i+j) P) - (Pinj i (Pc c)) is (Pc c) *) Inductive Pol : Type := | Pc : C -> Pol | Pinj : positive -> Pol -> Pol | PX : Pol -> positive -> Pol -> Pol. Definition P0 := Pc cO. Definition P1 := Pc cI. Fixpoint Peq (P P' : Pol) {struct P'} : bool := match P, P' with | Pc c, Pc c' => c ?=! c' | Pinj j Q, Pinj j' Q' => match j ?= j' with | Eq => Peq Q Q' | _ => false end | PX P i Q, PX P' i' Q' => match i ?= i' with | Eq => if Peq P P' then Peq Q Q' else false | _ => false end | _, _ => false end. Infix "?==" := Peq. Definition mkPinj j P := match P with | Pc _ => P | Pinj j' Q => Pinj (j + j') Q | _ => Pinj j P end. Definition mkPinj_pred j P:= match j with | xH => P | xO j => Pinj (Pos.pred_double j) P | xI j => Pinj (xO j) P end. Definition mkPX P i Q := match P with | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q | Pinj _ _ => PX P i Q | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q end. Definition mkXi i := PX P1 i P0. Definition mkX := mkXi 1. (** Opposite of addition *) Fixpoint Popp (P:Pol) : Pol := match P with | Pc c => Pc (-! c) | Pinj j Q => Pinj j (Popp Q) | PX P i Q => PX (Popp P) i (Popp Q) end. Notation "-- P" := (Popp P). (** Addition et subtraction *) Fixpoint PaddC (P:Pol) (c:C) : Pol := match P with | Pc c1 => Pc (c1 +! c) | Pinj j Q => Pinj j (PaddC Q c) | PX P i Q => PX P i (PaddC Q c) end. Fixpoint PsubC (P:Pol) (c:C) : Pol := match P with | Pc c1 => Pc (c1 -! c) | Pinj j Q => Pinj j (PsubC Q c) | PX P i Q => PX P i (PsubC Q c) end. Section PopI. Variable Pop : Pol -> Pol -> Pol. Variable Q : Pol. Fixpoint PaddI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PaddC Q c) | Pinj j' Q' => match Z.pos_sub j' j with | Zpos k => mkPinj j (Pop (Pinj k Q') Q) | Z0 => mkPinj j (Pop Q' Q) | Zneg k => mkPinj j' (PaddI k Q') end | PX P i Q' => match j with | xH => PX P i (Pop Q' Q) | xO j => PX P i (PaddI (Pos.pred_double j) Q') | xI j => PX P i (PaddI (xO j) Q') end end. Fixpoint PsubI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PaddC (--Q) c) | Pinj j' Q' => match Z.pos_sub j' j with | Zpos k => mkPinj j (Pop (Pinj k Q') Q) | Z0 => mkPinj j (Pop Q' Q) | Zneg k => mkPinj j' (PsubI k Q') end | PX P i Q' => match j with | xH => PX P i (Pop Q' Q) | xO j => PX P i (PsubI (Pos.pred_double j) Q') | xI j => PX P i (PsubI (xO j) Q') end end. Variable P' : Pol. Fixpoint PaddX (i':positive) (P:Pol) : Pol := match P with | Pc c => PX P' i' P | Pinj j Q' => match j with | xH => PX P' i' Q' | xO j => PX P' i' (Pinj (Pos.pred_double j) Q') | xI j => PX P' i' (Pinj (xO j) Q') end | PX P i Q' => match Z.pos_sub i i' with | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' | Z0 => mkPX (Pop P P') i Q' | Zneg k => mkPX (PaddX k P) i Q' end end. Fixpoint PsubX (i':positive) (P:Pol) : Pol := match P with | Pc c => PX (--P') i' P | Pinj j Q' => match j with | xH => PX (--P') i' Q' | xO j => PX (--P') i' (Pinj (Pos.pred_double j) Q') | xI j => PX (--P') i' (Pinj (xO j) Q') end | PX P i Q' => match Z.pos_sub i i' with | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' | Z0 => mkPX (Pop P P') i Q' | Zneg k => mkPX (PsubX k P) i Q' end end. End PopI. Fixpoint Padd (P P': Pol) {struct P'} : Pol := match P' with | Pc c' => PaddC P c' | Pinj j' Q' => PaddI Padd Q' j' P | PX P' i' Q' => match P with | Pc c => PX P' i' (PaddC Q' c) | Pinj j Q => match j with | xH => PX P' i' (Padd Q Q') | xO j => PX P' i' (Padd (Pinj (Pos.pred_double j) Q) Q') | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q') end | PX P i Q => match Z.pos_sub i i' with | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q') | Z0 => mkPX (Padd P P') i (Padd Q Q') | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q') end end end. Infix "++" := Padd. Fixpoint Psub (P P': Pol) {struct P'} : Pol := match P' with | Pc c' => PsubC P c' | Pinj j' Q' => PsubI Psub Q' j' P | PX P' i' Q' => match P with | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c) | Pinj j Q => match j with | xH => PX (--P') i' (Psub Q Q') | xO j => PX (--P') i' (Psub (Pinj (Pos.pred_double j) Q) Q') | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q') end | PX P i Q => match Z.pos_sub i i' with | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q') | Z0 => mkPX (Psub P P') i (Psub Q Q') | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q') end end end. Infix "--" := Psub. (** Multiplication *) Fixpoint PmulC_aux (P:Pol) (c:C) : Pol := match P with | Pc c' => Pc (c' *! c) | Pinj j Q => mkPinj j (PmulC_aux Q c) | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c) end. Definition PmulC P c := if c ?=! cO then P0 else if c ?=! cI then P else PmulC_aux P c. Section PmulI. Variable Pmul : Pol -> Pol -> Pol. Variable Q : Pol. Fixpoint PmulI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PmulC Q c) | Pinj j' Q' => match Z.pos_sub j' j with | Zpos k => mkPinj j (Pmul (Pinj k Q') Q) | Z0 => mkPinj j (Pmul Q' Q) | Zneg k => mkPinj j' (PmulI k Q') end | PX P' i' Q' => match j with | xH => mkPX (PmulI xH P') i' (Pmul Q' Q) | xO j' => mkPX (PmulI j P') i' (PmulI (Pos.pred_double j') Q') | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') end end. End PmulI. Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol := match P'' with | Pc c => PmulC P c | Pinj j' Q' => PmulI Pmul Q' j' P | PX P' i' Q' => match P with | Pc c => PmulC P'' c | Pinj j Q => let QQ' := match j with | xH => Pmul Q Q' | xO j => Pmul (Pinj (Pos.pred_double j) Q) Q' | xI j => Pmul (Pinj (xO j) Q) Q' end in mkPX (Pmul P P') i' QQ' | PX P i Q=> let QQ' := Pmul Q Q' in let PQ' := PmulI Pmul Q' xH P in let QP' := Pmul (mkPinj xH Q) P' in let PP' := Pmul P P' in (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ' end end. Infix "**" := Pmul. Fixpoint Psquare (P:Pol) : Pol := match P with | Pc c => Pc (c *! c) | Pinj j Q => Pinj j (Psquare Q) | PX P i Q => let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in let Q2 := Psquare Q in let P2 := Psquare P in mkPX (mkPX P2 i P0 ++ twoPQ) i Q2 end. (** Monomial **) (** A monomial is X1^k1...Xi^ki. Its representation is a simplified version of the polynomial representation: - [mon0] correspond to the polynom [P1]. - [(zmon j M)] corresponds to [(Pinj j ...)], i.e. skip j variable indices. - [(vmon i M)] is X^i*M with X the current variable, its corresponds to (PX P1 i ...)] *) Inductive Mon: Set := | mon0: Mon | zmon: positive -> Mon -> Mon | vmon: positive -> Mon -> Mon. Definition mkZmon j M := match M with mon0 => mon0 | _ => zmon j M end. Definition zmon_pred j M := match j with xH => M | _ => mkZmon (Pos.pred j) M end. Definition mkVmon i M := match M with | mon0 => vmon i mon0 | zmon j m => vmon i (zmon_pred j m) | vmon i' m => vmon (i+i') m end. Fixpoint MFactor (P: Pol) (M: Mon) : Pol * Pol := match P, M with _, mon0 => (Pc cO, P) | Pc _, _ => (P, Pc cO) | Pinj j1 P1, zmon j2 M1 => match (j1 ?= j2) with Eq => let (R,S) := MFactor P1 M1 in (mkPinj j1 R, mkPinj j1 S) | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in (mkPinj j1 R, mkPinj j1 S) | Gt => (P, Pc cO) end | Pinj _ _, vmon _ _ => (P, Pc cO) | PX P1 i Q1, zmon j M1 => let M2 := zmon_pred j M1 in let (R1, S1) := MFactor P1 M in let (R2, S2) := MFactor Q1 M2 in (mkPX R1 i R2, mkPX S1 i S2) | PX P1 i Q1, vmon j M1 => match (i ?= j) with Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in (mkPX R1 i Q1, S1) | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in (mkPX R1 i Q1, S1) | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO)) end end. Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol := let (Q1,R1) := MFactor P1 M1 in match R1 with (Pc c) => if c ?=! cO then None else Some (Padd Q1 (Pmul P2 R1)) | _ => Some (Padd Q1 (Pmul P2 R1)) end. Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) : Pol := match POneSubst P1 M1 P2 with Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end | _ => P1 end. Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol := match POneSubst P1 M1 P2 with Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end | _ => None end. Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) : Pol := match LM1 with cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n | _ => P1 end. Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) : option Pol := match LM1 with cons (M1,P2) LM2 => match PNSubst P1 M1 P2 n with Some P3 => Some (PSubstL1 P3 LM2 n) | None => PSubstL P1 LM2 n end | _ => None end. Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) : Pol := match PSubstL P1 LM1 n with Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end | _ => P1 end. (** Evaluation of a polynomial towards R *) Fixpoint Pphi(l:Env R) (P:Pol) : R := match P with | Pc c => [c] | Pinj j Q => Pphi (jump j l) Q | PX P i Q => Pphi l P * (hd l) ^ i + Pphi (tail l) Q end. Reserved Notation "P @ l " (at level 10, no associativity). Notation "P @ l " := (Pphi l P). (** Evaluation of a monomial towards R *) Fixpoint Mphi(l:Env R) (M: Mon) : R := match M with | mon0 => rI | zmon j M1 => Mphi (jump j l) M1 | vmon i M1 => Mphi (tail l) M1 * (hd l) ^ i end. Notation "M @@ l" := (Mphi l M) (at level 10, no associativity). (** Proofs *) Ltac destr_pos_sub := match goal with |- context [Z.pos_sub ?x ?y] => generalize (Z.pos_sub_discr x y); destruct (Z.pos_sub x y) end. Lemma Peq_ok P P' : (P ?== P') = true -> forall l, P@l == P'@ l. Proof. revert P';induction P;destruct P';simpl; intros H l; try easy. - now apply (morph_eq CRmorph). - destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. now rewrite IHP. - specialize (IHP1 P'1); specialize (IHP2 P'2). destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. destruct (P2 ?== P'1); [|easy]. rewrite H in *. now rewrite IHP1, IHP2. Qed. Lemma Peq_spec P P' : BoolSpec (forall l, P@l == P'@l) True (P ?== P'). Proof. generalize (Peq_ok P P'). destruct (P ?== P'); auto. Qed. Lemma Pphi0 l : P0@l == 0. Proof. simpl;apply (morph0 CRmorph). Qed. Lemma Pphi1 l : P1@l == 1. Proof. simpl;apply (morph1 CRmorph). Qed. Lemma env_morph p e1 e2 : (forall x, e1 x = e2 x) -> p @ e1 = p @ e2. Proof. revert e1 e2. induction p ; simpl. - reflexivity. - intros e1 e2 EQ. apply IHp. intros. apply EQ. - intros e1 e2 EQ. f_equal; [f_equal|]. + now apply IHp1. + f_equal. apply EQ. + apply IHp2. intros; apply EQ. Qed. Lemma Pjump_add P i j l : P @ (jump (i + j) l) = P @ (jump j (jump i l)). Proof. apply env_morph. intros. rewrite <- jump_add. f_equal. apply Pos.add_comm. Qed. Lemma Pjump_xO_tail P p l : P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l). Proof. apply env_morph. intros. now jump_simpl. Qed. Lemma Pjump_pred_double P p l : P @ (jump (Pos.pred_double p) (tail l)) = P @ (jump (xO p) l). Proof. apply env_morph. intros. rewrite jump_pred_double. now jump_simpl. Qed. Lemma mkPinj_ok j l P : (mkPinj j P)@l == P@(jump j l). Proof. destruct P;simpl;rsimpl. now rewrite Pjump_add. Qed. Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j. Proof. rewrite Pos.add_comm. apply (pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)). Qed. Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c'). Proof. generalize (morph_eq CRmorph c c'). destruct (c ?=! c'); auto. Qed. Lemma mkPX_ok l P i Q : (mkPX P i Q)@l == P@l * (hd l)^i + Q@(tail l). Proof. unfold mkPX. destruct P. - case ceqb_spec; intros H; simpl; try reflexivity. rewrite H, (morph0 CRmorph), mkPinj_ok; rsimpl. - reflexivity. - case Peq_spec; intros H; simpl; try reflexivity. rewrite H, Pphi0, Pos.add_comm, pow_pos_add; rsimpl. Qed. Hint Rewrite Pphi0 Pphi1 mkPinj_ok mkPX_ok (morph0 CRmorph) (morph1 CRmorph) (morph0 CRmorph) (morph_add CRmorph) (morph_mul CRmorph) (morph_sub CRmorph) (morph_opp CRmorph) : Esimpl. (* Quicker than autorewrite with Esimpl :-) *) Ltac Esimpl := try rewrite_db Esimpl; rsimpl; simpl. Lemma PaddC_ok c P l : (PaddC P c)@l == P@l + [c]. Proof. revert l;induction P;simpl;intros;Esimpl;trivial. rewrite IHP2;rsimpl. Qed. Lemma PsubC_ok c P l : (PsubC P c)@l == P@l - [c]. Proof. revert l;induction P;simpl;intros. - Esimpl. - rewrite IHP;rsimpl. - rewrite IHP2;rsimpl. Qed. Lemma PmulC_aux_ok c P l : (PmulC_aux P c)@l == P@l * [c]. Proof. revert l;induction P;simpl;intros;Esimpl;trivial. rewrite IHP1, IHP2;rsimpl. add_permut. mul_permut. Qed. Lemma PmulC_ok c P l : (PmulC P c)@l == P@l * [c]. Proof. unfold PmulC. case ceqb_spec; intros H. - rewrite H; Esimpl. - case ceqb_spec; intros H'. + rewrite H'; Esimpl. + apply PmulC_aux_ok. Qed. Lemma Popp_ok P l : (--P)@l == - P@l. Proof. revert l;induction P;simpl;intros. - Esimpl. - apply IHP. - rewrite IHP1, IHP2;rsimpl. Qed. Hint Rewrite PaddC_ok PsubC_ok PmulC_ok Popp_ok : Esimpl. Lemma PaddX_ok P' P k l : (forall P l, (P++P')@l == P@l + P'@l) -> (PaddX Padd P' k P) @ l == P@l + P'@l * (hd l)^k. Proof. intros IHP'. revert k l. induction P;simpl;intros. - add_permut. - destruct p; simpl; rewrite ?Pjump_xO_tail, ?Pjump_pred_double; add_permut. - destr_pos_sub; intros ->;Esimpl. + rewrite IHP';rsimpl. add_permut. + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. + rewrite IHP1, pow_pos_add;rsimpl. add_permut. Qed. Lemma Padd_ok P' P l : (P ++ P')@l == P@l + P'@l. Proof. revert P l; induction P';simpl;intros;Esimpl. - revert p l; induction P;simpl;intros. + Esimpl; add_permut. + destr_pos_sub; intros ->;Esimpl. * now rewrite IHP'. * rewrite IHP';Esimpl. now rewrite Pjump_add. * rewrite IHP. now rewrite Pjump_add. + destruct p0;simpl. * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl. * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl. * rewrite IHP'. rsimpl. - destruct P;simpl. + Esimpl. add_permut. + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. * rewrite Pjump_xO_tail. rsimpl. add_permut. * rewrite Pjump_pred_double. rsimpl. add_permut. * rsimpl. unfold tail. add_permut. + destr_pos_sub; intros ->; Esimpl. * rewrite IHP'1, IHP'2;rsimpl. add_permut. * rewrite IHP'1, IHP'2;simpl;Esimpl. rewrite pow_pos_add;rsimpl. add_permut. * rewrite PaddX_ok by trivial; rsimpl. rewrite IHP'2, pow_pos_add; rsimpl. add_permut. Qed. Lemma PsubX_ok P' P k l : (forall P l, (P--P')@l == P@l - P'@l) -> (PsubX Psub P' k P) @ l == P@l - P'@l * (hd l)^k. Proof. intros IHP'. revert k l. induction P;simpl;intros. - rewrite Popp_ok;rsimpl; add_permut. - destruct p; simpl; rewrite Popp_ok;rsimpl; rewrite ?Pjump_xO_tail, ?Pjump_pred_double; add_permut. - destr_pos_sub; intros ->; Esimpl. + rewrite IHP';rsimpl. add_permut. + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. + rewrite IHP1, pow_pos_add;rsimpl. add_permut. Qed. Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l. Proof. revert P l; induction P';simpl;intros;Esimpl. - revert p l; induction P;simpl;intros. + Esimpl; add_permut. + destr_pos_sub; intros ->;Esimpl. * rewrite IHP';rsimpl. * rewrite IHP';Esimpl. now rewrite Pjump_add. * rewrite IHP. now rewrite Pjump_add. + destruct p0;simpl. * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl. * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl. * rewrite IHP'. rsimpl. - destruct P;simpl. + Esimpl; add_permut. + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. * rewrite Pjump_xO_tail. rsimpl. add_permut. * rewrite Pjump_pred_double. rsimpl. add_permut. * rsimpl. unfold tail. add_permut. + destr_pos_sub; intros ->; Esimpl. * rewrite IHP'1, IHP'2;rsimpl. add_permut. * rewrite IHP'1, IHP'2;simpl;Esimpl. rewrite pow_pos_add;rsimpl. add_permut. * rewrite PsubX_ok by trivial;rsimpl. rewrite IHP'2, pow_pos_add;rsimpl. add_permut. Qed. Lemma PmulI_ok P' : (forall P l, (Pmul P P') @ l == P @ l * P' @ l) -> forall P p l, (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). Proof. intros IHP'. induction P;simpl;intros. - Esimpl; mul_permut. - destr_pos_sub; intros ->;Esimpl. + now rewrite IHP'. + now rewrite IHP', Pjump_add. + now rewrite IHP, Pjump_add. - destruct p0;Esimpl; rewrite ?IHP1, ?IHP2; rsimpl. + rewrite Pjump_xO_tail. f_equiv. mul_permut. + rewrite Pjump_pred_double. f_equiv. mul_permut. + rewrite IHP'. f_equiv. mul_permut. Qed. Lemma Pmul_ok P P' l : (P**P')@l == P@l * P'@l. Proof. revert P l;induction P';simpl;intros. - apply PmulC_ok. - apply PmulI_ok;trivial. - destruct P. + rewrite (ARmul_comm ARth). Esimpl. + Esimpl. rewrite IHP'1;Esimpl. f_equiv. destruct p0;rewrite IHP'2;Esimpl. * now rewrite Pjump_xO_tail. * rewrite Pjump_pred_double; Esimpl. + rewrite Padd_ok, !mkPX_ok, Padd_ok, !mkPX_ok, !IHP'1, !IHP'2, PmulI_ok; trivial. simpl. Esimpl. unfold tail. add_permut; f_equiv; mul_permut. Qed. Lemma Psquare_ok P l : (Psquare P)@l == P@l * P@l. Proof. revert l;induction P;simpl;intros;Esimpl. - apply IHP. - rewrite Padd_ok, Pmul_ok;Esimpl. rewrite IHP1, IHP2. mul_push ((hd l)^p). now mul_push (P2@l). Qed. Lemma Mphi_morph M e1 e2 : (forall x, e1 x = e2 x) -> M @@ e1 = M @@ e2. Proof. revert e1 e2; induction M; simpl; intros e1 e2 EQ; trivial. - apply IHM. intros; apply EQ. - f_equal. * apply IHM. intros; apply EQ. * f_equal. apply EQ. Qed. Lemma Mjump_xO_tail M p l : M @@ (jump (xO p) (tail l)) = M @@ (jump (xI p) l). Proof. apply Mphi_morph. intros. now jump_simpl. Qed. Lemma Mjump_pred_double M p l : M @@ (jump (Pos.pred_double p) (tail l)) = M @@ (jump (xO p) l). Proof. apply Mphi_morph. intros. rewrite jump_pred_double. now jump_simpl. Qed. Lemma Mjump_add M i j l : M @@ (jump (i + j) l) = M @@ (jump j (jump i l)). Proof. apply Mphi_morph. intros. now rewrite <- jump_add, Pos.add_comm. Qed. Lemma mkZmon_ok M j l : (mkZmon j M) @@ l == (zmon j M) @@ l. Proof. destruct M; simpl; rsimpl. Qed. Lemma zmon_pred_ok M j l : (zmon_pred j M) @@ (tail l) == (zmon j M) @@ l. Proof. destruct j; simpl; rewrite ?mkZmon_ok; simpl; rsimpl. - now rewrite Mjump_xO_tail. - rewrite Mjump_pred_double; rsimpl. Qed. Lemma mkVmon_ok M i l : (mkVmon i M)@@l == M@@l * (hd l)^i. Proof. destruct M;simpl;intros;rsimpl. - rewrite zmon_pred_ok;simpl;rsimpl. - rewrite pow_pos_add;rsimpl. Qed. Ltac destr_mfactor R S := match goal with | H : context [MFactor ?P _] |- context [MFactor ?P ?M] => specialize (H M); destruct MFactor as (R,S) end. Lemma Mphi_ok P M l : let (Q,R) := MFactor P M in P@l == Q@l + M@@l * R@l. Proof. revert M l; induction P; destruct M; intros l; simpl; auto; Esimpl. - case Pos.compare_spec; intros He; simpl. * destr_mfactor R1 S1. now rewrite IHP, He, !mkPinj_ok. * destr_mfactor R1 S1. rewrite IHP; simpl. now rewrite !mkPinj_ok, <- Mjump_add, Pos.add_comm, Pos.sub_add. * Esimpl. - destr_mfactor R1 S1. destr_mfactor R2 S2. rewrite IHP1, IHP2, !mkPX_ok, zmon_pred_ok; simpl; rsimpl. add_permut. - case Pos.compare_spec; intros He; simpl; destr_mfactor R1 S1; rewrite ?He, IHP1, mkPX_ok, ?mkZmon_ok; simpl; rsimpl; unfold tail; add_permut; mul_permut. * rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add by trivial; rsimpl. * rewrite mkPX_ok. simpl. Esimpl. mul_permut. rewrite <- pow_pos_add, Pos.sub_add by trivial; rsimpl. Qed. Lemma POneSubst_ok P1 M1 P2 P3 l : POneSubst P1 M1 P2 = Some P3 -> M1@@l == P2@l -> P1@l == P3@l. Proof. unfold POneSubst. assert (H := Mphi_ok P1). destr_mfactor R1 S1. rewrite H; clear H. intros EQ EQ'. replace P3 with (R1 ++ P2 ** S1). - rewrite EQ', Padd_ok, Pmul_ok; rsimpl. - revert EQ. destruct S1; try now injection 1. case ceqb_spec; now inversion 2. Qed. Lemma PNSubst1_ok n P1 M1 P2 l : M1@@l == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l. Proof. revert P1. induction n; simpl; intros P1; generalize (POneSubst_ok P1 M1 P2); destruct POneSubst; intros; rewrite <- ?IHn; auto; reflexivity. Qed. Lemma PNSubst_ok n P1 M1 P2 l P3 : PNSubst P1 M1 P2 n = Some P3 -> M1@@l == P2@l -> P1@l == P3@l. Proof. unfold PNSubst. assert (H := POneSubst_ok P1 M1 P2); destruct POneSubst; try discriminate. destruct n; inversion_clear 1. intros. rewrite <- PNSubst1_ok; auto. Qed. Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) : Prop := match LM1 with | cons (M1,P2) LM2 => (M1@@l == P2@l) /\ MPcond LM2 l | _ => True end. Lemma PSubstL1_ok n LM1 P1 l : MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. Proof. revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. - reflexivity. - rewrite <- IH by intuition. now apply PNSubst1_ok. Qed. Lemma PSubstL_ok n LM1 P1 P2 l : PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. Proof. revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros. - discriminate. - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst. * injection H; intros <-. rewrite <- PSubstL1_ok; intuition. * now apply IH. Qed. Lemma PNSubstL_ok m n LM1 P1 l : MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. Proof. revert LM1 P1. induction m; simpl; intros; assert (H' := PSubstL_ok n LM1 P2); destruct PSubstL; auto; try reflexivity. rewrite <- IHm; auto. Qed. (** Definition of polynomial expressions *) Inductive PExpr : Type := | PEc : C -> PExpr | PEX : positive -> PExpr | PEadd : PExpr -> PExpr -> PExpr | PEsub : PExpr -> PExpr -> PExpr | PEmul : PExpr -> PExpr -> PExpr | PEopp : PExpr -> PExpr | PEpow : PExpr -> N -> PExpr. (** evaluation of polynomial expressions towards R *) Definition mk_X j := mkPinj_pred j mkX. (** evaluation of polynomial expressions towards R *) Fixpoint PEeval (l:Env R) (pe:PExpr) : R := match pe with | PEc c => phi c | PEX j => nth j l | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) | PEopp pe1 => - (PEeval l pe1) | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) end. (** Correctness proofs *) Lemma mkX_ok p l : nth p l == (mk_X p) @ l. Proof. destruct p;simpl;intros;Esimpl;trivial. rewrite nth_spec ; auto. unfold hd. now rewrite <- nth_pred_double, nth_jump. Qed. Hint Rewrite Padd_ok Psub_ok : Esimpl. Section POWER. Variable subst_l : Pol -> Pol. Fixpoint Ppow_pos (res P:Pol) (p:positive) : Pol := match p with | xH => subst_l (res ** P) | xO p => Ppow_pos (Ppow_pos res P p) P p | xI p => subst_l ((Ppow_pos (Ppow_pos res P p) P p) ** P) end. Definition Ppow_N P n := match n with | N0 => P1 | Npos p => Ppow_pos P1 P p end. Lemma Ppow_pos_ok l : (forall P, subst_l P@l == P@l) -> forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. Proof. intros subst_l_ok res P p. revert res. induction p;simpl;intros; rewrite ?subst_l_ok, ?Pmul_ok, ?IHp; mul_permut. Qed. Lemma Ppow_N_ok l : (forall P, subst_l P@l == P@l) -> forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. Proof. destruct n;simpl. - reflexivity. - rewrite Ppow_pos_ok by trivial. Esimpl. Qed. End POWER. (** Normalization and rewriting *) Section NORM_SUBST_REC. Variable n : nat. Variable lmp:list (Mon*Pol). Let subst_l P := PNSubstL P lmp n n. Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2). Let Ppow_subst := Ppow_N subst_l. Fixpoint norm_aux (pe:PExpr) : Pol := match pe with | PEc c => Pc c | PEX j => mk_X j | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1) | PEadd pe1 (PEopp pe2) => Psub (norm_aux pe1) (norm_aux pe2) | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2) | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2) | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) | PEopp pe1 => Popp (norm_aux pe1) | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n end. Definition norm_subst pe := subst_l (norm_aux pe). (** Internally, [norm_aux] is expanded in a large number of cases. To speed-up proofs, we use an alternative definition. *) Definition get_PEopp pe := match pe with | PEopp pe' => Some pe' | _ => None end. Lemma norm_aux_PEadd pe1 pe2 : norm_aux (PEadd pe1 pe2) = match get_PEopp pe1, get_PEopp pe2 with | Some pe1', _ => (norm_aux pe2) -- (norm_aux pe1') | None, Some pe2' => (norm_aux pe1) -- (norm_aux pe2') | None, None => (norm_aux pe1) ++ (norm_aux pe2) end. Proof. simpl (norm_aux (PEadd _ _)). destruct pe1; [ | | | | | reflexivity | ]; destruct pe2; simpl get_PEopp; reflexivity. Qed. Lemma norm_aux_PEopp pe : match get_PEopp pe with | Some pe' => norm_aux pe = -- (norm_aux pe') | None => True end. Proof. now destruct pe. Qed. Lemma norm_aux_spec l pe : PEeval l pe == (norm_aux pe)@l. Proof. intros. induction pe. - reflexivity. - apply mkX_ok. - simpl PEeval. rewrite IHpe1, IHpe2. assert (H1 := norm_aux_PEopp pe1). assert (H2 := norm_aux_PEopp pe2). rewrite norm_aux_PEadd. do 2 destruct get_PEopp; rewrite ?H1, ?H2; Esimpl; add_permut. - simpl. rewrite IHpe1, IHpe2. Esimpl. - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - simpl. rewrite IHpe. Esimpl. - simpl. rewrite Ppow_N_ok by reflexivity. rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl. induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. Qed. End NORM_SUBST_REC. End MakeRingPol. coq-8.4pl4/plugins/micromega/sos.ml0000644000175000017500000022125312326224777016422 0ustar stephsteph(* ========================================================================= *) (* - This code originates from John Harrison's HOL LIGHT 2.30 *) (* (see file LICENSE.sos for license, copyright and disclaimer) *) (* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL *) (* independent bits *) (* - Frédéric Besson (fbesson@irisa.fr) is using it to feed micromega *) (* ========================================================================= *) (* ========================================================================= *) (* Nonlinear universal reals procedure using SOS decomposition. *) (* ========================================================================= *) open Num;; open List;; open Sos_types;; open Sos_lib;; (* prioritize_real();; *) let debugging = ref false;; exception Sanity;; exception Unsolvable;; (* ------------------------------------------------------------------------- *) (* Turn a rational into a decimal string with d sig digits. *) (* ------------------------------------------------------------------------- *) let decimalize = let rec normalize y = if abs_num y =/ Int 1 then normalize (y // Int 10) + 1 else 0 in fun d x -> if x =/ Int 0 then "0.0" else let y = abs_num x in let e = normalize y in let z = pow10(-e) */ y +/ Int 1 in let k = round_num(pow10 d */ z) in (if x a | h::t -> itern (k + 1) t f (f h k a);; let rec iter (m,n) f a = if n < m then a else iter (m+1,n) f (f m a);; (* ------------------------------------------------------------------------- *) (* The main types. *) (* ------------------------------------------------------------------------- *) type vector = int*(int,num)func;; type matrix = (int*int)*(int*int,num)func;; type monomial = (vname,int)func;; type poly = (monomial,num)func;; (* ------------------------------------------------------------------------- *) (* Assignment avoiding zeros. *) (* ------------------------------------------------------------------------- *) let (|-->) x y a = if y =/ Int 0 then a else (x |-> y) a;; (* ------------------------------------------------------------------------- *) (* This can be generic. *) (* ------------------------------------------------------------------------- *) let element (d,v) i = tryapplyd v i (Int 0);; let mapa f (d,v) = d,foldl (fun a i c -> (i |--> f(c)) a) undefined v;; let is_zero (d,v) = match v with Empty -> true | _ -> false;; (* ------------------------------------------------------------------------- *) (* Vectors. Conventionally indexed 1..n. *) (* ------------------------------------------------------------------------- *) let vector_0 n = (n,undefined:vector);; let dim (v:vector) = fst v;; let vector_const c n = if c =/ Int 0 then vector_0 n else (n,itlist (fun k -> k |-> c) (1--n) undefined :vector);; let vector_1 = vector_const (Int 1);; let vector_cmul c (v:vector) = let n = dim v in if c =/ Int 0 then vector_0 n else n,mapf (fun x -> c */ x) (snd v) let vector_neg (v:vector) = (fst v,mapf minus_num (snd v) :vector);; let vector_add (v1:vector) (v2:vector) = let m = dim v1 and n = dim v2 in if m <> n then failwith "vector_add: incompatible dimensions" else (n,combine (+/) (fun x -> x =/ Int 0) (snd v1) (snd v2) :vector);; let vector_sub v1 v2 = vector_add v1 (vector_neg v2);; let vector_dot (v1:vector) (v2:vector) = let m = dim v1 and n = dim v2 in if m <> n then failwith "vector_add: incompatible dimensions" else foldl (fun a i x -> x +/ a) (Int 0) (combine ( */ ) (fun x -> x =/ Int 0) (snd v1) (snd v2));; let vector_of_list l = let n = length l in (n,itlist2 (|->) (1--n) l undefined :vector);; (* ------------------------------------------------------------------------- *) (* Matrices; again rows and columns indexed from 1. *) (* ------------------------------------------------------------------------- *) let matrix_0 (m,n) = ((m,n),undefined:matrix);; let dimensions (m:matrix) = fst m;; let matrix_const c (m,n as mn) = if m <> n then failwith "matrix_const: needs to be square" else if c =/ Int 0 then matrix_0 mn else (mn,itlist (fun k -> (k,k) |-> c) (1--n) undefined :matrix);; let matrix_1 = matrix_const (Int 1);; let matrix_cmul c (m:matrix) = let (i,j) = dimensions m in if c =/ Int 0 then matrix_0 (i,j) else (i,j),mapf (fun x -> c */ x) (snd m);; let matrix_neg (m:matrix) = (dimensions m,mapf minus_num (snd m) :matrix);; let matrix_add (m1:matrix) (m2:matrix) = let d1 = dimensions m1 and d2 = dimensions m2 in if d1 <> d2 then failwith "matrix_add: incompatible dimensions" else (d1,combine (+/) (fun x -> x =/ Int 0) (snd m1) (snd m2) :matrix);; let matrix_sub m1 m2 = matrix_add m1 (matrix_neg m2);; let row k (m:matrix) = let i,j = dimensions m in (j, foldl (fun a (i,j) c -> if i = k then (j |-> c) a else a) undefined (snd m) : vector);; let column k (m:matrix) = let i,j = dimensions m in (i, foldl (fun a (i,j) c -> if j = k then (i |-> c) a else a) undefined (snd m) : vector);; let transp (m:matrix) = let i,j = dimensions m in ((j,i),foldl (fun a (i,j) c -> ((j,i) |-> c) a) undefined (snd m) :matrix);; let diagonal (v:vector) = let n = dim v in ((n,n),foldl (fun a i c -> ((i,i) |-> c) a) undefined (snd v) : matrix);; let matrix_of_list l = let m = length l in if m = 0 then matrix_0 (0,0) else let n = length (hd l) in (m,n),itern 1 l (fun v i -> itern 1 v (fun c j -> (i,j) |-> c)) undefined;; (* ------------------------------------------------------------------------- *) (* Monomials. *) (* ------------------------------------------------------------------------- *) let monomial_eval assig (m:monomial) = foldl (fun a x k -> a */ power_num (apply assig x) (Int k)) (Int 1) m;; let monomial_1 = (undefined:monomial);; let monomial_var x = (x |=> 1 :monomial);; let (monomial_mul:monomial->monomial->monomial) = combine (+) (fun x -> false);; let monomial_pow (m:monomial) k = if k = 0 then monomial_1 else mapf (fun x -> k * x) m;; let monomial_divides (m1:monomial) (m2:monomial) = foldl (fun a x k -> tryapplyd m2 x 0 >= k & a) true m1;; let monomial_div (m1:monomial) (m2:monomial) = let m = combine (+) (fun x -> x = 0) m1 (mapf (fun x -> -x) m2) in if foldl (fun a x k -> k >= 0 & a) true m then m else failwith "monomial_div: non-divisible";; let monomial_degree x (m:monomial) = tryapplyd m x 0;; let monomial_lcm (m1:monomial) (m2:monomial) = (itlist (fun x -> x |-> max (monomial_degree x m1) (monomial_degree x m2)) (union (dom m1) (dom m2)) undefined :monomial);; let monomial_multidegree (m:monomial) = foldl (fun a x k -> k + a) 0 m;; let monomial_variables m = dom m;; (* ------------------------------------------------------------------------- *) (* Polynomials. *) (* ------------------------------------------------------------------------- *) let eval assig (p:poly) = foldl (fun a m c -> a +/ c */ monomial_eval assig m) (Int 0) p;; let poly_0 = (undefined:poly);; let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 & a) true p;; let poly_var x = ((monomial_var x) |=> Int 1 :poly);; let poly_const c = if c =/ Int 0 then poly_0 else (monomial_1 |=> c);; let poly_cmul c (p:poly) = if c =/ Int 0 then poly_0 else mapf (fun x -> c */ x) p;; let poly_neg (p:poly) = (mapf minus_num p :poly);; let poly_add (p1:poly) (p2:poly) = (combine (+/) (fun x -> x =/ Int 0) p1 p2 :poly);; let poly_sub p1 p2 = poly_add p1 (poly_neg p2);; let poly_cmmul (c,m) (p:poly) = if c =/ Int 0 then poly_0 else if m = monomial_1 then mapf (fun d -> c */ d) p else foldl (fun a m' d -> (monomial_mul m m' |-> c */ d) a) poly_0 p;; let poly_mul (p1:poly) (p2:poly) = foldl (fun a m c -> poly_add (poly_cmmul (c,m) p2) a) poly_0 p1;; let poly_div (p1:poly) (p2:poly) = if not(poly_isconst p2) then failwith "poly_div: non-constant" else let c = eval undefined p2 in if c =/ Int 0 then failwith "poly_div: division by zero" else poly_cmul (Int 1 // c) p1;; let poly_square p = poly_mul p p;; let rec poly_pow p k = if k = 0 then poly_const (Int 1) else if k = 1 then p else let q = poly_square(poly_pow p (k / 2)) in if k mod 2 = 1 then poly_mul p q else q;; let poly_exp p1 p2 = if not(poly_isconst p2) then failwith "poly_exp: not a constant" else poly_pow p1 (Num.int_of_num (eval undefined p2));; let degree x (p:poly) = foldl (fun a m c -> max (monomial_degree x m) a) 0 p;; let multidegree (p:poly) = foldl (fun a m c -> max (monomial_multidegree m) a) 0 p;; let poly_variables (p:poly) = foldr (fun m c -> union (monomial_variables m)) p [];; (* ------------------------------------------------------------------------- *) (* Order monomials for human presentation. *) (* ------------------------------------------------------------------------- *) let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 or x1 = x2 & k1 > k2;; let humanorder_monomial = let rec ord l1 l2 = match (l1,l2) with _,[] -> true | [],_ -> false | h1::t1,h2::t2 -> humanorder_varpow h1 h2 or h1 = h2 & ord t1 t2 in fun m1 m2 -> m1 = m2 or ord (sort humanorder_varpow (graph m1)) (sort humanorder_varpow (graph m2));; (* ------------------------------------------------------------------------- *) (* Conversions to strings. *) (* ------------------------------------------------------------------------- *) let string_of_vector min_size max_size (v:vector) = let n_raw = dim v in if n_raw = 0 then "[]" else let n = max min_size (min n_raw max_size) in let xs = map ((o) string_of_num (element v)) (1--n) in "[" ^ end_itlist (fun s t -> s ^ ", " ^ t) xs ^ (if n_raw > max_size then ", ...]" else "]");; let string_of_matrix max_size (m:matrix) = let i_raw,j_raw = dimensions m in let i = min max_size i_raw and j = min max_size j_raw in let rstr = map (fun k -> string_of_vector j j (row k m)) (1--i) in "["^end_itlist(fun s t -> s^";\n "^t) rstr ^ (if j > max_size then "\n ...]" else "]");; let string_of_vname (v:vname): string = (v: string);; let rec string_of_term t = match t with Opp t1 -> "(- " ^ string_of_term t1 ^ ")" | Add (t1, t2) -> "(" ^ (string_of_term t1) ^ " + " ^ (string_of_term t2) ^ ")" | Sub (t1, t2) -> "(" ^ (string_of_term t1) ^ " - " ^ (string_of_term t2) ^ ")" | Mul (t1, t2) -> "(" ^ (string_of_term t1) ^ " * " ^ (string_of_term t2) ^ ")" | Inv t1 -> "(/ " ^ string_of_term t1 ^ ")" | Div (t1, t2) -> "(" ^ (string_of_term t1) ^ " / " ^ (string_of_term t2) ^ ")" | Pow (t1, n1) -> "(" ^ (string_of_term t1) ^ " ^ " ^ (string_of_int n1) ^ ")" | Zero -> "0" | Var v -> "x" ^ (string_of_vname v) | Const x -> string_of_num x;; let string_of_varpow x k = if k = 1 then string_of_vname x else string_of_vname x^"^"^string_of_int k;; let string_of_monomial m = if m = monomial_1 then "1" else let vps = List.fold_right (fun (x,k) a -> string_of_varpow x k :: a) (sort humanorder_varpow (graph m)) [] in end_itlist (fun s t -> s^"*"^t) vps;; let string_of_cmonomial (c,m) = if m = monomial_1 then string_of_num c else if c =/ Int 1 then string_of_monomial m else string_of_num c ^ "*" ^ string_of_monomial m;; let string_of_poly (p:poly) = if p = poly_0 then "<<0>>" else let cms = sort (fun (m1,_) (m2,_) -> humanorder_monomial m1 m2) (graph p) in let s = List.fold_left (fun a (m,c) -> if c >";; (* ------------------------------------------------------------------------- *) (* Printers. *) (* ------------------------------------------------------------------------- *) let print_vector v = Format.print_string(string_of_vector 0 20 v);; let print_matrix m = Format.print_string(string_of_matrix 20 m);; let print_monomial m = Format.print_string(string_of_monomial m);; let print_poly m = Format.print_string(string_of_poly m);; (* #install_printer print_vector;; #install_printer print_matrix;; #install_printer print_monomial;; #install_printer print_poly;; *) (* ------------------------------------------------------------------------- *) (* Conversion from term. *) (* ------------------------------------------------------------------------- *) let rec poly_of_term t = match t with Zero -> poly_0 | Const n -> poly_const n | Var x -> poly_var x | Opp t1 -> poly_neg (poly_of_term t1) | Inv t1 -> let p = poly_of_term t1 in if poly_isconst p then poly_const(Int 1 // eval undefined p) else failwith "poly_of_term: inverse of non-constant polyomial" | Add (l, r) -> poly_add (poly_of_term l) (poly_of_term r) | Sub (l, r) -> poly_sub (poly_of_term l) (poly_of_term r) | Mul (l, r) -> poly_mul (poly_of_term l) (poly_of_term r) | Div (l, r) -> let p = poly_of_term l and q = poly_of_term r in if poly_isconst q then poly_cmul (Int 1 // eval undefined q) p else failwith "poly_of_term: division by non-constant polynomial" | Pow (t, n) -> poly_pow (poly_of_term t) n;; (* ------------------------------------------------------------------------- *) (* String of vector (just a list of space-separated numbers). *) (* ------------------------------------------------------------------------- *) let sdpa_of_vector (v:vector) = let n = dim v in let strs = map (o (decimalize 20) (element v)) (1--n) in end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";; (* ------------------------------------------------------------------------- *) (* String for block diagonal matrix numbered k. *) (* ------------------------------------------------------------------------- *) let sdpa_of_blockdiagonal k m = let pfx = string_of_int k ^" " in let ents = foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in let entss = sort (increasing fst) ents in itlist (fun ((b,i,j),c) a -> pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) entss "";; (* ------------------------------------------------------------------------- *) (* String for a matrix numbered k, in SDPA sparse format. *) (* ------------------------------------------------------------------------- *) let sdpa_of_matrix k (m:matrix) = let pfx = string_of_int k ^ " 1 " in let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a) (snd m) [] in let mss = sort (increasing fst) ms in itlist (fun ((i,j),c) a -> pfx ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) mss "";; (* ------------------------------------------------------------------------- *) (* String in SDPA sparse format for standard SDP problem: *) (* *) (* X = v_1 * [M_1] + ... + v_m * [M_m] - [M_0] must be PSD *) (* Minimize obj_1 * v_1 + ... obj_m * v_m *) (* ------------------------------------------------------------------------- *) let sdpa_of_problem comment obj mats = let m = length mats - 1 and n,_ = dimensions (hd mats) in "\"" ^ comment ^ "\"\n" ^ string_of_int m ^ "\n" ^ "1\n" ^ string_of_int n ^ "\n" ^ sdpa_of_vector obj ^ itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) (1--length mats) mats "";; (* ------------------------------------------------------------------------- *) (* More parser basics. *) (* ------------------------------------------------------------------------- *) let word s = end_itlist (fun p1 p2 -> (p1 ++ p2) >> (fun (s,t) -> s^t)) (map a (explode s));; let token s = many (some isspace) ++ word s ++ many (some isspace) >> (fun ((_,t),_) -> t);; let decimal = let numeral = some isnum in let decimalint = atleast 1 numeral >> ((o) Num.num_of_string implode) in let decimalfrac = atleast 1 numeral >> (fun s -> Num.num_of_string(implode s) // pow10 (length s)) in let decimalsig = decimalint ++ possibly (a "." ++ decimalfrac >> snd) >> (function (h,[x]) -> h +/ x | (h,_) -> h) in let signed prs = a "-" ++ prs >> ((o) minus_num snd) || a "+" ++ prs >> snd || prs in let exponent = (a "e" || a "E") ++ signed decimalint >> snd in signed decimalsig ++ possibly exponent >> (function (h,[x]) -> h */ power_num (Int 10) x | (h,_) -> h);; let mkparser p s = let x,rst = p(explode s) in if rst = [] then x else failwith "mkparser: unparsed input";; let parse_decimal = mkparser decimal;; (* ------------------------------------------------------------------------- *) (* Parse back a vector. *) (* ------------------------------------------------------------------------- *) let parse_sdpaoutput,parse_csdpoutput = let vector = token "{" ++ listof decimal (token ",") "decimal" ++ token "}" >> (fun ((_,v),_) -> vector_of_list v) in let rec skipupto dscr prs inp = (dscr ++ prs >> snd || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in let ignore inp = (),[] in let sdpaoutput = skipupto (word "xVec" ++ token "=") (vector ++ ignore >> fst) in let csdpoutput = (decimal ++ many(a " " ++ decimal >> snd) >> (fun (h,t) -> h::t)) ++ (a " " ++ a "\n" ++ ignore) >> ((o) vector_of_list fst) in mkparser sdpaoutput,mkparser csdpoutput;; (* ------------------------------------------------------------------------- *) (* Also parse the SDPA output to test success (CSDP yields a return code). *) (* ------------------------------------------------------------------------- *) let sdpa_run_succeeded = let rec skipupto dscr prs inp = (dscr ++ prs >> snd || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in let prs = skipupto (word "phase.value" ++ token "=") (possibly (a "p") ++ possibly (a "d") ++ (word "OPT" || word "FEAS")) in fun s -> try ignore (prs (explode s)); true with Noparse -> false;; (* ------------------------------------------------------------------------- *) (* The default parameters. Unfortunately this goes to a fixed file. *) (* ------------------------------------------------------------------------- *) let sdpa_default_parameters = "100 unsigned int maxIteration;\ \n1.0E-7 double 0.0 < epsilonStar;\ \n1.0E2 double 0.0 < lambdaStar;\ \n2.0 double 1.0 < omegaStar;\ \n-1.0E5 double lowerBound;\ \n1.0E5 double upperBound;\ \n0.1 double 0.0 <= betaStar < 1.0;\ \n0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\ \n0.9 double 0.0 < gammaStar < 1.0;\ \n1.0E-7 double 0.0 < epsilonDash;\ \n";; (* ------------------------------------------------------------------------- *) (* These were suggested by Makoto Yamashita for problems where we are *) (* right at the edge of the semidefinite cone, as sometimes happens. *) (* ------------------------------------------------------------------------- *) let sdpa_alt_parameters = "1000 unsigned int maxIteration;\ \n1.0E-7 double 0.0 < epsilonStar;\ \n1.0E4 double 0.0 < lambdaStar;\ \n2.0 double 1.0 < omegaStar;\ \n-1.0E5 double lowerBound;\ \n1.0E5 double upperBound;\ \n0.1 double 0.0 <= betaStar < 1.0;\ \n0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\ \n0.9 double 0.0 < gammaStar < 1.0;\ \n1.0E-7 double 0.0 < epsilonDash;\ \n";; let sdpa_params = sdpa_alt_parameters;; (* ------------------------------------------------------------------------- *) (* CSDP parameters; so far I'm sticking with the defaults. *) (* ------------------------------------------------------------------------- *) let csdp_default_parameters = "axtol=1.0e-8\ \natytol=1.0e-8\ \nobjtol=1.0e-8\ \npinftol=1.0e8\ \ndinftol=1.0e8\ \nmaxiter=100\ \nminstepfrac=0.9\ \nmaxstepfrac=0.97\ \nminstepp=1.0e-8\ \nminstepd=1.0e-8\ \nusexzgap=1\ \ntweakgap=0\ \naffine=0\ \nprintlevel=1\ \n";; let csdp_params = csdp_default_parameters;; (* ------------------------------------------------------------------------- *) (* Now call CSDP on a problem and parse back the output. *) (* ------------------------------------------------------------------------- *) let run_csdp dbg obj mats = let input_file = Filename.temp_file "sos" ".dat-s" in let output_file = String.sub input_file 0 (String.length input_file - 6) ^ ".out" and params_file = Filename.concat (!temp_path) "param.csdp" in file_of_string input_file (sdpa_of_problem "" obj mats); file_of_string params_file csdp_params; let rv = Sys.command("cd "^(!temp_path)^"; csdp "^input_file ^ " " ^ output_file ^ (if dbg then "" else "> /dev/null")) in let op = string_of_file output_file in let res = parse_csdpoutput op in ((if dbg then () else (Sys.remove input_file; Sys.remove output_file)); rv,res);; let csdp obj mats = let rv,res = run_csdp (!debugging) obj mats in (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible" else if rv = 3 then () (* Format.print_string "csdp warning: Reduced accuracy"; Format.print_newline() *) else if rv <> 0 then failwith("csdp: error "^string_of_int rv) else ()); res;; (* ------------------------------------------------------------------------- *) (* Try some apparently sensible scaling first. Note that this is purely to *) (* get a cleaner translation to floating-point, and doesn't affect any of *) (* the results, in principle. In practice it seems a lot better when there *) (* are extreme numbers in the original problem. *) (* ------------------------------------------------------------------------- *) let scale_then = let common_denominator amat acc = foldl (fun a m c -> lcm_num (denominator c) a) acc amat and maximal_element amat acc = foldl (fun maxa m c -> max_num maxa (abs_num c)) acc amat in fun solver obj mats -> let cd1 = itlist common_denominator mats (Int 1) and cd2 = common_denominator (snd obj) (Int 1) in let mats' = map (mapf (fun x -> cd1 */ x)) mats and obj' = vector_cmul cd2 obj in let max1 = itlist maximal_element mats' (Int 0) and max2 = maximal_element (snd obj') (Int 0) in let scal1 = pow2 (20-int_of_float(log(float_of_num max1) /. log 2.0)) and scal2 = pow2 (20-int_of_float(log(float_of_num max2) /. log 2.0)) in let mats'' = map (mapf (fun x -> x */ scal1)) mats' and obj'' = vector_cmul scal2 obj' in solver obj'' mats'';; (* ------------------------------------------------------------------------- *) (* Round a vector to "nice" rationals. *) (* ------------------------------------------------------------------------- *) let nice_rational n x = round_num (n */ x) // n;; let nice_vector n = mapa (nice_rational n);; (* ------------------------------------------------------------------------- *) (* Reduce linear program to SDP (diagonal matrices) and test with CSDP. This *) (* one tests A [-1;x1;..;xn] >= 0 (i.e. left column is negated constants). *) (* ------------------------------------------------------------------------- *) let linear_program_basic a = let m,n = dimensions a in let mats = map (fun j -> diagonal (column j a)) (1--n) and obj = vector_const (Int 1) m in let rv,res = run_csdp false obj mats in if rv = 1 or rv = 2 then false else if rv = 0 then true else failwith "linear_program: An error occurred in the SDP solver";; (* ------------------------------------------------------------------------- *) (* Alternative interface testing A x >= b for matrix A, vector b. *) (* ------------------------------------------------------------------------- *) let linear_program a b = let m,n = dimensions a in if dim b <> m then failwith "linear_program: incompatible dimensions" else let mats = diagonal b :: map (fun j -> diagonal (column j a)) (1--n) and obj = vector_const (Int 1) m in let rv,res = run_csdp false obj mats in if rv = 1 or rv = 2 then false else if rv = 0 then true else failwith "linear_program: An error occurred in the SDP solver";; (* ------------------------------------------------------------------------- *) (* Test whether a point is in the convex hull of others. Rather than use *) (* computational geometry, express as linear inequalities and call CSDP. *) (* This is a bit lazy of me, but it's easy and not such a bottleneck so far. *) (* ------------------------------------------------------------------------- *) let in_convex_hull pts pt = let pts1 = (1::pt) :: map (fun x -> 1::x) pts in let pts2 = map (fun p -> map (fun x -> -x) p @ p) pts1 in let n = length pts + 1 and v = 2 * (length pt + 1) in let m = v + n - 1 in let mat = (m,n), itern 1 pts2 (fun pts j -> itern 1 pts (fun x i -> (i,j) |-> Int x)) (iter (1,n) (fun i -> (v + i,i+1) |-> Int 1) undefined) in linear_program_basic mat;; (* ------------------------------------------------------------------------- *) (* Filter down a set of points to a minimal set with the same convex hull. *) (* ------------------------------------------------------------------------- *) let minimal_convex_hull = let augment1 = function | [] -> assert false | (m::ms) -> if in_convex_hull ms m then ms else ms@[m] in let augment m ms = funpow 3 augment1 (m::ms) in fun mons -> let mons' = itlist augment (tl mons) [hd mons] in funpow (length mons') augment1 mons';; (* ------------------------------------------------------------------------- *) (* Stuff for "equations" (generic A->num functions). *) (* ------------------------------------------------------------------------- *) let equation_cmul c eq = if c =/ Int 0 then Empty else mapf (fun d -> c */ d) eq;; let equation_add eq1 eq2 = combine (+/) (fun x -> x =/ Int 0) eq1 eq2;; let equation_eval assig eq = let value v = apply assig v in foldl (fun a v c -> a +/ value(v) */ c) (Int 0) eq;; (* ------------------------------------------------------------------------- *) (* Eliminate among linear equations: return unconstrained variables and *) (* assignments for the others in terms of them. We give one pseudo-variable *) (* "one" that's used for a constant term. *) (* ------------------------------------------------------------------------- *) let failstore = ref [];; let eliminate_equations = let rec extract_first p l = match l with [] -> failwith "extract_first" | h::t -> if p(h) then h,t else let k,s = extract_first p t in k,h::s in let rec eliminate vars dun eqs = match vars with [] -> if forall is_undefined eqs then dun else (failstore := [vars,dun,eqs]; raise Unsolvable) | v::vs -> try let eq,oeqs = extract_first (fun e -> defined e v) eqs in let a = apply eq v in let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in let elim e = let b = tryapplyd e v (Int 0) in if b =/ Int 0 then e else equation_add e (equation_cmul (minus_num b // a) eq) in eliminate vs ((v |-> eq') (mapf elim dun)) (map elim oeqs) with Failure _ -> eliminate vs dun eqs in fun one vars eqs -> let assig = eliminate vars undefined eqs in let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in setify vs,assig;; (* ------------------------------------------------------------------------- *) (* Eliminate all variables, in an essentially arbitrary order. *) (* ------------------------------------------------------------------------- *) let eliminate_all_equations one = let choose_variable eq = let (v,_) = choose eq in if v = one then let eq' = undefine v eq in if is_undefined eq' then failwith "choose_variable" else let (w,_) = choose eq' in w else v in let rec eliminate dun eqs = match eqs with [] -> dun | eq::oeqs -> if is_undefined eq then eliminate dun oeqs else let v = choose_variable eq in let a = apply eq v in let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in let elim e = let b = tryapplyd e v (Int 0) in if b =/ Int 0 then e else equation_add e (equation_cmul (minus_num b // a) eq) in eliminate ((v |-> eq') (mapf elim dun)) (map elim oeqs) in fun eqs -> let assig = eliminate undefined eqs in let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in setify vs,assig;; (* ------------------------------------------------------------------------- *) (* Solve equations by assigning arbitrary numbers. *) (* ------------------------------------------------------------------------- *) let solve_equations one eqs = let vars,assigs = eliminate_all_equations one eqs in let vfn = itlist (fun v -> (v |-> Int 0)) vars (one |=> Int(-1)) in let ass = combine (+/) (fun c -> false) (mapf (equation_eval vfn) assigs) vfn in if forall (fun e -> equation_eval ass e =/ Int 0) eqs then undefine one ass else raise Sanity;; (* ------------------------------------------------------------------------- *) (* Hence produce the "relevant" monomials: those whose squares lie in the *) (* Newton polytope of the monomials in the input. (This is enough according *) (* to Reznik: "Extremal PSD forms with few terms", Duke Math. Journal, *) (* vol 45, pp. 363--374, 1978. *) (* *) (* These are ordered in sort of decreasing degree. In particular the *) (* constant monomial is last; this gives an order in diagonalization of the *) (* quadratic form that will tend to display constants. *) (* ------------------------------------------------------------------------- *) let newton_polytope pol = let vars = poly_variables pol in let mons = map (fun m -> map (fun x -> monomial_degree x m) vars) (dom pol) and ds = map (fun x -> (degree x pol + 1) / 2) vars in let all = itlist (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]] and mons' = minimal_convex_hull mons in let all' = filter (fun m -> in_convex_hull mons' (map (fun x -> 2 * x) m)) all in map (fun m -> itlist2 (fun v i a -> if i = 0 then a else (v |-> i) a) vars m monomial_1) (rev all');; (* ------------------------------------------------------------------------- *) (* Diagonalize (Cholesky/LDU) the matrix corresponding to a quadratic form. *) (* ------------------------------------------------------------------------- *) let diag m = let nn = dimensions m in let n = fst nn in if snd nn <> n then failwith "diagonalize: non-square matrix" else let rec diagonalize i m = if is_zero m then [] else let a11 = element m (i,i) in if a11 a1k // a11) v in let m' = (n,n), iter (i+1,n) (fun j -> iter (i+1,n) (fun k -> ((j,k) |--> (element m (j,k) -/ element v j */ element v' k)))) undefined in (a11,v')::diagonalize (i + 1) m' in diagonalize 1 m;; (* ------------------------------------------------------------------------- *) (* Adjust a diagonalization to collect rationals at the start. *) (* ------------------------------------------------------------------------- *) let deration d = if d = [] then Int 0,d else let adj(c,l) = let a = foldl (fun a i c -> lcm_num a (denominator c)) (Int 1) (snd l) // foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) in (c // (a */ a)),mapa (fun x -> a */ x) l in let d' = map adj d in let a = itlist ((o) lcm_num ( (o) denominator fst)) d' (Int 1) // itlist ((o) gcd_num ( (o) numerator fst)) d' (Int 0) in (Int 1 // a),map (fun (c,l) -> (a */ c,l)) d';; (* ------------------------------------------------------------------------- *) (* Enumeration of monomials with given multidegree bound. *) (* ------------------------------------------------------------------------- *) let rec enumerate_monomials d vars = if d < 0 then [] else if d = 0 then [undefined] else if vars = [] then [monomial_1] else let alts = map (fun k -> let oths = enumerate_monomials (d - k) (tl vars) in map (fun ks -> if k = 0 then ks else (hd vars |-> k) ks) oths) (0--d) in end_itlist (@) alts;; (* ------------------------------------------------------------------------- *) (* Enumerate products of distinct input polys with degree <= d. *) (* We ignore any constant input polynomials. *) (* Give the output polynomial and a record of how it was derived. *) (* ------------------------------------------------------------------------- *) let rec enumerate_products d pols = if d = 0 then [poly_const num_1,Rational_lt num_1] else if d < 0 then [] else match pols with [] -> [poly_const num_1,Rational_lt num_1] | (p,b)::ps -> let e = multidegree p in if e = 0 then enumerate_products d ps else enumerate_products d ps @ map (fun (q,c) -> poly_mul p q,Product(b,c)) (enumerate_products (d - e) ps);; (* ------------------------------------------------------------------------- *) (* Multiply equation-parametrized poly by regular poly and add accumulator. *) (* ------------------------------------------------------------------------- *) let epoly_pmul p q acc = foldl (fun a m1 c -> foldl (fun b m2 e -> let m = monomial_mul m1 m2 in let es = tryapplyd b m undefined in (m |-> equation_add (equation_cmul c e) es) b) a q) acc p;; (* ------------------------------------------------------------------------- *) (* Usual operations on equation-parametrized poly. *) (* ------------------------------------------------------------------------- *) let epoly_cmul c l = if c =/ Int 0 then undefined else mapf (equation_cmul c) l;; let epoly_neg = epoly_cmul (Int(-1));; let epoly_add = combine equation_add is_undefined;; let epoly_sub p q = epoly_add p (epoly_neg q);; (* ------------------------------------------------------------------------- *) (* Convert regular polynomial. Note that we treat (0,0,0) as -1. *) (* ------------------------------------------------------------------------- *) let epoly_of_poly p = foldl (fun a m c -> (m |-> ((0,0,0) |=> minus_num c)) a) undefined p;; (* ------------------------------------------------------------------------- *) (* String for block diagonal matrix numbered k. *) (* ------------------------------------------------------------------------- *) let sdpa_of_blockdiagonal k m = let pfx = string_of_int k ^" " in let ents = foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in let entss = sort (increasing fst) ents in itlist (fun ((b,i,j),c) a -> pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) entss "";; (* ------------------------------------------------------------------------- *) (* SDPA for problem using block diagonal (i.e. multiple SDPs) *) (* ------------------------------------------------------------------------- *) let sdpa_of_blockproblem comment nblocks blocksizes obj mats = let m = length mats - 1 in "\"" ^ comment ^ "\"\n" ^ string_of_int m ^ "\n" ^ string_of_int nblocks ^ "\n" ^ (end_itlist (fun s t -> s^" "^t) (map string_of_int blocksizes)) ^ "\n" ^ sdpa_of_vector obj ^ itlist2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a) (1--length mats) mats "";; (* ------------------------------------------------------------------------- *) (* Hence run CSDP on a problem in block diagonal form. *) (* ------------------------------------------------------------------------- *) let run_csdp dbg nblocks blocksizes obj mats = let input_file = Filename.temp_file "sos" ".dat-s" in let output_file = String.sub input_file 0 (String.length input_file - 6) ^ ".out" and params_file = Filename.concat (!temp_path) "param.csdp" in file_of_string input_file (sdpa_of_blockproblem "" nblocks blocksizes obj mats); file_of_string params_file csdp_params; let rv = Sys.command("cd "^(!temp_path)^"; csdp "^input_file ^ " " ^ output_file ^ (if dbg then "" else "> /dev/null")) in let op = string_of_file output_file in let res = parse_csdpoutput op in ((if dbg then () else (Sys.remove input_file; Sys.remove output_file)); rv,res);; let csdp nblocks blocksizes obj mats = let rv,res = run_csdp (!debugging) nblocks blocksizes obj mats in (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible" else if rv = 3 then () (*Format.print_string "csdp warning: Reduced accuracy"; Format.print_newline() *) else if rv <> 0 then failwith("csdp: error "^string_of_int rv) else ()); res;; (* ------------------------------------------------------------------------- *) (* 3D versions of matrix operations to consider blocks separately. *) (* ------------------------------------------------------------------------- *) let bmatrix_add = combine (+/) (fun x -> x =/ Int 0);; let bmatrix_cmul c bm = if c =/ Int 0 then undefined else mapf (fun x -> c */ x) bm;; let bmatrix_neg = bmatrix_cmul (Int(-1));; let bmatrix_sub m1 m2 = bmatrix_add m1 (bmatrix_neg m2);; (* ------------------------------------------------------------------------- *) (* Smash a block matrix into components. *) (* ------------------------------------------------------------------------- *) let blocks blocksizes bm = map (fun (bs,b0) -> let m = foldl (fun a (b,i,j) c -> if b = b0 then ((i,j) |-> c) a else a) undefined bm in (((bs,bs),m):matrix)) (zip blocksizes (1--length blocksizes));; (* ------------------------------------------------------------------------- *) (* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *) (* ------------------------------------------------------------------------- *) let real_positivnullstellensatz_general linf d eqs leqs pol = let vars = itlist ((o) union poly_variables) (pol::eqs @ map fst leqs) [] in let monoid = if linf then (poly_const num_1,Rational_lt num_1):: (filter (fun (p,c) -> multidegree p <= d) leqs) else enumerate_products d leqs in let nblocks = length monoid in let mk_idmultiplier k p = let e = d - multidegree p in let mons = enumerate_monomials e vars in let nons = zip mons (1--length mons) in mons, itlist (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in let mk_sqmultiplier k (p,c) = let e = (d - multidegree p) / 2 in let mons = enumerate_monomials e vars in let nons = zip mons (1--length mons) in mons, itlist (fun (m1,n1) -> itlist (fun (m2,n2) a -> let m = monomial_mul m1 m2 in if n1 > n2 then a else let c = if n1 = n2 then Int 1 else Int 2 in let e = tryapplyd a m undefined in (m |-> equation_add ((k,n1,n2) |=> c) e) a) nons) nons undefined in let sqmonlist,sqs = unzip(map2 mk_sqmultiplier (1--length monoid) monoid) and idmonlist,ids = unzip(map2 mk_idmultiplier (1--length eqs) eqs) in let blocksizes = map length sqmonlist in let bigsum = itlist2 (fun p q a -> epoly_pmul p q a) eqs ids (itlist2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs (epoly_of_poly(poly_neg pol))) in let eqns = foldl (fun a m e -> e::a) [] bigsum in let pvs,assig = eliminate_all_equations (0,0,0) eqns in let qvars = (0,0,0)::pvs in let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in let mk_matrix v = foldl (fun m (b,i,j) ass -> if b < 0 then m else let c = tryapplyd ass v (Int 0) in if c =/ Int 0 then m else ((b,j,i) |-> c) (((b,i,j) |-> c) m)) undefined allassig in let diagents = foldl (fun a (b,i,j) e -> if b > 0 & i = j then equation_add e a else a) undefined allassig in let mats = map mk_matrix qvars and obj = length pvs, itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0))) undefined in let raw_vec = if pvs = [] then vector_0 0 else scale_then (csdp nblocks blocksizes) obj mats in let find_rounding d = (if !debugging then (Format.print_string("Trying rounding with limit "^string_of_num d); Format.print_newline()) else ()); let vec = nice_vector d raw_vec in let blockmat = iter (1,dim vec) (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (el i mats)) a) (bmatrix_neg (el 0 mats)) in let allmats = blocks blocksizes blockmat in vec,map diag allmats in let vec,ratdias = if pvs = [] then find_rounding num_1 else tryfind find_rounding (map Num.num_of_int (1--31) @ map pow2 (5--66)) in let newassigs = itlist (fun k -> el (k - 1) pvs |-> element vec k) (1--dim vec) ((0,0,0) |=> Int(-1)) in let finalassigs = foldl (fun a v e -> (v |-> equation_eval newassigs e) a) newassigs allassig in let poly_of_epoly p = foldl (fun a v e -> (v |--> equation_eval finalassigs e) a) undefined p in let mk_sos mons = let mk_sq (c,m) = c,itlist (fun k a -> (el (k - 1) mons |--> element m k) a) (1--length mons) undefined in map mk_sq in let sqs = map2 mk_sos sqmonlist ratdias and cfs = map poly_of_epoly ids in let msq = filter (fun (a,b) -> b <> []) (map2 (fun a b -> a,b) monoid sqs) in let eval_sq sqs = itlist (fun (c,q) -> poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 in let sanity = itlist (fun ((p,c),s) -> poly_add (poly_mul p (eval_sq s))) msq (itlist2 (fun p q -> poly_add (poly_mul p q)) cfs eqs (poly_neg pol)) in if not(is_undefined sanity) then raise Sanity else cfs,map (fun (a,b) -> snd a,b) msq;; (* ------------------------------------------------------------------------- *) (* Iterative deepening. *) (* ------------------------------------------------------------------------- *) let rec deepen f n = try print_string "Searching with depth limit "; print_int n; print_newline(); f n with Failure _ -> deepen f (n + 1);; (* ------------------------------------------------------------------------- *) (* The ordering so we can create canonical HOL polynomials. *) (* ------------------------------------------------------------------------- *) let dest_monomial mon = sort (increasing fst) (graph mon);; let monomial_order = let rec lexorder l1 l2 = match (l1,l2) with [],[] -> true | vps,[] -> false | [],vps -> true | ((x1,n1)::vs1),((x2,n2)::vs2) -> if x1 < x2 then true else if x2 < x1 then false else if n1 < n2 then false else if n2 < n1 then true else lexorder vs1 vs2 in fun m1 m2 -> if m2 = monomial_1 then true else if m1 = monomial_1 then false else let mon1 = dest_monomial m1 and mon2 = dest_monomial m2 in let deg1 = itlist ((o) (+) snd) mon1 0 and deg2 = itlist ((o) (+) snd) mon2 0 in if deg1 < deg2 then false else if deg1 > deg2 then true else lexorder mon1 mon2;; let dest_poly p = map (fun (m,c) -> c,dest_monomial m) (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p));; (* ------------------------------------------------------------------------- *) (* Map back polynomials and their composites to HOL. *) (* ------------------------------------------------------------------------- *) let term_of_varpow = fun x k -> if k = 1 then Var x else Pow (Var x, k);; let term_of_monomial = fun m -> if m = monomial_1 then Const num_1 else let m' = dest_monomial m in let vps = itlist (fun (x,k) a -> term_of_varpow x k :: a) m' [] in end_itlist (fun s t -> Mul (s,t)) vps;; let term_of_cmonomial = fun (m,c) -> if m = monomial_1 then Const c else if c =/ num_1 then term_of_monomial m else Mul (Const c,term_of_monomial m);; let term_of_poly = fun p -> if p = poly_0 then Zero else let cms = map term_of_cmonomial (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p)) in end_itlist (fun t1 t2 -> Add (t1,t2)) cms;; let term_of_sqterm (c,p) = Product(Rational_lt c,Square(term_of_poly p));; let term_of_sos (pr,sqs) = if sqs = [] then pr else Product(pr,end_itlist (fun a b -> Sum(a,b)) (map term_of_sqterm sqs));; (* ------------------------------------------------------------------------- *) (* Interface to HOL. *) (* ------------------------------------------------------------------------- *) (* let REAL_NONLINEAR_PROVER translator (eqs,les,lts) = let eq0 = map (poly_of_term o lhand o concl) eqs and le0 = map (poly_of_term o lhand o concl) les and lt0 = map (poly_of_term o lhand o concl) lts in let eqp0 = map (fun (t,i) -> t,Axiom_eq i) (zip eq0 (0--(length eq0 - 1))) and lep0 = map (fun (t,i) -> t,Axiom_le i) (zip le0 (0--(length le0 - 1))) and ltp0 = map (fun (t,i) -> t,Axiom_lt i) (zip lt0 (0--(length lt0 - 1))) in let keq,eq = partition (fun (p,_) -> multidegree p = 0) eqp0 and klep,lep = partition (fun (p,_) -> multidegree p = 0) lep0 and kltp,ltp = partition (fun (p,_) -> multidegree p = 0) ltp0 in let trivial_axiom (p,ax) = match ax with Axiom_eq n when eval undefined p <>/ num_0 -> el n eqs | Axiom_le n when eval undefined p el n les | Axiom_lt n when eval undefined p <=/ num_0 -> el n lts | _ -> failwith "not a trivial axiom" in try let th = tryfind trivial_axiom (keq @ klep @ kltp) in CONV_RULE (LAND_CONV REAL_POLY_CONV THENC REAL_RAT_RED_CONV) th with Failure _ -> let pol = itlist poly_mul (map fst ltp) (poly_const num_1) in let leq = lep @ ltp in let tryall d = let e = multidegree pol in let k = if e = 0 then 0 else d / e in let eq' = map fst eq in tryfind (fun i -> d,i,real_positivnullstellensatz_general false d eq' leq (poly_neg(poly_pow pol i))) (0--k) in let d,i,(cert_ideal,cert_cone) = deepen tryall 0 in let proofs_ideal = map2 (fun q (p,ax) -> Eqmul(term_of_poly q,ax)) cert_ideal eq and proofs_cone = map term_of_sos cert_cone and proof_ne = if ltp = [] then Rational_lt num_1 else let p = end_itlist (fun s t -> Product(s,t)) (map snd ltp) in funpow i (fun q -> Product(p,q)) (Rational_lt num_1) in let proof = end_itlist (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in print_string("Translating proof certificate to HOL"); print_newline(); translator (eqs,les,lts) proof;; *) (* ------------------------------------------------------------------------- *) (* A wrapper that tries to substitute away variables first. *) (* ------------------------------------------------------------------------- *) (* let REAL_NONLINEAR_SUBST_PROVER = let zero = `&0:real` and mul_tm = `( * ):real->real->real` and shuffle1 = CONV_RULE(REWR_CONV(REAL_ARITH `a + x = (y:real) <=> x = y - a`)) and shuffle2 = CONV_RULE(REWR_CONV(REAL_ARITH `x + a = (y:real) <=> x = y - a`)) in let rec substitutable_monomial fvs tm = match tm with Var(_,Tyapp("real",[])) when not (mem tm fvs) -> Int 1,tm | Comb(Comb(Const("real_mul",_),c),(Var(_,_) as t)) when is_ratconst c & not (mem t fvs) -> rat_of_term c,t | Comb(Comb(Const("real_add",_),s),t) -> (try substitutable_monomial (union (frees t) fvs) s with Failure _ -> substitutable_monomial (union (frees s) fvs) t) | _ -> failwith "substitutable_monomial" and isolate_variable v th = match lhs(concl th) with x when x = v -> th | Comb(Comb(Const("real_add",_),(Var(_,Tyapp("real",[])) as x)),t) when x = v -> shuffle2 th | Comb(Comb(Const("real_add",_),s),t) -> isolate_variable v(shuffle1 th) in let make_substitution th = let (c,v) = substitutable_monomial [] (lhs(concl th)) in let th1 = AP_TERM (mk_comb(mul_tm,term_of_rat(Int 1 // c))) th in let th2 = CONV_RULE(BINOP_CONV REAL_POLY_MUL_CONV) th1 in CONV_RULE (RAND_CONV REAL_POLY_CONV) (isolate_variable v th2) in fun translator -> let rec substfirst(eqs,les,lts) = try let eth = tryfind make_substitution eqs in let modify = CONV_RULE(LAND_CONV(SUBS_CONV[eth] THENC REAL_POLY_CONV)) in substfirst(filter (fun t -> lhand(concl t) <> zero) (map modify eqs), map modify les,map modify lts) with Failure _ -> REAL_NONLINEAR_PROVER translator (eqs,les,lts) in substfirst;; *) (* ------------------------------------------------------------------------- *) (* Overall function. *) (* ------------------------------------------------------------------------- *) (* let REAL_SOS = let init = GEN_REWRITE_CONV ONCE_DEPTH_CONV [DECIMAL] and pure = GEN_REAL_ARITH REAL_NONLINEAR_SUBST_PROVER in fun tm -> let th = init tm in EQ_MP (SYM th) (pure(rand(concl th)));; *) (* ------------------------------------------------------------------------- *) (* Add hacks for division. *) (* ------------------------------------------------------------------------- *) (* let REAL_SOSFIELD = let inv_tm = `inv:real->real` in let prenex_conv = TOP_DEPTH_CONV BETA_CONV THENC PURE_REWRITE_CONV[FORALL_SIMP; EXISTS_SIMP; real_div; REAL_INV_INV; REAL_INV_MUL; GSYM REAL_POW_INV] THENC NNFC_CONV THENC DEPTH_BINOP_CONV `(/\)` CONDS_CELIM_CONV THENC PRENEX_CONV and setup_conv = NNF_CONV THENC WEAK_CNF_CONV THENC CONJ_CANON_CONV and core_rule t = try REAL_ARITH t with Failure _ -> try REAL_RING t with Failure _ -> REAL_SOS t and is_inv = let is_div = is_binop `(/):real->real->real` in fun tm -> (is_div tm or (is_comb tm & rator tm = inv_tm)) & not(is_ratconst(rand tm)) in let BASIC_REAL_FIELD tm = let is_freeinv t = is_inv t & free_in t tm in let itms = setify(map rand (find_terms is_freeinv tm)) in let hyps = map (fun t -> SPEC t REAL_MUL_RINV) itms in let tm' = itlist (fun th t -> mk_imp(concl th,t)) hyps tm in let itms' = map (curry mk_comb inv_tm) itms in let gvs = map (genvar o type_of) itms' in let tm'' = subst (zip gvs itms') tm' in let th1 = setup_conv tm'' in let cjs = conjuncts(rand(concl th1)) in let ths = map core_rule cjs in let th2 = EQ_MP (SYM th1) (end_itlist CONJ ths) in rev_itlist (C MP) hyps (INST (zip itms' gvs) th2) in fun tm -> let th0 = prenex_conv tm in let tm0 = rand(concl th0) in let avs,bod = strip_forall tm0 in let th1 = setup_conv bod in let ths = map BASIC_REAL_FIELD (conjuncts(rand(concl th1))) in EQ_MP (SYM th0) (GENL avs (EQ_MP (SYM th1) (end_itlist CONJ ths)));; *) (* ------------------------------------------------------------------------- *) (* Integer version. *) (* ------------------------------------------------------------------------- *) (* let INT_SOS = let atom_CONV = let pth = prove (`(~(x <= y) <=> y + &1 <= x:int) /\ (~(x < y) <=> y <= x) /\ (~(x = y) <=> x + &1 <= y \/ y + &1 <= x) /\ (x < y <=> x + &1 <= y)`, REWRITE_TAC[INT_NOT_LE; INT_NOT_LT; INT_NOT_EQ; INT_LT_DISCRETE]) in GEN_REWRITE_CONV I [pth] and bub_CONV = GEN_REWRITE_CONV TOP_SWEEP_CONV [int_eq; int_le; int_lt; int_ge; int_gt; int_of_num_th; int_neg_th; int_add_th; int_mul_th; int_sub_th; int_pow_th; int_abs_th; int_max_th; int_min_th] in let base_CONV = TRY_CONV atom_CONV THENC bub_CONV in let NNF_NORM_CONV = GEN_NNF_CONV false (base_CONV,fun t -> base_CONV t,base_CONV(mk_neg t)) in let init_CONV = GEN_REWRITE_CONV DEPTH_CONV [FORALL_SIMP; EXISTS_SIMP] THENC GEN_REWRITE_CONV DEPTH_CONV [INT_GT; INT_GE] THENC CONDS_ELIM_CONV THENC NNF_NORM_CONV in let p_tm = `p:bool` and not_tm = `(~)` in let pth = TAUT(mk_eq(mk_neg(mk_neg p_tm),p_tm)) in fun tm -> let th0 = INST [tm,p_tm] pth and th1 = NNF_NORM_CONV(mk_neg tm) in let th2 = REAL_SOS(mk_neg(rand(concl th1))) in EQ_MP th0 (EQ_MP (AP_TERM not_tm (SYM th1)) th2);; *) (* ------------------------------------------------------------------------- *) (* Natural number version. *) (* ------------------------------------------------------------------------- *) (* let SOS_RULE tm = let avs = frees tm in let tm' = list_mk_forall(avs,tm) in let th1 = NUM_TO_INT_CONV tm' in let th2 = INT_SOS (rand(concl th1)) in SPECL avs (EQ_MP (SYM th1) th2);; *) (* ------------------------------------------------------------------------- *) (* Now pure SOS stuff. *) (* ------------------------------------------------------------------------- *) (*prioritize_real();;*) (* ------------------------------------------------------------------------- *) (* Some combinatorial helper functions. *) (* ------------------------------------------------------------------------- *) let rec allpermutations l = if l = [] then [[]] else itlist (fun h acc -> map (fun t -> h::t) (allpermutations (subtract l [h])) @ acc) l [];; let allvarorders l = map (fun vlis x -> index x vlis) (allpermutations l);; let changevariables_monomial zoln (m:monomial) = foldl (fun a x k -> (assoc x zoln |-> k) a) monomial_1 m;; let changevariables zoln pol = foldl (fun a m c -> (changevariables_monomial zoln m |-> c) a) poly_0 pol;; (* ------------------------------------------------------------------------- *) (* Return to original non-block matrices. *) (* ------------------------------------------------------------------------- *) let sdpa_of_vector (v:vector) = let n = dim v in let strs = map (o (decimalize 20) (element v)) (1--n) in end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";; let sdpa_of_blockdiagonal k m = let pfx = string_of_int k ^" " in let ents = foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in let entss = sort (increasing fst) ents in itlist (fun ((b,i,j),c) a -> pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) entss "";; let sdpa_of_matrix k (m:matrix) = let pfx = string_of_int k ^ " 1 " in let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a) (snd m) [] in let mss = sort (increasing fst) ms in itlist (fun ((i,j),c) a -> pfx ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) mss "";; let sdpa_of_problem comment obj mats = let m = length mats - 1 and n,_ = dimensions (hd mats) in "\"" ^ comment ^ "\"\n" ^ string_of_int m ^ "\n" ^ "1\n" ^ string_of_int n ^ "\n" ^ sdpa_of_vector obj ^ itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) (1--length mats) mats "";; let run_csdp dbg obj mats = let input_file = Filename.temp_file "sos" ".dat-s" in let output_file = String.sub input_file 0 (String.length input_file - 6) ^ ".out" and params_file = Filename.concat (!temp_path) "param.csdp" in file_of_string input_file (sdpa_of_problem "" obj mats); file_of_string params_file csdp_params; let rv = Sys.command("cd "^(!temp_path)^"; csdp "^input_file ^ " " ^ output_file ^ (if dbg then "" else "> /dev/null")) in let op = string_of_file output_file in let res = parse_csdpoutput op in ((if dbg then () else (Sys.remove input_file; Sys.remove output_file)); rv,res);; let csdp obj mats = let rv,res = run_csdp (!debugging) obj mats in (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible" else if rv = 3 then () (* (Format.print_string "csdp warning: Reduced accuracy"; Format.print_newline()) *) else if rv <> 0 then failwith("csdp: error "^string_of_int rv) else ()); res;; (* ------------------------------------------------------------------------- *) (* Sum-of-squares function with some lowbrow symmetry reductions. *) (* ------------------------------------------------------------------------- *) let sumofsquares_general_symmetry tool pol = let vars = poly_variables pol and lpps = newton_polytope pol in let n = length lpps in let sym_eqs = let invariants = filter (fun vars' -> is_undefined(poly_sub pol (changevariables (zip vars vars') pol))) (allpermutations vars) in let lpns = zip lpps (1--length lpps) in let lppcs = filter (fun (m,(n1,n2)) -> n1 <= n2) (allpairs (fun (m1,n1) (m2,n2) -> (m1,m2),(n1,n2)) lpns lpns) in let clppcs = end_itlist (@) (map (fun ((m1,m2),(n1,n2)) -> map (fun vars' -> (changevariables_monomial (zip vars vars') m1, changevariables_monomial (zip vars vars') m2),(n1,n2)) invariants) lppcs) in let clppcs_dom = setify(map fst clppcs) in let clppcs_cls = map (fun d -> filter (fun (e,_) -> e = d) clppcs) clppcs_dom in let eqvcls = map (o setify (map snd)) clppcs_cls in let mk_eq cls acc = match cls with [] -> raise Sanity | [h] -> acc | h::t -> map (fun k -> (k |-> Int(-1)) (h |=> Int 1)) t @ acc in itlist mk_eq eqvcls [] in let eqs = foldl (fun a x y -> y::a) [] (itern 1 lpps (fun m1 n1 -> itern 1 lpps (fun m2 n2 f -> let m = monomial_mul m1 m2 in if n1 > n2 then f else let c = if n1 = n2 then Int 1 else Int 2 in (m |-> ((n1,n2) |-> c) (tryapplyd f m undefined)) f)) (foldl (fun a m c -> (m |-> ((0,0)|=>c)) a) undefined pol)) @ sym_eqs in let pvs,assig = eliminate_all_equations (0,0) eqs in let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in let qvars = (0,0)::pvs in let diagents = end_itlist equation_add (map (fun i -> apply allassig (i,i)) (1--n)) in let mk_matrix v = ((n,n), foldl (fun m (i,j) ass -> let c = tryapplyd ass v (Int 0) in if c =/ Int 0 then m else ((j,i) |-> c) (((i,j) |-> c) m)) undefined allassig :matrix) in let mats = map mk_matrix qvars and obj = length pvs, itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0))) undefined in let raw_vec = if pvs = [] then vector_0 0 else tool obj mats in let find_rounding d = (if !debugging then (Format.print_string("Trying rounding with limit "^string_of_num d); Format.print_newline()) else ()); let vec = nice_vector d raw_vec in let mat = iter (1,dim vec) (fun i a -> matrix_add (matrix_cmul (element vec i) (el i mats)) a) (matrix_neg (el 0 mats)) in deration(diag mat) in let rat,dia = if pvs = [] then let mat = matrix_neg (el 0 mats) in deration(diag mat) else tryfind find_rounding (map Num.num_of_int (1--31) @ map pow2 (5--66)) in let poly_of_lin(d,v) = d,foldl(fun a i c -> (el (i - 1) lpps |-> c) a) undefined (snd v) in let lins = map poly_of_lin dia in let sqs = map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in let sos = poly_cmul rat (end_itlist poly_add sqs) in if is_undefined(poly_sub sos pol) then rat,lins else raise Sanity;; let sumofsquares = sumofsquares_general_symmetry csdp;; (* ------------------------------------------------------------------------- *) (* Pure HOL SOS conversion. *) (* ------------------------------------------------------------------------- *) (* let SOS_CONV = let mk_square = let pow_tm = `(pow)` and two_tm = `2` in fun tm -> mk_comb(mk_comb(pow_tm,tm),two_tm) and mk_prod = mk_binop `( * )` and mk_sum = mk_binop `(+)` in fun tm -> let k,sos = sumofsquares(poly_of_term tm) in let mk_sqtm(c,p) = mk_prod (term_of_rat(k */ c)) (mk_square(term_of_poly p)) in let tm' = end_itlist mk_sum (map mk_sqtm sos) in let th = REAL_POLY_CONV tm and th' = REAL_POLY_CONV tm' in TRANS th (SYM th');; *) (* ------------------------------------------------------------------------- *) (* Attempt to prove &0 <= x by direct SOS decomposition. *) (* ------------------------------------------------------------------------- *) (* let PURE_SOS_TAC = let tac = MATCH_ACCEPT_TAC(REWRITE_RULE[GSYM REAL_POW_2] REAL_LE_SQUARE) ORELSE MATCH_ACCEPT_TAC REAL_LE_SQUARE ORELSE (MATCH_MP_TAC REAL_LE_ADD THEN CONJ_TAC) ORELSE (MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC) ORELSE CONV_TAC(RAND_CONV REAL_RAT_REDUCE_CONV THENC REAL_RAT_LE_CONV) in REPEAT GEN_TAC THEN REWRITE_TAC[real_ge] THEN GEN_REWRITE_TAC I [GSYM REAL_SUB_LE] THEN CONV_TAC(RAND_CONV SOS_CONV) THEN REPEAT tac THEN NO_TAC;; let PURE_SOS tm = prove(tm,PURE_SOS_TAC);; *) (* ------------------------------------------------------------------------- *) (* Examples. *) (* ------------------------------------------------------------------------- *) (***** time REAL_SOS `a1 >= &0 /\ a2 >= &0 /\ (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + &2) /\ (a1 * b1 + a2 * b2 = &0) ==> a1 * a2 - b1 * b2 >= &0`;; time REAL_SOS `&3 * x + &7 * a < &4 /\ &3 < &2 * x ==> a < &0`;; time REAL_SOS `b pow 2 < &4 * a * c ==> ~(a * x pow 2 + b * x + c = &0)`;; time REAL_SOS `(a * x pow 2 + b * x + c = &0) ==> b pow 2 >= &4 * a * c`;; time REAL_SOS `&0 <= x /\ x <= &1 /\ &0 <= y /\ y <= &1 ==> x pow 2 + y pow 2 < &1 \/ (x - &1) pow 2 + y pow 2 < &1 \/ x pow 2 + (y - &1) pow 2 < &1 \/ (x - &1) pow 2 + (y - &1) pow 2 < &1`;; time REAL_SOS `&0 <= b /\ &0 <= c /\ &0 <= x /\ &0 <= y /\ (x pow 2 = c) /\ (y pow 2 = a pow 2 * c + b) ==> a * c <= y * x`;; time REAL_SOS `&0 <= x /\ &0 <= y /\ &0 <= z /\ x + y + z <= &3 ==> x * y + x * z + y * z >= &3 * x * y * z`;; time REAL_SOS `(x pow 2 + y pow 2 + z pow 2 = &1) ==> (x + y + z) pow 2 <= &3`;; time REAL_SOS `(w pow 2 + x pow 2 + y pow 2 + z pow 2 = &1) ==> (w + x + y + z) pow 2 <= &4`;; time REAL_SOS `x >= &1 /\ y >= &1 ==> x * y >= x + y - &1`;; time REAL_SOS `x > &1 /\ y > &1 ==> x * y > x + y - &1`;; time REAL_SOS `abs(x) <= &1 ==> abs(&64 * x pow 7 - &112 * x pow 5 + &56 * x pow 3 - &7 * x) <= &1`;; time REAL_SOS `abs(x - z) <= e /\ abs(y - z) <= e /\ &0 <= u /\ &0 <= v /\ (u + v = &1) ==> abs((u * x + v * y) - z) <= e`;; (* ------------------------------------------------------------------------- *) (* One component of denominator in dodecahedral example. *) (* ------------------------------------------------------------------------- *) time REAL_SOS `&2 <= x /\ x <= &125841 / &50000 /\ &2 <= y /\ y <= &125841 / &50000 /\ &2 <= z /\ z <= &125841 / &50000 ==> &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= &0`;; (* ------------------------------------------------------------------------- *) (* Over a larger but simpler interval. *) (* ------------------------------------------------------------------------- *) time REAL_SOS `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4 ==> &0 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;; (* ------------------------------------------------------------------------- *) (* We can do 12. I think 12 is a sharp bound; see PP's certificate. *) (* ------------------------------------------------------------------------- *) time REAL_SOS `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4 ==> &12 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;; (* ------------------------------------------------------------------------- *) (* Gloptipoly example. *) (* ------------------------------------------------------------------------- *) (*** This works but normalization takes minutes time REAL_SOS `(x - y - &2 * x pow 4 = &0) /\ &0 <= x /\ x <= &2 /\ &0 <= y /\ y <= &3 ==> y pow 2 - &7 * y - &12 * x + &17 >= &0`;; ***) (* ------------------------------------------------------------------------- *) (* Inequality from sci.math (see "Leon-Sotelo, por favor"). *) (* ------------------------------------------------------------------------- *) time REAL_SOS `&0 <= x /\ &0 <= y /\ (x * y = &1) ==> x + y <= x pow 2 + y pow 2`;; time REAL_SOS `&0 <= x /\ &0 <= y /\ (x * y = &1) ==> x * y * (x + y) <= x pow 2 + y pow 2`;; time REAL_SOS `&0 <= x /\ &0 <= y ==> x * y * (x + y) pow 2 <= (x pow 2 + y pow 2) pow 2`;; (* ------------------------------------------------------------------------- *) (* Some examples over integers and natural numbers. *) (* ------------------------------------------------------------------------- *) time SOS_RULE `!m n. 2 * m + n = (n + m) + m`;; time SOS_RULE `!n. ~(n = 0) ==> (0 MOD n = 0)`;; time SOS_RULE `!m n. m < n ==> (m DIV n = 0)`;; time SOS_RULE `!n:num. n <= n * n`;; time SOS_RULE `!m n. n * (m DIV n) <= m`;; time SOS_RULE `!n. ~(n = 0) ==> (0 DIV n = 0)`;; time SOS_RULE `!m n p. ~(p = 0) /\ m <= n ==> m DIV p <= n DIV p`;; time SOS_RULE `!a b n. ~(a = 0) ==> (n <= b DIV a <=> a * n <= b)`;; (* ------------------------------------------------------------------------- *) (* This is particularly gratifying --- cf hideous manual proof in arith.ml *) (* ------------------------------------------------------------------------- *) (*** This doesn't now seem to work as well as it did; what changed? time SOS_RULE `!a b c d. ~(b = 0) /\ b * c < (a + 1) * d ==> c DIV d <= a DIV b`;; ***) (* ------------------------------------------------------------------------- *) (* Key lemma for injectivity of Cantor-type pairing functions. *) (* ------------------------------------------------------------------------- *) time SOS_RULE `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1) ==> (x1 + y1 = x2 + y2)`;; time SOS_RULE `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1) /\ (x1 + y1 = x2 + y2) ==> (x1 = x2) /\ (y1 = y2)`;; time SOS_RULE `!x1 y1 x2 y2. (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 = ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2) ==> (x1 + y1 = x2 + y2)`;; time SOS_RULE `!x1 y1 x2 y2. (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 = ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2) /\ (x1 + y1 = x2 + y2) ==> (x1 = x2) /\ (y1 = y2)`;; (* ------------------------------------------------------------------------- *) (* Reciprocal multiplication (actually just ARITH_RULE does these). *) (* ------------------------------------------------------------------------- *) time SOS_RULE `x <= 127 ==> ((86 * x) DIV 256 = x DIV 3)`;; time SOS_RULE `x < 2 EXP 16 ==> ((104858 * x) DIV (2 EXP 20) = x DIV 10)`;; (* ------------------------------------------------------------------------- *) (* This is more impressive since it's really nonlinear. See REMAINDER_DECODE *) (* ------------------------------------------------------------------------- *) time SOS_RULE `0 < m /\ m < n ==> ((m * ((n * x) DIV m + 1)) DIV n = x)`;; (* ------------------------------------------------------------------------- *) (* Some conversion examples. *) (* ------------------------------------------------------------------------- *) time SOS_CONV `&2 * x pow 4 + &2 * x pow 3 * y - x pow 2 * y pow 2 + &5 * y pow 4`;; time SOS_CONV `x pow 4 - (&2 * y * z + &1) * x pow 2 + (y pow 2 * z pow 2 + &2 * y * z + &2)`;; time SOS_CONV `&4 * x pow 4 + &4 * x pow 3 * y - &7 * x pow 2 * y pow 2 - &2 * x * y pow 3 + &10 * y pow 4`;; time SOS_CONV `&4 * x pow 4 * y pow 6 + x pow 2 - x * y pow 2 + y pow 2`;; time SOS_CONV `&4096 * (x pow 4 + x pow 2 + z pow 6 - &3 * x pow 2 * z pow 2) + &729`;; time SOS_CONV `&120 * x pow 2 - &63 * x pow 4 + &10 * x pow 6 + &30 * x * y - &120 * y pow 2 + &120 * y pow 4 + &31`;; time SOS_CONV `&9 * x pow 2 * y pow 4 + &9 * x pow 2 * z pow 4 + &36 * x pow 2 * y pow 3 + &36 * x pow 2 * y pow 2 - &48 * x * y * z pow 2 + &4 * y pow 4 + &4 * z pow 4 - &16 * y pow 3 + &16 * y pow 2`;; time SOS_CONV `(x pow 2 + y pow 2 + z pow 2) * (x pow 4 * y pow 2 + x pow 2 * y pow 4 + z pow 6 - &3 * x pow 2 * y pow 2 * z pow 2)`;; time SOS_CONV `x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3`;; (*** I think this will work, but normalization is slow time SOS_CONV `&100 * (x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z) + &212`;; ***) time SOS_CONV `&100 * ((&2 * x - &2) pow 2 + (x pow 3 - &8 * x - &2) pow 2) - &588`;; time SOS_CONV `x pow 2 * (&120 - &63 * x pow 2 + &10 * x pow 4) + &30 * x * y + &30 * y pow 2 * (&4 * y pow 2 - &4) + &31`;; (* ------------------------------------------------------------------------- *) (* Example of basic rule. *) (* ------------------------------------------------------------------------- *) time PURE_SOS `!x. x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3 >= &1 / &7`;; time PURE_SOS `&0 <= &98 * x pow 12 + -- &980 * x pow 10 + &3038 * x pow 8 + -- &2968 * x pow 6 + &1022 * x pow 4 + -- &84 * x pow 2 + &2`;; time PURE_SOS `!x. &0 <= &2 * x pow 14 + -- &84 * x pow 12 + &1022 * x pow 10 + -- &2968 * x pow 8 + &3038 * x pow 6 + -- &980 * x pow 4 + &98 * x pow 2`;; (* ------------------------------------------------------------------------- *) (* From Zeng et al, JSC vol 37 (2004), p83-99. *) (* All of them work nicely with pure SOS_CONV, except (maybe) the one noted. *) (* ------------------------------------------------------------------------- *) PURE_SOS `x pow 6 + y pow 6 + z pow 6 - &3 * x pow 2 * y pow 2 * z pow 2 >= &0`;; PURE_SOS `x pow 4 + y pow 4 + z pow 4 + &1 - &4*x*y*z >= &0`;; PURE_SOS `x pow 4 + &2*x pow 2*z + x pow 2 - &2*x*y*z + &2*y pow 2*z pow 2 + &2*y*z pow 2 + &2*z pow 2 - &2*x + &2* y*z + &1 >= &0`;; (**** This is harder. Interestingly, this fails the pure SOS test, it seems. Yet only on rounding(!?) Poor Newton polytope optimization or something? But REAL_SOS does finally converge on the second run at level 12! REAL_SOS `x pow 4*y pow 4 - &2*x pow 5*y pow 3*z pow 2 + x pow 6*y pow 2*z pow 4 + &2*x pow 2*y pow 3*z - &4* x pow 3*y pow 2*z pow 3 + &2*x pow 4*y*z pow 5 + z pow 2*y pow 2 - &2*z pow 4*y*x + z pow 6*x pow 2 >= &0`;; ****) PURE_SOS `x pow 4 + &4*x pow 2*y pow 2 + &2*x*y*z pow 2 + &2*x*y*w pow 2 + y pow 4 + z pow 4 + w pow 4 + &2*z pow 2*w pow 2 + &2*x pow 2*w + &2*y pow 2*w + &2*x*y + &3*w pow 2 + &2*z pow 2 + &1 >= &0`;; PURE_SOS `w pow 6 + &2*z pow 2*w pow 3 + x pow 4 + y pow 4 + z pow 4 + &2*x pow 2*w + &2*x pow 2*z + &3*x pow 2 + w pow 2 + &2*z*w + z pow 2 + &2*z + &2*w + &1 >= &0`;; *****) coq-8.4pl4/plugins/micromega/ZCoeff.v0000644000175000017500000001216512326224777016627 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R -> R. Variable ropp : R -> R. Variables req rle rlt : R -> R -> Prop. Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (rplus x y). Notation "x * y " := (rtimes x y). Notation "x - y " := (rminus x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). Notation "x ~= y" := (~ req x y). Notation "x <= y" := (rle x y). Notation "x < y" := (rlt x y). Lemma req_refl : forall x, req x x. Proof. destruct sor.(SORsetoid). apply Equivalence_Reflexive. Qed. Lemma req_sym : forall x y, req x y -> req y x. Proof. destruct sor.(SORsetoid). apply Equivalence_Symmetric. Qed. Lemma req_trans : forall x y z, req x y -> req y z -> req x z. Proof. destruct sor.(SORsetoid). apply Equivalence_Transitive. Qed. Add Relation R req reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) as sor_setoid. Add Morphism rplus with signature req ==> req ==> req as rplus_morph. Proof. exact sor.(SORplus_wd). Qed. Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. Proof. exact sor.(SORtimes_wd). Qed. Add Morphism ropp with signature req ==> req as ropp_morph. Proof. exact sor.(SORopp_wd). Qed. Add Morphism rle with signature req ==> req ==> iff as rle_morph. Proof. exact sor.(SORle_wd). Qed. Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. Proof. exact sor.(SORlt_wd). Qed. Add Morphism rminus with signature req ==> req ==> req as rminus_morph. Proof. exact (rminus_morph sor). Qed. Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption. Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption. Definition gen_order_phi_Z : Z -> R := gen_phiZ 0 1 rplus rtimes ropp. Notation phi_pos := (gen_phiPOS 1 rplus rtimes). Notation phi_pos1 := (gen_phiPOS1 1 rplus rtimes). Notation "[ x ]" := (gen_order_phi_Z x). Lemma ring_ops_wd : ring_eq_ext rplus rtimes ropp req. Proof. constructor. exact rplus_morph. exact rtimes_morph. exact ropp_morph. Qed. Lemma Zring_morph : ring_morph 0 1 rplus rtimes rminus ropp req 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool gen_order_phi_Z. Proof. exact (gen_phiZ_morph sor.(SORsetoid) ring_ops_wd sor.(SORrt)). Qed. Lemma phi_pos1_pos : forall x : positive, 0 < phi_pos1 x. Proof. induction x as [x IH | x IH |]; simpl; try apply (Rplus_pos_pos sor); try apply (Rtimes_pos_pos sor); try apply (Rplus_pos_pos sor); try apply (Rlt_0_1 sor); assumption. Qed. Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Pos.succ x) == 1 + phi_pos1 x. Proof. exact (ARgen_phiPOS_Psucc sor.(SORsetoid) ring_ops_wd (Rth_ARth sor.(SORsetoid) ring_ops_wd sor.(SORrt))). Qed. Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y. Proof. intros x y H. pattern y; apply Pos.lt_ind with x. rewrite phi_pos1_succ; apply (Rlt_succ_r sor). clear y H; intros y _ H. rewrite phi_pos1_succ. now apply (Rlt_lt_succ sor). assumption. Qed. Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y]. Proof. intros x y H. do 2 rewrite (same_genZ sor.(SORsetoid) ring_ops_wd sor.(SORrt)); destruct x; destruct y; simpl in *; try discriminate. apply phi_pos1_pos. now apply clt_pos_morph. apply <- (Ropp_neg_pos sor); apply phi_pos1_pos. apply (Rlt_trans sor) with 0. apply <- (Ropp_neg_pos sor); apply phi_pos1_pos. apply phi_pos1_pos. apply -> (Ropp_lt_mono sor); apply clt_pos_morph. red. now rewrite Pos.compare_antisym. Qed. Lemma Zcleb_morph : forall x y : Z, Z.leb x y = true -> [x] <= [y]. Proof. unfold Z.leb; intros x y H. case_eq (x ?= y)%Z; intro H1; rewrite H1 in H. le_equal. apply Zring_morph.(morph_eq). unfold Zeq_bool; now rewrite H1. le_less. now apply clt_morph. discriminate. Qed. Lemma Zcneqb_morph : forall x y : Z, Zeq_bool x y = false -> [x] ~= [y]. Proof. intros x y H. unfold Zeq_bool in H. case_eq (Z.compare x y); intro H1; rewrite H1 in *; (discriminate || clear H). apply (Rlt_neq sor). now apply clt_morph. fold (x > y)%Z in H1. rewrite Z.gt_lt_iff in H1. apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph. Qed. End InitialMorphism. coq-8.4pl4/plugins/micromega/micromega_plugin.mllib0000644000175000017500000000017312326224777021622 0ustar stephstephSos_types Mutils Micromega Polynomial Mfourier Certificate Persistent_cache Coq_micromega G_micromega Micromega_plugin_mod coq-8.4pl4/plugins/micromega/sos.mli0000644000175000017500000000221112326224777016562 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool val poly_neg : poly -> poly val poly_mul : poly -> poly -> poly val poly_pow : poly -> int -> poly val poly_const : Num.num -> poly val poly_of_term : term -> poly val term_of_poly : poly -> term val term_of_sos : positivstellensatz * (Num.num * poly) list -> positivstellensatz val string_of_poly : poly -> string val real_positivnullstellensatz_general : bool -> int -> poly list -> (poly * positivstellensatz) list -> poly -> poly list * (positivstellensatz * (Num.num * poly) list) list val sumofsquares : poly -> Num.num * ( Num.num * poly) list coq-8.4pl4/plugins/micromega/micromega.mli0000644000175000017500000006014112326224777017727 0ustar stephstephtype __ = Obj.t val negb : bool -> bool type nat = | O | S of nat val fst : ('a1 * 'a2) -> 'a1 val snd : ('a1 * 'a2) -> 'a2 val app : 'a1 list -> 'a1 list -> 'a1 list type comparison = | Eq | Lt | Gt val compOpp : comparison -> comparison type compareSpecT = | CompEqT | CompLtT | CompGtT val compareSpec2Type : comparison -> compareSpecT type 'a compSpecT = compareSpecT val compSpec2Type : 'a1 -> 'a1 -> comparison -> 'a1 compSpecT type 'a sig0 = 'a (* singleton inductive, whose constructor was exist *) val plus : nat -> nat -> nat val nat_iter : nat -> ('a1 -> 'a1) -> 'a1 -> 'a1 type positive = | XI of positive | XO of positive | XH type n = | N0 | Npos of positive type z = | Z0 | Zpos of positive | Zneg of positive module type TotalOrder' = sig type t end module MakeOrderTac : functor (O:TotalOrder') -> sig end module MaxLogicalProperties : functor (O:TotalOrder') -> functor (M:sig val max : O.t -> O.t -> O.t end) -> sig module T : sig end end module Pos : sig type t = positive val succ : positive -> positive val add : positive -> positive -> positive val add_carry : positive -> positive -> positive val pred_double : positive -> positive val pred : positive -> positive val pred_N : positive -> n type mask = | IsNul | IsPos of positive | IsNeg val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 val succ_double_mask : mask -> mask val double_mask : mask -> mask val double_pred_mask : positive -> mask val pred_mask : mask -> mask val sub_mask : positive -> positive -> mask val sub_mask_carry : positive -> positive -> mask val sub : positive -> positive -> positive val mul : positive -> positive -> positive val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 val pow : positive -> positive -> positive val div2 : positive -> positive val div2_up : positive -> positive val size_nat : positive -> nat val size : positive -> positive val compare_cont : positive -> positive -> comparison -> comparison val compare : positive -> positive -> comparison val min : positive -> positive -> positive val max : positive -> positive -> positive val eqb : positive -> positive -> bool val leb : positive -> positive -> bool val ltb : positive -> positive -> bool val sqrtrem_step : (positive -> positive) -> (positive -> positive) -> (positive * mask) -> positive * mask val sqrtrem : positive -> positive * mask val sqrt : positive -> positive val gcdn : nat -> positive -> positive -> positive val gcd : positive -> positive -> positive val ggcdn : nat -> positive -> positive -> positive * (positive * positive) val ggcd : positive -> positive -> positive * (positive * positive) val coq_Nsucc_double : n -> n val coq_Ndouble : n -> n val coq_lor : positive -> positive -> positive val coq_land : positive -> positive -> n val ldiff : positive -> positive -> n val coq_lxor : positive -> positive -> n val shiftl_nat : positive -> nat -> positive val shiftr_nat : positive -> nat -> positive val shiftl : positive -> n -> positive val shiftr : positive -> n -> positive val testbit_nat : positive -> nat -> bool val testbit : positive -> n -> bool val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 val to_nat : positive -> nat val of_nat : nat -> positive val of_succ_nat : nat -> positive end module Coq_Pos : sig module Coq__1 : sig type t = positive end type t = Coq__1.t val succ : positive -> positive val add : positive -> positive -> positive val add_carry : positive -> positive -> positive val pred_double : positive -> positive val pred : positive -> positive val pred_N : positive -> n type mask = Pos.mask = | IsNul | IsPos of positive | IsNeg val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 val succ_double_mask : mask -> mask val double_mask : mask -> mask val double_pred_mask : positive -> mask val pred_mask : mask -> mask val sub_mask : positive -> positive -> mask val sub_mask_carry : positive -> positive -> mask val sub : positive -> positive -> positive val mul : positive -> positive -> positive val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 val pow : positive -> positive -> positive val div2 : positive -> positive val div2_up : positive -> positive val size_nat : positive -> nat val size : positive -> positive val compare_cont : positive -> positive -> comparison -> comparison val compare : positive -> positive -> comparison val min : positive -> positive -> positive val max : positive -> positive -> positive val eqb : positive -> positive -> bool val leb : positive -> positive -> bool val ltb : positive -> positive -> bool val sqrtrem_step : (positive -> positive) -> (positive -> positive) -> (positive * mask) -> positive * mask val sqrtrem : positive -> positive * mask val sqrt : positive -> positive val gcdn : nat -> positive -> positive -> positive val gcd : positive -> positive -> positive val ggcdn : nat -> positive -> positive -> positive * (positive * positive) val ggcd : positive -> positive -> positive * (positive * positive) val coq_Nsucc_double : n -> n val coq_Ndouble : n -> n val coq_lor : positive -> positive -> positive val coq_land : positive -> positive -> n val ldiff : positive -> positive -> n val coq_lxor : positive -> positive -> n val shiftl_nat : positive -> nat -> positive val shiftr_nat : positive -> nat -> positive val shiftl : positive -> n -> positive val shiftr : positive -> n -> positive val testbit_nat : positive -> nat -> bool val testbit : positive -> n -> bool val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 val to_nat : positive -> nat val of_nat : nat -> positive val of_succ_nat : nat -> positive val eq_dec : positive -> positive -> bool val peano_rect : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 val peano_rec : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 type coq_PeanoView = | PeanoOne | PeanoSucc of positive * coq_PeanoView val coq_PeanoView_rect : 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 val coq_PeanoView_rec : 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 val peanoView_xO : positive -> coq_PeanoView -> coq_PeanoView val peanoView_xI : positive -> coq_PeanoView -> coq_PeanoView val peanoView : positive -> coq_PeanoView val coq_PeanoView_iter : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 val switch_Eq : comparison -> comparison -> comparison val mask2cmp : mask -> comparison module T : sig end module ORev : sig type t = Coq__1.t end module MRev : sig val max : t -> t -> t end module MPRev : sig module T : sig end end module P : sig val max_case_strong : t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 val max_case : t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 val max_dec : t -> t -> bool val min_case_strong : t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 val min_case : t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 val min_dec : t -> t -> bool end val max_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 val max_case : t -> t -> 'a1 -> 'a1 -> 'a1 val max_dec : t -> t -> bool val min_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 val min_case : t -> t -> 'a1 -> 'a1 -> 'a1 val min_dec : t -> t -> bool end module N : sig type t = n val zero : n val one : n val two : n val succ_double : n -> n val double : n -> n val succ : n -> n val pred : n -> n val succ_pos : n -> positive val add : n -> n -> n val sub : n -> n -> n val mul : n -> n -> n val compare : n -> n -> comparison val eqb : n -> n -> bool val leb : n -> n -> bool val ltb : n -> n -> bool val min : n -> n -> n val max : n -> n -> n val div2 : n -> n val even : n -> bool val odd : n -> bool val pow : n -> n -> n val log2 : n -> n val size : n -> n val size_nat : n -> nat val pos_div_eucl : positive -> n -> n * n val div_eucl : n -> n -> n * n val div : n -> n -> n val modulo : n -> n -> n val gcd : n -> n -> n val ggcd : n -> n -> n * (n * n) val sqrtrem : n -> n * n val sqrt : n -> n val coq_lor : n -> n -> n val coq_land : n -> n -> n val ldiff : n -> n -> n val coq_lxor : n -> n -> n val shiftl_nat : n -> nat -> n val shiftr_nat : n -> nat -> n val shiftl : n -> n -> n val shiftr : n -> n -> n val testbit_nat : n -> nat -> bool val testbit : n -> n -> bool val to_nat : n -> nat val of_nat : nat -> n val iter : n -> ('a1 -> 'a1) -> 'a1 -> 'a1 val eq_dec : n -> n -> bool val discr : n -> positive option val binary_rect : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 val binary_rec : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 val peano_rect : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 val peano_rec : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 module BootStrap : sig end val recursion : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 module OrderElts : sig type t = n end module OrderTac : sig end module NZPowP : sig end module NZSqrtP : sig end val sqrt_up : n -> n val log2_up : n -> n module NZDivP : sig end val lcm : n -> n -> n val b2n : bool -> n val setbit : n -> n -> n val clearbit : n -> n -> n val ones : n -> n val lnot : n -> n -> n module T : sig end module ORev : sig type t = n end module MRev : sig val max : n -> n -> n end module MPRev : sig module T : sig end end module P : sig val max_case_strong : n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 val max_case : n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 val max_dec : n -> n -> bool val min_case_strong : n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 val min_case : n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 val min_dec : n -> n -> bool end val max_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 val max_case : n -> n -> 'a1 -> 'a1 -> 'a1 val max_dec : n -> n -> bool val min_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 val min_case : n -> n -> 'a1 -> 'a1 -> 'a1 val min_dec : n -> n -> bool end val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 val nth : nat -> 'a1 list -> 'a1 -> 'a1 val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 module Z : sig type t = z val zero : z val one : z val two : z val double : z -> z val succ_double : z -> z val pred_double : z -> z val pos_sub : positive -> positive -> z val add : z -> z -> z val opp : z -> z val succ : z -> z val pred : z -> z val sub : z -> z -> z val mul : z -> z -> z val pow_pos : z -> positive -> z val pow : z -> z -> z val compare : z -> z -> comparison val sgn : z -> z val leb : z -> z -> bool val geb : z -> z -> bool val ltb : z -> z -> bool val gtb : z -> z -> bool val eqb : z -> z -> bool val max : z -> z -> z val min : z -> z -> z val abs : z -> z val abs_nat : z -> nat val abs_N : z -> n val to_nat : z -> nat val to_N : z -> n val of_nat : nat -> z val of_N : n -> z val iter : z -> ('a1 -> 'a1) -> 'a1 -> 'a1 val pos_div_eucl : positive -> z -> z * z val div_eucl : z -> z -> z * z val div : z -> z -> z val modulo : z -> z -> z val quotrem : z -> z -> z * z val quot : z -> z -> z val rem : z -> z -> z val even : z -> bool val odd : z -> bool val div2 : z -> z val quot2 : z -> z val log2 : z -> z val sqrtrem : z -> z * z val sqrt : z -> z val gcd : z -> z -> z val ggcd : z -> z -> z * (z * z) val testbit : z -> z -> bool val shiftl : z -> z -> z val shiftr : z -> z -> z val coq_lor : z -> z -> z val coq_land : z -> z -> z val ldiff : z -> z -> z val coq_lxor : z -> z -> z val eq_dec : z -> z -> bool module BootStrap : sig end module OrderElts : sig type t = z end module OrderTac : sig end val sqrt_up : z -> z val log2_up : z -> z module NZDivP : sig end module Quot2Div : sig val div : z -> z -> z val modulo : z -> z -> z end module NZQuot : sig end val lcm : z -> z -> z val b2z : bool -> z val setbit : z -> z -> z val clearbit : z -> z -> z val lnot : z -> z val ones : z -> z module T : sig end module ORev : sig type t = z end module MRev : sig val max : z -> z -> z end module MPRev : sig module T : sig end end module P : sig val max_case_strong : z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 val max_case : z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 val max_dec : z -> z -> bool val min_case_strong : z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 val min_case : z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 val min_dec : z -> z -> bool end val max_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 val max_case : z -> z -> 'a1 -> 'a1 -> 'a1 val max_dec : z -> z -> bool val min_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 val min_case : z -> z -> 'a1 -> 'a1 -> 'a1 val min_dec : z -> z -> bool end val zeq_bool : z -> z -> bool type 'c pol = | Pc of 'c | Pinj of positive * 'c pol | PX of 'c pol * positive * 'c pol val p0 : 'a1 -> 'a1 pol val p1 : 'a1 -> 'a1 pol val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool val mkPinj : positive -> 'a1 pol -> 'a1 pol val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol val mkPX : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol val mkX : 'a1 -> 'a1 -> 'a1 pol val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val paddI : ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val psubI : ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val paddX : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val psubX : 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val padd : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val psub : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol val pmulC : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol val pmulI : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val pmul : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val psquare : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol type 'c pExpr = | PEc of 'c | PEX of positive | PEadd of 'c pExpr * 'c pExpr | PEsub of 'c pExpr * 'c pExpr | PEmul of 'c pExpr * 'c pExpr | PEopp of 'c pExpr | PEpow of 'c pExpr * n val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol val ppow_pos : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol val ppow_N : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol val norm_aux : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol type 'a bFormula = | TT | FF | X | A of 'a | Cj of 'a bFormula * 'a bFormula | D of 'a bFormula * 'a bFormula | N of 'a bFormula | I of 'a bFormula * 'a bFormula val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula type 'term' clause = 'term' list type 'term' cnf = 'term' clause list val tt : 'a1 cnf val ff : 'a1 cnf val add_term : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 clause option val or_clause : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause -> 'a1 clause option val or_clause_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1 cnf val or_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 cnf val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf val xcnf : ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool val tauto_checker : ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> bool val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool val cltb : ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool type 'c polC = 'c pol type op1 = | Equal | NonEqual | Strict | NonStrict type 'c nFormula = 'c polC * op1 val opMult : op1 -> op1 -> op1 option val opAdd : op1 -> op1 -> op1 option type 'c psatz = | PsatzIn of nat | PsatzSquare of 'c polC | PsatzMulC of 'c polC * 'c psatz | PsatzMulE of 'c psatz * 'c psatz | PsatzAdd of 'c psatz * 'c psatz | PsatzC of 'c | PsatzZ val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option val map_option2 : ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option val pexpr_times_nformula : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option val nformula_times_nformula : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option val nformula_plus_nformula : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option val eval_Psatz : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option val check_inconsistent : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool val check_normalised_formulas : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool type op2 = | OpEq | OpNEq | OpLe | OpGe | OpLt | OpGt type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } val flhs : 'a1 formula -> 'a1 pExpr val fop : 'a1 formula -> op2 val frhs : 'a1 formula -> 'a1 pExpr val norm : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol val psub0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val padd0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val xnormalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list val cnf_normalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula cnf val xnegate : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list val cnf_negate : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula cnf val xdenorm : positive -> 'a1 pol -> 'a1 pExpr val denorm : 'a1 pol -> 'a1 pExpr val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula val simpl_cone : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> 'a1 psatz type q = { qnum : z; qden : positive } val qnum : q -> z val qden : q -> positive val qeq_bool : q -> q -> bool val qle_bool : q -> q -> bool val qplus : q -> q -> q val qmult : q -> q -> q val qopp : q -> q val qminus : q -> q -> q val qinv : q -> q val qpower_positive : q -> positive -> q val qpower : q -> z -> q type 'a t0 = | Empty | Leaf of 'a | Node of 'a t0 * 'a * 'a t0 val find : 'a1 -> 'a1 t0 -> positive -> 'a1 type zWitness = z psatz val zWeakChecker : z nFormula list -> z psatz -> bool val psub1 : z pol -> z pol -> z pol val padd1 : z pol -> z pol -> z pol val norm0 : z pExpr -> z pol val xnormalise0 : z formula -> z nFormula list val normalise : z formula -> z nFormula cnf val xnegate0 : z formula -> z nFormula list val negate : z formula -> z nFormula cnf val zunsat : z nFormula -> bool val zdeduce : z nFormula -> z nFormula -> z nFormula option val ceiling : z -> z -> z type zArithProof = | DoneProof | RatProof of zWitness * zArithProof | CutProof of zWitness * zArithProof | EnumProof of zWitness * zWitness * zArithProof list val zgcdM : z -> z -> z val zgcd_pol : z polC -> z * z val zdiv_pol : z polC -> z -> z polC val makeCuttingPlane : z polC -> z polC * z val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula val is_pol_Z0 : z polC -> bool val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option val valid_cut_sign : op1 -> bool val zChecker : z nFormula list -> zArithProof -> bool val zTautoChecker : z formula bFormula -> zArithProof list -> bool type qWitness = q psatz val qWeakChecker : q nFormula list -> q psatz -> bool val qnormalise : q formula -> q nFormula cnf val qnegate : q formula -> q nFormula cnf val qunsat : q nFormula -> bool val qdeduce : q nFormula -> q nFormula -> q nFormula option val qTautoChecker : q formula bFormula -> qWitness list -> bool type rcst = | C0 | C1 | CQ of q | CZ of z | CPlus of rcst * rcst | CMinus of rcst * rcst | CMult of rcst * rcst | CInv of rcst | COpp of rcst val q_of_Rcst : rcst -> q type rWitness = q psatz val rWeakChecker : q nFormula list -> q psatz -> bool val rnormalise : q formula -> q nFormula cnf val rnegate : q formula -> q nFormula cnf val runsat : q nFormula -> bool val rdeduce : q nFormula -> q nFormula -> q nFormula option val rTautoChecker : rcst formula bFormula -> rWitness list -> bool coq-8.4pl4/plugins/micromega/Tauto.v0000644000175000017500000003353012326224777016546 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* BFormula A | A : A -> BFormula A | Cj : BFormula A -> BFormula A -> BFormula A | D : BFormula A-> BFormula A -> BFormula A | N : BFormula A -> BFormula A | I : BFormula A-> BFormula A-> BFormula A. Fixpoint eval_f (A:Type) (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop := match f with | TT => True | FF => False | A a => ev a | X p => p | Cj e1 e2 => (eval_f ev e1) /\ (eval_f ev e2) | D e1 e2 => (eval_f ev e1) \/ (eval_f ev e2) | N e => ~ (eval_f ev e) | I f1 f2 => (eval_f ev f1) -> (eval_f ev f2) end. Lemma eval_f_morph : forall A (ev ev' : A -> Prop) (f : BFormula A), (forall a, ev a <-> ev' a) -> (eval_f ev f <-> eval_f ev' f). Proof. induction f ; simpl ; try tauto. intros. assert (H' := H a). auto. Qed. Fixpoint map_bformula (T U : Type) (fct : T -> U) (f : BFormula T) : BFormula U := match f with | TT => TT _ | FF => FF _ | X p => X _ p | A a => A (fct a) | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2) | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2) | N f => N (map_bformula fct f) | I f1 f2 => I (map_bformula fct f1) (map_bformula fct f2) end. Lemma eval_f_map : forall T U (fct: T-> U) env f , eval_f env (map_bformula fct f) = eval_f (fun x => env (fct x)) f. Proof. induction f ; simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto. rewrite <- IHf. auto. Qed. Lemma map_simpl : forall A B f l, @map A B f l = match l with | nil => nil | a :: l=> (f a) :: (@map A B f l) end. Proof. destruct l ; reflexivity. Qed. Section S. Variable Env : Type. Variable Term : Type. Variable eval : Env -> Term -> Prop. Variable Term' : Type. Variable eval' : Env -> Term' -> Prop. Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d). Variable unsat : Term' -> bool. Variable unsat_prop : forall t, unsat t = true -> forall env, eval' env t -> False. Variable deduce : Term' -> Term' -> option Term'. Variable deduce_prop : forall env t t' u, eval' env t -> eval' env t' -> deduce t t' = Some u -> eval' env u. Definition clause := list Term'. Definition cnf := list clause. Variable normalise : Term -> cnf. Variable negate : Term -> cnf. Definition tt : cnf := @nil clause. Definition ff : cnf := cons (@nil Term') nil. Fixpoint add_term (t: Term') (cl : clause) : option clause := match cl with | nil => match deduce t t with | None => Some (t ::nil) | Some u => if unsat u then None else Some (t::nil) end | t'::cl => match deduce t t' with | None => match add_term t cl with | None => None | Some cl' => Some (t' :: cl') end | Some u => if unsat u then None else match add_term t cl with | None => None | Some cl' => Some (t' :: cl') end end end. Fixpoint or_clause (cl1 cl2 : clause) : option clause := match cl1 with | nil => Some cl2 | t::cl => match add_term t cl2 with | None => None | Some cl' => or_clause cl cl' end end. (* Definition or_clause_cnf (t:clause) (f:cnf) : cnf := List.map (fun x => (t++x)) f. *) Definition or_clause_cnf (t:clause) (f:cnf) : cnf := List.fold_right (fun e acc => match or_clause t e with | None => acc | Some cl => cl :: acc end) nil f. Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf := match f with | nil => tt | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f') end. Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf := f1 ++ f2. Fixpoint xcnf (pol : bool) (f : BFormula Term) {struct f}: cnf := match f with | TT => if pol then tt else ff | FF => if pol then ff else tt | X p => if pol then ff else ff (* This is not complete - cannot negate any proposition *) | A x => if pol then normalise x else negate x | N e => xcnf (negb pol) e | Cj e1 e2 => (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) | D e1 e2 => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) | I e1 e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2) end. Definition eval_clause (env : Env) (cl : clause) := ~ make_conj (eval' env) cl. Definition eval_cnf (env : Env) (f:cnf) := make_conj (eval_clause env) f. Lemma eval_cnf_app : forall env x y, eval_cnf env (x++y) -> eval_cnf env x /\ eval_cnf env y. Proof. unfold eval_cnf. intros. rewrite make_conj_app in H ; auto. Qed. Definition eval_opt_clause (env : Env) (cl: option clause) := match cl with | None => True | Some cl => eval_clause env cl end. Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) -> eval_clause env (t::cl). Proof. induction cl. (* BC *) simpl. case_eq (deduce t t) ; auto. intros until 0. case_eq (unsat t0) ; auto. unfold eval_clause. rewrite make_conj_cons. intros. intro. apply unsat_prop with (1:= H) (env := env). apply deduce_prop with (3:= H0) ; tauto. (* IC *) simpl. case_eq (deduce t a). intro u. case_eq (unsat u). simpl. intros. unfold eval_clause. intro. apply unsat_prop with (1:= H) (env:= env). repeat rewrite make_conj_cons in H2. apply deduce_prop with (3:= H0); tauto. intro. case_eq (add_term t cl) ; intros. simpl in H2. rewrite H0 in IHcl. simpl in IHcl. unfold eval_clause in *. intros. repeat rewrite make_conj_cons in *. tauto. rewrite H0 in IHcl ; simpl in *. unfold eval_clause in *. intros. repeat rewrite make_conj_cons in *. tauto. case_eq (add_term t cl) ; intros. simpl in H1. unfold eval_clause in *. repeat rewrite make_conj_cons in *. rewrite H in IHcl. simpl in IHcl. tauto. simpl in *. rewrite H in IHcl. simpl in IHcl. unfold eval_clause in *. repeat rewrite make_conj_cons in *. tauto. Qed. Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') -> eval_clause env cl \/ eval_clause env cl'. Proof. induction cl. simpl. tauto. intros until 0. simpl. assert (HH := add_term_correct env a cl'). case_eq (add_term a cl'). simpl in *. intros. apply IHcl in H0. rewrite H in HH. simpl in HH. unfold eval_clause in *. destruct H0. repeat rewrite make_conj_cons in *. tauto. apply HH in H0. apply not_make_conj_cons in H0 ; auto. repeat rewrite make_conj_cons in *. tauto. simpl. intros. rewrite H in HH. simpl in HH. unfold eval_clause in *. assert (HH' := HH Coq.Init.Logic.I). apply not_make_conj_cons in HH'; auto. repeat rewrite make_conj_cons in *. tauto. Qed. Lemma or_clause_cnf_correct : forall env t f, eval_cnf env (or_clause_cnf t f) -> (eval_clause env t) \/ (eval_cnf env f). Proof. unfold eval_cnf. unfold or_clause_cnf. intros until t. set (F := (fun (e : clause) (acc : list clause) => match or_clause t e with | Some cl => cl :: acc | None => acc end)). induction f. auto. (**) simpl. intros. destruct f. simpl in H. simpl in IHf. unfold F in H. revert H. intros. apply or_clause_correct. destruct (or_clause t a) ; simpl in * ; auto. unfold F in H at 1. revert H. assert (HH := or_clause_correct t a env). destruct (or_clause t a); simpl in HH ; rewrite make_conj_cons in * ; intuition. rewrite make_conj_cons in *. tauto. Qed. Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval' env) a) -> eval_cnf env f -> eval_cnf env (a::f). Proof. intros. unfold eval_cnf in *. rewrite make_conj_cons ; eauto. Qed. Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') -> (eval_cnf env f) \/ (eval_cnf env f'). Proof. induction f. unfold eval_cnf. simpl. tauto. (**) intros. simpl in H. destruct (eval_cnf_app _ _ _ H). clear H. destruct (IHf _ H0). destruct (or_clause_cnf_correct _ _ _ H1). left. apply eval_cnf_cons ; auto. right ; auto. right ; auto. Qed. Variable normalise_correct : forall env t, eval_cnf env (normalise t) -> eval env t. Variable negate_correct : forall env t, eval_cnf env (negate t) -> ~ eval env t. Lemma xcnf_correct : forall f pol env, eval_cnf env (xcnf pol f) -> eval_f (eval env) (if pol then f else N f). Proof. induction f. (* TT *) unfold eval_cnf. simpl. destruct pol ; simpl ; auto. (* FF *) unfold eval_cnf. destruct pol; simpl ; auto. unfold eval_clause ; simpl. tauto. (* P *) simpl. destruct pol ; intros ;simpl. unfold eval_cnf in H. (* Here I have to drop the proposition *) simpl in H. unfold eval_clause in H ; simpl in H. tauto. (* Here, I could store P in the clause *) unfold eval_cnf in H;simpl in H. unfold eval_clause in H ; simpl in H. tauto. (* A *) simpl. destruct pol ; simpl. intros. apply normalise_correct ; auto. (* A 2 *) intros. apply negate_correct ; auto. auto. (* Cj *) destruct pol ; simpl. (* pol = true *) intros. unfold and_cnf in H. destruct (eval_cnf_app _ _ _ H). clear H. split. apply (IHf1 _ _ H0). apply (IHf2 _ _ H1). (* pol = false *) intros. destruct (or_cnf_correct _ _ _ H). generalize (IHf1 false env H0). simpl. tauto. generalize (IHf2 false env H0). simpl. tauto. (* D *) simpl. destruct pol. (* pol = true *) intros. destruct (or_cnf_correct _ _ _ H). generalize (IHf1 _ env H0). simpl. tauto. generalize (IHf2 _ env H0). simpl. tauto. (* pol = true *) unfold and_cnf. intros. destruct (eval_cnf_app _ _ _ H). clear H. simpl. generalize (IHf1 _ _ H0). generalize (IHf2 _ _ H1). simpl. tauto. (**) simpl. destruct pol ; simpl. intros. apply (IHf false) ; auto. intros. generalize (IHf _ _ H). tauto. (* I *) simpl; intros. destruct pol. simpl. intro. destruct (or_cnf_correct _ _ _ H). generalize (IHf1 _ _ H1). simpl in *. tauto. generalize (IHf2 _ _ H1). auto. (* pol = false *) unfold and_cnf in H. simpl in H. destruct (eval_cnf_app _ _ _ H). generalize (IHf1 _ _ H0). generalize (IHf2 _ _ H1). simpl. tauto. Qed. Variable Witness : Type. Variable checker : list Term' -> Witness -> bool. Variable checker_sound : forall t w, checker t w = true -> forall env, make_impl (eval' env) t False. Fixpoint cnf_checker (f : cnf) (l : list Witness) {struct f}: bool := match f with | nil => true | e::f => match l with | nil => false | c::l => match checker e c with | true => cnf_checker f l | _ => false end end end. Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf env t. Proof. unfold eval_cnf. induction t. (* bc *) simpl. auto. (* ic *) simpl. destruct w. intros ; discriminate. case_eq (checker a w) ; intros ; try discriminate. generalize (@checker_sound _ _ H env). generalize (IHt _ H0 env) ; intros. destruct t. red ; intro. rewrite <- make_conj_impl in H2. tauto. rewrite <- make_conj_impl in H2. tauto. Qed. Definition tauto_checker (f:BFormula Term) (w:list Witness) : bool := cnf_checker (xcnf true f) w. Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f (eval env) t. Proof. unfold tauto_checker. intros. change (eval_f (eval env) t) with (eval_f (eval env) (if true then t else TT Term)). apply (xcnf_correct t true). eapply cnf_checker_sound ; eauto. Qed. End S. (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.4pl4/plugins/micromega/coq_micromega.ml0000644000175000017500000017733112326224777020432 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ,=,<>,<=,>=} pExpr2 * where pExpr1, pExpr2 are polynomial expressions (see Micromega). pExprs are * parametrized by 'cst, which is used as the type of constants. *) type 'cst atom = 'cst Micromega.formula (** * Micromega's encoding of formulas. * By order of appearance: boolean constants, variables, atoms, conjunctions, * disjunctions, negation, implication. *) type 'cst formula = | TT | FF | X of Term.constr | A of 'cst atom * tag * Term.constr | C of 'cst formula * 'cst formula | D of 'cst formula * 'cst formula | N of 'cst formula | I of 'cst formula * Names.identifier option * 'cst formula (** * Formula pretty-printer. *) let rec pp_formula o f = match f with | TT -> output_string o "tt" | FF -> output_string o "ff" | X c -> output_string o "X " | A(_,t,_) -> Printf.fprintf o "A(%a)" Tag.pp t | C(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2 | D(f1,f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2 | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)" pp_formula f1 (match n with | Some id -> Names.string_of_id id | None -> "") pp_formula f2 | N(f) -> Printf.fprintf o "N(%a)" pp_formula f let rec map_atoms fct f = match f with | TT -> TT | FF -> FF | X x -> X x | A (at,tg,cstr) -> A(fct at,tg,cstr) | C (f1,f2) -> C(map_atoms fct f1, map_atoms fct f2) | D (f1,f2) -> D(map_atoms fct f1, map_atoms fct f2) | N f -> N(map_atoms fct f) | I(f1,o,f2) -> I(map_atoms fct f1, o , map_atoms fct f2) (** * Collect the identifiers of a (string of) implications. Implication labels * are inherited from Coq/CoC's higher order dependent type constructor (Pi). *) let rec ids_of_formula f = match f with | I(f1,Some id,f2) -> id::(ids_of_formula f2) | _ -> [] (** * A clause is a list of (tagged) nFormulas. * nFormulas are normalized formulas, i.e., of the form: * cPol {=,<>,>,>=} 0 * with cPol compact polynomials (see the Pol inductive type in EnvRing.v). *) type 'cst clause = ('cst Micromega.nFormula * tag) list (** * A CNF is a list of clauses. *) type 'cst cnf = ('cst clause) list (** * True and False are empty cnfs and clauses. *) let tt : 'cst cnf = [] let ff : 'cst cnf = [ [] ] (** * A refinement of cnf with tags left out. This is an intermediary form * between the cnf tagged list representation ('cst cnf) used to solve psatz, * and the freeform formulas ('cst formula) that is retrieved from Coq. *) module Mc = Micromega type 'cst mc_cnf = ('cst Mc.nFormula) list list (** * From a freeform formula, build a cnf. * The parametric functions negate and normalize are theory-dependent, and * originate in micromega.ml (extracted, e.g. for rnegate, from RMicromega.v * and RingMicromega.v). *) type 'a tagged_option = T of tag list | S of 'a let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) (unsat : 'cst Mc.nFormula -> bool) (deduce : 'cst Mc.nFormula -> 'cst Mc.nFormula -> 'cst Mc.nFormula option) (f:'cst formula) = let negate a t = List.map (fun cl -> List.map (fun x -> (x,t)) cl) (negate a) in let normalise a t = List.map (fun cl -> List.map (fun x -> (x,t)) cl) (normalise a) in let and_cnf x y = x @ y in let rec add_term t0 = function | [] -> (match deduce (fst t0) (fst t0) with | Some u -> if unsat u then T [snd t0] else S (t0::[]) | None -> S (t0::[])) | t'::cl0 -> (match deduce (fst t0) (fst t') with | Some u -> if unsat u then T [snd t0 ; snd t'] else (match add_term t0 cl0 with | S cl' -> S (t'::cl') | T l -> T l) | None -> (match add_term t0 cl0 with | S cl' -> S (t'::cl') | T l -> T l)) in let rec or_clause cl1 cl2 = match cl1 with | [] -> S cl2 | t0::cl -> (match add_term t0 cl2 with | S cl' -> or_clause cl cl' | T l -> T l) in let or_clause_cnf t f = List.fold_right (fun e (acc,tg) -> match or_clause t e with | S cl -> (cl :: acc,tg) | T l -> (acc,tg@l)) f ([],[]) in let rec or_cnf f f' = match f with | [] -> tt,[] | e :: rst -> let (rst_f',t) = or_cnf rst f' in let (e_f', t') = or_clause_cnf e f' in (rst_f' @ e_f', t @ t') in let rec xcnf (polarity : bool) f = match f with | TT -> if polarity then (tt,[]) else (ff,[]) | FF -> if polarity then (ff,[]) else (tt,[]) | X p -> if polarity then (ff,[]) else (ff,[]) | A(x,t,_) -> ((if polarity then normalise x t else negate x t),[]) | N(e) -> xcnf (not polarity) e | C(e1,e2) -> let e1,t1 = xcnf polarity e1 in let e2,t2 = xcnf polarity e2 in if polarity then and_cnf e1 e2, t1 @ t2 else let f',t' = or_cnf e1 e2 in (f', t1 @ t2 @ t') | D(e1,e2) -> let e1,t1 = xcnf polarity e1 in let e2,t2 = xcnf polarity e2 in if polarity then let f',t' = or_cnf e1 e2 in (f', t1 @ t2 @ t') else and_cnf e1 e2, t1 @ t2 | I(e1,_,e2) -> let e1 , t1 = (xcnf (not polarity) e1) in let e2 , t2 = (xcnf polarity e2) in if polarity then let f',t' = or_cnf e1 e2 in (f', t1 @ t2 @ t') else and_cnf e1 e2, t1 @ t2 in xcnf true f (** * MODULE: Ordered set of integers. *) module ISet = Set.Make(struct type t = int let compare : int -> int -> int = Pervasives.compare end) (** * Given a set of integers s={i0,...,iN} and a list m, return the list of * elements of m that are at position i0,...,iN. *) let selecti s m = let rec xselecti i m = match m with | [] -> [] | e::m -> if ISet.mem i s then e::(xselecti (i+1) m) else xselecti (i+1) m in xselecti 0 m (** * MODULE: Mapping of the Coq data-strustures into Caml and Caml extracted * code. This includes initializing Caml variables based on Coq terms, parsing * various Coq expressions into Caml, and dumping Caml expressions into Coq. * * Opened here and in csdpcert.ml. *) module M = struct open Coqlib open Term (** * Location of the Coq libraries. *) let logic_dir = ["Coq";"Logic";"Decidable"] let mic_modules = [ ["Coq";"Lists";"List"]; ["ZMicromega"]; ["Tauto"]; ["RingMicromega"]; ["EnvRing"]; ["Coq"; "micromega"; "ZMicromega"]; ["Coq"; "micromega"; "RMicromega"]; ["Coq" ; "micromega" ; "Tauto"]; ["Coq" ; "micromega" ; "RingMicromega"]; ["Coq" ; "micromega" ; "EnvRing"]; ["Coq";"QArith"; "QArith_base"]; ["Coq";"Reals" ; "Rdefinitions"]; ["Coq";"Reals" ; "Rpow_def"]; ["LRing_normalise"]] let coq_modules = init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules @ mic_modules let bin_module = [["Coq";"Numbers";"BinNums"]] let r_modules = [["Coq";"Reals" ; "Rdefinitions"]; ["Coq";"Reals" ; "Rpow_def"] ; ] let z_modules = [["Coq";"ZArith";"BinInt"]] (** * Initialization : a large amount of Caml symbols are derived from * ZMicromega.v *) let init_constant = gen_constant_in_modules "ZMicromega" init_modules let constant = gen_constant_in_modules "ZMicromega" coq_modules let bin_constant = gen_constant_in_modules "ZMicromega" bin_module let r_constant = gen_constant_in_modules "ZMicromega" r_modules let z_constant = gen_constant_in_modules "ZMicromega" z_modules let m_constant = gen_constant_in_modules "ZMicromega" mic_modules let coq_and = lazy (init_constant "and") let coq_or = lazy (init_constant "or") let coq_not = lazy (init_constant "not") let coq_iff = lazy (init_constant "iff") let coq_True = lazy (init_constant "True") let coq_False = lazy (init_constant "False") let coq_cons = lazy (constant "cons") let coq_nil = lazy (constant "nil") let coq_list = lazy (constant "list") let coq_O = lazy (init_constant "O") let coq_S = lazy (init_constant "S") let coq_nat = lazy (init_constant "nat") let coq_N0 = lazy (bin_constant "N0") let coq_Npos = lazy (bin_constant "Npos") let coq_pair = lazy (init_constant "pair") let coq_None = lazy (init_constant "None") let coq_option = lazy (init_constant "option") let coq_positive = lazy (bin_constant "positive") let coq_xH = lazy (bin_constant "xH") let coq_xO = lazy (bin_constant "xO") let coq_xI = lazy (bin_constant "xI") let coq_Z = lazy (bin_constant "Z") let coq_ZERO = lazy (bin_constant "Z0") let coq_POS = lazy (bin_constant "Zpos") let coq_NEG = lazy (bin_constant "Zneg") let coq_Q = lazy (constant "Q") let coq_R = lazy (constant "R") let coq_Build_Witness = lazy (constant "Build_Witness") let coq_Qmake = lazy (constant "Qmake") let coq_Rcst = lazy (constant "Rcst") let coq_C0 = lazy (m_constant "C0") let coq_C1 = lazy (m_constant "C1") let coq_CQ = lazy (m_constant "CQ") let coq_CZ = lazy (m_constant "CZ") let coq_CPlus = lazy (m_constant "CPlus") let coq_CMinus = lazy (m_constant "CMinus") let coq_CMult = lazy (m_constant "CMult") let coq_CInv = lazy (m_constant "CInv") let coq_COpp = lazy (m_constant "COpp") let coq_R0 = lazy (constant "R0") let coq_R1 = lazy (constant "R1") let coq_proofTerm = lazy (constant "ZArithProof") let coq_doneProof = lazy (constant "DoneProof") let coq_ratProof = lazy (constant "RatProof") let coq_cutProof = lazy (constant "CutProof") let coq_enumProof = lazy (constant "EnumProof") let coq_Zgt = lazy (z_constant "Z.gt") let coq_Zge = lazy (z_constant "Z.ge") let coq_Zle = lazy (z_constant "Z.le") let coq_Zlt = lazy (z_constant "Z.lt") let coq_Eq = lazy (init_constant "eq") let coq_Zplus = lazy (z_constant "Z.add") let coq_Zminus = lazy (z_constant "Z.sub") let coq_Zopp = lazy (z_constant "Z.opp") let coq_Zmult = lazy (z_constant "Z.mul") let coq_Zpower = lazy (z_constant "Z.pow") let coq_Qgt = lazy (constant "Qgt") let coq_Qge = lazy (constant "Qge") let coq_Qle = lazy (constant "Qle") let coq_Qlt = lazy (constant "Qlt") let coq_Qeq = lazy (constant "Qeq") let coq_Qplus = lazy (constant "Qplus") let coq_Qminus = lazy (constant "Qminus") let coq_Qopp = lazy (constant "Qopp") let coq_Qmult = lazy (constant "Qmult") let coq_Qpower = lazy (constant "Qpower") let coq_Rgt = lazy (r_constant "Rgt") let coq_Rge = lazy (r_constant "Rge") let coq_Rle = lazy (r_constant "Rle") let coq_Rlt = lazy (r_constant "Rlt") let coq_Rplus = lazy (r_constant "Rplus") let coq_Rminus = lazy (r_constant "Rminus") let coq_Ropp = lazy (r_constant "Ropp") let coq_Rmult = lazy (r_constant "Rmult") let coq_Rdiv = lazy (r_constant "Rdiv") let coq_Rinv = lazy (r_constant "Rinv") let coq_Rpower = lazy (r_constant "pow") let coq_IQR = lazy (constant "IQR") let coq_IZR = lazy (constant "IZR") let coq_PEX = lazy (constant "PEX" ) let coq_PEc = lazy (constant"PEc") let coq_PEadd = lazy (constant "PEadd") let coq_PEopp = lazy (constant "PEopp") let coq_PEmul = lazy (constant "PEmul") let coq_PEsub = lazy (constant "PEsub") let coq_PEpow = lazy (constant "PEpow") let coq_PX = lazy (constant "PX" ) let coq_Pc = lazy (constant"Pc") let coq_Pinj = lazy (constant "Pinj") let coq_OpEq = lazy (constant "OpEq") let coq_OpNEq = lazy (constant "OpNEq") let coq_OpLe = lazy (constant "OpLe") let coq_OpLt = lazy (constant "OpLt") let coq_OpGe = lazy (constant "OpGe") let coq_OpGt = lazy (constant "OpGt") let coq_PsatzIn = lazy (constant "PsatzIn") let coq_PsatzSquare = lazy (constant "PsatzSquare") let coq_PsatzMulE = lazy (constant "PsatzMulE") let coq_PsatzMultC = lazy (constant "PsatzMulC") let coq_PsatzAdd = lazy (constant "PsatzAdd") let coq_PsatzC = lazy (constant "PsatzC") let coq_PsatzZ = lazy (constant "PsatzZ") let coq_coneMember = lazy (constant "coneMember") let coq_make_impl = lazy (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_impl") let coq_make_conj = lazy (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_conj") let coq_TT = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT") let coq_FF = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "FF") let coq_And = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "Cj") let coq_Or = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "D") let coq_Neg = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "N") let coq_Atom = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "A") let coq_X = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "X") let coq_Impl = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "I") let coq_Formula = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "BFormula") (** * Initialization : a few Caml symbols are derived from other libraries; * QMicromega, ZArithRing, RingMicromega. *) let coq_QWitness = lazy (gen_constant_in_modules "QMicromega" [["Coq"; "micromega"; "QMicromega"]] "QWitness") let coq_ZWitness = lazy (gen_constant_in_modules "QMicromega" [["Coq"; "micromega"; "ZMicromega"]] "ZWitness") let coq_N_of_Z = lazy (gen_constant_in_modules "ZArithRing" [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z") let coq_Build = lazy (gen_constant_in_modules "RingMicromega" [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Build_Formula") let coq_Cstr = lazy (gen_constant_in_modules "RingMicromega" [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Formula") (** * Parsing and dumping : transformation functions between Caml and Coq * data-structures. * * dump_* functions go from Micromega to Coq terms * parse_* functions go from Coq to Micromega terms * pp_* functions pretty-print Coq terms. *) (* Error datastructures *) type parse_error = | Ukn | BadStr of string | BadNum of int | BadTerm of Term.constr | Msg of string | Goal of (Term.constr list ) * Term.constr * parse_error let string_of_error = function | Ukn -> "ukn" | BadStr s -> s | BadNum i -> string_of_int i | BadTerm _ -> "BadTerm" | Msg s -> s | Goal _ -> "Goal" exception ParseError (* A simple but useful getter function *) let get_left_construct term = match Term.kind_of_term term with | Term.Construct(_,i) -> (i,[| |]) | Term.App(l,rst) -> (match Term.kind_of_term l with | Term.Construct(_,i) -> (i,rst) | _ -> raise ParseError ) | _ -> raise ParseError (* Access the Micromega module *) (* parse/dump/print from numbers up to expressions and formulas *) let rec parse_nat term = let (i,c) = get_left_construct term in match i with | 1 -> Mc.O | 2 -> Mc.S (parse_nat (c.(0))) | i -> raise ParseError let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n) let rec dump_nat x = match x with | Mc.O -> Lazy.force coq_O | Mc.S p -> Term.mkApp(Lazy.force coq_S,[| dump_nat p |]) let rec parse_positive term = let (i,c) = get_left_construct term in match i with | 1 -> Mc.XI (parse_positive c.(0)) | 2 -> Mc.XO (parse_positive c.(0)) | 3 -> Mc.XH | i -> raise ParseError let rec dump_positive x = match x with | Mc.XH -> Lazy.force coq_xH | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_positive p |]) | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_positive p |]) let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x) let rec dump_n x = match x with | Mc.N0 -> Lazy.force coq_N0 | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) let rec dump_index x = match x with | Mc.XH -> Lazy.force coq_xH | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_index p |]) | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_index p |]) let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x) let rec pp_n o x = output_string o (string_of_int (CoqToCaml.n x)) let dump_pair t1 t2 dump_t1 dump_t2 (x,y) = Term.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|]) let rec parse_z term = let (i,c) = get_left_construct term in match i with | 1 -> Mc.Z0 | 2 -> Mc.Zpos (parse_positive c.(0)) | 3 -> Mc.Zneg (parse_positive c.(0)) | i -> raise ParseError let dump_z x = match x with | Mc.Z0 ->Lazy.force coq_ZERO | Mc.Zpos p -> Term.mkApp(Lazy.force coq_POS,[| dump_positive p|]) | Mc.Zneg p -> Term.mkApp(Lazy.force coq_NEG,[| dump_positive p|]) let pp_z o x = Printf.fprintf o "%s" (Big_int.string_of_big_int (CoqToCaml.z_big_int x)) let dump_num bd1 = Term.mkApp(Lazy.force coq_Qmake, [|dump_z (CamlToCoq.bigint (numerator bd1)) ; dump_positive (CamlToCoq.positive_big_int (denominator bd1)) |]) let dump_q q = Term.mkApp(Lazy.force coq_Qmake, [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|]) let parse_q term = match Term.kind_of_term term with | Term.App(c, args) -> if c = Lazy.force coq_Qmake then {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) } else raise ParseError | _ -> raise ParseError let rec pp_Rcst o cst = match cst with | Mc.C0 -> output_string o "C0" | Mc.C1 -> output_string o "C1" | Mc.CQ q -> output_string o "CQ _" | Mc.CZ z -> pp_z o z | Mc.CPlus(x,y) -> Printf.fprintf o "(%a + %a)" pp_Rcst x pp_Rcst y | Mc.CMinus(x,y) -> Printf.fprintf o "(%a - %a)" pp_Rcst x pp_Rcst y | Mc.CMult(x,y) -> Printf.fprintf o "(%a * %a)" pp_Rcst x pp_Rcst y | Mc.CInv t -> Printf.fprintf o "(/ %a)" pp_Rcst t | Mc.COpp t -> Printf.fprintf o "(- %a)" pp_Rcst t let rec dump_Rcst cst = match cst with | Mc.C0 -> Lazy.force coq_C0 | Mc.C1 -> Lazy.force coq_C1 | Mc.CQ q -> Term.mkApp(Lazy.force coq_CQ, [| dump_q q |]) | Mc.CZ z -> Term.mkApp(Lazy.force coq_CZ, [| dump_z z |]) | Mc.CPlus(x,y) -> Term.mkApp(Lazy.force coq_CPlus, [| dump_Rcst x ; dump_Rcst y |]) | Mc.CMinus(x,y) -> Term.mkApp(Lazy.force coq_CMinus, [| dump_Rcst x ; dump_Rcst y |]) | Mc.CMult(x,y) -> Term.mkApp(Lazy.force coq_CMult, [| dump_Rcst x ; dump_Rcst y |]) | Mc.CInv t -> Term.mkApp(Lazy.force coq_CInv, [| dump_Rcst t |]) | Mc.COpp t -> Term.mkApp(Lazy.force coq_COpp, [| dump_Rcst t |]) let rec parse_Rcst term = let (i,c) = get_left_construct term in match i with | 1 -> Mc.C0 | 2 -> Mc.C1 | 3 -> Mc.CQ (parse_q c.(0)) | 4 -> Mc.CPlus(parse_Rcst c.(0), parse_Rcst c.(1)) | 5 -> Mc.CMinus(parse_Rcst c.(0), parse_Rcst c.(1)) | 6 -> Mc.CMult(parse_Rcst c.(0), parse_Rcst c.(1)) | 7 -> Mc.CInv(parse_Rcst c.(0)) | 8 -> Mc.COpp(parse_Rcst c.(0)) | _ -> raise ParseError let rec parse_list parse_elt term = let (i,c) = get_left_construct term in match i with | 1 -> [] | 2 -> parse_elt c.(1) :: parse_list parse_elt c.(2) | i -> raise ParseError let rec dump_list typ dump_elt l = match l with | [] -> Term.mkApp(Lazy.force coq_nil,[| typ |]) | e :: l -> Term.mkApp(Lazy.force coq_cons, [| typ; dump_elt e;dump_list typ dump_elt l|]) let pp_list op cl elt o l = let rec _pp o l = match l with | [] -> () | [e] -> Printf.fprintf o "%a" elt e | e::l -> Printf.fprintf o "%a ,%a" elt e _pp l in Printf.fprintf o "%s%a%s" op _pp l cl let pp_var = pp_positive let dump_var = dump_positive let pp_expr pp_z o e = let rec pp_expr o e = match e with | Mc.PEX n -> Printf.fprintf o "V %a" pp_var n | Mc.PEc z -> pp_z o z | Mc.PEadd(e1,e2) -> Printf.fprintf o "(%a)+(%a)" pp_expr e1 pp_expr e2 | Mc.PEmul(e1,e2) -> Printf.fprintf o "%a*(%a)" pp_expr e1 pp_expr e2 | Mc.PEopp e -> Printf.fprintf o "-(%a)" pp_expr e | Mc.PEsub(e1,e2) -> Printf.fprintf o "(%a)-(%a)" pp_expr e1 pp_expr e2 | Mc.PEpow(e,n) -> Printf.fprintf o "(%a)^(%a)" pp_expr e pp_n n in pp_expr o e let dump_expr typ dump_z e = let rec dump_expr e = match e with | Mc.PEX n -> mkApp(Lazy.force coq_PEX,[| typ; dump_var n |]) | Mc.PEc z -> mkApp(Lazy.force coq_PEc,[| typ ; dump_z z |]) | Mc.PEadd(e1,e2) -> mkApp(Lazy.force coq_PEadd, [| typ; dump_expr e1;dump_expr e2|]) | Mc.PEsub(e1,e2) -> mkApp(Lazy.force coq_PEsub, [| typ; dump_expr e1;dump_expr e2|]) | Mc.PEopp e -> mkApp(Lazy.force coq_PEopp, [| typ; dump_expr e|]) | Mc.PEmul(e1,e2) -> mkApp(Lazy.force coq_PEmul, [| typ; dump_expr e1;dump_expr e2|]) | Mc.PEpow(e,n) -> mkApp(Lazy.force coq_PEpow, [| typ; dump_expr e; dump_n n|]) in dump_expr e let dump_pol typ dump_c e = let rec dump_pol e = match e with | Mc.Pc n -> mkApp(Lazy.force coq_Pc, [|typ ; dump_c n|]) | Mc.Pinj(p,pol) -> mkApp(Lazy.force coq_Pinj , [| typ ; dump_positive p ; dump_pol pol|]) | Mc.PX(pol1,p,pol2) -> mkApp(Lazy.force coq_PX, [| typ ; dump_pol pol1 ; dump_positive p ; dump_pol pol2|]) in dump_pol e let pp_pol pp_c o e = let rec pp_pol o e = match e with | Mc.Pc n -> Printf.fprintf o "Pc %a" pp_c n | Mc.Pinj(p,pol) -> Printf.fprintf o "Pinj(%a,%a)" pp_positive p pp_pol pol | Mc.PX(pol1,p,pol2) -> Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 in pp_pol o e let pp_cnf pp_c o f = let pp_clause o l = List.iter (fun ((p,_),t) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) l in List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause l) f let dump_psatz typ dump_z e = let z = Lazy.force typ in let rec dump_cone e = match e with | Mc.PsatzIn n -> mkApp(Lazy.force coq_PsatzIn,[| z; dump_nat n |]) | Mc.PsatzMulC(e,c) -> mkApp(Lazy.force coq_PsatzMultC, [| z; dump_pol z dump_z e ; dump_cone c |]) | Mc.PsatzSquare e -> mkApp(Lazy.force coq_PsatzSquare, [| z;dump_pol z dump_z e|]) | Mc.PsatzAdd(e1,e2) -> mkApp(Lazy.force coq_PsatzAdd, [| z; dump_cone e1; dump_cone e2|]) | Mc.PsatzMulE(e1,e2) -> mkApp(Lazy.force coq_PsatzMulE, [| z; dump_cone e1; dump_cone e2|]) | Mc.PsatzC p -> mkApp(Lazy.force coq_PsatzC,[| z; dump_z p|]) | Mc.PsatzZ -> mkApp( Lazy.force coq_PsatzZ,[| z|]) in dump_cone e let pp_psatz pp_z o e = let rec pp_cone o e = match e with | Mc.PsatzIn n -> Printf.fprintf o "(In %a)%%nat" pp_nat n | Mc.PsatzMulC(e,c) -> Printf.fprintf o "( %a [*] %a)" (pp_pol pp_z) e pp_cone c | Mc.PsatzSquare e -> Printf.fprintf o "(%a^2)" (pp_pol pp_z) e | Mc.PsatzAdd(e1,e2) -> Printf.fprintf o "(%a [+] %a)" pp_cone e1 pp_cone e2 | Mc.PsatzMulE(e1,e2) -> Printf.fprintf o "(%a [*] %a)" pp_cone e1 pp_cone e2 | Mc.PsatzC p -> Printf.fprintf o "(%a)%%positive" pp_z p | Mc.PsatzZ -> Printf.fprintf o "0" in pp_cone o e let rec dump_op = function | Mc.OpEq-> Lazy.force coq_OpEq | Mc.OpNEq-> Lazy.force coq_OpNEq | Mc.OpLe -> Lazy.force coq_OpLe | Mc.OpGe -> Lazy.force coq_OpGe | Mc.OpGt-> Lazy.force coq_OpGt | Mc.OpLt-> Lazy.force coq_OpLt let pp_op o e= match e with | Mc.OpEq-> Printf.fprintf o "=" | Mc.OpNEq-> Printf.fprintf o "<>" | Mc.OpLe -> Printf.fprintf o "=<" | Mc.OpGe -> Printf.fprintf o ">=" | Mc.OpGt-> Printf.fprintf o ">" | Mc.OpLt-> Printf.fprintf o "<" let pp_cstr pp_z o {Mc.flhs = l ; Mc.fop = op ; Mc.frhs = r } = Printf.fprintf o"(%a %a %a)" (pp_expr pp_z) l pp_op op (pp_expr pp_z) r let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} = Term.mkApp(Lazy.force coq_Build, [| typ; dump_expr typ dump_constant e1 ; dump_op o ; dump_expr typ dump_constant e2|]) let assoc_const x l = try snd (List.find (fun (x',y) -> x = Lazy.force x') l) with Not_found -> raise ParseError let zop_table = [ coq_Zgt, Mc.OpGt ; coq_Zge, Mc.OpGe ; coq_Zlt, Mc.OpLt ; coq_Zle, Mc.OpLe ] let rop_table = [ coq_Rgt, Mc.OpGt ; coq_Rge, Mc.OpGe ; coq_Rlt, Mc.OpLt ; coq_Rle, Mc.OpLe ] let qop_table = [ coq_Qlt, Mc.OpLt ; coq_Qle, Mc.OpLe ; coq_Qeq, Mc.OpEq ] let parse_zop (op,args) = match kind_of_term op with | Const x -> (assoc_const op zop_table, args.(0) , args.(1)) | Ind(n,0) -> if op = Lazy.force coq_Eq && args.(0) = Lazy.force coq_Z then (Mc.OpEq, args.(1), args.(2)) else raise ParseError | _ -> failwith "parse_zop" let parse_rop (op,args) = match kind_of_term op with | Const x -> (assoc_const op rop_table, args.(0) , args.(1)) | Ind(n,0) -> if op = Lazy.force coq_Eq && args.(0) = Lazy.force coq_R then (Mc.OpEq, args.(1), args.(2)) else raise ParseError | _ -> failwith "parse_zop" let parse_qop (op,args) = (assoc_const op qop_table, args.(0) , args.(1)) let is_constant t = (* This is an approx *) match kind_of_term t with | Construct(i,_) -> true | _ -> false type 'a op = | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) | Opp | Power | Ukn of string let assoc_ops x l = try snd (List.find (fun (x',y) -> x = Lazy.force x') l) with Not_found -> Ukn "Oups" (** * MODULE: Env is for environment. *) module Env = struct type t = constr list let compute_rank_add env v = let rec _add env n v = match env with | [] -> ([v],n) | e::l -> if eq_constr e v then (env,n) else let (env,n) = _add l ( n+1) v in (e::env,n) in let (env, n) = _add env 1 v in (env, CamlToCoq.idx n) let empty = [] let elements env = env end (* MODULE END: Env *) (** * This is the big generic function for expression parsers. *) let parse_expr parse_constant parse_exp ops_spec env term = if debug then (Pp.pp (Pp.str "parse_expr: "); Pp.pp (Printer.prterm term); Pp.pp (Pp.str "\n"); Pp.pp_flush ()); (* let constant_or_variable env term = try ( Mc.PEc (parse_constant term) , env) with ParseError -> let (env,n) = Env.compute_rank_add env term in (Mc.PEX n , env) in *) let parse_variable env term = let (env,n) = Env.compute_rank_add env term in (Mc.PEX n , env) in let rec parse_expr env term = let combine env op (t1,t2) = let (expr1,env) = parse_expr env t1 in let (expr2,env) = parse_expr env t2 in (op expr1 expr2,env) in try (Mc.PEc (parse_constant term) , env) with ParseError -> match kind_of_term term with | App(t,args) -> ( match kind_of_term t with | Const c -> ( match assoc_ops t ops_spec with | Binop f -> combine env f (args.(0),args.(1)) | Opp -> let (expr,env) = parse_expr env args.(0) in (Mc.PEopp expr, env) | Power -> begin try let (expr,env) = parse_expr env args.(0) in let power = (parse_exp expr args.(1)) in (power , env) with e when e <> Sys.Break -> (* if the exponent is a variable *) let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) end | Ukn s -> if debug then (Printf.printf "unknown op: %s\n" s; flush stdout;); let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) ) | _ -> parse_variable env term ) | _ -> parse_variable env term in parse_expr env term let zop_spec = [ coq_Zplus , Binop (fun x y -> Mc.PEadd(x,y)) ; coq_Zminus , Binop (fun x y -> Mc.PEsub(x,y)) ; coq_Zmult , Binop (fun x y -> Mc.PEmul (x,y)) ; coq_Zopp , Opp ; coq_Zpower , Power] let qop_spec = [ coq_Qplus , Binop (fun x y -> Mc.PEadd(x,y)) ; coq_Qminus , Binop (fun x y -> Mc.PEsub(x,y)) ; coq_Qmult , Binop (fun x y -> Mc.PEmul (x,y)) ; coq_Qopp , Opp ; coq_Qpower , Power] let rop_spec = [ coq_Rplus , Binop (fun x y -> Mc.PEadd(x,y)) ; coq_Rminus , Binop (fun x y -> Mc.PEsub(x,y)) ; coq_Rmult , Binop (fun x y -> Mc.PEmul (x,y)) ; coq_Ropp , Opp ; coq_Rpower , Power] let zconstant = parse_z let qconstant = parse_q let rconst_assoc = [ coq_Rplus , (fun x y -> Mc.CPlus(x,y)) ; coq_Rminus , (fun x y -> Mc.CMinus(x,y)) ; coq_Rmult , (fun x y -> Mc.CMult(x,y)) ; coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ; ] let rec rconstant term = match Term.kind_of_term term with | Const x -> if term = Lazy.force coq_R0 then Mc.C0 else if term = Lazy.force coq_R1 then Mc.C1 else raise ParseError | App(op,args) -> begin try (* the evaluation order is important in the following *) let f = assoc_const op rconst_assoc in let a = rconstant args.(0) in let b = rconstant args.(1) in f a b with ParseError -> match op with | op when op = Lazy.force coq_Rinv -> Mc.CInv(rconstant args.(0)) | op when op = Lazy.force coq_IQR -> Mc.CQ (parse_q args.(0)) (* | op when op = Lazy.force coq_IZR -> Mc.CZ (parse_z args.(0))*) | _ -> raise ParseError end | _ -> raise ParseError let rconstant term = if debug then (Pp.pp_flush (); Pp.pp (Pp.str "rconstant: "); Pp.pp (Printer.prterm term); Pp.pp (Pp.str "\n"); Pp.pp_flush ()); let res = rconstant term in if debug then (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; res let parse_zexpr = parse_expr zconstant (fun expr x -> let exp = (parse_z x) in match exp with | Mc.Zneg _ -> Mc.PEc Mc.Z0 | _ -> Mc.PEpow(expr, Mc.Z.to_N exp)) zop_spec let parse_qexpr = parse_expr qconstant (fun expr x -> let exp = parse_z x in match exp with | Mc.Zneg _ -> begin match expr with | Mc.PEc q -> Mc.PEc (Mc.qpower q exp) | _ -> print_string "parse_qexpr parse error" ; flush stdout ; raise ParseError end | _ -> let exp = Mc.Z.to_N exp in Mc.PEpow(expr,exp)) qop_spec let parse_rexpr = parse_expr rconstant (fun expr x -> let exp = Mc.N.of_nat (parse_nat x) in Mc.PEpow(expr,exp)) rop_spec let parse_arith parse_op parse_expr env cstr = if debug then (Pp.pp_flush (); Pp.pp (Pp.str "parse_arith: "); Pp.pp (Printer.prterm cstr); Pp.pp (Pp.str "\n"); Pp.pp_flush ()); match kind_of_term cstr with | App(op,args) -> let (op,lhs,rhs) = parse_op (op,args) in let (e1,env) = parse_expr env lhs in let (e2,env) = parse_expr env rhs in ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) | _ -> failwith "error : parse_arith(2)" let parse_zarith = parse_arith parse_zop parse_zexpr let parse_qarith = parse_arith parse_qop parse_qexpr let parse_rarith = parse_arith parse_rop parse_rexpr (* generic parsing of arithmetic expressions *) let rec f2f = function | TT -> Mc.TT | FF -> Mc.FF | X _ -> Mc.X | A (x,_,_) -> Mc.A x | C (a,b) -> Mc.Cj(f2f a,f2f b) | D (a,b) -> Mc.D(f2f a,f2f b) | N (a) -> Mc.N(f2f a) | I(a,_,b) -> Mc.I(f2f a,f2f b) let is_prop t = match t with | Names.Anonymous -> true (* Not quite right *) | Names.Name x -> false let mkC f1 f2 = C(f1,f2) let mkD f1 f2 = D(f1,f2) let mkIff f1 f2 = C(I(f1,None,f2),I(f2,None,f1)) let mkI f1 f2 = I(f1,None,f2) let mkformula_binary g term f1 f2 = match f1 , f2 with | X _ , X _ -> X(term) | _ -> g f1 f2 (** * This is the big generic function for formula parsers. *) let parse_formula parse_atom env tg term = let parse_atom env tg t = try let (at,env) = parse_atom env t in (A(at,tg,t), env,Tag.next tg) with e when e <> Sys.Break -> (X(t),env,tg) in let rec xparse_formula env tg term = match kind_of_term term with | App(l,rst) -> (match rst with | [|a;b|] when eq_constr l (Lazy.force coq_and) -> let f,env,tg = xparse_formula env tg a in let g,env, tg = xparse_formula env tg b in mkformula_binary mkC term f g,env,tg | [|a;b|] when eq_constr l (Lazy.force coq_or) -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkD term f g,env,tg | [|a|] when eq_constr l (Lazy.force coq_not) -> let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg) | [|a;b|] when eq_constr l (Lazy.force coq_iff) -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkIff term f g,env,tg | _ -> parse_atom env tg term) | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b) -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkI term f g,env,tg | _ when eq_constr term (Lazy.force coq_True) -> (TT,env,tg) | _ when eq_constr term (Lazy.force coq_False) -> (FF,env,tg) | _ -> X(term),env,tg in xparse_formula env tg ((*Reductionops.whd_zeta*) term) let dump_formula typ dump_atom f = let rec xdump f = match f with | TT -> mkApp(Lazy.force coq_TT,[|typ|]) | FF -> mkApp(Lazy.force coq_FF,[|typ|]) | C(x,y) -> mkApp(Lazy.force coq_And,[|typ ; xdump x ; xdump y|]) | D(x,y) -> mkApp(Lazy.force coq_Or,[|typ ; xdump x ; xdump y|]) | I(x,_,y) -> mkApp(Lazy.force coq_Impl,[|typ ; xdump x ; xdump y|]) | N(x) -> mkApp(Lazy.force coq_Neg,[|typ ; xdump x|]) | A(x,_,_) -> mkApp(Lazy.force coq_Atom,[|typ ; dump_atom x|]) | X(t) -> mkApp(Lazy.force coq_X,[|typ ; t|]) in xdump f (** * Given a conclusion and a list of affectations, rebuild a term prefixed by * the appropriate letins. * TODO: reverse the list of bindings! *) let set l concl = let rec xset acc = function | [] -> acc | (e::l) -> let (name,expr,typ) = e in xset (Term.mkNamedLetIn (Names.id_of_string name) expr typ acc) l in xset concl l end (** * MODULE END: M *) open M let rec sig_of_cone = function | Mc.PsatzIn n -> [CoqToCaml.nat n] | Mc.PsatzMulE(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2) | Mc.PsatzMulC(w1,w2) -> (sig_of_cone w2) | Mc.PsatzAdd(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2) | _ -> [] let same_proof sg cl1 cl2 = let rec xsame_proof sg = match sg with | [] -> true | n::sg -> (try List.nth cl1 n = List.nth cl2 n with e when e <> Sys.Break -> false) && (xsame_proof sg ) in xsame_proof sg let tags_of_clause tgs wit clause = let rec xtags tgs = function | Mc.PsatzIn n -> Names.Idset.union tgs (snd (List.nth clause (CoqToCaml.nat n) )) | Mc.PsatzMulC(e,w) -> xtags tgs w | Mc.PsatzMulE (w1,w2) | Mc.PsatzAdd(w1,w2) -> xtags (xtags tgs w1) w2 | _ -> tgs in xtags tgs wit (*let tags_of_cnf wits cnf = List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl) Names.Idset.empty wits cnf *) let find_witness prover polys1 = try_any prover polys1 let rec witness prover l1 l2 = match l2 with | [] -> Some [] | e :: l2 -> match find_witness prover (e::l1) with | None -> None | Some w -> (match witness prover l1 l2 with | None -> None | Some l -> Some (w::l) ) let rec apply_ids t ids = match ids with | [] -> t | i::ids -> apply_ids (Term.mkApp(t,[| Term.mkVar i |])) ids let coq_Node = lazy (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") let coq_Leaf = lazy (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf") let coq_Empty = lazy (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") let btree_of_array typ a = let size_of_a = Array.length a in let semi_size_of_a = size_of_a lsr 1 in let node = Lazy.force coq_Node and leaf = Lazy.force coq_Leaf and empty = Term.mkApp (Lazy.force coq_Empty, [| typ |]) in let rec aux n = if n > size_of_a then empty else if n > semi_size_of_a then Term.mkApp (leaf, [| typ; a.(n-1) |]) else Term.mkApp (node, [| typ; aux (2*n); a.(n-1); aux (2*n+1) |]) in aux 1 let btree_of_array typ a = try btree_of_array typ a with x when x <> Sys.Break -> failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x)) let dump_varmap typ env = btree_of_array typ (Array.of_list env) let rec pp_varmap o vm = match vm with | Mc.Empty -> output_string o "[]" | Mc.Leaf z -> Printf.fprintf o "[%a]" pp_z z | Mc.Node(l,z,r) -> Printf.fprintf o "[%a, %a, %a]" pp_varmap l pp_z z pp_varmap r let rec dump_proof_term = function | Micromega.DoneProof -> Lazy.force coq_doneProof | Micromega.RatProof(cone,rst) -> Term.mkApp(Lazy.force coq_ratProof, [| dump_psatz coq_Z dump_z cone; dump_proof_term rst|]) | Micromega.CutProof(cone,prf) -> Term.mkApp(Lazy.force coq_cutProof, [| dump_psatz coq_Z dump_z cone ; dump_proof_term prf|]) | Micromega.EnumProof(c1,c2,prfs) -> Term.mkApp (Lazy.force coq_enumProof, [| dump_psatz coq_Z dump_z c1 ; dump_psatz coq_Z dump_z c2 ; dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |]) let rec size_of_psatz = function | Micromega.PsatzIn _ -> 1 | Micromega.PsatzSquare _ -> 1 | Micromega.PsatzMulC(_,p) -> 1 + (size_of_psatz p) | Micromega.PsatzMulE(p1,p2) | Micromega.PsatzAdd(p1,p2) -> size_of_psatz p1 + size_of_psatz p2 | Micromega.PsatzC _ -> 1 | Micromega.PsatzZ -> 1 let rec size_of_pf = function | Micromega.DoneProof -> 1 | Micromega.RatProof(p,a) -> (size_of_pf a) + (size_of_psatz p) | Micromega.CutProof(p,a) -> (size_of_pf a) + (size_of_psatz p) | Micromega.EnumProof(p1,p2,l) -> (size_of_psatz p1) + (size_of_psatz p2) + (List.fold_left (fun acc p -> size_of_pf p + acc) 0 l) let dump_proof_term t = if debug then Printf.printf "dump_proof_term %i\n" (size_of_pf t) ; dump_proof_term t let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden let rec pp_proof_term o = function | Micromega.DoneProof -> Printf.fprintf o "D" | Micromega.RatProof(cone,rst) -> Printf.fprintf o "R[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst | Micromega.CutProof(cone,rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst | Micromega.EnumProof(c1,c2,rst) -> Printf.fprintf o "EP[%a,%a,%a]" (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 (pp_list "[" "]" pp_proof_term) rst let rec parse_hyps parse_arith env tg hyps = match hyps with | [] -> ([],env,tg) | (i,t)::l -> let (lhyps,env,tg) = parse_hyps parse_arith env tg l in try let (c,env,tg) = parse_formula parse_arith env tg t in ((i,c)::lhyps, env,tg) with e when e <> Sys.Break -> (lhyps,env,tg) (*(if debug then Printf.printf "parse_arith : %s\n" x);*) (*exception ParseError*) let parse_goal parse_arith env hyps term = (* try*) let (f,env,tg) = parse_formula parse_arith env (Tag.from 0) term in let (lhyps,env,tg) = parse_hyps parse_arith env tg hyps in (lhyps,f,env) (* with Failure x -> raise ParseError*) (** * The datastructures that aggregate theory-dependent proof values. *) type ('synt_c, 'prf) domain_spec = { typ : Term.constr; (* is the type of the interpretation domain - Z, Q, R*) coeff : Term.constr ; (* is the type of the syntactic coeffs - Z , Q , Rcst *) dump_coeff : 'synt_c -> Term.constr ; proof_typ : Term.constr ; dump_proof : 'prf -> Term.constr } let zz_domain_spec = lazy { typ = Lazy.force coq_Z; coeff = Lazy.force coq_Z; dump_coeff = dump_z ; proof_typ = Lazy.force coq_proofTerm ; dump_proof = dump_proof_term } let qq_domain_spec = lazy { typ = Lazy.force coq_Q; coeff = Lazy.force coq_Q; dump_coeff = dump_q ; proof_typ = Lazy.force coq_QWitness ; dump_proof = dump_psatz coq_Q dump_q } let rcst_domain_spec = lazy { typ = Lazy.force coq_R; coeff = Lazy.force coq_Rcst; dump_coeff = dump_Rcst; proof_typ = Lazy.force coq_QWitness ; dump_proof = dump_psatz coq_Q dump_q } (** * Instanciate the current Coq goal with a Micromega formula, a varmap, and a * witness. *) let micromega_order_change spec cert cert_typ env ff gl = let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[|spec.coeff|])) in let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in let vm = dump_varmap (spec.typ) env in Tactics.change_in_concl None (set [ ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |])); ("__varmap", vm, Term.mkApp (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|spec.typ|])); ("__wit", cert, cert_typ) ] (Tacmach.pf_concl gl) ) gl (** * The datastructures that aggregate prover attributes. *) type ('a,'prf) prover = { name : string ; (* name of the prover *) prover : 'a list -> 'prf option ; (* the prover itself *) hyps : 'prf -> ISet.t ; (* extract the indexes of the hypotheses really used in the proof *) compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *) pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *) pp_f : out_channel -> 'a -> unit (* pretty printing of the formulas (polynomials)*) } (** * Given a list of provers and a disjunction of atoms, find a proof of any of * the atoms. Returns an (optional) pair of a proof and a prover * datastructure. *) let find_witness provers polys1 = let provers = List.map (fun p -> (fun l -> match p.prover l with | None -> None | Some prf -> Some(prf,p)) , p.name) provers in try_any provers (List.map fst polys1) (** * Given a list of provers and a CNF, find a proof for each of the clauses. * Return the proofs as a list. *) let witness_list prover l = let rec xwitness_list l = match l with | [] -> Some [] | e :: l -> match find_witness prover e with | None -> None | Some w -> (match xwitness_list l with | None -> None | Some l -> Some (w :: l) ) in xwitness_list l let witness_list_tags = witness_list (* *Deprecated* let is_singleton = function [] -> true | [e] -> true | _ -> false *) let pp_ml_list pp_elt o l = output_string o "[" ; List.iter (fun x -> Printf.fprintf o "%a ;" pp_elt x) l ; output_string o "]" (** * Prune the proof object, according to the 'diff' between two cnf formulas. *) let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = let new_cl = Mutils.mapi (fun (f,_) i -> (f,i)) new_cl in let remap i = let formula = try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" in List.assoc formula new_cl in (* if debug then begin Printf.printf "\ncompact_proof : %a %a %a" (pp_ml_list prover.pp_f) (List.map fst old_cl) prover.pp_prf prf (pp_ml_list prover.pp_f) (List.map fst new_cl) ; flush stdout end ; *) let res = try prover.compact prf remap with x when x <> Sys.Break -> if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; (* This should not happen -- this is the recovery plan... *) match prover.prover (List.map fst new_cl) with | None -> failwith "proof compaction error" | Some p -> p in if debug then begin Printf.printf " -> %a\n" prover.pp_prf res ; flush stdout end ; res in let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = let hyps_idx = prover.hyps prf in let hyps = selecti hyps_idx old_cl in is_sublist hyps new_cl in let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *) List.map (fun x -> let (o,p) = List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res in compact_proof o p x) cnf_ff' (** * "Hide out" tagged atoms of a formula by transforming them into generic * variables. See the Tag module in mutils.ml for more. *) let abstract_formula hyps f = let rec xabs f = match f with | X c -> X c | A(a,t,term) -> if TagSet.mem t hyps then A(a,t,term) else X(term) | C(f1,f2) -> (match xabs f1 , xabs f2 with | X a1 , X a2 -> X (Term.mkApp(Lazy.force coq_and, [|a1;a2|])) | f1 , f2 -> C(f1,f2) ) | D(f1,f2) -> (match xabs f1 , xabs f2 with | X a1 , X a2 -> X (Term.mkApp(Lazy.force coq_or, [|a1;a2|])) | f1 , f2 -> D(f1,f2) ) | N(f) -> (match xabs f with | X a -> X (Term.mkApp(Lazy.force coq_not, [|a|])) | f -> N f) | I(f1,hyp,f2) -> (match xabs f1 , hyp, xabs f2 with | X a1 , Some _ , af2 -> af2 | X a1 , None , X a2 -> X (Term.mkArrow a1 a2) | af1 , _ , af2 -> I(af1,hyp,af2) ) | FF -> FF | TT -> TT in xabs f (* [abstract_wrt_formula] is used in contexts whre f1 is already an abstraction of f2 *) let rec abstract_wrt_formula f1 f2 = match f1 , f2 with | X c , _ -> X c | A _ , A _ -> f2 | C(a,b) , C(a',b') -> C(abstract_wrt_formula a a', abstract_wrt_formula b b') | D(a,b) , D(a',b') -> D(abstract_wrt_formula a a', abstract_wrt_formula b b') | I(a,_,b) , I(a',x,b') -> I(abstract_wrt_formula a a',x, abstract_wrt_formula b b') | FF , FF -> FF | TT , TT -> TT | N x , N y -> N(abstract_wrt_formula x y) | _ -> failwith "abstract_wrt_formula" (** * This exception is raised by really_call_csdpcert if Coq's configure didn't * find a CSDP executable. *) exception CsdpNotFound (** * This is the core of Micromega: apply the prover, analyze the result and * prune unused fomulas, and finally modify the proof state. *) let formula_hyps_concl hyps concl = List.fold_right (fun (id,f) (cc,ids) -> match f with X _ -> (cc,ids) | _ -> (I(f,Some id,cc), id::ids)) hyps (concl,[]) let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 gl = (* Express the goal as one big implication *) let (ff,ids) = formula_hyps_concl polys1 polys2 in (* Convert the aplpication into a (mc_)cnf (a list of lists of formulas) *) let cnf_ff,cnf_ff_tags = cnf negate normalise unsat deduce ff in if debug then begin Pp.pp (Pp.str "Formula....\n") ; let formula_typ = (Term.mkApp(Lazy.force coq_Cstr, [|spec.coeff|])) in let ff = dump_formula formula_typ (dump_cstr spec.typ spec.dump_coeff) ff in Pp.pp (Printer.prterm ff) ; Pp.pp_flush (); Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff end; match witness_list_tags prover cnf_ff with | None -> None | Some res -> (*Printf.printf "\nList %i" (List.length `res); *) let hyps = List.fold_left (fun s (cl,(prf,p)) -> let tags = ISet.fold (fun i s -> let t = snd (List.nth cl i) in if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in TagSet.union s tags) (List.fold_left (fun s i -> TagSet.add i s) TagSet.empty cnf_ff_tags) (List.combine cnf_ff res) in if debug then (Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; Printf.printf "Hyps : %a\n" (fun o s -> TagSet.fold (fun i _ -> Printf.fprintf o "%a " Tag.pp i) s ()) hyps) ; let ff' = abstract_formula hyps ff in let cnf_ff',_ = cnf negate normalise unsat deduce ff' in if debug then begin Pp.pp (Pp.str "\nAFormula\n") ; let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in let ff' = dump_formula formula_typ (dump_cstr spec.typ spec.dump_coeff) ff' in Pp.pp (Printer.prterm ff') ; Pp.pp_flush (); Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' end; (* Even if it does not work, this does not mean it is not provable -- the prover is REALLY incomplete *) (* if debug then begin (* recompute the proofs *) match witness_list_tags prover cnf_ff' with | None -> failwith "abstraction is wrong" | Some res -> () end ; *) let res' = compact_proofs cnf_ff res cnf_ff' in let (ff',res',ids) = (ff',res', ids_of_formula ff') in let res' = dump_list (spec.proof_typ) spec.dump_proof res' in Some (ids,ff',res') (** * Parse the proof environment, and call micromega_tauto *) let micromega_gen parse_arith (negate:'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) unsat deduce spec prover gl = let concl = Tacmach.pf_concl gl in let hyps = Tacmach.pf_hyps_types gl in try let (hyps,concl,env) = parse_goal parse_arith Env.empty hyps concl in let env = Env.elements env in let spec = Lazy.force spec in match micromega_tauto negate normalise unsat deduce spec prover env hyps concl gl with | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl | Some (ids,ff',res') -> (Tacticals.tclTHENSEQ [ Tactics.generalize (List.map Term.mkVar ids) ; micromega_order_change spec res' (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env ff' ]) gl with (* | Failure x -> flush stdout ; Pp.pp_flush () ; Tacticals.tclFAIL 0 (Pp.str x) gl *) | ParseError -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl | CsdpNotFound -> flush stdout ; Pp.pp_flush () ; Tacticals.tclFAIL 0 (Pp.str (" Skipping what remains of this tactic: the complexity of the goal requires " ^ "the use of a specialized external tool called csdp. \n\n" ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) gl let micromega_order_changer cert env ff gl = let coeff = Lazy.force coq_Rcst in let dump_coeff = dump_Rcst in let typ = Lazy.force coq_R in let cert_typ = (Term.mkApp(Lazy.force coq_list, [|Lazy.force coq_QWitness |])) in let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[| coeff|])) in let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in let vm = dump_varmap (typ) env in Tactics.change_in_concl None (set [ ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |])); ("__varmap", vm, Term.mkApp (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|])); ("__wit", cert, cert_typ) ] (Tacmach.pf_concl gl) ) gl let micromega_genr prover gl = let parse_arith = parse_rarith in let negate = Mc.rnegate in let normalise = Mc.rnormalise in let unsat = Mc.runsat in let deduce = Mc.rdeduce in let spec = lazy { typ = Lazy.force coq_R; coeff = Lazy.force coq_Rcst; dump_coeff = dump_q; proof_typ = Lazy.force coq_QWitness ; dump_proof = dump_psatz coq_Q dump_q } in let concl = Tacmach.pf_concl gl in let hyps = Tacmach.pf_hyps_types gl in try let (hyps,concl,env) = parse_goal parse_arith Env.empty hyps concl in let env = Env.elements env in let spec = Lazy.force spec in let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl with | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl | Some (ids,ff',res') -> let (ff,ids') = formula_hyps_concl (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in (Tacticals.tclTHENSEQ [ Tactics.generalize (List.map Term.mkVar ids) ; micromega_order_changer res' env (abstract_wrt_formula ff' ff) ]) gl with (* | Failure x -> flush stdout ; Pp.pp_flush () ; Tacticals.tclFAIL 0 (Pp.str x) gl *) | ParseError -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl | CsdpNotFound -> flush stdout ; Pp.pp_flush () ; Tacticals.tclFAIL 0 (Pp.str (" Skipping what remains of this tactic: the complexity of the goal requires " ^ "the use of a specialized external tool called csdp. \n\n" ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) gl let lift_ratproof prover l = match prover l with | None -> None | Some c -> Some (Mc.RatProof( c,Mc.DoneProof)) type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list type csdp_certificate = S of Sos_types.positivstellensatz option | F of string type provername = string * int option (** * The caching mechanism. *) open Persistent_cache module Cache = PHashtable(struct type t = (provername * micromega_polys) let equal = (=) let hash = Hashtbl.hash end) let csdp_cache = "csdp.cache" (** * Build the command to call csdpcert, and launch it. This in turn will call * the sos driver to the csdp executable. * Throw CsdpNotFound if Coq isn't aware of any csdp executable. *) let require_csdp = if System.is_in_system_path "csdp" then lazy () else lazy (raise CsdpNotFound) let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivstellensatz option = fun provername poly -> Lazy.force require_csdp; let cmdname = List.fold_left Filename.concat (Envars.coqlib ()) ["plugins"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in match ((command cmdname [|cmdname|] (provername,poly)) : csdp_certificate) with | F str -> failwith str | S res -> res (** * Check the cache before calling the prover. *) let xcall_csdpcert = Cache.memo csdp_cache (fun (prover,pb) -> really_call_csdpcert prover pb) (** * Prover callback functions. *) let call_csdpcert prover pb = xcall_csdpcert (prover,pb) let rec z_to_q_pol e = match e with | Mc.Pc z -> Mc.Pc {Mc.qnum = z ; Mc.qden = Mc.XH} | Mc.Pinj(p,pol) -> Mc.Pinj(p,z_to_q_pol pol) | Mc.PX(pol1,p,pol2) -> Mc.PX(z_to_q_pol pol1, p, z_to_q_pol pol2) let call_csdpcert_q provername poly = match call_csdpcert provername poly with | None -> None | Some cert -> let cert = Certificate.q_cert_of_pos cert in if Mc.qWeakChecker poly cert then Some cert else ((print_string "buggy certificate" ; flush stdout) ;None) let call_csdpcert_z provername poly = let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in match call_csdpcert provername l with | None -> None | Some cert -> let cert = Certificate.z_cert_of_pos cert in if Mc.zWeakChecker poly cert then Some cert else ((print_string "buggy certificate" ; flush stdout) ;None) let xhyps_of_cone base acc prf = let rec xtract e acc = match e with | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> acc | Mc.PsatzIn n -> let n = (CoqToCaml.nat n) in if n >= base then ISet.add (n-base) acc else acc | Mc.PsatzMulC(_,c) -> xtract c acc | Mc.PsatzAdd(e1,e2) | Mc.PsatzMulE(e1,e2) -> xtract e1 (xtract e2 acc) in xtract prf acc let hyps_of_cone prf = xhyps_of_cone 0 ISet.empty prf let compact_cone prf f = let np n = CamlToCoq.nat (f (CoqToCaml.nat n)) in let rec xinterp prf = match prf with | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> prf | Mc.PsatzIn n -> Mc.PsatzIn (np n) | Mc.PsatzMulC(e,c) -> Mc.PsatzMulC(e,xinterp c) | Mc.PsatzAdd(e1,e2) -> Mc.PsatzAdd(xinterp e1,xinterp e2) | Mc.PsatzMulE(e1,e2) -> Mc.PsatzMulE(xinterp e1,xinterp e2) in xinterp prf let hyps_of_pt pt = let rec xhyps base pt acc = match pt with | Mc.DoneProof -> acc | Mc.RatProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) | Mc.CutProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) | Mc.EnumProof(c1,c2,l) -> let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in List.fold_left (fun s x -> xhyps (base + 1) x s) s l in xhyps 0 pt ISet.empty let hyps_of_pt pt = let res = hyps_of_pt pt in if debug then (Printf.fprintf stdout "\nhyps_of_pt : %a -> " pp_proof_term pt ; ISet.iter (fun i -> Printf.printf "%i " i) res); res let compact_pt pt f = let translate ofset x = if x < ofset then x else (f (x-ofset) + ofset) in let rec compact_pt ofset pt = match pt with | Mc.DoneProof -> Mc.DoneProof | Mc.RatProof(c,pt) -> Mc.RatProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) | Mc.CutProof(c,pt) -> Mc.CutProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) | Mc.EnumProof(c1,c2,l) -> Mc.EnumProof(compact_cone c1 (translate (ofset)), compact_cone c2 (translate (ofset)), Mc.map (fun x -> compact_pt (ofset+1) x) l) in compact_pt 0 pt (** * Definition of provers. * Instantiates the type ('a,'prf) prover defined above. *) let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l) let linear_prover_Z = { name = "linear prover" ; prover = lift_ratproof (lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec)) ; hyps = hyps_of_pt ; compact = compact_pt ; pp_prf = pp_proof_term; pp_f = fun o x -> pp_pol pp_z o (fst x) } let linear_prover_Q = { name = "linear prover"; prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ; hyps = hyps_of_cone ; compact = compact_cone ; pp_prf = pp_psatz pp_q ; pp_f = fun o x -> pp_pol pp_q o (fst x) } let linear_prover_R = { name = "linear prover"; prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ; hyps = hyps_of_cone ; compact = compact_cone ; pp_prf = pp_psatz pp_q ; pp_f = fun o x -> pp_pol pp_q o (fst x) } let non_linear_prover_Q str o = { name = "real nonlinear prover"; prover = call_csdpcert_q (str, o); hyps = hyps_of_cone; compact = compact_cone ; pp_prf = pp_psatz pp_q ; pp_f = fun o x -> pp_pol pp_q o (fst x) } let non_linear_prover_R str o = { name = "real nonlinear prover"; prover = call_csdpcert_q (str, o); hyps = hyps_of_cone; compact = compact_cone; pp_prf = pp_psatz pp_q; pp_f = fun o x -> pp_pol pp_q o (fst x) } let non_linear_prover_Z str o = { name = "real nonlinear prover"; prover = lift_ratproof (call_csdpcert_z (str, o)); hyps = hyps_of_pt; compact = compact_pt; pp_prf = pp_proof_term; pp_f = fun o x -> pp_pol pp_z o (fst x) } module CacheZ = PHashtable(struct type t = (Mc.z Mc.pol * Mc.op1) list let equal = (=) let hash = Hashtbl.hash end) let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.lia) let memo_nlia = CacheZ.memo "nlia.cache" (lift_pexpr_prover Certificate.nlia) (*let memo_zlinear_prover = (lift_pexpr_prover Lia.lia)*) (*let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.zlinear_prover)*) let linear_Z = { name = "lia"; prover = memo_zlinear_prover ; hyps = hyps_of_pt; compact = compact_pt; pp_prf = pp_proof_term; pp_f = fun o x -> pp_pol pp_z o (fst x) } let nlinear_Z = { name = "nlia"; prover = memo_nlia ; hyps = hyps_of_pt; compact = compact_pt; pp_prf = pp_proof_term; pp_f = fun o x -> pp_pol pp_z o (fst x) } let tauto_lia ff = let prover = linear_Z in let cnf_ff,_ = cnf Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce ff in match witness_list_tags [prover] cnf_ff with | None -> None | Some l -> Some (List.map fst l) (** * Functions instantiating micromega_gen with the appropriate theories and * solvers *) let psatzl_Z gl = micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec [ linear_prover_Z ] gl let psatzl_Q gl = micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec [ linear_prover_Q ] gl let psatz_Q i gl = micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] gl let psatzl_R gl = micromega_genr [ linear_prover_R ] gl let psatz_R i gl = micromega_genr [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] gl let psatz_Z i gl = micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] gl let sos_Z gl = micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec [ non_linear_prover_Z "pure_sos" None ] gl let sos_Q gl = micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec [ non_linear_prover_Q "pure_sos" None ] gl let sos_R gl = micromega_genr [ non_linear_prover_R "pure_sos" None ] gl let xlia gl = try micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec [ linear_Z ] gl with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise let xnlia gl = try micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec [ nlinear_Z ] gl with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.4pl4/plugins/micromega/RMicromega.v0000644000175000017500000003302112326224777017472 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (IZR (Qnum x) * / IZR (' Qden x))%R. Lemma Rinv_elim : forall x y z, y <> 0 -> (z * y = x <-> x * / y = z). Proof. intros. split ; intros. subst. rewrite Rmult_assoc. rewrite Rinv_r; auto. ring. subst. rewrite Rmult_assoc. rewrite (Rmult_comm (/ y)). rewrite Rinv_r ; auto. ring. Qed. Ltac INR_nat_of_P := match goal with | H : context[INR (Pos.to_nat ?X)] |- _ => revert H ; let HH := fresh in assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X)) | |- context[INR (Pos.to_nat ?X)] => let HH := fresh in assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X)) end. Ltac add_eq expr val := set (temp := expr) ; generalize (eq_refl temp) ; unfold temp at 1 ; generalize temp ; intro val ; clear temp. Ltac Rinv_elim := match goal with | |- context[?x * / ?y] => let z := fresh "v" in add_eq (x * / y) z ; let H := fresh in intro H ; rewrite <- Rinv_elim in H end. Lemma Rlt_neq : forall r , 0 < r -> r <> 0. Proof. red. intros. subst. apply (Rlt_irrefl 0 H). Qed. Lemma Rinv_1 : forall x, x * / 1 = x. Proof. intro. Rinv_elim. subst ; ring. apply R1_neq_R0. Qed. Lemma Qeq_true : forall x y, Qeq_bool x y = true -> IQR x = IQR y. Proof. unfold IQR. simpl. intros. apply Qeq_bool_eq in H. unfold Qeq in H. assert (IZR (Qnum x * ' Qden y) = IZR (Qnum y * ' Qden x))%Z. rewrite H. reflexivity. repeat rewrite mult_IZR in H0. simpl in H0. revert H0. repeat INR_nat_of_P. intros. apply Rinv_elim in H2 ; [| apply Rlt_neq ; auto]. rewrite <- H2. field. split ; apply Rlt_neq ; auto. Qed. Lemma Qeq_false : forall x y, Qeq_bool x y = false -> IQR x <> IQR y. Proof. intros. apply Qeq_bool_neq in H. intro. apply H. clear H. unfold Qeq,IQR in *. simpl in *. revert H0. repeat Rinv_elim. intros. subst. assert (IZR (Qnum x * ' Qden y)%Z = IZR (Qnum y * ' Qden x)%Z). repeat rewrite mult_IZR. simpl. rewrite <- H0. rewrite <- H. ring. apply eq_IZR ; auto. INR_nat_of_P; intros; apply Rlt_neq ; auto. INR_nat_of_P; intros ; apply Rlt_neq ; auto. Qed. Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> IQR x <= IQR y. Proof. intros. apply Qle_bool_imp_le in H. unfold Qle in H. unfold IQR. simpl in *. apply IZR_le in H. repeat rewrite mult_IZR in H. simpl in H. repeat INR_nat_of_P; intros. assert (Hr := Rlt_neq r H). assert (Hr0 := Rlt_neq r0 H0). replace (IZR (Qnum x) * / r) with ((IZR (Qnum x) * r0) * (/r * /r0)). replace (IZR (Qnum y) * / r0) with ((IZR (Qnum y) * r) * (/r * /r0)). apply Rmult_le_compat_r ; auto. apply Rmult_le_pos. unfold Rle. left. apply Rinv_0_lt_compat ; auto. unfold Rle. left. apply Rinv_0_lt_compat ; auto. field ; intuition. field ; intuition. Qed. Lemma IQR_0 : IQR 0 = 0. Proof. compute. apply Rinv_1. Qed. Lemma IQR_1 : IQR 1 = 1. Proof. compute. apply Rinv_1. Qed. Lemma IQR_plus : forall x y, IQR (x + y) = IQR x + IQR y. Proof. intros. unfold IQR. simpl in *. rewrite plus_IZR in *. rewrite mult_IZR in *. simpl. rewrite Pos2Nat.inj_mul. rewrite mult_INR. rewrite mult_IZR. simpl. repeat INR_nat_of_P. intros. field. split ; apply Rlt_neq ; auto. Qed. Lemma IQR_opp : forall x, IQR (- x) = - IQR x. Proof. intros. unfold IQR. simpl. rewrite opp_IZR. ring. Qed. Lemma IQR_minus : forall x y, IQR (x - y) = IQR x - IQR y. Proof. intros. unfold Qminus. rewrite IQR_plus. rewrite IQR_opp. ring. Qed. Lemma IQR_mult : forall x y, IQR (x * y) = IQR x * IQR y. Proof. unfold IQR ; intros. simpl. repeat rewrite mult_IZR. simpl. rewrite Pos2Nat.inj_mul. rewrite mult_INR. repeat INR_nat_of_P. intros. field ; split ; apply Rlt_neq ; auto. Qed. Lemma IQR_inv_lt : forall x, (0 < x)%Q -> IQR (/ x) = / IQR x. Proof. unfold IQR ; simpl. intros. unfold Qlt in H. revert H. simpl. intros. unfold Qinv. destruct x ; simpl in *. destruct Qnum ; simpl. exfalso. auto with zarith. clear H. repeat INR_nat_of_P. intros. assert (HH := Rlt_neq _ H). assert (HH0 := Rlt_neq _ H0). rewrite Rinv_mult_distr ; auto. rewrite Rinv_involutive ; auto. ring. apply Rinv_0_lt_compat in H0. apply Rlt_neq ; auto. simpl in H. exfalso. rewrite Pos.mul_comm in H. compute in H. discriminate. Qed. Lemma Qinv_opp : forall x, (- (/ x) = / ( -x))%Q. Proof. destruct x ; destruct Qnum ; reflexivity. Qed. Lemma Qopp_involutive_strong : forall x, (- - x = x)%Q. Proof. intros. destruct x. unfold Qopp. simpl. rewrite Z.opp_involutive. reflexivity. Qed. Lemma Ropp_0 : forall r , - r = 0 -> r = 0. Proof. intros. rewrite <- (Ropp_involutive r). apply Ropp_eq_0_compat ; auto. Qed. Lemma IQR_x_0 : forall x, IQR x = 0 -> x == 0%Q. Proof. destruct x ; simpl. unfold IQR. simpl. INR_nat_of_P. intros. apply Rmult_integral in H0. destruct H0. apply eq_IZR_R0 in H0. subst. reflexivity. exfalso. apply Rinv_0_lt_compat in H. rewrite <- H0 in H. apply Rlt_irrefl in H. auto. Qed. Lemma IQR_inv_gt : forall x, (0 > x)%Q -> IQR (/ x) = / IQR x. Proof. intros. rewrite <- (Qopp_involutive_strong x). rewrite <- Qinv_opp. rewrite IQR_opp. rewrite IQR_inv_lt. repeat rewrite IQR_opp. rewrite Ropp_inv_permute. auto. intro. apply Ropp_0 in H0. apply IQR_x_0 in H0. rewrite H0 in H. compute in H. discriminate. unfold Qlt in *. destruct x ; simpl in *. auto with zarith. Qed. Lemma IQR_inv : forall x, ~ x == 0 -> IQR (/ x) = / IQR x. Proof. intros. assert ( 0 > x \/ 0 < x)%Q. destruct x ; unfold Qlt, Qeq in * ; simpl in *. rewrite Z.mul_1_r in *. destruct Qnum ; simpl in * ; intuition auto. right. reflexivity. left ; reflexivity. destruct H0. apply IQR_inv_gt ; auto. apply IQR_inv_lt ; auto. Qed. Lemma IQR_inv_ext : forall x, IQR (/ x) = (if Qeq_bool x 0 then 0 else / IQR x). Proof. intros. case_eq (Qeq_bool x 0). intros. apply Qeq_bool_eq in H. destruct x ; simpl. unfold Qeq in H. simpl in H. replace Qnum with 0%Z. compute. rewrite Rinv_1. reflexivity. rewrite <- H. ring. intros. apply IQR_inv. intro. rewrite <- Qeq_bool_iff in H0. congruence. Qed. Notation to_nat := N.to_nat. Lemma QSORaddon : @SORaddon R R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle (* ring elements *) Q 0%Q 1%Q Qplus Qmult Qminus Qopp (* coefficients *) Qeq_bool Qle_bool IQR nat to_nat pow. Proof. constructor. constructor ; intros ; try reflexivity. apply IQR_0. apply IQR_1. apply IQR_plus. apply IQR_minus. apply IQR_mult. apply IQR_opp. apply Qeq_true ; auto. apply R_power_theory. apply Qeq_false. apply Qle_true. Qed. (* Syntactic ring coefficients. For computing, we use Q. *) Inductive Rcst := | C0 | C1 | CQ (r : Q) | CZ (r : Z) | CPlus (r1 r2 : Rcst) | CMinus (r1 r2 : Rcst) | CMult (r1 r2 : Rcst) | CInv (r : Rcst) | COpp (r : Rcst). Fixpoint Q_of_Rcst (r : Rcst) : Q := match r with | C0 => 0 # 1 | C1 => 1 # 1 | CZ z => z # 1 | CQ q => q | CPlus r1 r2 => Qplus (Q_of_Rcst r1) (Q_of_Rcst r2) | CMinus r1 r2 => Qminus (Q_of_Rcst r1) (Q_of_Rcst r2) | CMult r1 r2 => Qmult (Q_of_Rcst r1) (Q_of_Rcst r2) | CInv r => Qinv (Q_of_Rcst r) | COpp r => Qopp (Q_of_Rcst r) end. Fixpoint R_of_Rcst (r : Rcst) : R := match r with | C0 => R0 | C1 => R1 | CZ z => IZR z | CQ q => IQR q | CPlus r1 r2 => (R_of_Rcst r1) + (R_of_Rcst r2) | CMinus r1 r2 => (R_of_Rcst r1) - (R_of_Rcst r2) | CMult r1 r2 => (R_of_Rcst r1) * (R_of_Rcst r2) | CInv r => if Qeq_bool (Q_of_Rcst r) (0 # 1) then R0 else Rinv (R_of_Rcst r) | COpp r => - (R_of_Rcst r) end. Lemma Q_of_RcstR : forall c, IQR (Q_of_Rcst c) = R_of_Rcst c. Proof. induction c ; simpl ; try (rewrite <- IHc1 ; rewrite <- IHc2). apply IQR_0. apply IQR_1. reflexivity. unfold IQR. simpl. rewrite Rinv_1. reflexivity. apply IQR_plus. apply IQR_minus. apply IQR_mult. rewrite <- IHc. apply IQR_inv_ext. rewrite <- IHc. apply IQR_opp. Qed. Require Import EnvRing. Definition INZ (n:N) : R := match n with | N0 => IZR 0%Z | Npos p => IZR (Zpos p) end. Definition Reval_expr := eval_pexpr Rplus Rmult Rminus Ropp R_of_Rcst N.to_nat pow. Definition Reval_op2 (o:Op2) : R -> R -> Prop := match o with | OpEq => @eq R | OpNEq => fun x y => ~ x = y | OpLe => Rle | OpGe => Rge | OpLt => Rlt | OpGt => Rgt end. Definition Reval_formula (e: PolEnv R) (ff : Formula Rcst) := let (lhs,o,rhs) := ff in Reval_op2 o (Reval_expr e lhs) (Reval_expr e rhs). Definition Reval_formula' := eval_sformula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt N.to_nat pow R_of_Rcst. Definition QReval_formula := eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IQR N.to_nat pow . Lemma Reval_formula_compat : forall env f, Reval_formula env f <-> Reval_formula' env f. Proof. intros. unfold Reval_formula. destruct f. unfold Reval_formula'. unfold Reval_expr. split ; destruct Fop ; simpl ; auto. apply Rge_le. apply Rle_ge. Qed. Definition Qeval_nformula := eval_nformula 0 Rplus Rmult (@eq R) Rle Rlt IQR. Lemma Reval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d). Proof. exact (fun env d =>eval_nformula_dec Rsor IQR env d). Qed. Definition RWitness := Psatz Q. Definition RWeakChecker := check_normalised_formulas 0%Q 1%Q Qplus Qmult Qeq_bool Qle_bool. Require Import List. Lemma RWeakChecker_sound : forall (l : list (NFormula Q)) (cm : RWitness), RWeakChecker l cm = true -> forall env, make_impl (Qeval_nformula env) l False. Proof. intros l cm H. intro. unfold Qeval_nformula. apply (checker_nf_sound Rsor QSORaddon l cm). unfold RWeakChecker in H. exact H. Qed. Require Import Tauto. Definition Rnormalise := @cnf_normalise Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool. Definition Rnegate := @cnf_negate Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool. Definition runsat := check_inconsistent 0%Q Qeq_bool Qle_bool. Definition rdeduce := nformula_plus_nformula 0%Q Qplus Qeq_bool. Definition RTautoChecker (f : BFormula (Formula Rcst)) (w: list RWitness) : bool := @tauto_checker (Formula Q) (NFormula Q) runsat rdeduce Rnormalise Rnegate RWitness RWeakChecker (map_bformula (map_Formula Q_of_Rcst) f) w. Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_f (Reval_formula env) f. Proof. intros f w. unfold RTautoChecker. intros TC env. apply (tauto_checker_sound QReval_formula Qeval_nformula) with (env := env) in TC. rewrite eval_f_map in TC. rewrite eval_f_morph with (ev':= Reval_formula env) in TC ; auto. intro. unfold QReval_formula. rewrite <- eval_formulaSC with (phiS := R_of_Rcst). rewrite Reval_formula_compat. tauto. intro. rewrite Q_of_RcstR. reflexivity. apply Reval_nformula_dec. destruct t. apply (check_inconsistent_sound Rsor QSORaddon) ; auto. unfold rdeduce. apply (nformula_plus_nformula_correct Rsor QSORaddon). now apply (cnf_normalise_correct Rsor QSORaddon). intros. now apply (cnf_negate_correct Rsor QSORaddon). intros t w0. apply RWeakChecker_sound. Qed. (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.4pl4/plugins/micromega/QMicromega.v0000644000175000017500000001474412326224777017504 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* x) (fun x => x) (pow_N 1 Qmult). Proof. constructor. constructor ; intros ; try reflexivity. apply Qeq_bool_eq; auto. constructor. reflexivity. intros x y. apply Qeq_bool_neq ; auto. apply Qle_bool_imp_le. Qed. (*Definition Zeval_expr := eval_pexpr 0 Z.add Z.mul Z.sub Z.opp (fun x => x) (fun x => Z.of_N x) (Z.pow).*) Require Import EnvRing. Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q := match e with | PEc c => c | PEX j => env j | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) | PEopp pe1 => - (Qeval_expr env pe1) | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z.of_N n) end. Lemma Qeval_expr_simpl : forall env e, Qeval_expr env e = match e with | PEc c => c | PEX j => env j | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) | PEopp pe1 => - (Qeval_expr env pe1) | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z.of_N n) end. Proof. destruct e ; reflexivity. Qed. Definition Qeval_expr' := eval_pexpr Qplus Qmult Qminus Qopp (fun x => x) (fun x => x) (pow_N 1 Qmult). Lemma QNpower : forall r n, r ^ Z.of_N n = pow_N 1 Qmult r n. Proof. destruct n ; reflexivity. Qed. Lemma Qeval_expr_compat : forall env e, Qeval_expr env e = Qeval_expr' env e. Proof. induction e ; simpl ; subst ; try congruence. reflexivity. rewrite IHe. apply QNpower. Qed. Definition Qeval_op2 (o : Op2) : Q -> Q -> Prop := match o with | OpEq => Qeq | OpNEq => fun x y => ~ x == y | OpLe => Qle | OpGe => fun x y => Qle y x | OpLt => Qlt | OpGt => fun x y => Qlt y x end. Definition Qeval_formula (e:PolEnv Q) (ff : Formula Q) := let (lhs,o,rhs) := ff in Qeval_op2 o (Qeval_expr e lhs) (Qeval_expr e rhs). Definition Qeval_formula' := eval_formula Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult). Lemma Qeval_formula_compat : forall env f, Qeval_formula env f <-> Qeval_formula' env f. Proof. intros. unfold Qeval_formula. destruct f. repeat rewrite Qeval_expr_compat. unfold Qeval_formula'. unfold Qeval_expr'. split ; destruct Fop ; simpl; auto. Qed. Definition Qeval_nformula := eval_nformula 0 Qplus Qmult Qeq Qle Qlt (fun x => x) . Definition Qeval_op1 (o : Op1) : Q -> Prop := match o with | Equal => fun x : Q => x == 0 | NonEqual => fun x : Q => ~ x == 0 | Strict => fun x : Q => 0 < x | NonStrict => fun x : Q => 0 <= x end. Lemma Qeval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d). Proof. exact (fun env d =>eval_nformula_dec Qsor (fun x => x) env d). Qed. Definition QWitness := Psatz Q. Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult Qeq_bool Qle_bool. Require Import List. Lemma QWeakChecker_sound : forall (l : list (NFormula Q)) (cm : QWitness), QWeakChecker l cm = true -> forall env, make_impl (Qeval_nformula env) l False. Proof. intros l cm H. intro. unfold Qeval_nformula. apply (checker_nf_sound Qsor QSORaddon l cm). unfold QWeakChecker in H. exact H. Qed. Require Import Tauto. Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Definition qunsat := check_inconsistent 0 Qeq_bool Qle_bool. Definition qdeduce := nformula_plus_nformula 0 Qplus Qeq_bool. Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool := @tauto_checker (Formula Q) (NFormula Q) qunsat qdeduce Qnormalise Qnegate QWitness QWeakChecker f w. Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_f (Qeval_formula env) f. Proof. intros f w. unfold QTautoChecker. apply (tauto_checker_sound Qeval_formula Qeval_nformula). apply Qeval_nformula_dec. intros until env. unfold eval_nformula. unfold RingMicromega.eval_nformula. destruct t. apply (check_inconsistent_sound Qsor QSORaddon) ; auto. unfold qdeduce. apply (nformula_plus_nformula_correct Qsor QSORaddon). intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_normalise_correct Qsor QSORaddon). intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor QSORaddon). intros t w0. apply QWeakChecker_sound. Qed. (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.4pl4/plugins/micromega/Refl.v0000644000175000017500000000673412326224777016350 0ustar stephsteph(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ' '/\': basic properties *) Fixpoint make_impl (A : Type) (eval : A -> Prop) (l : list A) (goal : Prop) {struct l} : Prop := match l with | nil => goal | cons e l => (eval e) -> (make_impl eval l goal) end. Theorem make_impl_true : forall (A : Type) (eval : A -> Prop) (l : list A), make_impl eval l True. Proof. induction l as [| a l IH]; simpl. trivial. intro; apply IH. Qed. Fixpoint make_conj (A : Type) (eval : A -> Prop) (l : list A) {struct l} : Prop := match l with | nil => True | cons e nil => (eval e) | cons e l2 => ((eval e) /\ (make_conj eval l2)) end. Theorem make_conj_cons : forall (A : Type) (eval : A -> Prop) (a : A) (l : list A), make_conj eval (a :: l) <-> eval a /\ make_conj eval l. Proof. intros; destruct l; simpl; tauto. Qed. Lemma make_conj_impl : forall (A : Type) (eval : A -> Prop) (l : list A) (g : Prop), (make_conj eval l -> g) <-> make_impl eval l g. Proof. induction l. simpl. tauto. simpl. intros. destruct l. simpl. tauto. generalize (IHl g). tauto. Qed. Lemma make_conj_in : forall (A : Type) (eval : A -> Prop) (l : list A), make_conj eval l -> (forall p, In p l -> eval p). Proof. induction l. simpl. tauto. simpl. intros. destruct l. simpl in H0. destruct H0. subst; auto. tauto. destruct H. destruct H0. subst;auto. apply IHl; auto. Qed. Lemma make_conj_app : forall A eval l1 l2, @make_conj A eval (l1 ++ l2) <-> @make_conj A eval l1 /\ @make_conj A eval l2. Proof. induction l1. simpl. tauto. intros. change ((a::l1) ++ l2) with (a :: (l1 ++ l2)). rewrite make_conj_cons. rewrite IHl1. rewrite make_conj_cons. tauto. Qed. Lemma not_make_conj_cons : forall (A:Type) (t:A) a eval (no_middle_eval : (eval t) \/ ~ (eval t)), ~ make_conj eval (t ::a) -> ~ (eval t) \/ (~ make_conj eval a). Proof. intros. simpl in H. destruct a. tauto. tauto. Qed. Lemma not_make_conj_app : forall (A:Type) (t:list A) a eval (no_middle_eval : forall d, eval d \/ ~ eval d) , ~ make_conj eval (t ++ a) -> (~ make_conj eval t) \/ (~ make_conj eval a). Proof. induction t. simpl. tauto. intros. simpl ((a::t)++a0)in H. destruct (@not_make_conj_cons _ _ _ _ (no_middle_eval a) H). left ; red ; intros. apply H0. rewrite make_conj_cons in H1. tauto. destruct (IHt _ _ no_middle_eval H0). left ; red ; intros. apply H1. rewrite make_conj_cons in H2. tauto. right ; auto. Qed. coq-8.4pl4/plugins/micromega/micromega.ml0000644000175000017500000030245212326224777017562 0ustar stephstephtype __ = Obj.t let __ = let rec f _ = Obj.repr f in Obj.repr f (** val negb : bool -> bool **) let negb = function | true -> false | false -> true type nat = | O | S of nat (** val fst : ('a1 * 'a2) -> 'a1 **) let fst = function | x,y -> x (** val snd : ('a1 * 'a2) -> 'a2 **) let snd = function | x,y -> y (** val app : 'a1 list -> 'a1 list -> 'a1 list **) let rec app l m = match l with | [] -> m | a::l1 -> a::(app l1 m) type comparison = | Eq | Lt | Gt (** val compOpp : comparison -> comparison **) let compOpp = function | Eq -> Eq | Lt -> Gt | Gt -> Lt type compareSpecT = | CompEqT | CompLtT | CompGtT (** val compareSpec2Type : comparison -> compareSpecT **) let compareSpec2Type = function | Eq -> CompEqT | Lt -> CompLtT | Gt -> CompGtT type 'a compSpecT = compareSpecT (** val compSpec2Type : 'a1 -> 'a1 -> comparison -> 'a1 compSpecT **) let compSpec2Type x y c = compareSpec2Type c type 'a sig0 = 'a (* singleton inductive, whose constructor was exist *) (** val plus : nat -> nat -> nat **) let rec plus n0 m = match n0 with | O -> m | S p -> S (plus p m) (** val nat_iter : nat -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) let rec nat_iter n0 f x = match n0 with | O -> x | S n' -> f (nat_iter n' f x) type positive = | XI of positive | XO of positive | XH type n = | N0 | Npos of positive type z = | Z0 | Zpos of positive | Zneg of positive module type TotalOrder' = sig type t end module MakeOrderTac = functor (O:TotalOrder') -> struct end module MaxLogicalProperties = functor (O:TotalOrder') -> functor (M:sig val max : O.t -> O.t -> O.t end) -> struct module T = MakeOrderTac(O) end module Pos = struct type t = positive (** val succ : positive -> positive **) let rec succ = function | XI p -> XO (succ p) | XO p -> XI p | XH -> XO XH (** val add : positive -> positive -> positive **) let rec add x y = match x with | XI p -> (match y with | XI q0 -> XO (add_carry p q0) | XO q0 -> XI (add p q0) | XH -> XO (succ p)) | XO p -> (match y with | XI q0 -> XI (add p q0) | XO q0 -> XO (add p q0) | XH -> XI p) | XH -> (match y with | XI q0 -> XO (succ q0) | XO q0 -> XI q0 | XH -> XO XH) (** val add_carry : positive -> positive -> positive **) and add_carry x y = match x with | XI p -> (match y with | XI q0 -> XI (add_carry p q0) | XO q0 -> XO (add_carry p q0) | XH -> XI (succ p)) | XO p -> (match y with | XI q0 -> XO (add_carry p q0) | XO q0 -> XI (add p q0) | XH -> XO (succ p)) | XH -> (match y with | XI q0 -> XI (succ q0) | XO q0 -> XO (succ q0) | XH -> XI XH) (** val pred_double : positive -> positive **) let rec pred_double = function | XI p -> XI (XO p) | XO p -> XI (pred_double p) | XH -> XH (** val pred : positive -> positive **) let pred = function | XI p -> XO p | XO p -> pred_double p | XH -> XH (** val pred_N : positive -> n **) let pred_N = function | XI p -> Npos (XO p) | XO p -> Npos (pred_double p) | XH -> N0 type mask = | IsNul | IsPos of positive | IsNeg (** val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) let mask_rect f f0 f1 = function | IsNul -> f | IsPos x -> f0 x | IsNeg -> f1 (** val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) let mask_rec f f0 f1 = function | IsNul -> f | IsPos x -> f0 x | IsNeg -> f1 (** val succ_double_mask : mask -> mask **) let succ_double_mask = function | IsNul -> IsPos XH | IsPos p -> IsPos (XI p) | IsNeg -> IsNeg (** val double_mask : mask -> mask **) let double_mask = function | IsPos p -> IsPos (XO p) | x0 -> x0 (** val double_pred_mask : positive -> mask **) let double_pred_mask = function | XI p -> IsPos (XO (XO p)) | XO p -> IsPos (XO (pred_double p)) | XH -> IsNul (** val pred_mask : mask -> mask **) let pred_mask = function | IsPos q0 -> (match q0 with | XH -> IsNul | _ -> IsPos (pred q0)) | _ -> IsNeg (** val sub_mask : positive -> positive -> mask **) let rec sub_mask x y = match x with | XI p -> (match y with | XI q0 -> double_mask (sub_mask p q0) | XO q0 -> succ_double_mask (sub_mask p q0) | XH -> IsPos (XO p)) | XO p -> (match y with | XI q0 -> succ_double_mask (sub_mask_carry p q0) | XO q0 -> double_mask (sub_mask p q0) | XH -> IsPos (pred_double p)) | XH -> (match y with | XH -> IsNul | _ -> IsNeg) (** val sub_mask_carry : positive -> positive -> mask **) and sub_mask_carry x y = match x with | XI p -> (match y with | XI q0 -> succ_double_mask (sub_mask_carry p q0) | XO q0 -> double_mask (sub_mask p q0) | XH -> IsPos (pred_double p)) | XO p -> (match y with | XI q0 -> double_mask (sub_mask_carry p q0) | XO q0 -> succ_double_mask (sub_mask_carry p q0) | XH -> double_pred_mask p) | XH -> IsNeg (** val sub : positive -> positive -> positive **) let sub x y = match sub_mask x y with | IsPos z0 -> z0 | _ -> XH (** val mul : positive -> positive -> positive **) let rec mul x y = match x with | XI p -> add y (XO (mul p y)) | XO p -> XO (mul p y) | XH -> y (** val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) let rec iter n0 f x = match n0 with | XI n' -> f (iter n' f (iter n' f x)) | XO n' -> iter n' f (iter n' f x) | XH -> f x (** val pow : positive -> positive -> positive **) let pow x y = iter y (mul x) XH (** val div2 : positive -> positive **) let div2 = function | XI p2 -> p2 | XO p2 -> p2 | XH -> XH (** val div2_up : positive -> positive **) let div2_up = function | XI p2 -> succ p2 | XO p2 -> p2 | XH -> XH (** val size_nat : positive -> nat **) let rec size_nat = function | XI p2 -> S (size_nat p2) | XO p2 -> S (size_nat p2) | XH -> S O (** val size : positive -> positive **) let rec size = function | XI p2 -> succ (size p2) | XO p2 -> succ (size p2) | XH -> XH (** val compare_cont : positive -> positive -> comparison -> comparison **) let rec compare_cont x y r = match x with | XI p -> (match y with | XI q0 -> compare_cont p q0 r | XO q0 -> compare_cont p q0 Gt | XH -> Gt) | XO p -> (match y with | XI q0 -> compare_cont p q0 Lt | XO q0 -> compare_cont p q0 r | XH -> Gt) | XH -> (match y with | XH -> r | _ -> Lt) (** val compare : positive -> positive -> comparison **) let compare x y = compare_cont x y Eq (** val min : positive -> positive -> positive **) let min p p' = match compare p p' with | Gt -> p' | _ -> p (** val max : positive -> positive -> positive **) let max p p' = match compare p p' with | Gt -> p | _ -> p' (** val eqb : positive -> positive -> bool **) let rec eqb p q0 = match p with | XI p2 -> (match q0 with | XI q1 -> eqb p2 q1 | _ -> false) | XO p2 -> (match q0 with | XO q1 -> eqb p2 q1 | _ -> false) | XH -> (match q0 with | XH -> true | _ -> false) (** val leb : positive -> positive -> bool **) let leb x y = match compare x y with | Gt -> false | _ -> true (** val ltb : positive -> positive -> bool **) let ltb x y = match compare x y with | Lt -> true | _ -> false (** val sqrtrem_step : (positive -> positive) -> (positive -> positive) -> (positive * mask) -> positive * mask **) let sqrtrem_step f g = function | s,y -> (match y with | IsPos r -> let s' = XI (XO s) in let r' = g (f r) in if leb s' r' then (XI s),(sub_mask r' s') else (XO s),(IsPos r') | _ -> (XO s),(sub_mask (g (f XH)) (XO (XO XH)))) (** val sqrtrem : positive -> positive * mask **) let rec sqrtrem = function | XI p2 -> (match p2 with | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XI x) (sqrtrem p3) | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XI x) (sqrtrem p3) | XH -> XH,(IsPos (XO XH))) | XO p2 -> (match p2 with | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XO x) (sqrtrem p3) | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XO x) (sqrtrem p3) | XH -> XH,(IsPos XH)) | XH -> XH,IsNul (** val sqrt : positive -> positive **) let sqrt p = fst (sqrtrem p) (** val gcdn : nat -> positive -> positive -> positive **) let rec gcdn n0 a b = match n0 with | O -> XH | S n1 -> (match a with | XI a' -> (match b with | XI b' -> (match compare a' b' with | Eq -> a | Lt -> gcdn n1 (sub b' a') a | Gt -> gcdn n1 (sub a' b') b) | XO b0 -> gcdn n1 a b0 | XH -> XH) | XO a0 -> (match b with | XI p -> gcdn n1 a0 b | XO b0 -> XO (gcdn n1 a0 b0) | XH -> XH) | XH -> XH) (** val gcd : positive -> positive -> positive **) let gcd a b = gcdn (plus (size_nat a) (size_nat b)) a b (** val ggcdn : nat -> positive -> positive -> positive * (positive * positive) **) let rec ggcdn n0 a b = match n0 with | O -> XH,(a,b) | S n1 -> (match a with | XI a' -> (match b with | XI b' -> (match compare a' b' with | Eq -> a,(XH,XH) | Lt -> let g,p = ggcdn n1 (sub b' a') a in let ba,aa = p in g,(aa,(add aa (XO ba))) | Gt -> let g,p = ggcdn n1 (sub a' b') b in let ab,bb = p in g,((add bb (XO ab)),bb)) | XO b0 -> let g,p = ggcdn n1 a b0 in let aa,bb = p in g,(aa,(XO bb)) | XH -> XH,(a,XH)) | XO a0 -> (match b with | XI p -> let g,p2 = ggcdn n1 a0 b in let aa,bb = p2 in g,((XO aa),bb) | XO b0 -> let g,p = ggcdn n1 a0 b0 in (XO g),p | XH -> XH,(a,XH)) | XH -> XH,(XH,b)) (** val ggcd : positive -> positive -> positive * (positive * positive) **) let ggcd a b = ggcdn (plus (size_nat a) (size_nat b)) a b (** val coq_Nsucc_double : n -> n **) let coq_Nsucc_double = function | N0 -> Npos XH | Npos p -> Npos (XI p) (** val coq_Ndouble : n -> n **) let coq_Ndouble = function | N0 -> N0 | Npos p -> Npos (XO p) (** val coq_lor : positive -> positive -> positive **) let rec coq_lor p q0 = match p with | XI p2 -> (match q0 with | XI q1 -> XI (coq_lor p2 q1) | XO q1 -> XI (coq_lor p2 q1) | XH -> p) | XO p2 -> (match q0 with | XI q1 -> XI (coq_lor p2 q1) | XO q1 -> XO (coq_lor p2 q1) | XH -> XI p2) | XH -> (match q0 with | XO q1 -> XI q1 | _ -> q0) (** val coq_land : positive -> positive -> n **) let rec coq_land p q0 = match p with | XI p2 -> (match q0 with | XI q1 -> coq_Nsucc_double (coq_land p2 q1) | XO q1 -> coq_Ndouble (coq_land p2 q1) | XH -> Npos XH) | XO p2 -> (match q0 with | XI q1 -> coq_Ndouble (coq_land p2 q1) | XO q1 -> coq_Ndouble (coq_land p2 q1) | XH -> N0) | XH -> (match q0 with | XO q1 -> N0 | _ -> Npos XH) (** val ldiff : positive -> positive -> n **) let rec ldiff p q0 = match p with | XI p2 -> (match q0 with | XI q1 -> coq_Ndouble (ldiff p2 q1) | XO q1 -> coq_Nsucc_double (ldiff p2 q1) | XH -> Npos (XO p2)) | XO p2 -> (match q0 with | XI q1 -> coq_Ndouble (ldiff p2 q1) | XO q1 -> coq_Ndouble (ldiff p2 q1) | XH -> Npos p) | XH -> (match q0 with | XO q1 -> Npos XH | _ -> N0) (** val coq_lxor : positive -> positive -> n **) let rec coq_lxor p q0 = match p with | XI p2 -> (match q0 with | XI q1 -> coq_Ndouble (coq_lxor p2 q1) | XO q1 -> coq_Nsucc_double (coq_lxor p2 q1) | XH -> Npos (XO p2)) | XO p2 -> (match q0 with | XI q1 -> coq_Nsucc_double (coq_lxor p2 q1) | XO q1 -> coq_Ndouble (coq_lxor p2 q1) | XH -> Npos (XI p2)) | XH -> (match q0 with | XI q1 -> Npos (XO q1) | XO q1 -> Npos (XI q1) | XH -> N0) (** val shiftl_nat : positive -> nat -> positive **) let shiftl_nat p n0 = nat_iter n0 (fun x -> XO x) p (** val shiftr_nat : positive -> nat -> positive **) let shiftr_nat p n0 = nat_iter n0 div2 p (** val shiftl : positive -> n -> positive **) let shiftl p = function | N0 -> p | Npos n1 -> iter n1 (fun x -> XO x) p (** val shiftr : positive -> n -> positive **) let shiftr p = function | N0 -> p | Npos n1 -> iter n1 div2 p (** val testbit_nat : positive -> nat -> bool **) let rec testbit_nat p n0 = match p with | XI p2 -> (match n0 with | O -> true | S n' -> testbit_nat p2 n') | XO p2 -> (match n0 with | O -> false | S n' -> testbit_nat p2 n') | XH -> (match n0 with | O -> true | S n1 -> false) (** val testbit : positive -> n -> bool **) let rec testbit p n0 = match p with | XI p2 -> (match n0 with | N0 -> true | Npos n1 -> testbit p2 (pred_N n1)) | XO p2 -> (match n0 with | N0 -> false | Npos n1 -> testbit p2 (pred_N n1)) | XH -> (match n0 with | N0 -> true | Npos p2 -> false) (** val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 **) let rec iter_op op p a = match p with | XI p2 -> op a (iter_op op p2 (op a a)) | XO p2 -> iter_op op p2 (op a a) | XH -> a (** val to_nat : positive -> nat **) let to_nat x = iter_op plus x (S O) (** val of_nat : nat -> positive **) let rec of_nat = function | O -> XH | S x -> (match x with | O -> XH | S n1 -> succ (of_nat x)) (** val of_succ_nat : nat -> positive **) let rec of_succ_nat = function | O -> XH | S x -> succ (of_succ_nat x) end module Coq_Pos = struct module Coq__1 = struct type t = positive end type t = Coq__1.t (** val succ : positive -> positive **) let rec succ = function | XI p -> XO (succ p) | XO p -> XI p | XH -> XO XH (** val add : positive -> positive -> positive **) let rec add x y = match x with | XI p -> (match y with | XI q0 -> XO (add_carry p q0) | XO q0 -> XI (add p q0) | XH -> XO (succ p)) | XO p -> (match y with | XI q0 -> XI (add p q0) | XO q0 -> XO (add p q0) | XH -> XI p) | XH -> (match y with | XI q0 -> XO (succ q0) | XO q0 -> XI q0 | XH -> XO XH) (** val add_carry : positive -> positive -> positive **) and add_carry x y = match x with | XI p -> (match y with | XI q0 -> XI (add_carry p q0) | XO q0 -> XO (add_carry p q0) | XH -> XI (succ p)) | XO p -> (match y with | XI q0 -> XO (add_carry p q0) | XO q0 -> XI (add p q0) | XH -> XO (succ p)) | XH -> (match y with | XI q0 -> XI (succ q0) | XO q0 -> XO (succ q0) | XH -> XI XH) (** val pred_double : positive -> positive **) let rec pred_double = function | XI p -> XI (XO p) | XO p -> XI (pred_double p) | XH -> XH (** val pred : positive -> positive **) let pred = function | XI p -> XO p | XO p -> pred_double p | XH -> XH (** val pred_N : positive -> n **) let pred_N = function | XI p -> Npos (XO p) | XO p -> Npos (pred_double p) | XH -> N0 type mask = Pos.mask = | IsNul | IsPos of positive | IsNeg (** val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) let mask_rect f f0 f1 = function | IsNul -> f | IsPos x -> f0 x | IsNeg -> f1 (** val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) let mask_rec f f0 f1 = function | IsNul -> f | IsPos x -> f0 x | IsNeg -> f1 (** val succ_double_mask : mask -> mask **) let succ_double_mask = function | IsNul -> IsPos XH | IsPos p -> IsPos (XI p) | IsNeg -> IsNeg (** val double_mask : mask -> mask **) let double_mask = function | IsPos p -> IsPos (XO p) | x0 -> x0 (** val double_pred_mask : positive -> mask **) let double_pred_mask = function | XI p -> IsPos (XO (XO p)) | XO p -> IsPos (XO (pred_double p)) | XH -> IsNul (** val pred_mask : mask -> mask **) let pred_mask = function | IsPos q0 -> (match q0 with | XH -> IsNul | _ -> IsPos (pred q0)) | _ -> IsNeg (** val sub_mask : positive -> positive -> mask **) let rec sub_mask x y = match x with | XI p -> (match y with | XI q0 -> double_mask (sub_mask p q0) | XO q0 -> succ_double_mask (sub_mask p q0) | XH -> IsPos (XO p)) | XO p -> (match y with | XI q0 -> succ_double_mask (sub_mask_carry p q0) | XO q0 -> double_mask (sub_mask p q0) | XH -> IsPos (pred_double p)) | XH -> (match y with | XH -> IsNul | _ -> IsNeg) (** val sub_mask_carry : positive -> positive -> mask **) and sub_mask_carry x y = match x with | XI p -> (match y with | XI q0 -> succ_double_mask (sub_mask_carry p q0) | XO q0 -> double_mask (sub_mask p q0) | XH -> IsPos (pred_double p)) | XO p -> (match y with | XI q0 -> double_mask (sub_mask_carry p q0) | XO q0 -> succ_double_mask (sub_mask_carry p q0) | XH -> double_pred_mask p) | XH -> IsNeg (** val sub : positive -> positive -> positive **) let sub x y = match sub_mask x y with | IsPos z0 -> z0 | _ -> XH (** val mul : positive -> positive -> positive **) let rec mul x y = match x with | XI p -> add y (XO (mul p y)) | XO p -> XO (mul p y) | XH -> y (** val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) let rec iter n0 f x = match n0 with | XI n' -> f (iter n' f (iter n' f x)) | XO n' -> iter n' f (iter n' f x) | XH -> f x (** val pow : positive -> positive -> positive **) let pow x y = iter y (mul x) XH (** val div2 : positive -> positive **) let div2 = function | XI p2 -> p2 | XO p2 -> p2 | XH -> XH (** val div2_up : positive -> positive **) let div2_up = function | XI p2 -> succ p2 | XO p2 -> p2 | XH -> XH (** val size_nat : positive -> nat **) let rec size_nat = function | XI p2 -> S (size_nat p2) | XO p2 -> S (size_nat p2) | XH -> S O (** val size : positive -> positive **) let rec size = function | XI p2 -> succ (size p2) | XO p2 -> succ (size p2) | XH -> XH (** val compare_cont : positive -> positive -> comparison -> comparison **) let rec compare_cont x y r = match x with | XI p -> (match y with | XI q0 -> compare_cont p q0 r | XO q0 -> compare_cont p q0 Gt | XH -> Gt) | XO p -> (match y with | XI q0 -> compare_cont p q0 Lt | XO q0 -> compare_cont p q0 r | XH -> Gt) | XH -> (match y with | XH -> r | _ -> Lt) (** val compare : positive -> positive -> comparison **) let compare x y = compare_cont x y Eq (** val min : positive -> positive -> positive **) let min p p' = match compare p p' with | Gt -> p' | _ -> p (** val max : positive -> positive -> positive **) let max p p' = match compare p p' with | Gt -> p | _ -> p' (** val eqb : positive -> positive -> bool **) let rec eqb p q0 = match p with | XI p2 -> (match q0 with | XI q1 -> eqb p2 q1 | _ -> false) | XO p2 -> (match q0 with | XO q1 -> eqb p2 q1 | _ -> false) | XH -> (match q0 with | XH -> true | _ -> false) (** val leb : positive -> positive -> bool **) let leb x y = match compare x y with | Gt -> false | _ -> true (** val ltb : positive -> positive -> bool **) let ltb x y = match compare x y with | Lt -> true | _ -> false (** val sqrtrem_step : (positive -> positive) -> (positive -> positive) -> (positive * mask) -> positive * mask **) let sqrtrem_step f g = function | s,y -> (match y with | IsPos r -> let s' = XI (XO s) in let r' = g (f r) in if leb s' r' then (XI s),(sub_mask r' s') else (XO s),(IsPos r') | _ -> (XO s),(sub_mask (g (f XH)) (XO (XO XH)))) (** val sqrtrem : positive -> positive * mask **) let rec sqrtrem = function | XI p2 -> (match p2 with | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XI x) (sqrtrem p3) | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XI x) (sqrtrem p3) | XH -> XH,(IsPos (XO XH))) | XO p2 -> (match p2 with | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XO x) (sqrtrem p3) | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XO x) (sqrtrem p3) | XH -> XH,(IsPos XH)) | XH -> XH,IsNul (** val sqrt : positive -> positive **) let sqrt p = fst (sqrtrem p) (** val gcdn : nat -> positive -> positive -> positive **) let rec gcdn n0 a b = match n0 with | O -> XH | S n1 -> (match a with | XI a' -> (match b with | XI b' -> (match compare a' b' with | Eq -> a | Lt -> gcdn n1 (sub b' a') a | Gt -> gcdn n1 (sub a' b') b) | XO b0 -> gcdn n1 a b0 | XH -> XH) | XO a0 -> (match b with | XI p -> gcdn n1 a0 b | XO b0 -> XO (gcdn n1 a0 b0) | XH -> XH) | XH -> XH) (** val gcd : positive -> positive -> positive **) let gcd a b = gcdn (plus (size_nat a) (size_nat b)) a b (** val ggcdn : nat -> positive -> positive -> positive * (positive * positive) **) let rec ggcdn n0 a b = match n0 with | O -> XH,(a,b) | S n1 -> (match a with | XI a' -> (match b with | XI b' -> (match compare a' b' with | Eq -> a,(XH,XH) | Lt -> let g,p = ggcdn n1 (sub b' a') a in let ba,aa = p in g,(aa,(add aa (XO ba))) | Gt -> let g,p = ggcdn n1 (sub a' b') b in let ab,bb = p in g,((add bb (XO ab)),bb)) | XO b0 -> let g,p = ggcdn n1 a b0 in let aa,bb = p in g,(aa,(XO bb)) | XH -> XH,(a,XH)) | XO a0 -> (match b with | XI p -> let g,p2 = ggcdn n1 a0 b in let aa,bb = p2 in g,((XO aa),bb) | XO b0 -> let g,p = ggcdn n1 a0 b0 in (XO g),p | XH -> XH,(a,XH)) | XH -> XH,(XH,b)) (** val ggcd : positive -> positive -> positive * (positive * positive) **) let ggcd a b = ggcdn (plus (size_nat a) (size_nat b)) a b (** val coq_Nsucc_double : n -> n **) let coq_Nsucc_double = function | N0 -> Npos XH | Npos p -> Npos (XI p) (** val coq_Ndouble : n -> n **) let coq_Ndouble = function | N0 -> N0 | Npos p -> Npos (XO p) (** val coq_lor : positive -> positive -> positive **) let rec coq_lor p q0 = match p with | XI p2 -> (match q0 with | XI q1 -> XI (coq_lor p2 q1) | XO q1 -> XI (coq_lor p2 q1) | XH -> p) | XO p2 -> (match q0 with | XI q1 -> XI (coq_lor p2 q1) | XO q1 -> XO (coq_lor p2 q1) | XH -> XI p2) | XH -> (match q0 with | XO q1 -> XI q1 | _ -> q0) (** val coq_land : positive -> positive -> n **) let rec coq_land p q0 = match p with | XI p2 -> (match q0 with | XI q1 -> coq_Nsucc_double (coq_land p2 q1) | XO q1 -> coq_Ndouble (coq_land p2 q1) | XH -> Npos XH) | XO p2 -> (match q0 with | XI q1 -> coq_Ndouble (coq_land p2 q1) | XO q1 -> coq_Ndouble (coq_land p2 q1) | XH -> N0) | XH -> (match q0 with | XO q1 -> N0 | _ -> Npos XH) (** val ldiff : positive -> positive -> n **) let rec ldiff p q0 = match p with | XI p2 -> (match q0 with | XI q1 -> coq_Ndouble (ldiff p2 q1) | XO q1 -> coq_Nsucc_double (ldiff p2 q1) | XH -> Npos (XO p2)) | XO p2 -> (match q0 with | XI q1 -> coq_Ndouble (ldiff p2 q1) | XO q1 -> coq_Ndouble (ldiff p2 q1) | XH -> Npos p) | XH -> (match q0 with | XO q1 -> Npos XH | _ -> N0) (** val coq_lxor : positive -> positive -> n **) let rec coq_lxor p q0 = match p with | XI p2 -> (match q0 with | XI q1 -> coq_Ndouble (coq_lxor p2 q1) | XO q1 -> coq_Nsucc_double (coq_lxor p2 q1) | XH -> Npos (XO p2)) | XO p2 -> (match q0 with | XI q1 -> coq_Nsucc_double (coq_lxor p2 q1) | XO q1 -> coq_Ndouble (coq_lxor p2 q1) | XH -> Npos (XI p2)) | XH -> (match q0 with | XI q1 -> Npos (XO q1) | XO q1 -> Npos (XI q1) | XH -> N0) (** val shiftl_nat : positive -> nat -> positive **) let shiftl_nat p n0 = nat_iter n0 (fun x -> XO x) p (** val shiftr_nat : positive -> nat -> positive **) let shiftr_nat p n0 = nat_iter n0 div2 p (** val shiftl : positive -> n -> positive **) let shiftl p = function | N0 -> p | Npos n1 -> iter n1 (fun x -> XO x) p (** val shiftr : positive -> n -> positive **) let shiftr p = function | N0 -> p | Npos n1 -> iter n1 div2 p (** val testbit_nat : positive -> nat -> bool **) let rec testbit_nat p n0 = match p with | XI p2 -> (match n0 with | O -> true | S n' -> testbit_nat p2 n') | XO p2 -> (match n0 with | O -> false | S n' -> testbit_nat p2 n') | XH -> (match n0 with | O -> true | S n1 -> false) (** val testbit : positive -> n -> bool **) let rec testbit p n0 = match p with | XI p2 -> (match n0 with | N0 -> true | Npos n1 -> testbit p2 (pred_N n1)) | XO p2 -> (match n0 with | N0 -> false | Npos n1 -> testbit p2 (pred_N n1)) | XH -> (match n0 with | N0 -> true | Npos p2 -> false) (** val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 **) let rec iter_op op p a = match p with | XI p2 -> op a (iter_op op p2 (op a a)) | XO p2 -> iter_op op p2 (op a a) | XH -> a (** val to_nat : positive -> nat **) let to_nat x = iter_op plus x (S O) (** val of_nat : nat -> positive **) let rec of_nat = function | O -> XH | S x -> (match x with | O -> XH | S n1 -> succ (of_nat x)) (** val of_succ_nat : nat -> positive **) let rec of_succ_nat = function | O -> XH | S x -> succ (of_succ_nat x) (** val eq_dec : positive -> positive -> bool **) let rec eq_dec p y0 = match p with | XI p2 -> (match y0 with | XI p3 -> eq_dec p2 p3 | _ -> false) | XO p2 -> (match y0 with | XO p3 -> eq_dec p2 p3 | _ -> false) | XH -> (match y0 with | XH -> true | _ -> false) (** val peano_rect : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 **) let rec peano_rect a f p = let f2 = peano_rect (f XH a) (fun p2 x -> f (succ (XO p2)) (f (XO p2) x)) in (match p with | XI q0 -> f (XO q0) (f2 q0) | XO q0 -> f2 q0 | XH -> a) (** val peano_rec : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 **) let peano_rec = peano_rect type coq_PeanoView = | PeanoOne | PeanoSucc of positive * coq_PeanoView (** val coq_PeanoView_rect : 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 **) let rec coq_PeanoView_rect f f0 p = function | PeanoOne -> f | PeanoSucc (p3, p4) -> f0 p3 p4 (coq_PeanoView_rect f f0 p3 p4) (** val coq_PeanoView_rec : 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 **) let rec coq_PeanoView_rec f f0 p = function | PeanoOne -> f | PeanoSucc (p3, p4) -> f0 p3 p4 (coq_PeanoView_rec f f0 p3 p4) (** val peanoView_xO : positive -> coq_PeanoView -> coq_PeanoView **) let rec peanoView_xO p = function | PeanoOne -> PeanoSucc (XH, PeanoOne) | PeanoSucc (p2, q1) -> PeanoSucc ((succ (XO p2)), (PeanoSucc ((XO p2), (peanoView_xO p2 q1)))) (** val peanoView_xI : positive -> coq_PeanoView -> coq_PeanoView **) let rec peanoView_xI p = function | PeanoOne -> PeanoSucc ((succ XH), (PeanoSucc (XH, PeanoOne))) | PeanoSucc (p2, q1) -> PeanoSucc ((succ (XI p2)), (PeanoSucc ((XI p2), (peanoView_xI p2 q1)))) (** val peanoView : positive -> coq_PeanoView **) let rec peanoView = function | XI p2 -> peanoView_xI p2 (peanoView p2) | XO p2 -> peanoView_xO p2 (peanoView p2) | XH -> PeanoOne (** val coq_PeanoView_iter : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 **) let rec coq_PeanoView_iter a f p = function | PeanoOne -> a | PeanoSucc (p2, q1) -> f p2 (coq_PeanoView_iter a f p2 q1) (** val switch_Eq : comparison -> comparison -> comparison **) let switch_Eq c = function | Eq -> c | x -> x (** val mask2cmp : mask -> comparison **) let mask2cmp = function | IsNul -> Eq | IsPos p2 -> Gt | IsNeg -> Lt module T = struct end module ORev = struct type t = Coq__1.t end module MRev = struct (** val max : t -> t -> t **) let max x y = min y x end module MPRev = MaxLogicalProperties(ORev)(MRev) module P = struct (** val max_case_strong : t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) let max_case_strong n0 m compat hl hr = let c = compSpec2Type n0 m (compare n0 m) in (match c with | CompGtT -> compat n0 (max n0 m) __ (hl __) | _ -> compat m (max n0 m) __ (hr __)) (** val max_case : t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) let max_case n0 m x x0 x1 = max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) (** val max_dec : t -> t -> bool **) let max_dec n0 m = max_case n0 m (fun x y _ h0 -> h0) true false (** val min_case_strong : t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) let min_case_strong n0 m compat hl hr = let c = compSpec2Type n0 m (compare n0 m) in (match c with | CompGtT -> compat m (min n0 m) __ (hr __) | _ -> compat n0 (min n0 m) __ (hl __)) (** val min_case : t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) let min_case n0 m x x0 x1 = min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) (** val min_dec : t -> t -> bool **) let min_dec n0 m = min_case n0 m (fun x y _ h0 -> h0) true false end (** val max_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) let max_case_strong n0 m x x0 = P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 (** val max_case : t -> t -> 'a1 -> 'a1 -> 'a1 **) let max_case n0 m x x0 = max_case_strong n0 m (fun _ -> x) (fun _ -> x0) (** val max_dec : t -> t -> bool **) let max_dec = P.max_dec (** val min_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) let min_case_strong n0 m x x0 = P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 (** val min_case : t -> t -> 'a1 -> 'a1 -> 'a1 **) let min_case n0 m x x0 = min_case_strong n0 m (fun _ -> x) (fun _ -> x0) (** val min_dec : t -> t -> bool **) let min_dec = P.min_dec end module N = struct type t = n (** val zero : n **) let zero = N0 (** val one : n **) let one = Npos XH (** val two : n **) let two = Npos (XO XH) (** val succ_double : n -> n **) let succ_double = function | N0 -> Npos XH | Npos p -> Npos (XI p) (** val double : n -> n **) let double = function | N0 -> N0 | Npos p -> Npos (XO p) (** val succ : n -> n **) let succ = function | N0 -> Npos XH | Npos p -> Npos (Coq_Pos.succ p) (** val pred : n -> n **) let pred = function | N0 -> N0 | Npos p -> Coq_Pos.pred_N p (** val succ_pos : n -> positive **) let succ_pos = function | N0 -> XH | Npos p -> Coq_Pos.succ p (** val add : n -> n -> n **) let add n0 m = match n0 with | N0 -> m | Npos p -> (match m with | N0 -> n0 | Npos q0 -> Npos (Coq_Pos.add p q0)) (** val sub : n -> n -> n **) let sub n0 m = match n0 with | N0 -> N0 | Npos n' -> (match m with | N0 -> n0 | Npos m' -> (match Coq_Pos.sub_mask n' m' with | Coq_Pos.IsPos p -> Npos p | _ -> N0)) (** val mul : n -> n -> n **) let mul n0 m = match n0 with | N0 -> N0 | Npos p -> (match m with | N0 -> N0 | Npos q0 -> Npos (Coq_Pos.mul p q0)) (** val compare : n -> n -> comparison **) let compare n0 m = match n0 with | N0 -> (match m with | N0 -> Eq | Npos m' -> Lt) | Npos n' -> (match m with | N0 -> Gt | Npos m' -> Coq_Pos.compare n' m') (** val eqb : n -> n -> bool **) let rec eqb n0 m = match n0 with | N0 -> (match m with | N0 -> true | Npos p -> false) | Npos p -> (match m with | N0 -> false | Npos q0 -> Coq_Pos.eqb p q0) (** val leb : n -> n -> bool **) let leb x y = match compare x y with | Gt -> false | _ -> true (** val ltb : n -> n -> bool **) let ltb x y = match compare x y with | Lt -> true | _ -> false (** val min : n -> n -> n **) let min n0 n' = match compare n0 n' with | Gt -> n' | _ -> n0 (** val max : n -> n -> n **) let max n0 n' = match compare n0 n' with | Gt -> n0 | _ -> n' (** val div2 : n -> n **) let div2 = function | N0 -> N0 | Npos p2 -> (match p2 with | XI p -> Npos p | XO p -> Npos p | XH -> N0) (** val even : n -> bool **) let even = function | N0 -> true | Npos p -> (match p with | XO p2 -> true | _ -> false) (** val odd : n -> bool **) let odd n0 = negb (even n0) (** val pow : n -> n -> n **) let pow n0 = function | N0 -> Npos XH | Npos p2 -> (match n0 with | N0 -> N0 | Npos q0 -> Npos (Coq_Pos.pow q0 p2)) (** val log2 : n -> n **) let log2 = function | N0 -> N0 | Npos p2 -> (match p2 with | XI p -> Npos (Coq_Pos.size p) | XO p -> Npos (Coq_Pos.size p) | XH -> N0) (** val size : n -> n **) let size = function | N0 -> N0 | Npos p -> Npos (Coq_Pos.size p) (** val size_nat : n -> nat **) let size_nat = function | N0 -> O | Npos p -> Coq_Pos.size_nat p (** val pos_div_eucl : positive -> n -> n * n **) let rec pos_div_eucl a b = match a with | XI a' -> let q0,r = pos_div_eucl a' b in let r' = succ_double r in if leb b r' then (succ_double q0),(sub r' b) else (double q0),r' | XO a' -> let q0,r = pos_div_eucl a' b in let r' = double r in if leb b r' then (succ_double q0),(sub r' b) else (double q0),r' | XH -> (match b with | N0 -> N0,(Npos XH) | Npos p -> (match p with | XH -> (Npos XH),N0 | _ -> N0,(Npos XH))) (** val div_eucl : n -> n -> n * n **) let div_eucl a b = match a with | N0 -> N0,N0 | Npos na -> (match b with | N0 -> N0,a | Npos p -> pos_div_eucl na b) (** val div : n -> n -> n **) let div a b = fst (div_eucl a b) (** val modulo : n -> n -> n **) let modulo a b = snd (div_eucl a b) (** val gcd : n -> n -> n **) let gcd a b = match a with | N0 -> b | Npos p -> (match b with | N0 -> a | Npos q0 -> Npos (Coq_Pos.gcd p q0)) (** val ggcd : n -> n -> n * (n * n) **) let ggcd a b = match a with | N0 -> b,(N0,(Npos XH)) | Npos p -> (match b with | N0 -> a,((Npos XH),N0) | Npos q0 -> let g,p2 = Coq_Pos.ggcd p q0 in let aa,bb = p2 in (Npos g),((Npos aa),(Npos bb))) (** val sqrtrem : n -> n * n **) let sqrtrem = function | N0 -> N0,N0 | Npos p -> let s,m = Coq_Pos.sqrtrem p in (match m with | Coq_Pos.IsPos r -> (Npos s),(Npos r) | _ -> (Npos s),N0) (** val sqrt : n -> n **) let sqrt = function | N0 -> N0 | Npos p -> Npos (Coq_Pos.sqrt p) (** val coq_lor : n -> n -> n **) let coq_lor n0 m = match n0 with | N0 -> m | Npos p -> (match m with | N0 -> n0 | Npos q0 -> Npos (Coq_Pos.coq_lor p q0)) (** val coq_land : n -> n -> n **) let coq_land n0 m = match n0 with | N0 -> N0 | Npos p -> (match m with | N0 -> N0 | Npos q0 -> Coq_Pos.coq_land p q0) (** val ldiff : n -> n -> n **) let rec ldiff n0 m = match n0 with | N0 -> N0 | Npos p -> (match m with | N0 -> n0 | Npos q0 -> Coq_Pos.ldiff p q0) (** val coq_lxor : n -> n -> n **) let coq_lxor n0 m = match n0 with | N0 -> m | Npos p -> (match m with | N0 -> n0 | Npos q0 -> Coq_Pos.coq_lxor p q0) (** val shiftl_nat : n -> nat -> n **) let shiftl_nat a n0 = nat_iter n0 double a (** val shiftr_nat : n -> nat -> n **) let shiftr_nat a n0 = nat_iter n0 div2 a (** val shiftl : n -> n -> n **) let shiftl a n0 = match a with | N0 -> N0 | Npos a0 -> Npos (Coq_Pos.shiftl a0 n0) (** val shiftr : n -> n -> n **) let shiftr a = function | N0 -> a | Npos p -> Coq_Pos.iter p div2 a (** val testbit_nat : n -> nat -> bool **) let testbit_nat = function | N0 -> (fun x -> false) | Npos p -> Coq_Pos.testbit_nat p (** val testbit : n -> n -> bool **) let testbit a n0 = match a with | N0 -> false | Npos p -> Coq_Pos.testbit p n0 (** val to_nat : n -> nat **) let to_nat = function | N0 -> O | Npos p -> Coq_Pos.to_nat p (** val of_nat : nat -> n **) let of_nat = function | O -> N0 | S n' -> Npos (Coq_Pos.of_succ_nat n') (** val iter : n -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) let iter n0 f x = match n0 with | N0 -> x | Npos p -> Coq_Pos.iter p f x (** val eq_dec : n -> n -> bool **) let eq_dec n0 m = match n0 with | N0 -> (match m with | N0 -> true | Npos p -> false) | Npos x -> (match m with | N0 -> false | Npos p2 -> Coq_Pos.eq_dec x p2) (** val discr : n -> positive option **) let discr = function | N0 -> None | Npos p -> Some p (** val binary_rect : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) let binary_rect f0 f2 fS2 n0 = let f2' = fun p -> f2 (Npos p) in let fS2' = fun p -> fS2 (Npos p) in (match n0 with | N0 -> f0 | Npos p -> let rec f = function | XI p3 -> fS2' p3 (f p3) | XO p3 -> f2' p3 (f p3) | XH -> fS2 N0 f0 in f p) (** val binary_rec : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) let binary_rec = binary_rect (** val peano_rect : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) let peano_rect f0 f n0 = let f' = fun p -> f (Npos p) in (match n0 with | N0 -> f0 | Npos p -> Coq_Pos.peano_rect (f N0 f0) f' p) (** val peano_rec : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) let peano_rec = peano_rect module BootStrap = struct end (** val recursion : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) let recursion x = peano_rect x module OrderElts = struct type t = n end module OrderTac = MakeOrderTac(OrderElts) module NZPowP = struct end module NZSqrtP = struct end (** val sqrt_up : n -> n **) let sqrt_up a = match compare N0 a with | Lt -> succ (sqrt (pred a)) | _ -> N0 (** val log2_up : n -> n **) let log2_up a = match compare (Npos XH) a with | Lt -> succ (log2 (pred a)) | _ -> N0 module NZDivP = struct end (** val lcm : n -> n -> n **) let lcm a b = mul a (div b (gcd a b)) (** val b2n : bool -> n **) let b2n = function | true -> Npos XH | false -> N0 (** val setbit : n -> n -> n **) let setbit a n0 = coq_lor a (shiftl (Npos XH) n0) (** val clearbit : n -> n -> n **) let clearbit a n0 = ldiff a (shiftl (Npos XH) n0) (** val ones : n -> n **) let ones n0 = pred (shiftl (Npos XH) n0) (** val lnot : n -> n -> n **) let lnot a n0 = coq_lxor a (ones n0) module T = struct end module ORev = struct type t = n end module MRev = struct (** val max : n -> n -> n **) let max x y = min y x end module MPRev = MaxLogicalProperties(ORev)(MRev) module P = struct (** val max_case_strong : n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) let max_case_strong n0 m compat hl hr = let c = compSpec2Type n0 m (compare n0 m) in (match c with | CompGtT -> compat n0 (max n0 m) __ (hl __) | _ -> compat m (max n0 m) __ (hr __)) (** val max_case : n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) let max_case n0 m x x0 x1 = max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) (** val max_dec : n -> n -> bool **) let max_dec n0 m = max_case n0 m (fun x y _ h0 -> h0) true false (** val min_case_strong : n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) let min_case_strong n0 m compat hl hr = let c = compSpec2Type n0 m (compare n0 m) in (match c with | CompGtT -> compat m (min n0 m) __ (hr __) | _ -> compat n0 (min n0 m) __ (hl __)) (** val min_case : n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) let min_case n0 m x x0 x1 = min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) (** val min_dec : n -> n -> bool **) let min_dec n0 m = min_case n0 m (fun x y _ h0 -> h0) true false end (** val max_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) let max_case_strong n0 m x x0 = P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 (** val max_case : n -> n -> 'a1 -> 'a1 -> 'a1 **) let max_case n0 m x x0 = max_case_strong n0 m (fun _ -> x) (fun _ -> x0) (** val max_dec : n -> n -> bool **) let max_dec = P.max_dec (** val min_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) let min_case_strong n0 m x x0 = P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 (** val min_case : n -> n -> 'a1 -> 'a1 -> 'a1 **) let min_case n0 m x x0 = min_case_strong n0 m (fun _ -> x) (fun _ -> x0) (** val min_dec : n -> n -> bool **) let min_dec = P.min_dec end (** val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 **) let rec pow_pos rmul x = function | XI i0 -> let p = pow_pos rmul x i0 in rmul x (rmul p p) | XO i0 -> let p = pow_pos rmul x i0 in rmul p p | XH -> x (** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **) let rec nth n0 l default = match n0 with | O -> (match l with | [] -> default | x::l' -> x) | S m -> (match l with | [] -> default | x::t1 -> nth m t1 default) (** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) let rec map f = function | [] -> [] | a::t1 -> (f a)::(map f t1) (** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) let rec fold_right f a0 = function | [] -> a0 | b::t1 -> f b (fold_right f a0 t1) module Z = struct type t = z (** val zero : z **) let zero = Z0 (** val one : z **) let one = Zpos XH (** val two : z **) let two = Zpos (XO XH) (** val double : z -> z **) let double = function | Z0 -> Z0 | Zpos p -> Zpos (XO p) | Zneg p -> Zneg (XO p) (** val succ_double : z -> z **) let succ_double = function | Z0 -> Zpos XH | Zpos p -> Zpos (XI p) | Zneg p -> Zneg (Coq_Pos.pred_double p) (** val pred_double : z -> z **) let pred_double = function | Z0 -> Zneg XH | Zpos p -> Zpos (Coq_Pos.pred_double p) | Zneg p -> Zneg (XI p) (** val pos_sub : positive -> positive -> z **) let rec pos_sub x y = match x with | XI p -> (match y with | XI q0 -> double (pos_sub p q0) | XO q0 -> succ_double (pos_sub p q0) | XH -> Zpos (XO p)) | XO p -> (match y with | XI q0 -> pred_double (pos_sub p q0) | XO q0 -> double (pos_sub p q0) | XH -> Zpos (Coq_Pos.pred_double p)) | XH -> (match y with | XI q0 -> Zneg (XO q0) | XO q0 -> Zneg (Coq_Pos.pred_double q0) | XH -> Z0) (** val add : z -> z -> z **) let add x y = match x with | Z0 -> y | Zpos x' -> (match y with | Z0 -> x | Zpos y' -> Zpos (Coq_Pos.add x' y') | Zneg y' -> pos_sub x' y') | Zneg x' -> (match y with | Z0 -> x | Zpos y' -> pos_sub y' x' | Zneg y' -> Zneg (Coq_Pos.add x' y')) (** val opp : z -> z **) let opp = function | Z0 -> Z0 | Zpos x0 -> Zneg x0 | Zneg x0 -> Zpos x0 (** val succ : z -> z **) let succ x = add x (Zpos XH) (** val pred : z -> z **) let pred x = add x (Zneg XH) (** val sub : z -> z -> z **) let sub m n0 = add m (opp n0) (** val mul : z -> z -> z **) let mul x y = match x with | Z0 -> Z0 | Zpos x' -> (match y with | Z0 -> Z0 | Zpos y' -> Zpos (Coq_Pos.mul x' y') | Zneg y' -> Zneg (Coq_Pos.mul x' y')) | Zneg x' -> (match y with | Z0 -> Z0 | Zpos y' -> Zneg (Coq_Pos.mul x' y') | Zneg y' -> Zpos (Coq_Pos.mul x' y')) (** val pow_pos : z -> positive -> z **) let pow_pos z0 n0 = Coq_Pos.iter n0 (mul z0) (Zpos XH) (** val pow : z -> z -> z **) let pow x = function | Z0 -> Zpos XH | Zpos p -> pow_pos x p | Zneg p -> Z0 (** val compare : z -> z -> comparison **) let compare x y = match x with | Z0 -> (match y with | Z0 -> Eq | Zpos y' -> Lt | Zneg y' -> Gt) | Zpos x' -> (match y with | Zpos y' -> Coq_Pos.compare x' y' | _ -> Gt) | Zneg x' -> (match y with | Zneg y' -> compOpp (Coq_Pos.compare x' y') | _ -> Lt) (** val sgn : z -> z **) let sgn = function | Z0 -> Z0 | Zpos p -> Zpos XH | Zneg p -> Zneg XH (** val leb : z -> z -> bool **) let leb x y = match compare x y with | Gt -> false | _ -> true (** val geb : z -> z -> bool **) let geb x y = match compare x y with | Lt -> false | _ -> true (** val ltb : z -> z -> bool **) let ltb x y = match compare x y with | Lt -> true | _ -> false (** val gtb : z -> z -> bool **) let gtb x y = match compare x y with | Gt -> true | _ -> false (** val eqb : z -> z -> bool **) let rec eqb x y = match x with | Z0 -> (match y with | Z0 -> true | _ -> false) | Zpos p -> (match y with | Zpos q0 -> Coq_Pos.eqb p q0 | _ -> false) | Zneg p -> (match y with | Zneg q0 -> Coq_Pos.eqb p q0 | _ -> false) (** val max : z -> z -> z **) let max n0 m = match compare n0 m with | Lt -> m | _ -> n0 (** val min : z -> z -> z **) let min n0 m = match compare n0 m with | Gt -> m | _ -> n0 (** val abs : z -> z **) let abs = function | Zneg p -> Zpos p | x -> x (** val abs_nat : z -> nat **) let abs_nat = function | Z0 -> O | Zpos p -> Coq_Pos.to_nat p | Zneg p -> Coq_Pos.to_nat p (** val abs_N : z -> n **) let abs_N = function | Z0 -> N0 | Zpos p -> Npos p | Zneg p -> Npos p (** val to_nat : z -> nat **) let to_nat = function | Zpos p -> Coq_Pos.to_nat p | _ -> O (** val to_N : z -> n **) let to_N = function | Zpos p -> Npos p | _ -> N0 (** val of_nat : nat -> z **) let of_nat = function | O -> Z0 | S n1 -> Zpos (Coq_Pos.of_succ_nat n1) (** val of_N : n -> z **) let of_N = function | N0 -> Z0 | Npos p -> Zpos p (** val iter : z -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) let iter n0 f x = match n0 with | Zpos p -> Coq_Pos.iter p f x | _ -> x (** val pos_div_eucl : positive -> z -> z * z **) let rec pos_div_eucl a b = match a with | XI a' -> let q0,r = pos_div_eucl a' b in let r' = add (mul (Zpos (XO XH)) r) (Zpos XH) in if gtb b r' then (mul (Zpos (XO XH)) q0),r' else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b) | XO a' -> let q0,r = pos_div_eucl a' b in let r' = mul (Zpos (XO XH)) r in if gtb b r' then (mul (Zpos (XO XH)) q0),r' else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b) | XH -> if geb b (Zpos (XO XH)) then Z0,(Zpos XH) else (Zpos XH),Z0 (** val div_eucl : z -> z -> z * z **) let div_eucl a b = match a with | Z0 -> Z0,Z0 | Zpos a' -> (match b with | Z0 -> Z0,Z0 | Zpos p -> pos_div_eucl a' b | Zneg b' -> let q0,r = pos_div_eucl a' (Zpos b') in (match r with | Z0 -> (opp q0),Z0 | _ -> (opp (add q0 (Zpos XH))),(add b r))) | Zneg a' -> (match b with | Z0 -> Z0,Z0 | Zpos p -> let q0,r = pos_div_eucl a' b in (match r with | Z0 -> (opp q0),Z0 | _ -> (opp (add q0 (Zpos XH))),(sub b r)) | Zneg b' -> let q0,r = pos_div_eucl a' (Zpos b') in q0,(opp r)) (** val div : z -> z -> z **) let div a b = let q0,x = div_eucl a b in q0 (** val modulo : z -> z -> z **) let modulo a b = let x,r = div_eucl a b in r (** val quotrem : z -> z -> z * z **) let quotrem a b = match a with | Z0 -> Z0,Z0 | Zpos a0 -> (match b with | Z0 -> Z0,a | Zpos b0 -> let q0,r = N.pos_div_eucl a0 (Npos b0) in (of_N q0),(of_N r) | Zneg b0 -> let q0,r = N.pos_div_eucl a0 (Npos b0) in (opp (of_N q0)),(of_N r)) | Zneg a0 -> (match b with | Z0 -> Z0,a | Zpos b0 -> let q0,r = N.pos_div_eucl a0 (Npos b0) in (opp (of_N q0)),(opp (of_N r)) | Zneg b0 -> let q0,r = N.pos_div_eucl a0 (Npos b0) in (of_N q0),(opp (of_N r))) (** val quot : z -> z -> z **) let quot a b = fst (quotrem a b) (** val rem : z -> z -> z **) let rem a b = snd (quotrem a b) (** val even : z -> bool **) let even = function | Z0 -> true | Zpos p -> (match p with | XO p2 -> true | _ -> false) | Zneg p -> (match p with | XO p2 -> true | _ -> false) (** val odd : z -> bool **) let odd = function | Z0 -> false | Zpos p -> (match p with | XO p2 -> false | _ -> true) | Zneg p -> (match p with | XO p2 -> false | _ -> true) (** val div2 : z -> z **) let div2 = function | Z0 -> Z0 | Zpos p -> (match p with | XH -> Z0 | _ -> Zpos (Coq_Pos.div2 p)) | Zneg p -> Zneg (Coq_Pos.div2_up p) (** val quot2 : z -> z **) let quot2 = function | Z0 -> Z0 | Zpos p -> (match p with | XH -> Z0 | _ -> Zpos (Coq_Pos.div2 p)) | Zneg p -> (match p with | XH -> Z0 | _ -> Zneg (Coq_Pos.div2 p)) (** val log2 : z -> z **) let log2 = function | Zpos p2 -> (match p2 with | XI p -> Zpos (Coq_Pos.size p) | XO p -> Zpos (Coq_Pos.size p) | XH -> Z0) | _ -> Z0 (** val sqrtrem : z -> z * z **) let sqrtrem = function | Zpos p -> let s,m = Coq_Pos.sqrtrem p in (match m with | Coq_Pos.IsPos r -> (Zpos s),(Zpos r) | _ -> (Zpos s),Z0) | _ -> Z0,Z0 (** val sqrt : z -> z **) let sqrt = function | Zpos p -> Zpos (Coq_Pos.sqrt p) | _ -> Z0 (** val gcd : z -> z -> z **) let gcd a b = match a with | Z0 -> abs b | Zpos a0 -> (match b with | Z0 -> abs a | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0) | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0)) | Zneg a0 -> (match b with | Z0 -> abs a | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0) | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0)) (** val ggcd : z -> z -> z * (z * z) **) let ggcd a b = match a with | Z0 -> (abs b),(Z0,(sgn b)) | Zpos a0 -> (match b with | Z0 -> (abs a),((sgn a),Z0) | Zpos b0 -> let g,p = Coq_Pos.ggcd a0 b0 in let aa,bb = p in (Zpos g),((Zpos aa),(Zpos bb)) | Zneg b0 -> let g,p = Coq_Pos.ggcd a0 b0 in let aa,bb = p in (Zpos g),((Zpos aa),(Zneg bb))) | Zneg a0 -> (match b with | Z0 -> (abs a),((sgn a),Z0) | Zpos b0 -> let g,p = Coq_Pos.ggcd a0 b0 in let aa,bb = p in (Zpos g),((Zneg aa),(Zpos bb)) | Zneg b0 -> let g,p = Coq_Pos.ggcd a0 b0 in let aa,bb = p in (Zpos g),((Zneg aa),(Zneg bb))) (** val testbit : z -> z -> bool **) let testbit a = function | Z0 -> odd a | Zpos p -> (match a with | Z0 -> false | Zpos a0 -> Coq_Pos.testbit a0 (Npos p) | Zneg a0 -> negb (N.testbit (Coq_Pos.pred_N a0) (Npos p))) | Zneg p -> false (** val shiftl : z -> z -> z **) let shiftl a = function | Z0 -> a | Zpos p -> Coq_Pos.iter p (mul (Zpos (XO XH))) a | Zneg p -> Coq_Pos.iter p div2 a (** val shiftr : z -> z -> z **) let shiftr a n0 = shiftl a (opp n0) (** val coq_lor : z -> z -> z **) let coq_lor a b = match a with | Z0 -> b | Zpos a0 -> (match b with | Z0 -> a | Zpos b0 -> Zpos (Coq_Pos.coq_lor a0 b0) | Zneg b0 -> Zneg (N.succ_pos (N.ldiff (Coq_Pos.pred_N b0) (Npos a0)))) | Zneg a0 -> (match b with | Z0 -> a | Zpos b0 -> Zneg (N.succ_pos (N.ldiff (Coq_Pos.pred_N a0) (Npos b0))) | Zneg b0 -> Zneg (N.succ_pos (N.coq_land (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0)))) (** val coq_land : z -> z -> z **) let coq_land a b = match a with | Z0 -> Z0 | Zpos a0 -> (match b with | Z0 -> Z0 | Zpos b0 -> of_N (Coq_Pos.coq_land a0 b0) | Zneg b0 -> of_N (N.ldiff (Npos a0) (Coq_Pos.pred_N b0))) | Zneg a0 -> (match b with | Z0 -> Z0 | Zpos b0 -> of_N (N.ldiff (Npos b0) (Coq_Pos.pred_N a0)) | Zneg b0 -> Zneg (N.succ_pos (N.coq_lor (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0)))) (** val ldiff : z -> z -> z **) let ldiff a b = match a with | Z0 -> Z0 | Zpos a0 -> (match b with | Z0 -> a | Zpos b0 -> of_N (Coq_Pos.ldiff a0 b0) | Zneg b0 -> of_N (N.coq_land (Npos a0) (Coq_Pos.pred_N b0))) | Zneg a0 -> (match b with | Z0 -> a | Zpos b0 -> Zneg (N.succ_pos (N.coq_lor (Coq_Pos.pred_N a0) (Npos b0))) | Zneg b0 -> of_N (N.ldiff (Coq_Pos.pred_N b0) (Coq_Pos.pred_N a0))) (** val coq_lxor : z -> z -> z **) let coq_lxor a b = match a with | Z0 -> b | Zpos a0 -> (match b with | Z0 -> a | Zpos b0 -> of_N (Coq_Pos.coq_lxor a0 b0) | Zneg b0 -> Zneg (N.succ_pos (N.coq_lxor (Npos a0) (Coq_Pos.pred_N b0)))) | Zneg a0 -> (match b with | Z0 -> a | Zpos b0 -> Zneg (N.succ_pos (N.coq_lxor (Coq_Pos.pred_N a0) (Npos b0))) | Zneg b0 -> of_N (N.coq_lxor (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0))) (** val eq_dec : z -> z -> bool **) let eq_dec x y = match x with | Z0 -> (match y with | Z0 -> true | _ -> false) | Zpos x0 -> (match y with | Zpos p2 -> Coq_Pos.eq_dec x0 p2 | _ -> false) | Zneg x0 -> (match y with | Zneg p2 -> Coq_Pos.eq_dec x0 p2 | _ -> false) module BootStrap = struct end module OrderElts = struct type t = z end module OrderTac = MakeOrderTac(OrderElts) (** val sqrt_up : z -> z **) let sqrt_up a = match compare Z0 a with | Lt -> succ (sqrt (pred a)) | _ -> Z0 (** val log2_up : z -> z **) let log2_up a = match compare (Zpos XH) a with | Lt -> succ (log2 (pred a)) | _ -> Z0 module NZDivP = struct end module Quot2Div = struct (** val div : z -> z -> z **) let div = quot (** val modulo : z -> z -> z **) let modulo = rem end module NZQuot = struct end (** val lcm : z -> z -> z **) let lcm a b = abs (mul a (div b (gcd a b))) (** val b2z : bool -> z **) let b2z = function | true -> Zpos XH | false -> Z0 (** val setbit : z -> z -> z **) let setbit a n0 = coq_lor a (shiftl (Zpos XH) n0) (** val clearbit : z -> z -> z **) let clearbit a n0 = ldiff a (shiftl (Zpos XH) n0) (** val lnot : z -> z **) let lnot a = pred (opp a) (** val ones : z -> z **) let ones n0 = pred (shiftl (Zpos XH) n0) module T = struct end module ORev = struct type t = z end module MRev = struct (** val max : z -> z -> z **) let max x y = min y x end module MPRev = MaxLogicalProperties(ORev)(MRev) module P = struct (** val max_case_strong : z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) let max_case_strong n0 m compat hl hr = let c = compSpec2Type n0 m (compare n0 m) in (match c with | CompGtT -> compat n0 (max n0 m) __ (hl __) | _ -> compat m (max n0 m) __ (hr __)) (** val max_case : z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) let max_case n0 m x x0 x1 = max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) (** val max_dec : z -> z -> bool **) let max_dec n0 m = max_case n0 m (fun x y _ h0 -> h0) true false (** val min_case_strong : z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) let min_case_strong n0 m compat hl hr = let c = compSpec2Type n0 m (compare n0 m) in (match c with | CompGtT -> compat m (min n0 m) __ (hr __) | _ -> compat n0 (min n0 m) __ (hl __)) (** val min_case : z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) let min_case n0 m x x0 x1 = min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) (** val min_dec : z -> z -> bool **) let min_dec n0 m = min_case n0 m (fun x y _ h0 -> h0) true false end (** val max_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) let max_case_strong n0 m x x0 = P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 (** val max_case : z -> z -> 'a1 -> 'a1 -> 'a1 **) let max_case n0 m x x0 = max_case_strong n0 m (fun _ -> x) (fun _ -> x0) (** val max_dec : z -> z -> bool **) let max_dec = P.max_dec (** val min_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) let min_case_strong n0 m x x0 = P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 (** val min_case : z -> z -> 'a1 -> 'a1 -> 'a1 **) let min_case n0 m x x0 = min_case_strong n0 m (fun _ -> x) (fun _ -> x0) (** val min_dec : z -> z -> bool **) let min_dec = P.min_dec end (** val zeq_bool : z -> z -> bool **) let zeq_bool x y = match Z.compare x y with | Eq -> true | _ -> false type 'c pol = | Pc of 'c | Pinj of positive * 'c pol | PX of 'c pol * positive * 'c pol (** val p0 : 'a1 -> 'a1 pol **) let p0 cO = Pc cO (** val p1 : 'a1 -> 'a1 pol **) let p1 cI = Pc cI (** val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool **) let rec peq ceqb p p' = match p with | Pc c -> (match p' with | Pc c' -> ceqb c c' | _ -> false) | Pinj (j, q0) -> (match p' with | Pinj (j', q') -> (match Coq_Pos.compare j j' with | Eq -> peq ceqb q0 q' | _ -> false) | _ -> false) | PX (p2, i, q0) -> (match p' with | PX (p'0, i', q') -> (match Coq_Pos.compare i i' with | Eq -> if peq ceqb p2 p'0 then peq ceqb q0 q' else false | _ -> false) | _ -> false) (** val mkPinj : positive -> 'a1 pol -> 'a1 pol **) let mkPinj j p = match p with | Pc c -> p | Pinj (j', q0) -> Pinj ((Coq_Pos.add j j'), q0) | PX (p2, p3, p4) -> Pinj (j, p) (** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **) let mkPinj_pred j p = match j with | XI j0 -> Pinj ((XO j0), p) | XO j0 -> Pinj ((Coq_Pos.pred_double j0), p) | XH -> p (** val mkPX : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let mkPX cO ceqb p i q0 = match p with | Pc c -> if ceqb c cO then mkPinj XH q0 else PX (p, i, q0) | Pinj (p2, p3) -> PX (p, i, q0) | PX (p', i', q') -> if peq ceqb q' (p0 cO) then PX (p', (Coq_Pos.add i' i), q0) else PX (p, i, q0) (** val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol **) let mkXi cO cI i = PX ((p1 cI), i, (p0 cO)) (** val mkX : 'a1 -> 'a1 -> 'a1 pol **) let mkX cO cI = mkXi cO cI XH (** val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **) let rec popp copp = function | Pc c -> Pc (copp c) | Pinj (j, q0) -> Pinj (j, (popp copp q0)) | PX (p2, i, q0) -> PX ((popp copp p2), i, (popp copp q0)) (** val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) let rec paddC cadd p c = match p with | Pc c1 -> Pc (cadd c1 c) | Pinj (j, q0) -> Pinj (j, (paddC cadd q0 c)) | PX (p2, i, q0) -> PX (p2, i, (paddC cadd q0 c)) (** val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) let rec psubC csub p c = match p with | Pc c1 -> Pc (csub c1 c) | Pinj (j, q0) -> Pinj (j, (psubC csub q0 c)) | PX (p2, i, q0) -> PX (p2, i, (psubC csub q0 c)) (** val paddI : ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let rec paddI cadd pop q0 j = function | Pc c -> mkPinj j (paddC cadd q0 c) | Pinj (j', q') -> (match Z.pos_sub j' j with | Z0 -> mkPinj j (pop q' q0) | Zpos k -> mkPinj j (pop (Pinj (k, q')) q0) | Zneg k -> mkPinj j' (paddI cadd pop q0 k q')) | PX (p2, i, q') -> (match j with | XI j0 -> PX (p2, i, (paddI cadd pop q0 (XO j0) q')) | XO j0 -> PX (p2, i, (paddI cadd pop q0 (Coq_Pos.pred_double j0) q')) | XH -> PX (p2, i, (pop q' q0))) (** val psubI : ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let rec psubI cadd copp pop q0 j = function | Pc c -> mkPinj j (paddC cadd (popp copp q0) c) | Pinj (j', q') -> (match Z.pos_sub j' j with | Z0 -> mkPinj j (pop q' q0) | Zpos k -> mkPinj j (pop (Pinj (k, q')) q0) | Zneg k -> mkPinj j' (psubI cadd copp pop q0 k q')) | PX (p2, i, q') -> (match j with | XI j0 -> PX (p2, i, (psubI cadd copp pop q0 (XO j0) q')) | XO j0 -> PX (p2, i, (psubI cadd copp pop q0 (Coq_Pos.pred_double j0) q')) | XH -> PX (p2, i, (pop q' q0))) (** val paddX : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let rec paddX cO ceqb pop p' i' p = match p with | Pc c -> PX (p', i', p) | Pinj (j, q') -> (match j with | XI j0 -> PX (p', i', (Pinj ((XO j0), q'))) | XO j0 -> PX (p', i', (Pinj ((Coq_Pos.pred_double j0), q'))) | XH -> PX (p', i', q')) | PX (p2, i, q') -> (match Z.pos_sub i i' with | Z0 -> mkPX cO ceqb (pop p2 p') i q' | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q') (** val psubX : 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let rec psubX cO copp ceqb pop p' i' p = match p with | Pc c -> PX ((popp copp p'), i', p) | Pinj (j, q') -> (match j with | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q'))) | XO j0 -> PX ((popp copp p'), i', (Pinj ((Coq_Pos.pred_double j0), q'))) | XH -> PX ((popp copp p'), i', q')) | PX (p2, i, q') -> (match Z.pos_sub i i' with | Z0 -> mkPX cO ceqb (pop p2 p') i q' | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q') (** val padd : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) let rec padd cO cadd ceqb p = function | Pc c' -> paddC cadd p c' | Pinj (j', q') -> paddI cadd (padd cO cadd ceqb) q' j' p | PX (p'0, i', q') -> (match p with | Pc c -> PX (p'0, i', (paddC cadd q' c)) | Pinj (j, q0) -> (match j with | XI j0 -> PX (p'0, i', (padd cO cadd ceqb (Pinj ((XO j0), q0)) q')) | XO j0 -> PX (p'0, i', (padd cO cadd ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q')) | XH -> PX (p'0, i', (padd cO cadd ceqb q0 q'))) | PX (p2, i, q0) -> (match Z.pos_sub i i' with | Z0 -> mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i (padd cO cadd ceqb q0 q') | Zpos k -> mkPX cO ceqb (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i' (padd cO cadd ceqb q0 q') | Zneg k -> mkPX cO ceqb (paddX cO ceqb (padd cO cadd ceqb) p'0 k p2) i (padd cO cadd ceqb q0 q'))) (** val psub : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) let rec psub cO cadd csub copp ceqb p = function | Pc c' -> psubC csub p c' | Pinj (j', q') -> psubI cadd copp (psub cO cadd csub copp ceqb) q' j' p | PX (p'0, i', q') -> (match p with | Pc c -> PX ((popp copp p'0), i', (paddC cadd (popp copp q') c)) | Pinj (j, q0) -> (match j with | XI j0 -> PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q')) | XO j0 -> PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q')) | XH -> PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q0 q'))) | PX (p2, i, q0) -> (match Z.pos_sub i i' with | Z0 -> mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i (psub cO cadd csub copp ceqb q0 q') | Zpos k -> mkPX cO ceqb (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0) i' (psub cO cadd csub copp ceqb q0 q') | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb (psub cO cadd csub copp ceqb) p'0 k p2) i (psub cO cadd csub copp ceqb q0 q'))) (** val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol **) let rec pmulC_aux cO cmul ceqb p c = match p with | Pc c' -> Pc (cmul c' c) | Pinj (j, q0) -> mkPinj j (pmulC_aux cO cmul ceqb q0 c) | PX (p2, i, q0) -> mkPX cO ceqb (pmulC_aux cO cmul ceqb p2 c) i (pmulC_aux cO cmul ceqb q0 c) (** val pmulC : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol **) let pmulC cO cI cmul ceqb p c = if ceqb c cO then p0 cO else if ceqb c cI then p else pmulC_aux cO cmul ceqb p c (** val pmulI : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let rec pmulI cO cI cmul ceqb pmul0 q0 j = function | Pc c -> mkPinj j (pmulC cO cI cmul ceqb q0 c) | Pinj (j', q') -> (match Z.pos_sub j' j with | Z0 -> mkPinj j (pmul0 q' q0) | Zpos k -> mkPinj j (pmul0 (Pinj (k, q')) q0) | Zneg k -> mkPinj j' (pmulI cO cI cmul ceqb pmul0 q0 k q')) | PX (p', i', q') -> (match j with | XI j' -> mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' (pmulI cO cI cmul ceqb pmul0 q0 (XO j') q') | XO j' -> mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' (pmulI cO cI cmul ceqb pmul0 q0 (Coq_Pos.pred_double j') q') | XH -> mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i' (pmul0 q' q0)) (** val pmul : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with | Pc c -> pmulC cO cI cmul ceqb p c | Pinj (j', q') -> pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' j' p | PX (p', i', q') -> (match p with | Pc c -> pmulC cO cI cmul ceqb p'' c | Pinj (j, q0) -> let qQ' = match j with | XI j0 -> pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q' | XO j0 -> pmul cO cI cadd cmul ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q' | XH -> pmul cO cI cadd cmul ceqb q0 q' in mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i' qQ' | PX (p2, i, q0) -> let qQ' = pmul cO cI cadd cmul ceqb q0 q' in let pQ' = pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' XH p2 in let qP' = pmul cO cI cadd cmul ceqb (mkPinj XH q0) p' in let pP' = pmul cO cI cadd cmul ceqb p2 p' in padd cO cadd ceqb (mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb pP' i (p0 cO)) qP') i' (p0 cO)) (mkPX cO ceqb pQ' i qQ')) (** val psquare : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol **) let rec psquare cO cI cadd cmul ceqb = function | Pc c -> Pc (cmul c c) | Pinj (j, q0) -> Pinj (j, (psquare cO cI cadd cmul ceqb q0)) | PX (p2, i, q0) -> let twoPQ = pmul cO cI cadd cmul ceqb p2 (mkPinj XH (pmulC cO cI cmul ceqb q0 (cadd cI cI))) in let q2 = psquare cO cI cadd cmul ceqb q0 in let p3 = psquare cO cI cadd cmul ceqb p2 in mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb p3 i (p0 cO)) twoPQ) i q2 type 'c pExpr = | PEc of 'c | PEX of positive | PEadd of 'c pExpr * 'c pExpr | PEsub of 'c pExpr * 'c pExpr | PEmul of 'c pExpr * 'c pExpr | PEopp of 'c pExpr | PEpow of 'c pExpr * n (** val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol **) let mk_X cO cI j = mkPinj_pred j (mkX cO cI) (** val ppow_pos : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol **) let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function | XI p3 -> subst_l (pmul cO cI cadd cmul ceqb (ppow_pos cO cI cadd cmul ceqb subst_l (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3) p) | XO p3 -> ppow_pos cO cI cadd cmul ceqb subst_l (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3 | XH -> subst_l (pmul cO cI cadd cmul ceqb res p) (** val ppow_N : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol **) let ppow_N cO cI cadd cmul ceqb subst_l p = function | N0 -> p1 cI | Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2 (** val norm_aux : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) let rec norm_aux cO cI cadd cmul csub copp ceqb = function | PEc c -> Pc c | PEX j -> mk_X cO cI j | PEadd (pe1, pe2) -> (match pe1 with | PEopp pe3 -> psub cO cadd csub copp ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe2) (norm_aux cO cI cadd cmul csub copp ceqb pe3) | _ -> (match pe2 with | PEopp pe3 -> psub cO cadd csub copp ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) (norm_aux cO cI cadd cmul csub copp ceqb pe3) | _ -> padd cO cadd ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) (norm_aux cO cI cadd cmul csub copp ceqb pe2))) | PEsub (pe1, pe2) -> psub cO cadd csub copp ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) (norm_aux cO cI cadd cmul csub copp ceqb pe2) | PEmul (pe1, pe2) -> pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) (norm_aux cO cI cadd cmul csub copp ceqb pe2) | PEopp pe1 -> popp copp (norm_aux cO cI cadd cmul csub copp ceqb pe1) | PEpow (pe1, n0) -> ppow_N cO cI cadd cmul ceqb (fun p -> p) (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0 type 'a bFormula = | TT | FF | X | A of 'a | Cj of 'a bFormula * 'a bFormula | D of 'a bFormula * 'a bFormula | N of 'a bFormula | I of 'a bFormula * 'a bFormula (** val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula **) let rec map_bformula fct = function | TT -> TT | FF -> FF | X -> X | A a -> A (fct a) | Cj (f1, f2) -> Cj ((map_bformula fct f1), (map_bformula fct f2)) | D (f1, f2) -> D ((map_bformula fct f1), (map_bformula fct f2)) | N f0 -> N (map_bformula fct f0) | I (f1, f2) -> I ((map_bformula fct f1), (map_bformula fct f2)) type 'term' clause = 'term' list type 'term' cnf = 'term' clause list (** val tt : 'a1 cnf **) let tt = [] (** val ff : 'a1 cnf **) let ff = []::[] (** val add_term : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 clause option **) let rec add_term unsat deduce t1 = function | [] -> (match deduce t1 t1 with | Some u -> if unsat u then None else Some (t1::[]) | None -> Some (t1::[])) | t'::cl0 -> (match deduce t1 t' with | Some u -> if unsat u then None else (match add_term unsat deduce t1 cl0 with | Some cl' -> Some (t'::cl') | None -> None) | None -> (match add_term unsat deduce t1 cl0 with | Some cl' -> Some (t'::cl') | None -> None)) (** val or_clause : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause -> 'a1 clause option **) let rec or_clause unsat deduce cl1 cl2 = match cl1 with | [] -> Some cl2 | t1::cl -> (match add_term unsat deduce t1 cl2 with | Some cl' -> or_clause unsat deduce cl cl' | None -> None) (** val or_clause_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1 cnf **) let or_clause_cnf unsat deduce t1 f = fold_right (fun e acc -> match or_clause unsat deduce t1 e with | Some cl -> cl::acc | None -> acc) [] f (** val or_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) let rec or_cnf unsat deduce f f' = match f with | [] -> tt | e::rst -> app (or_cnf unsat deduce rst f') (or_clause_cnf unsat deduce e f') (** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) let and_cnf f1 f2 = app f1 f2 (** val xcnf : ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **) let rec xcnf unsat deduce normalise0 negate0 pol0 = function | TT -> if pol0 then tt else ff | FF -> if pol0 then ff else tt | X -> ff | A x -> if pol0 then normalise0 x else negate0 x | Cj (e1, e2) -> if pol0 then and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) else or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 pol0 e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) | D (e1, e2) -> if pol0 then or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 pol0 e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) else and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) | N e -> xcnf unsat deduce normalise0 negate0 (negb pol0) e | I (e1, e2) -> if pol0 then or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) else and_cnf (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) (** val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool **) let rec cnf_checker checker f l = match f with | [] -> true | e::f0 -> (match l with | [] -> false | c::l0 -> if checker e c then cnf_checker checker f0 l0 else false) (** val tauto_checker : ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> bool **) let tauto_checker unsat deduce normalise0 negate0 checker f w = cnf_checker checker (xcnf unsat deduce normalise0 negate0 true f) w (** val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) let cneqb ceqb x y = negb (ceqb x y) (** val cltb : ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) let cltb ceqb cleb x y = (&&) (cleb x y) (cneqb ceqb x y) type 'c polC = 'c pol type op1 = | Equal | NonEqual | Strict | NonStrict type 'c nFormula = 'c polC * op1 (** val opMult : op1 -> op1 -> op1 option **) let opMult o o' = match o with | Equal -> Some Equal | NonEqual -> (match o' with | Strict -> None | NonStrict -> None | x -> Some x) | Strict -> (match o' with | NonEqual -> None | _ -> Some o') | NonStrict -> (match o' with | NonEqual -> None | Strict -> Some NonStrict | x -> Some x) (** val opAdd : op1 -> op1 -> op1 option **) let opAdd o o' = match o with | Equal -> Some o' | NonEqual -> (match o' with | Equal -> Some NonEqual | _ -> None) | Strict -> (match o' with | NonEqual -> None | _ -> Some Strict) | NonStrict -> (match o' with | Equal -> Some NonStrict | NonEqual -> None | x -> Some x) type 'c psatz = | PsatzIn of nat | PsatzSquare of 'c polC | PsatzMulC of 'c polC * 'c psatz | PsatzMulE of 'c psatz * 'c psatz | PsatzAdd of 'c psatz * 'c psatz | PsatzC of 'c | PsatzZ (** val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option **) let map_option f = function | Some x -> f x | None -> None (** val map_option2 : ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option **) let map_option2 f o o' = match o with | Some x -> (match o' with | Some x' -> f x x' | None -> None) | None -> None (** val pexpr_times_nformula : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **) let pexpr_times_nformula cO cI cplus ctimes ceqb e = function | ef,o -> (match o with | Equal -> Some ((pmul cO cI cplus ctimes ceqb e ef),Equal) | _ -> None) (** val nformula_times_nformula : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **) let nformula_times_nformula cO cI cplus ctimes ceqb f1 f2 = let e1,o1 = f1 in let e2,o2 = f2 in map_option (fun x -> Some ((pmul cO cI cplus ctimes ceqb e1 e2),x)) (opMult o1 o2) (** val nformula_plus_nformula : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **) let nformula_plus_nformula cO cplus ceqb f1 f2 = let e1,o1 = f1 in let e2,o2 = f2 in map_option (fun x -> Some ((padd cO cplus ceqb e1 e2),x)) (opAdd o1 o2) (** val eval_Psatz : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option **) let rec eval_Psatz cO cI cplus ctimes ceqb cleb l = function | PsatzIn n0 -> Some (nth n0 l ((Pc cO),Equal)) | PsatzSquare e0 -> Some ((psquare cO cI cplus ctimes ceqb e0),NonStrict) | PsatzMulC (re, e0) -> map_option (pexpr_times_nformula cO cI cplus ctimes ceqb re) (eval_Psatz cO cI cplus ctimes ceqb cleb l e0) | PsatzMulE (f1, f2) -> map_option2 (nformula_times_nformula cO cI cplus ctimes ceqb) (eval_Psatz cO cI cplus ctimes ceqb cleb l f1) (eval_Psatz cO cI cplus ctimes ceqb cleb l f2) | PsatzAdd (f1, f2) -> map_option2 (nformula_plus_nformula cO cplus ceqb) (eval_Psatz cO cI cplus ctimes ceqb cleb l f1) (eval_Psatz cO cI cplus ctimes ceqb cleb l f2) | PsatzC c -> if cltb ceqb cleb cO c then Some ((Pc c),Strict) else None | PsatzZ -> Some ((Pc cO),Equal) (** val check_inconsistent : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool **) let check_inconsistent cO ceqb cleb = function | e,op -> (match e with | Pc c -> (match op with | Equal -> cneqb ceqb c cO | NonEqual -> ceqb c cO | Strict -> cleb c cO | NonStrict -> cltb ceqb cleb c cO) | _ -> false) (** val check_normalised_formulas : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool **) let check_normalised_formulas cO cI cplus ctimes ceqb cleb l cm = match eval_Psatz cO cI cplus ctimes ceqb cleb l cm with | Some f -> check_inconsistent cO ceqb cleb f | None -> false type op2 = | OpEq | OpNEq | OpLe | OpGe | OpLt | OpGt type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } (** val flhs : 'a1 formula -> 'a1 pExpr **) let flhs x = x.flhs (** val fop : 'a1 formula -> op2 **) let fop x = x.fop (** val frhs : 'a1 formula -> 'a1 pExpr **) let frhs x = x.frhs (** val norm : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) let norm cO cI cplus ctimes cminus copp ceqb = norm_aux cO cI cplus ctimes cminus copp ceqb (** val psub0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) let psub0 cO cplus cminus copp ceqb = psub cO cplus cminus copp ceqb (** val padd0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) let padd0 cO cplus ceqb = padd cO cplus ceqb (** val xnormalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list **) let xnormalise cO cI cplus ctimes cminus copp ceqb t1 = let { flhs = lhs; fop = o; frhs = rhs } = t1 in let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in (match o with | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict)::[]) | OpNEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal)::[] | OpLe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::[] | OpGe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict)::[] | OpLt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonStrict)::[] | OpGt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict)::[]) (** val cnf_normalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula cnf **) let cnf_normalise cO cI cplus ctimes cminus copp ceqb t1 = map (fun x -> x::[]) (xnormalise cO cI cplus ctimes cminus copp ceqb t1) (** val xnegate : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list **) let xnegate cO cI cplus ctimes cminus copp ceqb t1 = let { flhs = lhs; fop = o; frhs = rhs } = t1 in let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in (match o with | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal)::[] | OpNEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict)::[]) | OpLe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict)::[] | OpGe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonStrict)::[] | OpLt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict)::[] | OpGt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::[]) (** val cnf_negate : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula cnf **) let cnf_negate cO cI cplus ctimes cminus copp ceqb t1 = map (fun x -> x::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t1) (** val xdenorm : positive -> 'a1 pol -> 'a1 pExpr **) let rec xdenorm jmp = function | Pc c -> PEc c | Pinj (j, p2) -> xdenorm (Coq_Pos.add j jmp) p2 | PX (p2, j, q0) -> PEadd ((PEmul ((xdenorm jmp p2), (PEpow ((PEX jmp), (Npos j))))), (xdenorm (Coq_Pos.succ jmp) q0)) (** val denorm : 'a1 pol -> 'a1 pExpr **) let denorm p = xdenorm XH p (** val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr **) let rec map_PExpr c_of_S = function | PEc c -> PEc (c_of_S c) | PEX p -> PEX p | PEadd (e1, e2) -> PEadd ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) | PEsub (e1, e2) -> PEsub ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) | PEmul (e1, e2) -> PEmul ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) | PEopp e0 -> PEopp (map_PExpr c_of_S e0) | PEpow (e0, n0) -> PEpow ((map_PExpr c_of_S e0), n0) (** val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula **) let map_Formula c_of_S f = let { flhs = l; fop = o; frhs = r } = f in { flhs = (map_PExpr c_of_S l); fop = o; frhs = (map_PExpr c_of_S r) } (** val simpl_cone : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> 'a1 psatz **) let simpl_cone cO cI ctimes ceqb e = match e with | PsatzSquare t1 -> (match t1 with | Pc c -> if ceqb cO c then PsatzZ else PsatzC (ctimes c c) | _ -> PsatzSquare t1) | PsatzMulE (t1, t2) -> (match t1 with | PsatzMulE (x, x0) -> (match x with | PsatzC p2 -> (match t2 with | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x0) | PsatzZ -> PsatzZ | _ -> e) | _ -> (match x0 with | PsatzC p2 -> (match t2 with | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x) | PsatzZ -> PsatzZ | _ -> e) | _ -> (match t2 with | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2) | PsatzZ -> PsatzZ | _ -> e))) | PsatzC c -> (match t2 with | PsatzMulE (x, x0) -> (match x with | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x0) | _ -> (match x0 with | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x) | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2))) | PsatzAdd (y, z0) -> PsatzAdd ((PsatzMulE ((PsatzC c), y)), (PsatzMulE ((PsatzC c), z0))) | PsatzC c0 -> PsatzC (ctimes c c0) | PsatzZ -> PsatzZ | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2)) | PsatzZ -> PsatzZ | _ -> (match t2 with | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2) | PsatzZ -> PsatzZ | _ -> e)) | PsatzAdd (t1, t2) -> (match t1 with | PsatzZ -> t2 | _ -> (match t2 with | PsatzZ -> t1 | _ -> PsatzAdd (t1, t2))) | _ -> e type q = { qnum : z; qden : positive } (** val qnum : q -> z **) let qnum x = x.qnum (** val qden : q -> positive **) let qden x = x.qden (** val qeq_bool : q -> q -> bool **) let qeq_bool x y = zeq_bool (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)) (** val qle_bool : q -> q -> bool **) let qle_bool x y = Z.leb (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)) (** val qplus : q -> q -> q **) let qplus x y = { qnum = (Z.add (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden))); qden = (Coq_Pos.mul x.qden y.qden) } (** val qmult : q -> q -> q **) let qmult x y = { qnum = (Z.mul x.qnum y.qnum); qden = (Coq_Pos.mul x.qden y.qden) } (** val qopp : q -> q **) let qopp x = { qnum = (Z.opp x.qnum); qden = x.qden } (** val qminus : q -> q -> q **) let qminus x y = qplus x (qopp y) (** val qinv : q -> q **) let qinv x = match x.qnum with | Z0 -> { qnum = Z0; qden = XH } | Zpos p -> { qnum = (Zpos x.qden); qden = p } | Zneg p -> { qnum = (Zneg x.qden); qden = p } (** val qpower_positive : q -> positive -> q **) let qpower_positive q0 p = pow_pos qmult q0 p (** val qpower : q -> z -> q **) let qpower q0 = function | Z0 -> { qnum = (Zpos XH); qden = XH } | Zpos p -> qpower_positive q0 p | Zneg p -> qinv (qpower_positive q0 p) type 'a t0 = | Empty | Leaf of 'a | Node of 'a t0 * 'a * 'a t0 (** val find : 'a1 -> 'a1 t0 -> positive -> 'a1 **) let rec find default vm p = match vm with | Empty -> default | Leaf i -> i | Node (l, e, r) -> (match p with | XI p2 -> find default r p2 | XO p2 -> find default l p2 | XH -> e) type zWitness = z psatz (** val zWeakChecker : z nFormula list -> z psatz -> bool **) let zWeakChecker = check_normalised_formulas Z0 (Zpos XH) Z.add Z.mul zeq_bool Z.leb (** val psub1 : z pol -> z pol -> z pol **) let psub1 = psub0 Z0 Z.add Z.sub Z.opp zeq_bool (** val padd1 : z pol -> z pol -> z pol **) let padd1 = padd0 Z0 Z.add zeq_bool (** val norm0 : z pExpr -> z pol **) let norm0 = norm Z0 (Zpos XH) Z.add Z.mul Z.sub Z.opp zeq_bool (** val xnormalise0 : z formula -> z nFormula list **) let xnormalise0 t1 = let { flhs = lhs; fop = o; frhs = rhs } = t1 in let lhs0 = norm0 lhs in let rhs0 = norm0 rhs in (match o with | OpEq -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::(((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[]) | OpNEq -> ((psub1 lhs0 rhs0),Equal)::[] | OpLe -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::[] | OpGe -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[] | OpLt -> ((psub1 lhs0 rhs0),NonStrict)::[] | OpGt -> ((psub1 rhs0 lhs0),NonStrict)::[]) (** val normalise : z formula -> z nFormula cnf **) let normalise t1 = map (fun x -> x::[]) (xnormalise0 t1) (** val xnegate0 : z formula -> z nFormula list **) let xnegate0 t1 = let { flhs = lhs; fop = o; frhs = rhs } = t1 in let lhs0 = norm0 lhs in let rhs0 = norm0 rhs in (match o with | OpEq -> ((psub1 lhs0 rhs0),Equal)::[] | OpNEq -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::(((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[]) | OpLe -> ((psub1 rhs0 lhs0),NonStrict)::[] | OpGe -> ((psub1 lhs0 rhs0),NonStrict)::[] | OpLt -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[] | OpGt -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::[]) (** val negate : z formula -> z nFormula cnf **) let negate t1 = map (fun x -> x::[]) (xnegate0 t1) (** val zunsat : z nFormula -> bool **) let zunsat = check_inconsistent Z0 zeq_bool Z.leb (** val zdeduce : z nFormula -> z nFormula -> z nFormula option **) let zdeduce = nformula_plus_nformula Z0 Z.add zeq_bool (** val ceiling : z -> z -> z **) let ceiling a b = let q0,r = Z.div_eucl a b in (match r with | Z0 -> q0 | _ -> Z.add q0 (Zpos XH)) type zArithProof = | DoneProof | RatProof of zWitness * zArithProof | CutProof of zWitness * zArithProof | EnumProof of zWitness * zWitness * zArithProof list (** val zgcdM : z -> z -> z **) let zgcdM x y = Z.max (Z.gcd x y) (Zpos XH) (** val zgcd_pol : z polC -> z * z **) let rec zgcd_pol = function | Pc c -> Z0,c | Pinj (p2, p3) -> zgcd_pol p3 | PX (p2, p3, q0) -> let g1,c1 = zgcd_pol p2 in let g2,c2 = zgcd_pol q0 in (zgcdM (zgcdM g1 c1) g2),c2 (** val zdiv_pol : z polC -> z -> z polC **) let rec zdiv_pol p x = match p with | Pc c -> Pc (Z.div c x) | Pinj (j, p2) -> Pinj (j, (zdiv_pol p2 x)) | PX (p2, j, q0) -> PX ((zdiv_pol p2 x), j, (zdiv_pol q0 x)) (** val makeCuttingPlane : z polC -> z polC * z **) let makeCuttingPlane p = let g,c = zgcd_pol p in if Z.gtb g Z0 then (zdiv_pol (psubC Z.sub p c) g),(Z.opp (ceiling (Z.opp c) g)) else p,Z0 (** val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option **) let genCuttingPlane = function | e,op -> (match op with | Equal -> let g,c = zgcd_pol e in if (&&) (Z.gtb g Z0) ((&&) (negb (zeq_bool c Z0)) (negb (zeq_bool (Z.gcd g c) g))) then None else Some ((makeCuttingPlane e),Equal) | NonEqual -> Some ((e,Z0),op) | Strict -> Some ((makeCuttingPlane (psubC Z.sub e (Zpos XH))),NonStrict) | NonStrict -> Some ((makeCuttingPlane e),NonStrict)) (** val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula **) let nformula_of_cutting_plane = function | e_z,o -> let e,z0 = e_z in (padd1 e (Pc z0)),o (** val is_pol_Z0 : z polC -> bool **) let is_pol_Z0 = function | Pc z0 -> (match z0 with | Z0 -> true | _ -> false) | _ -> false (** val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option **) let eval_Psatz0 = eval_Psatz Z0 (Zpos XH) Z.add Z.mul zeq_bool Z.leb (** val valid_cut_sign : op1 -> bool **) let valid_cut_sign = function | Equal -> true | NonStrict -> true | _ -> false (** val zChecker : z nFormula list -> zArithProof -> bool **) let rec zChecker l = function | DoneProof -> false | RatProof (w, pf0) -> (match eval_Psatz0 l w with | Some f -> if zunsat f then true else zChecker (f::l) pf0 | None -> false) | CutProof (w, pf0) -> (match eval_Psatz0 l w with | Some f -> (match genCuttingPlane f with | Some cp -> zChecker ((nformula_of_cutting_plane cp)::l) pf0 | None -> true) | None -> false) | EnumProof (w1, w2, pf0) -> (match eval_Psatz0 l w1 with | Some f1 -> (match eval_Psatz0 l w2 with | Some f2 -> (match genCuttingPlane f1 with | Some p -> let p2,op3 = p in let e1,z1 = p2 in (match genCuttingPlane f2 with | Some p3 -> let p4,op4 = p3 in let e2,z2 = p4 in if (&&) ((&&) (valid_cut_sign op3) (valid_cut_sign op4)) (is_pol_Z0 (padd1 e1 e2)) then let rec label pfs lb ub = match pfs with | [] -> Z.gtb lb ub | pf1::rsr -> (&&) (zChecker (((psub1 e1 (Pc lb)),Equal)::l) pf1) (label rsr (Z.add lb (Zpos XH)) ub) in label pf0 (Z.opp z1) z2 else false | None -> true) | None -> true) | None -> false) | None -> false) (** val zTautoChecker : z formula bFormula -> zArithProof list -> bool **) let zTautoChecker f w = tauto_checker zunsat zdeduce normalise negate zChecker f w type qWitness = q psatz (** val qWeakChecker : q nFormula list -> q psatz -> bool **) let qWeakChecker = check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qeq_bool qle_bool (** val qnormalise : q formula -> q nFormula cnf **) let qnormalise = cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qminus qopp qeq_bool (** val qnegate : q formula -> q nFormula cnf **) let qnegate = cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qminus qopp qeq_bool (** val qunsat : q nFormula -> bool **) let qunsat = check_inconsistent { qnum = Z0; qden = XH } qeq_bool qle_bool (** val qdeduce : q nFormula -> q nFormula -> q nFormula option **) let qdeduce = nformula_plus_nformula { qnum = Z0; qden = XH } qplus qeq_bool (** val qTautoChecker : q formula bFormula -> qWitness list -> bool **) let qTautoChecker f w = tauto_checker qunsat qdeduce qnormalise qnegate qWeakChecker f w type rcst = | C0 | C1 | CQ of q | CZ of z | CPlus of rcst * rcst | CMinus of rcst * rcst | CMult of rcst * rcst | CInv of rcst | COpp of rcst (** val q_of_Rcst : rcst -> q **) let rec q_of_Rcst = function | C0 -> { qnum = Z0; qden = XH } | C1 -> { qnum = (Zpos XH); qden = XH } | CQ q0 -> q0 | CZ z0 -> { qnum = z0; qden = XH } | CPlus (r1, r2) -> qplus (q_of_Rcst r1) (q_of_Rcst r2) | CMinus (r1, r2) -> qminus (q_of_Rcst r1) (q_of_Rcst r2) | CMult (r1, r2) -> qmult (q_of_Rcst r1) (q_of_Rcst r2) | CInv r0 -> qinv (q_of_Rcst r0) | COpp r0 -> qopp (q_of_Rcst r0) type rWitness = q psatz (** val rWeakChecker : q nFormula list -> q psatz -> bool **) let rWeakChecker = check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qeq_bool qle_bool (** val rnormalise : q formula -> q nFormula cnf **) let rnormalise = cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qminus qopp qeq_bool (** val rnegate : q formula -> q nFormula cnf **) let rnegate = cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qminus qopp qeq_bool (** val runsat : q nFormula -> bool **) let runsat = check_inconsistent { qnum = Z0; qden = XH } qeq_bool qle_bool (** val rdeduce : q nFormula -> q nFormula -> q nFormula option **) let rdeduce = nformula_plus_nformula { qnum = Z0; qden = XH } qplus qeq_bool (** val rTautoChecker : rcst formula bFormula -> rWitness list -> bool **) let rTautoChecker f w = tauto_checker runsat rdeduce rnormalise rnegate rWeakChecker (map_bformula (map_Formula q_of_Rcst) f) w coq-8.4pl4/plugins/micromega/LICENSE.sos0000644000175000017500000000305712326224777017074 0ustar stephsteph HOL Light copyright notice, licence and disclaimer (c) University of Cambridge 1998 (c) Copyright, John Harrison 1998-2006 HOL Light version 2.20, hereinafter referred to as "the software", is a computer theorem proving system written by John Harrison. Much of the software was developed at the University of Cambridge Computer Laboratory, New Museums Site, Pembroke Street, Cambridge, CB2 3QG, England. The software is copyright, University of Cambridge 1998 and John Harrison 1998-2006. Permission to use, copy, modify, and distribute the software and its documentation for any purpose and without fee is hereby granted. In the case of further distribution of the software the present text, including copyright notice, licence and disclaimer of warranty, must be included in full and unmodified form in any release. Distribution of derivative software obtained by modifying the software, or incorporating it into other software, is permitted, provided the inclusion of the software is acknowledged and that any changes made to the software are clearly documented. John Harrison and the University of Cambridge disclaim all warranties with regard to the software, including all implied warranties of merchantability and fitness. In no event shall John Harrison or the University of Cambridge be liable for any special, indirect, incidental or consequential damages or any damages whatsoever, including, but not limited to, those arising from computer failure or malfunction, work stoppage, loss of profit or loss of contracts. coq-8.4pl4/plugins/micromega/VarMap.v0000644000175000017500000000350612326224777016640 0ustar stephsteph(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t | Node : t -> A -> t -> t . Fixpoint find (vm : t) (p:positive) {struct vm} : A := match vm with | Empty => default | Leaf i => i | Node l e r => match p with | xH => e | xO p => find l p | xI p => find r p end end. End MakeVarMap. coq-8.4pl4/plugins/micromega/ZMicromega.v0000644000175000017500000007424112326224777017513 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* destruct (andb_prop _ _ id); clear id | [ id : (_ || _)%bool = true |- _ ] => destruct (orb_prop _ _ id); clear id end. Ltac inv H := inversion H ; try subst ; clear H. Require Import EnvRing. Open Scope Z_scope. Lemma Zsor : SOR 0 1 Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt. Proof. constructor ; intros ; subst ; try (intuition (auto with zarith)). apply Zsth. apply Zth. destruct (Z.lt_trichotomy n m) ; intuition. apply Z.mul_pos_pos ; auto. Qed. Lemma ZSORaddon : SORaddon 0 1 Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le (* ring elements *) 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (* coefficients *) Zeq_bool Z.leb (fun x => x) (fun x => x) (pow_N 1 Z.mul). Proof. constructor. constructor ; intros ; try reflexivity. apply Zeq_bool_eq ; auto. constructor. reflexivity. intros x y. apply Zeq_bool_neq ; auto. apply Zle_bool_imp_le. Qed. Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z := match e with | PEc c => c | PEX x => env x | PEadd e1 e2 => Zeval_expr env e1 + Zeval_expr env e2 | PEmul e1 e2 => Zeval_expr env e1 * Zeval_expr env e2 | PEpow e1 n => Z.pow (Zeval_expr env e1) (Z.of_N n) | PEsub e1 e2 => (Zeval_expr env e1) - (Zeval_expr env e2) | PEopp e => Z.opp (Zeval_expr env e) end. Definition eval_expr := eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x => x) (fun x => x) (pow_N 1 Z.mul). Lemma ZNpower : forall r n, r ^ Z.of_N n = pow_N 1 Z.mul r n. Proof. destruct n. reflexivity. simpl. unfold Z.pow_pos. replace (pow_pos Z.mul r p) with (1 * (pow_pos Z.mul r p)) by ring. generalize 1. induction p; simpl ; intros ; repeat rewrite IHp ; ring. Qed. Lemma Zeval_expr_compat : forall env e, Zeval_expr env e = eval_expr env e. Proof. induction e ; simpl ; try congruence. reflexivity. rewrite ZNpower. congruence. Qed. Definition Zeval_op2 (o : Op2) : Z -> Z -> Prop := match o with | OpEq => @eq Z | OpNEq => fun x y => ~ x = y | OpLe => Z.le | OpGe => Z.ge | OpLt => Z.lt | OpGt => Z.gt end. Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):= let (lhs, op, rhs) := f in (Zeval_op2 op) (Zeval_expr env lhs) (Zeval_expr env rhs). Definition Zeval_formula' := eval_formula Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt (fun x => x) (fun x => x) (pow_N 1 Z.mul). Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f. Proof. destruct f ; simpl. rewrite Zeval_expr_compat. rewrite Zeval_expr_compat. unfold eval_expr. generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) (fun x : N => x) (pow_N 1 Z.mul) env Flhs). generalize ((eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) (fun x : N => x) (pow_N 1 Z.mul) env Frhs)). destruct Fop ; simpl; intros ; intuition (auto with zarith). Qed. Definition eval_nformula := eval_nformula 0 Z.add Z.mul (@eq Z) Z.le Z.lt (fun x => x) . Definition Zeval_op1 (o : Op1) : Z -> Prop := match o with | Equal => fun x : Z => x = 0 | NonEqual => fun x : Z => x <> 0 | Strict => fun x : Z => 0 < x | NonStrict => fun x : Z => 0 <= x end. Lemma Zeval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). Proof. intros. apply (eval_nformula_dec Zsor). Qed. Definition ZWitness := Psatz Z. Definition ZWeakChecker := check_normalised_formulas 0 1 Z.add Z.mul Zeq_bool Z.leb. Lemma ZWeakChecker_sound : forall (l : list (NFormula Z)) (cm : ZWitness), ZWeakChecker l cm = true -> forall env, make_impl (eval_nformula env) l False. Proof. intros l cm H. intro. unfold eval_nformula. apply (checker_nf_sound Zsor ZSORaddon l cm). unfold ZWeakChecker in H. exact H. Qed. Definition psub := psub Z0 Z.add Z.sub Z.opp Zeq_bool. Definition padd := padd Z0 Z.add Zeq_bool. Definition norm := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool. Definition eval_pol := eval_pol Z.add Z.mul (fun x => x). Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) = eval_pol env lhs - eval_pol env rhs. Proof. intros. apply (eval_pol_sub Zsor ZSORaddon). Qed. Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd lhs rhs) = eval_pol env lhs + eval_pol env rhs. Proof. intros. apply (eval_pol_add Zsor ZSORaddon). Qed. Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (norm e) . Proof. intros. apply (eval_pol_norm Zsor ZSORaddon). Qed. Definition xnormalise (t:Formula Z) : list (NFormula Z) := let (lhs,o,rhs) := t in let lhs := norm lhs in let rhs := norm rhs in match o with | OpEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil | OpNEq => (psub lhs rhs,Equal) :: nil | OpGt => (psub rhs lhs,NonStrict) :: nil | OpLt => (psub lhs rhs,NonStrict) :: nil | OpGe => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil | OpLe => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil end. Require Import Tauto BinNums. Definition normalise (t:Formula Z) : cnf (NFormula Z) := List.map (fun x => x::nil) (xnormalise t). Lemma normalise_correct : forall env t, eval_cnf eval_nformula env (normalise t) <-> Zeval_formula env t. Proof. Opaque padd. unfold normalise, xnormalise ; simpl; intros env t. rewrite Zeval_formula_compat. unfold eval_cnf, eval_clause. destruct t as [lhs o rhs]; case_eq o; simpl; repeat rewrite eval_pol_sub; repeat rewrite eval_pol_add; repeat rewrite <- eval_pol_norm ; simpl in *; unfold eval_expr; generalize ( eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) (fun x : N => x) (pow_N 1 Z.mul) env lhs); generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) (fun x : N => x) (pow_N 1 Z.mul) env rhs) ; intros z1 z2 ; intros ; subst; intuition (auto with zarith). Transparent padd. Qed. Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) := let (lhs,o,rhs) := t in let lhs := norm lhs in let rhs := norm rhs in match o with | OpEq => (psub lhs rhs,Equal) :: nil | OpNEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil | OpGt => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil | OpLt => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil | OpGe => (psub lhs rhs,NonStrict) :: nil | OpLe => (psub rhs lhs,NonStrict) :: nil end. Definition negate (t:RingMicromega.Formula Z) : cnf (NFormula Z) := List.map (fun x => x::nil) (xnegate t). Lemma negate_correct : forall env t, eval_cnf eval_nformula env (negate t) <-> ~ Zeval_formula env t. Proof. Proof. Opaque padd. intros env t. rewrite Zeval_formula_compat. unfold negate, xnegate ; simpl. unfold eval_cnf,eval_clause. destruct t as [lhs o rhs]; case_eq o; simpl; repeat rewrite eval_pol_sub; repeat rewrite eval_pol_add; repeat rewrite <- eval_pol_norm ; simpl in *; unfold eval_expr; generalize ( eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) (fun x : N => x) (pow_N 1 Z.mul) env lhs); generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) (fun x : N => x) (pow_N 1 Z.mul) env rhs) ; intros z1 z2 ; intros ; subst; intuition (auto with zarith). Transparent padd. Qed. Definition Zunsat := check_inconsistent 0 Zeq_bool Z.leb. Definition Zdeduce := nformula_plus_nformula 0 Z.add Zeq_bool. Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool := @tauto_checker (Formula Z) (NFormula Z) Zunsat Zdeduce normalise negate ZWitness ZWeakChecker f w. (* To get a complete checker, the proof format has to be enriched *) Require Import Zdiv. Open Scope Z_scope. Definition ceiling (a b:Z) : Z := let (q,r) := Z.div_eucl a b in match r with | Z0 => q | _ => q + 1 end. Require Import Znumtheory. Lemma Zdivide_ceiling : forall a b, (b | a) -> ceiling a b = Z.div a b. Proof. unfold ceiling. intros. apply Zdivide_mod in H. case_eq (Z.div_eucl a b). intros. change z with (fst (z,z0)). rewrite <- H0. change (fst (Z.div_eucl a b)) with (Z.div a b). change z0 with (snd (z,z0)). rewrite <- H0. change (snd (Z.div_eucl a b)) with (Z.modulo a b). rewrite H. reflexivity. Qed. Lemma narrow_interval_lower_bound a b x : a > 0 -> a * x >= b -> x >= ceiling b a. Proof. rewrite !Z.ge_le_iff. unfold ceiling. intros Ha H. generalize (Z_div_mod b a Ha). destruct (Z.div_eucl b a) as (q,r). intros (->,(H1,H2)). destruct r as [|r|r]. - rewrite Z.add_0_r in H. apply Z.mul_le_mono_pos_l in H; auto with zarith. - assert (0 < Z.pos r) by easy. rewrite Z.add_1_r, Z.le_succ_l. apply Z.mul_lt_mono_pos_l with a; auto with zarith. - now elim H1. Qed. (** NB: narrow_interval_upper_bound is Zdiv.Zdiv_le_lower_bound *) Require Import QArith. Inductive ZArithProof : Type := | DoneProof | RatProof : ZWitness -> ZArithProof -> ZArithProof | CutProof : ZWitness -> ZArithProof -> ZArithProof | EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof (*| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof*). (* n/d <= x -> d*x - n >= 0 *) (* In order to compute the 'cut', we need to express a polynomial P as a * Q + b. - b is the constant - a is the gcd of the other coefficient. *) Require Import Znumtheory. Definition isZ0 (x:Z) := match x with | Z0 => true | _ => false end. Lemma isZ0_0 : forall x, isZ0 x = true <-> x = 0. Proof. destruct x ; simpl ; intuition congruence. Qed. Lemma isZ0_n0 : forall x, isZ0 x = false <-> x <> 0. Proof. destruct x ; simpl ; intuition congruence. Qed. Definition ZgcdM (x y : Z) := Z.max (Z.gcd x y) 1. Fixpoint Zgcd_pol (p : PolC Z) : (Z * Z) := match p with | Pc c => (0,c) | Pinj _ p => Zgcd_pol p | PX p _ q => let (g1,c1) := Zgcd_pol p in let (g2,c2) := Zgcd_pol q in (ZgcdM (ZgcdM g1 c1) g2 , c2) end. (*Eval compute in (Zgcd_pol ((PX (Pc (-2)) 1 (Pc 4)))).*) Fixpoint Zdiv_pol (p:PolC Z) (x:Z) : PolC Z := match p with | Pc c => Pc (Z.div c x) | Pinj j p => Pinj j (Zdiv_pol p x) | PX p j q => PX (Zdiv_pol p x) j (Zdiv_pol q x) end. Inductive Zdivide_pol (x:Z): PolC Z -> Prop := | Zdiv_Pc : forall c, (x | c) -> Zdivide_pol x (Pc c) | Zdiv_Pinj : forall p, Zdivide_pol x p -> forall j, Zdivide_pol x (Pinj j p) | Zdiv_PX : forall p q, Zdivide_pol x p -> Zdivide_pol x q -> forall j, Zdivide_pol x (PX p j q). Lemma Zdiv_pol_correct : forall a p, 0 < a -> Zdivide_pol a p -> forall env, eval_pol env p = a * eval_pol env (Zdiv_pol p a). Proof. intros until 2. induction H0. (* Pc *) simpl. intros. apply Zdivide_Zdiv_eq ; auto. (* Pinj *) simpl. intros. apply IHZdivide_pol. (* PX *) simpl. intros. rewrite IHZdivide_pol1. rewrite IHZdivide_pol2. ring. Qed. Lemma Zgcd_pol_ge : forall p, fst (Zgcd_pol p) >= 0. Proof. induction p. simpl. auto with zarith. simpl. auto. simpl. case_eq (Zgcd_pol p1). case_eq (Zgcd_pol p3). intros. simpl. unfold ZgcdM. generalize (Z.gcd_nonneg z1 z2). generalize (Zmax_spec (Z.gcd z1 z2) 1). generalize (Z.gcd_nonneg (Z.max (Z.gcd z1 z2) 1) z). generalize (Zmax_spec (Z.gcd (Z.max (Z.gcd z1 z2) 1) z) 1). auto with zarith. Qed. Lemma Zdivide_pol_Zdivide : forall p x y, Zdivide_pol x p -> (y | x) -> Zdivide_pol y p. Proof. intros. induction H. constructor. apply Z.divide_trans with (1:= H0) ; assumption. constructor. auto. constructor ; auto. Qed. Lemma Zdivide_pol_one : forall p, Zdivide_pol 1 p. Proof. induction p ; constructor ; auto. exists c. ring. Qed. Lemma Zgcd_minus : forall a b c, (a | c - b ) -> (Z.gcd a b | c). Proof. intros a b c (q,Hq). destruct (Zgcd_is_gcd a b) as [(a',Ha) (b',Hb) _]. set (g:=Z.gcd a b) in *; clearbody g. exists (q * a' + b'). symmetry in Hq. rewrite <- Z.add_move_r in Hq. rewrite <- Hq, Hb, Ha. ring. Qed. Lemma Zdivide_pol_sub : forall p a b, 0 < Z.gcd a b -> Zdivide_pol a (PsubC Z.sub p b) -> Zdivide_pol (Z.gcd a b) p. Proof. induction p. simpl. intros. inversion H0. constructor. apply Zgcd_minus ; auto. intros. constructor. simpl in H0. inversion H0 ; subst; clear H0. apply IHp ; auto. simpl. intros. inv H0. constructor. apply Zdivide_pol_Zdivide with (1:= H3). destruct (Zgcd_is_gcd a b) ; assumption. apply IHp2 ; assumption. Qed. Lemma Zdivide_pol_sub_0 : forall p a, Zdivide_pol a (PsubC Z.sub p 0) -> Zdivide_pol a p. Proof. induction p. simpl. intros. inversion H. constructor. replace (c - 0) with c in H1 ; auto with zarith. intros. constructor. simpl in H. inversion H ; subst; clear H. apply IHp ; auto. simpl. intros. inv H. constructor. auto. apply IHp2 ; assumption. Qed. Lemma Zgcd_pol_div : forall p g c, Zgcd_pol p = (g, c) -> Zdivide_pol g (PsubC Z.sub p c). Proof. induction p ; simpl. (* Pc *) intros. inv H. constructor. exists 0. now ring. (* Pinj *) intros. constructor. apply IHp ; auto. (* PX *) intros g c. case_eq (Zgcd_pol p1) ; case_eq (Zgcd_pol p3) ; intros. inv H1. unfold ZgcdM at 1. destruct (Zmax_spec (Z.gcd (ZgcdM z1 z2) z) 1) as [HH1 | HH1]; destruct HH1 as [HH1 HH1'] ; rewrite HH1'. constructor. apply Zdivide_pol_Zdivide with (x:= ZgcdM z1 z2). unfold ZgcdM. destruct (Zmax_spec (Z.gcd z1 z2) 1) as [HH2 | HH2]. destruct HH2. rewrite H2. apply Zdivide_pol_sub ; auto. auto with zarith. destruct HH2. rewrite H2. apply Zdivide_pol_one. unfold ZgcdM in HH1. unfold ZgcdM. destruct (Zmax_spec (Z.gcd z1 z2) 1) as [HH2 | HH2]. destruct HH2. rewrite H2 in *. destruct (Zgcd_is_gcd (Z.gcd z1 z2) z); auto. destruct HH2. rewrite H2. destruct (Zgcd_is_gcd 1 z); auto. apply Zdivide_pol_Zdivide with (x:= z). apply (IHp2 _ _ H); auto. destruct (Zgcd_is_gcd (ZgcdM z1 z2) z); auto. constructor. apply Zdivide_pol_one. apply Zdivide_pol_one. Qed. Lemma Zgcd_pol_correct_lt : forall p env g c, Zgcd_pol p = (g,c) -> 0 < g -> eval_pol env p = g * (eval_pol env (Zdiv_pol (PsubC Z.sub p c) g)) + c. Proof. intros. rewrite <- Zdiv_pol_correct ; auto. rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). unfold eval_pol. ring. (**) apply Zgcd_pol_div ; auto. Qed. Definition makeCuttingPlane (p : PolC Z) : PolC Z * Z := let (g,c) := Zgcd_pol p in if Z.gtb g Z0 then (Zdiv_pol (PsubC Z.sub p c) g , Z.opp (ceiling (Z.opp c) g)) else (p,Z0). Definition genCuttingPlane (f : NFormula Z) : option (PolC Z * Z * Op1) := let (e,op) := f in match op with | Equal => let (g,c) := Zgcd_pol e in if andb (Z.gtb g Z0) (andb (negb (Zeq_bool c Z0)) (negb (Zeq_bool (Z.gcd g c) g))) then None (* inconsistent *) else (* Could be optimised Zgcd_pol is recomputed *) let (p,c) := makeCuttingPlane e in Some (p,c,Equal) | NonEqual => Some (e,Z0,op) | Strict => let (p,c) := makeCuttingPlane (PsubC Z.sub e 1) in Some (p,c,NonStrict) | NonStrict => let (p,c) := makeCuttingPlane e in Some (p,c,NonStrict) end. Definition nformula_of_cutting_plane (t : PolC Z * Z * Op1) : NFormula Z := let (e_z, o) := t in let (e,z) := e_z in (padd e (Pc z) , o). Definition is_pol_Z0 (p : PolC Z) : bool := match p with | Pc Z0 => true | _ => false end. Lemma is_pol_Z0_eval_pol : forall p, is_pol_Z0 p = true -> forall env, eval_pol env p = 0. Proof. unfold is_pol_Z0. destruct p ; try discriminate. destruct z ; try discriminate. reflexivity. Qed. Definition eval_Psatz : list (NFormula Z) -> ZWitness -> option (NFormula Z) := eval_Psatz 0 1 Z.add Z.mul Zeq_bool Z.leb. Definition valid_cut_sign (op:Op1) := match op with | Equal => true | NonStrict => true | _ => false end. Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool := match pf with | DoneProof => false | RatProof w pf => match eval_Psatz l w with | None => false | Some f => if Zunsat f then true else ZChecker (f::l) pf end | CutProof w pf => match eval_Psatz l w with | None => false | Some f => match genCuttingPlane f with | None => true | Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf end end | EnumProof w1 w2 pf => match eval_Psatz l w1 , eval_Psatz l w2 with | Some f1 , Some f2 => match genCuttingPlane f1 , genCuttingPlane f2 with |Some (e1,z1,op1) , Some (e2,z2,op2) => if (valid_cut_sign op1 && valid_cut_sign op2 && is_pol_Z0 (padd e1 e2)) then (fix label (pfs:list ZArithProof) := fun lb ub => match pfs with | nil => if Z.gtb lb ub then true else false | pf::rsr => andb (ZChecker ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Z.add lb 1%Z) ub) end) pf (Z.opp z1) z2 else false | _ , _ => true end | _ , _ => false end end. Fixpoint bdepth (pf : ZArithProof) : nat := match pf with | DoneProof => O | RatProof _ p => S (bdepth p) | CutProof _ p => S (bdepth p) | EnumProof _ _ l => S (List.fold_right (fun pf x => Max.max (bdepth pf) x) O l) end. Require Import Wf_nat. Lemma in_bdepth : forall l a b y, In y l -> ltof ZArithProof bdepth y (EnumProof a b l). Proof. induction l. (* nil *) simpl. tauto. (* cons *) simpl. intros. destruct H. subst. unfold ltof. simpl. generalize ( (fold_right (fun (pf : ZArithProof) (x : nat) => Max.max (bdepth pf) x) 0%nat l)). intros. generalize (bdepth y) ; intros. generalize (Max.max_l n0 n) (Max.max_r n0 n). auto with zarith. generalize (IHl a0 b y H). unfold ltof. simpl. generalize ( (fold_right (fun (pf : ZArithProof) (x : nat) => Max.max (bdepth pf) x) 0%nat l)). intros. generalize (Max.max_l (bdepth a) n) (Max.max_r (bdepth a) n). auto with zarith. Qed. Lemma eval_Psatz_sound : forall env w l f', make_conj (eval_nformula env) l -> eval_Psatz l w = Some f' -> eval_nformula env f'. Proof. intros. apply (eval_Psatz_Sound Zsor ZSORaddon) with (l:=l) (e:= w) ; auto. apply make_conj_in ; auto. Qed. Lemma makeCuttingPlane_ns_sound : forall env e e' c, eval_nformula env (e, NonStrict) -> makeCuttingPlane e = (e',c) -> eval_nformula env (nformula_of_cutting_plane (e', c, NonStrict)). Proof. unfold nformula_of_cutting_plane. unfold eval_nformula. unfold RingMicromega.eval_nformula. unfold eval_op1. intros. rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). simpl. (**) unfold makeCuttingPlane in H0. revert H0. case_eq (Zgcd_pol e) ; intros g c0. generalize (Zgt_cases g 0) ; destruct (Z.gtb g 0). intros. inv H2. change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in *. apply Zgcd_pol_correct_lt with (env:=env) in H1. generalize (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Z.sub e c0) g)) H0). auto with zarith. auto with zarith. (* g <= 0 *) intros. inv H2. auto with zarith. Qed. Lemma cutting_plane_sound : forall env f p, eval_nformula env f -> genCuttingPlane f = Some p -> eval_nformula env (nformula_of_cutting_plane p). Proof. unfold genCuttingPlane. destruct f as [e op]. destruct op. (* Equal *) destruct p as [[e' z] op]. case_eq (Zgcd_pol e) ; intros g c. case_eq (Z.gtb g 0 && (negb (Zeq_bool c 0) && negb (Zeq_bool (Z.gcd g c) g))) ; [discriminate|]. case_eq (makeCuttingPlane e). intros. inv H3. unfold makeCuttingPlane in H. rewrite H1 in H. revert H. change (eval_pol env e = 0) in H2. case_eq (Z.gtb g 0). intros. rewrite <- Zgt_is_gt_bool in H. rewrite Zgcd_pol_correct_lt with (1:= H1) in H2; auto with zarith. unfold nformula_of_cutting_plane. change (eval_pol env (padd e' (Pc z)) = 0). inv H3. rewrite eval_pol_add. set (x:=eval_pol env (Zdiv_pol (PsubC Z.sub e c) g)) in *; clearbody x. simpl. rewrite andb_false_iff in H0. destruct H0. rewrite Zgt_is_gt_bool in H ; congruence. rewrite andb_false_iff in H0. destruct H0. rewrite negb_false_iff in H0. apply Zeq_bool_eq in H0. subst. simpl. rewrite Z.add_0_r, Z.mul_eq_0 in H2. intuition auto with zarith. rewrite negb_false_iff in H0. apply Zeq_bool_eq in H0. assert (HH := Zgcd_is_gcd g c). rewrite H0 in HH. inv HH. apply Zdivide_opp_r in H4. rewrite Zdivide_ceiling ; auto. apply Z.sub_move_0_r. apply Z.div_unique_exact ; auto with zarith. intros. unfold nformula_of_cutting_plane. inv H3. change (eval_pol env (padd e' (Pc 0)) = 0). rewrite eval_pol_add. simpl. auto with zarith. (* NonEqual *) intros. inv H0. unfold eval_nformula in *. unfold RingMicromega.eval_nformula in *. unfold nformula_of_cutting_plane. unfold eval_op1 in *. rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). simpl. auto with zarith. (* Strict *) destruct p as [[e' z] op]. case_eq (makeCuttingPlane (PsubC Z.sub e 1)). intros. inv H1. apply makeCuttingPlane_ns_sound with (env:=env) (2:= H). simpl in *. rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). auto with zarith. (* NonStrict *) destruct p as [[e' z] op]. case_eq (makeCuttingPlane e). intros. inv H1. apply makeCuttingPlane_ns_sound with (env:=env) (2:= H). assumption. Qed. Lemma genCuttingPlaneNone : forall env f, genCuttingPlane f = None -> eval_nformula env f -> False. Proof. unfold genCuttingPlane. destruct f. destruct o. case_eq (Zgcd_pol p) ; intros g c. case_eq (Z.gtb g 0 && (negb (Zeq_bool c 0) && negb (Zeq_bool (Z.gcd g c) g))). intros. flatten_bool. rewrite negb_true_iff in H5. apply Zeq_bool_neq in H5. rewrite <- Zgt_is_gt_bool in H3. rewrite negb_true_iff in H. apply Zeq_bool_neq in H. change (eval_pol env p = 0) in H2. rewrite Zgcd_pol_correct_lt with (1:= H0) in H2; auto with zarith. set (x:=eval_pol env (Zdiv_pol (PsubC Z.sub p c) g)) in *; clearbody x. contradict H5. apply Zis_gcd_gcd; auto with zarith. constructor; auto with zarith. exists (-x). rewrite Z.mul_opp_l, Z.mul_comm; auto with zarith. (**) destruct (makeCuttingPlane p); discriminate. discriminate. destruct (makeCuttingPlane (PsubC Z.sub p 1)) ; discriminate. destruct (makeCuttingPlane p) ; discriminate. Qed. Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl (eval_nformula env) l False. Proof. induction w using (well_founded_ind (well_founded_ltof _ bdepth)). destruct w as [ | w pf | w pf | w1 w2 pf]. (* DoneProof *) simpl. discriminate. (* RatProof *) simpl. intro l. case_eq (eval_Psatz l w) ; [| discriminate]. intros f Hf. case_eq (Zunsat f). intros. apply (checker_nf_sound Zsor ZSORaddon l w). unfold check_normalised_formulas. unfold eval_Psatz in Hf. rewrite Hf. unfold Zunsat in H0. assumption. intros. assert (make_impl (eval_nformula env) (f::l) False). apply H with (2:= H1). unfold ltof. simpl. auto with arith. destruct f. rewrite <- make_conj_impl in H2. rewrite make_conj_cons in H2. rewrite <- make_conj_impl. intro. apply H2. split ; auto. apply eval_Psatz_sound with (2:= Hf) ; assumption. (* CutProof *) simpl. intro l. case_eq (eval_Psatz l w) ; [ | discriminate]. intros f' Hlc. case_eq (genCuttingPlane f'). intros. assert (make_impl (eval_nformula env) (nformula_of_cutting_plane p::l) False). eapply (H pf) ; auto. unfold ltof. simpl. auto with arith. rewrite <- make_conj_impl in H2. rewrite make_conj_cons in H2. rewrite <- make_conj_impl. intro. apply H2. split ; auto. apply eval_Psatz_sound with (env:=env) in Hlc. apply cutting_plane_sound with (1:= Hlc) (2:= H0). auto. (* genCuttingPlane = None *) intros. rewrite <- make_conj_impl. intros. apply eval_Psatz_sound with (2:= Hlc) in H2. apply genCuttingPlaneNone with (2:= H2) ; auto. (* EnumProof *) intro. simpl. case_eq (eval_Psatz l w1) ; [ | discriminate]. case_eq (eval_Psatz l w2) ; [ | discriminate]. intros f1 Hf1 f2 Hf2. case_eq (genCuttingPlane f2). destruct p as [ [p1 z1] op1]. case_eq (genCuttingPlane f1). destruct p as [ [p2 z2] op2]. case_eq (valid_cut_sign op1 && valid_cut_sign op2 && is_pol_Z0 (padd p1 p2)). intros Hcond. flatten_bool. rename H1 into HZ0. rename H2 into Hop1. rename H3 into Hop2. intros HCutL HCutR Hfix env. (* get the bounds of the enum *) rewrite <- make_conj_impl. intro. assert (-z1 <= eval_pol env p1 <= z2). split. apply eval_Psatz_sound with (env:=env) in Hf2 ; auto. apply cutting_plane_sound with (1:= Hf2) in HCutR. unfold nformula_of_cutting_plane in HCutR. unfold eval_nformula in HCutR. unfold RingMicromega.eval_nformula in HCutR. change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in HCutR. unfold eval_op1 in HCutR. destruct op1 ; simpl in Hop1 ; try discriminate; rewrite eval_pol_add in HCutR; simpl in HCutR; auto with zarith. (**) apply is_pol_Z0_eval_pol with (env := env) in HZ0. rewrite eval_pol_add in HZ0. replace (eval_pol env p1) with (- eval_pol env p2) by omega. apply eval_Psatz_sound with (env:=env) in Hf1 ; auto. apply cutting_plane_sound with (1:= Hf1) in HCutL. unfold nformula_of_cutting_plane in HCutL. unfold eval_nformula in HCutL. unfold RingMicromega.eval_nformula in HCutL. change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in HCutL. unfold eval_op1 in HCutL. rewrite eval_pol_add in HCutL. simpl in HCutL. destruct op2 ; simpl in Hop2 ; try discriminate ; omega. revert Hfix. match goal with | |- context[?F pf (-z1) z2 = true] => set (FF := F) end. intros. assert (HH :forall x, -z1 <= x <= z2 -> exists pr, (In pr pf /\ ZChecker ((PsubC Z.sub p1 x,Equal) :: l) pr = true)%Z). clear HZ0 Hop1 Hop2 HCutL HCutR H0 H1. revert Hfix. generalize (-z1). clear z1. intro z1. revert z1 z2. induction pf;simpl ;intros. generalize (Zgt_cases z1 z2). destruct (Z.gtb z1 z2). intros. apply False_ind ; omega. discriminate. flatten_bool. assert (HH:(x = z1 \/ z1 +1 <=x)%Z) by omega. destruct HH. subst. exists a ; auto. assert (z1 + 1 <= x <= z2)%Z by omega. elim IHpf with (2:=H2) (3:= H4). destruct H4. intros. exists x0 ; split;tauto. intros until 1. apply H ; auto. unfold ltof in *. simpl in *. zify. omega. (*/asser *) destruct (HH _ H1) as [pr [Hin Hcheker]]. assert (make_impl (eval_nformula env) ((PsubC Z.sub p1 (eval_pol env p1),Equal) :: l) False). apply (H pr);auto. apply in_bdepth ; auto. rewrite <- make_conj_impl in H2. apply H2. rewrite make_conj_cons. split ;auto. unfold eval_nformula. unfold RingMicromega.eval_nformula. simpl. rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). unfold eval_pol. ring. discriminate. (* No cutting plane *) intros. rewrite <- make_conj_impl. intros. apply eval_Psatz_sound with (2:= Hf1) in H3. apply genCuttingPlaneNone with (2:= H3) ; auto. (* No Cutting plane (bis) *) intros. rewrite <- make_conj_impl. intros. apply eval_Psatz_sound with (2:= Hf2) in H2. apply genCuttingPlaneNone with (2:= H2) ; auto. Qed. Definition ZTautoChecker (f : BFormula (Formula Z)) (w: list ZArithProof): bool := @tauto_checker (Formula Z) (NFormula Z) Zunsat Zdeduce normalise negate ZArithProof ZChecker f w. Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f (Zeval_formula env) f. Proof. intros f w. unfold ZTautoChecker. apply (tauto_checker_sound Zeval_formula eval_nformula). apply Zeval_nformula_dec. intros until env. unfold eval_nformula. unfold RingMicromega.eval_nformula. destruct t. apply (check_inconsistent_sound Zsor ZSORaddon) ; auto. unfold Zdeduce. apply (nformula_plus_nformula_correct Zsor ZSORaddon). intros env t. rewrite normalise_correct ; auto. intros env t. rewrite negate_correct ; auto. intros t w0. apply ZChecker_sound. Qed. Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := match pt with | DoneProof => acc | RatProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt | CutProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt | EnumProof c1 c2 l => let acc := xhyps_of_psatz base (xhyps_of_psatz base acc c2) c1 in List.fold_left (xhyps_of_pt (S base)) l acc end. Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt. (*Lemma hyps_of_pt_correct : forall pt l, *) Open Scope Z_scope. (** To ease bindings from ml code **) (*Definition varmap := Quote.varmap.*) Definition make_impl := Refl.make_impl. Definition make_conj := Refl.make_conj. Require VarMap. (*Definition varmap_type := VarMap.t Z. *) Definition env := PolEnv Z. Definition node := @VarMap.Node Z. Definition empty := @VarMap.Empty Z. Definition leaf := @VarMap.Leaf Z. Definition coneMember := ZWitness. Definition eval := eval_formula. Definition prod_pos_nat := prod positive nat. Notation n_of_Z := Z.to_N (only parsing). (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.4pl4/plugins/micromega/persistent_cache.ml0000644000175000017500000001254212326224777021140 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string -> 'a t (** [create i f] creates an empty persistent table with initial size i associated with file [f] *) val open_in : string -> 'a t (** [open_in f] rebuilds a table from the records stored in file [f]. As marshaling is not type-safe, it migth segault. *) val find : 'a t -> key -> 'a (** find has the specification of Hashtable.find *) val add : 'a t -> key -> 'a -> unit (** [add tbl key elem] adds the binding [key] [elem] to the table [tbl]. (and writes the binding to the file associated with [tbl].) If [key] is already bound, raises KeyAlreadyBound *) val close : 'a t -> unit (** [close tbl] is closing the table. Once closed, a table cannot be used. i.e, find,add will raise UnboundTable *) val memo : string -> (key -> 'a) -> (key -> 'a) (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table. Note that the cache will only be loaded when the function is used for the first time *) end open Hashtbl module PHashtable(Key:HashedType) : PHashtable with type key = Key.t = struct open Unix type key = Key.t module Table = Hashtbl.Make(Key) exception InvalidTableFormat exception UnboundTable type mode = Closed | Open type 'a t = { outch : out_channel ; mutable status : mode ; htbl : 'a Table.t } let create i f = let flags = [O_WRONLY; O_TRUNC;O_CREAT] in { outch = out_channel_of_descr (openfile f flags 0o666); status = Open ; htbl = Table.create i } let finally f rst = try let res = f () in rst () ; res with reraise -> (try rst () with any -> raise reraise ); raise reraise let read_key_elem inch = try Some (Marshal.from_channel inch) with | End_of_file -> None | e when e <> Sys.Break -> raise InvalidTableFormat (** In win32, it seems that we should unlock the exact zone that has been locked, and not the whole file *) let locked_start = ref 0 let lock fd = locked_start := lseek fd 0 SEEK_CUR; lockf fd F_LOCK 0 let rlock fd = locked_start := lseek fd 0 SEEK_CUR; lockf fd F_RLOCK 0 let unlock fd = let pos = lseek fd 0 SEEK_CUR in ignore (lseek fd !locked_start SEEK_SET); lockf fd F_ULOCK 0; ignore (lseek fd pos SEEK_SET) let open_in f = let flags = [O_RDONLY ; O_CREAT] in let finch = openfile f flags 0o666 in let inch = in_channel_of_descr finch in let htbl = Table.create 100 in let rec xload () = match read_key_elem inch with | None -> () | Some (key,elem) -> Table.add htbl key elem ; xload () in try (* Locking of the (whole) file while reading *) rlock finch; finally (fun () -> xload () ) (fun () -> unlock finch ; close_in_noerr inch ; ) ; { outch = out_channel_of_descr (openfile f [O_WRONLY;O_APPEND;O_CREAT] 0o666) ; status = Open ; htbl = htbl } with InvalidTableFormat -> (* Try to keep as many entries as possible *) begin let flags = [O_WRONLY; O_TRUNC;O_CREAT] in let out = (openfile f flags 0o666) in let outch = out_channel_of_descr out in lock out; (try Table.iter (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl; flush outch ; with e when e <> Sys.Break -> () ) ; unlock out ; { outch = outch ; status = Open ; htbl = htbl } end let close t = let {outch = outch ; status = status ; htbl = tbl} = t in match t.status with | Closed -> () (* don't do it twice *) | Open -> close_out outch ; Table.clear tbl ; t.status <- Closed let add t k e = let {outch = outch ; status = status ; htbl = tbl} = t in if status = Closed then raise UnboundTable else let fd = descr_of_out_channel outch in begin Table.add tbl k e ; lock fd; ignore (lseek fd 0 SEEK_END); Marshal.to_channel outch (k,e) [Marshal.No_sharing] ; flush outch ; unlock fd end let find t k = let {outch = outch ; status = status ; htbl = tbl} = t in if status = Closed then raise UnboundTable else let res = Table.find tbl k in res let memo cache f = let tbl = lazy (open_in cache) in fun x -> let tbl = Lazy.force tbl in try find tbl x with Not_found -> let res = f x in add tbl x res ; res end (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.4pl4/plugins/micromega/MExtraction.v0000644000175000017500000000441412326224777017706 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* "( * )" [ "(,)" ]. Extract Inductive list => list [ "[]" "(::)" ]. Extract Inductive bool => bool [ true false ]. Extract Inductive sumbool => bool [ true false ]. Extract Inductive option => option [ Some None ]. Extract Inductive sumor => option [ Some None ]. (** Then, in a ternary alternative { }+{ }+{ }, - leftmost choice (Inleft Left) is (Some true), - middle choice (Inleft Right) is (Some false), - rightmost choice (Inright) is (None) *) (** To preserve its laziness, andb is normally expansed. Let's rather use the ocaml && *) Extract Inlined Constant andb => "(&&)". Require Import Reals. Extract Constant R => "int". Extract Constant R0 => "0". Extract Constant R1 => "1". Extract Constant Rplus => "( + )". Extract Constant Rmult => "( * )". Extract Constant Ropp => "fun x -> - x". Extract Constant Rinv => "fun x -> 1 / x". Extraction "micromega.ml" List.map simpl_cone (*map_cone indexes*) denorm Qpower n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.4pl4/plugins/micromega/csdpcert.ml0000644000175000017500000001531012326224777017420 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Const (C2Ml.q_to_num z) | PEX v -> Var ("x"^(string_of_int (C2Ml.index v))) | PEmul(p1,p2) -> let p1 = expr_to_term p1 in let p2 = expr_to_term p2 in let res = Mul(p1,p2) in res | PEadd(p1,p2) -> Add(expr_to_term p1, expr_to_term p2) | PEsub(p1,p2) -> Sub(expr_to_term p1, expr_to_term p2) | PEpow(p,n) -> Pow(expr_to_term p , C2Ml.n n) | PEopp p -> Opp (expr_to_term p) end open M open List open Mutils let rec canonical_sum_to_string = function s -> failwith "not implemented" let print_canonical_sum m = Format.print_string (canonical_sum_to_string m) let print_list_term o l = output_string o "print_list_term\n"; List.iter (fun (e,k) -> Printf.fprintf o "q: %s %s ;" (string_of_poly (poly_of_term (expr_to_term e))) (match k with Mc.Equal -> "= " | Mc.Strict -> "> " | Mc.NonStrict -> ">= " | _ -> failwith "not_implemented")) (List.map (fun (e, o) -> Mc.denorm e , o) l) ; output_string o "\n" let partition_expr l = let rec f i = function | [] -> ([],[],[]) | (e,k)::l -> let (eq,ge,neq) = f (i+1) l in match k with | Mc.Equal -> ((e,i)::eq,ge,neq) | Mc.NonStrict -> (eq,(e,Axiom_le i)::ge,neq) | Mc.Strict -> (* e > 0 == e >= 0 /\ e <> 0 *) (eq, (e,Axiom_lt i)::ge,(e,Axiom_lt i)::neq) | Mc.NonEqual -> (eq,ge,(e,Axiom_eq i)::neq) (* Not quite sure -- Coq interface has changed *) in f 0 l let rec sets_of_list l = match l with | [] -> [[]] | e::l -> let s = sets_of_list l in s@(List.map (fun s0 -> e::s0) s) (* The exploration is probably not complete - for simple cases, it works... *) let real_nonlinear_prover d l = let l = List.map (fun (e,op) -> (Mc.denorm e,op)) l in try let (eq,ge,neq) = partition_expr l in let rec elim_const = function [] -> [] | (x,y)::l -> let p = poly_of_term (expr_to_term x) in if poly_isconst p then elim_const l else (p,y)::(elim_const l) in let eq = elim_const eq in let peq = List.map fst eq in let pge = List.map (fun (e,psatz) -> poly_of_term (expr_to_term e),psatz) ge in let monoids = List.map (fun m -> (List.fold_right (fun (p,kd) y -> let p = poly_of_term (expr_to_term p) in match kd with | Axiom_lt i -> poly_mul p y | Axiom_eq i -> poly_mul (poly_pow p 2) y | _ -> failwith "monoids") m (poly_const (Int 1)) , map snd m)) (sets_of_list neq) in let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d -> list_try_find (fun m -> let (ci,cc) = real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in (ci,cc,snd m)) monoids) 0 in let proofs_ideal = map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i)) cert_ideal (List.map snd eq) in let proofs_cone = map term_of_sos cert_cone in let proof_ne = let (neq , lt) = List.partition (function Axiom_eq _ -> true | _ -> false ) monoid in let sq = match (List.map (function Axiom_eq i -> i | _ -> failwith "error") neq) with | [] -> Rational_lt (Int 1) | l -> Monoid l in List.fold_right (fun x y -> Product(x,y)) lt sq in let proof = list_fold_right_elements (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in S (Some proof) with | Sos_lib.TooDeep -> S None | x when x <> Sys.Break -> F (Printexc.to_string x) (* This is somewhat buggy, over Z, strict inequality vanish... *) let pure_sos l = let l = List.map (fun (e,o) -> Mc.denorm e, o) l in (* If there is no strict inequality, I should nonetheless be able to try something - over Z > is equivalent to -1 >= *) try let l = List.combine l (interval 0 (length l -1)) in let (lt,i) = try (List.find (fun (x,_) -> snd x = Mc.Strict) l) with Not_found -> List.hd l in let plt = poly_neg (poly_of_term (expr_to_term (fst lt))) in let (n,polys) = sumofsquares plt in (* n * (ci * pi^2) *) let pos = Product (Rational_lt n, List.fold_right (fun (c,p) rst -> Sum (Product (Rational_lt c, Square (term_of_poly p)), rst)) polys (Rational_lt (Int 0))) in let proof = Sum(Axiom_lt i, pos) in (* let s,proof' = scale_certificate proof in let cert = snd (cert_of_pos proof') in *) S (Some proof) with (* | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *) | x when x <> Sys.Break -> (* May be that could be refined *) S None let run_prover prover pb = match prover with | "real_nonlinear_prover", Some d -> real_nonlinear_prover d pb | "pure_sos", None -> pure_sos pb | prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1) let output_csdp_certificate o = function | S None -> output_string o "S None" | S (Some p) -> Printf.fprintf o "S (Some %a)" output_psatz p | F s -> Printf.fprintf o "F %s" s let main () = try let (prover,poly) = (input_value stdin : provername * micromega_polys) in let cert = run_prover prover poly in (* Printf.fprintf chan "%a -> %a" print_list_term poly output_csdp_certificate cert ; close_out chan ; *) output_value stdout (cert:csdp_certificate); flush stdout ; Marshal.to_channel chan (cert:csdp_certificate) [] ; flush chan ; exit 0 with any -> (Printf.fprintf chan "error %s" (Printexc.to_string any) ; exit 1) ;; let _ = main () in () (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.4pl4/plugins/micromega/sos_types.ml0000644000175000017500000000535412326224777017650 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* output_string o "0" | Const n -> output_string o (string_of_num n) | Var n -> Printf.fprintf o "v%s" n | Inv t -> Printf.fprintf o "1/(%a)" output_term t | Opp t -> Printf.fprintf o "- (%a)" output_term t | Add(t1,t2) -> Printf.fprintf o "(%a)+(%a)" output_term t1 output_term t2 | Sub(t1,t2) -> Printf.fprintf o "(%a)-(%a)" output_term t1 output_term t2 | Mul(t1,t2) -> Printf.fprintf o "(%a)*(%a)" output_term t1 output_term t2 | Div(t1,t2) -> Printf.fprintf o "(%a)/(%a)" output_term t1 output_term t2 | Pow(t1,i) -> Printf.fprintf o "(%a)^(%i)" output_term t1 i (* ------------------------------------------------------------------------- *) (* Data structure for Positivstellensatz refutations. *) (* ------------------------------------------------------------------------- *) type positivstellensatz = Axiom_eq of int | Axiom_le of int | Axiom_lt of int | Rational_eq of num | Rational_le of num | Rational_lt of num | Square of term | Monoid of int list | Eqmul of term * positivstellensatz | Sum of positivstellensatz * positivstellensatz | Product of positivstellensatz * positivstellensatz;; let rec output_psatz o = function | Axiom_eq i -> Printf.fprintf o "Aeq(%i)" i | Axiom_le i -> Printf.fprintf o "Ale(%i)" i | Axiom_lt i -> Printf.fprintf o "Alt(%i)" i | Rational_eq n -> Printf.fprintf o "eq(%s)" (string_of_num n) | Rational_le n -> Printf.fprintf o "le(%s)" (string_of_num n) | Rational_lt n -> Printf.fprintf o "lt(%s)" (string_of_num n) | Square t -> Printf.fprintf o "(%a)^2" output_term t | Monoid l -> Printf.fprintf o "monoid" | Eqmul (t,ps) -> Printf.fprintf o "%a * %a" output_term t output_psatz ps | Sum (t1,t2) -> Printf.fprintf o "%a + %a" output_psatz t1 output_psatz t2 | Product (t1,t2) -> Printf.fprintf o "%a * %a" output_psatz t1 output_psatz t2 coq-8.4pl4/plugins/micromega/RingMicromega.v0000644000175000017500000007550612326224777020206 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R -> R. Variable ropp : R -> R. Variables req rle rlt : R -> R -> Prop. Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (rplus x y). Notation "x * y " := (rtimes x y). Notation "x - y " := (rminus x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). Notation "x ~= y" := (~ req x y). Notation "x <= y" := (rle x y). Notation "x < y" := (rlt x y). (* Assume we have a type of coefficients C and a morphism from C to R *) Variable C : Type. Variables cO cI : C. Variables cplus ctimes cminus: C -> C -> C. Variable copp : C -> C. Variables ceqb cleb : C -> C -> bool. Variable phi : C -> R. (* Power coefficients *) Variable E : Set. (* the type of exponents *) Variable pow_phi : N -> E. Variable rpow : R -> E -> R. Notation "[ x ]" := (phi x). Notation "x [=] y" := (ceqb x y). Notation "x [<=] y" := (cleb x y). (* Let's collect all hypotheses in addition to the ordered ring axioms into one structure *) Record SORaddon := mk_SOR_addon { SORrm : ring_morph 0 1 rplus rtimes rminus ropp req cO cI cplus ctimes cminus copp ceqb phi; SORpower : power_theory rI rtimes req pow_phi rpow; SORcneqb_morph : forall x y : C, x [=] y = false -> [x] ~= [y]; SORcleb_morph : forall x y : C, x [<=] y = true -> [x] <= [y] }. Variable addon : SORaddon. Add Relation R req reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ ) symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ ) transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ ) as micomega_sor_setoid. Add Morphism rplus with signature req ==> req ==> req as rplus_morph. Proof. exact sor.(SORplus_wd). Qed. Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. Proof. exact sor.(SORtimes_wd). Qed. Add Morphism ropp with signature req ==> req as ropp_morph. Proof. exact sor.(SORopp_wd). Qed. Add Morphism rle with signature req ==> req ==> iff as rle_morph. Proof. exact sor.(SORle_wd). Qed. Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. Proof. exact sor.(SORlt_wd). Qed. Add Morphism rminus with signature req ==> req ==> req as rminus_morph. Proof. exact (rminus_morph sor). (* We already proved that minus is a morphism in OrderedRing.v *) Qed. Definition cneqb (x y : C) := negb (ceqb x y). Definition cltb (x y : C) := (cleb x y) && (cneqb x y). Notation "x [~=] y" := (cneqb x y). Notation "x [<] y" := (cltb x y). Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption. Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption. Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H]. Lemma cleb_sound : forall x y : C, x [<=] y = true -> [x] <= [y]. Proof. exact addon.(SORcleb_morph). Qed. Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y]. Proof. intros x y H1. apply addon.(SORcneqb_morph). unfold cneqb, negb in H1. destruct (ceqb x y); now try discriminate. Qed. Lemma cltb_sound : forall x y : C, x [<] y = true -> [x] < [y]. Proof. intros x y H. unfold cltb in H. apply andb_prop in H. destruct H as [H1 H2]. apply cleb_sound in H1. apply cneqb_sound in H2. apply <- (Rlt_le_neq sor). now split. Qed. (* Begin Micromega *) Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *) Definition PolEnv := Env R. (* For interpreting PolC *) Definition eval_pol (env : PolEnv) (p:PolC) : R := Pphi rplus rtimes phi env p. Inductive Op1 : Set := (* relations with 0 *) | Equal (* == 0 *) | NonEqual (* ~= 0 *) | Strict (* > 0 *) | NonStrict (* >= 0 *). Definition NFormula := (PolC * Op1)%type. (* normalized formula *) Definition eval_op1 (o : Op1) : R -> Prop := match o with | Equal => fun x => x == 0 | NonEqual => fun x : R => x ~= 0 | Strict => fun x : R => 0 < x | NonStrict => fun x : R => 0 <= x end. Definition eval_nformula (env : PolEnv) (f : NFormula) : Prop := let (p, op) := f in eval_op1 op (eval_pol env p). (** Rule of "signs" for addition and multiplication. An arbitrary result is coded buy None. *) Definition OpMult (o o' : Op1) : option Op1 := match o with | Equal => Some Equal | NonStrict => match o' with | Equal => Some Equal | NonEqual => None | Strict => Some NonStrict | NonStrict => Some NonStrict end | Strict => match o' with | NonEqual => None | _ => Some o' end | NonEqual => match o' with | Equal => Some Equal | NonEqual => Some NonEqual | _ => None end end. Definition OpAdd (o o': Op1) : option Op1 := match o with | Equal => Some o' | NonStrict => match o' with | Strict => Some Strict | NonEqual => None | _ => Some NonStrict end | Strict => match o' with | NonEqual => None | _ => Some Strict end | NonEqual => match o' with | Equal => Some NonEqual | _ => None end end. Lemma OpMult_sound : forall (o o' om: Op1) (x y : R), eval_op1 o x -> eval_op1 o' y -> OpMult o o' = Some om -> eval_op1 om (x * y). Proof. unfold eval_op1; destruct o; simpl; intros o' om x y H1 H2 H3. (* x == 0 *) inversion H3. rewrite H1. now rewrite (Rtimes_0_l sor). (* x ~= 0 *) destruct o' ; inversion H3. (* y == 0 *) rewrite H2. now rewrite (Rtimes_0_r sor). (* y ~= 0 *) apply (Rtimes_neq_0 sor) ; auto. (* 0 < x *) destruct o' ; inversion H3. (* y == 0 *) rewrite H2; now rewrite (Rtimes_0_r sor). (* 0 < y *) now apply (Rtimes_pos_pos sor). (* 0 <= y *) apply (Rtimes_nonneg_nonneg sor); [le_less | assumption]. (* 0 <= x *) destruct o' ; inversion H3. (* y == 0 *) rewrite H2; now rewrite (Rtimes_0_r sor). (* 0 < y *) apply (Rtimes_nonneg_nonneg sor); [assumption | le_less ]. (* 0 <= y *) now apply (Rtimes_nonneg_nonneg sor). Qed. Lemma OpAdd_sound : forall (o o' oa : Op1) (e e' : R), eval_op1 o e -> eval_op1 o' e' -> OpAdd o o' = Some oa -> eval_op1 oa (e + e'). Proof. unfold eval_op1; destruct o; simpl; intros o' oa e e' H1 H2 Hoa. (* e == 0 *) inversion Hoa. rewrite <- H0. destruct o' ; rewrite H1 ; now rewrite (Rplus_0_l sor). (* e ~= 0 *) destruct o'. (* e' == 0 *) inversion Hoa. rewrite H2. now rewrite (Rplus_0_r sor). (* e' ~= 0 *) discriminate. (* 0 < e' *) discriminate. (* 0 <= e' *) discriminate. (* 0 < e *) destruct o'. (* e' == 0 *) inversion Hoa. rewrite H2. now rewrite (Rplus_0_r sor). (* e' ~= 0 *) discriminate. (* 0 < e' *) inversion Hoa. now apply (Rplus_pos_pos sor). (* 0 <= e' *) inversion Hoa. now apply (Rplus_pos_nonneg sor). (* 0 <= e *) destruct o'. (* e' == 0 *) inversion Hoa. now rewrite H2, (Rplus_0_r sor). (* e' ~= 0 *) discriminate. (* 0 < e' *) inversion Hoa. now apply (Rplus_nonneg_pos sor). (* 0 <= e' *) inversion Hoa. now apply (Rplus_nonneg_nonneg sor). Qed. Inductive Psatz : Type := | PsatzIn : nat -> Psatz | PsatzSquare : PolC -> Psatz | PsatzMulC : PolC -> Psatz -> Psatz | PsatzMulE : Psatz -> Psatz -> Psatz | PsatzAdd : Psatz -> Psatz -> Psatz | PsatzC : C -> Psatz | PsatzZ : Psatz. (** Given a list [l] of NFormula and an extended polynomial expression [e], if [eval_Psatz l e] succeeds (= Some f) then [f] is a logic consequence of the conjunction of the formulae in l. Moreover, the polynomial expression is obtained by replacing the (PsatzIn n) by the nth polynomial expression in [l] and the sign is computed by the "rule of sign" *) (* Might be defined elsewhere *) Definition map_option (A B:Type) (f : A -> option B) (o : option A) : option B := match o with | None => None | Some x => f x end. Arguments map_option [A B] f o. Definition map_option2 (A B C : Type) (f : A -> B -> option C) (o: option A) (o': option B) : option C := match o , o' with | None , _ => None | _ , None => None | Some x , Some x' => f x x' end. Arguments map_option2 [A B C] f o o'. Definition Rops_wd := mk_reqe (*rplus rtimes ropp req*) sor.(SORplus_wd) sor.(SORtimes_wd) sor.(SORopp_wd). Definition pexpr_times_nformula (e: PolC) (f : NFormula) : option NFormula := let (ef,o) := f in match o with | Equal => Some (Pmul cO cI cplus ctimes ceqb e ef , Equal) | _ => None end. Definition nformula_times_nformula (f1 f2 : NFormula) : option NFormula := let (e1,o1) := f1 in let (e2,o2) := f2 in map_option (fun x => (Some (Pmul cO cI cplus ctimes ceqb e1 e2,x))) (OpMult o1 o2). Definition nformula_plus_nformula (f1 f2 : NFormula) : option NFormula := let (e1,o1) := f1 in let (e2,o2) := f2 in map_option (fun x => (Some (Padd cO cplus ceqb e1 e2,x))) (OpAdd o1 o2). Fixpoint eval_Psatz (l : list NFormula) (e : Psatz) {struct e} : option NFormula := match e with | PsatzIn n => Some (nth n l (Pc cO, Equal)) | PsatzSquare e => Some (Psquare cO cI cplus ctimes ceqb e , NonStrict) | PsatzMulC re e => map_option (pexpr_times_nformula re) (eval_Psatz l e) | PsatzMulE f1 f2 => map_option2 nformula_times_nformula (eval_Psatz l f1) (eval_Psatz l f2) | PsatzAdd f1 f2 => map_option2 nformula_plus_nformula (eval_Psatz l f1) (eval_Psatz l f2) | PsatzC c => if cltb cO c then Some (Pc c, Strict) else None (* This could be 0, or <> 0 -- but these cases are useless *) | PsatzZ => Some (Pc cO, Equal) (* Just to make life easier *) end. Lemma pexpr_times_nformula_correct : forall (env: PolEnv) (e: PolC) (f f' : NFormula), eval_nformula env f -> pexpr_times_nformula e f = Some f' -> eval_nformula env f'. Proof. unfold pexpr_times_nformula. destruct f. intros. destruct o ; inversion H0 ; try discriminate. simpl in *. unfold eval_pol in *. rewrite (Pmul_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). rewrite H. apply (Rtimes_0_r sor). Qed. Lemma nformula_times_nformula_correct : forall (env:PolEnv) (f1 f2 f : NFormula), eval_nformula env f1 -> eval_nformula env f2 -> nformula_times_nformula f1 f2 = Some f -> eval_nformula env f. Proof. unfold nformula_times_nformula. destruct f1 ; destruct f2. case_eq (OpMult o o0) ; simpl ; try discriminate. intros. inversion H2 ; simpl. unfold eval_pol. destruct o1; simpl; rewrite (Pmul_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); apply OpMult_sound with (3:= H);assumption. Qed. Lemma nformula_plus_nformula_correct : forall (env:PolEnv) (f1 f2 f : NFormula), eval_nformula env f1 -> eval_nformula env f2 -> nformula_plus_nformula f1 f2 = Some f -> eval_nformula env f. Proof. unfold nformula_plus_nformula. destruct f1 ; destruct f2. case_eq (OpAdd o o0) ; simpl ; try discriminate. intros. inversion H2 ; simpl. unfold eval_pol. destruct o1; simpl; rewrite (Padd_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); apply OpAdd_sound with (3:= H);assumption. Qed. Lemma eval_Psatz_Sound : forall (l : list NFormula) (env : PolEnv), (forall (f : NFormula), In f l -> eval_nformula env f) -> forall (e : Psatz) (f : NFormula), eval_Psatz l e = Some f -> eval_nformula env f. Proof. induction e. (* PsatzIn *) simpl ; intros. destruct (nth_in_or_default n l (Pc cO, Equal)). (* index is in bounds *) apply H ; congruence. (* index is out-of-bounds *) inversion H0. rewrite e. simpl. now apply addon.(SORrm).(morph0). (* PsatzSquare *) simpl. intros. inversion H0. simpl. unfold eval_pol. rewrite (Psquare_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); now apply (Rtimes_square_nonneg sor). (* PsatzMulC *) simpl. intro. case_eq (eval_Psatz l e) ; simpl ; intros. apply IHe in H0. apply pexpr_times_nformula_correct with (1:=H0) (2:= H1). discriminate. (* PsatzMulC *) simpl ; intro. case_eq (eval_Psatz l e1) ; simpl ; try discriminate. case_eq (eval_Psatz l e2) ; simpl ; try discriminate. intros. apply IHe1 in H1. apply IHe2 in H0. apply (nformula_times_nformula_correct env n0 n) ; assumption. (* PsatzAdd *) simpl ; intro. case_eq (eval_Psatz l e1) ; simpl ; try discriminate. case_eq (eval_Psatz l e2) ; simpl ; try discriminate. intros. apply IHe1 in H1. apply IHe2 in H0. apply (nformula_plus_nformula_correct env n0 n) ; assumption. (* PsatzC *) simpl. intro. case_eq (cO [<] c). intros. inversion H1. simpl. rewrite <- addon.(SORrm).(morph0). now apply cltb_sound. discriminate. (* PsatzZ *) simpl. intros. inversion H0. simpl. apply addon.(SORrm).(morph0). Qed. Fixpoint ge_bool (n m : nat) : bool := match n with | O => match m with | O => true | S _ => false end | S n => match m with | O => true | S m => ge_bool n m end end. Lemma ge_bool_cases : forall n m, (if ge_bool n m then n >= m else n < m)%nat. Proof. induction n; destruct m ; simpl; auto with arith. specialize (IHn m). destruct (ge_bool); auto with arith. Qed. Fixpoint xhyps_of_psatz (base:nat) (acc : list nat) (prf : Psatz) : list nat := match prf with | PsatzC _ | PsatzZ | PsatzSquare _ => acc | PsatzMulC _ prf => xhyps_of_psatz base acc prf | PsatzAdd e1 e2 | PsatzMulE e1 e2 => xhyps_of_psatz base (xhyps_of_psatz base acc e2) e1 | PsatzIn n => if ge_bool n base then (n::acc) else acc end. Fixpoint nhyps_of_psatz (prf : Psatz) : list nat := match prf with | PsatzC _ | PsatzZ | PsatzSquare _ => nil | PsatzMulC _ prf => nhyps_of_psatz prf | PsatzAdd e1 e2 | PsatzMulE e1 e2 => nhyps_of_psatz e1 ++ nhyps_of_psatz e2 | PsatzIn n => n :: nil end. Fixpoint extract_hyps (l: list NFormula) (ln : list nat) : list NFormula := match ln with | nil => nil | n::ln => nth n l (Pc cO, Equal) :: extract_hyps l ln end. Lemma extract_hyps_app : forall l ln1 ln2, extract_hyps l (ln1 ++ ln2) = (extract_hyps l ln1) ++ (extract_hyps l ln2). Proof. induction ln1. reflexivity. simpl. intros. rewrite IHln1. reflexivity. Qed. Ltac inv H := inversion H ; try subst ; clear H. Lemma nhyps_of_psatz_correct : forall (env : PolEnv) (e:Psatz) (l : list NFormula) (f: NFormula), eval_Psatz l e = Some f -> ((forall f', In f' (extract_hyps l (nhyps_of_psatz e)) -> eval_nformula env f') -> eval_nformula env f). Proof. induction e ; intros. (*PsatzIn*) simpl in *. apply H0. intuition congruence. (* PsatzSquare *) simpl in *. inv H. simpl. unfold eval_pol. rewrite (Psquare_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); now apply (Rtimes_square_nonneg sor). (* PsatzMulC *) simpl in *. case_eq (eval_Psatz l e). intros. rewrite H1 in H. simpl in H. apply pexpr_times_nformula_correct with (2:= H). apply IHe with (1:= H1); auto. intros. rewrite H1 in H. simpl in H ; discriminate. (* PsatzMulE *) simpl in *. revert H. case_eq (eval_Psatz l e1). case_eq (eval_Psatz l e2) ; simpl ; intros. apply nformula_times_nformula_correct with (3:= H2). apply IHe1 with (1:= H1) ; auto. intros. apply H0. rewrite extract_hyps_app. apply in_or_app. tauto. apply IHe2 with (1:= H) ; auto. intros. apply H0. rewrite extract_hyps_app. apply in_or_app. tauto. discriminate. simpl. discriminate. (* PsatzAdd *) simpl in *. revert H. case_eq (eval_Psatz l e1). case_eq (eval_Psatz l e2) ; simpl ; intros. apply nformula_plus_nformula_correct with (3:= H2). apply IHe1 with (1:= H1) ; auto. intros. apply H0. rewrite extract_hyps_app. apply in_or_app. tauto. apply IHe2 with (1:= H) ; auto. intros. apply H0. rewrite extract_hyps_app. apply in_or_app. tauto. discriminate. simpl. discriminate. (* PsatzC *) simpl in H. case_eq (cO [<] c). intros. rewrite H1 in H. inv H. unfold eval_nformula. simpl. rewrite <- addon.(SORrm).(morph0). now apply cltb_sound. intros. rewrite H1 in H. discriminate. (* PsatzZ *) simpl in *. inv H. unfold eval_nformula. simpl. apply addon.(SORrm).(morph0). Qed. (* roughly speaking, normalise_pexpr_correct is a proof of forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *) (*****) Definition paddC := PaddC cplus. Definition psubC := PsubC cminus. Definition PsubC_ok : forall c P env, eval_pol env (psubC P c) == eval_pol env P - [c] := let Rops_wd := mk_reqe (*rplus rtimes ropp req*) sor.(SORplus_wd) sor.(SORtimes_wd) sor.(SORopp_wd) in PsubC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm). Definition PaddC_ok : forall c P env, eval_pol env (paddC P c) == eval_pol env P + [c] := let Rops_wd := mk_reqe (*rplus rtimes ropp req*) sor.(SORplus_wd) sor.(SORtimes_wd) sor.(SORopp_wd) in PaddC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm). (* Check that a formula f is inconsistent by normalizing and comparing the resulting constant with 0 *) Definition check_inconsistent (f : NFormula) : bool := let (e, op) := f in match e with | Pc c => match op with | Equal => cneqb c cO | NonStrict => c [<] cO | Strict => c [<=] cO | NonEqual => c [=] cO end | _ => false (* not a constant *) end. Lemma check_inconsistent_sound : forall (p : PolC) (op : Op1), check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pol env p). Proof. intros p op H1 env. unfold check_inconsistent in H1. destruct op; simpl ; (*****) destruct p ; simpl; try discriminate H1; try rewrite <- addon.(SORrm).(morph0); trivial. now apply cneqb_sound. apply addon.(SORrm).(morph_eq) in H1. congruence. apply cleb_sound in H1. now apply -> (Rle_ngt sor). apply cltb_sound in H1. now apply -> (Rlt_nge sor). Qed. Definition check_normalised_formulas : list NFormula -> Psatz -> bool := fun l cm => match eval_Psatz l cm with | None => false | Some f => check_inconsistent f end. Lemma checker_nf_sound : forall (l : list NFormula) (cm : Psatz), check_normalised_formulas l cm = true -> forall env : PolEnv, make_impl (eval_nformula env) l False. Proof. intros l cm H env. unfold check_normalised_formulas in H. revert H. case_eq (eval_Psatz l cm) ; [|discriminate]. intros nf. intros. rewrite <- make_conj_impl. intro. assert (H1' := make_conj_in _ _ H1). assert (Hnf := @eval_Psatz_Sound _ _ H1' _ _ H). destruct nf. apply (@check_inconsistent_sound _ _ H0 env Hnf). Qed. (** Normalisation of formulae **) Inductive Op2 : Set := (* binary relations *) | OpEq | OpNEq | OpLe | OpGe | OpLt | OpGt. Definition eval_op2 (o : Op2) : R -> R -> Prop := match o with | OpEq => req | OpNEq => fun x y : R => x ~= y | OpLe => rle | OpGe => fun x y : R => y <= x | OpLt => fun x y : R => x < y | OpGt => fun x y : R => y < x end. Definition eval_pexpr (l : PolEnv) (pe : PExpr C) : R := PEeval rplus rtimes rminus ropp phi pow_phi rpow l pe. Record Formula (T:Type) : Type := { Flhs : PExpr T; Fop : Op2; Frhs : PExpr T }. Definition eval_formula (env : PolEnv) (f : Formula C) : Prop := let (lhs, op, rhs) := f in (eval_op2 op) (eval_pexpr env lhs) (eval_pexpr env rhs). (* We normalize Formulas by moving terms to one side *) Definition norm := norm_aux cO cI cplus ctimes cminus copp ceqb. Definition psub := Psub cO cplus cminus copp ceqb. Definition padd := Padd cO cplus ceqb. Definition normalise (f : Formula C) : NFormula := let (lhs, op, rhs) := f in let lhs := norm lhs in let rhs := norm rhs in match op with | OpEq => (psub lhs rhs, Equal) | OpNEq => (psub lhs rhs, NonEqual) | OpLe => (psub rhs lhs, NonStrict) | OpGe => (psub lhs rhs, NonStrict) | OpGt => (psub lhs rhs, Strict) | OpLt => (psub rhs lhs, Strict) end. Definition negate (f : Formula C) : NFormula := let (lhs, op, rhs) := f in let lhs := norm lhs in let rhs := norm rhs in match op with | OpEq => (psub rhs lhs, NonEqual) | OpNEq => (psub rhs lhs, Equal) | OpLe => (psub lhs rhs, Strict) (* e <= e' == ~ e > e' *) | OpGe => (psub rhs lhs, Strict) | OpGt => (psub rhs lhs, NonStrict) | OpLt => (psub lhs rhs, NonStrict) end. Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) == eval_pol env lhs - eval_pol env rhs. Proof. intros. apply (Psub_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). Qed. Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd lhs rhs) == eval_pol env lhs + eval_pol env rhs. Proof. intros. apply (Padd_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). Qed. Lemma eval_pol_norm : forall env lhs, eval_pexpr env lhs == eval_pol env (norm lhs). Proof. intros. apply (norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm) addon.(SORpower) ). Qed. Theorem normalise_sound : forall (env : PolEnv) (f : Formula C), eval_formula env f -> eval_nformula env (normalise f). Proof. intros env f H; destruct f as [lhs op rhs]; simpl in *. destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm. now apply <- (Rminus_eq_0 sor). intros H1. apply -> (Rminus_eq_0 sor) in H1. now apply H. now apply -> (Rle_le_minus sor). now apply -> (Rle_le_minus sor). now apply -> (Rlt_lt_minus sor). now apply -> (Rlt_lt_minus sor). Qed. Theorem negate_correct : forall (env : PolEnv) (f : Formula C), eval_formula env f <-> ~ (eval_nformula env (negate f)). Proof. intros env f; destruct f as [lhs op rhs]; simpl. destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm. symmetry. rewrite (Rminus_eq_0 sor). split; intro H; [symmetry; now apply -> (Req_dne sor) | symmetry in H; now apply <- (Req_dne sor)]. rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor). rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). Qed. (** Another normalisation - this is used for cnf conversion **) Definition xnormalise (t:Formula C) : list (NFormula) := let (lhs,o,rhs) := t in let lhs := norm lhs in let rhs := norm rhs in match o with | OpEq => (psub lhs rhs, Strict)::(psub rhs lhs , Strict)::nil | OpNEq => (psub lhs rhs,Equal) :: nil | OpGt => (psub rhs lhs,NonStrict) :: nil | OpLt => (psub lhs rhs,NonStrict) :: nil | OpGe => (psub rhs lhs , Strict) :: nil | OpLe => (psub lhs rhs ,Strict) :: nil end. Require Import Tauto. Definition cnf_normalise (t:Formula C) : cnf (NFormula) := List.map (fun x => x::nil) (xnormalise t). Add Ring SORRing : sor.(SORrt). Lemma cnf_normalise_correct : forall env t, eval_cnf eval_nformula env (cnf_normalise t) -> eval_formula env t. Proof. unfold cnf_normalise, xnormalise ; simpl ; intros env t. unfold eval_cnf, eval_clause. destruct t as [lhs o rhs]; case_eq o ; simpl; repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; generalize (eval_pexpr env lhs); generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros. (**) apply sor.(SORle_antisymm). rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. now rewrite <- (Rminus_eq_0 sor). rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. Qed. Definition xnegate (t:Formula C) : list (NFormula) := let (lhs,o,rhs) := t in let lhs := norm lhs in let rhs := norm rhs in match o with | OpEq => (psub lhs rhs,Equal) :: nil | OpNEq => (psub lhs rhs ,Strict)::(psub rhs lhs,Strict)::nil | OpGt => (psub lhs rhs,Strict) :: nil | OpLt => (psub rhs lhs,Strict) :: nil | OpGe => (psub lhs rhs,NonStrict) :: nil | OpLe => (psub rhs lhs,NonStrict) :: nil end. Definition cnf_negate (t:Formula C) : cnf (NFormula) := List.map (fun x => x::nil) (xnegate t). Lemma cnf_negate_correct : forall env t, eval_cnf eval_nformula env (cnf_negate t) -> ~ eval_formula env t. Proof. unfold cnf_negate, xnegate ; simpl ; intros env t. unfold eval_cnf, eval_clause. destruct t as [lhs o rhs]; case_eq o ; simpl; repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; generalize (eval_pexpr env lhs); generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros ; intuition. (**) apply H0. rewrite H1 ; ring. (**) apply H1. apply sor.(SORle_antisymm). rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. (**) apply H0. now rewrite (Rle_le_minus sor) in H1. apply H0. now rewrite (Rle_le_minus sor) in H1. apply H0. now rewrite (Rlt_lt_minus sor) in H1. apply H0. now rewrite (Rlt_lt_minus sor) in H1. Qed. Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). Proof. intros. destruct d ; simpl. generalize (eval_pol env p); intros. destruct o ; simpl. apply (Req_em sor r 0). destruct (Req_em sor r 0) ; tauto. rewrite <- (Rle_ngt sor r 0). generalize (Rle_gt_cases sor r 0). tauto. rewrite <- (Rlt_nge sor r 0). generalize (Rle_gt_cases sor 0 r). tauto. Qed. (** Reverse transformation *) Fixpoint xdenorm (jmp : positive) (p: Pol C) : PExpr C := match p with | Pc c => PEc c | Pinj j p => xdenorm (Pos.add j jmp ) p | PX p j q => PEadd (PEmul (xdenorm jmp p) (PEpow (PEX _ jmp) (Npos j))) (xdenorm (Pos.succ jmp) q) end. Lemma xdenorm_correct : forall p i env, eval_pol (jump i env) p == eval_pexpr env (xdenorm (Pos.succ i) p). Proof. unfold eval_pol. induction p. simpl. reflexivity. (* Pinj *) simpl. intros. rewrite Pos.add_succ_r. rewrite <- IHp. symmetry. rewrite Pos.add_comm. rewrite Pjump_add. reflexivity. (* PX *) simpl. intros. rewrite <- IHp1, <- IHp2. unfold Env.tail , Env.hd. rewrite <- Pjump_add. rewrite Pos.add_1_r. unfold Env.nth. unfold jump at 2. rewrite <- Pos.add_1_l. rewrite addon.(SORpower).(rpow_pow_N). unfold pow_N. ring. Qed. Definition denorm (p : Pol C) := xdenorm xH p. Lemma denorm_correct : forall p env, eval_pol env p == eval_pexpr env (denorm p). Proof. unfold denorm. induction p. reflexivity. simpl. rewrite Pos.add_1_r. apply xdenorm_correct. simpl. intros. rewrite IHp1. unfold Env.tail. rewrite xdenorm_correct. change (Pos.succ xH) with 2%positive. rewrite addon.(SORpower).(rpow_pow_N). simpl. reflexivity. Qed. (** Sometimes it is convenient to make a distinction between "syntactic" coefficients and "real" coefficients that are used to actually compute *) Variable S : Type. Variable C_of_S : S -> C. Variable phiS : S -> R. Variable phi_C_of_S : forall c, phiS c = phi (C_of_S c). Fixpoint map_PExpr (e : PExpr S) : PExpr C := match e with | PEc c => PEc (C_of_S c) | PEX p => PEX _ p | PEadd e1 e2 => PEadd (map_PExpr e1) (map_PExpr e2) | PEsub e1 e2 => PEsub (map_PExpr e1) (map_PExpr e2) | PEmul e1 e2 => PEmul (map_PExpr e1) (map_PExpr e2) | PEopp e => PEopp (map_PExpr e) | PEpow e n => PEpow (map_PExpr e) n end. Definition map_Formula (f : Formula S) : Formula C := let (l,o,r) := f in Build_Formula (map_PExpr l) o (map_PExpr r). Definition eval_sexpr (env : PolEnv) (e : PExpr S) : R := PEeval rplus rtimes rminus ropp phiS pow_phi rpow env e. Definition eval_sformula (env : PolEnv) (f : Formula S) : Prop := let (lhs, op, rhs) := f in (eval_op2 op) (eval_sexpr env lhs) (eval_sexpr env rhs). Lemma eval_pexprSC : forall env s, eval_sexpr env s = eval_pexpr env (map_PExpr s). Proof. unfold eval_pexpr, eval_sexpr. induction s ; simpl ; try (rewrite IHs1 ; rewrite IHs2) ; try reflexivity. apply phi_C_of_S. rewrite IHs. reflexivity. rewrite IHs. reflexivity. Qed. (** equality migth be (too) strong *) Lemma eval_formulaSC : forall env f, eval_sformula env f = eval_formula env (map_Formula f). Proof. destruct f. simpl. repeat rewrite eval_pexprSC. reflexivity. Qed. (** Some syntactic simplifications of expressions *) Definition simpl_cone (e:Psatz) : Psatz := match e with | PsatzSquare t => match t with | Pc c => if ceqb cO c then PsatzZ else PsatzC (ctimes c c) | _ => PsatzSquare t end | PsatzMulE t1 t2 => match t1 , t2 with | PsatzZ , x => PsatzZ | x , PsatzZ => PsatzZ | PsatzC c , PsatzC c' => PsatzC (ctimes c c') | PsatzC p1 , PsatzMulE (PsatzC p2) x => PsatzMulE (PsatzC (ctimes p1 p2)) x | PsatzC p1 , PsatzMulE x (PsatzC p2) => PsatzMulE (PsatzC (ctimes p1 p2)) x | PsatzMulE (PsatzC p2) x , PsatzC p1 => PsatzMulE (PsatzC (ctimes p1 p2)) x | PsatzMulE x (PsatzC p2) , PsatzC p1 => PsatzMulE (PsatzC (ctimes p1 p2)) x | PsatzC x , PsatzAdd y z => PsatzAdd (PsatzMulE (PsatzC x) y) (PsatzMulE (PsatzC x) z) | PsatzC c , _ => if ceqb cI c then t2 else PsatzMulE t1 t2 | _ , PsatzC c => if ceqb cI c then t1 else PsatzMulE t1 t2 | _ , _ => e end | PsatzAdd t1 t2 => match t1 , t2 with | PsatzZ , x => x | x , PsatzZ => x | x , y => PsatzAdd x y end | _ => e end. End Micromega. (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.4pl4/plugins/micromega/certificate.ml0000644000175000017500000011115512326224777020077 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a; number_to_num : 'a -> num; zero : 'a; unit : 'a; mult : 'a -> 'a -> 'a; eqb : 'a -> 'a -> bool } let z_spec = { bigint_to_number = Ml2C.bigint ; number_to_num = (fun x -> Big_int (C2Ml.z_big_int x)); zero = Mc.Z0; unit = Mc.Zpos Mc.XH; mult = Mc.Z.mul; eqb = Mc.zeq_bool } let q_spec = { bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH}); number_to_num = C2Ml.q_to_num; zero = {Mc.qnum = Mc.Z0;Mc.qden = Mc.XH}; unit = {Mc.qnum = (Mc.Zpos Mc.XH) ; Mc.qden = Mc.XH}; mult = Mc.qmult; eqb = Mc.qeq_bool } let r_spec = z_spec let dev_form n_spec p = let rec dev_form p = match p with | Mc.PEc z -> Poly.constant (n_spec.number_to_num z) | Mc.PEX v -> Poly.variable (C2Ml.positive v) | Mc.PEmul(p1,p2) -> let p1 = dev_form p1 in let p2 = dev_form p2 in Poly.product p1 p2 | Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2) | Mc.PEopp p -> Poly.uminus (dev_form p) | Mc.PEsub(p1,p2) -> Poly.addition (dev_form p1) (Poly.uminus (dev_form p2)) | Mc.PEpow(p,n) -> let p = dev_form p in let n = C2Ml.n n in let rec pow n = if n = 0 then Poly.constant (n_spec.number_to_num n_spec.unit) else Poly.product p (pow (n-1)) in pow n in dev_form p let monomial_to_polynomial mn = Monomial.fold (fun v i acc -> let v = Ml2C.positive v in let mn = if i = 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in if acc = Mc.PEc (Mc.Zpos Mc.XH) then mn else Mc.PEmul(mn,acc)) mn (Mc.PEc (Mc.Zpos Mc.XH)) let list_to_polynomial vars l = assert (List.for_all (fun x -> ceiling_num x =/ x) l); let var x = monomial_to_polynomial (List.nth vars x) in let rec xtopoly p i = function | [] -> p | c::l -> if c =/ (Int 0) then xtopoly p (i+1) l else let c = Mc.PEc (Ml2C.bigint (numerator c)) in let mn = if c = Mc.PEc (Mc.Zpos Mc.XH) then var i else Mc.PEmul (c,var i) in let p' = if p = Mc.PEc Mc.Z0 then mn else Mc.PEadd (mn, p) in xtopoly p' (i+1) l in xtopoly (Mc.PEc Mc.Z0) 0 l let rec fixpoint f x = let y' = f x in if y' = x then y' else fixpoint f y' let rec_simpl_cone n_spec e = let simpl_cone = Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in let rec rec_simpl_cone = function | Mc.PsatzMulE(t1, t2) -> simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2)) | Mc.PsatzAdd(t1,t2) -> simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2)) | x -> simpl_cone x in rec_simpl_cone e let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c type cone_prod = Const of cone | Ideal of cone *cone | Mult of cone * cone | Other of cone and cone = Mc.zWitness let factorise_linear_cone c = let rec cone_list c l = match c with | Mc.PsatzAdd (x,r) -> cone_list r (x::l) | _ -> c :: l in let factorise c1 c2 = match c1 , c2 with | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') -> if x = x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') -> if x = x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None | _ -> None in let rec rebuild_cone l pending = match l with | [] -> (match pending with | None -> Mc.PsatzZ | Some p -> p ) | e::l -> (match pending with | None -> rebuild_cone l (Some e) | Some p -> (match factorise p e with | None -> Mc.PsatzAdd(p, rebuild_cone l (Some e)) | Some f -> rebuild_cone l (Some f) ) ) in (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None) (* The binding with Fourier might be a bit obsolete -- how does it handle equalities ? *) (* Certificates are elements of the cone such that P = 0 *) (* To begin with, we search for certificates of the form: a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0 where pi >= 0 qi > 0 ai >= 0 bi >= 0 Sum bi + c >= 1 This is a linear problem: each monomial is considered as a variable. Hence, we can use fourier. The variable c is at index 0 *) open Mfourier (* fold_left followed by a rev ! *) let constrain_monomial mn l = let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in if mn = Monomial.const then { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; op = Eq ; cst = Big_int zero_big_int } else { coeffs = Vect.from_list ((Big_int zero_big_int):: (List.rev coeffs)) ; op = Eq ; cst = Big_int zero_big_int } let positivity l = let rec xpositivity i l = match l with | [] -> [] | (_,Mc.Equal)::l -> xpositivity (i+1) l | (_,_)::l -> {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; op = Ge ; cst = Int 0 } :: (xpositivity (i+1) l) in xpositivity 0 l let string_of_op = function | Mc.Strict -> "> 0" | Mc.NonStrict -> ">= 0" | Mc.Equal -> "= 0" | Mc.NonEqual -> "<> 0" (* If the certificate includes at least one strict inequality, the obtained polynomial can also be 0 *) let build_linear_system l = (* Gather the monomials: HINT add up of the polynomials ==> This does not work anymore *) let l' = List.map fst l in let module MonSet = Set.Make(Monomial) in let monomials = List.fold_left (fun acc p -> Poly.fold (fun m _ acc -> MonSet.add m acc) p acc) (MonSet.singleton Monomial.const) l' in (* For each monomial, compute a constraint *) let s0 = MonSet.fold (fun mn res -> (constrain_monomial mn l')::res) monomials [] in (* I need at least something strictly positive *) let strict = { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.map (fun (x,y) -> match y with Mc.Strict -> Big_int unit_big_int | _ -> Big_int zero_big_int) l)); op = Ge ; cst = Big_int unit_big_int } in (* Add the positivity constraint *) {coeffs = Vect.from_list ([Big_int unit_big_int]) ; op = Ge ; cst = Big_int zero_big_int}::(strict::(positivity l)@s0) let big_int_to_z = Ml2C.bigint (* For Q, this is a pity that the certificate has been scaled -- at a lower layer, certificates are using nums... *) let make_certificate n_spec (cert,li) = let bint_to_cst = n_spec.bigint_to_number in match cert with | [] -> failwith "empty_certificate" | e::cert' -> (* let cst = match compare_big_int e zero_big_int with | 0 -> Mc.PsatzZ | 1 -> Mc.PsatzC (bint_to_cst e) | _ -> failwith "positivity error" in *) let rec scalar_product cert l = match cert with | [] -> Mc.PsatzZ | c::cert -> match l with | [] -> failwith "make_certificate(1)" | i::l -> let r = scalar_product cert l in match compare_big_int c zero_big_int with | -1 -> Mc.PsatzAdd ( Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), r) | 0 -> r | _ -> Mc.PsatzAdd ( Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), r) in (factorise_linear_cone (simplify_cone n_spec (scalar_product cert' li))) exception Found of Monomial.t exception Strict let primal l = let vr = ref 0 in let module Mmn = Map.Make(Monomial) in let vect_of_poly map p = Poly.fold (fun mn vl (map,vect) -> if mn = Monomial.const then (map,vect) else let (mn,m) = try (Mmn.find mn map,map) with Not_found -> let res = (!vr, Mmn.add mn !vr map) in incr vr ; res in (m,if sign_num vl = 0 then vect else (mn,vl)::vect)) p (map,[]) in let op_op = function Mc.NonStrict -> Ge |Mc.Equal -> Eq | _ -> raise Strict in let cmp x y = Pervasives.compare (fst x) (fst y) in snd (List.fold_right (fun (p,op) (map,l) -> let (mp,vect) = vect_of_poly map p in let cstr = {coeffs = List.sort cmp vect; op = op_op op ; cst = minus_num (Poly.get Monomial.const p)} in (mp,cstr::l)) l (Mmn.empty,[])) let dual_raw_certificate (l: (Poly.t * Mc.op1) list) = (* List.iter (fun (p,op) -> Printf.fprintf stdout "%a %s 0\n" Poly.pp p (string_of_op op) ) l ; *) let sys = build_linear_system l in try match Fourier.find_point sys with | Inr _ -> None | Inl cert -> Some (rats_to_ints (Vect.to_list cert)) (* should not use rats_to_ints *) with x when Errors.noncritical x -> if debug then (Printf.printf "raw certificate %s" (Printexc.to_string x); flush stdout) ; None let raw_certificate l = try let p = primal l in match Fourier.find_point p with | Inr prf -> if debug then Printf.printf "AProof : %a\n" pp_proof prf ; let cert = List.map (fun (x,n) -> x+1,n) (fst (List.hd (Proof.mk_proof p prf))) in if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; Some (rats_to_ints (Vect.to_list cert)) | Inl _ -> None with Strict -> (* Fourier elimination should handle > *) dual_raw_certificate l let simple_linear_prover l = let (lc,li) = List.split l in match raw_certificate lc with | None -> None (* No certificate *) | Some cert -> Some (cert,li) let linear_prover n_spec l = let build_system n_spec l = let li = List.combine l (interval 0 (List.length l -1)) in let (l1,l') = List.partition (fun (x,_) -> if snd x = Mc.NonEqual then true else false) li in List.map (fun ((x,y),i) -> match y with Mc.NonEqual -> failwith "cannot happen" | y -> ((dev_form n_spec x, y),i)) l' in let l' = build_system n_spec l in simple_linear_prover (*n_spec*) l' let linear_prover n_spec l = try linear_prover n_spec l with x when x <> Sys.Break -> (print_string (Printexc.to_string x); None) let linear_prover_with_cert spec l = match linear_prover spec l with | None -> None | Some cert -> Some (make_certificate spec cert) let make_linear_system l = let l' = List.map fst l in let monomials = List.fold_left (fun acc p -> Poly.addition p acc) (Poly.constant (Int 0)) l' in let monomials = Poly.fold (fun mn _ l -> if mn = Monomial.const then l else mn::l) monomials [] in (List.map (fun (c,op) -> {coeffs = Vect.from_list (List.map (fun mn -> (Poly.get mn c)) monomials) ; op = op ; cst = minus_num ( (Poly.get Monomial.const c))}) l ,monomials) let pplus x y = Mc.PEadd(x,y) let pmult x y = Mc.PEmul(x,y) let pconst x = Mc.PEc x let popp x = Mc.PEopp x let debug = false (* keep track of enumerated vectors *) let rec mem p x l = match l with [] -> false | e::l -> if p x e then true else mem p x l let rec remove_assoc p x l = match l with [] -> [] | e::l -> if p x (fst e) then remove_assoc p x l else e::(remove_assoc p x l) let eq x y = Vect.compare x y = 0 let remove e l = List.fold_left (fun l x -> if eq x e then l else x::l) [] l (* The prover is (probably) incomplete -- only searching for naive cutting planes *) let develop_constraint z_spec (e,k) = match k with | Mc.NonStrict -> (dev_form z_spec e , Ge) | Mc.Equal -> (dev_form z_spec e , Eq) | _ -> assert false let op_of_op_compat = function | Ge -> Mc.NonStrict | Eq -> Mc.Equal let integer_vector coeffs = let vars , coeffs = List.split coeffs in List.combine vars (List.map (fun x -> Big_int x) (rats_to_ints coeffs)) let integer_cstr {coeffs = coeffs ; op = op ; cst = cst } = let vars , coeffs = List.split coeffs in match rats_to_ints (cst::coeffs) with | cst :: coeffs -> { coeffs = List.combine vars (List.map (fun x -> Big_int x) coeffs) ; op = op ; cst = Big_int cst} | _ -> assert false let pexpr_of_cstr_compat var cstr = let {coeffs = coeffs ; op = op ; cst = cst } = integer_cstr cstr in try let expr = list_to_polynomial var (Vect.to_list coeffs) in let d = Ml2C.bigint (denominator cst) in let n = Ml2C.bigint (numerator cst) in (pplus (pmult (pconst d) expr) (popp (pconst n)), op_of_op_compat op) with Failure _ -> failwith "pexpr_of_cstr_compat" open Sos_types let rec scale_term t = match t with | Zero -> unit_big_int , Zero | Const n -> (denominator n) , Const (Big_int (numerator n)) | Var n -> unit_big_int , Var n | Inv _ -> failwith "scale_term : not implemented" | Opp t -> let s, t = scale_term t in s, Opp t | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in let g = gcd_big_int s1 s2 in let s1' = div_big_int s1 g in let s2' = div_big_int s2 g in let e = mult_big_int g (mult_big_int s1' s2') in if (compare_big_int e unit_big_int) = 0 then (unit_big_int, Add (y1,y2)) else e, Add (Mul(Const (Big_int s2'), y1), Mul (Const (Big_int s1'), y2)) | Sub _ -> failwith "scale term: not implemented" | Mul(y,z) -> let s1,y1 = scale_term y and s2,y2 = scale_term z in mult_big_int s1 s2 , Mul (y1, y2) | Pow(t,n) -> let s,t = scale_term t in power_big_int_positive_int s n , Pow(t,n) | _ -> failwith "scale_term : not implemented" let scale_term t = let (s,t') = scale_term t in s,t' let get_index_of_ith_match f i l = let rec get j res l = match l with | [] -> failwith "bad index" | e::l -> if f e then (if j = i then res else get (j+1) (res+1) l ) else get j (res+1) l in get 0 0 l let rec scale_certificate pos = match pos with | Axiom_eq i -> unit_big_int , Axiom_eq i | Axiom_le i -> unit_big_int , Axiom_le i | Axiom_lt i -> unit_big_int , Axiom_lt i | Monoid l -> unit_big_int , Monoid l | Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n)) | Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n)) | Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n)) | Square t -> let s,t' = scale_term t in mult_big_int s s , Square t' | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in mult_big_int s1 s2 , Eqmul (y1,y2) | Sum (y, z) -> let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in let g = gcd_big_int s1 s2 in let s1' = div_big_int s1 g in let s2' = div_big_int s2 g in mult_big_int g (mult_big_int s1' s2'), Sum (Product(Rational_le (Big_int s2'), y1), Product (Rational_le (Big_int s1'), y2)) | Product (y, z) -> let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in mult_big_int s1 s2 , Product (y1,y2) open Micromega let rec term_to_q_expr = function | Const n -> PEc (Ml2C.q n) | Zero -> PEc ( Ml2C.q (Int 0)) | Var s -> PEX (Ml2C.index (int_of_string (String.sub s 1 (String.length s - 1)))) | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2) | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2) | Opp p -> PEopp (term_to_q_expr p) | Pow(t,n) -> PEpow (term_to_q_expr t,Ml2C.n n) | Sub(t1,t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2) | _ -> failwith "term_to_q_expr: not implemented" let term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e) let rec product l = match l with | [] -> Mc.PsatzZ | [i] -> Mc.PsatzIn (Ml2C.nat i) | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l) let q_cert_of_pos pos = let rec _cert_of_pos = function Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) | Monoid l -> product l | Rational_eq n | Rational_le n | Rational_lt n -> if compare_num n (Int 0) = 0 then Mc.PsatzZ else Mc.PsatzC (Ml2C.q n) | Square t -> Mc.PsatzSquare (term_to_q_pol t) | Eqmul (t, y) -> Mc.PsatzMulC(term_to_q_pol t, _cert_of_pos y) | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in simplify_cone q_spec (_cert_of_pos pos) let rec term_to_z_expr = function | Const n -> PEc (Ml2C.bigint (big_int_of_num n)) | Zero -> PEc ( Z0) | Var s -> PEX (Ml2C.index (int_of_string (String.sub s 1 (String.length s - 1)))) | Mul(p1,p2) -> PEmul(term_to_z_expr p1, term_to_z_expr p2) | Add(p1,p2) -> PEadd(term_to_z_expr p1, term_to_z_expr p2) | Opp p -> PEopp (term_to_z_expr p) | Pow(t,n) -> PEpow (term_to_z_expr t,Ml2C.n n) | Sub(t1,t2) -> PEsub (term_to_z_expr t1, term_to_z_expr t2) | _ -> failwith "term_to_z_expr: not implemented" let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add Mc.Z.mul Mc.Z.sub Mc.Z.opp Mc.zeq_bool (term_to_z_expr e) let z_cert_of_pos pos = let s,pos = (scale_certificate pos) in let rec _cert_of_pos = function Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) | Monoid l -> product l | Rational_eq n | Rational_le n | Rational_lt n -> if compare_num n (Int 0) = 0 then Mc.PsatzZ else Mc.PsatzC (Ml2C.bigint (big_int_of_num n)) | Square t -> Mc.PsatzSquare (term_to_z_pol t) | Eqmul (t, y) -> let is_unit = match t with | Const n -> n =/ Int 1 | _ -> false in if is_unit then _cert_of_pos y else Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y) | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in simplify_cone z_spec (_cert_of_pos pos) (** All constraints (initial or derived) have an index and have a justification i.e., proof. Given a constraint, all the coefficients are always integers. *) open Mutils open Mfourier open Num open Big_int open Polynomial (*module Mc = Micromega*) (*module Ml2C = Mutils.CamlToCoq module C2Ml = Mutils.CoqToCaml *) let debug = false module Env = struct type t = int list let id_of_hyp hyp l = let rec xid_of_hyp i l = match l with | [] -> failwith "id_of_hyp" | hyp'::l -> if hyp = hyp' then i else xid_of_hyp (i+1) l in xid_of_hyp 0 l end let coq_poly_of_linpol (p,c) = let pol_of_mon m = Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc (Mc.Zpos Mc.XH)) in List.fold_left (fun acc (x,v) -> let mn = LinPoly.MonT.retrieve x in Mc.PEadd(Mc.PEmul(Mc.PEc (Ml2C.bigint (numerator v)), pol_of_mon mn),acc)) (Mc.PEc (Ml2C.bigint (numerator c))) p let rec cmpl_prf_rule env = function | Hyp i | Def i -> Mc.PsatzIn (Ml2C.nat (Env.id_of_hyp i env)) | Cst i -> Mc.PsatzC (Ml2C.bigint i) | Zero -> Mc.PsatzZ | MulPrf(p1,p2) -> Mc.PsatzMulE(cmpl_prf_rule env p1, cmpl_prf_rule env p2) | AddPrf(p1,p2) -> Mc.PsatzAdd(cmpl_prf_rule env p1 , cmpl_prf_rule env p2) | MulC(lp,p) -> let lp = Mc.norm0 (coq_poly_of_linpol lp) in Mc.PsatzMulC(lp,cmpl_prf_rule env p) | Square lp -> Mc.PsatzSquare (Mc.norm0 (coq_poly_of_linpol lp)) | _ -> failwith "Cuts should already be compiled" let rec cmpl_proof env = function | Done -> Mc.DoneProof | Step(i,p,prf) -> begin match p with | CutPrf p' -> Mc.CutProof(cmpl_prf_rule env p', cmpl_proof (i::env) prf) | _ -> Mc.RatProof(cmpl_prf_rule env p,cmpl_proof (i::env) prf) end | Enum(i,p1,_,p2,l) -> Mc.EnumProof(cmpl_prf_rule env p1,cmpl_prf_rule env p2,List.map (cmpl_proof (i::env)) l) let compile_proof env prf = let id = 1 + proof_max_id prf in let _,prf = normalise_proof id prf in if debug then Printf.fprintf stdout "compiled proof %a\n" output_proof prf; cmpl_proof env prf type prf_sys = (cstr_compat * prf_rule) list let xlinear_prover sys = match Fourier.find_point sys with | Inr prf -> if debug then Printf.printf "AProof : %a\n" pp_proof prf ; let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Proof.mk_proof sys prf))) in if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; Some (rats_to_ints (Vect.to_list cert)) | Inl _ -> None let output_num o n = output_string o (string_of_num n) let output_bigint o n = output_string o (string_of_big_int n) let proof_of_farkas prf cert = (* Printf.printf "\nproof_of_farkas %a , %a \n" (pp_list output_prf_rule) prf (pp_list output_bigint) cert ; *) let rec mk_farkas acc prf cert = match prf, cert with | _ , [] -> acc | [] , _ -> failwith "proof_of_farkas : not enough hyps" | p::prf,c::cert -> mk_farkas (add_proof (mul_proof c p) acc) prf cert in let res = mk_farkas Zero prf cert in (*Printf.printf "==> %a" output_prf_rule res ; *) res let linear_prover sys = let (sysi,prfi) = List.split sys in match xlinear_prover sysi with | None -> None | Some cert -> Some (proof_of_farkas prfi cert) let linear_prover = if debug then fun sys -> Printf.printf ""; flush stdout ; res else linear_prover (** A single constraint can be unsat for the following reasons: - 0 >= c for c a negative constant - 0 = c for c a non-zero constant - e = c when the coeffs of e are all integers and c is rational *) type checksat = | Tauto (* Tautology *) | Unsat of prf_rule (* Unsatisfiable *) | Cut of cstr_compat * prf_rule (* Cutting plane *) | Normalise of cstr_compat * prf_rule (* coefficients are relatively prime *) (** [check_sat] - detects constraints that are not satisfiable; - normalises constraints and generate cuts. *) let check_sat (cstr,prf) = let {coeffs=coeffs ; op=op ; cst=cst} = cstr in match coeffs with | [] -> if eval_op op (Int 0) cst then Tauto else Unsat prf | _ -> let gcdi = (gcd_list (List.map snd coeffs)) in let gcd = Big_int gcdi in if eq_num gcd (Int 1) then Normalise(cstr,prf) else if sign_num (mod_num cst gcd) = 0 then (* We can really normalise *) begin assert (sign_num gcd >=1 ) ; let cstr = { coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; op = op ; cst = cst // gcd } in Normalise(cstr,Gcd(gcdi,prf)) (* Normalise(cstr,CutPrf prf)*) end else match op with | Eq -> Unsat (CutPrf prf) | Ge -> let cstr = { coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; op = op ; cst = ceiling_num (cst // gcd) } in Cut(cstr,CutPrf prf) (** Proof generating pivoting over variable v *) let pivot v (c1,p1) (c2,p2) = let {coeffs = v1 ; op = op1 ; cst = n1} = c1 and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in (* Could factorise gcd... *) let xpivot cv1 cv2 = ( {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ; op = Proof.add_op op1 op2 ; cst = n1 */ cv1 +/ n2 */ cv2 }, AddPrf(mul_proof (numerator cv1) p1,mul_proof (numerator cv2) p2)) in match Vect.get v v1 , Vect.get v v2 with | None , _ | _ , None -> None | Some a , Some b -> if (sign_num a) * (sign_num b) = -1 then let cv1 = abs_num b and cv2 = abs_num a in Some (xpivot cv1 cv2) else if op1 = Eq then let cv1 = minus_num (b */ (Int (sign_num a))) and cv2 = abs_num a in Some (xpivot cv1 cv2) else if op2 = Eq then let cv1 = abs_num b and cv2 = minus_num (a */ (Int (sign_num b))) in Some (xpivot cv1 cv2) else None (* op2 could be Eq ... this might happen *) exception FoundProof of prf_rule let rec simpl_sys sys = List.fold_left (fun acc (c,p) -> match check_sat (c,p) with | Tauto -> acc | Unsat prf -> raise (FoundProof prf) | Cut(c,p) -> (c,p)::acc | Normalise (c,p) -> (c,p)::acc) [] sys (** [ext_gcd a b] is the extended Euclid algorithm. [ext_gcd a b = (x,y,g)] iff [ax+by=g] Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm *) let rec ext_gcd a b = if sign_big_int b = 0 then (unit_big_int,zero_big_int) else let (q,r) = quomod_big_int a b in let (s,t) = ext_gcd b r in (t, sub_big_int s (mult_big_int q t)) let pp_ext_gcd a b = let a' = big_int_of_int a in let b' = big_int_of_int b in let (x,y) = ext_gcd a' b' in Printf.fprintf stdout "%s * %s + %s * %s = %s\n" (string_of_big_int x) (string_of_big_int a') (string_of_big_int y) (string_of_big_int b') (string_of_big_int (add_big_int (mult_big_int x a') (mult_big_int y b'))) exception Result of (int * (proof * cstr_compat)) let split_equations psys = List.partition (fun (c,p) -> c.op = Eq) let extract_coprime (c1,p1) (c2,p2) = let rec exist2 vect1 vect2 = match vect1 , vect2 with | _ , [] | [], _ -> None | (v1,n1)::vect1' , (v2, n2) :: vect2' -> if v1 = v2 then if compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int = 0 then Some (v1,n1,n2) else exist2 vect1' vect2' else if v1 < v2 then exist2 vect1' vect2 else exist2 vect1 vect2' in if c1.op = Eq && c2.op = Eq then exist2 c1.coeffs c2.coeffs else None let extract2 pred l = let rec xextract2 rl l = match l with | [] -> (None,rl) (* Did not find *) | e::l -> match extract (pred e) l with | None,_ -> xextract2 (e::rl) l | Some (r,e'),l' -> Some (r,e,e'), List.rev_append rl l' in xextract2 [] l let extract_coprime_equation psys = extract2 extract_coprime psys let apply_and_normalise f psys = List.fold_left (fun acc pc' -> match f pc' with | None -> pc'::acc | Some pc' -> match check_sat pc' with | Tauto -> acc | Unsat prf -> raise (FoundProof prf) | Cut(c,p) -> (c,p)::acc | Normalise (c,p) -> (c,p)::acc ) [] psys let pivot_sys v pc psys = apply_and_normalise (pivot v pc) psys let reduce_coprime psys = let oeq,sys = extract_coprime_equation psys in match oeq with | None -> None (* Nothing to do *) | Some((v,n1,n2),(c1,p1),(c2,p2) ) -> let (l1,l2) = ext_gcd (numerator n1) (numerator n2) in let l1' = Big_int l1 and l2' = Big_int l2 in let cstr = {coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs); op = Eq ; cst = (l1' */ c1.cst) +/ (l2' */ c2.cst) } in let prf = add_proof (mul_proof (numerator l1') p1) (mul_proof (numerator l2') p2) in Some (pivot_sys v (cstr,prf) ((c1,p1)::sys)) (** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *) let reduce_unary psys = let is_unary_equation (cstr,prf) = if cstr.op = Eq then try Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs)) with Not_found -> None else None in let (oeq,sys) = extract is_unary_equation psys in match oeq with | None -> None (* Nothing to do *) | Some(v,pc) -> Some(pivot_sys v pc sys) let reduce_non_lin_unary psys = let is_unary_equation (cstr,prf) = if cstr.op = Eq then try let x = fst (List.find (fun (x,n) -> (n =/ (Int 1) || n=/ (Int (-1))) && Monomial.is_var (LinPoly.MonT.retrieve x) ) cstr.coeffs) in let x' = LinPoly.MonT.retrieve x in if List.for_all (fun (y,_) -> y = x || snd (Monomial.div (LinPoly.MonT.retrieve y) x') = 0) cstr.coeffs then Some x else None with Not_found -> None else None in let (oeq,sys) = extract is_unary_equation psys in match oeq with | None -> None (* Nothing to do *) | Some(v,pc) -> Some(apply_and_normalise (LinPoly.pivot_eq v pc) sys) let reduce_var_change psys = let rec rel_prime vect = match vect with | [] -> None | (x,v)::vect -> let v = numerator v in try let (x',v') = List.find (fun (_,v') -> let v' = numerator v' in eq_big_int (gcd_big_int v v') unit_big_int) vect in Some ((x,v),(x',numerator v')) with Not_found -> rel_prime vect in let rel_prime (cstr,prf) = if cstr.op = Eq then rel_prime cstr.coeffs else None in let (oeq,sys) = extract rel_prime psys in match oeq with | None -> None | Some(((x,v),(x',v')),(c,p)) -> let (l1,l2) = ext_gcd v v' in let l1,l2 = Big_int l1 , Big_int l2 in let get v vect = match Vect.get v vect with | None -> Int 0 | Some n -> n in let pivot_eq (c',p') = let {coeffs = coeffs ; op = op ; cst = cst} = c' in let vx = get x coeffs in let vx' = get x' coeffs in let m = minus_num (vx */ l1 +/ vx' */ l2) in Some ({coeffs = Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} , AddPrf(MulC(([], m),p),p')) in Some (apply_and_normalise pivot_eq sys) let reduce_pivot psys = let is_equation (cstr,prf) = if cstr.op = Eq then try Some (fst (List.hd cstr.coeffs)) with Not_found -> None else None in let (oeq,sys) = extract is_equation psys in match oeq with | None -> None (* Nothing to do *) | Some(v,pc) -> if debug then Printf.printf "Bad news : loss of completeness %a=%s" Vect.pp_vect (fst pc).coeffs (string_of_num (fst pc).cst); Some(pivot_sys v pc sys) let iterate_until_stable f x = let rec iter x = match f x with | None -> x | Some x' -> iter x' in iter x let rec app_funs l x = match l with | [] -> None | f::fl -> match f x with | None -> app_funs fl x | Some x' -> Some x' let reduction_equations psys = iterate_until_stable (app_funs [reduce_unary ; reduce_coprime ; reduce_var_change (*; reduce_pivot*)]) psys let reduction_non_lin_equations psys = iterate_until_stable (app_funs [reduce_non_lin_unary (*; reduce_coprime ; reduce_var_change ; reduce_pivot *)]) psys (** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *) let get_bound sys = let is_small (v,i) = match Itv.range i with | None -> false | Some i -> i <=/ (Int 1) in let select_best (x1,i1) (x2,i2) = if Itv.smaller_itv i1 i2 then (x1,i1) else (x2,i2) in (* For lia, there are no equations => these precautions are not needed *) (* For nlia, there are equations => do not enumerate over equations! *) let all_planes sys = let (eq,ineq) = List.partition (fun c -> c.op = Eq) sys in match eq with | [] -> List.rev_map (fun c -> c.coeffs) ineq | _ -> List.fold_left (fun acc c -> if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq then acc else c.coeffs ::acc) [] ineq in let smallest_interval = List.fold_left (fun acc vect -> if is_small acc then acc else match Fourier.optimise vect sys with | None -> acc | Some i -> if debug then Printf.printf "Found a new bound %a" Vect.pp_vect vect ; select_best (vect,i) acc) (Vect.null, (None,None)) (all_planes sys) in let smallest_interval = match smallest_interval with | (x,(Some i, Some j)) -> Some(i,x,j) | x -> None (* This should not be possible *) in match smallest_interval with | Some (lb,e,ub) -> let (lbn,lbd) = (sub_big_int (numerator lb) unit_big_int, denominator lb) in let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in (match (* x <= ub -> x > ub *) xlinear_prover ({coeffs = Vect.mul (Big_int ubd) e ; op = Ge ; cst = Big_int ubn} :: sys), (* lb <= x -> lb > x *) xlinear_prover ({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys) with | Some cub , Some clb -> Some(List.tl clb,(lb,e,ub), List.tl cub) | _ -> failwith "Interval without proof" ) | None -> None let check_sys sys = List.for_all (fun (c,p) -> List.for_all (fun (_,n) -> sign_num n <> 0) c.coeffs) sys let xlia reduction_equations sys = let rec enum_proof (id:int) (sys:prf_sys) : proof option = if debug then (Printf.printf "enum_proof\n" ; flush stdout) ; assert (check_sys sys) ; let nsys,prf = List.split sys in match get_bound nsys with | None -> None (* Is the systeme really unbounded ? *) | Some(prf1,(lb,e,ub),prf2) -> if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp_vect e (string_of_num lb) (string_of_num ub) ; (match start_enum id e (ceiling_num lb) (floor_num ub) sys with | Some prfl -> Some(Enum(id,proof_of_farkas prf prf1,e, proof_of_farkas prf prf2,prfl)) | None -> None ) and start_enum id e clb cub sys = if clb >/ cub then Some [] else let eq = {coeffs = e ; op = Eq ; cst = clb} in match aux_lia (id+1) ((eq, Def id) :: sys) with | None -> None | Some prf -> match start_enum id e (clb +/ (Int 1)) cub sys with | None -> None | Some l -> Some (prf::l) and aux_lia (id:int) (sys:prf_sys) : proof option = assert (check_sys sys) ; if debug then Printf.printf "xlia: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ; try let sys = reduction_equations sys in if debug then Printf.printf "after reduction: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ; match linear_prover sys with | Some prf -> Some (Step(id,prf,Done)) | None -> enum_proof id sys with FoundProof prf -> (* [reduction_equations] can find a proof *) Some(Step(id,prf,Done)) in (* let sys' = List.map (fun (p,o) -> Mc.norm0 p , o) sys in*) let id = List.length sys in let orpf = try let sys = simpl_sys sys in aux_lia id sys with FoundProof pr -> Some(Step(id,pr,Done)) in match orpf with | None -> None | Some prf -> (*Printf.printf "direct proof %a\n" output_proof prf ; *) let env = mapi (fun _ i -> i) sys in let prf = compile_proof env prf in (*try if Mc.zChecker sys' prf then Some prf else raise Certificate.BadCertificate with Failure s -> (Printf.printf "%s" s ; Some prf) *) Some prf let cstr_compat_of_poly (p,o) = let (v,c) = LinPoly.linpol_of_pol p in {coeffs = v ; op = o ; cst = minus_num c } let lia sys = LinPoly.MonT.clear (); let sys = List.map (develop_constraint z_spec) sys in let (sys:cstr_compat list) = List.map cstr_compat_of_poly sys in let sys = mapi (fun c i -> (c,Hyp i)) sys in xlia reduction_equations sys let nlia sys = LinPoly.MonT.clear (); let sys = List.map (develop_constraint z_spec) sys in let sys = mapi (fun c i -> (c,Hyp i)) sys in let is_linear = List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in let module MonMap = Map.Make(Monomial) in let collect_square = List.fold_left (fun acc ((p,_),_) -> Poly.fold (fun m _ acc -> match Monomial.sqrt m with | None -> acc | Some s -> MonMap.add s m acc) p acc) MonMap.empty sys in let sys = MonMap.fold (fun s m acc -> let s = LinPoly.linpol_of_pol (Poly.add s (Int 1) (Poly.constant (Int 0))) in let m = Poly.add m (Int 1) (Poly.constant (Int 0)) in ((m, Ge), (Square s))::acc) collect_square sys in (* List.iter (fun ((p,_),_) -> Printf.printf "square %a\n" Poly.pp p) gen_square*) let sys = if is_linear then sys else sys @ (all_sym_pairs (fun ((c,o),p) ((c',o'),p') -> ((Poly.product c c',opMult o o'), MulPrf(p,p'))) sys) in let sys = List.map (fun (c,p) -> cstr_compat_of_poly c,p) sys in assert (check_sys sys) ; xlia (if is_linear then reduction_equations else reduction_non_lin_equations) sys (* Local Variables: *) (* coding: utf-8 *) (* End: *) coq-8.4pl4/plugins/nsatz/0000755000175000017500000000000012365131025014435 5ustar stephstephcoq-8.4pl4/plugins/nsatz/utile.ml0000644000175000017500000000737512326224777016143 0ustar stephsteph(* Printing *) let pr x = if !Flags.debug then (Format.printf "@[%s@]" x; flush(stdout);)else () let prn x = if !Flags.debug then (Format.printf "@[%s\n@]" x; flush(stdout);) else () let prt0 s = () (* print_string s;flush(stdout)*) let prt s = if !Flags.debug then (print_string (s^"\n");flush(stdout)) else () let info s = Flags.if_verbose prerr_string s (* Lists *) let rec list_mem_eq eq x l = match l with [] -> false |y::l1 -> if (eq x y) then true else (list_mem_eq eq x l1) let set_of_list_eq eq l = let res = ref [] in List.iter (fun x -> if not (list_mem_eq eq x (!res)) then res:=x::(!res)) l; List.rev !res (* Memoization f is compatible with nf: f(nf(x)) = f(x) *) let memos s memoire nf f x = try (let v = Hashtbl.find memoire (nf x) in pr s;v) with e when Errors.noncritical e -> (pr "#"; let v = f x in Hashtbl.add memoire (nf x) v; v) (********************************************************************** ElÃĐments minimaux pour un ordre partiel de division. E est un ensemble, avec une multiplication et une division partielle div (la fonction div peut ÃĐchouer), constant est un prÃĐdicat qui dÃĐfinit un sous-ensemble C de E. *) (* Etant donnÃĐe une partie A de E, on calcule une partie B de E disjointe de C telle que: - les ÃĐlÃĐments de A sont des produits d'ÃĐlÃĐments de B et d'un de C. - B est minimale pour cette propriÃĐtÃĐ. *) let facteurs_liste div constant lp = let lp = List.filter (fun x -> not (constant x)) lp in let rec factor lmin lp = (* lmin: ne se divisent pas entre eux *) match lp with [] -> lmin |p::lp1 -> (let l1 = ref [] in let p_dans_lmin = ref false in List.iter (fun q -> try (let r = div p q in if not (constant r) then l1:=r::(!l1) else p_dans_lmin:=true) with e when Errors.noncritical e -> ()) lmin; if !p_dans_lmin then factor lmin lp1 else if (!l1)=[] (* aucun q de lmin ne divise p *) then (let l1=ref lp1 in let lmin1=ref [] in List.iter (fun q -> try (let r = div q p in if not (constant r) then l1:=r::(!l1)) with e when Errors.noncritical e -> lmin1:=q::(!lmin1)) lmin; factor (List.rev (p::(!lmin1))) !l1) (* au moins un q de lmin divise p non trivialement *) else factor lmin ((!l1)@lp1)) in factor [] lp (* On suppose que tout ÃĐlÃĐment de A est produit d'ÃĐlÃĐments de B et d'un de C: A et B sont deux tableaux, rend un tableau de couples (ÃĐlÃĐment de C, listes d'indices l) tels que A.(i) = l.(i)_1*Produit(B.(j), j dans l.(i)_2) zero est un prÃĐdicat sur E tel que (zero x) => (constant x): si (zero x) est vrai on ne decompose pas x c est un ÃĐlÃĐment quelconque de E. *) let factorise_tableau div zero c f l1 = let res = Array.create (Array.length f) (c,[]) in Array.iteri (fun i p -> let r = ref p in let li = ref [] in if not (zero p) then Array.iteri (fun j q -> try (while true do let rr = div !r q in li:=j::(!li); r:=rr; done) with e when Errors.noncritical e -> ()) l1; res.(i)<-(!r,!li)) f; (l1,res) (* exemples: let l = [1;2;6;24;720] and div1 = (fun a b -> if a mod b =0 then a/b else failwith "div") and constant = (fun x -> x<2) and zero = (fun x -> x=0) let f = facteurs_liste div1 constant l factorise_tableau div1 zero 0 (Array.of_list l) (Array.of_list f) *) coq-8.4pl4/plugins/nsatz/vo.itarget0000644000175000017500000000001112326224777016450 0ustar stephstephNsatz.vo coq-8.4pl4/plugins/nsatz/ideal.ml0000644000175000017500000006160012326224777016066 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* mon -> mon val deg : mon -> int val compare_mon : mon -> mon -> int val div_mon : mon -> mon -> mon val div_mon_test : mon -> mon -> bool val ppcm_mon : mon -> mon -> mon (* Polynomials *) type deg = int type coef type poly type polynom val repr : poly -> (coef * mon) list val polconst : coef -> poly val zeroP : poly val gen : int -> poly val equal : poly -> poly -> bool val name_var : string list ref val getvar : string list -> int -> string val lstringP : poly list -> string val printP : poly -> unit val lprintP : poly list -> unit val div_pol_coef : poly -> coef -> poly val plusP : poly -> poly -> poly val mult_t_pol : coef -> mon -> poly -> poly val selectdiv : mon -> poly list -> poly val oppP : poly -> poly val emultP : coef -> poly -> poly val multP : poly -> poly -> poly val puisP : poly -> int -> poly val contentP : poly -> coef val contentPlist : poly list -> coef val pgcdpos : coef -> coef -> coef val div_pol : poly -> poly -> coef -> coef -> mon -> poly val reduce2 : poly -> poly list -> coef * poly val poldepcontent : coef list ref val coefpoldep_find : poly -> poly -> poly val coefpoldep_set : poly -> poly -> poly -> unit val initcoefpoldep : poly list -> unit val reduce2_trace : poly -> poly list -> poly list -> poly list * poly val spol : poly -> poly -> poly val etrangers : poly -> poly -> bool val div_ppcm : poly -> poly -> poly -> bool val genPcPf : poly -> poly list -> poly list -> poly list val genOCPf : poly list -> poly list val is_homogeneous : poly -> bool type certificate = { coef : coef; power : int; gb_comb : poly list list; last_comb : poly list } val test_dans_ideal : poly -> poly list -> poly list -> poly list * poly * certificate val in_ideal : deg -> poly list -> poly -> poly list * poly * certificate end (*********************************************************************** Global options *) let lexico = ref false let use_hmon = ref false (* division of tail monomials *) let reduire_les_queues = false (* divide first with new polynomials *) let nouveaux_pol_en_tete = false (*********************************************************************** Functor *) module Make (P:Polynom.S) = struct type coef = P.t let coef0 = P.of_num (Num.Int 0) let coef1 = P.of_num (Num.Int 1) let coefm1 = P.of_num (Num.Int (-1)) let string_of_coef c = "["^(P.to_string c)^"]" (*********************************************************************** Monomials array of integers, first is the degree *) type mon = int array type deg = int type poly = (coef * mon) list type polynom = {pol : poly ref; num : int; sugar : int} let nvar m = Array.length m - 1 let deg m = m.(0) let mult_mon m m' = let d = nvar m in let m'' = Array.create (d+1) 0 in for i=0 to d do m''.(i)<- (m.(i)+m'.(i)); done; m'' let compare_mon m m' = let d = nvar m in if !lexico then ( (* Comparaison de monomes avec ordre du degre lexicographique = on commence par regarder la 1ere variable*) let res=ref 0 in let i=ref 1 in (* 1 si lexico pur 0 si degre*) while (!res=0) && (!i<=d) do res:= (compare m.(!i) m'.(!i)); i:=!i+1; done; !res) else ( (* degre lexicographique inverse *) match compare m.(0) m'.(0) with | 0 -> (* meme degre total *) let res=ref 0 in let i=ref d in while (!res=0) && (!i>=1) do res:= - (compare m.(!i) m'.(!i)); i:=!i-1; done; !res | x -> x) let div_mon m m' = let d = nvar m in let m'' = Array.create (d+1) 0 in for i=0 to d do m''.(i)<- (m.(i)-m'.(i)); done; m'' let div_pol_coef p c = List.map (fun (a,m) -> (P.divP a c,m)) p (* m' divides m *) let div_mon_test m m' = let d = nvar m in let res=ref true in let i=ref 0 in (*il faut que le degre total soit bien mis sinon, i=ref 1*) while (!res) && (!i<=d) do res:= (m.(!i) >= m'.(!i)); i:=succ !i; done; !res let set_deg m = let d = nvar m in m.(0)<-0; for i=1 to d do m.(0)<- m.(i)+m.(0); done; m (* lcm *) let ppcm_mon m m' = let d = nvar m in let m'' = Array.create (d+1) 0 in for i=1 to d do m''.(i)<- (max m.(i) m'.(i)); done; set_deg m'' (********************************************************************** Polynomials list of (coefficient, monomial) decreasing order *) let repr p = p let equal = Util.list_for_all2eq (fun (c1,m1) (c2,m2) -> P.equal c1 c2 && m1=m2) let hash p = let c = map fst p in let m = map snd p in fold_left (fun h p -> h * 17 + P.hash p) (Hashtbl.hash m) c module Hashpol = Hashtbl.Make( struct type t = poly let equal = equal let hash = hash end) (* A pretty printer for polynomials, with Maple-like syntax. *) open Format let getvar lv i = try (nth lv i) with e when Errors.noncritical e -> (fold_left (fun r x -> r^" "^x) "lv= " lv) ^" i="^(string_of_int i) let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef dimmon string_of_exp lvar p = let rec string_of_mon m coefone = let s=ref [] in for i=1 to (dimmon m) do (match (string_of_exp m i) with "0" -> () | "1" -> s:= (!s) @ [(getvar !lvar (i-1))] | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]); done; (match !s with [] -> if coefone then "1" else "" | l -> if coefone then (String.concat "*" l) else ( "*" ^ (String.concat "*" l))) and string_of_term t start = let a = coefterm t and m = monterm t in match (string_of_coef a) with "0" -> "" | "1" ->(match start with true -> string_of_mon m true |false -> ( "+ "^ (string_of_mon m true))) | "-1" ->( "-" ^" "^(string_of_mon m true)) | c -> if (String.get c 0)='-' then ( "- "^ (String.sub c 1 ((String.length c)-1))^ (string_of_mon m false)) else (match start with true -> ( c^(string_of_mon m false)) |false -> ( "+ "^ c^(string_of_mon m false))) and stringP p start = if (zeroP p) then (if start then ("0") else "") else ((string_of_term (hdP p) start)^ " "^ (stringP (tlP p) false)) in (stringP p true) let print_pol zeroP hdP tlP coefterm monterm string_of_coef dimmon string_of_exp lvar p = let rec print_mon m coefone = let s=ref [] in for i=1 to (dimmon m) do (match (string_of_exp m i) with "0" -> () | "1" -> s:= (!s) @ [(getvar !lvar (i-1))] | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]); done; (match !s with [] -> if coefone then print_string "1" else () | l -> if coefone then print_string (String.concat "*" l) else (print_string "*"; print_string (String.concat "*" l))) and print_term t start = let a = coefterm t and m = monterm t in match (string_of_coef a) with "0" -> () | "1" ->(match start with true -> print_mon m true |false -> (print_string "+ "; print_mon m true)) | "-1" ->(print_string "-";print_space();print_mon m true) | c -> if (String.get c 0)='-' then (print_string "- "; print_string (String.sub c 1 ((String.length c)-1)); print_mon m false) else (match start with true -> (print_string c;print_mon m false) |false -> (print_string "+ "; print_string c;print_mon m false)) and printP p start = if (zeroP p) then (if start then print_string("0") else ()) else (print_term (hdP p) start; if start then open_hovbox 0; print_space(); print_cut(); printP (tlP p) false) in open_hovbox 3; printP p true; print_flush() let name_var= ref [] let stringP p = string_of_pol (fun p -> match p with [] -> true | _ -> false) (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal") (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal") (fun (a,m) -> a) (fun (a,m) -> m) string_of_coef (fun m -> (Array.length m)-1) (fun m i -> (string_of_int (m.(i)))) name_var p let nsP2 = ref max_int let stringPcut p = (*Polynomesrec.nsP1:=20;*) nsP2:=10; let res = if (length p)> !nsP2 then (stringP [hd p])^" + "^(string_of_int (length p))^" terms" else stringP p in (*Polynomesrec.nsP1:= max_int;*) nsP2:= max_int; res let rec lstringP l = match l with [] -> "" |p::l -> (stringP p)^("\n")^(lstringP l) let printP = print_pol (fun p -> match p with [] -> true | _ -> false) (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal") (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal") (fun (a,m) -> a) (fun (a,m) -> m) string_of_coef (fun m -> (Array.length m)-1) (fun m i -> (string_of_int (m.(i)))) name_var let rec lprintP l = match l with [] -> () |p::l -> printP p;print_string "\n"; lprintP l (* Operations *) let zeroP = [] (* returns a constant polynom ial with d variables *) let polconst d c = let m = Array.create (d+1) 0 in let m = set_deg m in [(c,m)] let plusP p q = let rec plusP p q = match p with [] -> q |t::p' -> match q with [] -> p |t'::q' -> match compare_mon (snd t) (snd t') with 1 -> t::(plusP p' q) |(-1) -> t'::(plusP p q') |_ -> let c=P.plusP (fst t) (fst t') in match P.equal c coef0 with true -> (plusP p' q') |false -> (c,(snd t))::(plusP p' q') in plusP p q (* multiplication by (a,monomial) *) let mult_t_pol a m p = let rec mult_t_pol p = match p with [] -> [] |(b,m')::p -> ((P.multP a b),(mult_mon m m'))::(mult_t_pol p) in mult_t_pol p let coef_of_int x = P.of_num (Num.Int x) (* variable i *) let gen d i = let m = Array.create (d+1) 0 in m.(i) <- 1; let m = set_deg m in [((coef_of_int 1),m)] let oppP p = let rec oppP p = match p with [] -> [] |(b,m')::p -> ((P.oppP b),m')::(oppP p) in oppP p (* multiplication by a coefficient *) let emultP a p = let rec emultP p = match p with [] -> [] |(b,m')::p -> ((P.multP a b),m')::(emultP p) in emultP p let multP p q = let rec aux p = match p with [] -> [] |(a,m)::p' -> plusP (mult_t_pol a m q) (aux p') in aux p let puisP p n= match p with [] -> [] |_ -> let d = nvar (snd (hd p)) in let rec puisP n = match n with 0 -> [coef1, Array.create (d+1) 0] | 1 -> p |_ -> multP p (puisP (n-1)) in puisP n let rec contentP p = match p with |[] -> coef1 |[a,m] -> a |(a,m)::p1 -> if P.equal a coef1 || P.equal a coefm1 then a else P.pgcdP a (contentP p1) let contentPlist lp = match lp with |[] -> coef1 |p::l1 -> fold_left (fun r q -> if P.equal r coef1 || P.equal r coefm1 then r else P.pgcdP r (contentP q)) (contentP p) l1 (*********************************************************************** Division of polynomials *) let pgcdpos a b = P.pgcdP a b let polynom0 = {pol = ref []; num = 0; sugar = 0} let ppol p = !(p.pol) let lm p = snd (hd (ppol p)) let nallpol = ref 0 let allpol = ref (Array.create 1000 polynom0) let new_allpol p s = nallpol := !nallpol + 1; if !nallpol >= Array.length !allpol then allpol := Array.append !allpol (Array.create !nallpol polynom0); let p = {pol = ref p; num = !nallpol; sugar = s} in !allpol.(!nallpol)<- p; p (* returns a polynomial of l whose head monomial divides m, else [] *) let rec selectdiv m l = match l with [] -> polynom0 |q::r -> let m'= snd (hd (ppol q)) in match (div_mon_test m m') with true -> q |false -> selectdiv m r let div_pol p q a b m = (* info ".";*) plusP (emultP a p) (mult_t_pol b m q) let hmon = Hashtbl.create 1000 let use_hmon = ref false let find_hmon m = if !use_hmon then Hashtbl.find hmon m else raise Not_found let add_hmon m q = if !use_hmon then Hashtbl.add hmon m q else () let div_coef a b = P.divP a b (* remainder r of the division of p by polynomials of l, returns (c,r) where c is the coefficient for pseudo-division : c p = sum_i q_i p_i + r *) let reduce2 p l = let l = if nouveaux_pol_en_tete then rev l else l in let rec reduce p = match p with [] -> (coef1,[]) |t::p' -> let (a,m)=t in let q = (try find_hmon m with Not_found -> let q = selectdiv m l in match (ppol q) with t'::q' -> (add_hmon m q; q) |[] -> q) in match (ppol q) with [] -> if reduire_les_queues then let (c,r)=(reduce p') in (c,((P.multP a c,m)::r)) else (coef1,p) |(b,m')::q' -> let c=(pgcdpos a b) in let a'= (div_coef b c) in let b'=(P.oppP (div_coef a c)) in let (e,r)=reduce (div_pol p' q' a' b' (div_mon m m')) in (P.multP a' e,r) in let (c,r) = reduce p in (c,r) (* trace of divisions *) (* list of initial polynomials *) let poldep = ref [] let poldepcontent = ref [] (* coefficients of polynomials when written with initial polynomials *) let coefpoldep = Hashtbl.create 51 (* coef of q in p = sum_i c_i*q_i *) let coefpoldep_find p q = try (Hashtbl.find coefpoldep (p.num,q.num)) with Not_found -> [] let coefpoldep_remove p q = Hashtbl.remove coefpoldep (p.num,q.num) let coefpoldep_set p q c = Hashtbl.add coefpoldep (p.num,q.num) c let initcoefpoldep d lp = poldep:=lp; poldepcontent:= map (fun p -> contentP (ppol p)) lp; iter (fun p -> coefpoldep_set p p (polconst d (coef_of_int 1))) lp (* keeps trace in coefpoldep divides without pseudodivisions *) let reduce2_trace p l lcp = let l = if nouveaux_pol_en_tete then rev l else l in (* rend (lq,r), ou r = p + sum(lq) *) let rec reduce p = match p with [] -> ([],[]) |t::p' -> let (a,m)=t in let q = (try find_hmon m with Not_found -> let q = selectdiv m l in match (ppol q) with t'::q' -> (add_hmon m q; q) |[] -> q) in match (ppol q) with [] -> if reduire_les_queues then let (lq,r)=(reduce p') in (lq,((a,m)::r)) else ([],p) |(b,m')::q' -> let b'=(P.oppP (div_coef a b)) in let m''= div_mon m m' in let p1=plusP p' (mult_t_pol b' m'' q') in let (lq,r)=reduce p1 in ((b',m'',q)::lq, r) in let (lq,r) = reduce p in (*info "reduce2_trace:\n"; iter (fun (a,m,s) -> let x = mult_t_pol a m s in info ((stringP x)^"\n")) lq; info "ok\n";*) (map2 (fun c0 q -> let c = fold_left (fun x (a,m,s) -> if equal (ppol s) (ppol q) then plusP x (mult_t_pol a m (polconst (nvar m) (coef_of_int 1))) else x) c0 lq in c) lcp !poldep, r) let homogeneous = ref false let pol_courant = ref polynom0 (*********************************************************************** Completion *) let sugar_flag = ref true let compute_sugar p = fold_left (fun s (a,m) -> max s m.(0)) 0 p let mk_polynom p = new_allpol p (compute_sugar p) let spol ps qs= let p = ppol ps in let q = ppol qs in let m = snd (hd p) in let m'= snd (hd q) in let a = fst (hd p) in let b = fst (hd q) in let p'= tl p in let q'= tl q in let c = (pgcdpos a b) in let m''=(ppcm_mon m m') in let m1 = div_mon m'' m in let m2 = div_mon m'' m' in let fsp p' q' = plusP (mult_t_pol (div_coef b c) m1 p') (mult_t_pol (P.oppP (div_coef a c)) m2 q') in let sp = fsp p' q' in let sps = new_allpol sp (max (m1.(0) + ps.sugar) (m2.(0) + qs.sugar)) in coefpoldep_set sps ps (fsp (polconst (nvar m) (coef_of_int 1)) []); coefpoldep_set sps qs (fsp [] (polconst (nvar m) (coef_of_int 1))); sps let etrangers p p'= let m = snd (hd p) in let m'= snd (hd p') in let d = nvar m in let res=ref true in let i=ref 1 in while (!res) && (!i<=d) do res:= (m.(!i) = 0) || (m'.(!i)=0); i:=!i+1; done; !res (* teste if head monomial of p'' divides lcm of lhead monomials of p and p' *) let div_ppcm p p' p'' = let m = snd (hd p) in let m'= snd (hd p') in let m''= snd (hd p'') in let d = nvar m in let res=ref true in let i=ref 1 in while (!res) && (!i<=d) do res:= ((max m.(!i) m'.(!i)) >= m''.(!i)); i:=!i+1; done; !res (* code from extraction of Laurent ThÃĐry Coq program *) type 'poly cpRes = Keep of ('poly list) | DontKeep of ('poly list) let list_rec f0 f1 = let rec f2 = function [] -> f0 | a0::l0 -> f1 a0 l0 (f2 l0) in f2 let addRes i = function Keep h'0 -> Keep (i::h'0) | DontKeep h'0 -> DontKeep (i::h'0) let slice i a q = list_rec (match etrangers (ppol i) (ppol a) with true -> DontKeep [] | false -> Keep []) (fun b q1 rec_ren -> match div_ppcm (ppol i) (ppol a) (ppol b) with true -> DontKeep (b::q1) | false -> (match div_ppcm (ppol i) (ppol b) (ppol a) with true -> rec_ren | false -> addRes b rec_ren)) q (* sugar strategy *) let rec addS x l = l @ [x] (* oblige de mettre en queue sinon le certificat deconne *) let addSsugar x l = if !sugar_flag then let sx = x.sugar in let rec insere l = match l with | [] -> [x] | y::l1 -> if sx <= y.sugar then x::l else y::(insere l1) in insere l else addS x l (* ajoute les spolynomes de i avec la liste de polynomes aP, a la liste q *) let genPcPf i aP q = (let rec genPc aP0 = match aP0 with [] -> (fun r -> r) | a::l1 -> (fun l -> (match slice i a l1 with Keep l2 -> addSsugar (spol i a) (genPc l2 l) | DontKeep l2 -> genPc l2 l)) in genPc aP) q let genOCPf h' = list_rec [] (fun a l rec_ren -> genPcPf a l rec_ren) h' (*********************************************************************** critical pairs/s-polynomials *) let ordcpair ((i1,j1),m1) ((i2,j2),m2) = (* let s1 = (max (!allpol.(i1).sugar + m1.(0) - (snd (hd (ppol !allpol.(i1)))).(0)) (!allpol.(j1).sugar + m1.(0) - (snd (hd (ppol !allpol.(j1)))).(0))) in let s2 = (max (!allpol.(i2).sugar + m2.(0) - (snd (hd (ppol !allpol.(i2)))).(0)) (!allpol.(j2).sugar + m2.(0) - (snd (hd (ppol !allpol.(j2)))).(0))) in match compare s1 s2 with | 1 -> 1 |(-1) -> -1 |0 -> compare_mon m1 m2*) compare_mon m1 m2 let sortcpairs lcp = sort ordcpair lcp let mergecpairs l1 l2 = merge ordcpair l1 l2 let ord i j = if i r @ (cpair p q)) [] lq) let cpairs lp = let rec aux l = match l with []|[_] -> [] |p::l1 -> mergecpairs (cpairs1 p l1) (aux l1) in aux lp let critere2 ((i,j),m) lp lcp = exists (fun h -> h.num <> i && h.num <> j && (div_mon_test m (lm h)) && (let c1 = ord i h.num in not (exists (fun (c,_) -> c1 = c) lcp)) && (let c1 = ord j h.num in not (exists (fun (c,_) -> c1 = c) lcp))) lp let critere3 ((i,j),m) lp lcp = exists (fun h -> h.num <> i && h.num <> j && (div_mon_test m (lm h)) && (h.num < j || not (m = ppcm_mon (lm (!allpol.(i))) (lm h))) && (h.num < i || not (m = ppcm_mon (lm (!allpol.(j))) (lm h)))) lp let add_cpairs p lp lcp = mergecpairs (cpairs1 p lp) lcp let step = ref 0 let infobuch p q = if !step = 0 then (info ("[" ^ (string_of_int (length p)) ^ "," ^ (string_of_int (length q)) ^ "]")) (* in lp new polynomials are at the end *) let coef_courant = ref coef1 type certificate = { coef : coef; power : int; gb_comb : poly list list; last_comb : poly list } let test_dans_ideal p lp lp0 = let (c,r) = reduce2 (ppol !pol_courant) lp in info ("remainder: "^(stringPcut r)^"\n"); coef_courant:= P.multP !coef_courant c; pol_courant:= mk_polynom r; if r=[] then (info "polynomial reduced to 0\n"; let lcp = map (fun q -> []) !poldep in let c = !coef_courant in let (lcq,r) = reduce2_trace (emultP c p) lp lcp in info "r ok\n"; info ("r: "^(stringP r)^"\n"); let res=ref (emultP c p) in iter2 (fun cq q -> res:=plusP (!res) (multP cq (ppol q)); ) lcq !poldep; info ("verif sum: "^(stringP (!res))^"\n"); info ("coefficient: "^(stringP (polconst 1 c))^"\n"); let rec aux lp = match lp with |[] -> [] |p::lp -> (map (fun q -> coefpoldep_find p q) lp)::(aux lp) in let coefficient_multiplicateur = c in let liste_polynomes_de_depart = rev lp0 in let polynome_a_tester = p in let liste_des_coefficients_intermediaires = (let lci = rev (aux (rev lp)) in let lci = ref lci (* (map rev lci) *) in iter (fun x -> lci := tl (!lci)) lp0; !lci) in let liste_des_coefficients = map (fun cq -> emultP (coef_of_int (-1)) cq) (rev lcq) in (liste_polynomes_de_depart, polynome_a_tester, {coef = coefficient_multiplicateur; power = 1; gb_comb = liste_des_coefficients_intermediaires; last_comb = liste_des_coefficients}) ) else ((*info "polynomial not reduced to 0\n"; info ("\nremainder: "^(stringPcut r)^"\n");*) raise NotInIdeal) let divide_rem_with_critical_pair = ref false let list_diff l x = filter (fun y -> y <> x) l let deg_hom p = match p with | [] -> -1 | (a,m)::_ -> m.(0) let pbuchf pq p lp0= info "computation of the Groebner basis\n"; step:=0; Hashtbl.clear hmon; let rec pbuchf (lp, lpc) = infobuch lp lpc; (* step:=(!step+1)mod 10;*) match lpc with [] -> (* info ("List of polynomials:\n"^(fold_left (fun r p -> r^(stringP p)^"\n") "" lp)); info "--------------------\n";*) test_dans_ideal (ppol p) lp lp0 | ((i,j),m) :: lpc2 -> (* info "choosen pair\n";*) if critere3 ((i,j),m) lp lpc2 then (info "c"; pbuchf (lp, lpc2)) else let a = spol !allpol.(i) !allpol.(j) in if !homogeneous && (ppol a)<>[] && deg_hom (ppol a) > deg_hom (ppol !pol_courant) then (info "h"; pbuchf (lp, lpc2)) else (* let sa = a.sugar in*) let (ca,a0)= reduce2 (ppol a) lp in match a0 with [] -> info "0";pbuchf (lp, lpc2) | _ -> (* info "pair reduced\n";*) a.pol := emultP ca (ppol a); let (lca,a0) = reduce2_trace (ppol a) lp (map (fun q -> emultP ca (coefpoldep_find a q)) !poldep) in (* info "paire re-reduced";*) a.pol := a0; (* let a0 = new_allpol a0 sa in*) iter2 (fun c q -> coefpoldep_remove a q; coefpoldep_set a q c) lca !poldep; let a0 = a in info ("\nnew polynomial: "^(stringPcut (ppol a0))^"\n"); let ct = coef1 (* contentP a0 *) in (*info ("content: "^(string_of_coef ct)^"\n");*) poldep:=addS a0 lp; poldepcontent:=addS ct (!poldepcontent); try test_dans_ideal (ppol p) (addS a0 lp) lp0 with NotInIdeal -> let newlpc = add_cpairs a0 lp lpc2 in pbuchf (((addS a0 lp), newlpc)) in pbuchf pq let is_homogeneous p = match p with | [] -> true | (a,m)::p1 -> let d = m.(0) in for_all (fun (b,m') -> m'.(0)=d) p1 (* returns c lp = [pn;...;p1] p lci = [[a(n+1,n);...;a(n+1,1)]; [a(n+2,n+1);...;a(n+2,1)]; ... [a(n+m,n+m-1);...;a(n+m,1)]] lc = [qn+m; ... q1] such that c*p = sum qi*pi where pn+k = a(n+k,n+k-1)*pn+k-1 + ... + a(n+k,1)* p1 *) let in_ideal d lp p = Hashtbl.clear hmon; Hashtbl.clear coefpoldep; nallpol := 0; allpol := Array.create 1000 polynom0; homogeneous := for_all is_homogeneous (p::lp); if !homogeneous then info "homogeneous polynomials\n"; info ("p: "^(stringPcut p)^"\n"); info ("lp:\n"^(fold_left (fun r p -> r^(stringPcut p)^"\n") "" lp)); (*info ("p: "^(stringP p)^"\n"); info ("lp:\n"^(fold_left (fun r p -> r^(stringP p)^"\n") "" lp));*) let lp = map mk_polynom lp in let p = mk_polynom p in initcoefpoldep d lp; coef_courant:=coef1; pol_courant:=p; let (lp1,p1,cert) = try test_dans_ideal (ppol p) lp lp with NotInIdeal -> pbuchf (lp, (cpairs lp)) p lp in info "computed\n"; (map ppol lp1, p1, cert) (* *) end coq-8.4pl4/plugins/nsatz/polynom.mli0000644000175000017500000000574612326224777016667 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t -> bool val lt : t -> t -> bool val le : t -> t -> bool val abs : t -> t val plus : t -> t -> t val mult : t -> t -> t val sub : t -> t -> t val opp : t -> t val div : t -> t -> t val modulo : t -> t -> t val puis : t -> int -> t val pgcd : t -> t -> t val hash : t -> int val of_num : Num.num -> t val to_string : t -> string end module type S = sig type coef type variable = int type t = Pint of coef | Prec of variable * t array val of_num : Num.num -> t val x : variable -> t val monome : variable -> int -> t val is_constantP : t -> bool val is_zero : t -> bool val max_var_pol : t -> variable val max_var_pol2 : t -> variable val max_var : t array -> variable val equal : t -> t -> bool val norm : t -> t val deg : variable -> t -> int val deg_total : t -> int val copyP : t -> t val coef : variable -> int -> t -> t val plusP : t -> t -> t val content : t -> coef val div_int : t -> coef -> t val vire_contenu : t -> t val vars : t -> variable list val int_of_Pint : t -> coef val multx : int -> variable -> t -> t val multP : t -> t -> t val deriv : variable -> t -> t val oppP : t -> t val moinsP : t -> t -> t val puisP : t -> int -> t val ( @@ ) : t -> t -> t val ( -- ) : t -> t -> t val ( ^^ ) : t -> int -> t val coefDom : variable -> t -> t val coefConst : variable -> t -> t val remP : variable -> t -> t val coef_int_tete : t -> coef val normc : t -> t val coef_constant : t -> coef val univ : bool ref val string_of_var : int -> string val nsP : int ref val to_string : t -> string val printP : t -> unit val print_tpoly : t array -> unit val print_lpoly : t list -> unit val quo_rem_pol : t -> t -> variable -> t * t val div_pol : t -> t -> variable -> t val divP : t -> t -> t val div_pol_rat : t -> t -> bool val pseudo_div : t -> t -> variable -> t * t * int * t val pgcdP : t -> t -> t val pgcd_pol : t -> t -> variable -> t val content_pol : t -> variable -> t val pgcd_coef_pol : t -> t -> variable -> t val pgcd_pol_rec : t -> t -> variable -> t val gcd_sub_res : t -> t -> variable -> t val gcd_sub_res_rec : t -> t -> t -> t -> int -> variable -> t val lazard_power : t -> t -> int -> variable -> t val hash : t -> int module Hashpol : Hashtbl.S with type key=t end module Make (C:Coef) : S with type coef = C.t coq-8.4pl4/plugins/nsatz/Nsatz.v0000644000175000017500000003407112326224777015746 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* x == y. intros x y H; setoid_replace x with ((x - y) + y); simpl; [setoid_rewrite H | idtac]; simpl. cring. cring. Qed. Lemma psos_r1: forall x y, x == y -> x - y == 0. intros x y H; simpl; setoid_rewrite H; simpl; cring. Qed. Lemma nsatzR_diff: forall x y:R, not (x == y) -> not (x - y == 0). intros. intro; apply H. simpl; setoid_replace x with ((x - y) + y). simpl. setoid_rewrite H0. simpl; cring. simpl. simpl; cring. Qed. (* adpatation du code de Benjamin aux setoides *) Require Import ZArith. Require Export Ring_polynom. Require Export InitialRing. Definition PolZ := Pol Z. Definition PEZ := PExpr Z. Definition P0Z : PolZ := P0 (C:=Z) 0%Z. Definition PolZadd : PolZ -> PolZ -> PolZ := @Padd Z 0%Z Z.add Zeq_bool. Definition PolZmul : PolZ -> PolZ -> PolZ := @Pmul Z 0%Z 1%Z Z.add Z.mul Zeq_bool. Definition PolZeq := @Peq Z Zeq_bool. Definition norm := @norm_aux Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool. Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ := match la, lp with | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp) | _, _ => P0Z end. Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) := match lla with | List.nil => lp | la::lla => compute_list lla ((mult_l la lp)::lp) end. Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) := let (lla, lq) := certif in let lp := List.map norm lpe in PolZeq (norm qe) (mult_l lq (compute_list lla lp)). (* Correction *) Definition PhiR : list R -> PolZ -> R := (Pphi ring0 add mul (InitialRing.gen_phiZ ring0 ring1 add mul opp)). Definition PEevalR : list R -> PEZ -> R := PEeval ring0 add mul sub opp (gen_phiZ ring0 ring1 add mul opp) N.to_nat pow. Lemma P0Z_correct : forall l, PhiR l P0Z = 0. Proof. trivial. Qed. Lemma Rext: ring_eq_ext add mul opp _==_. Proof. constructor; solve_proper. Qed. Lemma Rset : Setoid_Theory R _==_. apply ring_setoid. Qed. Definition Rtheory:ring_theory ring0 ring1 add mul sub opp _==_. apply mk_rt. apply ring_add_0_l. apply ring_add_comm. apply ring_add_assoc. apply ring_mul_1_l. apply cring_mul_comm. apply ring_mul_assoc. apply ring_distr_l. apply ring_sub_def. apply ring_opp_def. Defined. Lemma PolZadd_correct : forall P' P l, PhiR l (PolZadd P P') == ((PhiR l P) + (PhiR l P')). Proof. unfold PolZadd, PhiR. intros. simpl. refine (Padd_ok Rset Rext (Rth_ARth Rset Rext Rtheory) (gen_phiZ_morph Rset Rext Rtheory) _ _ _). Qed. Lemma PolZmul_correct : forall P P' l, PhiR l (PolZmul P P') == ((PhiR l P) * (PhiR l P')). Proof. unfold PolZmul, PhiR. intros. refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext Rtheory) (gen_phiZ_morph Rset Rext Rtheory) _ _ _). Qed. Lemma R_power_theory : Ring_theory.power_theory ring1 mul _==_ N.to_nat pow. apply Ring_theory.mkpow_th. unfold pow. intros. rewrite Nnat.N2Nat.id. reflexivity. Qed. Lemma norm_correct : forall (l : list R) (pe : PEZ), PEevalR l pe == PhiR l (norm pe). Proof. intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext Rtheory) (gen_phiZ_morph Rset Rext Rtheory) R_power_theory). Qed. Lemma PolZeq_correct : forall P P' l, PolZeq P P' = true -> PhiR l P == PhiR l P'. Proof. intros;apply (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext Rtheory));trivial. Qed. Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop := match l with | List.nil => True | a::l => Interp a == 0 /\ Cond0 A Interp l end. Lemma mult_l_correct : forall l la lp, Cond0 PolZ (PhiR l) lp -> PhiR l (mult_l la lp) == 0. Proof. induction la;simpl;intros. cring. destruct lp;trivial. simpl. cring. simpl in H;destruct H. rewrite PolZadd_correct. simpl. rewrite PolZmul_correct. simpl. rewrite H. rewrite IHla. cring. trivial. Qed. Lemma compute_list_correct : forall l lla lp, Cond0 PolZ (PhiR l) lp -> Cond0 PolZ (PhiR l) (compute_list lla lp). Proof. induction lla;simpl;intros;trivial. apply IHlla;simpl;split;trivial. apply mult_l_correct;trivial. Qed. Lemma check_correct : forall l lpe qe certif, check lpe qe certif = true -> Cond0 PEZ (PEevalR l) lpe -> PEevalR l qe == 0. Proof. unfold check;intros l lpe qe (lla, lq) H2 H1. apply PolZeq_correct with (l:=l) in H2. rewrite norm_correct, H2. apply mult_l_correct. apply compute_list_correct. clear H2 lq lla qe;induction lpe;simpl;trivial. simpl in H1;destruct H1. rewrite <- norm_correct;auto. Qed. (* fin *) Definition R2:= 1 + 1. Fixpoint IPR p {struct p}: R := match p with xH => ring1 | xO xH => 1+1 | xO p1 => R2*(IPR p1) | xI xH => 1+(1+1) | xI p1 => 1+(R2*(IPR p1)) end. Definition IZR1 z := match z with Z0 => 0 | Zpos p => IPR p | Zneg p => -(IPR p) end. Fixpoint interpret3 t fv {struct t}: R := match t with | (PEadd t1 t2) => let v1 := interpret3 t1 fv in let v2 := interpret3 t2 fv in (v1 + v2) | (PEmul t1 t2) => let v1 := interpret3 t1 fv in let v2 := interpret3 t2 fv in (v1 * v2) | (PEsub t1 t2) => let v1 := interpret3 t1 fv in let v2 := interpret3 t2 fv in (v1 - v2) | (PEopp t1) => let v1 := interpret3 t1 fv in (-v1) | (PEpow t1 t2) => let v1 := interpret3 t1 fv in pow v1 (N.to_nat t2) | (PEc t1) => (IZR1 t1) | (PEX n) => List.nth (pred (Pos.to_nat n)) fv 0 end. End nsatz1. Ltac equality_to_goal H x y:= (* eliminate trivial hypotheses, but it takes time!: let h := fresh "nH" in (assert (h:equality x y); [solve [cring] | clear H; clear h]) || *) try (generalize (@psos_r1 _ _ _ _ _ _ _ _ _ _ _ x y H); clear H) . Ltac equalities_to_goal := lazymatch goal with | H: (_ ?x ?y) |- _ => equality_to_goal H x y | H: (_ _ ?x ?y) |- _ => equality_to_goal H x y | H: (_ _ _ ?x ?y) |- _ => equality_to_goal H x y | H: (_ _ _ _ ?x ?y) |- _ => equality_to_goal H x y (* extension possible :-) *) | H: (?x == ?y) |- _ => equality_to_goal H x y end. (* lp est incluse dans fv. La met en tete. *) Ltac parametres_en_tete fv lp := match fv with | (@nil _) => lp | (@cons _ ?x ?fv1) => let res := AddFvTail x lp in parametres_en_tete fv1 res end. Ltac append1 a l := match l with | (@nil _) => constr:(cons a l) | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l') end. Ltac rev l := match l with |(@nil _) => l | (cons ?x ?l) => let l' := rev l in append1 x l' end. Ltac nsatz_call_n info nparam p rr lp kont := (* idtac "Trying power: " rr;*) let ll := constr:(PEc info :: PEc nparam :: PEpow p rr :: lp) in (* idtac "calcul...";*) nsatz_compute ll; (* idtac "done";*) match goal with | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ => intros _; set (lci:=lci0); set (lq:=lq0); kont c rr lq lci end. Ltac nsatz_call radicalmax info nparam p lp kont := let rec try_n n := lazymatch n with | 0%N => fail | _ => (let r := eval compute in (N.sub radicalmax (N.pred n)) in nsatz_call_n info nparam p r lp kont) || let n' := eval compute in (N.pred n) in try_n n' end in try_n radicalmax. Ltac lterm_goal g := match g with ?b1 == ?b2 => constr:(b1::b2::nil) | ?b1 == ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l) end. Ltac reify_goal l le lb:= match le with nil => idtac | ?e::?le1 => match lb with ?b::?lb1 => (* idtac "b="; idtac b;*) let x := fresh "B" in set (x:= b) at 1; change x with (interpret3 e l); clear x; reify_goal l le1 lb1 end end. Ltac get_lpol g := match g with (interpret3 ?p _) == _ => constr:(p::nil) | (interpret3 ?p _) == _ -> ?g => let l := get_lpol g in constr:(p::l) end. Ltac nsatz_generic radicalmax info lparam lvar := let nparam := eval compute in (Z.of_nat (List.length lparam)) in match goal with |- ?g => let lb := lterm_goal g in match (match lvar with |(@nil _) => match lparam with |(@nil _) => let r := eval red in (list_reifyl (lterm:=lb)) in r |_ => match eval red in (list_reifyl (lterm:=lb)) with |(?fv, ?le) => let fv := parametres_en_tete fv lparam in (* we reify a second time, with the good order for variables *) let r := eval red in (list_reifyl (lterm:=lb) (lvar:=fv)) in r end end |_ => let fv := parametres_en_tete lvar lparam in let r := eval red in (list_reifyl (lterm:=lb) (lvar:=fv)) in r end) with |(?fv, ?le) => reify_goal fv le lb ; match goal with |- ?g => let lp := get_lpol g in let lpol := eval compute in (List.rev lp) in intros; let SplitPolyList kont := match lpol with | ?p2::?lp2 => kont p2 lp2 | _ => idtac "polynomial not in the ideal" end in SplitPolyList ltac:(fun p lp => set (p21:=p) ; set (lp21:=lp); (* idtac "nparam:"; idtac nparam; idtac "p:"; idtac p; idtac "lp:"; idtac lp; *) nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci => set (q := PEmul c (PEpow p21 r)); let Hg := fresh "Hg" in assert (Hg:check lp21 q (lci,lq) = true); [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate" | let Hg2 := fresh "Hg" in assert (Hg2: (interpret3 q fv) == 0); [ (*simpl*) idtac; generalize (@check_correct _ _ _ _ _ _ _ _ _ _ _ fv lp21 q (lci,lq) Hg); let cc := fresh "H" in (*simpl*) idtac; intro cc; apply cc; clear cc; (*simpl*) idtac; repeat (split;[assumption|idtac]); exact I | (*simpl in Hg2;*) (*simpl*) idtac; apply Rintegral_domain_pow with (interpret3 c fv) (N.to_nat r); (*simpl*) idtac; try apply integral_domain_one_zero; try apply integral_domain_minus_one_zero; try trivial; try exact integral_domain_one_zero; try exact integral_domain_minus_one_zero || (solve [simpl; unfold R2, equality, eq_notation, addition, add_notation, one, one_notation, multiplication, mul_notation, zero, zero_notation; discrR || omega]) || ((*simpl*) idtac) || idtac "could not prove discrimination result" ] ] ) ) end end end . Ltac nsatz_default:= intros; try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); match goal with |- (@equality ?r _ _ _) => repeat equalities_to_goal; nsatz_generic 6%N 1%Z (@nil r) (@nil r) end. Tactic Notation "nsatz" := nsatz_default. Tactic Notation "nsatz" "with" "radicalmax" ":=" constr(radicalmax) "strategy" ":=" constr(info) "parameters" ":=" constr(lparam) "variables" ":=" constr(lvar):= intros; try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); match goal with |- (@equality ?r _ _ _) => repeat equalities_to_goal; nsatz_generic radicalmax info lparam lvar end. (* Real numbers *) Require Import Reals. Require Import RealField. Lemma Rsth : Setoid_Theory R (@eq R). constructor;red;intros;subst;trivial. Qed. Instance Rops: (@Ring_ops R 0%R 1%R Rplus Rmult Rminus Ropp (@eq R)). Instance Rri : (Ring (Ro:=Rops)). constructor; try (try apply Rsth; try (unfold respectful, Proper; unfold equality; unfold eq_notation in *; intros; try rewrite H; try rewrite H0; reflexivity)). exact Rplus_0_l. exact Rplus_comm. symmetry. apply Rplus_assoc. exact Rmult_1_l. exact Rmult_1_r. symmetry. apply Rmult_assoc. exact Rmult_plus_distr_r. intros; apply Rmult_plus_distr_l. exact Rplus_opp_r. Defined. Lemma R_one_zero: 1%R <> 0%R. discrR. Qed. Instance Rcri: (Cring (Rr:=Rri)). red. exact Rmult_comm. Defined. Instance Rdi : (Integral_domain (Rcr:=Rcri)). constructor. exact Rmult_integral. exact R_one_zero. Defined. (* Rational numbers *) Require Import QArith. Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq). Instance Qri : (Ring (Ro:=Qops)). constructor. try apply Q_Setoid. apply Qplus_comp. apply Qmult_comp. apply Qminus_comp. apply Qopp_comp. exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc. exact Qmult_1_l. exact Qmult_1_r. apply Qmult_assoc. apply Qmult_plus_distr_l. intros. apply Qmult_plus_distr_r. reflexivity. exact Qplus_opp_r. Defined. Lemma Q_one_zero: not (Qeq 1%Q 0%Q). unfold Qeq. simpl. auto with *. Qed. Instance Qcri: (Cring (Rr:=Qri)). red. exact Qmult_comm. Defined. Instance Qdi : (Integral_domain (Rcr:=Qcri)). constructor. exact Qmult_integral. exact Q_one_zero. Defined. (* Integers *) Lemma Z_one_zero: 1%Z <> 0%Z. omega. Qed. Instance Zcri: (Cring (Rr:=Zr)). red. exact Z.mul_comm. Defined. Instance Zdi : (Integral_domain (Rcr:=Zcri)). constructor. exact Zmult_integral. exact Z_one_zero. Defined. coq-8.4pl4/plugins/nsatz/polynom.ml0000644000175000017500000004145712326224777016515 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t -> bool val lt : t -> t -> bool val le : t -> t -> bool val abs : t -> t val plus : t -> t -> t val mult : t -> t -> t val sub : t -> t -> t val opp : t -> t val div : t -> t -> t val modulo : t -> t -> t val puis : t -> int -> t val pgcd : t -> t -> t val hash : t -> int val of_num : Num.num -> t val to_string : t -> string end module type S = sig type coef type variable = int type t = Pint of coef | Prec of variable * t array val of_num : Num.num -> t val x : variable -> t val monome : variable -> int -> t val is_constantP : t -> bool val is_zero : t -> bool val max_var_pol : t -> variable val max_var_pol2 : t -> variable val max_var : t array -> variable val equal : t -> t -> bool val norm : t -> t val deg : variable -> t -> int val deg_total : t -> int val copyP : t -> t val coef : variable -> int -> t -> t val plusP : t -> t -> t val content : t -> coef val div_int : t -> coef -> t val vire_contenu : t -> t val vars : t -> variable list val int_of_Pint : t -> coef val multx : int -> variable -> t -> t val multP : t -> t -> t val deriv : variable -> t -> t val oppP : t -> t val moinsP : t -> t -> t val puisP : t -> int -> t val ( @@ ) : t -> t -> t val ( -- ) : t -> t -> t val ( ^^ ) : t -> int -> t val coefDom : variable -> t -> t val coefConst : variable -> t -> t val remP : variable -> t -> t val coef_int_tete : t -> coef val normc : t -> t val coef_constant : t -> coef val univ : bool ref val string_of_var : int -> string val nsP : int ref val to_string : t -> string val printP : t -> unit val print_tpoly : t array -> unit val print_lpoly : t list -> unit val quo_rem_pol : t -> t -> variable -> t * t val div_pol : t -> t -> variable -> t val divP : t -> t -> t val div_pol_rat : t -> t -> bool val pseudo_div : t -> t -> variable -> t * t * int * t val pgcdP : t -> t -> t val pgcd_pol : t -> t -> variable -> t val content_pol : t -> variable -> t val pgcd_coef_pol : t -> t -> variable -> t val pgcd_pol_rec : t -> t -> variable -> t val gcd_sub_res : t -> t -> variable -> t val gcd_sub_res_rec : t -> t -> t -> t -> int -> variable -> t val lazard_power : t -> t -> int -> variable -> t val hash : t -> int module Hashpol : Hashtbl.S with type key=t end (*********************************************************************** 2. Type of polynomials, operations. *) module Make (C:Coef) = struct type coef = C.t let coef_of_int i = C.of_num (Num.Int i) let coef0 = coef_of_int 0 let coef1 = coef_of_int 1 type variable = int type t = Pint of coef (* constant polynomial *) | Prec of variable * (t array) (* coefficients, increasing degree *) (* by default, operations work with normalized polynomials: - variables are positive integers - coefficients of a polynomial in x only use variables < x - no zero coefficient at beginning - no Prec(x,a) where a is constant in x *) (* constant polynomials *) let of_num x = Pint (C.of_num x) let cf0 = of_num (Num.Int 0) let cf1 = of_num (Num.Int 1) (* nth variable *) let x n = Prec (n,[|cf0;cf1|]) (* create v^n *) let monome v n = match n with 0->Pint coef1; |_->let tmp = Array.create (n+1) (Pint coef0) in tmp.(n)<-(Pint coef1); Prec (v, tmp) let is_constantP = function Pint _ -> true | Prec _ -> false let int_of_Pint = function Pint x -> x | _ -> failwith "non" let is_zero p = match p with Pint n -> if C.equal n coef0 then true else false |_-> false let max_var_pol p = match p with Pint _ -> 0 |Prec(x,_) -> x (* p not normalized *) let rec max_var_pol2 p = match p with Pint _ -> 0 |Prec(v,c)-> Array.fold_right (fun q m -> max (max_var_pol2 q) m) c v let rec max_var l = Array.fold_right (fun p m -> max (max_var_pol2 p) m) l 0 (* equality between polynomials *) let rec equal p q = match (p,q) with (Pint a,Pint b) -> C.equal a b |(Prec(x,p1),Prec(y,q1)) -> if x<>y then false else if (Array.length p1)<>(Array.length q1) then false else (try (Array.iteri (fun i a -> if not (equal a q1.(i)) then failwith "raté") p1; true) with e when Errors.noncritical e -> false) | (_,_) -> false (* normalize polynomial: remove head zeros, coefficients are normalized if constant, returns the coefficient *) let rec norm p = match p with Pint _ -> p |Prec (x,a)-> let d = (Array.length a -1) in let n = ref d in while !n>0 && (equal a.(!n) (Pint coef0)) do n:=!n-1; done; if !n<0 then Pint coef0 else if !n=0 then a.(0) else if !n=d then p else (let b=Array.create (!n+1) (Pint coef0) in for i=0 to !n do b.(i)<-a.(i);done; Prec(x,b)) (* degree in v, v >= max var of p *) let rec deg v p = match p with Prec(x,p1) when x=v -> Array.length p1 -1 |_ -> 0 (* total degree *) let rec deg_total p = match p with Prec (x,p1) -> let d = ref 0 in Array.iteri (fun i q -> d:= (max !d (i+(deg_total q)))) p1; !d |_ -> 0 let rec copyP p = match p with Pint i -> Pint i |Prec(x,q) -> Prec(x,Array.map copyP q) (* coefficient of degree i in v, v >= max var of p *) let coef v i p = match p with Prec (x,p1) when x=v -> if i<(Array.length p1) then p1.(i) else Pint coef0 |_ -> if i=0 then p else Pint coef0 (* addition *) let rec plusP p q = let res = (match (p,q) with (Pint a,Pint b) -> Pint (C.plus a b) |(Pint a, Prec (y,q1)) -> let q2=Array.map copyP q1 in q2.(0)<- plusP p q1.(0); Prec (y,q2) |(Prec (x,p1),Pint b) -> let p2=Array.map copyP p1 in p2.(0)<- plusP p1.(0) q; Prec (x,p2) |(Prec (x,p1),Prec (y,q1)) -> if xy then (let p2=Array.map copyP p1 in p2.(0)<- plusP p1.(0) q; Prec (x,p2)) else (let n=max (deg x p) (deg x q) in let r=Array.create (n+1) (Pint coef0) in for i=0 to n do r.(i)<- plusP (coef x i p) (coef x i q); done; Prec(x,r))) in norm res (* content, positive integer *) let rec content p = match p with Pint a -> C.abs a | Prec (x ,p1) -> Array.fold_left C.pgcd coef0 (Array.map content p1) let rec div_int p a= match p with Pint b -> Pint (C.div b a) | Prec(x,p1) -> Prec(x,Array.map (fun x -> div_int x a) p1) let vire_contenu p = let c = content p in if C.equal c coef0 then p else div_int p c (* sorted list of variables of a polynomial *) let rec vars=function Pint _->[] | Prec (x,l)->(List.flatten ([x]::(List.map vars (Array.to_list l)))) (* multiply p by v^n, v >= max_var p *) let rec multx n v p = match p with Prec (x,p1) when x=v -> let p2= Array.create ((Array.length p1)+n) (Pint coef0) in for i=0 to (Array.length p1)-1 do p2.(i+n)<-p1.(i); done; Prec (x,p2) |_ -> if equal p (Pint coef0) then (Pint coef0) else (let p2=Array.create (n+1) (Pint coef0) in p2.(n)<-p; Prec (v,p2)) (* product *) let rec multP p q = match (p,q) with (Pint a,Pint b) -> Pint (C.mult a b) |(Pint a, Prec (y,q1)) -> if C.equal a coef0 then Pint coef0 else let q2 = Array.map (fun z-> multP p z) q1 in Prec (y,q2) |(Prec (x,p1), Pint b) -> if C.equal b coef0 then Pint coef0 else let p2 = Array.map (fun z-> multP z q) p1 in Prec (x,p2) |(Prec (x,p1), Prec(y,q1)) -> if x multP p z) q1 in Prec (y,q2)) else if x>y then (let p2 = Array.map (fun z-> multP z q) p1 in Prec (x,p2)) else Array.fold_left plusP (Pint coef0) (Array.mapi (fun i z-> (multx i x (multP z q))) p1) (* derive p with variable v, v >= max_var p *) let rec deriv v p = match p with Pint a -> Pint coef0 | Prec(x,p1) when x=v -> let d = Array.length p1 -1 in if d=1 then p1.(1) else (let p2 = Array.create d (Pint coef0) in for i=0 to d-1 do p2.(i)<- multP (Pint (coef_of_int (i+1))) p1.(i+1); done; Prec (x,p2)) | Prec(x,p1)-> Pint coef0 (* opposite *) let rec oppP p = match p with Pint a -> Pint (C.opp a) |Prec(x,p1) -> Prec(x,Array.map oppP p1) let moinsP p q=plusP p (oppP q) let rec puisP p n = match n with 0 -> cf1 |_ -> (multP p (puisP p (n-1))) (* infix notations *) (*let (++) a b = plusP a b *) let (@@) a b = multP a b let (--) a b = moinsP a b let (^^) a b = puisP a b (* leading coefficient in v, v>= max_var p *) let coefDom v p= coef v (deg v p) p let coefConst v p = coef v 0 p (* tail of a polynomial *) let remP v p = moinsP p (multP (coefDom v p) (puisP (x v) (deg v p))) (* first interger coefficient of p *) let rec coef_int_tete p = let v = max_var_pol p in if v>0 then coef_int_tete (coefDom v p) else (match p with | Pint a -> a |_ -> assert false) (* divide by the content and make the head int coef positive *) let normc p = let p = vire_contenu p in let a = coef_int_tete p in if C.le coef0 a then p else oppP p (* constant coef of normalized polynomial *) let rec coef_constant p = match p with Pint a->a |Prec(_,q)->coef_constant q.(0) (*********************************************************************** 3. Printing polynomials. *) (* if univ = false, we use x,y,z,a,b,c,d... as variables, else x1,x2,... *) let univ=ref true let string_of_var x= if !univ then "u"^(string_of_int x) else if x<=3 then String.make 1 (Char.chr(x+(Char.code 'w'))) else String.make 1 (Char.chr(x-4+(Char.code 'a'))) let nsP = ref 0 let rec string_of_Pcut p = if (!nsP)<=0 then "..." else match p with |Pint a-> nsP:=(!nsP)-1; if C.le coef0 a then C.to_string a else "("^(C.to_string a)^")" |Prec (x,t)-> let v=string_of_var x and s=ref "" and sp=ref "" in let st0 = string_of_Pcut t.(0) in if st0<>"0" then s:=st0; let fin = ref false in for i=(Array.length t)-1 downto 1 do if (!nsP)<0 then (sp:="..."; if not (!fin) then s:=(!s)^"+"^(!sp); fin:=true) else ( let si=string_of_Pcut t.(i) in sp:=""; if i=1 then ( if si<>"0" then (nsP:=(!nsP)-1; if si="1" then sp:=v else (if (String.contains si '+') then sp:="("^si^")*"^v else sp:=si^"*"^v))) else ( if si<>"0" then (nsP:=(!nsP)-1; if si="1" then sp:=v^"^"^(string_of_int i) else (if (String.contains si '+') then sp:="("^si^")*"^v^"^"^(string_of_int i) else sp:=si^"*"^v^"^"^(string_of_int i)))); if !sp<>"" && not (!fin) then (nsP:=(!nsP)-1; if !s="" then s:=!sp else s:=(!s)^"+"^(!sp))); done; if !s="" then (nsP:=(!nsP)-1; (s:="0")); !s let to_string p = nsP:=20; string_of_Pcut p let printP p = Format.printf "@[%s@]" (to_string p) let print_tpoly lp = let s = ref "\n{ " in Array.iter (fun p -> s:=(!s)^(to_string p)^"\n") lp; prt0 ((!s)^"}") let print_lpoly lp = print_tpoly (Array.of_list lp) (*********************************************************************** 4. Exact division of polynomials. *) (* return (s,r) s.t. p = s*q+r *) let rec quo_rem_pol p q x = if x=0 then (match (p,q) with |(Pint a, Pint b) -> if C.equal (C.modulo a b) coef0 then (Pint (C.div a b), cf0) else failwith "div_pol1" |_ -> assert false) else let m = deg x q in let b = coefDom x q in let q1 = remP x q in (* q = b*x^m+q1 *) let r = ref p in let s = ref cf0 in let continue =ref true in while (!continue) && (not (equal !r cf0)) do let n = deg x !r in if n false (*********************************************************************** 5. Pseudo-division and gcd with subresultants. *) (* pseudo division : q = c*x^m+q1 retruns (r,c,d,s) s.t. c^d*p = s*q + r. *) let pseudo_div p q x = match q with Pint _ -> (cf0, q,1, p) | Prec (v,q1) when x<>v -> (cf0, q,1, p) | Prec (v,q1) -> ( (* pr "pseudo_division: c^d*p = s*q + r";*) let delta = ref 0 in let r = ref p in let c = coefDom x q in let q1 = remP x q in let d' = deg x q in let s = ref cf0 in while (deg x !r)>=(deg x q) do let d = deg x !r in let a = coefDom x !r in let r1=remP x !r in let u = a @@ ((monome x (d-d'))) in r:=(c @@ r1) -- (u @@ q1); s:=plusP (c @@ (!s)) u; delta := (!delta) + 1; done; (* pr ("deg d: "^(string_of_int (!delta))^", deg c: "^(string_of_int (deg_total c))); pr ("deg r:"^(string_of_int (deg_total !r))); *) (!r,c,!delta, !s) ) (* gcd with subresultants *) let rec pgcdP p q = let x = max (max_var_pol p) (max_var_pol q) in pgcd_pol p q x and pgcd_pol p q x = pgcd_pol_rec p q x and content_pol p x = match p with Prec(v,p1) when v=x -> Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) cf0 p1 | _ -> p and pgcd_coef_pol c p x = match p with Prec(v,p1) when x=v -> Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) c p1 |_ -> pgcd_pol_rec c p (x-1) and pgcd_pol_rec p q x = match (p,q) with (Pint a,Pint b) -> Pint (C.pgcd (C.abs a) (C.abs b)) |_ -> if equal p cf0 then q else if equal q cf0 then p else if (deg x q) = 0 then pgcd_coef_pol q p x else if (deg x p) = 0 then pgcd_coef_pol p q x else ( let a = content_pol p x in let b = content_pol q x in let c = pgcd_pol_rec a b (x-1) in pr (string_of_int x); let p1 = div_pol p c x in let q1 = div_pol q c x in let r = gcd_sub_res p1 q1 x in let cr = content_pol r x in let res = c @@ (div_pol r cr x) in res ) (* Sub-résultants: ai*Ai = Qi*Ai+1 + bi*Ai+2 deg Ai+2 < deg Ai+1 Ai = ci*X^ni + ... di = ni - ni+1 ai = (- ci+1)^(di + 1) b1 = 1 bi = ci*si^di si i>1 s1 = 1 si+1 = ((ci+1)^di*si)/si^di *) and gcd_sub_res p q x = if equal q cf0 then p else let d = deg x p in let d' = deg x q in if d (C.hash a) | Prec (v,p) -> Array.fold_right (fun q h -> h + hash q) p 0 module Hashpol = Hashtbl.Make( struct type poly = t type t = poly let equal = equal let hash = hash end) end coq-8.4pl4/plugins/nsatz/nsatz.ml40000644000175000017500000004055212326224777016236 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 1 let puis = power_big_int_positive_int (* a et b positifs, rÃĐsultat positif *) let rec pgcd a b = if equal b coef0 then a else if lt a b then pgcd b a else pgcd b (modulo a b) (* signe du pgcd = signe(a)*signe(b) si non nuls. *) let pgcd2 a b = if equal a coef0 then b else if equal b coef0 then a else let c = pgcd (abs a) (abs b) in if ((lt coef0 a)&&(lt b coef0)) ||((lt coef0 b)&&(lt a coef0)) then opp c else c end (* module Ent = struct type t = Entiers.entiers let of_int = Entiers.ent_of_int let of_num x = Entiers.ent_of_string(Num.string_of_num x) let to_num x = Num.num_of_string (Entiers.string_of_ent x) let equal = Entiers.eq_ent let lt = Entiers.lt_ent let le = Entiers.le_ent let abs = Entiers.abs_ent let plus =Entiers.add_ent let mult = Entiers.mult_ent let sub = Entiers.moins_ent let opp = Entiers.opp_ent let div = Entiers.div_ent let modulo = Entiers.mod_ent let coef0 = Entiers.ent0 let coef1 = Entiers.ent1 let to_string = Entiers.string_of_ent let to_int x = Entiers.int_of_ent x let hash x =Entiers.hash_ent x let signe = Entiers.signe_ent let rec puis p n = match n with 0 -> coef1 |_ -> (mult p (puis p (n-1))) (* a et b positifs, rÃĐsultat positif *) let rec pgcd a b = if equal b coef0 then a else if lt a b then pgcd b a else pgcd b (modulo a b) (* signe du pgcd = signe(a)*signe(b) si non nuls. *) let pgcd2 a b = if equal a coef0 then b else if equal b coef0 then a else let c = pgcd (abs a) (abs b) in if ((lt coef0 a)&&(lt b coef0)) ||((lt coef0 b)&&(lt a coef0)) then opp c else c end *) (* ------------------------------------------------------------------------- *) (* ------------------------------------------------------------------------- *) type vname = string type term = | Zero | Const of Num.num | Var of vname | Opp of term | Add of term * term | Sub of term * term | Mul of term * term | Pow of term * int let const n = if eq_num n num_0 then Zero else Const n let pow(p,i) = if i=1 then p else Pow(p,i) let add = function (Zero,q) -> q | (p,Zero) -> p | (p,q) -> Add(p,q) let mul = function (Zero,_) -> Zero | (_,Zero) -> Zero | (p,Const n) when eq_num n num_1 -> p | (Const n,q) when eq_num n num_1 -> q | (p,q) -> Mul(p,q) let unconstr = mkRel 1 let tpexpr = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PExpr") let ttconst = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEc") let ttvar = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEX") let ttadd = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEadd") let ttsub = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEsub") let ttmul = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEmul") let ttopp = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEopp") let ttpow = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEpow") let datatypes = ["Init";"Datatypes"] let binnums = ["Numbers";"BinNums"] let tlist = lazy (gen_constant "CC" datatypes "list") let lnil = lazy (gen_constant "CC" datatypes "nil") let lcons = lazy (gen_constant "CC" datatypes "cons") let tz = lazy (gen_constant "CC" binnums "Z") let z0 = lazy (gen_constant "CC" binnums "Z0") let zpos = lazy (gen_constant "CC" binnums "Zpos") let zneg = lazy(gen_constant "CC" binnums "Zneg") let pxI = lazy(gen_constant "CC" binnums "xI") let pxO = lazy(gen_constant "CC" binnums "xO") let pxH = lazy(gen_constant "CC" binnums "xH") let nN0 = lazy (gen_constant "CC" binnums "N0") let nNpos = lazy(gen_constant "CC" binnums "Npos") let mkt_app name l = mkApp (Lazy.force name, Array.of_list l) let tlp () = mkt_app tlist [mkt_app tpexpr [Lazy.force tz]] let tllp () = mkt_app tlist [tlp()] let rec mkt_pos n = if n =/ num_1 then Lazy.force pxH else if mod_num n num_2 =/ num_0 then mkt_app pxO [mkt_pos (quo_num n num_2)] else mkt_app pxI [mkt_pos (quo_num n num_2)] let mkt_n n = if n=num_0 then Lazy.force nN0 else mkt_app nNpos [mkt_pos n] let mkt_z z = if z =/ num_0 then Lazy.force z0 else if z >/ num_0 then mkt_app zpos [mkt_pos z] else mkt_app zneg [mkt_pos ((Int 0) -/ z)] let rec mkt_term t = match t with | Zero -> mkt_term (Const num_0) | Const r -> let (n,d) = numdom r in mkt_app ttconst [Lazy.force tz; mkt_z n] | Var v -> mkt_app ttvar [Lazy.force tz; mkt_pos (num_of_string v)] | Opp t1 -> mkt_app ttopp [Lazy.force tz; mkt_term t1] | Add (t1,t2) -> mkt_app ttadd [Lazy.force tz; mkt_term t1; mkt_term t2] | Sub (t1,t2) -> mkt_app ttsub [Lazy.force tz; mkt_term t1; mkt_term t2] | Mul (t1,t2) -> mkt_app ttmul [Lazy.force tz; mkt_term t1; mkt_term t2] | Pow (t1,n) -> if (n = 0) then mkt_app ttconst [Lazy.force tz; mkt_z num_1] else mkt_app ttpow [Lazy.force tz; mkt_term t1; mkt_n (num_of_int n)] let rec parse_pos p = match kind_of_term p with | App (a,[|p2|]) -> if eq_constr a (Lazy.force pxO) then num_2 */ (parse_pos p2) else num_1 +/ (num_2 */ (parse_pos p2)) | _ -> num_1 let parse_z z = match kind_of_term z with | App (a,[|p2|]) -> if eq_constr a (Lazy.force zpos) then parse_pos p2 else (num_0 -/ (parse_pos p2)) | _ -> num_0 let parse_n z = match kind_of_term z with | App (a,[|p2|]) -> parse_pos p2 | _ -> num_0 let rec parse_term p = match kind_of_term p with | App (a,[|_;p2|]) -> if eq_constr a (Lazy.force ttvar) then Var (string_of_num (parse_pos p2)) else if eq_constr a (Lazy.force ttconst) then Const (parse_z p2) else if eq_constr a (Lazy.force ttopp) then Opp (parse_term p2) else Zero | App (a,[|_;p2;p3|]) -> if eq_constr a (Lazy.force ttadd) then Add (parse_term p2, parse_term p3) else if eq_constr a (Lazy.force ttsub) then Sub (parse_term p2, parse_term p3) else if eq_constr a (Lazy.force ttmul) then Mul (parse_term p2, parse_term p3) else if eq_constr a (Lazy.force ttpow) then Pow (parse_term p2, int_of_num (parse_n p3)) else Zero | _ -> Zero let rec parse_request lp = match kind_of_term lp with | App (_,[|_|]) -> [] | App (_,[|_;p;lp1|]) -> (parse_term p)::(parse_request lp1) |_-> assert false let nvars = ref 0 let set_nvars_term t = let rec aux t = match t with | Zero -> () | Const r -> () | Var v -> let n = int_of_string v in nvars:= max (!nvars) n | Opp t1 -> aux t1 | Add (t1,t2) -> aux t1; aux t2 | Sub (t1,t2) -> aux t1; aux t2 | Mul (t1,t2) -> aux t1; aux t2 | Pow (t1,n) -> aux t1 in aux t let string_of_term p = let rec aux p = match p with | Zero -> "0" | Const r -> string_of_num r | Var v -> "x"^v | Opp t1 -> "(-"^(aux t1)^")" | Add (t1,t2) -> "("^(aux t1)^"+"^(aux t2)^")" | Sub (t1,t2) -> "("^(aux t1)^"-"^(aux t2)^")" | Mul (t1,t2) -> "("^(aux t1)^"*"^(aux t2)^")" | Pow (t1,n) -> (aux t1)^"^"^(string_of_int n) in aux p (*********************************************************************** Coefficients: recursive polynomials *) module Coef = BigInt (*module Coef = Ent*) module Poly = Polynom.Make(Coef) module PIdeal = Ideal.Make(Poly) open PIdeal (* term to sparse polynomial varaibles <=np are in the coefficients *) let term_pol_sparse np t= let d = !nvars in let rec aux t = (* info ("conversion de: "^(string_of_term t)^"\n");*) let res = match t with | Zero -> zeroP | Const r -> if r = num_0 then zeroP else polconst d (Poly.Pint (Coef.of_num r)) | Var v -> let v = int_of_string v in if v <= np then polconst d (Poly.x v) else gen d v | Opp t1 -> oppP (aux t1) | Add (t1,t2) -> plusP (aux t1) (aux t2) | Sub (t1,t2) -> plusP (aux t1) (oppP (aux t2)) | Mul (t1,t2) -> multP (aux t1) (aux t2) | Pow (t1,n) -> puisP (aux t1) n in (* info ("donne: "^(stringP res)^"\n");*) res in let res= aux t in res (* sparse polynomial to term *) let polrec_to_term p = let rec aux p = match p with |Poly.Pint n -> const (Coef.to_num n) |Poly.Prec (v,coefs) -> let res = ref Zero in Array.iteri (fun i c -> res:=add(!res, mul(aux c, pow (Var (string_of_int v), i)))) coefs; !res in aux p (* approximation of the Horner form used in the tactic ring *) let pol_sparse_to_term n2 p = (* info "pol_sparse_to_term ->\n";*) let p = PIdeal.repr p in let rec aux p = match p with [] -> const (num_of_string "0") | (a,m)::p1 -> let n = (Array.length m)-1 in let (i0,e0) = List.fold_left (fun (r,d) (a,m) -> let i0= ref 0 in for k=1 to n do if m.(k)>0 then i0:=k done; if !i0 = 0 then (r,d) else if !i0 > r then (!i0, m.(!i0)) else if !i0 = r && m.(!i0) if m.(i0)>=e0 then (m.(i0)<-m.(i0)-e0; p1:=(a,m)::(!p1)) else p2:=(a,m)::(!p2)) p; let vm = if e0=1 then Var (string_of_int (i0)) else pow (Var (string_of_int (i0)),e0) in add(mul(vm, aux (List.rev (!p1))), aux (List.rev (!p2)))) in (*info "-> pol_sparse_to_term\n";*) aux p let rec remove_list_tail l i = let rec aux l i = if l=[] then [] else if i<0 then l else if i=0 then List.tl l else match l with |(a::l1) -> a::(aux l1 (i-1)) |_ -> assert false in List.rev (aux (List.rev l) i) (* lq = [cn+m+1 n+m ...cn+m+1 1] lci=[[cn+1 n,...,cn1 1] ... [cn+m n+m-1,...,cn+m 1]] removes intermediate polynomials not useful to compute the last one. *) let remove_zeros zero lci = let n = List.length (List.hd lci) in let m=List.length lci in let u = Array.create m false in let rec utiles k = if k>=m then () else ( u.(k)<-true; let lc = List.nth lci k in for i=0 to List.length lc - 1 do if not (zero (List.nth lc i)) then utiles (i+k+1); done) in utiles 0; let lr = ref [] in for i=0 to m-1 do if u.(i) then lr:=(List.nth lci i)::(!lr) done; let lr=List.rev !lr in let lr = List.map (fun lc -> let lcr=ref lc in for i=0 to m-1 do if not u.(i) then lcr:=remove_list_tail !lcr (m-i+(n-m)) done; !lcr) lr in info ("useless spolynomials: " ^string_of_int (m-List.length lr)^"\n"); info ("useful spolynomials: " ^string_of_int (List.length lr)^"\n"); lr let theoremedeszeros lpol p = let t1 = Unix.gettimeofday() in let m = !nvars in let (lp0,p,cert) = in_ideal m lpol p in let lpc = List.rev !poldepcontent in info ("time: "^Format.sprintf "@[%10.3f@]s\n" (Unix.gettimeofday ()-.t1)); (cert,lp0,p,lpc) open Ideal let theoremedeszeros_termes lp = nvars:=0;(* mise a jour par term_pol_sparse *) List.iter set_nvars_term lp; match lp with | Const (Int sugarparam)::Const (Int nparam)::lp -> ((match sugarparam with |0 -> info "computation without sugar\n"; lexico:=false; sugar_flag := false; divide_rem_with_critical_pair := false |1 -> info "computation with sugar\n"; lexico:=false; sugar_flag := true; divide_rem_with_critical_pair := false |2 -> info "ordre lexico computation without sugar\n"; lexico:=true; sugar_flag := false; divide_rem_with_critical_pair := false |3 -> info "ordre lexico computation with sugar\n"; lexico:=true; sugar_flag := true; divide_rem_with_critical_pair := false |4 -> info "computation without sugar, division by pairs\n"; lexico:=false; sugar_flag := false; divide_rem_with_critical_pair := true |5 -> info "computation with sugar, division by pairs\n"; lexico:=false; sugar_flag := true; divide_rem_with_critical_pair := true |6 -> info "ordre lexico computation without sugar, division by pairs\n"; lexico:=true; sugar_flag := false; divide_rem_with_critical_pair := true |7 -> info "ordre lexico computation with sugar, division by pairs\n"; lexico:=true; sugar_flag := true; divide_rem_with_critical_pair := true | _ -> error "nsatz: bad parameter" ); let m= !nvars in let lvar=ref [] in for i=m downto 1 do lvar:=["x"^(string_of_int i)^""]@(!lvar); done; lvar:=["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"] @ (!lvar); (* pour macaulay *) name_var:=!lvar; let lp = List.map (term_pol_sparse nparam) lp in match lp with | [] -> assert false | p::lp1 -> let lpol = List.rev lp1 in let (cert,lp0,p,_lct) = theoremedeszeros lpol p in info "cert ok\n"; let lc = cert.last_comb::List.rev cert.gb_comb in match remove_zeros (fun x -> x=zeroP) lc with | [] -> assert false | (lq::lci) -> (* lci commence par les nouveaux polynomes *) let m= !nvars in let c = pol_sparse_to_term m (polconst m cert.coef) in let r = Pow(Zero,cert.power) in let lci = List.rev lci in let lci = List.map (List.map (pol_sparse_to_term m)) lci in let lq = List.map (pol_sparse_to_term m) lq in info ("number of parametres: "^string_of_int nparam^"\n"); info "term computed\n"; (c,r,lci,lq) ) |_ -> assert false (* version avec hash-consing du certificat: let nsatz lpol = Hashtbl.clear Dansideal.hmon; Hashtbl.clear Dansideal.coefpoldep; Hashtbl.clear Dansideal.sugartbl; Hashtbl.clear Polynomesrec.hcontentP; init_constants (); let lp= parse_request lpol in let (_lp0,_p,c,r,_lci,_lq as rthz) = theoremedeszeros_termes lp in let certif = certificat_vers_polynome_creux rthz in let certif = hash_certif certif in let certif = certif_term certif in let c = mkt_term c in info "constr computed\n"; (c, certif) *) let nsatz lpol = let lp= parse_request lpol in let (c,r,lci,lq) = theoremedeszeros_termes lp in let res = [c::r::lq]@lci in let res = List.map (fun lx -> List.map mkt_term lx) res in let res = List.fold_right (fun lt r -> let ltterm = List.fold_right (fun t r -> mkt_app lcons [mkt_app tpexpr [Lazy.force tz];t;r]) lt (mkt_app lnil [mkt_app tpexpr [Lazy.force tz]]) in mkt_app lcons [tlp ();ltterm;r]) res (mkt_app lnil [tlp ()]) in info "term computed\n"; res let return_term t = let a = mkApp(gen_constant "CC" ["Init";"Logic"] "refl_equal",[|tllp ();t|]) in generalize [a] let nsatz_compute t = let lpol = try nsatz t with Ideal.NotInIdeal -> error "nsatz cannot solve this problem" in return_term lpol TACTIC EXTEND nsatz_compute | [ "nsatz_compute" constr(lt) ] -> [ nsatz_compute lt ] END coq-8.4pl4/plugins/nsatz/utile.mli0000644000175000017500000000111112326224777016272 0ustar stephsteph (* Printing *) val pr : string -> unit val prn : string -> unit val prt0 : 'a -> unit val prt : string -> unit val info : string -> unit (* Listes *) val list_mem_eq : ('a -> 'b -> bool) -> 'a -> 'b list -> bool val set_of_list_eq : ('a -> 'a -> bool) -> 'a list -> 'a list (* Memoization *) val memos : string -> ('a, 'b) Hashtbl.t -> ('c -> 'a) -> ('c -> 'b) -> 'c -> 'b val facteurs_liste : ('a -> 'a -> 'a) -> ('a -> bool) -> 'a list -> 'a list val factorise_tableau : ('a -> 'b -> 'a) -> ('a -> bool) -> 'a -> 'a array -> 'b array -> 'b array * ('a * int list) array coq-8.4pl4/plugins/nsatz/nsatz_plugin.mllib0000644000175000017500000000005312326224777020207 0ustar stephstephUtile Polynom Ideal Nsatz Nsatz_plugin_mod coq-8.4pl4/plugins/quote/0000755000175000017500000000000012365131025014433 5ustar stephstephcoq-8.4pl4/plugins/quote/vo.itarget0000644000175000017500000000001012326224777016445 0ustar stephstephQuote.vocoq-8.4pl4/plugins/quote/g_quote.ml40000644000175000017500000000223412326224777016533 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* k)) in let x = TacDynamic(dummy_loc, Pretyping.constr_in x) in let tac = <:tactic> in Tacinterp.interp tac TACTIC EXTEND quote [ "quote" ident(f) ] -> [ quote f [] ] | [ "quote" ident(f) "[" ne_ident_list(lc) "]"] -> [ quote f lc ] | [ "quote" ident(f) "in" constr(c) "using" tactic(k) ] -> [ gen_quote (make_cont k) c f [] ] | [ "quote" ident(f) "[" ne_ident_list(lc) "]" "in" constr(c) "using" tactic(k) ] -> [ gen_quote (make_cont k) c f lc ] END coq-8.4pl4/plugins/quote/quote.ml0000644000175000017500000004146212326224777016147 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (varmap A L) -> A}. Then, the tactic \texttt{quote f} will replace an expression \texttt{e} of type \texttt{A} by \texttt{(f vm t)} such that \texttt{e} and \texttt{(f vm t)} are convertible. The problem is then inverting the function \texttt{f}. The tactic works when: \begin{itemize} \item L is a simple inductive datatype. The constructors of L may have one of the three following forms: \begin{enumerate} \item ordinary recursive constructors like: \verb|Cplus : L -> L -> L| \item variable leaf like: \verb|Cvar : index -> L| \item constant leaf like \verb|Cconst : A -> L| \end{enumerate} The definition of \texttt{L} must contain at most one variable leaf and at most one constant leaf. When there are both a variable leaf and a constant leaf, there is an ambiguity on inversion. The term t can be either the interpretation of \texttt{(Cconst t)} or the interpretation of (\texttt{Cvar}~$i$) in a variable map containing the binding $i \rightarrow$~\texttt{t}. How to discriminate between these choices? To solve the dilemma, one gives to \texttt{quote} a list of \emph{constant constructors}: a term will be considered as a constant if it is either a constant constructor or the application of a constant constructor to constants. For example the list \verb+[S, O]+ defines the closed natural numbers. \texttt{(S (S O))} is a constant when \texttt{(S x)} is not. The definition of constants vary for each application of the tactic, so it can even be different for two applications of \texttt{quote} with the same function. \item \texttt{f} is a quite simple fixpoint on \texttt{L}. In particular, \texttt{f} must verify: \begin{verbatim} (f (Cvar i)) = (varmap_find vm default_value i) \end{verbatim} \begin{verbatim} (f (Cconst c)) = c \end{verbatim} where \texttt{index} and \texttt{varmap\_find} are those defined the \texttt{Quote} module. \emph{The tactic won't work with user's own variables map!!} It is mandatory to use the variable map defined in module \texttt{Quote}. \end{itemize} The method to proceed is then clear: \begin{itemize} \item Start with an empty hashtable of "registed leafs" that maps constr to integers and a "variable counter" equal to 0. \item Try to match the term with every right hand side of the definition of \texttt{f}. If there is one match, returns the correponding left hand side and call yourself recursively to get the arguments of this left hand side. If there is no match, we are at a leaf. That is the interpretation of either a variable or a constant. If it is a constant, return \texttt{Cconst} applied to that constant. If not, it is a variable. Look in the hashtable if this leaf has been already encountered. If not, increment the variable counter and add an entry to the hashtable; then return \texttt{(Cvar !variables\_counter)} \end{itemize} *) (*i*) open Pp open Util open Names open Term open Pattern open Matching open Tacmach open Tactics open Tacexpr (*i*) (*s First, we need to access some Coq constants We do that lazily, because this code can be linked before the constants are loaded in the environment *) let constant dir s = Coqlib.gen_constant "Quote" ("quote"::dir) s let coq_Empty_vm = lazy (constant ["Quote"] "Empty_vm") let coq_Node_vm = lazy (constant ["Quote"] "Node_vm") let coq_varmap_find = lazy (constant ["Quote"] "varmap_find") let coq_Right_idx = lazy (constant ["Quote"] "Right_idx") let coq_Left_idx = lazy (constant ["Quote"] "Left_idx") let coq_End_idx = lazy (constant ["Quote"] "End_idx") (*s Then comes the stuff to decompose the body of interpetation function and pre-compute the inversion data. For a function like: \begin{verbatim} Fixpoint interp (vm:varmap Prop) (f:form) := match f with | f_and f1 f1 f2 => (interp f1) /\ (interp f2) | f_or f1 f1 f2 => (interp f1) \/ (interp f2) | f_var i => varmap_find Prop default_v i vm | f_const c => c end. \end{verbatim} With the constant constructors \texttt{C1}, \dots, \texttt{Cn}, the corresponding scheme will be: \begin{verbatim} {normal_lhs_rhs = [ "(f_and ?1 ?2)", "?1 /\ ?2"; "(f_or ?1 ?2)", " ?1 \/ ?2";]; return_type = "Prop"; constants = Some [C1,...Cn]; variable_lhs = Some "(f_var ?1)"; constant_lhs = Some "(f_const ?1)" } \end{verbatim} If there is no constructor for variables in the type \texttt{form}, then [variable_lhs] is [None]. Idem for constants and [constant_lhs]. Both cannot be equal to [None]. The metas in the RHS must correspond to those in the LHS (one cannot exchange ?1 and ?2 in the example above) *) module ConstrSet = Set.Make( struct type t = constr let compare = constr_ord end) type inversion_scheme = { normal_lhs_rhs : (constr * constr_pattern) list; variable_lhs : constr option; return_type : constr; constants : ConstrSet.t; constant_lhs : constr option } (*s [compute_ivs gl f cs] computes the inversion scheme associated to [f:constr] with constants list [cs:constr list] in the context of goal [gl]. This function uses the auxiliary functions [i_can't_do_that], [decomp_term], [compute_lhs] and [compute_rhs]. *) let i_can't_do_that () = error "Quote: not a simple fixpoint" let decomp_term c = kind_of_term (strip_outer_cast c) (*s [compute_lhs typ i nargsi] builds the term \texttt{(C ?nargsi ... ?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive type [typ] *) let coerce_meta_out id = let s = string_of_id id in int_of_string (String.sub s 1 (String.length s - 1)) let coerce_meta_in n = id_of_string ("M" ^ string_of_int n) let compute_lhs typ i nargsi = match kind_of_term typ with | Ind(sp,0) -> let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in mkApp (mkConstruct ((sp,0),i+1), argsi) | _ -> i_can't_do_that () (*s This function builds the pattern from the RHS. Recursive calls are replaced by meta-variables ?i corresponding to those in the LHS *) let compute_rhs bodyi index_of_f = let rec aux c = match kind_of_term c with | App (j, args) when isRel j && destRel j = index_of_f (* recursive call *) -> let i = destRel (array_last args) in PMeta (Some (coerce_meta_in i)) | App (f,args) -> PApp (snd (pattern_of_constr Evd.empty f), Array.map aux args) | Cast (c,_,_) -> aux c | _ -> snd (pattern_of_constr Evd.empty c) in aux bodyi (*s Now the function [compute_ivs] itself *) let compute_ivs gl f cs = let cst = try destConst f with e when Errors.noncritical e -> i_can't_do_that () in let body = Environ.constant_value (Global.env()) cst in match decomp_term body with | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) -> let (args3, body3) = decompose_lam body2 in let nargs3 = List.length args3 in begin match decomp_term body3 with | Case(_,p,c,lci) -> (*

    Case c of c1 ... cn end *) let n_lhs_rhs = ref [] and v_lhs = ref (None : constr option) and c_lhs = ref (None : constr option) in Array.iteri (fun i ci -> let argsi, bodyi = decompose_lam ci in let nargsi = List.length argsi in (* REL (narg3 + nargsi + 1) is f *) (* REL nargsi+1 to REL nargsi + nargs3 are arguments of f *) (* REL 1 to REL nargsi are argsi (reverse order) *) (* First we test if the RHS is the RHS for constants *) if isRel bodyi && destRel bodyi = 1 then c_lhs := Some (compute_lhs (snd (List.hd args3)) i nargsi) (* Then we test if the RHS is the RHS for variables *) else begin match decompose_app bodyi with | vmf, [_; _; a3; a4 ] when isRel a3 & isRel a4 & pf_conv_x gl vmf (Lazy.force coq_varmap_find)-> v_lhs := Some (compute_lhs (snd (List.hd args3)) i nargsi) (* Third case: this is a normal LHS-RHS *) | _ -> n_lhs_rhs := (compute_lhs (snd (List.hd args3)) i nargsi, compute_rhs bodyi (nargs3 + nargsi + 1)) :: !n_lhs_rhs end) lci; if !c_lhs = None & !v_lhs = None then i_can't_do_that (); (* The Cases predicate is a lambda; we assume no dependency *) let p = match kind_of_term p with | Lambda (_,_,p) -> Termops.pop p | _ -> p in { normal_lhs_rhs = List.rev !n_lhs_rhs; variable_lhs = !v_lhs; return_type = p; constants = List.fold_right ConstrSet.add cs ConstrSet.empty; constant_lhs = !c_lhs } | _ -> i_can't_do_that () end |_ -> i_can't_do_that () (* TODO for that function: \begin{itemize} \item handle the case where the return type is an argument of the function \item handle the case of simple mutual inductive (for example terms and lists of terms) formulas with the corresponding mutual recursvive interpretation functions. \end{itemize} *) (*s Stuff to build variables map, currently implemented as complete binary search trees (see file \texttt{Quote.v}) *) (* First the function to distinghish between constants (closed terms) and variables (open terms) *) let rec closed_under cset t = (ConstrSet.mem t cset) or (match (kind_of_term t) with | Cast(c,_,_) -> closed_under cset c | App(f,l) -> closed_under cset f && array_for_all (closed_under cset) l | _ -> false) (*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete binary search tree containing the [ci], that is: \begin{verbatim} c1 / \ c2 c3 / \ c4 c5 \end{verbatim} The second argument is a constr (the common type of the [ci]) *) let btree_of_array a ty = let size_of_a = Array.length a in let semi_size_of_a = size_of_a lsr 1 in let node = Lazy.force coq_Node_vm and empty = mkApp (Lazy.force coq_Empty_vm, [| ty |]) in let rec aux n = if n > size_of_a then empty else if n > semi_size_of_a then mkApp (node, [| ty; a.(n-1); empty; empty |]) else mkApp (node, [| ty; a.(n-1); aux (2*n); aux (2*n+1) |]) in aux 1 (*s [btree_of_array] and [path_of_int] verify the following invariant:\\ {\tt (varmap\_find A dv }[(path_of_int n)] [(btree_of_array a ty)] = [a.(n)]\\ [n] must be [> 0] *) let path_of_int n = (* returns the list of digits of n in reverse order with initial 1 removed *) let rec digits_of_int n = if n=1 then [] else (n mod 2 = 1)::(digits_of_int (n lsr 1)) in List.fold_right (fun b c -> mkApp ((if b then Lazy.force coq_Right_idx else Lazy.force coq_Left_idx), [| c |])) (List.rev (digits_of_int n)) (Lazy.force coq_End_idx) (*s The tactic works with a list of subterms sharing the same variables map. We need to sort terms in order to avoid than strange things happen during replacement of terms by their 'abstract' counterparties. *) (* [subterm t t'] tests if constr [t'] occurs in [t] *) (* This function does not descend under binders (lambda and Cases) *) let rec subterm gl (t : constr) (t' : constr) = (pf_conv_x gl t t') or (match (kind_of_term t) with | App (f,args) -> array_exists (fun t -> subterm gl t t') args | Cast(t,_,_) -> (subterm gl t t') | _ -> false) (*s We want to sort the list according to reverse subterm order. *) (* Since it's a partial order the algoritm of Sort.list won't work !! *) let rec sort_subterm gl l = let rec insert c = function | [] -> [c] | (h::t as l) when eq_constr c h -> l (* Avoid doing the same work twice *) | h::t -> if subterm gl c h then c::h::t else h::(insert c t) in match l with | [] -> [] | h::t -> insert h (sort_subterm gl t) module Constrhash = Hashtbl.Make (struct type t = constr let equal = eq_constr let hash = hash_constr end) (*s Now we are able to do the inversion itself. We destructurate the term and use an imperative hashtable to store leafs that are already encountered. The type of arguments is:\\ [ivs : inversion_scheme]\\ [lc: constr list]\\ [gl: goal sigma]\\ *) let quote_terms ivs lc gl = Coqlib.check_required_library ["Coq";"quote";"Quote"]; let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) let rec aux c = let rec auxl l = match l with | (lhs, rhs)::tail -> begin try let s1 = matches rhs c in let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux c_i)) s1 in Termops.subst_meta s2 lhs with PatternMatchingFailure -> auxl tail end | [] -> begin match ivs.variable_lhs with | None -> begin match ivs.constant_lhs with | Some c_lhs -> Termops.subst_meta [1, c] c_lhs | None -> anomaly "invalid inversion scheme for quote" end | Some var_lhs -> begin match ivs.constant_lhs with | Some c_lhs when closed_under ivs.constants c -> Termops.subst_meta [1, c] c_lhs | _ -> begin try Constrhash.find varhash c with Not_found -> let newvar = Termops.subst_meta [1, (path_of_int !counter)] var_lhs in begin incr counter; varlist := c :: !varlist; Constrhash.add varhash c newvar; newvar end end end end in auxl ivs.normal_lhs_rhs in let lp = List.map aux lc in (lp, (btree_of_array (Array.of_list (List.rev !varlist)) ivs.return_type )) (*s actually we could "quote" a list of terms instead of a single term. Ring for example needs that, but Ring doesn't use Quote yet. *) let quote f lid gl = let f = pf_global gl f in let cl = List.map (pf_global gl) lid in let ivs = compute_ivs gl f cl in let (p, vm) = match quote_terms ivs [(pf_concl gl)] gl with | [p], vm -> (p,vm) | _ -> assert false in match ivs.variable_lhs with | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast gl | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast gl let gen_quote cont c f lid gl = let f = pf_global gl f in let cl = List.map (pf_global gl) lid in let ivs = compute_ivs gl f cl in let (p, vm) = match quote_terms ivs [c] gl with | [p], vm -> (p,vm) | _ -> assert false in match ivs.variable_lhs with | None -> cont (mkApp (f, [| p |])) gl | Some _ -> cont (mkApp (f, [| vm; p |])) gl (*i Just testing ... #use "include.ml";; open Quote;; let r = glob_constr_of_string;; let ivs = { normal_lhs_rhs = [ r "(f_and ?1 ?2)", r "?1/\?2"; r "(f_not ?1)", r "~?1"]; variable_lhs = Some (r "(f_atom ?1)"); return_type = r "Prop"; constants = ConstrSet.empty; constant_lhs = (r "nat") };; let t1 = r "True/\(True /\ ~False)";; let t2 = r "True/\~~False";; quote_term ivs () t1;; quote_term ivs () t2;; let ivs2 = normal_lhs_rhs = [ r "(f_and ?1 ?2)", r "?1/\?2"; r "(f_not ?1)", r "~?1" r "True", r "f_true"]; variable_lhs = Some (r "(f_atom ?1)"); return_type = r "Prop"; constants = ConstrSet.empty; constant_lhs = (r "nat") i*) coq-8.4pl4/plugins/quote/quote_plugin.mllib0000644000175000017500000000003712326224777020205 0ustar stephstephQuote G_quote Quote_plugin_mod coq-8.4pl4/plugins/quote/Quote.v0000644000175000017500000000505012326224777015735 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool index_eq_prop: (n,m:index)(index_eq n m)=true -> n=m index_lt : index -> bool varmap : Type -> Type. varmap_find : (A:Type)A -> index -> (varmap A) -> A. The first arg. of varmap_find is the default value to take if the object is not found in the varmap. index_lt defines a total well-founded order, but we don't prove that. ***********************************************************************) Set Implicit Arguments. Section variables_map. Variable A : Type. Inductive varmap : Type := | Empty_vm : varmap | Node_vm : A -> varmap -> varmap -> varmap. Inductive index : Set := | Left_idx : index -> index | Right_idx : index -> index | End_idx : index. Fixpoint varmap_find (default_value:A) (i:index) (v:varmap) {struct v} : A := match i, v with | End_idx, Node_vm x _ _ => x | Right_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v2 | Left_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v1 | _, _ => default_value end. Fixpoint index_eq (n m:index) {struct m} : bool := match n, m with | End_idx, End_idx => true | Left_idx n', Left_idx m' => index_eq n' m' | Right_idx n', Right_idx m' => index_eq n' m' | _, _ => false end. Fixpoint index_lt (n m:index) {struct m} : bool := match n, m with | End_idx, Left_idx _ => true | End_idx, Right_idx _ => true | Left_idx n', Right_idx m' => true | Right_idx n', Right_idx m' => index_lt n' m' | Left_idx n', Left_idx m' => index_lt n' m' | _, _ => false end. Lemma index_eq_prop : forall n m:index, index_eq n m = true -> n = m. simple induction n; simple induction m; simpl; intros. rewrite (H i0 H1); reflexivity. discriminate. discriminate. discriminate. rewrite (H i0 H1); reflexivity. discriminate. discriminate. discriminate. reflexivity. Qed. End variables_map. Unset Implicit Arguments. coq-8.4pl4/plugins/pluginsbyte.itarget0000644000175000017500000000114212326224777017240 0ustar stephstephfield/field_plugin.cma setoid_ring/newring_plugin.cma extraction/extraction_plugin.cma decl_mode/decl_mode_plugin.cma firstorder/ground_plugin.cma rtauto/rtauto_plugin.cma fourier/fourier_plugin.cma romega/romega_plugin.cma omega/omega_plugin.cma micromega/micromega_plugin.cma xml/xml_plugin.cma subtac/subtac_plugin.cma ring/ring_plugin.cma cc/cc_plugin.cma nsatz/nsatz_plugin.cma funind/recdef_plugin.cma syntax/ascii_syntax_plugin.cma syntax/nat_syntax_plugin.cma syntax/numbers_syntax_plugin.cma syntax/r_syntax_plugin.cma syntax/string_syntax_plugin.cma syntax/z_syntax_plugin.cma quote/quote_plugin.cma coq-8.4pl4/plugins/setoid_ring/0000755000175000017500000000000012365131025015604 5ustar stephstephcoq-8.4pl4/plugins/setoid_ring/Ncring_tac.v0000644000175000017500000002233412326224777020064 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr:(t1::t2::nil) | ?t1 = ?t2 => constr:(t1::t2::nil) | (_ ?t1 ?t2) => constr:(t1::t2::nil) end. Lemma Zeqb_ok: forall x y : Z, Zeq_bool x y = true -> x == y. intros x y H. rewrite (Zeq_bool_eq x y H). reflexivity. Qed. Ltac reify_goal lvar lexpr lterm:= (*idtac lvar; idtac lexpr; idtac lterm;*) match lexpr with nil => idtac | ?e1::?e2::_ => match goal with |- (?op ?u1 ?u2) => change (op (@PEeval Z _ _ _ _ _ _ _ _ _ (@gen_phiZ _ _ _ _ _ _ _ _ _) N (fun n:N => n) (@pow_N _ _ _ _ _ _ _ _ _) lvar e1) (@PEeval Z _ _ _ _ _ _ _ _ _ (@gen_phiZ _ _ _ _ _ _ _ _ _) N (fun n:N => n) (@pow_N _ _ _ _ _ _ _ _ _) lvar e2)) end end. Lemma comm: forall (R:Type)`{Ring R}(c : Z) (x : R), x * (gen_phiZ c) == (gen_phiZ c) * x. induction c. intros. simpl. gen_rewrite. simpl. intros. rewrite <- same_gen. induction p. simpl. gen_rewrite. rewrite IHp. reflexivity. simpl. gen_rewrite. rewrite IHp. reflexivity. simpl. gen_rewrite. simpl. intros. rewrite <- same_gen. induction p. simpl. generalize IHp. clear IHp. gen_rewrite. intro IHp. rewrite IHp. reflexivity. simpl. generalize IHp. clear IHp. gen_rewrite. intro IHp. rewrite IHp. reflexivity. simpl. gen_rewrite. Qed. Ltac ring_gen := match goal with |- ?g => let lterm := lterm_goal g in match eval red in (list_reifyl (lterm:=lterm)) with | (?fv, ?lexpr) => (*idtac "variables:";idtac fv; idtac "terms:"; idtac lterm; idtac "reifications:"; idtac lexpr; *) reify_goal fv lexpr lterm; match goal with |- ?g => apply (@ring_correct Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ (@gen_phiZ _ _ _ _ _ _ _ _ _) _ (@comm _ _ _ _ _ _ _ _ _ _) Zeq_bool Zeqb_ok N (fun n:N => n) (@pow_N _ _ _ _ _ _ _ _ _)); [apply mkpow_th; reflexivity |vm_compute; reflexivity] end end end. Ltac non_commutative_ring:= intros; ring_gen. (* simplification *) Ltac ring_simplify_aux lterm fv lexpr hyp := match lterm with | ?t0::?lterm => match lexpr with | ?e::?le => (* e:PExpr Z est la rÃĐification de t0:R *) let t := constr:(@Ncring_polynom.norm_subst Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (@eq Z) Zops Zeq_bool e) in (* t:Pol Z *) let te := constr:(@Ncring_polynom.Pphi Z _ 0 1 _+_ _*_ _-_ -_ _==_ _ Ncring_initial.gen_phiZ fv t) in let eq1 := fresh "ring" in let nft := eval vm_compute in t in let t':= fresh "t" in pose (t' := nft); assert (eq1 : t = t'); [vm_cast_no_check (eq_refl t')| let eq2 := fresh "ring" in assert (eq2:(@Ncring_polynom.PEeval Z _ 0 1 _+_ _*_ _-_ -_ _==_ _ Ncring_initial.gen_phiZ N (fun n:N => n) (@Ring_theory.pow_N _ 1 multiplication) fv e) == te); [apply (@Ncring_polynom.norm_subst_ok Z _ 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (@eq Z) _ _ 0 1 _+_ _*_ _-_ -_ _==_ _ _ Ncring_initial.gen_phiZ _ (@comm _ 0 1 _+_ _*_ _-_ -_ _==_ _ _) _ Zeqb_ok); apply mkpow_th; reflexivity | match hyp with | 1%nat => rewrite eq2 | ?H => try rewrite eq2 in H end]; let P:= fresh "P" in match hyp with | 1%nat => idtac "ok"; rewrite eq1; pattern (@Ncring_polynom.Pphi Z _ 0 1 _+_ _*_ _-_ -_ _==_ _ Ncring_initial.gen_phiZ fv t'); match goal with |- (?p ?t) => set (P:=p) end; unfold t' in *; clear t' eq1 eq2; simpl | ?H => rewrite eq1 in H; pattern (@Ncring_polynom.Pphi Z _ 0 1 _+_ _*_ _-_ -_ _==_ _ Ncring_initial.gen_phiZ fv t') in H; match type of H with | (?p ?t) => set (P:=p) in H end; unfold t' in *; clear t' eq1 eq2; simpl in H end; unfold P in *; clear P ]; ring_simplify_aux lterm fv le hyp | nil => idtac end | nil => idtac end. Ltac set_variables fv := match fv with | nil => idtac | ?t::?fv => let v := fresh "X" in set (v:=t) in *; set_variables fv end. Ltac deset n:= match n with | 0%nat => idtac | S ?n1 => match goal with | h:= ?v : ?t |- ?g => unfold h in *; clear h; deset n1 end end. (* a est soit un terme de l'anneau, soit une liste de termes. J'ai pas rÃĐussi à un dÃĐcomposer les Vlists obtenues avec ne_constr_list dans Tactic Notation *) Ltac ring_simplify_gen a hyp := let lterm := match a with | _::_ => a | _ => constr:(a::nil) end in match eval red in (list_reifyl (lterm:=lterm)) with | (?fv, ?lexpr) => idtac lterm; idtac fv; idtac lexpr; let n := eval compute in (length fv) in idtac n; let lt:=fresh "lt" in set (lt:= lterm); let lv:=fresh "fv" in set (lv:= fv); (* les termes de fv sont remplacÃĐs par des variables pour pouvoir utiliser simpl ensuite sans risquer des simplifications indÃĐsirables *) set_variables fv; let lterm1 := eval unfold lt in lt in let lv1 := eval unfold lv in lv in idtac lterm1; idtac lv1; ring_simplify_aux lterm1 lv1 lexpr hyp; clear lt lv; (* on remet les termes de fv *) deset n end. Tactic Notation "non_commutative_ring_simplify" constr(lterm):= ring_simplify_gen lterm 1%nat. Tactic Notation "non_commutative_ring_simplify" constr(lterm) "in" ident(H):= ring_simplify_gen lterm H. coq-8.4pl4/plugins/setoid_ring/Field_theory.v0000644000175000017500000017646412326224777020450 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R->R) (ropp : R->R). Variable (rdiv : R -> R -> R) (rinv : R -> R). Variable req : R -> R -> Prop. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). Notation "x - y " := (rsub x y). Notation "x / y" := (rdiv x y). Notation "- x" := (ropp x). Notation "/ x" := (rinv x). Notation "x == y" := (req x y) (at level 70, no associativity). (* Equality properties *) Variable Rsth : Equivalence req. Variable Reqe : ring_eq_ext radd rmul ropp req. Variable SRinv_ext : forall p q, p == q -> / p == / q. (* Field properties *) Record almost_field_theory : Prop := mk_afield { AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req; AF_1_neq_0 : ~ 1 == 0; AFdiv_def : forall p q, p / q == p * / q; AFinv_l : forall p, ~ p == 0 -> / p * p == 1 }. Section AlmostField. Variable AFth : almost_field_theory. Let ARth := AFth.(AF_AR). Let rI_neq_rO := AFth.(AF_1_neq_0). Let rdiv_def := AFth.(AFdiv_def). Let rinv_l := AFth.(AFinv_l). (* Coefficients *) Variable C: Type. Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). Variable ceqb : C->C->bool. Variable phi : C -> R. Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. Lemma ceqb_rect : forall c1 c2 (A:Type) (x y:A) (P:A->Type), (phi c1 == phi c2 -> P x) -> P y -> P (if ceqb c1 c2 then x else y). Proof. intros. generalize (fun h => X (morph_eq CRmorph c1 c2 h)). case (ceqb c1 c2); auto. Qed. (* C notations *) Notation "x +! y" := (cadd x y) (at level 50). Notation "x *! y " := (cmul x y) (at level 40). Notation "x -! y " := (csub x y) (at level 50). Notation "-! x" := (copp x) (at level 35). Notation " x ?=! y" := (ceqb x y) (at level 70, no associativity). Notation "[ x ]" := (phi x) (at level 0). (* Useful tactics *) Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. Add Morphism rinv : rinv_ext. exact SRinv_ext. Qed. Let eq_trans := Setoid.Seq_trans _ _ Rsth. Let eq_sym := Setoid.Seq_sym _ _ Rsth. Let eq_refl := Setoid.Seq_refl _ _ Rsth. Hint Resolve eq_refl rdiv_def rinv_l rI_neq_rO CRmorph.(morph1) . Hint Resolve (Rmul_ext Reqe) (Rmul_ext Reqe) (Radd_ext Reqe) (ARsub_ext Rsth Reqe ARth) (Ropp_ext Reqe) SRinv_ext. Hint Resolve (ARadd_0_l ARth) (ARadd_comm ARth) (ARadd_assoc ARth) (ARmul_1_l ARth) (ARmul_0_l ARth) (ARmul_comm ARth) (ARmul_assoc ARth) (ARdistr_l ARth) (ARopp_mul_l ARth) (ARopp_add ARth) (ARsub_def ARth) . (* Power coefficients *) Variable Cpow : Type. Variable Cp_phi : N -> Cpow. Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory rI rmul req Cp_phi rpow. (* sign function *) Variable get_sign : C -> option C. Variable get_sign_spec : sign_theory copp ceqb get_sign. Variable cdiv:C -> C -> C*C. Variable cdiv_th : div_theory req cadd cmul phi cdiv. Notation NPEeval := (PEeval rO radd rmul rsub ropp phi Cp_phi rpow). Notation Nnorm:= (norm_subst cO cI cadd cmul csub copp ceqb cdiv). Notation NPphi_dev := (Pphi_dev rO rI radd rmul rsub ropp cO cI ceqb phi get_sign). Notation NPphi_pow := (Pphi_pow rO rI radd rmul rsub ropp cO cI ceqb phi Cp_phi rpow get_sign). (* add abstract semi-ring to help with some proofs *) Add Ring Rring : (ARth_SRth ARth). Local Hint Extern 2 (_ == _) => f_equiv. (* additional ring properties *) Lemma rsub_0_l : forall r, 0 - r == - r. intros; rewrite (ARsub_def ARth);ring. Qed. Lemma rsub_0_r : forall r, r - 0 == r. intros; rewrite (ARsub_def ARth). rewrite (ARopp_zero Rsth Reqe ARth); ring. Qed. (*************************************************************************** Properties of division ***************************************************************************) Theorem rdiv_simpl: forall p q, ~ q == 0 -> q * (p / q) == p. Proof. intros p q H. rewrite rdiv_def. transitivity (/ q * q * p); [ ring | idtac ]. rewrite rinv_l; auto. Qed. Hint Resolve rdiv_simpl . Instance SRdiv_ext: Proper (req ==> req ==> req) rdiv. Proof. intros p1 p2 Ep q1 q2 Eq. transitivity (p1 * / q1); auto. transitivity (p2 * / q2); auto. Qed. Hint Resolve SRdiv_ext. Lemma rmul_reg_l : forall p q1 q2, ~ p == 0 -> p * q1 == p * q2 -> q1 == q2. Proof. intros p q1 q2 H EQ. rewrite <- (@rdiv_simpl q1 p) by trivial. rewrite <- (@rdiv_simpl q2 p) by trivial. rewrite !rdiv_def, !(ARmul_assoc ARth). now rewrite EQ. Qed. Theorem field_is_integral_domain : forall r1 r2, ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0. Proof. intros r1 r2 H1 H2. contradict H2. transitivity (1 * r2); auto. transitivity (/ r1 * r1 * r2); auto. rewrite <- (ARmul_assoc ARth). rewrite H2. apply ARmul_0_r with (1 := Rsth) (2 := ARth). Qed. Theorem ropp_neq_0 : forall r, ~ -(1) == 0 -> ~ r == 0 -> ~ -r == 0. intros. setoid_replace (- r) with (- (1) * r). apply field_is_integral_domain; trivial. rewrite <- (ARopp_mul_l ARth). rewrite (ARmul_1_l ARth). reflexivity. Qed. Theorem rdiv_r_r : forall r, ~ r == 0 -> r / r == 1. intros. rewrite (AFdiv_def AFth). rewrite (ARmul_comm ARth). apply (AFinv_l AFth). trivial. Qed. Theorem rdiv1: forall r, r == r / 1. intros r; transitivity (1 * (r / 1)); auto. Qed. Theorem rdiv2: forall r1 r2 r3 r4, ~ r2 == 0 -> ~ r4 == 0 -> r1 / r2 + r3 / r4 == (r1 * r4 + r3 * r2) / (r2 * r4). Proof. intros r1 r2 r3 r4 H H0. assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial). apply rmul_reg_l with (r2 * r4); trivial. rewrite rdiv_simpl; trivial. rewrite (ARdistr_r Rsth Reqe ARth). apply (Radd_ext Reqe). - transitivity (r2 * (r1 / r2) * r4); [ ring | auto ]. - transitivity (r2 * (r4 * (r3 / r4))); auto. transitivity (r2 * r3); auto. Qed. Theorem rdiv2b: forall r1 r2 r3 r4 r5, ~ (r2*r5) == 0 -> ~ (r4*r5) == 0 -> r1 / (r2*r5) + r3 / (r4*r5) == (r1 * r4 + r3 * r2) / (r2 * (r4 * r5)). Proof. intros r1 r2 r3 r4 r5 H H0. assert (HH1: ~ r2 == 0) by (intros HH; case H; rewrite HH; ring). assert (HH2: ~ r5 == 0) by (intros HH; case H; rewrite HH; ring). assert (HH3: ~ r4 == 0) by (intros HH; case H0; rewrite HH; ring). assert (HH4: ~ r2 * (r4 * r5) == 0) by (repeat apply field_is_integral_domain; trivial). apply rmul_reg_l with (r2 * (r4 * r5)); trivial. rewrite rdiv_simpl; trivial. rewrite (ARdistr_r Rsth Reqe ARth). apply (Radd_ext Reqe). transitivity ((r2 * r5) * (r1 / (r2 * r5)) * r4); [ ring | auto ]. transitivity ((r4 * r5) * (r3 / (r4 * r5)) * r2); [ ring | auto ]. Qed. Theorem rdiv5: forall r1 r2, - (r1 / r2) == - r1 / r2. Proof. intros r1 r2. transitivity (- (r1 * / r2)); auto. transitivity (- r1 * / r2); auto. Qed. Hint Resolve rdiv5 . Theorem rdiv3 r1 r2 r3 r4 : ~ r2 == 0 -> ~ r4 == 0 -> r1 / r2 - r3 / r4 == (r1 * r4 - r3 * r2) / (r2 * r4). Proof. intros H2 H4. assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial). transitivity (r1 / r2 + - (r3 / r4)); auto. transitivity (r1 / r2 + - r3 / r4); auto. transitivity ((r1 * r4 + - r3 * r2) / (r2 * r4)). apply rdiv2; auto. f_equiv. transitivity (r1 * r4 + - (r3 * r2)); auto. Qed. Theorem rdiv3b: forall r1 r2 r3 r4 r5, ~ (r2 * r5) == 0 -> ~ (r4 * r5) == 0 -> r1 / (r2*r5) - r3 / (r4*r5) == (r1 * r4 - r3 * r2) / (r2 * (r4 * r5)). Proof. intros r1 r2 r3 r4 r5 H H0. transitivity (r1 / (r2 * r5) + - (r3 / (r4 * r5))); auto. transitivity (r1 / (r2 * r5) + - r3 / (r4 * r5)); auto. transitivity ((r1 * r4 + - r3 * r2) / (r2 * (r4 * r5))). apply rdiv2b; auto; try ring. apply (SRdiv_ext); auto. transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto. Qed. Theorem rdiv6: forall r1 r2, ~ r1 == 0 -> ~ r2 == 0 -> / (r1 / r2) == r2 / r1. intros r1 r2 H H0. assert (~ r1 / r2 == 0) as Hk. intros H1; case H. transitivity (r2 * (r1 / r2)); auto. rewrite H1; ring. apply rmul_reg_l with (r1 / r2); auto. transitivity (/ (r1 / r2) * (r1 / r2)); auto. transitivity 1; auto. repeat rewrite rdiv_def. transitivity (/ r1 * r1 * (/ r2 * r2)); [ idtac | ring ]. repeat rewrite rinv_l; auto. Qed. Hint Resolve rdiv6 . Theorem rdiv4: forall r1 r2 r3 r4, ~ r2 == 0 -> ~ r4 == 0 -> (r1 / r2) * (r3 / r4) == (r1 * r3) / (r2 * r4). Proof. intros r1 r2 r3 r4 H H0. assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial). apply rmul_reg_l with (r2 * r4); trivial. rewrite rdiv_simpl; trivial. transitivity (r2 * (r1 / r2) * (r4 * (r3 / r4))); [ ring | idtac ]. repeat rewrite rdiv_simpl; trivial. Qed. Theorem rdiv4b: forall r1 r2 r3 r4 r5 r6, ~ r2 * r5 == 0 -> ~ r4 * r6 == 0 -> ((r1 * r6) / (r2 * r5)) * ((r3 * r5) / (r4 * r6)) == (r1 * r3) / (r2 * r4). Proof. intros r1 r2 r3 r4 r5 r6 H H0. rewrite rdiv4; auto. transitivity ((r5 * r6) * (r1 * r3) / ((r5 * r6) * (r2 * r4))). apply SRdiv_ext; ring. assert (HH: ~ r5*r6 == 0). apply field_is_integral_domain. intros H1; case H; rewrite H1; ring. intros H1; case H0; rewrite H1; ring. rewrite <- rdiv4 ; auto. rewrite rdiv_r_r; auto. apply field_is_integral_domain. intros H1; case H; rewrite H1; ring. intros H1; case H0; rewrite H1; ring. Qed. Theorem rdiv7: forall r1 r2 r3 r4, ~ r2 == 0 -> ~ r3 == 0 -> ~ r4 == 0 -> (r1 / r2) / (r3 / r4) == (r1 * r4) / (r2 * r3). Proof. intros. rewrite (rdiv_def (r1 / r2)). rewrite rdiv6; trivial. apply rdiv4; trivial. Qed. Theorem rdiv7b: forall r1 r2 r3 r4 r5 r6, ~ r2 * r6 == 0 -> ~ r3 * r5 == 0 -> ~ r4 * r6 == 0 -> ((r1 * r5) / (r2 * r6)) / ((r3 * r5) / (r4 * r6)) == (r1 * r4) / (r2 * r3). Proof. intros. rewrite rdiv7; auto. transitivity ((r5 * r6) * (r1 * r4) / ((r5 * r6) * (r2 * r3))). apply SRdiv_ext; ring. assert (HH: ~ r5*r6 == 0). apply field_is_integral_domain. intros H2; case H0; rewrite H2; ring. intros H2; case H1; rewrite H2; ring. rewrite <- rdiv4 ; auto. rewrite rdiv_r_r; auto. apply field_is_integral_domain. intros H2; case H; rewrite H2; ring. intros H2; case H0; rewrite H2; ring. Qed. Theorem rdiv8: forall r1 r2, ~ r2 == 0 -> r1 == 0 -> r1 / r2 == 0. intros r1 r2 H H0. transitivity (r1 * / r2); auto. transitivity (0 * / r2); auto. Qed. Theorem cross_product_eq : forall r1 r2 r3 r4, ~ r2 == 0 -> ~ r4 == 0 -> r1 * r4 == r3 * r2 -> r1 / r2 == r3 / r4. intros. transitivity (r1 / r2 * (r4 / r4)). rewrite rdiv_r_r; trivial. symmetry . apply (ARmul_1_r Rsth ARth). rewrite rdiv4; trivial. rewrite H1. rewrite (ARmul_comm ARth r2 r4). rewrite <- rdiv4; trivial. rewrite rdiv_r_r by trivial. apply (ARmul_1_r Rsth ARth). Qed. (*************************************************************************** Some equality test ***************************************************************************) (* equality test *) Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool := match e1, e2 with PEc c1, PEc c2 => ceqb c1 c2 | PEX p1, PEX p2 => Pos.eqb p1 p2 | PEadd e3 e5, PEadd e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false | PEsub e3 e5, PEsub e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false | PEmul e3 e5, PEmul e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false | PEopp e3, PEopp e4 => PExpr_eq e3 e4 | PEpow e3 n3, PEpow e4 n4 => if N.eqb n3 n4 then PExpr_eq e3 e4 else false | _, _ => false end. Add Morphism (pow_pos rmul) with signature req ==> eq ==> req as pow_morph. intros x y H p;induction p as [p IH| p IH|];simpl;auto;ring[IH]. Qed. Add Morphism (pow_N rI rmul) with signature req ==> eq ==> req as pow_N_morph. intros x y H [|p];simpl;auto. apply pow_morph;trivial. Qed. Theorem PExpr_eq_semi_correct: forall l e1 e2, PExpr_eq e1 e2 = true -> NPEeval l e1 == NPEeval l e2. intros l e1; elim e1. intros c1; intros e2; elim e2; simpl; (try (intros; discriminate)). intros c2; apply (morph_eq CRmorph). intros p1; intros e2; elim e2; simpl; (try (intros; discriminate)). intros p2; case Pos.eqb_spec; intros; now subst. intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)). intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4); (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6); (try (intros; discriminate)); auto. intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)). intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4); (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6); (try (intros; discriminate)); auto. intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)). intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4); (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6); (try (intros; discriminate)); auto. intros e3 rec e2; (case e2; simpl; (try (intros; discriminate))). intros e4; generalize (rec e4); case (PExpr_eq e3 e4); (try (intros; discriminate)); auto. intros e3 rec n3 e2;(case e2;simpl;(try (intros;discriminate))). intros e4 n4; case N.eqb_spec; try discriminate; intros EQ H; subst. repeat rewrite pow_th.(rpow_pow_N). rewrite (rec _ H);auto. Qed. (* add *) Definition NPEadd e1 e2 := match e1, e2 with PEc c1, PEc c2 => PEc (cadd c1 c2) | PEc c, _ => if ceqb c cO then e2 else PEadd e1 e2 | _, PEc c => if ceqb c cO then e1 else PEadd e1 e2 (* Peut t'on factoriser ici ??? *) | _, _ => PEadd e1 e2 end. Theorem NPEadd_correct: forall l e1 e2, NPEeval l (NPEadd e1 e2) == NPEeval l (PEadd e1 e2). Proof. intros l e1 e2. destruct e1; destruct e2; simpl; try reflexivity; try apply ceqb_rect; try (intro eq_c; rewrite eq_c); simpl;try apply eq_refl; try (ring [(morph0 CRmorph)]). apply (morph_add CRmorph). Qed. Definition NPEpow x n := match n with | N0 => PEc cI | Npos p => if Pos.eqb p xH then x else match x with | PEc c => if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p) | _ => PEpow x n end end. Theorem NPEpow_correct : forall l e n, NPEeval l (NPEpow e n) == NPEeval l (PEpow e n). Proof. destruct n;simpl. rewrite pow_th.(rpow_pow_N);simpl;auto. fold (p =? 1)%positive. case Pos.eqb_spec; intros H; (rewrite H || clear H). now rewrite pow_th.(rpow_pow_N). destruct e;simpl;auto. repeat apply ceqb_rect;simpl;intros;rewrite pow_th.(rpow_pow_N);simpl. symmetry;induction p;simpl;trivial; ring [IHp H CRmorph.(morph1)]. symmetry; induction p;simpl;trivial;ring [IHp CRmorph.(morph0)]. induction p;simpl;auto;repeat rewrite CRmorph.(morph_mul);ring [IHp]. Qed. (* mul *) Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C := match x, y with PEc c1, PEc c2 => PEc (cmul c1 c2) | PEc c, _ => if ceqb c cI then y else if ceqb c cO then PEc cO else PEmul x y | _, PEc c => if ceqb c cI then x else if ceqb c cO then PEc cO else PEmul x y | PEpow e1 n1, PEpow e2 n2 => if N.eqb n1 n2 then NPEpow (NPEmul e1 e2) n1 else PEmul x y | _, _ => PEmul x y end. Lemma pow_pos_mul : forall x y p, pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p. induction p;simpl;auto;try ring [IHp]. Qed. Theorem NPEmul_correct : forall l e1 e2, NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2). induction e1;destruct e2; simpl;try reflexivity; repeat apply ceqb_rect; try (intro eq_c; rewrite eq_c); simpl; try reflexivity; try ring [(morph0 CRmorph) (morph1 CRmorph)]. apply (morph_mul CRmorph). case N.eqb_spec; intros H; try rewrite <- H; clear H. rewrite NPEpow_correct. simpl. repeat rewrite pow_th.(rpow_pow_N). rewrite IHe1; destruct n;simpl;try ring. apply pow_pos_mul. simpl;auto. Qed. (* sub *) Definition NPEsub e1 e2 := match e1, e2 with PEc c1, PEc c2 => PEc (csub c1 c2) | PEc c, _ => if ceqb c cO then PEopp e2 else PEsub e1 e2 | _, PEc c => if ceqb c cO then e1 else PEsub e1 e2 (* Peut-on factoriser ici *) | _, _ => PEsub e1 e2 end. Theorem NPEsub_correct: forall l e1 e2, NPEeval l (NPEsub e1 e2) == NPEeval l (PEsub e1 e2). intros l e1 e2. destruct e1; destruct e2; simpl; try reflexivity; try apply ceqb_rect; try (intro eq_c; rewrite eq_c); simpl; try rewrite (morph0 CRmorph); try reflexivity; try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r). apply (morph_sub CRmorph). Qed. (* opp *) Definition NPEopp e1 := match e1 with PEc c1 => PEc (copp c1) | _ => PEopp e1 end. Theorem NPEopp_correct: forall l e1, NPEeval l (NPEopp e1) == NPEeval l (PEopp e1). intros l e1; case e1; simpl; auto. intros; apply (morph_opp CRmorph). Qed. (* simplification *) Fixpoint PExpr_simp (e : PExpr C) : PExpr C := match e with PEadd e1 e2 => NPEadd (PExpr_simp e1) (PExpr_simp e2) | PEmul e1 e2 => NPEmul (PExpr_simp e1) (PExpr_simp e2) | PEsub e1 e2 => NPEsub (PExpr_simp e1) (PExpr_simp e2) | PEopp e1 => NPEopp (PExpr_simp e1) | PEpow e1 n1 => NPEpow (PExpr_simp e1) n1 | _ => e end. Theorem PExpr_simp_correct: forall l e, NPEeval l (PExpr_simp e) == NPEeval l e. intros l e; elim e; simpl; auto. intros e1 He1 e2 He2. transitivity (NPEeval l (PEadd (PExpr_simp e1) (PExpr_simp e2))); auto. apply NPEadd_correct. simpl; auto. intros e1 He1 e2 He2. transitivity (NPEeval l (PEsub (PExpr_simp e1) (PExpr_simp e2))); auto. apply NPEsub_correct. simpl; auto. intros e1 He1 e2 He2. transitivity (NPEeval l (PEmul (PExpr_simp e1) (PExpr_simp e2))); auto. apply NPEmul_correct. simpl; auto. intros e1 He1. transitivity (NPEeval l (PEopp (PExpr_simp e1))); auto. apply NPEopp_correct. simpl; auto. intros e1 He1 n;simpl. rewrite NPEpow_correct;simpl. repeat rewrite pow_th.(rpow_pow_N). rewrite He1;auto. Qed. (**************************************************************************** Datastructure ***************************************************************************) (* The input: syntax of a field expression *) Inductive FExpr : Type := FEc: C -> FExpr | FEX: positive -> FExpr | FEadd: FExpr -> FExpr -> FExpr | FEsub: FExpr -> FExpr -> FExpr | FEmul: FExpr -> FExpr -> FExpr | FEopp: FExpr -> FExpr | FEinv: FExpr -> FExpr | FEdiv: FExpr -> FExpr -> FExpr | FEpow: FExpr -> N -> FExpr . Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R := match pe with | FEc c => phi c | FEX x => BinList.nth 0 x l | FEadd x y => FEeval l x + FEeval l y | FEsub x y => FEeval l x - FEeval l y | FEmul x y => FEeval l x * FEeval l y | FEopp x => - FEeval l x | FEinv x => / FEeval l x | FEdiv x y => FEeval l x / FEeval l y | FEpow x n => rpow (FEeval l x) (Cp_phi n) end. Strategy expand [FEeval]. (* The result of the normalisation *) Record linear : Type := mk_linear { num : PExpr C; denum : PExpr C; condition : list (PExpr C) }. (*************************************************************************** Semantics and properties of side condition ***************************************************************************) Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop := match le with | nil => True | e1 :: nil => ~ req (NPEeval l e1) rO | e1 :: l1 => ~ req (NPEeval l e1) rO /\ PCond l l1 end. Theorem PCond_cons_inv_l : forall l a l1, PCond l (a::l1) -> ~ NPEeval l a == 0. intros l a l1 H. destruct l1; simpl in H |- *; trivial. destruct H; trivial. Qed. Theorem PCond_cons_inv_r : forall l a l1, PCond l (a :: l1) -> PCond l l1. intros l a l1 H. destruct l1; simpl in H |- *; trivial. destruct H; trivial. Qed. Theorem PCond_app_inv_l: forall l l1 l2, PCond l (l1 ++ l2) -> PCond l l1. intros l l1 l2; elim l1; simpl app. simpl; auto. destruct l0; simpl in *. destruct l2; firstorder. firstorder. Qed. Theorem PCond_app_inv_r: forall l l1 l2, PCond l (l1 ++ l2) -> PCond l l2. intros l l1 l2; elim l1; simpl app; auto. intros a l0 H H0; apply H; apply PCond_cons_inv_r with ( 1 := H0 ). Qed. (* An unsatisfiable condition: issued when a division by zero is detected *) Definition absurd_PCond := cons (PEc cO) nil. Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond. unfold absurd_PCond; simpl. red; intros. apply H. apply (morph0 CRmorph). Qed. (*************************************************************************** Normalisation ***************************************************************************) Fixpoint isIn (e1:PExpr C) (p1:positive) (e2:PExpr C) (p2:positive) {struct e2}: option (N * PExpr C) := match e2 with | PEmul e3 e4 => match isIn e1 p1 e3 p2 with | Some (N0, e5) => Some (N0, NPEmul e5 (NPEpow e4 (Npos p2))) | Some (Npos p, e5) => match isIn e1 p e4 p2 with | Some (n, e6) => Some (n, NPEmul e5 e6) | None => Some (Npos p, NPEmul e5 (NPEpow e4 (Npos p2))) end | None => match isIn e1 p1 e4 p2 with | Some (n, e5) => Some (n,NPEmul (NPEpow e3 (Npos p2)) e5) | None => None end end | PEpow e3 N0 => None | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pos.mul p3 p2) | _ => if PExpr_eq e1 e2 then match Z.pos_sub p1 p2 with | Zpos p => Some (Npos p, PEc cI) | Z0 => Some (N0, PEc cI) | Zneg p => Some (N0, NPEpow e2 (Npos p)) end else None end. Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end. Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end. Notation pow_pos_add := (Ring_theory.pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)). Lemma Z_pos_sub_gt p q : (p > q)%positive -> Z.pos_sub p q = Zpos (p - q). Proof. intros; now apply Z.pos_sub_gt, Pos.gt_lt. Qed. Ltac simpl_pos_sub := rewrite ?Z_pos_sub_gt in * by assumption. Lemma isIn_correct_aux : forall l e1 e2 p1 p2, match (if PExpr_eq e1 e2 then match Z.sub (Zpos p1) (Zpos p2) with | Zpos p => Some (Npos p, PEc cI) | Z0 => Some (N0, PEc cI) | Zneg p => Some (N0, NPEpow e2 (Npos p)) end else None) with | Some(n, e3) => NPEeval l (PEpow e2 (Npos p2)) == NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\ (Zpos p1 > NtoZ n)%Z | _ => True end. Proof. intros l e1 e2 p1 p2; generalize (PExpr_eq_semi_correct l e1 e2); case (PExpr_eq e1 e2); simpl; auto; intros H. rewrite Z.pos_sub_spec. case Pos.compare_spec;intros;simpl. - repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:reflexivity. subst. rewrite H by trivial. ring [ (morph1 CRmorph)]. - fold (p2 - p1 =? 1)%positive. fold (NPEpow e2 (Npos (p2 - p1))). rewrite NPEpow_correct;simpl. repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite H;trivial. split. 2:reflexivity. rewrite <- pow_pos_add. now rewrite Pos.add_comm, Pos.sub_add. - repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite H;trivial. rewrite Z.pos_sub_gt by now apply Pos.sub_decr. replace (p1 - (p1 - p2))%positive with p2; [| rewrite Pos.sub_sub_distr, Pos.add_comm; auto using Pos.add_sub, Pos.sub_decr ]. split. simpl. ring [ (morph1 CRmorph)]. now apply Z.lt_gt, Pos.sub_decr. Qed. Lemma pow_pos_pow_pos : forall x p1 p2, pow_pos rmul (pow_pos rmul x p1) p2 == pow_pos rmul x (p1*p2). induction p1;simpl;intros;repeat rewrite pow_pos_mul;repeat rewrite pow_pos_add;simpl. ring [(IHp1 p2)]. ring [(IHp1 p2)]. auto. Qed. Theorem isIn_correct: forall l e1 p1 e2 p2, match isIn e1 p1 e2 p2 with | Some(n, e3) => NPEeval l (PEpow e2 (Npos p2)) == NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\ (Zpos p1 > NtoZ n)%Z | _ => True end. Proof. Opaque NPEpow. intros l e1 p1 e2; generalize p1;clear p1;elim e2; intros; try (refine (isIn_correct_aux l e1 _ p1 p2);fail);simpl isIn. generalize (H p1 p2);clear H;destruct (isIn e1 p1 p p2). destruct p3. destruct n. simpl. rewrite NPEmul_correct. simpl; rewrite NPEpow_correct;simpl. repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul;intros (H,H1);split;[ring[H]|trivial]. generalize (H0 p4 p2);clear H0;destruct (isIn e1 p4 p0 p2). destruct p5. destruct n;simpl. rewrite NPEmul_correct;repeat rewrite pow_th.(rpow_pow_N);simpl. intros (H1,H2) (H3,H4). simpl_pos_sub. simpl in H3. rewrite pow_pos_mul. rewrite H1;rewrite H3. assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 * (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) == pow_pos rmul (NPEeval l e1) p4 * pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *NPEeval l p5) by ring. rewrite H;clear H. rewrite <- pow_pos_add. rewrite Pos.add_comm, Pos.sub_add by (now apply Z.gt_lt in H4). split. symmetry;apply ARth.(ARmul_assoc). reflexivity. repeat rewrite pow_th.(rpow_pow_N);simpl. intros (H1,H2) (H3,H4). simpl_pos_sub. simpl in H1, H3. assert (Zpos p1 > Zpos p6)%Z. apply Zgt_trans with (Zpos p4). exact H4. exact H2. simpl_pos_sub. split. 2:exact H. rewrite pow_pos_mul. simpl;rewrite H1;rewrite H3. assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 * (pow_pos rmul (NPEeval l e1) (p4 - p6) * NPEeval l p5) == pow_pos rmul (NPEeval l e1) (p1 - p4) * pow_pos rmul (NPEeval l e1) (p4 - p6) * NPEeval l p3 * NPEeval l p5) by ring. rewrite H0;clear H0. rewrite <- pow_pos_add. replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive. rewrite NPEmul_correct. simpl;ring. assert (Zpos p1 - Zpos p6 = Zpos p1 - Zpos p4 + (Zpos p4 - Zpos p6))%Z. change ((Zpos p1 - Zpos p6)%Z = (Zpos p1 + (- Zpos p4) + (Zpos p4 +(- Zpos p6)))%Z). rewrite <- Z.add_assoc. rewrite (Z.add_assoc (- Zpos p4)). simpl. rewrite Z.pos_sub_diag. simpl. reflexivity. unfold Z.sub, Z.opp in H0. simpl in H0. simpl_pos_sub. inversion H0; trivial. simpl. repeat rewrite pow_th.(rpow_pow_N). intros H1 (H2,H3). simpl_pos_sub. rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. simpl in H2. rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul. split. ring [H2]. exact H3. generalize (H0 p1 p2);clear H0;destruct (isIn e1 p1 p0 p2). destruct p3. destruct n;simpl. rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. repeat rewrite pow_th.(rpow_pow_N);simpl. intros (H1,H2);split;trivial. rewrite pow_pos_mul;ring [H1]. rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul. intros (H1, H2);rewrite H1;split. simpl_pos_sub. simpl in H1;ring [H1]. trivial. trivial. destruct n. trivial. generalize (H p1 (p0*p2)%positive);clear H;destruct (isIn e1 p1 p (p0*p2)). destruct p3. destruct n;simpl. repeat rewrite pow_th.(rpow_pow_N). simpl. intros (H1,H2);split. rewrite pow_pos_pow_pos. trivial. trivial. repeat rewrite pow_th.(rpow_pow_N). simpl. intros (H1,H2);split;trivial. rewrite pow_pos_pow_pos;trivial. trivial. Qed. Record rsplit : Type := mk_rsplit { rsplit_left : PExpr C; rsplit_common : PExpr C; rsplit_right : PExpr C}. (* Stupid name clash *) Notation left := rsplit_left. Notation right := rsplit_right. Notation common := rsplit_common. Fixpoint split_aux (e1: PExpr C) (p:positive) (e2:PExpr C) {struct e1}: rsplit := match e1 with | PEmul e3 e4 => let r1 := split_aux e3 p e2 in let r2 := split_aux e4 p (right r1) in mk_rsplit (NPEmul (left r1) (left r2)) (NPEmul (common r1) (common r2)) (right r2) | PEpow e3 N0 => mk_rsplit (PEc cI) (PEc cI) e2 | PEpow e3 (Npos p3) => split_aux e3 (Pos.mul p3 p) e2 | _ => match isIn e1 p e2 xH with | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3 | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2 end end. Lemma split_aux_correct_1 : forall l e1 p e2, let res := match isIn e1 p e2 xH with | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3 | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2 end in NPEeval l (PEpow e1 (Npos p)) == NPEeval l (NPEmul (left res) (common res)) /\ NPEeval l e2 == NPEeval l (NPEmul (right res) (common res)). Proof. intros. unfold res;clear res; generalize (isIn_correct l e1 p e2 xH). destruct (isIn e1 p e2 1). destruct p0. Opaque NPEpow NPEmul. destruct n;simpl; (repeat rewrite NPEmul_correct;simpl; repeat rewrite NPEpow_correct;simpl; repeat rewrite pow_th.(rpow_pow_N);simpl). intros (H, Hgt);split;try ring [H CRmorph.(morph1)]. intros (H, Hgt). simpl_pos_sub. simpl in H;split;try ring [H]. apply Z.gt_lt in Hgt. now rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add. simpl;intros. repeat rewrite NPEmul_correct;simpl. rewrite NPEpow_correct;simpl. split;ring [CRmorph.(morph1)]. Qed. Theorem split_aux_correct: forall l e1 p e2, NPEeval l (PEpow e1 (Npos p)) == NPEeval l (NPEmul (left (split_aux e1 p e2)) (common (split_aux e1 p e2))) /\ NPEeval l e2 == NPEeval l (NPEmul (right (split_aux e1 p e2)) (common (split_aux e1 p e2))). Proof. intros l; induction e1;intros k e2; try refine (split_aux_correct_1 l _ k e2);simpl. generalize (IHe1_1 k e2); clear IHe1_1. generalize (IHe1_2 k (rsplit_right (split_aux e1_1 k e2))); clear IHe1_2. simpl. repeat (rewrite NPEmul_correct;simpl). repeat rewrite pow_th.(rpow_pow_N);simpl. intros (H1,H2) (H3,H4);split. rewrite pow_pos_mul. rewrite H1;rewrite H3. ring. rewrite H4;rewrite H2;ring. destruct n;simpl. split. repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite NPEmul_correct. simpl. induction k;simpl;try ring [CRmorph.(morph1)]; ring [IHk CRmorph.(morph1)]. rewrite NPEmul_correct;simpl. ring [CRmorph.(morph1)]. generalize (IHe1 (p*k)%positive e2);clear IHe1;simpl. repeat rewrite NPEmul_correct;simpl. repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_pow_pos. intros [H1 H2];split;ring [H1 H2]. Qed. Definition split e1 e2 := split_aux e1 xH e2. Theorem split_correct_l: forall l e1 e2, NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2)) (common (split e1 e2))). Proof. intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl. rewrite pow_th.(rpow_pow_N);simpl;auto. Qed. Theorem split_correct_r: forall l e1 e2, NPEeval l e2 == NPEeval l (NPEmul (right (split e1 e2)) (common (split e1 e2))). Proof. intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl;auto. Qed. Fixpoint Fnorm (e : FExpr) : linear := match e with | FEc c => mk_linear (PEc c) (PEc cI) nil | FEX x => mk_linear (PEX C x) (PEc cI) nil | FEadd e1 e2 => let x := Fnorm e1 in let y := Fnorm e2 in let s := split (denum x) (denum y) in mk_linear (NPEadd (NPEmul (num x) (right s)) (NPEmul (num y) (left s))) (NPEmul (left s) (NPEmul (right s) (common s))) (condition x ++ condition y) | FEsub e1 e2 => let x := Fnorm e1 in let y := Fnorm e2 in let s := split (denum x) (denum y) in mk_linear (NPEsub (NPEmul (num x) (right s)) (NPEmul (num y) (left s))) (NPEmul (left s) (NPEmul (right s) (common s))) (condition x ++ condition y) | FEmul e1 e2 => let x := Fnorm e1 in let y := Fnorm e2 in let s1 := split (num x) (denum y) in let s2 := split (num y) (denum x) in mk_linear (NPEmul (left s1) (left s2)) (NPEmul (right s2) (right s1)) (condition x ++ condition y) | FEopp e1 => let x := Fnorm e1 in mk_linear (NPEopp (num x)) (denum x) (condition x) | FEinv e1 => let x := Fnorm e1 in mk_linear (denum x) (num x) (num x :: condition x) | FEdiv e1 e2 => let x := Fnorm e1 in let y := Fnorm e2 in let s1 := split (num x) (num y) in let s2 := split (denum x) (denum y) in mk_linear (NPEmul (left s1) (right s2)) (NPEmul (left s2) (right s1)) (num y :: condition x ++ condition y) | FEpow e1 n => let x := Fnorm e1 in mk_linear (NPEpow (num x) n) (NPEpow (denum x) n) (condition x) end. (* Example *) (* Eval compute in (Fnorm (FEdiv (FEc cI) (FEadd (FEinv (FEX xH%positive)) (FEinv (FEX (xO xH)%positive))))). *) Lemma pow_pos_not_0 : forall x, ~x==0 -> forall p, ~pow_pos rmul x p == 0. Proof. induction p;simpl. intro Hp;assert (H1 := @rmul_reg_l _ (pow_pos rmul x p * pow_pos rmul x p) 0 H). apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). reflexivity. rewrite H1. ring. rewrite Hp;ring. intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). reflexivity. rewrite Hp;ring. trivial. Qed. Theorem Pcond_Fnorm: forall l e, PCond l (condition (Fnorm e)) -> ~ NPEeval l (denum (Fnorm e)) == 0. intros l e; elim e. simpl; intros _ _; rewrite (morph1 CRmorph); exact rI_neq_rO. simpl; intros _ _; rewrite (morph1 CRmorph); exact rI_neq_rO. intros e1 Hrec1 e2 Hrec2 Hcond. simpl condition in Hcond. simpl denum. rewrite NPEmul_correct. simpl. apply field_is_integral_domain. intros HH; case Hrec1; auto. apply PCond_app_inv_l with (1 := Hcond). rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). rewrite NPEmul_correct; simpl; rewrite HH; ring. intros HH; case Hrec2; auto. apply PCond_app_inv_r with (1 := Hcond). rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto. intros e1 Hrec1 e2 Hrec2 Hcond. simpl condition in Hcond. simpl denum. rewrite NPEmul_correct. simpl. apply field_is_integral_domain. intros HH; case Hrec1; auto. apply PCond_app_inv_l with (1 := Hcond). rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). rewrite NPEmul_correct; simpl; rewrite HH; ring. intros HH; case Hrec2; auto. apply PCond_app_inv_r with (1 := Hcond). rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto. intros e1 Hrec1 e2 Hrec2 Hcond. simpl condition in Hcond. simpl denum. rewrite NPEmul_correct. simpl. apply field_is_integral_domain. intros HH; apply Hrec1. apply PCond_app_inv_l with (1 := Hcond). rewrite (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))). rewrite NPEmul_correct; simpl; rewrite HH; ring. intros HH; apply Hrec2. apply PCond_app_inv_r with (1 := Hcond). rewrite (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2))). rewrite NPEmul_correct; simpl; rewrite HH; ring. intros e1 Hrec1 Hcond. simpl condition in Hcond. simpl denum. auto. intros e1 Hrec1 Hcond. simpl condition in Hcond. simpl denum. apply PCond_cons_inv_l with (1:=Hcond). intros e1 Hrec1 e2 Hrec2 Hcond. simpl condition in Hcond. simpl denum. rewrite NPEmul_correct. simpl. apply field_is_integral_domain. intros HH; apply Hrec1. specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1. apply PCond_app_inv_l with (1 := Hcond1). rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). rewrite NPEmul_correct; simpl; rewrite HH; ring. intros HH; apply PCond_cons_inv_l with (1:=Hcond). rewrite (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2))). rewrite NPEmul_correct; simpl; rewrite HH; ring. simpl;intros e1 Hrec1 n Hcond. rewrite NPEpow_correct. simpl;rewrite pow_th.(rpow_pow_N). destruct n;simpl;intros. apply AFth.(AF_1_neq_0). apply pow_pos_not_0;auto. Qed. Hint Resolve Pcond_Fnorm. (*************************************************************************** Main theorem ***************************************************************************) Theorem Fnorm_FEeval_PEeval: forall l fe, PCond l (condition (Fnorm fe)) -> FEeval l fe == NPEeval l (num (Fnorm fe)) / NPEeval l (denum (Fnorm fe)). Proof. intros l fe; elim fe; simpl. intros c H; rewrite CRmorph.(morph1); apply rdiv1. intros p H; rewrite CRmorph.(morph1); apply rdiv1. intros e1 He1 e2 He2 HH. assert (HH1: PCond l (condition (Fnorm e1))). apply PCond_app_inv_l with ( 1 := HH ). assert (HH2: PCond l (condition (Fnorm e2))). apply PCond_app_inv_r with ( 1 := HH ). rewrite (He1 HH1); rewrite (He2 HH2). rewrite NPEadd_correct; simpl. repeat rewrite NPEmul_correct; simpl. generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))) (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))). repeat rewrite NPEmul_correct; simpl. intros U1 U2; rewrite U1; rewrite U2. apply rdiv2b; auto. rewrite <- U1; auto. rewrite <- U2; auto. intros e1 He1 e2 He2 HH. assert (HH1: PCond l (condition (Fnorm e1))). apply PCond_app_inv_l with ( 1 := HH ). assert (HH2: PCond l (condition (Fnorm e2))). apply PCond_app_inv_r with ( 1 := HH ). rewrite (He1 HH1); rewrite (He2 HH2). rewrite NPEsub_correct; simpl. repeat rewrite NPEmul_correct; simpl. generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))) (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))). repeat rewrite NPEmul_correct; simpl. intros U1 U2; rewrite U1; rewrite U2. apply rdiv3b; auto. rewrite <- U1; auto. rewrite <- U2; auto. intros e1 He1 e2 He2 HH. assert (HH1: PCond l (condition (Fnorm e1))). apply PCond_app_inv_l with ( 1 := HH ). assert (HH2: PCond l (condition (Fnorm e2))). apply PCond_app_inv_r with ( 1 := HH ). rewrite (He1 HH1); rewrite (He2 HH2). repeat rewrite NPEmul_correct; simpl. generalize (split_correct_l l (num (Fnorm e1)) (denum (Fnorm e2))) (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2))) (split_correct_l l (num (Fnorm e2)) (denum (Fnorm e1))) (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))). repeat rewrite NPEmul_correct; simpl. intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3; rewrite U4; simpl. apply rdiv4b; auto. rewrite <- U4; auto. rewrite <- U2; auto. intros e1 He1 HH. rewrite NPEopp_correct; simpl; rewrite (He1 HH); apply rdiv5; auto. intros e1 He1 HH. assert (HH1: PCond l (condition (Fnorm e1))). apply PCond_cons_inv_r with ( 1 := HH ). rewrite (He1 HH1); apply rdiv6; auto. apply PCond_cons_inv_l with ( 1 := HH ). intros e1 He1 e2 He2 HH. assert (HH1: PCond l (condition (Fnorm e1))). apply PCond_app_inv_l with (condition (Fnorm e2)). apply PCond_cons_inv_r with ( 1 := HH ). assert (HH2: PCond l (condition (Fnorm e2))). apply PCond_app_inv_r with (condition (Fnorm e1)). apply PCond_cons_inv_r with ( 1 := HH ). rewrite (He1 HH1); rewrite (He2 HH2). repeat rewrite NPEmul_correct;simpl. generalize (split_correct_l l (num (Fnorm e1)) (num (Fnorm e2))) (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2))) (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))) (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))). repeat rewrite NPEmul_correct; simpl. intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3; rewrite U4; simpl. apply rdiv7b; auto. rewrite <- U3; auto. rewrite <- U2; auto. apply PCond_cons_inv_l with ( 1 := HH ). rewrite <- U4; auto. intros e1 He1 n Hcond;assert (He1' := He1 Hcond);clear He1. repeat rewrite NPEpow_correct;simpl;repeat rewrite pow_th.(rpow_pow_N). rewrite He1';clear He1'. destruct n;simpl. apply rdiv1. generalize (NPEeval l (num (Fnorm e1))) (NPEeval l (denum (Fnorm e1))) (Pcond_Fnorm _ _ Hcond). intros r r0 Hdiff;induction p;simpl. repeat (rewrite <- rdiv4;trivial). rewrite IHp. reflexivity. apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial. intro Hp. apply (pow_pos_not_0 Hdiff p). rewrite (@rmul_reg_l (pow_pos rmul r0 p) (pow_pos rmul r0 p) 0). reflexivity. apply pow_pos_not_0;trivial. ring [Hp]. rewrite <- rdiv4;trivial. rewrite IHp;reflexivity. apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial. reflexivity. Qed. Theorem Fnorm_crossproduct: forall l fe1 fe2, let nfe1 := Fnorm fe1 in let nfe2 := Fnorm fe2 in NPEeval l (PEmul (num nfe1) (denum nfe2)) == NPEeval l (PEmul (num nfe2) (denum nfe1)) -> PCond l (condition nfe1 ++ condition nfe2) -> FEeval l fe1 == FEeval l fe2. intros l fe1 fe2 nfe1 nfe2 Hcrossprod Hcond; subst nfe1 nfe2. rewrite Fnorm_FEeval_PEeval by apply PCond_app_inv_l with (1 := Hcond). rewrite Fnorm_FEeval_PEeval by apply PCond_app_inv_r with (1 := Hcond). apply cross_product_eq; trivial. apply Pcond_Fnorm. apply PCond_app_inv_l with (1 := Hcond). apply Pcond_Fnorm. apply PCond_app_inv_r with (1 := Hcond). Qed. (* Correctness lemmas of reflexive tactics *) Notation Ninterp_PElist := (interp_PElist rO radd rmul rsub ropp req phi Cp_phi rpow). Notation Nmk_monpol_list := (mk_monpol_list cO cI cadd cmul csub copp ceqb cdiv). Theorem Fnorm_correct: forall n l lpe fe, Ninterp_PElist l lpe -> Peq ceqb (Nnorm n (Nmk_monpol_list lpe) (num (Fnorm fe))) (Pc cO) = true -> PCond l (condition (Fnorm fe)) -> FEeval l fe == 0. intros n l lpe fe Hlpe H H1; apply eq_trans with (1 := Fnorm_FEeval_PEeval l fe H1). apply rdiv8; auto. transitivity (NPEeval l (PEc cO)); auto. rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th cdiv_th n l lpe);auto. change (NPEeval l (PEc cO)) with (Pphi 0 radd rmul phi l (Pc cO)). apply (Peq_ok Rsth Reqe CRmorph);auto. simpl. apply (morph0 CRmorph); auto. Qed. (* simplify a field expression into a fraction *) (* TODO: simplify when den is constant... *) Definition display_linear l num den := NPphi_dev l num / NPphi_dev l den. Definition display_pow_linear l num den := NPphi_pow l num / NPphi_pow l den. Theorem Field_rw_correct : forall n lpe l, Ninterp_PElist l lpe -> forall lmp, Nmk_monpol_list lpe = lmp -> forall fe nfe, Fnorm fe = nfe -> PCond l (condition nfe) -> FEeval l fe == display_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)). Proof. intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H). unfold display_linear; apply SRdiv_ext; eapply (ring_rw_correct Rsth Reqe ARth CRmorph);eauto. Qed. Theorem Field_rw_pow_correct : forall n lpe l, Ninterp_PElist l lpe -> forall lmp, Nmk_monpol_list lpe = lmp -> forall fe nfe, Fnorm fe = nfe -> PCond l (condition nfe) -> FEeval l fe == display_pow_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)). Proof. intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H). unfold display_pow_linear; apply SRdiv_ext; eapply (ring_rw_pow_correct Rsth Reqe ARth CRmorph);eauto. Qed. Theorem Field_correct : forall n l lpe fe1 fe2, Ninterp_PElist l lpe -> forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> Peq ceqb (Nnorm n lmp (PEmul (num nfe1) (denum nfe2))) (Nnorm n lmp (PEmul (num nfe2) (denum nfe1))) = true -> PCond l (condition nfe1 ++ condition nfe2) -> FEeval l fe1 == FEeval l fe2. Proof. intros n l lpe fe1 fe2 Hlpe lmp eq_lmp nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2 lmp. apply Fnorm_crossproduct; trivial. eapply (ring_correct Rsth Reqe ARth CRmorph); eauto. Qed. (* simplify a field equation : generate the crossproduct and simplify polynomials *) Theorem Field_simplify_eq_old_correct : forall l fe1 fe2 nfe1 nfe2, Fnorm fe1 = nfe1 -> Fnorm fe2 = nfe2 -> NPphi_dev l (Nnorm O nil (PEmul (num nfe1) (denum nfe2))) == NPphi_dev l (Nnorm O nil (PEmul (num nfe2) (denum nfe1))) -> PCond l (condition nfe1 ++ condition nfe2) -> FEeval l fe1 == FEeval l fe2. Proof. intros l fe1 fe2 nfe1 nfe2 eq1 eq2 Hcrossprod Hcond; subst nfe1 nfe2. apply Fnorm_crossproduct; trivial. match goal with [ |- NPEeval l ?x == NPEeval l ?y] => rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec O nil l I Logic.eq_refl x Logic.eq_refl); rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec O nil l I Logic.eq_refl y Logic.eq_refl) end. trivial. Qed. Theorem Field_simplify_eq_correct : forall n l lpe fe1 fe2, Ninterp_PElist l lpe -> forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> forall den, split (denum nfe1) (denum nfe2) = den -> NPphi_dev l (Nnorm n lmp (PEmul (num nfe1) (right den))) == NPphi_dev l (Nnorm n lmp (PEmul (num nfe2) (left den))) -> PCond l (condition nfe1 ++ condition nfe2) -> FEeval l fe1 == FEeval l fe2. Proof. intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond; subst nfe1 nfe2 den lmp. apply Fnorm_crossproduct; trivial. simpl. rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))). rewrite NPEmul_correct. rewrite NPEmul_correct. simpl. repeat rewrite (ARmul_assoc ARth). rewrite <-( let x := PEmul (num (Fnorm fe1)) (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l Hlpe Logic.eq_refl x Logic.eq_refl) in Hcrossprod. rewrite <-( let x := (PEmul (num (Fnorm fe2)) (rsplit_left (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l Hlpe Logic.eq_refl x Logic.eq_refl) in Hcrossprod. simpl in Hcrossprod. rewrite Hcrossprod. reflexivity. Qed. Theorem Field_simplify_eq_pow_correct : forall n l lpe fe1 fe2, Ninterp_PElist l lpe -> forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> forall den, split (denum nfe1) (denum nfe2) = den -> NPphi_pow l (Nnorm n lmp (PEmul (num nfe1) (right den))) == NPphi_pow l (Nnorm n lmp (PEmul (num nfe2) (left den))) -> PCond l (condition nfe1 ++ condition nfe2) -> FEeval l fe1 == FEeval l fe2. Proof. intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond; subst nfe1 nfe2 den lmp. apply Fnorm_crossproduct; trivial. simpl. rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))). rewrite NPEmul_correct. rewrite NPEmul_correct. simpl. repeat rewrite (ARmul_assoc ARth). rewrite <-( let x := PEmul (num (Fnorm fe1)) (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l Hlpe Logic.eq_refl x Logic.eq_refl) in Hcrossprod. rewrite <-( let x := (PEmul (num (Fnorm fe2)) (rsplit_left (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l Hlpe Logic.eq_refl x Logic.eq_refl) in Hcrossprod. simpl in Hcrossprod. rewrite Hcrossprod. reflexivity. Qed. Theorem Field_simplify_eq_pow_in_correct : forall n l lpe fe1 fe2, Ninterp_PElist l lpe -> forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> forall den, split (denum nfe1) (denum nfe2) = den -> forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 -> forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 -> FEeval l fe1 == FEeval l fe2 -> PCond l (condition nfe1 ++ condition nfe2) -> NPphi_pow l np1 == NPphi_pow l np2. Proof. intros. subst nfe1 nfe2 lmp np1 np2. repeat rewrite (Pphi_pow_ok Rsth Reqe ARth CRmorph pow_th get_sign_spec). repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl. assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)). assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)). apply (@rmul_reg_l (NPEeval l (rsplit_common den))). intro Heq;apply N1. rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq]. repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))). repeat rewrite <- ARth.(ARmul_assoc). change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))). change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))). repeat rewrite <- NPEmul_correct. rewrite <- H3. rewrite <- split_correct_l. rewrite <- split_correct_r. apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))). intro Heq; apply AFth.(AF_1_neq_0). rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial. ring [Heq]. rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). repeat rewrite <- (ARth.(ARmul_assoc)). rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial. apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))). intro Heq; apply AFth.(AF_1_neq_0). rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial. ring [Heq]. repeat rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe1)))). repeat rewrite <- (ARth.(ARmul_assoc)). repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial. rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp. rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). repeat rewrite <- (AFth.(AFdiv_def)). repeat rewrite <- Fnorm_FEeval_PEeval ; trivial. apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7). Qed. Theorem Field_simplify_eq_in_correct : forall n l lpe fe1 fe2, Ninterp_PElist l lpe -> forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> forall den, split (denum nfe1) (denum nfe2) = den -> forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 -> forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 -> FEeval l fe1 == FEeval l fe2 -> PCond l (condition nfe1 ++ condition nfe2) -> NPphi_dev l np1 == NPphi_dev l np2. Proof. intros. subst nfe1 nfe2 lmp np1 np2. repeat rewrite (Pphi_dev_ok Rsth Reqe ARth CRmorph get_sign_spec). repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl. assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)). assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)). apply (@rmul_reg_l (NPEeval l (rsplit_common den))). intro Heq;apply N1. rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq]. repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))). repeat rewrite <- ARth.(ARmul_assoc). change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))). change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))). repeat rewrite <- NPEmul_correct;rewrite <- H3. rewrite <- split_correct_l. rewrite <- split_correct_r. apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))). intro Heq; apply AFth.(AF_1_neq_0). rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial. ring [Heq]. rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). repeat rewrite <- (ARth.(ARmul_assoc)). rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial. apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))). intro Heq; apply AFth.(AF_1_neq_0). rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial. ring [Heq]. repeat rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe1)))). repeat rewrite <- (ARth.(ARmul_assoc)). repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial. rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp. rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). repeat rewrite <- (AFth.(AFdiv_def)). repeat rewrite <- Fnorm_FEeval_PEeval;trivial. apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7). Qed. Section Fcons_impl. Variable Fcons : PExpr C -> list (PExpr C) -> list (PExpr C). Hypothesis PCond_fcons_inv : forall l a l1, PCond l (Fcons a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) := match l with | nil => m | cons a l1 => Fcons a (Fapp l1 m) end. Lemma fcons_correct : forall l l1, (forall lock, lock = PCond l -> lock (Fapp l1 nil)) -> PCond l l1. Proof. intros l l1 h1; assert (H := h1 (PCond l) (refl_equal _));clear h1. induction l1; simpl; intros. trivial. elim PCond_fcons_inv with (1 := H); intros. destruct l1; trivial. split; trivial. apply IHl1; trivial. Qed. End Fcons_impl. Section Fcons_simpl. (* Some general simpifications of the condition: eliminate duplicates, split multiplications *) Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := match l with nil => cons e nil | cons a l1 => if PExpr_eq e a then l else cons a (Fcons e l1) end. Theorem PFcons_fcons_inv: forall l a l1, PCond l (Fcons a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. intros l a l1; elim l1; simpl Fcons; auto. simpl; auto. intros a0 l0. generalize (PExpr_eq_semi_correct l a a0); case (PExpr_eq a a0). intros H H0 H1; split; auto. rewrite H; auto. generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. intros H H0 H1; assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)). split. generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. apply H0. generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto. generalize Hp; case l0; simpl; intuition. Qed. (* equality of normal forms rather than syntactic equality *) Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := match l with nil => cons e nil | cons a l1 => if Peq ceqb (Nnorm O nil e) (Nnorm O nil a) then l else cons a (Fcons0 e l1) end. Theorem PFcons0_fcons_inv: forall l a l1, PCond l (Fcons0 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. intros l a l1; elim l1; simpl Fcons0; auto. simpl; auto. intros a0 l0. generalize (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_th O l nil a a0). simpl. case (Peq ceqb (Nnorm O nil a) (Nnorm O nil a0)). intros H H0 H1; split; auto. rewrite H; auto. generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. intros H H0 H1; assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)). split. generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. apply H0. generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto. clear get_sign get_sign_spec. generalize Hp; case l0; simpl; intuition. Qed. (* split factorized denominators *) Fixpoint Fcons00 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := match e with PEmul e1 e2 => Fcons00 e1 (Fcons00 e2 l) | PEpow e1 _ => Fcons00 e1 l | _ => Fcons0 e l end. Theorem PFcons00_fcons_inv: forall l a l1, PCond l (Fcons00 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail). intros p H p0 H0 l1 H1. simpl in H1. case (H _ H1); intros H2 H3. case (H0 _ H3); intros H4 H5; split; auto. simpl. apply field_is_integral_domain; trivial. simpl;intros. rewrite pow_th.(rpow_pow_N). destruct (H _ H0);split;auto. destruct n;simpl. apply AFth.(AF_1_neq_0). apply pow_pos_not_0;trivial. Qed. Definition Pcond_simpl_gen := fcons_correct _ PFcons00_fcons_inv. (* Specific case when the equality test of coefs is complete w.r.t. the field equality: non-zero coefs can be eliminated, and opposite can be simplified (if -1 <> 0) *) Hypothesis ceqb_complete : forall c1 c2, phi c1 == phi c2 -> ceqb c1 c2 = true. Lemma ceqb_rect_complete : forall c1 c2 (A:Type) (x y:A) (P:A->Type), (phi c1 == phi c2 -> P x) -> (~ phi c1 == phi c2 -> P y) -> P (if ceqb c1 c2 then x else y). Proof. intros. generalize (fun h => X (morph_eq CRmorph c1 c2 h)). generalize (@ceqb_complete c1 c2). case (c1 ?=! c2); auto; intros. apply X0. red; intro. absurd (false = true); auto; discriminate. Qed. Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := match e with PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l) | PEpow e _ => Fcons1 e l | PEopp e => if ceqb (copp cI) cO then absurd_PCond else Fcons1 e l | PEc c => if ceqb c cO then absurd_PCond else l | _ => Fcons0 e l end. Theorem PFcons1_fcons_inv: forall l a l1, PCond l (Fcons1 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail). simpl; intros c l1. apply ceqb_rect_complete; intros. elim (@absurd_PCond_bottom l H0). split; trivial. rewrite <- (morph0 CRmorph); trivial. intros p H p0 H0 l1 H1. simpl in H1. case (H _ H1); intros H2 H3. case (H0 _ H3); intros H4 H5; split; auto. simpl. apply field_is_integral_domain; trivial. simpl; intros p H l1. apply ceqb_rect_complete; intros. elim (@absurd_PCond_bottom l H1). destruct (H _ H1). split; trivial. apply ropp_neq_0; trivial. rewrite (morph_opp CRmorph) in H0. rewrite (morph1 CRmorph) in H0. rewrite (morph0 CRmorph) in H0. trivial. intros;simpl. destruct (H _ H0);split;trivial. rewrite pow_th.(rpow_pow_N). destruct n;simpl. apply AFth.(AF_1_neq_0). apply pow_pos_not_0;trivial. Qed. Definition Fcons2 e l := Fcons1 (PExpr_simp e) l. Theorem PFcons2_fcons_inv: forall l a l1, PCond l (Fcons2 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. unfold Fcons2; intros l a l1 H; split; case (PFcons1_fcons_inv l (PExpr_simp a) l1); auto. intros H1 H2 H3; case H1. transitivity (NPEeval l a); trivial. apply PExpr_simp_correct. Qed. Definition Pcond_simpl_complete := fcons_correct _ PFcons2_fcons_inv. End Fcons_simpl. End AlmostField. Section FieldAndSemiField. Record field_theory : Prop := mk_field { F_R : ring_theory rO rI radd rmul rsub ropp req; F_1_neq_0 : ~ 1 == 0; Fdiv_def : forall p q, p / q == p * / q; Finv_l : forall p, ~ p == 0 -> / p * p == 1 }. Definition F2AF f := mk_afield (Rth_ARth Rsth Reqe f.(F_R)) f.(F_1_neq_0) f.(Fdiv_def) f.(Finv_l). Record semi_field_theory : Prop := mk_sfield { SF_SR : semi_ring_theory rO rI radd rmul req; SF_1_neq_0 : ~ 1 == 0; SFdiv_def : forall p q, p / q == p * / q; SFinv_l : forall p, ~ p == 0 -> / p * p == 1 }. End FieldAndSemiField. End MakeFieldPol. Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth (sf:semi_field_theory rO rI radd rmul rdiv rinv req) := mk_afield _ _ (SRth_ARth Rsth sf.(SF_SR)) sf.(SF_1_neq_0) sf.(SFdiv_def) sf.(SFinv_l). Section Complete. Variable R : Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable (rdiv : R -> R -> R) (rinv : R -> R). Variable req : R -> R -> Prop. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "x / y " := (rdiv x y). Notation "/ x" := (rinv x). Notation "x == y" := (req x y) (at level 70, no associativity). Variable Rsth : Setoid_Theory R req. Add Setoid R req Rsth as R_setoid3. Variable Reqe : ring_eq_ext radd rmul ropp req. Add Morphism radd : radd_ext3. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext3. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext3. exact (Ropp_ext Reqe). Qed. Section AlmostField. Variable AFth : almost_field_theory rO rI radd rmul rsub ropp rdiv rinv req. Let ARth := AFth.(AF_AR). Let rI_neq_rO := AFth.(AF_1_neq_0). Let rdiv_def := AFth.(AFdiv_def). Let rinv_l := AFth.(AFinv_l). Hypothesis S_inj : forall x y, 1+x==1+y -> x==y. Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0. Lemma add_inj_r : forall p x y, gen_phiPOS1 rI radd rmul p + x == gen_phiPOS1 rI radd rmul p + y -> x==y. intros p x y. elim p using Pos.peano_ind; simpl; intros. apply S_inj; trivial. apply H. apply S_inj. repeat rewrite (ARadd_assoc ARth). rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth); trivial. Qed. Lemma gen_phiPOS_inj : forall x y, gen_phiPOS rI radd rmul x == gen_phiPOS rI radd rmul y -> x = y. intros x y. repeat rewrite <- (same_gen Rsth Reqe ARth). case (Pos.compare_spec x y). intros. trivial. intros. elim gen_phiPOS_not_0 with (y - x)%positive. apply add_inj_r with x. symmetry. rewrite (ARadd_0_r Rsth ARth). rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth). now rewrite Pos.add_comm, Pos.sub_add. intros. elim gen_phiPOS_not_0 with (x - y)%positive. apply add_inj_r with y. rewrite (ARadd_0_r Rsth ARth). rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth). now rewrite Pos.add_comm, Pos.sub_add. Qed. Lemma gen_phiN_inj : forall x y, gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> x = y. destruct x; destruct y; simpl; intros; trivial. elim gen_phiPOS_not_0 with p. symmetry . rewrite (same_gen Rsth Reqe ARth); trivial. elim gen_phiPOS_not_0 with p. rewrite (same_gen Rsth Reqe ARth); trivial. rewrite gen_phiPOS_inj with (1 := H); trivial. Qed. Lemma gen_phiN_complete : forall x y, gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> N.eqb x y = true. Proof. intros. now apply N.eqb_eq, gen_phiN_inj. Qed. End AlmostField. Section Field. Variable Fth : field_theory rO rI radd rmul rsub ropp rdiv rinv req. Let Rth := Fth.(F_R). Let rI_neq_rO := Fth.(F_1_neq_0). Let rdiv_def := Fth.(Fdiv_def). Let rinv_l := Fth.(Finv_l). Let AFth := F2AF Rsth Reqe Fth. Let ARth := Rth_ARth Rsth Reqe Rth. Lemma ring_S_inj : forall x y, 1+x==1+y -> x==y. intros. transitivity (x + (1 + - (1))). rewrite (Ropp_def Rth). symmetry . apply (ARadd_0_r Rsth ARth). transitivity (y + (1 + - (1))). repeat rewrite <- (ARplus_assoc ARth). repeat rewrite (ARadd_assoc ARth). apply (Radd_ext Reqe). repeat rewrite <- (ARadd_comm ARth 1). trivial. reflexivity. rewrite (Ropp_def Rth). apply (ARadd_0_r Rsth ARth). Qed. Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0. Let gen_phiPOS_inject := gen_phiPOS_inj AFth ring_S_inj gen_phiPOS_not_0. Lemma gen_phiPOS_discr_sgn : forall x y, ~ gen_phiPOS rI radd rmul x == - gen_phiPOS rI radd rmul y. red; intros. apply gen_phiPOS_not_0 with (y + x)%positive. rewrite (ARgen_phiPOS_add Rsth Reqe ARth). transitivity (gen_phiPOS1 1 radd rmul y + - gen_phiPOS1 1 radd rmul y). apply (Radd_ext Reqe); trivial. reflexivity. rewrite (same_gen Rsth Reqe ARth). rewrite (same_gen Rsth Reqe ARth). trivial. apply (Ropp_def Rth). Qed. Lemma gen_phiZ_inj : forall x y, gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> x = y. destruct x; destruct y; simpl; intros. trivial. elim gen_phiPOS_not_0 with p. rewrite (same_gen Rsth Reqe ARth). symmetry ; trivial. elim gen_phiPOS_not_0 with p. rewrite (same_gen Rsth Reqe ARth). rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)). rewrite <- H. apply (ARopp_zero Rsth Reqe ARth). elim gen_phiPOS_not_0 with p. rewrite (same_gen Rsth Reqe ARth). trivial. rewrite gen_phiPOS_inject with (1 := H); trivial. elim gen_phiPOS_discr_sgn with (1 := H). elim gen_phiPOS_not_0 with p. rewrite (same_gen Rsth Reqe ARth). rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)). rewrite H. apply (ARopp_zero Rsth Reqe ARth). elim gen_phiPOS_discr_sgn with p0 p. symmetry ; trivial. replace p0 with p; trivial. apply gen_phiPOS_inject. rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)). rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p0)). rewrite H; trivial. reflexivity. Qed. Lemma gen_phiZ_complete : forall x y, gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> Zeq_bool x y = true. intros. replace y with x. unfold Zeq_bool. rewrite Z.compare_refl; trivial. apply gen_phiZ_inj; trivial. Qed. End Field. End Complete. coq-8.4pl4/plugins/setoid_ring/newring.ml40000644000175000017500000012106012326224777017711 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* f i c | _ -> assert false type protect_flag = Eval|Prot|Rec let tag_arg tag_rec map subs i c = match map i with Eval -> mk_clos subs c | Prot -> mk_atom c | Rec -> if i = -1 then mk_clos subs c else tag_rec c let rec mk_clos_but f_map subs t = match f_map t with | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t | None -> (match kind_of_term t with App(f,args) -> mk_clos_app_but f_map subs f args 0 | Prod _ -> mk_clos_deep (mk_clos_but f_map) subs t | _ -> mk_atom t) and mk_clos_app_but f_map subs f args n = if n >= Array.length args then mk_atom(mkApp(f, args)) else let fargs, args' = array_chop n args in let f' = mkApp(f,fargs) in match f_map f' with Some map -> mk_clos_deep (fun s' -> unmark_arg (tag_arg (mk_clos_but f_map s') map s')) subs (mkApp (mark_arg (-1) f', Array.mapi mark_arg args')) | None -> mk_clos_app_but f_map subs f args (n+1) let interp_map l c = try let (im,am) = List.assoc c l in Some(fun i -> if List.mem i im then Eval else if List.mem i am then Prot else if i = -1 then Eval else Rec) with Not_found -> None let interp_map l t = try Some(list_assoc_f eq_constr t l) with Not_found -> None let protect_maps = ref Stringmap.empty let add_map s m = protect_maps := Stringmap.add s m !protect_maps let lookup_map map = try Stringmap.find map !protect_maps with Not_found -> errorlabstrm"lookup_map"(str"map "++qs map++str"not found") let protect_red map env sigma c = kl (create_clos_infos betadeltaiota env) (mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c);; let protect_tac map = Tactics.reduct_option (protect_red map,DEFAULTcast) None ;; let protect_tac_in map id = Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Termops.InHyp));; TACTIC EXTEND protect_fv [ "protect_fv" string(map) "in" ident(id) ] -> [ protect_tac_in map id ] | [ "protect_fv" string(map) ] -> [ protect_tac map ] END;; (****************************************************************************) let closed_term t l = let l = List.map constr_of_global l in let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in if Quote.closed_under cs t then tclIDTAC else tclFAIL 0 (mt()) ;; TACTIC EXTEND closed_term [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] -> [ closed_term t l ] END ;; TACTIC EXTEND echo | [ "echo" constr(t) ] -> [ Pp.msg (Termops.print_constr t); Tacinterp.eval_tactic (TacId []) ] END;; (* let closed_term_ast l = TacFun([Some(id_of_string"t")], TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term", [Genarg.in_gen Genarg.wit_constr (mkVar(id_of_string"t")); Genarg.in_gen (Genarg.wit_list1 Genarg.wit_ref) l]))) *) let closed_term_ast l = let l = List.map (fun gr -> ArgArg(dummy_loc,gr)) l in TacFun([Some(id_of_string"t")], TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term", [Genarg.in_gen Genarg.globwit_constr (GVar(dummy_loc,id_of_string"t"),None); Genarg.in_gen (Genarg.wit_list1 Genarg.globwit_ref) l]))) (* let _ = add_tacdef false ((dummy_loc,id_of_string"ring_closed_term" *) (****************************************************************************) let ic c = let env = Global.env() and sigma = Evd.empty in Constrintern.interp_constr sigma env c let ty c = Typing.type_of (Global.env()) Evd.empty c let decl_constant na c = mkConst(declare_constant (id_of_string na) (DefinitionEntry { const_entry_body = c; const_entry_secctx = None; const_entry_type = None; const_entry_opaque = true }, IsProof Lemma)) (* Calling a global tactic *) let ltac_call tac (args:glob_tactic_arg list) = TacArg(dummy_loc,TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args)) (* Calling a locally bound tactic *) let ltac_lcall tac args = TacArg(dummy_loc,TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args)) let ltac_letin (x, e1) e2 = TacLetIn(false,[(dummy_loc,id_of_string x),e1],e2) let ltac_apply (f:glob_tactic_expr) (args:glob_tactic_arg list) = Tacinterp.eval_tactic (ltac_letin ("F", Tacexp f) (ltac_lcall "F" args)) let ltac_record flds = TacFun([Some(id_of_string"proj")], ltac_lcall "proj" flds) let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c) let dummy_goal env = let (gl,_,sigma) = Goal.V82.mk_goal Evd.empty (named_context_val env) mkProp Store.empty in {Evd.it = gl; Evd.sigma = sigma} let exec_tactic env n f args = let lid = list_tabulate(fun i -> id_of_string("x"^string_of_int i)) n in let res = ref [||] in let get_res ist = let l = List.map (fun id -> List.assoc id ist.lfun) lid in res := Array.of_list l; TacId[] in let getter = Tacexp(TacFun(List.map(fun id -> Some id) lid, glob_tactic(tacticIn get_res))) in let _ = Tacinterp.eval_tactic(ltac_call f (args@[getter])) (dummy_goal env) in !res let constr_of = function | VConstr ([],c) -> c | _ -> failwith "Ring.exec_tactic: anomaly" let stdlib_modules = [["Coq";"Setoids";"Setoid"]; ["Coq";"Lists";"List"]; ["Coq";"Init";"Datatypes"]; ["Coq";"Init";"Logic"]; ] let coq_constant c = lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c) let coq_mk_Setoid = coq_constant "Build_Setoid_Theory" let coq_cons = coq_constant "cons" let coq_nil = coq_constant "nil" let coq_None = coq_constant "None" let coq_Some = coq_constant "Some" let coq_eq = coq_constant "eq" let lapp f args = mkApp(Lazy.force f,args) let dest_rel0 t = match kind_of_term t with | App(f,args) when Array.length args >= 2 -> let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in if closed0 rel then (rel,args.(Array.length args - 2),args.(Array.length args - 1)) else error "ring: cannot find relation (not closed)" | _ -> error "ring: cannot find relation" let rec dest_rel t = match kind_of_term t with | Prod(_,_,c) -> dest_rel c | _ -> dest_rel0 t (****************************************************************************) (* Library linking *) let plugin_dir = "setoid_ring" let cdir = ["Coq";plugin_dir] let plugin_modules = List.map (fun d -> cdir@d) [["Ring_theory"];["Ring_polynom"]; ["Ring_tac"];["InitialRing"]; ["Field_tac"]; ["Field_theory"] ] let my_constant c = lazy (Coqlib.gen_constant_in_modules "Ring" plugin_modules c) let new_ring_path = make_dirpath (List.map id_of_string ["Ring_tac";plugin_dir;"Coq"]) let ltac s = lazy(make_kn (MPfile new_ring_path) (make_dirpath []) (mk_label s)) let znew_ring_path = make_dirpath (List.map id_of_string ["InitialRing";plugin_dir;"Coq"]) let zltac s = lazy(make_kn (MPfile znew_ring_path) (make_dirpath []) (mk_label s)) let mk_cst l s = lazy (Coqlib.gen_constant "newring" l s);; let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;; (* Ring theory *) (* almost_ring defs *) let coq_almost_ring_theory = my_constant "almost_ring_theory" (* setoid and morphism utilities *) let coq_eq_setoid = my_constant "Eqsth" let coq_eq_morph = my_constant "Eq_ext" let coq_eq_smorph = my_constant "Eq_s_ext" (* ring -> almost_ring utilities *) let coq_ring_theory = my_constant "ring_theory" let coq_mk_reqe = my_constant "mk_reqe" (* semi_ring -> almost_ring utilities *) let coq_semi_ring_theory = my_constant "semi_ring_theory" let coq_mk_seqe = my_constant "mk_seqe" let ltac_inv_morph_gen = zltac"inv_gen_phi" let ltac_inv_morphZ = zltac"inv_gen_phiZ" let ltac_inv_morphN = zltac"inv_gen_phiN" let ltac_inv_morphNword = zltac"inv_gen_phiNword" let coq_abstract = my_constant"Abstract" let coq_comp = my_constant"Computational" let coq_morph = my_constant"Morphism" (* morphism *) let coq_ring_morph = my_constant "ring_morph" let coq_semi_morph = my_constant "semi_morph" (* power function *) let ltac_inv_morph_nothing = zltac"inv_morph_nothing" let coq_pow_N_pow_N = my_constant "pow_N_pow_N" (* hypothesis *) let coq_mkhypo = my_constant "mkhypo" let coq_hypo = my_constant "hypo" (* Equality: do not evaluate but make recursive call on both sides *) let map_with_eq arg_map c = let (req,_,_) = dest_rel c in interp_map ((req,(function -1->Prot|_->Rec)):: List.map (fun (c,map) -> (Lazy.force c,map)) arg_map) let _ = add_map "ring" (map_with_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); pol_cst "Pphi_pow", (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)]) (****************************************************************************) (* Ring database *) type ring_info = { ring_carrier : types; ring_req : constr; ring_setoid : constr; ring_ext : constr; ring_morph : constr; ring_th : constr; ring_cst_tac : glob_tactic_expr; ring_pow_tac : glob_tactic_expr; ring_lemma1 : constr; ring_lemma2 : constr; ring_pre_tac : glob_tactic_expr; ring_post_tac : glob_tactic_expr } module Cmap = Map.Make(struct type t = constr let compare = constr_ord end) let from_carrier = ref Cmap.empty let from_relation = ref Cmap.empty let from_name = ref Spmap.empty let ring_for_carrier r = Cmap.find r !from_carrier let ring_for_relation rel = Cmap.find rel !from_relation let find_ring_structure env sigma l = match l with | t::cl' -> let ty = Retyping.get_type_of env sigma t in let check c = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then errorlabstrm "ring" (str"arguments of ring_simplify do not have all the same type") in List.iter check cl'; (try ring_for_carrier ty with Not_found -> errorlabstrm "ring" (str"cannot find a declared ring structure over"++ spc()++str"\""++pr_constr ty++str"\"")) | [] -> assert false (* let (req,_,_) = dest_rel cl in (try ring_for_relation req with Not_found -> errorlabstrm "ring" (str"cannot find a declared ring structure for equality"++ spc()++str"\""++pr_constr req++str"\"")) *) let _ = Summary.declare_summary "tactic-new-ring-table" { Summary.freeze_function = (fun () -> !from_carrier,!from_relation,!from_name); Summary.unfreeze_function = (fun (ct,rt,nt) -> from_carrier := ct; from_relation := rt; from_name := nt); Summary.init_function = (fun () -> from_carrier := Cmap.empty; from_relation := Cmap.empty; from_name := Spmap.empty) } let add_entry (sp,_kn) e = (* let _ = ty e.ring_lemma1 in let _ = ty e.ring_lemma2 in *) from_carrier := Cmap.add e.ring_carrier e !from_carrier; from_relation := Cmap.add e.ring_req e !from_relation; from_name := Spmap.add sp e !from_name let subst_th (subst,th) = let c' = subst_mps subst th.ring_carrier in let eq' = subst_mps subst th.ring_req in let set' = subst_mps subst th.ring_setoid in let ext' = subst_mps subst th.ring_ext in let morph' = subst_mps subst th.ring_morph in let th' = subst_mps subst th.ring_th in let thm1' = subst_mps subst th.ring_lemma1 in let thm2' = subst_mps subst th.ring_lemma2 in let tac'= subst_tactic subst th.ring_cst_tac in let pow_tac'= subst_tactic subst th.ring_pow_tac in let pretac'= subst_tactic subst th.ring_pre_tac in let posttac'= subst_tactic subst th.ring_post_tac in if c' == th.ring_carrier && eq' == th.ring_req && eq_constr set' th.ring_setoid && ext' == th.ring_ext && morph' == th.ring_morph && th' == th.ring_th && thm1' == th.ring_lemma1 && thm2' == th.ring_lemma2 && tac' == th.ring_cst_tac && pow_tac' == th.ring_pow_tac && pretac' == th.ring_pre_tac && posttac' == th.ring_post_tac then th else { ring_carrier = c'; ring_req = eq'; ring_setoid = set'; ring_ext = ext'; ring_morph = morph'; ring_th = th'; ring_cst_tac = tac'; ring_pow_tac = pow_tac'; ring_lemma1 = thm1'; ring_lemma2 = thm2'; ring_pre_tac = pretac'; ring_post_tac = posttac' } let theory_to_obj : ring_info -> obj = let cache_th (name,th) = add_entry name th in declare_object {(default_object "tactic-new-ring-theory") with open_function = (fun i o -> if i=1 then cache_th o); cache_function = cache_th; subst_function = subst_th; classify_function = (fun x -> Substitute x)} let setoid_of_relation env a r = let evm = Evd.empty in try lapp coq_mk_Setoid [|a ; r ; Rewrite.get_reflexive_proof env evm a r ; Rewrite.get_symmetric_proof env evm a r ; Rewrite.get_transitive_proof env evm a r |] with Not_found -> error "cannot find setoid relation" let op_morph r add mul opp req m1 m2 m3 = lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |] let op_smorph r add mul req m1 m2 = lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |] (* let default_ring_equality (r,add,mul,opp,req) = *) (* let is_setoid = function *) (* {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} -> *) (* eq_constr req rel (\* Qu: use conversion ? *\) *) (* | _ -> false in *) (* match default_relation_for_carrier ~filter:is_setoid r with *) (* Leibniz _ -> *) (* let setoid = lapp coq_eq_setoid [|r|] in *) (* let op_morph = *) (* match opp with *) (* Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] *) (* | None -> lapp coq_eq_smorph [|r;add;mul|] in *) (* (setoid,op_morph) *) (* | Relation rel -> *) (* let setoid = setoid_of_relation rel in *) (* let is_endomorphism = function *) (* { args=args } -> List.for_all *) (* (function (var,Relation rel) -> *) (* var=None && eq_constr req rel *) (* | _ -> false) args in *) (* let add_m = *) (* try default_morphism ~filter:is_endomorphism add *) (* with Not_found -> *) (* error "ring addition should be declared as a morphism" in *) (* let mul_m = *) (* try default_morphism ~filter:is_endomorphism mul *) (* with Not_found -> *) (* error "ring multiplication should be declared as a morphism" in *) (* let op_morph = *) (* match opp with *) (* | Some opp -> *) (* (let opp_m = *) (* try default_morphism ~filter:is_endomorphism opp *) (* with Not_found -> *) (* error "ring opposite should be declared as a morphism" in *) (* let op_morph = *) (* op_morph r add mul opp req add_m.lem mul_m.lem opp_m.lem in *) (* msgnl *) (* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\""++spc()++ *) (* str"and morphisms \""++pr_constr add_m.morphism_theory++ *) (* str"\","++spc()++ str"\""++pr_constr mul_m.morphism_theory++ *) (* str"\""++spc()++str"and \""++pr_constr opp_m.morphism_theory++ *) (* str"\""); *) (* op_morph) *) (* | None -> *) (* (msgnl *) (* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\"" ++ spc() ++ *) (* str"and morphisms \""++pr_constr add_m.morphism_theory++ *) (* str"\""++spc()++str"and \""++ *) (* pr_constr mul_m.morphism_theory++str"\""); *) (* op_smorph r add mul req add_m.lem mul_m.lem) in *) (* (setoid,op_morph) *) let ring_equality (r,add,mul,opp,req) = match kind_of_term req with | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) -> let setoid = lapp coq_eq_setoid [|r|] in let op_morph = match opp with Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] | None -> lapp coq_eq_smorph [|r;add;mul|] in (setoid,op_morph) | _ -> let setoid = setoid_of_relation (Global.env ()) r req in let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in let add_m, add_m_lem = try Rewrite.default_morphism signature add with Not_found -> error "ring addition should be declared as a morphism" in let mul_m, mul_m_lem = try Rewrite.default_morphism signature mul with Not_found -> error "ring multiplication should be declared as a morphism" in let op_morph = match opp with | Some opp -> (let opp_m,opp_m_lem = try Rewrite.default_morphism ([Some(r,Some req)],Some(r,Some req)) opp with Not_found -> error "ring opposite should be declared as a morphism" in let op_morph = op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in Flags.if_verbose msgnl (str"Using setoid \""++pr_constr req++str"\""++spc()++ str"and morphisms \""++pr_constr add_m_lem ++ str"\","++spc()++ str"\""++pr_constr mul_m_lem++ str"\""++spc()++str"and \""++pr_constr opp_m_lem++ str"\""); op_morph) | None -> (Flags.if_verbose msgnl (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++ str"and morphisms \""++pr_constr add_m_lem ++ str"\""++spc()++str"and \""++ pr_constr mul_m_lem++str"\""); op_smorph r add mul req add_m_lem mul_m_lem) in (setoid,op_morph) let build_setoid_params r add mul opp req eqth = match eqth with Some th -> th | None -> ring_equality (r,add,mul,opp,req) let dest_ring env sigma th_spec = let th_typ = Retyping.get_type_of env sigma th_spec in match kind_of_term th_typ with App(f,[|r;zero;one;add;mul;sub;opp;req|]) when eq_constr f (Lazy.force coq_almost_ring_theory) -> (None,r,zero,one,add,mul,Some sub,Some opp,req) | App(f,[|r;zero;one;add;mul;req|]) when eq_constr f (Lazy.force coq_semi_ring_theory) -> (Some true,r,zero,one,add,mul,None,None,req) | App(f,[|r;zero;one;add;mul;sub;opp;req|]) when eq_constr f (Lazy.force coq_ring_theory) -> (Some false,r,zero,one,add,mul,Some sub,Some opp,req) | _ -> error "bad ring structure" let dest_morph env sigma m_spec = let m_typ = Retyping.get_type_of env sigma m_spec in match kind_of_term m_typ with App(f,[|r;zero;one;add;mul;sub;opp;req; c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|]) when eq_constr f (Lazy.force coq_ring_morph) -> (c,czero,cone,cadd,cmul,Some csub,Some copp,ceqb,phi) | App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|]) when eq_constr f (Lazy.force coq_semi_morph) -> (c,czero,cone,cadd,cmul,None,None,ceqb,phi) | _ -> error "bad morphism structure" type coeff_spec = Computational of constr (* equality test *) | Abstract (* coeffs = Z *) | Morphism of constr (* general morphism *) let reflect_coeff rkind = (* We build an ill-typed terms on purpose... *) match rkind with Abstract -> Lazy.force coq_abstract | Computational c -> lapp coq_comp [|c|] | Morphism m -> lapp coq_morph [|m|] type cst_tac_spec = CstTac of raw_tactic_expr | Closed of reference list let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = match cst_tac with Some (CstTac t) -> Tacinterp.glob_tactic t | Some (Closed lc) -> closed_term_ast (List.map Smartlocate.global_with_alias lc) | None -> (match rk, opp, kind with Abstract, None, _ -> let t = ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in TacArg(dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul])) | Abstract, Some opp, Some _ -> let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphZ) in TacArg(dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp])) | Abstract, Some opp, None -> let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphNword) in TacArg (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp])) | Computational _,_,_ -> let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in TacArg (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;zero;one])) | Morphism mth,_,_ -> let (_,czero,cone,_,_,_,_,_,_) = dest_morph env sigma mth in let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in TacArg (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;czero;cone]))) let make_hyp env c = let t = Retyping.get_type_of env Evd.empty c in lapp coq_mkhypo [|t;c|] let make_hyp_list env lH = let carrier = Lazy.force coq_hypo in List.fold_right (fun c l -> lapp coq_cons [|carrier; (make_hyp env c); l|]) lH (lapp coq_nil [|carrier|]) let interp_power env pow = let carrier = Lazy.force coq_hypo in match pow with | None -> let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_nothing) in (TacArg(dummy_loc,TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|]) | Some (tac, spec) -> let tac = match tac with | CstTac t -> Tacinterp.glob_tactic t | Closed lc -> closed_term_ast (List.map Smartlocate.global_with_alias lc) in let spec = make_hyp env (ic spec) in (tac, lapp coq_Some [|carrier; spec|]) let interp_sign env sign = let carrier = Lazy.force coq_hypo in match sign with | None -> lapp coq_None [|carrier|] | Some spec -> let spec = make_hyp env (ic spec) in lapp coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) let interp_div env div = let carrier = Lazy.force coq_hypo in match div with | None -> lapp coq_None [|carrier|] | Some spec -> let spec = make_hyp env (ic spec) in lapp coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) let add_theory name rth eqth morphth cst_tac (pre,post) power sign div = check_required_library (cdir@["Ring_base"]); let env = Global.env() in let sigma = Evd.empty in let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in let (sth,ext) = build_setoid_params r add mul opp req eqth in let (pow_tac, pspec) = interp_power env power in let sspec = interp_sign env sign in let dspec = interp_div env div in let rk = reflect_coeff morphth in let params = exec_tactic env 5 (zltac "ring_lemmas") (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in let lemma1 = constr_of params.(3) in let lemma2 = constr_of params.(4) in let lemma1 = decl_constant (string_of_id name^"_ring_lemma1") lemma1 in let lemma2 = decl_constant (string_of_id name^"_ring_lemma2") lemma2 in let cst_tac = interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in let pretac = match pre with Some t -> Tacinterp.glob_tactic t | _ -> TacId [] in let posttac = match post with Some t -> Tacinterp.glob_tactic t | _ -> TacId [] in let _ = Lib.add_leaf name (theory_to_obj { ring_carrier = r; ring_req = req; ring_setoid = sth; ring_ext = constr_of params.(1); ring_morph = constr_of params.(2); ring_th = constr_of params.(0); ring_cst_tac = cst_tac; ring_pow_tac = pow_tac; ring_lemma1 = lemma1; ring_lemma2 = lemma2; ring_pre_tac = pretac; ring_post_tac = posttac }) in () type ring_mod = Ring_kind of coeff_spec | Const_tac of cst_tac_spec | Pre_tac of raw_tactic_expr | Post_tac of raw_tactic_expr | Setoid of Topconstr.constr_expr * Topconstr.constr_expr | Pow_spec of cst_tac_spec * Topconstr.constr_expr (* Syntaxification tactic , correctness lemma *) | Sign_spec of Topconstr.constr_expr | Div_spec of Topconstr.constr_expr VERNAC ARGUMENT EXTEND ring_mod | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational (ic eq_test)) ] | [ "abstract" ] -> [ Ring_kind Abstract ] | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism (ic morph)) ] | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ] | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ] | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ] | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ] | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ] | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ] | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] -> [ Pow_spec (Closed l, pow_spec) ] | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] -> [ Pow_spec (CstTac cst_tac, pow_spec) ] | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ] END let set_once s r v = if !r = None then r := Some v else error (s^" cannot be set twice") let process_ring_mods l = let kind = ref None in let set = ref None in let cst_tac = ref None in let pre = ref None in let post = ref None in let sign = ref None in let power = ref None in let div = ref None in List.iter(function Ring_kind k -> set_once "ring kind" kind k | Const_tac t -> set_once "tactic recognizing constants" cst_tac t | Pre_tac t -> set_once "preprocess tactic" pre t | Post_tac t -> set_once "postprocess tactic" post t | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext) | Pow_spec(t,spec) -> set_once "power" power (t,spec) | Sign_spec t -> set_once "sign" sign t | Div_spec t -> set_once "div" div t) l; let k = match !kind with Some k -> k | None -> Abstract in (k, !set, !cst_tac, !pre, !post, !power, !sign, !div) VERNAC COMMAND EXTEND AddSetoidRing | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] -> [ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in add_theory id (ic t) set k cst (pre,post) power sign div] END (*****************************************************************************) (* The tactics consist then only in a lookup in the ring database and call the appropriate ltac. *) let make_args_list rl t = match rl with | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2] | _ -> rl let make_term_list carrier rl = List.fold_right (fun x l -> lapp coq_cons [|carrier;x;l|]) rl (lapp coq_nil [|carrier|]) let ltac_ring_structure e = let req = carg e.ring_req in let sth = carg e.ring_setoid in let ext = carg e.ring_ext in let morph = carg e.ring_morph in let th = carg e.ring_th in let cst_tac = Tacexp e.ring_cst_tac in let pow_tac = Tacexp e.ring_pow_tac in let lemma1 = carg e.ring_lemma1 in let lemma2 = carg e.ring_lemma2 in let pretac = Tacexp(TacFun([None],e.ring_pre_tac)) in let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in [req;sth;ext;morph;th;cst_tac;pow_tac; lemma1;lemma2;pretac;posttac] let ring_lookup (f:glob_tactic_expr) lH rl t gl = let env = pf_env gl in let sigma = project gl in let rl = make_args_list rl t in let e = find_ring_structure env sigma rl in let rl = carg (make_term_list e.ring_carrier rl) in let lH = carg (make_hyp_list env lH) in let ring = ltac_ring_structure e in ltac_apply f (ring@[lH;rl]) gl TACTIC EXTEND ring_lookup | [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] -> [ let (t,lr) = list_sep_last lrt in ring_lookup f lH lr t] END (***********************************************************************) let new_field_path = make_dirpath (List.map id_of_string ["Field_tac";plugin_dir;"Coq"]) let field_ltac s = lazy(make_kn (MPfile new_field_path) (make_dirpath []) (mk_label s)) let _ = add_map "field" (map_with_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); (* display_linear: evaluate polynomials and coef operations, protect field operations and make recursive call on the var map *) my_constant "display_linear", (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot); my_constant "display_pow_linear", (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot); (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); pol_cst "Pphi_pow", (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot); (* FEeval: evaluate morphism, protect field operations and make recursive call on the var map *) my_constant "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);; let _ = add_map "field_cond" (map_with_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); (* PCond: evaluate morphism and denum list, protect ring operations and make recursive call on the var map *) my_constant "PCond", (function -1|8|10|13->Eval|12->Rec|_->Prot)]);; (* (function -1|8|10->Eval|9->Rec|_->Prot)]);;*) let _ = Redexpr.declare_reduction "simpl_field_expr" (protect_red "field") let afield_theory = my_constant "almost_field_theory" let field_theory = my_constant "field_theory" let sfield_theory = my_constant "semi_field_theory" let af_ar = my_constant"AF_AR" let f_r = my_constant"F_R" let sf_sr = my_constant"SF_SR" let dest_field env sigma th_spec = let th_typ = Retyping.get_type_of env sigma th_spec in match kind_of_term th_typ with | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) when eq_constr f (Lazy.force afield_theory) -> let rth = lapp af_ar [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) when eq_constr f (Lazy.force field_theory) -> let rth = lapp f_r [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;div;inv;req|]) when eq_constr f (Lazy.force sfield_theory) -> let rth = lapp sf_sr [|r;zero;one;add;mul;div;inv;req;th_spec|] in (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth) | _ -> error "bad field structure" type field_info = { field_carrier : types; field_req : constr; field_cst_tac : glob_tactic_expr; field_pow_tac : glob_tactic_expr; field_ok : constr; field_simpl_eq_ok : constr; field_simpl_ok : constr; field_simpl_eq_in_ok : constr; field_cond : constr; field_pre_tac : glob_tactic_expr; field_post_tac : glob_tactic_expr } let field_from_carrier = ref Cmap.empty let field_from_relation = ref Cmap.empty let field_from_name = ref Spmap.empty let field_for_carrier r = Cmap.find r !field_from_carrier let field_for_relation rel = Cmap.find rel !field_from_relation let find_field_structure env sigma l = check_required_library (cdir@["Field_tac"]); match l with | t::cl' -> let ty = Retyping.get_type_of env sigma t in let check c = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then errorlabstrm "field" (str"arguments of field_simplify do not have all the same type") in List.iter check cl'; (try field_for_carrier ty with Not_found -> errorlabstrm "field" (str"cannot find a declared field structure over"++ spc()++str"\""++pr_constr ty++str"\"")) | [] -> assert false (* let (req,_,_) = dest_rel cl in (try field_for_relation req with Not_found -> errorlabstrm "field" (str"cannot find a declared field structure for equality"++ spc()++str"\""++pr_constr req++str"\"")) *) let _ = Summary.declare_summary "tactic-new-field-table" { Summary.freeze_function = (fun () -> !field_from_carrier,!field_from_relation,!field_from_name); Summary.unfreeze_function = (fun (ct,rt,nt) -> field_from_carrier := ct; field_from_relation := rt; field_from_name := nt); Summary.init_function = (fun () -> field_from_carrier := Cmap.empty; field_from_relation := Cmap.empty; field_from_name := Spmap.empty) } let add_field_entry (sp,_kn) e = (* let _ = ty e.field_ok in let _ = ty e.field_simpl_eq_ok in let _ = ty e.field_simpl_ok in let _ = ty e.field_cond in *) field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier; field_from_relation := Cmap.add e.field_req e !field_from_relation; field_from_name := Spmap.add sp e !field_from_name let subst_th (subst,th) = let c' = subst_mps subst th.field_carrier in let eq' = subst_mps subst th.field_req in let thm1' = subst_mps subst th.field_ok in let thm2' = subst_mps subst th.field_simpl_eq_ok in let thm3' = subst_mps subst th.field_simpl_ok in let thm4' = subst_mps subst th.field_simpl_eq_in_ok in let thm5' = subst_mps subst th.field_cond in let tac'= subst_tactic subst th.field_cst_tac in let pow_tac' = subst_tactic subst th.field_pow_tac in let pretac'= subst_tactic subst th.field_pre_tac in let posttac'= subst_tactic subst th.field_post_tac in if c' == th.field_carrier && eq' == th.field_req && thm1' == th.field_ok && thm2' == th.field_simpl_eq_ok && thm3' == th.field_simpl_ok && thm4' == th.field_simpl_eq_in_ok && thm5' == th.field_cond && tac' == th.field_cst_tac && pow_tac' == th.field_pow_tac && pretac' == th.field_pre_tac && posttac' == th.field_post_tac then th else { field_carrier = c'; field_req = eq'; field_cst_tac = tac'; field_pow_tac = pow_tac'; field_ok = thm1'; field_simpl_eq_ok = thm2'; field_simpl_ok = thm3'; field_simpl_eq_in_ok = thm4'; field_cond = thm5'; field_pre_tac = pretac'; field_post_tac = posttac' } let ftheory_to_obj : field_info -> obj = let cache_th (name,th) = add_field_entry name th in declare_object {(default_object "tactic-new-field-theory") with open_function = (fun i o -> if i=1 then cache_th o); cache_function = cache_th; subst_function = subst_th; classify_function = (fun x -> Substitute x) } let field_equality r inv req = match kind_of_term req with | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) -> mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|]) | _ -> let _setoid = setoid_of_relation (Global.env ()) r req in let signature = [Some (r,Some req)],Some(r,Some req) in let inv_m, inv_m_lem = try Rewrite.default_morphism signature inv with Not_found -> error "field inverse should be declared as a morphism" in inv_m_lem let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odiv = check_required_library (cdir@["Field_tac"]); let env = Global.env() in let sigma = Evd.empty in let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) = dest_field env sigma fth in let (sth,ext) = build_setoid_params r add mul opp req eqth in let eqth = Some(sth,ext) in let _ = add_theory name rth eqth morphth cst_tac (None,None) power sign odiv in let (pow_tac, pspec) = interp_power env power in let sspec = interp_sign env sign in let dspec = interp_div env odiv in let inv_m = field_equality r inv req in let rk = reflect_coeff morphth in let params = exec_tactic env 9 (field_ltac"field_lemmas") (List.map carg[sth;ext;inv_m;fth;pspec;sspec;dspec;rk]) in let lemma1 = constr_of params.(3) in let lemma2 = constr_of params.(4) in let lemma3 = constr_of params.(5) in let lemma4 = constr_of params.(6) in let cond_lemma = match inj with | Some thm -> mkApp(constr_of params.(8),[|thm|]) | None -> constr_of params.(7) in let lemma1 = decl_constant (string_of_id name^"_field_lemma1") lemma1 in let lemma2 = decl_constant (string_of_id name^"_field_lemma2") lemma2 in let lemma3 = decl_constant (string_of_id name^"_field_lemma3") lemma3 in let lemma4 = decl_constant (string_of_id name^"_field_lemma4") lemma4 in let cond_lemma = decl_constant (string_of_id name^"_lemma5") cond_lemma in let cst_tac = interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in let pretac = match pre with Some t -> Tacinterp.glob_tactic t | _ -> TacId [] in let posttac = match post with Some t -> Tacinterp.glob_tactic t | _ -> TacId [] in let _ = Lib.add_leaf name (ftheory_to_obj { field_carrier = r; field_req = req; field_cst_tac = cst_tac; field_pow_tac = pow_tac; field_ok = lemma1; field_simpl_eq_ok = lemma2; field_simpl_ok = lemma3; field_simpl_eq_in_ok = lemma4; field_cond = cond_lemma; field_pre_tac = pretac; field_post_tac = posttac }) in () type field_mod = Ring_mod of ring_mod | Inject of Topconstr.constr_expr VERNAC ARGUMENT EXTEND field_mod | [ ring_mod(m) ] -> [ Ring_mod m ] | [ "completeness" constr(inj) ] -> [ Inject inj ] END let process_field_mods l = let kind = ref None in let set = ref None in let cst_tac = ref None in let pre = ref None in let post = ref None in let inj = ref None in let sign = ref None in let power = ref None in let div = ref None in List.iter(function Ring_mod(Ring_kind k) -> set_once "field kind" kind k | Ring_mod(Const_tac t) -> set_once "tactic recognizing constants" cst_tac t | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic sth,ic ext) | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec) | Ring_mod(Sign_spec t) -> set_once "sign" sign t | Ring_mod(Div_spec t) -> set_once "div" div t | Inject i -> set_once "infinite property" inj (ic i)) l; let k = match !kind with Some k -> k | None -> Abstract in (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) VERNAC COMMAND EXTEND AddSetoidField | [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> [ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div] END let ltac_field_structure e = let req = carg e.field_req in let cst_tac = Tacexp e.field_cst_tac in let pow_tac = Tacexp e.field_pow_tac in let field_ok = carg e.field_ok in let field_simpl_ok = carg e.field_simpl_ok in let field_simpl_eq_ok = carg e.field_simpl_eq_ok in let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in let cond_ok = carg e.field_cond in let pretac = Tacexp(TacFun([None],e.field_pre_tac)) in let posttac = Tacexp(TacFun([None],e.field_post_tac)) in [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok; field_simpl_eq_in_ok;cond_ok;pretac;posttac] let field_lookup (f:glob_tactic_expr) lH rl t gl = let env = pf_env gl in let sigma = project gl in let rl = make_args_list rl t in let e = find_field_structure env sigma rl in let rl = carg (make_term_list e.field_carrier rl) in let lH = carg (make_hyp_list env lH) in let field = ltac_field_structure e in ltac_apply f (field@[lH;rl]) gl TACTIC EXTEND field_lookup | [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] -> [ let (t,l) = list_sep_last lt in field_lookup f lH l t ] END coq-8.4pl4/plugins/setoid_ring/Ring_polynom.v0000644000175000017500000012441712326224777020476 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R->R) (ropp : R->R). Variable req : R -> R -> Prop. (* Ring properties *) Variable Rsth : Equivalence req. Variable Reqe : ring_eq_ext radd rmul ropp req. Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. (* Coefficients *) Variable C: Type. Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). Variable ceqb : C->C->bool. Variable phi : C -> R. Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. (* Power coefficients *) Variable Cpow : Type. Variable Cp_phi : N -> Cpow. Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory rI rmul req Cp_phi rpow. (* division is ok *) Variable cdiv: C -> C -> C * C. Variable div_th: div_theory req cadd cmul phi cdiv. (* R notations *) Notation "0" := rO. Notation "1" := rI. Infix "+" := radd. Infix "*" := rmul. Infix "-" := rsub. Notation "- x" := (ropp x). Infix "==" := req. Infix "^" := (pow_pos rmul). (* C notations *) Infix "+!" := cadd. Infix "*!" := cmul. Infix "-! " := csub. Notation "-! x" := (copp x). Infix "?=!" := ceqb. Notation "[ x ]" := (phi x). (* Useful tactics *) Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac rsimpl := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth. Ltac add_permut_rec t := match t with | ?x + ?y => add_permut_rec y || add_permut_rec x | _ => add_push t; apply (Radd_ext Reqe); [|reflexivity] end. Ltac add_permut := repeat (reflexivity || match goal with |- ?t == _ => add_permut_rec t end). Ltac mul_permut_rec t := match t with | ?x * ?y => mul_permut_rec y || mul_permut_rec x | _ => mul_push t; apply (Rmul_ext Reqe); [|reflexivity] end. Ltac mul_permut := repeat (reflexivity || match goal with |- ?t == _ => mul_permut_rec t end). (* Definition of multivariable polynomials with coefficients in C : Type [Pol] represents [X1 ... Xn]. The representation is Horner's where a [n] variable polynomial (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients are polynomials with [n-1] variables (C[X2..Xn]). There are several optimisations to make the repr compacter: - [Pc c] is the constant polynomial of value c == c*X1^0*..*Xn^0 - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. variable indices are shifted of j in Q. == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} - [PX P i Q] is an optimised Horner form of P*X^i + Q with P not the null polynomial == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} In addition: - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden since they can be represented by the simpler form (PX P (i+j) Q) - (Pinj i (Pinj j P)) is (Pinj (i+j) P) - (Pinj i (Pc c)) is (Pc c) *) Inductive Pol : Type := | Pc : C -> Pol | Pinj : positive -> Pol -> Pol | PX : Pol -> positive -> Pol -> Pol. Definition P0 := Pc cO. Definition P1 := Pc cI. Fixpoint Peq (P P' : Pol) {struct P'} : bool := match P, P' with | Pc c, Pc c' => c ?=! c' | Pinj j Q, Pinj j' Q' => match j ?= j' with | Eq => Peq Q Q' | _ => false end | PX P i Q, PX P' i' Q' => match i ?= i' with | Eq => if Peq P P' then Peq Q Q' else false | _ => false end | _, _ => false end. Infix "?==" := Peq. Definition mkPinj j P := match P with | Pc _ => P | Pinj j' Q => Pinj (j + j') Q | _ => Pinj j P end. Definition mkPinj_pred j P:= match j with | xH => P | xO j => Pinj (Pos.pred_double j) P | xI j => Pinj (xO j) P end. Definition mkPX P i Q := match P with | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q | Pinj _ _ => PX P i Q | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q end. Definition mkXi i := PX P1 i P0. Definition mkX := mkXi 1. (** Opposite of addition *) Fixpoint Popp (P:Pol) : Pol := match P with | Pc c => Pc (-! c) | Pinj j Q => Pinj j (Popp Q) | PX P i Q => PX (Popp P) i (Popp Q) end. Notation "-- P" := (Popp P). (** Addition et subtraction *) Fixpoint PaddC (P:Pol) (c:C) : Pol := match P with | Pc c1 => Pc (c1 +! c) | Pinj j Q => Pinj j (PaddC Q c) | PX P i Q => PX P i (PaddC Q c) end. Fixpoint PsubC (P:Pol) (c:C) : Pol := match P with | Pc c1 => Pc (c1 -! c) | Pinj j Q => Pinj j (PsubC Q c) | PX P i Q => PX P i (PsubC Q c) end. Section PopI. Variable Pop : Pol -> Pol -> Pol. Variable Q : Pol. Fixpoint PaddI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PaddC Q c) | Pinj j' Q' => match Z.pos_sub j' j with | Zpos k => mkPinj j (Pop (Pinj k Q') Q) | Z0 => mkPinj j (Pop Q' Q) | Zneg k => mkPinj j' (PaddI k Q') end | PX P i Q' => match j with | xH => PX P i (Pop Q' Q) | xO j => PX P i (PaddI (Pos.pred_double j) Q') | xI j => PX P i (PaddI (xO j) Q') end end. Fixpoint PsubI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PaddC (--Q) c) | Pinj j' Q' => match Z.pos_sub j' j with | Zpos k => mkPinj j (Pop (Pinj k Q') Q) | Z0 => mkPinj j (Pop Q' Q) | Zneg k => mkPinj j' (PsubI k Q') end | PX P i Q' => match j with | xH => PX P i (Pop Q' Q) | xO j => PX P i (PsubI (Pos.pred_double j) Q') | xI j => PX P i (PsubI (xO j) Q') end end. Variable P' : Pol. Fixpoint PaddX (i':positive) (P:Pol) : Pol := match P with | Pc c => PX P' i' P | Pinj j Q' => match j with | xH => PX P' i' Q' | xO j => PX P' i' (Pinj (Pos.pred_double j) Q') | xI j => PX P' i' (Pinj (xO j) Q') end | PX P i Q' => match Z.pos_sub i i' with | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' | Z0 => mkPX (Pop P P') i Q' | Zneg k => mkPX (PaddX k P) i Q' end end. Fixpoint PsubX (i':positive) (P:Pol) : Pol := match P with | Pc c => PX (--P') i' P | Pinj j Q' => match j with | xH => PX (--P') i' Q' | xO j => PX (--P') i' (Pinj (Pos.pred_double j) Q') | xI j => PX (--P') i' (Pinj (xO j) Q') end | PX P i Q' => match Z.pos_sub i i' with | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' | Z0 => mkPX (Pop P P') i Q' | Zneg k => mkPX (PsubX k P) i Q' end end. End PopI. Fixpoint Padd (P P': Pol) {struct P'} : Pol := match P' with | Pc c' => PaddC P c' | Pinj j' Q' => PaddI Padd Q' j' P | PX P' i' Q' => match P with | Pc c => PX P' i' (PaddC Q' c) | Pinj j Q => match j with | xH => PX P' i' (Padd Q Q') | xO j => PX P' i' (Padd (Pinj (Pos.pred_double j) Q) Q') | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q') end | PX P i Q => match Z.pos_sub i i' with | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q') | Z0 => mkPX (Padd P P') i (Padd Q Q') | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q') end end end. Infix "++" := Padd. Fixpoint Psub (P P': Pol) {struct P'} : Pol := match P' with | Pc c' => PsubC P c' | Pinj j' Q' => PsubI Psub Q' j' P | PX P' i' Q' => match P with | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c) | Pinj j Q => match j with | xH => PX (--P') i' (Psub Q Q') | xO j => PX (--P') i' (Psub (Pinj (Pos.pred_double j) Q) Q') | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q') end | PX P i Q => match Z.pos_sub i i' with | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q') | Z0 => mkPX (Psub P P') i (Psub Q Q') | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q') end end end. Infix "--" := Psub. (** Multiplication *) Fixpoint PmulC_aux (P:Pol) (c:C) : Pol := match P with | Pc c' => Pc (c' *! c) | Pinj j Q => mkPinj j (PmulC_aux Q c) | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c) end. Definition PmulC P c := if c ?=! cO then P0 else if c ?=! cI then P else PmulC_aux P c. Section PmulI. Variable Pmul : Pol -> Pol -> Pol. Variable Q : Pol. Fixpoint PmulI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PmulC Q c) | Pinj j' Q' => match Z.pos_sub j' j with | Zpos k => mkPinj j (Pmul (Pinj k Q') Q) | Z0 => mkPinj j (Pmul Q' Q) | Zneg k => mkPinj j' (PmulI k Q') end | PX P' i' Q' => match j with | xH => mkPX (PmulI xH P') i' (Pmul Q' Q) | xO j' => mkPX (PmulI j P') i' (PmulI (Pos.pred_double j') Q') | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') end end. End PmulI. Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol := match P'' with | Pc c => PmulC P c | Pinj j' Q' => PmulI Pmul Q' j' P | PX P' i' Q' => match P with | Pc c => PmulC P'' c | Pinj j Q => let QQ' := match j with | xH => Pmul Q Q' | xO j => Pmul (Pinj (Pos.pred_double j) Q) Q' | xI j => Pmul (Pinj (xO j) Q) Q' end in mkPX (Pmul P P') i' QQ' | PX P i Q=> let QQ' := Pmul Q Q' in let PQ' := PmulI Pmul Q' xH P in let QP' := Pmul (mkPinj xH Q) P' in let PP' := Pmul P P' in (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ' end end. Infix "**" := Pmul. Fixpoint Psquare (P:Pol) : Pol := match P with | Pc c => Pc (c *! c) | Pinj j Q => Pinj j (Psquare Q) | PX P i Q => let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in let Q2 := Psquare Q in let P2 := Psquare P in mkPX (mkPX P2 i P0 ++ twoPQ) i Q2 end. (** Monomial **) (** A monomial is X1^k1...Xi^ki. Its representation is a simplified version of the polynomial representation: - [mon0] correspond to the polynom [P1]. - [(zmon j M)] corresponds to [(Pinj j ...)], i.e. skip j variable indices. - [(vmon i M)] is X^i*M with X the current variable, its corresponds to (PX P1 i ...)] *) Inductive Mon: Set := | mon0: Mon | zmon: positive -> Mon -> Mon | vmon: positive -> Mon -> Mon. Definition mkZmon j M := match M with mon0 => mon0 | _ => zmon j M end. Definition zmon_pred j M := match j with xH => M | _ => mkZmon (Pos.pred j) M end. Definition mkVmon i M := match M with | mon0 => vmon i mon0 | zmon j m => vmon i (zmon_pred j m) | vmon i' m => vmon (i+i') m end. Fixpoint CFactor (P: Pol) (c: C) {struct P}: Pol * Pol := match P with | Pc c1 => let (q,r) := cdiv c1 c in (Pc r, Pc q) | Pinj j1 P1 => let (R,S) := CFactor P1 c in (mkPinj j1 R, mkPinj j1 S) | PX P1 i Q1 => let (R1, S1) := CFactor P1 c in let (R2, S2) := CFactor Q1 c in (mkPX R1 i R2, mkPX S1 i S2) end. Fixpoint MFactor (P: Pol) (c: C) (M: Mon) {struct P}: Pol * Pol := match P, M with _, mon0 => if (ceqb c cI) then (Pc cO, P) else CFactor P c | Pc _, _ => (P, Pc cO) | Pinj j1 P1, zmon j2 M1 => match j1 ?= j2 with Eq => let (R,S) := MFactor P1 c M1 in (mkPinj j1 R, mkPinj j1 S) | Lt => let (R,S) := MFactor P1 c (zmon (j2 - j1) M1) in (mkPinj j1 R, mkPinj j1 S) | Gt => (P, Pc cO) end | Pinj _ _, vmon _ _ => (P, Pc cO) | PX P1 i Q1, zmon j M1 => let M2 := zmon_pred j M1 in let (R1, S1) := MFactor P1 c M in let (R2, S2) := MFactor Q1 c M2 in (mkPX R1 i R2, mkPX S1 i S2) | PX P1 i Q1, vmon j M1 => match i ?= j with Eq => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in (mkPX R1 i Q1, S1) | Lt => let (R1,S1) := MFactor P1 c (vmon (j - i) M1) in (mkPX R1 i Q1, S1) | Gt => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO)) end end. Definition POneSubst (P1: Pol) (cM1: C * Mon) (P2: Pol): option Pol := let (c,M1) := cM1 in let (Q1,R1) := MFactor P1 c M1 in match R1 with (Pc c) => if c ?=! cO then None else Some (Padd Q1 (Pmul P2 R1)) | _ => Some (Padd Q1 (Pmul P2 R1)) end. Fixpoint PNSubst1 (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat) : Pol := match POneSubst P1 cM1 P2 with Some P3 => match n with S n1 => PNSubst1 P3 cM1 P2 n1 | _ => P3 end | _ => P1 end. Definition PNSubst (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat): option Pol := match POneSubst P1 cM1 P2 with Some P3 => match n with S n1 => Some (PNSubst1 P3 cM1 P2 n1) | _ => None end | _ => None end. Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) : Pol := match LM1 with cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n | _ => P1 end. Fixpoint PSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) : option Pol := match LM1 with cons (M1,P2) LM2 => match PNSubst P1 M1 P2 n with Some P3 => Some (PSubstL1 P3 LM2 n) | None => PSubstL P1 LM2 n end | _ => None end. Fixpoint PNSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (m n: nat) : Pol := match PSubstL P1 LM1 n with Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end | _ => P1 end. (** Evaluation of a polynomial towards R *) Local Notation hd := (List.hd 0). Fixpoint Pphi(l:list R) (P:Pol) : R := match P with | Pc c => [c] | Pinj j Q => Pphi (jump j l) Q | PX P i Q => Pphi l P * (hd l) ^ i + Pphi (tail l) Q end. Reserved Notation "P @ l " (at level 10, no associativity). Notation "P @ l " := (Pphi l P). (** Evaluation of a monomial towards R *) Fixpoint Mphi(l:list R) (M: Mon) : R := match M with | mon0 => rI | zmon j M1 => Mphi (jump j l) M1 | vmon i M1 => Mphi (tail l) M1 * (hd l) ^ i end. Notation "M @@ l" := (Mphi l M) (at level 10, no associativity). (** Proofs *) Ltac destr_pos_sub := match goal with |- context [Z.pos_sub ?x ?y] => generalize (Z.pos_sub_discr x y); destruct (Z.pos_sub x y) end. Lemma jump_add' i j (l:list R) : jump (i + j) l = jump j (jump i l). Proof. rewrite Pos.add_comm. apply jump_add. Qed. Lemma Peq_ok P P' : (P ?== P') = true -> forall l, P@l == P'@ l. Proof. revert P';induction P;destruct P';simpl; intros H l; try easy. - now apply (morph_eq CRmorph). - destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. now rewrite IHP. - specialize (IHP1 P'1); specialize (IHP2 P'2). destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. destruct (P2 ?== P'1); [|easy]. rewrite H in *. now rewrite IHP1, IHP2. Qed. Lemma Peq_spec P P' : BoolSpec (forall l, P@l == P'@l) True (P ?== P'). Proof. generalize (Peq_ok P P'). destruct (P ?== P'); auto. Qed. Lemma Pphi0 l : P0@l == 0. Proof. simpl;apply (morph0 CRmorph). Qed. Lemma Pphi1 l : P1@l == 1. Proof. simpl;apply (morph1 CRmorph). Qed. Lemma mkPinj_ok j l P : (mkPinj j P)@l == P@(jump j l). Proof. destruct P;simpl;rsimpl. now rewrite jump_add'. Qed. Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j. Proof. rewrite Pos.add_comm. apply (pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)). Qed. Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c'). Proof. generalize (morph_eq CRmorph c c'). destruct (c ?=! c'); auto. Qed. Lemma mkPX_ok l P i Q : (mkPX P i Q)@l == P@l * (hd l)^i + Q@(tail l). Proof. unfold mkPX. destruct P. - case ceqb_spec; intros H; simpl; try reflexivity. rewrite H, (morph0 CRmorph), mkPinj_ok; rsimpl. - reflexivity. - case Peq_spec; intros H; simpl; try reflexivity. rewrite H, Pphi0, Pos.add_comm, pow_pos_add; rsimpl. Qed. Hint Rewrite Pphi0 Pphi1 mkPinj_ok mkPX_ok (morph0 CRmorph) (morph1 CRmorph) (morph0 CRmorph) (morph_add CRmorph) (morph_mul CRmorph) (morph_sub CRmorph) (morph_opp CRmorph) : Esimpl. (* Quicker than autorewrite with Esimpl :-) *) Ltac Esimpl := try rewrite_db Esimpl; rsimpl; simpl. Lemma PaddC_ok c P l : (PaddC P c)@l == P@l + [c]. Proof. revert l;induction P;simpl;intros;Esimpl;trivial. rewrite IHP2;rsimpl. Qed. Lemma PsubC_ok c P l : (PsubC P c)@l == P@l - [c]. Proof. revert l;induction P;simpl;intros. - Esimpl. - rewrite IHP;rsimpl. - rewrite IHP2;rsimpl. Qed. Lemma PmulC_aux_ok c P l : (PmulC_aux P c)@l == P@l * [c]. Proof. revert l;induction P;simpl;intros;Esimpl;trivial. rewrite IHP1, IHP2;rsimpl. add_permut. mul_permut. Qed. Lemma PmulC_ok c P l : (PmulC P c)@l == P@l * [c]. Proof. unfold PmulC. case ceqb_spec; intros H. - rewrite H; Esimpl. - case ceqb_spec; intros H'. + rewrite H'; Esimpl. + apply PmulC_aux_ok. Qed. Lemma Popp_ok P l : (--P)@l == - P@l. Proof. revert l;induction P;simpl;intros. - Esimpl. - apply IHP. - rewrite IHP1, IHP2;rsimpl. Qed. Hint Rewrite PaddC_ok PsubC_ok PmulC_ok Popp_ok : Esimpl. Lemma PaddX_ok P' P k l : (forall P l, (P++P')@l == P@l + P'@l) -> (PaddX Padd P' k P) @ l == P@l + P'@l * (hd l)^k. Proof. intros IHP'. revert k l. induction P;simpl;intros. - add_permut. - destruct p; simpl; rewrite ?jump_pred_double; add_permut. - destr_pos_sub; intros ->;Esimpl. + rewrite IHP';rsimpl. add_permut. + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. + rewrite IHP1, pow_pos_add;rsimpl. add_permut. Qed. Lemma Padd_ok P' P l : (P ++ P')@l == P@l + P'@l. Proof. revert P l; induction P';simpl;intros;Esimpl. - revert p l; induction P;simpl;intros. + Esimpl; add_permut. + destr_pos_sub; intros ->;Esimpl. * now rewrite IHP'. * rewrite IHP';Esimpl. now rewrite jump_add'. * rewrite IHP. now rewrite jump_add'. + destruct p0;simpl. * rewrite IHP2;simpl. rsimpl. * rewrite IHP2;simpl. rewrite jump_pred_double. rsimpl. * rewrite IHP'. rsimpl. - destruct P;simpl. + Esimpl. add_permut. + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. * rsimpl. add_permut. * rewrite jump_pred_double. rsimpl. add_permut. * rsimpl. add_permut. + destr_pos_sub; intros ->; Esimpl. * rewrite IHP'1, IHP'2;rsimpl. add_permut. * rewrite IHP'1, IHP'2;simpl;Esimpl. rewrite pow_pos_add;rsimpl. add_permut. * rewrite PaddX_ok by trivial; rsimpl. rewrite IHP'2, pow_pos_add; rsimpl. add_permut. Qed. Lemma PsubX_ok P' P k l : (forall P l, (P--P')@l == P@l - P'@l) -> (PsubX Psub P' k P) @ l == P@l - P'@l * (hd l)^k. Proof. intros IHP'. revert k l. induction P;simpl;intros. - rewrite Popp_ok;rsimpl; add_permut. - destruct p; simpl; rewrite Popp_ok;rsimpl; rewrite ?jump_pred_double; add_permut. - destr_pos_sub; intros ->; Esimpl. + rewrite IHP';rsimpl. add_permut. + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. + rewrite IHP1, pow_pos_add;rsimpl. add_permut. Qed. Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l. Proof. revert P l; induction P';simpl;intros;Esimpl. - revert p l; induction P;simpl;intros. + Esimpl; add_permut. + destr_pos_sub; intros ->;Esimpl. * rewrite IHP';rsimpl. * rewrite IHP';Esimpl. now rewrite jump_add'. * rewrite IHP. now rewrite jump_add'. + destruct p0;simpl. * rewrite IHP2;simpl. rsimpl. * rewrite IHP2;simpl. rewrite jump_pred_double. rsimpl. * rewrite IHP'. rsimpl. - destruct P;simpl. + Esimpl; add_permut. + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. * rsimpl. add_permut. * rewrite jump_pred_double. rsimpl. add_permut. * rsimpl. add_permut. + destr_pos_sub; intros ->; Esimpl. * rewrite IHP'1, IHP'2;rsimpl. add_permut. * rewrite IHP'1, IHP'2;simpl;Esimpl. rewrite pow_pos_add;rsimpl. add_permut. * rewrite PsubX_ok by trivial;rsimpl. rewrite IHP'2, pow_pos_add;rsimpl. add_permut. Qed. Lemma PmulI_ok P' : (forall P l, (Pmul P P') @ l == P @ l * P' @ l) -> forall P p l, (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). Proof. intros IHP'. induction P;simpl;intros. - Esimpl; mul_permut. - destr_pos_sub; intros ->;Esimpl. + now rewrite IHP'. + now rewrite IHP', jump_add'. + now rewrite IHP, jump_add'. - destruct p0;Esimpl; rewrite ?IHP1, ?IHP2; rsimpl. + f_equiv. mul_permut. + rewrite jump_pred_double. f_equiv. mul_permut. + rewrite IHP'. f_equiv. mul_permut. Qed. Lemma Pmul_ok P P' l : (P**P')@l == P@l * P'@l. Proof. revert P l;induction P';simpl;intros. - apply PmulC_ok. - apply PmulI_ok;trivial. - destruct P. + rewrite (ARmul_comm ARth). Esimpl. + Esimpl. f_equiv. rewrite IHP'1; Esimpl. destruct p0;rewrite IHP'2;Esimpl. rewrite jump_pred_double; Esimpl. + rewrite Padd_ok, !mkPX_ok, Padd_ok, !mkPX_ok, !IHP'1, !IHP'2, PmulI_ok; trivial. simpl. Esimpl. add_permut; f_equiv; mul_permut. Qed. Lemma Psquare_ok P l : (Psquare P)@l == P@l * P@l. Proof. revert l;induction P;simpl;intros;Esimpl. - apply IHP. - rewrite Padd_ok, Pmul_ok;Esimpl. rewrite IHP1, IHP2. mul_push ((hd l)^p). now mul_push (P2@l). Qed. Lemma mkZmon_ok M j l : (mkZmon j M) @@ l == (zmon j M) @@ l. Proof. destruct M; simpl; rsimpl. Qed. Lemma zmon_pred_ok M j l : (zmon_pred j M) @@ (tail l) == (zmon j M) @@ l. Proof. destruct j; simpl; rewrite ?mkZmon_ok; simpl; rsimpl. rewrite jump_pred_double; rsimpl. Qed. Lemma mkVmon_ok M i l : (mkVmon i M)@@l == M@@l * (hd l)^i. Proof. destruct M;simpl;intros;rsimpl. - rewrite zmon_pred_ok;simpl;rsimpl. - rewrite pow_pos_add;rsimpl. Qed. Ltac destr_factor := match goal with | H : context [CFactor ?P _] |- context [CFactor ?P ?c] => destruct (CFactor P c); destr_factor; rewrite H; clear H | H : context [MFactor ?P _ _] |- context [MFactor ?P ?c ?M] => specialize (H M); destruct (MFactor P c M); destr_factor; rewrite H; clear H | _ => idtac end. Lemma Mcphi_ok P c l : let (Q,R) := CFactor P c in P@l == Q@l + [c] * R@l. Proof. revert l. induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl. - assert (H := div_th.(div_eucl_th) c0 c). destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. - destr_factor. Esimpl. - destr_factor. Esimpl. add_permut. Qed. Lemma Mphi_ok P (cM: C * Mon) l : let (c,M) := cM in let (Q,R) := MFactor P c M in P@l == Q@l + [c] * M@@l * R@l. Proof. destruct cM as (c,M). revert M l. induction P; destruct M; intros l; simpl; auto; try (case ceqb_spec; intro He); try (case Pos.compare_spec; intros He); rewrite ?He; destr_factor; simpl; Esimpl. - assert (H := div_th.(div_eucl_th) c0 c). destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. - assert (H := Mcphi_ok P c). destr_factor. Esimpl. - now rewrite <- jump_add, Pos.sub_add. - assert (H2 := Mcphi_ok P2 c). assert (H3 := Mcphi_ok P3 c). destr_factor. Esimpl. add_permut. - rewrite zmon_pred_ok. simpl. add_permut. - rewrite mkZmon_ok. simpl. add_permut. mul_permut. - add_permut. mul_permut. rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add by trivial; rsimpl. - rewrite mkZmon_ok. simpl. Esimpl. add_permut. mul_permut. rewrite <- pow_pos_add, Pos.sub_add by trivial; rsimpl. Qed. Lemma POneSubst_ok P1 cM1 P2 P3 l : POneSubst P1 cM1 P2 = Some P3 -> [fst cM1] * (snd cM1)@@l == P2@l -> P1@l == P3@l. Proof. destruct cM1 as (cc,M1). unfold POneSubst. assert (H := Mphi_ok P1 (cc, M1) l). simpl in H. destruct MFactor as (R1,S1); simpl. rewrite H. clear H. intros EQ EQ'. replace P3 with (R1 ++ P2 ** S1). - rewrite EQ', Padd_ok, Pmul_ok; rsimpl. - revert EQ. destruct S1; try now injection 1. case ceqb_spec; now inversion 2. Qed. Lemma PNSubst1_ok n P1 cM1 P2 l : [fst cM1] * (snd cM1)@@l == P2@l -> P1@l == (PNSubst1 P1 cM1 P2 n)@l. Proof. revert P1. induction n; simpl; intros P1; generalize (POneSubst_ok P1 cM1 P2); destruct POneSubst; intros; rewrite <- ?IHn; auto; reflexivity. Qed. Lemma PNSubst_ok n P1 cM1 P2 l P3 : PNSubst P1 cM1 P2 n = Some P3 -> [fst cM1] * (snd cM1)@@l == P2@l -> P1@l == P3@l. Proof. unfold PNSubst. assert (H := POneSubst_ok P1 cM1 P2); destruct POneSubst; try discriminate. destruct n; inversion_clear 1. intros. rewrite <- PNSubst1_ok; auto. Qed. Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) : Prop := match LM1 with | (M1,P2) :: LM2 => ([fst M1] * (snd M1)@@l == P2@l) /\ MPcond LM2 l | _ => True end. Lemma PSubstL1_ok n LM1 P1 l : MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. Proof. revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. - reflexivity. - rewrite <- IH by intuition. now apply PNSubst1_ok. Qed. Lemma PSubstL_ok n LM1 P1 P2 l : PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. Proof. revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros. - discriminate. - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst. * injection H; intros <-. rewrite <- PSubstL1_ok; intuition. * now apply IH. Qed. Lemma PNSubstL_ok m n LM1 P1 l : MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. Proof. revert LM1 P1. induction m; simpl; intros; assert (H' := PSubstL_ok n LM1 P2); destruct PSubstL; auto; try reflexivity. rewrite <- IHm; auto. Qed. (** Definition of polynomial expressions *) Inductive PExpr : Type := | PEc : C -> PExpr | PEX : positive -> PExpr | PEadd : PExpr -> PExpr -> PExpr | PEsub : PExpr -> PExpr -> PExpr | PEmul : PExpr -> PExpr -> PExpr | PEopp : PExpr -> PExpr | PEpow : PExpr -> N -> PExpr. (** evaluation of polynomial expressions towards R *) Definition mk_X j := mkPinj_pred j mkX. (** evaluation of polynomial expressions towards R *) Fixpoint PEeval (l:list R) (pe:PExpr) {struct pe} : R := match pe with | PEc c => phi c | PEX j => nth 0 j l | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) | PEopp pe1 => - (PEeval l pe1) | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) end. Strategy expand [PEeval]. (** Correctness proofs *) Lemma mkX_ok p l : nth 0 p l == (mk_X p) @ l. Proof. destruct p;simpl;intros;Esimpl;trivial. - now rewrite <-jump_tl, nth_jump. - now rewrite <- nth_jump, nth_pred_double. Qed. Hint Rewrite Padd_ok Psub_ok : Esimpl. Section POWER. Variable subst_l : Pol -> Pol. Fixpoint Ppow_pos (res P:Pol) (p:positive) : Pol := match p with | xH => subst_l (res ** P) | xO p => Ppow_pos (Ppow_pos res P p) P p | xI p => subst_l ((Ppow_pos (Ppow_pos res P p) P p) ** P) end. Definition Ppow_N P n := match n with | N0 => P1 | Npos p => Ppow_pos P1 P p end. Lemma Ppow_pos_ok l : (forall P, subst_l P@l == P@l) -> forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. Proof. intros subst_l_ok res P p. revert res. induction p;simpl;intros; rewrite ?subst_l_ok, ?Pmul_ok, ?IHp; mul_permut. Qed. Lemma Ppow_N_ok l : (forall P, subst_l P@l == P@l) -> forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. Proof. destruct n;simpl. - reflexivity. - rewrite Ppow_pos_ok by trivial. Esimpl. Qed. End POWER. (** Normalization and rewriting *) Section NORM_SUBST_REC. Variable n : nat. Variable lmp:list (C*Mon*Pol). Let subst_l P := PNSubstL P lmp n n. Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2). Let Ppow_subst := Ppow_N subst_l. Fixpoint norm_aux (pe:PExpr) : Pol := match pe with | PEc c => Pc c | PEX j => mk_X j | PEadd (PEopp pe1) pe2 => (norm_aux pe2) -- (norm_aux pe1) | PEadd pe1 (PEopp pe2) => (norm_aux pe1) -- (norm_aux pe2) | PEadd pe1 pe2 => (norm_aux pe1) ++ (norm_aux pe2) | PEsub pe1 pe2 => (norm_aux pe1) -- (norm_aux pe2) | PEmul pe1 pe2 => (norm_aux pe1) ** (norm_aux pe2) | PEopp pe1 => -- (norm_aux pe1) | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n end. Definition norm_subst pe := subst_l (norm_aux pe). (** Internally, [norm_aux] is expanded in a large number of cases. To speed-up proofs, we use an alternative definition. *) Definition get_PEopp pe := match pe with | PEopp pe' => Some pe' | _ => None end. Lemma norm_aux_PEadd pe1 pe2 : norm_aux (PEadd pe1 pe2) = match get_PEopp pe1, get_PEopp pe2 with | Some pe1', _ => (norm_aux pe2) -- (norm_aux pe1') | None, Some pe2' => (norm_aux pe1) -- (norm_aux pe2') | None, None => (norm_aux pe1) ++ (norm_aux pe2) end. Proof. simpl (norm_aux (PEadd _ _)). destruct pe1; [ | | | | | reflexivity | ]; destruct pe2; simpl get_PEopp; reflexivity. Qed. Lemma norm_aux_PEopp pe : match get_PEopp pe with | Some pe' => norm_aux pe = -- (norm_aux pe') | None => True end. Proof. now destruct pe. Qed. Lemma norm_aux_spec l pe : PEeval l pe == (norm_aux pe)@l. Proof. intros. induction pe. - reflexivity. - apply mkX_ok. - simpl PEeval. rewrite IHpe1, IHpe2. assert (H1 := norm_aux_PEopp pe1). assert (H2 := norm_aux_PEopp pe2). rewrite norm_aux_PEadd. do 2 destruct get_PEopp; rewrite ?H1, ?H2; Esimpl; add_permut. - simpl. rewrite IHpe1, IHpe2. Esimpl. - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - simpl. rewrite IHpe. Esimpl. - simpl. rewrite Ppow_N_ok by reflexivity. rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl. induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. Qed. Lemma norm_subst_spec : forall l pe, MPcond lmp l -> PEeval l pe == (norm_subst pe)@l. Proof. intros;unfold norm_subst. unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec. Qed. End NORM_SUBST_REC. Fixpoint interp_PElist (l:list R) (lpe:list (PExpr*PExpr)) {struct lpe} : Prop := match lpe with | nil => True | (me,pe)::lpe => match lpe with | nil => PEeval l me == PEeval l pe | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe end end. Fixpoint mon_of_pol (P:Pol) : option (C * Mon) := match P with | Pc c => if (c ?=! cO) then None else Some (c, mon0) | Pinj j P => match mon_of_pol P with | None => None | Some (c,m) => Some (c, mkZmon j m) end | PX P i Q => if Peq Q P0 then match mon_of_pol P with | None => None | Some (c,m) => Some (c, mkVmon i m) end else None end. Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (C*Mon*Pol) := match lpe with | nil => nil | (me,pe)::lpe => match mon_of_pol (norm_subst 0 nil me) with | None => mk_monpol_list lpe | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe end end. Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m -> forall l, [fst m] * Mphi l (snd m) == P@l. Proof. induction P;simpl;intros;Esimpl. assert (H1 := (morph_eq CRmorph) c cO). destruct (c ?=! cO). discriminate. inversion H;trivial;Esimpl. generalize H;clear H;case_eq (mon_of_pol P). intros (c1,P2) H0 H1; inversion H1; Esimpl. generalize (IHP (c1, P2) H0 (jump p l)). rewrite mkZmon_ok;simpl;auto. intros; discriminate. generalize H;clear H;change match P3 with | Pc c => c ?=! cO | Pinj _ _ => false | PX _ _ _ => false end with (P3 ?== P0). assert (H := Peq_ok P3 P0). destruct (P3 ?== P0). case_eq (mon_of_pol P2);try intros (cc, pp); intros. inversion H1. simpl. rewrite mkVmon_ok;simpl. rewrite H;trivial;Esimpl. generalize (IHP1 _ H0); simpl; intros HH; rewrite HH; rsimpl. discriminate. intros;discriminate. Qed. Lemma interp_PElist_ok : forall l lpe, interp_PElist l lpe -> MPcond (mk_monpol_list lpe) l. Proof. induction lpe;simpl. trivial. destruct a;simpl;intros. assert (HH:=mon_of_pol_ok (norm_subst 0 nil p)); destruct (mon_of_pol (norm_subst 0 nil p)). split. rewrite <- norm_subst_spec by exact I. destruct lpe;try destruct H;rewrite <- H; rewrite (norm_subst_spec 0 nil); try exact I;apply HH;trivial. apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0. apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0. Qed. Lemma norm_subst_ok : forall n l lpe pe, interp_PElist l lpe -> PEeval l pe == (norm_subst n (mk_monpol_list lpe) pe)@l. Proof. intros;apply norm_subst_spec. apply interp_PElist_ok;trivial. Qed. Lemma ring_correct : forall n l lpe pe1 pe2, interp_PElist l lpe -> (let lmp := mk_monpol_list lpe in norm_subst n lmp pe1 ?== norm_subst n lmp pe2) = true -> PEeval l pe1 == PEeval l pe2. Proof. simpl;intros. do 2 (rewrite (norm_subst_ok n l lpe);trivial). apply Peq_ok;trivial. Qed. (** Generic evaluation of polynomial towards R avoiding parenthesis *) Variable get_sign : C -> option C. Variable get_sign_spec : sign_theory copp ceqb get_sign. Section EVALUATION. (* [mkpow x p] = x^p *) Variable mkpow : R -> positive -> R. (* [mkpow x p] = -(x^p) *) Variable mkopp_pow : R -> positive -> R. (* [mkmult_pow r x p] = r * x^p *) Variable mkmult_pow : R -> R -> positive -> R. Fixpoint mkmult_rec (r:R) (lm:list (R*positive)) {struct lm}: R := match lm with | nil => r | cons (x,p) t => mkmult_rec (mkmult_pow r x p) t end. Definition mkmult1 lm := match lm with | nil => 1 | cons (x,p) t => mkmult_rec (mkpow x p) t end. Definition mkmultm1 lm := match lm with | nil => ropp rI | cons (x,p) t => mkmult_rec (mkopp_pow x p) t end. Definition mkmult_c_pos c lm := if c ?=! cI then mkmult1 (rev' lm) else mkmult_rec [c] (rev' lm). Definition mkmult_c c lm := match get_sign c with | None => mkmult_c_pos c lm | Some c' => if c' ?=! cI then mkmultm1 (rev' lm) else mkmult_rec [c] (rev' lm) end. Definition mkadd_mult rP c lm := match get_sign c with | None => rP + mkmult_c_pos c lm | Some c' => rP - mkmult_c_pos c' lm end. Definition add_pow_list (r:R) n l := match n with | N0 => l | Npos p => (r,p)::l end. Fixpoint add_mult_dev (rP:R) (P:Pol) (fv:list R) (n:N) (lm:list (R*positive)) {struct P} : R := match P with | Pc c => let lm := add_pow_list (hd fv) n lm in mkadd_mult rP c lm | Pinj j Q => add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd fv) n lm) | PX P i Q => let rP := add_mult_dev rP P fv (N.add (Npos i) n) lm in if Q ?== P0 then rP else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd fv) n lm) end. Fixpoint mult_dev (P:Pol) (fv : list R) (n:N) (lm:list (R*positive)) {struct P} : R := (* P@l * (hd 0 l)^n * lm *) match P with | Pc c => mkmult_c c (add_pow_list (hd fv) n lm) | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd fv) n lm) | PX P i Q => let rP := mult_dev P fv (N.add (Npos i) n) lm in if Q ?== P0 then rP else let lmq := add_pow_list (hd fv) n lm in add_mult_dev rP Q (tail fv) N0 lmq end. Definition Pphi_avoid fv P := mult_dev P fv N0 nil. Fixpoint r_list_pow (l:list (R*positive)) : R := match l with | nil => rI | cons (r,p) l => pow_pos rmul r p * r_list_pow l end. Hypothesis mkpow_spec : forall r p, mkpow r p == pow_pos rmul r p. Hypothesis mkopp_pow_spec : forall r p, mkopp_pow r p == - (pow_pos rmul r p). Hypothesis mkmult_pow_spec : forall r x p, mkmult_pow r x p == r * pow_pos rmul x p. Lemma mkmult_rec_ok : forall lm r, mkmult_rec r lm == r * r_list_pow lm. Proof. induction lm;intros;simpl;Esimpl. destruct a as (x,p);Esimpl. rewrite IHlm. rewrite mkmult_pow_spec. Esimpl. Qed. Lemma mkmult1_ok : forall lm, mkmult1 lm == r_list_pow lm. Proof. destruct lm;simpl;Esimpl. destruct p. rewrite mkmult_rec_ok;rewrite mkpow_spec;Esimpl. Qed. Lemma mkmultm1_ok : forall lm, mkmultm1 lm == - r_list_pow lm. Proof. destruct lm;simpl;Esimpl. destruct p;rewrite mkmult_rec_ok. rewrite mkopp_pow_spec;Esimpl. Qed. Lemma r_list_pow_rev : forall l, r_list_pow (rev' l) == r_list_pow l. Proof. assert (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l). induction l;intros;simpl;Esimpl. destruct a;rewrite IHl;Esimpl. rewrite (ARmul_comm ARth (pow_pos rmul r p)). reflexivity. intros;unfold rev'. rewrite H;simpl;Esimpl. Qed. Lemma mkmult_c_pos_ok : forall c lm, mkmult_c_pos c lm == [c]* r_list_pow lm. Proof. intros;unfold mkmult_c_pos;simpl. assert (H := (morph_eq CRmorph) c cI). rewrite <- r_list_pow_rev; destruct (c ?=! cI). rewrite H;trivial;Esimpl. apply mkmult1_ok. apply mkmult_rec_ok. Qed. Lemma mkmult_c_ok : forall c lm, mkmult_c c lm == [c] * r_list_pow lm. Proof. intros;unfold mkmult_c;simpl. case_eq (get_sign c);intros. assert (H1 := (morph_eq CRmorph) c0 cI). destruct (c0 ?=! cI). rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H)). Esimpl. rewrite H1;trivial. rewrite <- r_list_pow_rev;trivial;Esimpl. apply mkmultm1_ok. rewrite <- r_list_pow_rev; apply mkmult_rec_ok. apply mkmult_c_pos_ok. Qed. Lemma mkadd_mult_ok : forall rP c lm, mkadd_mult rP c lm == rP + [c]*r_list_pow lm. Proof. intros;unfold mkadd_mult. case_eq (get_sign c);intros. rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H));Esimpl. rewrite mkmult_c_pos_ok;Esimpl. rewrite mkmult_c_pos_ok;Esimpl. Qed. Lemma add_pow_list_ok : forall r n l, r_list_pow (add_pow_list r n l) == pow_N rI rmul r n * r_list_pow l. Proof. destruct n;simpl;intros;Esimpl. Qed. Lemma add_mult_dev_ok : forall P rP fv n lm, add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd fv) n * r_list_pow lm. Proof. induction P;simpl;intros. rewrite mkadd_mult_ok. rewrite add_pow_list_ok; Esimpl. rewrite IHP. simpl. rewrite add_pow_list_ok; Esimpl. change (match P3 with | Pc c => c ?=! cO | Pinj _ _ => false | PX _ _ _ => false end) with (Peq P3 P0). change match n with | N0 => Npos p | Npos q => Npos (p + q) end with (N.add (Npos p) n);trivial. assert (H := Peq_ok P3 P0). destruct (P3 ?== P0). rewrite (H eq_refl). rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. add_permut. mul_permut. rewrite IHP2. rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. add_permut. mul_permut. Qed. Lemma mult_dev_ok : forall P fv n lm, mult_dev P fv n lm == P@fv * pow_N rI rmul (hd fv) n * r_list_pow lm. Proof. induction P;simpl;intros;Esimpl. rewrite mkmult_c_ok;rewrite add_pow_list_ok;Esimpl. rewrite IHP. simpl;rewrite add_pow_list_ok;Esimpl. change (match P3 with | Pc c => c ?=! cO | Pinj _ _ => false | PX _ _ _ => false end) with (Peq P3 P0). change match n with | N0 => Npos p | Npos q => Npos (p + q) end with (N.add (Npos p) n);trivial. assert (H := Peq_ok P3 P0). destruct (P3 ?== P0). rewrite (H eq_refl). rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. mul_permut. rewrite add_mult_dev_ok. rewrite IHP1; rewrite add_pow_list_ok. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. add_permut; mul_permut. Qed. Lemma Pphi_avoid_ok : forall P fv, Pphi_avoid fv P == P@fv. Proof. unfold Pphi_avoid;intros;rewrite mult_dev_ok;simpl;Esimpl. Qed. End EVALUATION. Definition Pphi_pow := let mkpow x p := match p with xH => x | _ => rpow x (Cp_phi (Npos p)) end in let mkopp_pow x p := ropp (mkpow x p) in let mkmult_pow r x p := rmul r (mkpow x p) in Pphi_avoid mkpow mkopp_pow mkmult_pow. Lemma local_mkpow_ok r p : match p with | xI _ => rpow r (Cp_phi (Npos p)) | xO _ => rpow r (Cp_phi (Npos p)) | 1 => r end == pow_pos rmul r p. Proof. destruct p; now rewrite ?pow_th.(rpow_pow_N). Qed. Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P == P@fv. Proof. unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros; now rewrite ?local_mkpow_ok. Qed. Lemma ring_rw_pow_correct : forall n lH l, interp_PElist l lH -> forall lmp, mk_monpol_list lH = lmp -> forall pe npe, norm_subst n lmp pe = npe -> PEeval l pe == Pphi_pow l npe. Proof. intros n lH l H1 lmp Heq1 pe npe Heq2. rewrite Pphi_pow_ok, <- Heq2, <- Heq1. apply norm_subst_ok. trivial. Qed. Fixpoint mkmult_pow (r x:R) (p: positive) {struct p} : R := match p with | xH => r*x | xO p => mkmult_pow (mkmult_pow r x p) x p | xI p => mkmult_pow (mkmult_pow (r*x) x p) x p end. Definition mkpow x p := match p with | xH => x | xO p => mkmult_pow x x (Pos.pred_double p) | xI p => mkmult_pow x x (xO p) end. Definition mkopp_pow x p := match p with | xH => -x | xO p => mkmult_pow (-x) x (Pos.pred_double p) | xI p => mkmult_pow (-x) x (xO p) end. Definition Pphi_dev := Pphi_avoid mkpow mkopp_pow mkmult_pow. Lemma mkmult_pow_ok p r x : mkmult_pow r x p == r * x^p. Proof. revert r; induction p;intros;simpl;Esimpl;rewrite !IHp;Esimpl. Qed. Lemma mkpow_ok p x : mkpow x p == x^p. Proof. destruct p;simpl;intros;Esimpl. - rewrite !mkmult_pow_ok;Esimpl. - rewrite mkmult_pow_ok;Esimpl. change x with (x^1) at 1. now rewrite <- pow_pos_add, Pos.add_1_r, Pos.succ_pred_double. Qed. Lemma mkopp_pow_ok p x : mkopp_pow x p == - x^p. Proof. destruct p;simpl;intros;Esimpl. - rewrite !mkmult_pow_ok;Esimpl. - rewrite mkmult_pow_ok;Esimpl. change x with (x^1) at 1. now rewrite <- pow_pos_add, Pos.add_1_r, Pos.succ_pred_double. Qed. Lemma Pphi_dev_ok : forall P fv, Pphi_dev fv P == P@fv. Proof. unfold Pphi_dev;intros;apply Pphi_avoid_ok. - intros;apply mkpow_ok. - intros;apply mkopp_pow_ok. - intros;apply mkmult_pow_ok. Qed. Lemma ring_rw_correct : forall n lH l, interp_PElist l lH -> forall lmp, mk_monpol_list lH = lmp -> forall pe npe, norm_subst n lmp pe = npe -> PEeval l pe == Pphi_dev l npe. Proof. intros n lH l H1 lmp Heq1 pe npe Heq2. rewrite Pphi_dev_ok. rewrite <- Heq2;rewrite <- Heq1. apply norm_subst_ok. trivial. Qed. End MakeRingPol. coq-8.4pl4/plugins/setoid_ring/Rings_Z.v0000644000175000017500000000046212326224777017366 0ustar stephstephRequire Export Cring. Require Export Integral_domain. Require Export Ncring_initial. Instance Zcri: (Cring (Rr:=Zr)). red. exact Z.mul_comm. Defined. Lemma Z_one_zero: 1%Z <> 0%Z. omega. Qed. Instance Zdi : (Integral_domain (Rcr:=Zcri)). constructor. exact Zmult_integral. exact Z_one_zero. Defined. coq-8.4pl4/plugins/setoid_ring/Ring_base.v0000644000175000017500000000146112326224777017704 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* tl l | xO p => jump p (jump p l) | xI p => jump p (jump p (tl l)) end. Fixpoint nth (p:positive) (l:list A) {struct p} : A:= match p with | xH => hd default l | xO p => nth p (jump p l) | xI p => nth p (jump p (tl l)) end. Lemma jump_tl : forall j l, tl (jump j l) = jump j (tl l). Proof. induction j;simpl;intros; now rewrite ?IHj. Qed. Lemma jump_succ : forall j l, jump (Pos.succ j) l = jump 1 (jump j l). Proof. induction j;simpl;intros. - rewrite !IHj; simpl; now rewrite !jump_tl. - now rewrite !jump_tl. - trivial. Qed. Lemma jump_add : forall i j l, jump (i + j) l = jump i (jump j l). Proof. induction i using Pos.peano_ind; intros. - now rewrite Pos.add_1_l, jump_succ. - now rewrite Pos.add_succ_l, !jump_succ, IHi. Qed. Lemma jump_pred_double : forall i l, jump (Pos.pred_double i) (tl l) = jump i (jump i l). Proof. induction i;intros;simpl. - now rewrite !jump_tl. - now rewrite IHi, <- 2 jump_tl, IHi. - trivial. Qed. Lemma nth_jump : forall p l, nth p (tl l) = hd default (jump p l). Proof. induction p;simpl;intros. - now rewrite <-jump_tl, IHp. - now rewrite <-jump_tl, IHp. - trivial. Qed. Lemma nth_pred_double : forall p l, nth (Pos.pred_double p) (tl l) = nth p (jump p l). Proof. induction p;simpl;intros. - now rewrite !jump_tl. - now rewrite jump_pred_double, <- !jump_tl, IHp. - trivial. Qed. End MakeBinList. coq-8.4pl4/plugins/setoid_ring/Ring.v0000644000175000017500000000265012326224777016713 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* b) (eq(A:=bool)). split; simpl. destruct x; reflexivity. destruct x; destruct y; reflexivity. destruct x; destruct y; destruct z; reflexivity. reflexivity. destruct x; destruct y; reflexivity. destruct x; destruct y; reflexivity. destruct x; destruct y; destruct z; reflexivity. reflexivity. destruct x; reflexivity. Qed. Definition bool_eq (b1 b2:bool) := if b1 then b2 else negb b2. Lemma bool_eq_ok : forall b1 b2, bool_eq b1 b2 = true -> b1 = b2. destruct b1; destruct b2; auto. Qed. Ltac bool_cst t := let t := eval hnf in t in match t with true => constr:true | false => constr:false | _ => constr:NotConstant end. Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]). coq-8.4pl4/plugins/setoid_ring/InitialRing.v0000644000175000017500000006114612326224777020232 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R->R) (ropp : R -> R). Variable req : R -> R -> Prop. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). Variable Rsth : Setoid_Theory R req. Add Setoid R req Rsth as R_setoid3. Ltac rrefl := gen_reflexivity Rsth. Variable Reqe : ring_eq_ext radd rmul ropp req. Add Morphism radd : radd_ext3. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext3. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext3. exact (Ropp_ext Reqe). Qed. Fixpoint gen_phiPOS1 (p:positive) : R := match p with | xH => 1 | xO p => (1 + 1) * (gen_phiPOS1 p) | xI p => 1 + ((1 + 1) * (gen_phiPOS1 p)) end. Fixpoint gen_phiPOS (p:positive) : R := match p with | xH => 1 | xO xH => (1 + 1) | xO p => (1 + 1) * (gen_phiPOS p) | xI xH => 1 + (1 +1) | xI p => 1 + ((1 + 1) * (gen_phiPOS p)) end. Definition gen_phiZ1 z := match z with | Zpos p => gen_phiPOS1 p | Z0 => 0 | Zneg p => -(gen_phiPOS1 p) end. Definition gen_phiZ z := match z with | Zpos p => gen_phiPOS p | Z0 => 0 | Zneg p => -(gen_phiPOS p) end. Notation "[ x ]" := (gen_phiZ x). Definition get_signZ z := match z with | Zneg p => Some (Zpos p) | _ => None end. Lemma get_signZ_th : sign_theory Z.opp Zeq_bool get_signZ. Proof. constructor. destruct c;intros;try discriminate. injection H;clear H;intros H1;subst c'. simpl. unfold Zeq_bool. rewrite Z.compare_refl. trivial. Qed. Section ALMOST_RING. Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. Add Morphism rsub : rsub_ext3. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac norm := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x. Proof. induction x;simpl. rewrite IHx;destruct x;simpl;norm. rewrite IHx;destruct x;simpl;norm. rrefl. Qed. Lemma ARgen_phiPOS_Psucc : forall x, gen_phiPOS1 (Pos.succ x) == 1 + (gen_phiPOS1 x). Proof. induction x;simpl;norm. rewrite IHx;norm. add_push 1;rrefl. Qed. Lemma ARgen_phiPOS_add : forall x y, gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y). Proof. induction x;destruct y;simpl;norm. rewrite Pos.add_carry_spec. rewrite ARgen_phiPOS_Psucc. rewrite IHx;norm. add_push (gen_phiPOS1 y);add_push 1;rrefl. rewrite IHx;norm;add_push (gen_phiPOS1 y);rrefl. rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl. rewrite IHx;norm;add_push(gen_phiPOS1 y); add_push 1;rrefl. rewrite IHx;norm;add_push(gen_phiPOS1 y);rrefl. add_push 1;rrefl. rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl. Qed. Lemma ARgen_phiPOS_mult : forall x y, gen_phiPOS1 (x * y) == gen_phiPOS1 x * gen_phiPOS1 y. Proof. induction x;intros;simpl;norm. rewrite ARgen_phiPOS_add;simpl;rewrite IHx;norm. rewrite IHx;rrefl. Qed. End ALMOST_RING. Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. Let ARth := Rth_ARth Rsth Reqe Rth. Add Morphism rsub : rsub_ext4. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac norm := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. (*morphisms are extensionaly equal*) Lemma same_genZ : forall x, [x] == gen_phiZ1 x. Proof. destruct x;simpl; try rewrite (same_gen ARth);rrefl. Qed. Lemma gen_Zeqb_ok : forall x y, Zeq_bool x y = true -> [x] == [y]. Proof. intros x y H. assert (H1 := Zeq_bool_eq x y H);unfold IDphi in H1. rewrite H1;rrefl. Qed. Lemma gen_phiZ1_pos_sub : forall x y, gen_phiZ1 (Z.pos_sub x y) == gen_phiPOS1 x + -gen_phiPOS1 y. Proof. intros x y. rewrite Z.pos_sub_spec. case Pos.compare_spec; intros H; simpl. rewrite H. rewrite (Ropp_def Rth);rrefl. rewrite <- (Pos.sub_add y x H) at 2. rewrite Pos.add_comm. rewrite (ARgen_phiPOS_add ARth);simpl;norm. rewrite (Ropp_def Rth);norm. rewrite <- (Pos.sub_add x y H) at 2. rewrite (ARgen_phiPOS_add ARth);simpl;norm. add_push (gen_phiPOS1 (x-y));rewrite (Ropp_def Rth); norm. Qed. Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y]. Proof. intros x y; repeat rewrite same_genZ; generalize x y;clear x y. destruct x, y; simpl; norm. apply (ARgen_phiPOS_add ARth). apply gen_phiZ1_pos_sub. rewrite gen_phiZ1_pos_sub. apply (Radd_comm Rth). rewrite (ARgen_phiPOS_add ARth); norm. Qed. Lemma gen_phiZ_mul : forall x y, [x * y] == [x] * [y]. Proof. intros x y;repeat rewrite same_genZ. destruct x;destruct y;simpl;norm; rewrite (ARgen_phiPOS_mult ARth);try (norm;fail). rewrite (Ropp_opp Rsth Reqe Rth);rrefl. Qed. Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y]. Proof. intros;subst;rrefl. Qed. (*proof that [.] satisfies morphism specifications*) Lemma gen_phiZ_morph : ring_morph 0 1 radd rmul rsub ropp req Z0 (Zpos xH) Z.add Z.mul Z.sub Z.opp Zeq_bool gen_phiZ. Proof. assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH) Z.add Z.mul Zeq_bool gen_phiZ). apply mkRmorph;simpl;try rrefl. apply gen_phiZ_add. apply gen_phiZ_mul. apply gen_Zeqb_ok. apply (Smorph_morph Rsth Reqe Rth Zth SRmorph gen_phiZ_ext). Qed. End ZMORPHISM. (** N is a semi-ring and a setoid*) Lemma Nsth : Setoid_Theory N (@eq N). Proof (Eqsth N). Lemma Nseqe : sring_eq_ext N.add N.mul (@eq N). Proof (Eq_s_ext N.add N.mul). Lemma Nth : semi_ring_theory 0%N 1%N N.add N.mul (@eq N). Proof. constructor. exact N.add_0_l. exact N.add_comm. exact N.add_assoc. exact N.mul_1_l. exact N.mul_0_l. exact N.mul_comm. exact N.mul_assoc. exact N.mul_add_distr_r. Qed. Definition Nsub := SRsub N.add. Definition Nopp := (@SRopp N). Lemma Neqe : ring_eq_ext N.add N.mul Nopp (@eq N). Proof (SReqe_Reqe Nseqe). Lemma Nath : almost_ring_theory 0%N 1%N N.add N.mul Nsub Nopp (@eq N). Proof (SRth_ARth Nsth Nth). Lemma Neqb_ok : forall x y, N.eqb x y = true -> x = y. Proof. exact (fun x y => proj1 (N.eqb_eq x y)). Qed. (**Same as above : definition of two,extensionaly equal, generic morphisms *) (**from N to any semi-ring*) Section NMORPHISM. Variable R : Type. Variable (rO rI : R) (radd rmul: R->R->R). Variable req : R -> R -> Prop. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). Variable Rsth : Setoid_Theory R req. Add Setoid R req Rsth as R_setoid4. Ltac rrefl := gen_reflexivity Rsth. Variable SReqe : sring_eq_ext radd rmul req. Variable SRth : semi_ring_theory 0 1 radd rmul req. Let ARth := SRth_ARth Rsth SRth. Let Reqe := SReqe_Reqe SReqe. Let ropp := (@SRopp R). Let rsub := (@SRsub R radd). Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). Add Morphism radd : radd_ext4. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext4. exact (Rmul_ext Reqe). Qed. Ltac norm := gen_srewrite_sr Rsth Reqe ARth. Definition gen_phiN1 x := match x with | N0 => 0 | Npos x => gen_phiPOS1 1 radd rmul x end. Definition gen_phiN x := match x with | N0 => 0 | Npos x => gen_phiPOS 1 radd rmul x end. Notation "[ x ]" := (gen_phiN x). Lemma same_genN : forall x, [x] == gen_phiN1 x. Proof. destruct x;simpl. reflexivity. now rewrite (same_gen Rsth Reqe ARth). Qed. Lemma gen_phiN_add : forall x y, [x + y] == [x] + [y]. Proof. intros x y;repeat rewrite same_genN. destruct x;destruct y;simpl;norm. apply (ARgen_phiPOS_add Rsth Reqe ARth). Qed. Lemma gen_phiN_mult : forall x y, [x * y] == [x] * [y]. Proof. intros x y;repeat rewrite same_genN. destruct x;destruct y;simpl;norm. apply (ARgen_phiPOS_mult Rsth Reqe ARth). Qed. Lemma gen_phiN_sub : forall x y, [Nsub x y] == [x] - [y]. Proof. exact gen_phiN_add. Qed. (*gen_phiN satisfies morphism specifications*) Lemma gen_phiN_morph : ring_morph 0 1 radd rmul rsub ropp req 0%N 1%N N.add N.mul Nsub Nopp N.eqb gen_phiN. Proof. constructor; simpl; try reflexivity. apply gen_phiN_add. apply gen_phiN_sub. apply gen_phiN_mult. intros x y EQ. apply N.eqb_eq in EQ. now subst. Qed. End NMORPHISM. (* Words on N : initial structure for almost-rings. *) Definition Nword := list N. Definition NwO : Nword := nil. Definition NwI : Nword := 1%N :: nil. Definition Nwcons n (w : Nword) : Nword := match w, n with | nil, 0%N => nil | _, _ => n :: w end. Fixpoint Nwadd (w1 w2 : Nword) {struct w1} : Nword := match w1, w2 with | n1::w1', n2:: w2' => (n1+n2)%N :: Nwadd w1' w2' | nil, _ => w2 | _, nil => w1 end. Definition Nwopp (w:Nword) : Nword := Nwcons 0%N w. Definition Nwsub w1 w2 := Nwadd w1 (Nwopp w2). Fixpoint Nwscal (n : N) (w : Nword) {struct w} : Nword := match w with | m :: w' => (n*m)%N :: Nwscal n w' | nil => nil end. Fixpoint Nwmul (w1 w2 : Nword) {struct w1} : Nword := match w1 with | 0%N::w1' => Nwopp (Nwmul w1' w2) | n1::w1' => Nwsub (Nwscal n1 w2) (Nwmul w1' w2) | nil => nil end. Fixpoint Nw_is0 (w : Nword) : bool := match w with | nil => true | 0%N :: w' => Nw_is0 w' | _ => false end. Fixpoint Nweq_bool (w1 w2 : Nword) {struct w1} : bool := match w1, w2 with | n1::w1', n2::w2' => if N.eqb n1 n2 then Nweq_bool w1' w2' else false | nil, _ => Nw_is0 w2 | _, nil => Nw_is0 w1 end. Section NWORDMORPHISM. Variable R : Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable req : R -> R -> Prop. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). Variable Rsth : Setoid_Theory R req. Add Setoid R req Rsth as R_setoid5. Ltac rrefl := gen_reflexivity Rsth. Variable Reqe : ring_eq_ext radd rmul ropp req. Add Morphism radd : radd_ext5. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext5. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext5. exact (Ropp_ext Reqe). Qed. Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. Add Morphism rsub : rsub_ext7. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac norm := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. Fixpoint gen_phiNword (w : Nword) : R := match w with | nil => 0 | n :: nil => gen_phiN rO rI radd rmul n | N0 :: w' => - gen_phiNword w' | n::w' => gen_phiN rO rI radd rmul n - gen_phiNword w' end. Lemma gen_phiNword0_ok : forall w, Nw_is0 w = true -> gen_phiNword w == 0. Proof. induction w; simpl; intros; auto. reflexivity. destruct a. destruct w. reflexivity. rewrite IHw; trivial. apply (ARopp_zero Rsth Reqe ARth). discriminate. Qed. Lemma gen_phiNword_cons : forall w n, gen_phiNword (n::w) == gen_phiN rO rI radd rmul n - gen_phiNword w. induction w. destruct n; simpl; norm. intros. destruct n; norm. Qed. Lemma gen_phiNword_Nwcons : forall w n, gen_phiNword (Nwcons n w) == gen_phiN rO rI radd rmul n - gen_phiNword w. destruct w; intros. destruct n; norm. unfold Nwcons. rewrite gen_phiNword_cons. reflexivity. Qed. Lemma gen_phiNword_ok : forall w1 w2, Nweq_bool w1 w2 = true -> gen_phiNword w1 == gen_phiNword w2. induction w1; intros. simpl. rewrite (gen_phiNword0_ok _ H). reflexivity. rewrite gen_phiNword_cons. destruct w2. simpl in H. destruct a; try discriminate. rewrite (gen_phiNword0_ok _ H). norm. simpl in H. rewrite gen_phiNword_cons. case_eq (N.eqb a n); intros H0. rewrite H0 in H. apply N.eqb_eq in H0. rewrite <- H0. rewrite (IHw1 _ H). reflexivity. rewrite H0 in H; discriminate H. Qed. Lemma Nwadd_ok : forall x y, gen_phiNword (Nwadd x y) == gen_phiNword x + gen_phiNword y. induction x; intros. simpl. norm. destruct y. simpl Nwadd; norm. simpl Nwadd. repeat rewrite gen_phiNword_cons. rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) by (destruct Reqe; constructor; trivial). rewrite IHx. norm. add_push (- gen_phiNword x); reflexivity. Qed. Lemma Nwopp_ok : forall x, gen_phiNword (Nwopp x) == - gen_phiNword x. simpl. unfold Nwopp; simpl. intros. rewrite gen_phiNword_Nwcons; norm. Qed. Lemma Nwscal_ok : forall n x, gen_phiNword (Nwscal n x) == gen_phiN rO rI radd rmul n * gen_phiNword x. induction x; intros. norm. simpl Nwscal. repeat rewrite gen_phiNword_cons. rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) by (destruct Reqe; constructor; trivial). rewrite IHx. norm. Qed. Lemma Nwmul_ok : forall x y, gen_phiNword (Nwmul x y) == gen_phiNword x * gen_phiNword y. induction x; intros. norm. destruct a. simpl Nwmul. rewrite Nwopp_ok. rewrite IHx. rewrite gen_phiNword_cons. norm. simpl Nwmul. unfold Nwsub. rewrite Nwadd_ok. rewrite Nwscal_ok. rewrite Nwopp_ok. rewrite IHx. rewrite gen_phiNword_cons. norm. Qed. (* Proof that [.] satisfies morphism specifications *) Lemma gen_phiNword_morph : ring_morph 0 1 radd rmul rsub ropp req NwO NwI Nwadd Nwmul Nwsub Nwopp Nweq_bool gen_phiNword. constructor. reflexivity. reflexivity. exact Nwadd_ok. intros. unfold Nwsub. rewrite Nwadd_ok. rewrite Nwopp_ok. norm. exact Nwmul_ok. exact Nwopp_ok. exact gen_phiNword_ok. Qed. End NWORDMORPHISM. Section GEN_DIV. Variables (R : Type) (rO : R) (rI : R) (radd : R -> R -> R) (rmul : R -> R -> R) (rsub : R -> R -> R) (ropp : R -> R) (req : R -> R -> Prop) (C : Type) (cO : C) (cI : C) (cadd : C -> C -> C) (cmul : C -> C -> C) (csub : C -> C -> C) (copp : C -> C) (ceqb : C -> C -> bool) (phi : C -> R). Variable Rsth : Setoid_Theory R req. Variable Reqe : ring_eq_ext radd rmul ropp req. Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. Variable morph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. (* Useful tactics *) Add Setoid R req Rsth as R_set1. Ltac rrefl := gen_reflexivity Rsth. Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac rsimpl := gen_srewrite Rsth Reqe ARth. Definition triv_div x y := if ceqb x y then (cI, cO) else (cO, x). Ltac Esimpl :=repeat (progress ( match goal with | |- context [phi cO] => rewrite (morph0 morph) | |- context [phi cI] => rewrite (morph1 morph) | |- context [phi (cadd ?x ?y)] => rewrite ((morph_add morph) x y) | |- context [phi (cmul ?x ?y)] => rewrite ((morph_mul morph) x y) | |- context [phi (csub ?x ?y)] => rewrite ((morph_sub morph) x y) | |- context [phi (copp ?x)] => rewrite ((morph_opp morph) x) end)). Lemma triv_div_th : Ring_theory.div_theory req cadd cmul phi triv_div. Proof. constructor. intros a b;unfold triv_div. assert (X:= morph.(morph_eq) a b);destruct (ceqb a b). Esimpl. rewrite X; trivial. rsimpl. Esimpl; rsimpl. Qed. Variable zphi : Z -> R. Lemma Ztriv_div_th : div_theory req Z.add Z.mul zphi Z.quotrem. Proof. constructor. intros; generalize (Z.quotrem_eq a b); case Z.quotrem; intros; subst. rewrite Z.mul_comm; rsimpl. Qed. Variable nphi : N -> R. Lemma Ntriv_div_th : div_theory req N.add N.mul nphi N.div_eucl. constructor. intros; generalize (N.div_eucl_spec a b); case N.div_eucl; intros; subst. rewrite N.mul_comm; rsimpl. Qed. End GEN_DIV. (* syntaxification of constants in an abstract ring: the inverse of gen_phiPOS *) Ltac inv_gen_phi_pos rI add mul t := let rec inv_cst t := match t with rI => constr:1%positive | (add rI rI) => constr:2%positive | (add rI (add rI rI)) => constr:3%positive | (mul (add rI rI) ?p) => (* 2p *) match inv_cst p with NotConstant => constr:NotConstant | 1%positive => constr:NotConstant (* 2*1 is not convertible to 2 *) | ?p => constr:(xO p) end | (add rI (mul (add rI rI) ?p)) => (* 1+2p *) match inv_cst p with NotConstant => constr:NotConstant | 1%positive => constr:NotConstant | ?p => constr:(xI p) end | _ => constr:NotConstant end in inv_cst t. (* The (partial) inverse of gen_phiNword *) Ltac inv_gen_phiNword rO rI add mul opp t := match t with rO => constr:NwO | _ => match inv_gen_phi_pos rI add mul t with NotConstant => constr:NotConstant | ?p => constr:(Npos p::nil) end end. (* The inverse of gen_phiN *) Ltac inv_gen_phiN rO rI add mul t := match t with rO => constr:0%N | _ => match inv_gen_phi_pos rI add mul t with NotConstant => constr:NotConstant | ?p => constr:(Npos p) end end. (* The inverse of gen_phiZ *) Ltac inv_gen_phiZ rO rI add mul opp t := match t with rO => constr:0%Z | (opp ?p) => match inv_gen_phi_pos rI add mul p with NotConstant => constr:NotConstant | ?p => constr:(Zneg p) end | _ => match inv_gen_phi_pos rI add mul t with NotConstant => constr:NotConstant | ?p => constr:(Zpos p) end end. (* A simple tactic recognizing only 0 and 1. The inv_gen_phiX above are only optimisations that directly returns the reifid constant instead of resorting to the constant propagation of the simplification algorithm. *) Ltac inv_gen_phi rO rI cO cI t := match t with | rO => cO | rI => cI end. (* A simple tactic recognizing no constant *) Ltac inv_morph_nothing t := constr:NotConstant. Ltac coerce_to_almost_ring set ext rspec := match type of rspec with | ring_theory _ _ _ _ _ _ _ => constr:(Rth_ARth set ext rspec) | semi_ring_theory _ _ _ _ _ => constr:(SRth_ARth set rspec) | almost_ring_theory _ _ _ _ _ _ _ => rspec | _ => fail 1 "not a valid ring theory" end. Ltac coerce_to_ring_ext ext := match type of ext with | ring_eq_ext _ _ _ _ => ext | sring_eq_ext _ _ _ => constr:(SReqe_Reqe ext) | _ => fail 1 "not a valid ring_eq_ext theory" end. Ltac abstract_ring_morphism set ext rspec := match type of rspec with | ring_theory _ _ _ _ _ _ _ => constr:(gen_phiZ_morph set ext rspec) | semi_ring_theory _ _ _ _ _ => constr:(gen_phiN_morph set ext rspec) | almost_ring_theory _ _ _ _ _ _ _ => constr:(gen_phiNword_morph set ext rspec) | _ => fail 1 "bad ring structure" end. Record hypo : Type := mkhypo { hypo_type : Type; hypo_proof : hypo_type }. Ltac gen_ring_pow set arth pspec := match pspec with | None => match type of arth with | @almost_ring_theory ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?req => constr:(mkhypo (@pow_N_th R rI rmul req set)) | _ => fail 1 "gen_ring_pow" end | Some ?t => constr:(t) end. Ltac gen_ring_sign morph sspec := match sspec with | None => match type of morph with | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req Z ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi => constr:(@mkhypo (sign_theory copp ceqb get_signZ) get_signZ_th) | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi => constr:(mkhypo (@get_sign_None_th C copp ceqb)) | _ => fail 2 "ring anomaly : default_sign_spec" end | Some ?t => constr:(t) end. Ltac default_div_spec set reqe arth morph := match type of morph with | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req Z ?c0 ?c1 Z.add Z.mul ?csub ?copp ?ceq_b ?phi => constr:(mkhypo (Ztriv_div_th set phi)) | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req N ?c0 ?c1 N.add N.mul ?csub ?copp ?ceq_b ?phi => constr:(mkhypo (Ntriv_div_th set phi)) | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi => constr:(mkhypo (triv_div_th set reqe arth morph)) | _ => fail 1 "ring anomaly : default_sign_spec" end. Ltac gen_ring_div set reqe arth morph dspec := match dspec with | None => default_div_spec set reqe arth morph | Some ?t => constr:(t) end. Ltac ring_elements set ext rspec pspec sspec dspec rk := let arth := coerce_to_almost_ring set ext rspec in let ext_r := coerce_to_ring_ext ext in let morph := match rk with | Abstract => abstract_ring_morphism set ext rspec | @Computational ?reqb_ok => match type of arth with | almost_ring_theory ?rO ?rI ?add ?mul ?sub ?opp _ => constr:(IDmorph rO rI add mul sub opp set _ reqb_ok) | _ => fail 2 "ring anomaly" end | @Morphism ?m => match type of m with | ring_morph _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => m | @semi_morph _ _ _ _ _ _ _ _ _ _ _ _ _ => constr:(SRmorph_Rmorph set m) | _ => fail 2 "ring anomaly" end | _ => fail 1 "ill-formed ring kind" end in let p_spec := gen_ring_pow set arth pspec in let s_spec := gen_ring_sign morph sspec in let d_spec := gen_ring_div set ext_r arth morph dspec in fun f => f arth ext_r morph p_spec s_spec d_spec. (* Given a ring structure and the kind of morphism, returns 2 lemmas (one for ring, and one for ring_simplify). *) Ltac ring_lemmas set ext rspec pspec sspec dspec rk := let gen_lemma2 := match pspec with | None => constr:(ring_rw_correct) | Some _ => constr:(ring_rw_pow_correct) end in ring_elements set ext rspec pspec sspec dspec rk ltac:(fun arth ext_r morph p_spec s_spec d_spec => match type of morph with | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi => let gen_lemma2_0 := constr:(gen_lemma2 R r0 rI radd rmul rsub ropp req set ext_r arth C c0 c1 cadd cmul csub copp ceq_b phi morph) in match p_spec with | @mkhypo (power_theory _ _ _ ?Cp_phi ?rpow) ?pp_spec => let gen_lemma2_1 := constr:(gen_lemma2_0 _ Cp_phi rpow pp_spec) in match d_spec with | @mkhypo (div_theory _ _ _ _ ?cdiv) ?dd_spec => let gen_lemma2_2 := constr:(gen_lemma2_1 cdiv dd_spec) in match s_spec with | @mkhypo (sign_theory _ _ ?get_sign) ?ss_spec => let lemma2 := constr:(gen_lemma2_2 get_sign ss_spec) in let lemma1 := constr:(ring_correct set ext_r arth morph pp_spec dd_spec) in fun f => f arth ext_r morph lemma1 lemma2 | _ => fail 4 "ring: bad sign specification" end | _ => fail 3 "ring: bad coefficiant division specification" end | _ => fail 2 "ring: bad power specification" end | _ => fail 1 "ring internal error: ring_lemmas, please report" end). (* Tactic for constant *) Ltac isnatcst t := match t with O => constr:true | S ?p => isnatcst p | _ => constr:false end. Ltac isPcst t := match t with | xI ?p => isPcst p | xO ?p => isPcst p | xH => constr:true (* nat -> positive *) | Pos.of_succ_nat ?n => isnatcst n | _ => constr:false end. Ltac isNcst t := match t with N0 => constr:true | Npos ?p => isPcst p | _ => constr:false end. Ltac isZcst t := match t with Z0 => constr:true | Zpos ?p => isPcst p | Zneg ?p => isPcst p (* injection nat -> Z *) | Z.of_nat ?n => isnatcst n (* injection N -> Z *) | Z.of_N ?n => isNcst n (* *) | _ => constr:false end. coq-8.4pl4/plugins/setoid_ring/Field_tac.v0000644000175000017500000004473412326224777017677 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* match t with | (radd ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(FEadd e1 e2) | (rmul ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(FEmul e1 e2) | (rsub ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(FEsub e1 e2) | (ropp ?t1) => fun _ => let e1 := mkP t1 in constr:(FEopp e1) | (rdiv ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(FEdiv e1 e2) | (rinv ?t1) => fun _ => let e1 := mkP t1 in constr:(FEinv e1) | (rpow ?t1 ?n) => match CstPow n with | InitialRing.NotConstant => fun _ => let p := Find_at t fv in constr:(@FEX C p) | ?c => fun _ => let e1 := mkP t1 in constr:(FEpow e1 c) end | _ => fun _ => let p := Find_at t fv in constr:(@FEX C p) end | ?c => fun _ => constr:(FEc c) end in f () in mkP t. Ltac FFV Cst CstPow add mul sub opp div inv pow t fv := let rec TFV t fv := match Cst t with | InitialRing.NotConstant => match t with | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) | (opp ?t1) => TFV t1 fv | (div ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) | (inv ?t1) => TFV t1 fv | (pow ?t1 ?n) => match CstPow n with | InitialRing.NotConstant => AddFvTail t fv | _ => TFV t1 fv end | _ => AddFvTail t fv end | _ => fv end in TFV t fv. (* packaging the field structure *) (* TODO: inline PackField into field_lookup *) Ltac PackField F req Cst_tac Pow_tac L1 L2 L3 L4 cond_ok pre post := let FLD := match type of L1 with | context [req (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) _ ] => (fun proj => proj Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok) | _ => fail 1 "field anomaly: bad correctness lemma (parse)" end in F FLD. Ltac get_FldPre FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => pre). Ltac get_FldPost FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => post). Ltac get_L1 FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => L1). Ltac get_SimplifyEqLemma FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => L2). Ltac get_SimplifyLemma FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => L3). Ltac get_L4 FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => L4). Ltac get_CondLemma FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => cond_ok). Ltac get_FldEq FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => req). Ltac get_FldCarrier FLD := let req := get_FldEq FLD in relation_carrier req. Ltac get_RingFV FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => FV Cst_tac Pow_tac radd rmul rsub ropp rpow). Ltac get_FFV FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow). Ltac get_RingMeta FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow). Ltac get_Meta FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow). Ltac get_Hyp_tac FLD := FLD ltac: (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok => let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH). Ltac get_FEeval FLD := let L1 := get_L1 FLD in match type of L1 with | context [(@FEeval ?R ?r0 ?add ?mul ?sub ?opp ?div ?inv ?C ?phi ?Cpow ?powphi ?pow _ _)] => constr:(@FEeval R r0 add mul sub opp div inv C phi Cpow powphi pow) | _ => fail 1 "field anomaly: bad correctness lemma (get_FEeval)" end. (* simplifying the non-zero condition... *) Ltac fold_field_cond req := let rec fold_concl t := match t with ?x /\ ?y => let fx := fold_concl x in let fy := fold_concl y in constr:(fx/\fy) | req ?x ?y -> False => constr:(~ req x y) | _ => t end in let ft := fold_concl Get_goal in change ft. Ltac simpl_PCond FLD := let req := get_FldEq FLD in let lemma := get_CondLemma FLD in try (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; clear lock_def lock); protect_fv "field_cond"; fold_field_cond req; try exact I. Ltac simpl_PCond_BEURK FLD := let req := get_FldEq FLD in let lemma := get_CondLemma FLD in try (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; clear lock_def lock); protect_fv "field_cond"; fold_field_cond req. (* Rewriting (field_simplify) *) Ltac Field_norm_gen f n FLD lH rl := let mkFV := get_RingFV FLD in let mkFFV := get_FFV FLD in let mkFE := get_Meta FLD in let fv0 := FV_hypo_tac mkFV ltac:(get_FldEq FLD) lH in let lemma_tac fv kont := let lemma := get_SimplifyLemma FLD in (* reify equations of the context *) let lpe := get_Hyp_tac FLD fv lH in let vlpe := fresh "hyps" in pose (vlpe := lpe); let prh := proofHyp_tac lH in (* compute the normal form of the reified hyps *) let vlmp := fresh "hyps'" in let vlmp_eq := fresh "hyps_eq" in let mk_monpol := get_MonPol lemma in compute_assertion vlmp_eq vlmp (mk_monpol vlpe); (* partially instantiate the lemma *) let lem := fresh "f_rw_lemma" in (assert (lem := lemma n vlpe fv prh vlmp vlmp_eq) || fail "type error when building the rewriting lemma"); (* continuation will call main_tac for all reified terms *) kont lem; (* at the end, cleanup *) (clear lem vlmp_eq vlmp vlpe||idtac"Field_norm_gen:cleanup failed") in (* each instance of the lemma is simplified then passed to f *) let main_tac H := protect_fv "field" in H; f H in (* generate and use equations for each expression *) ReflexiveRewriteTactic mkFFV mkFE lemma_tac main_tac fv0 rl; try simpl_PCond FLD. Ltac Field_simplify_gen f FLD lH rl := get_FldPre FLD (); Field_norm_gen f ring_subst_niter FLD lH rl; get_FldPost FLD (). Ltac Field_simplify := Field_simplify_gen ltac:(fun H => rewrite H). Tactic Notation (at level 0) "field_simplify" constr_list(rl) := let G := Get_goal in field_lookup (PackField Field_simplify) [] rl G. Tactic Notation (at level 0) "field_simplify" "[" constr_list(lH) "]" constr_list(rl) := let G := Get_goal in field_lookup (PackField Field_simplify) [lH] rl G. Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):= let G := Get_goal in let t := type of H in let g := fresh "goal" in set (g:= G); revert H; field_lookup (PackField Field_simplify) [] rl t; intro H; unfold g;clear g. Tactic Notation "field_simplify" "["constr_list(lH) "]" constr_list(rl) "in" hyp(H):= let G := Get_goal in let t := type of H in let g := fresh "goal" in set (g:= G); revert H; field_lookup (PackField Field_simplify) [lH] rl t; intro H; unfold g;clear g. (* Ltac Field_simplify_in hyp:= Field_simplify_gen ltac:(fun H => rewrite H in hyp). Tactic Notation (at level 0) "field_simplify" constr_list(rl) "in" hyp(h) := let t := type of h in field_lookup (Field_simplify_in h) [] rl t. Tactic Notation (at level 0) "field_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h) := let t := type of h in field_lookup (Field_simplify_in h) [lH] rl t. *) (** Generic tactic for solving equations *) Ltac Field_Scheme Simpl_tac n lemma FLD lH := let req := get_FldEq FLD in let mkFV := get_RingFV FLD in let mkFFV := get_FFV FLD in let mkFE := get_Meta FLD in let Main_eq t1 t2 := let fv := FV_hypo_tac mkFV req lH in let fv := mkFFV t1 fv in let fv := mkFFV t2 fv in let lpe := get_Hyp_tac FLD fv lH in let prh := proofHyp_tac lH in let vlpe := fresh "list_hyp" in let fe1 := mkFE t1 fv in let fe2 := mkFE t2 fv in pose (vlpe := lpe); let nlemma := fresh "field_lemma" in (assert (nlemma := lemma n fv vlpe fe1 fe2 prh) || fail "field anomaly:failed to build lemma"); ProveLemmaHyps nlemma ltac:(fun ilemma => apply ilemma || fail "field anomaly: failed in applying lemma"; [ Simpl_tac | simpl_PCond FLD]); clear nlemma; subst vlpe in OnEquation req Main_eq. (* solve completely a field equation, leaving non-zero conditions to be proved (field) *) Ltac FIELD FLD lH rl := let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in let lemma := get_L1 FLD in get_FldPre FLD (); Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH; try exact I; get_FldPost FLD(). Tactic Notation (at level 0) "field" := let G := Get_goal in field_lookup (PackField FIELD) [] G. Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" := let G := Get_goal in field_lookup (PackField FIELD) [lH] G. (* transforms a field equation to an equivalent (simplified) ring equation, and leaves non-zero conditions to be proved (field_simplify_eq) *) Ltac FIELD_SIMPL FLD lH rl := let Simpl := (protect_fv "field") in let lemma := get_SimplifyEqLemma FLD in get_FldPre FLD (); Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH; get_FldPost FLD (). Tactic Notation (at level 0) "field_simplify_eq" := let G := Get_goal in field_lookup (PackField FIELD_SIMPL) [] G. Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" := let G := Get_goal in field_lookup (PackField FIELD_SIMPL) [lH] G. (* Same as FIELD_SIMPL but in hypothesis *) Ltac Field_simplify_eq n FLD lH := let req := get_FldEq FLD in let mkFV := get_RingFV FLD in let mkFFV := get_FFV FLD in let mkFE := get_Meta FLD in let lemma := get_L4 FLD in let hyp := fresh "hyp" in intro hyp; OnEquationHyp req hyp ltac:(fun t1 t2 => let fv := FV_hypo_tac mkFV req lH in let fv := mkFFV t1 fv in let fv := mkFFV t2 fv in let lpe := get_Hyp_tac FLD fv lH in let prh := proofHyp_tac lH in let fe1 := mkFE t1 fv in let fe2 := mkFE t2 fv in let vlpe := fresh "vlpe" in ProveLemmaHyps (lemma n fv lpe fe1 fe2 prh) ltac:(fun ilemma => match type of ilemma with | req _ _ -> _ -> ?EQ => let tmp := fresh "tmp" in assert (tmp : EQ); [ apply ilemma; [ exact hyp | simpl_PCond_BEURK FLD] | protect_fv "field" in tmp; revert tmp ]; clear hyp end)). Ltac FIELD_SIMPL_EQ FLD lH rl := get_FldPre FLD (); Field_simplify_eq Ring_tac.ring_subst_niter FLD lH; get_FldPost FLD (). Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) := let t := type of H in generalize H; field_lookup (PackField FIELD_SIMPL_EQ) [] t; [ try exact I | clear H;intro H]. Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" "in" hyp(H) := let t := type of H in generalize H; field_lookup (PackField FIELD_SIMPL_EQ) [lH] t; [ try exact I |clear H;intro H]. (* More generic tactics to build variants of field *) (* This tactic reifies c and pass to F: - the FLD structure gathering all info in the field DB - the atom list - the expression (FExpr) *) Ltac gen_with_field F c := let MetaExpr FLD _ rl := let R := get_FldCarrier FLD in let mkFFV := get_FFV FLD in let mkFE := get_Meta FLD in let csr := match rl with | List.cons ?r _ => r | _ => fail 1 "anomaly: ill-formed list" end in let fv := mkFFV csr (@List.nil R) in let expr := mkFE csr fv in F FLD fv expr in field_lookup (PackField MetaExpr) [] (c=c). (* pushes the equation expr = ope(expr) in the goal, and discharge it with field *) Ltac prove_field_eqn ope FLD fv expr := let res := ope expr in let expr' := fresh "input_expr" in pose (expr' := expr); let res' := fresh "result" in pose (res' := res); let lemma := get_L1 FLD in let lemma := constr:(lemma O fv List.nil expr' res' I List.nil (eq_refl _)) in let ty := type of lemma in let lhs := match ty with forall _, ?lhs=_ -> _ => lhs end in let rhs := match ty with forall _, _=_ -> forall _, ?rhs=_ -> _ => rhs end in let lhs' := fresh "lhs" in let lhs_eq := fresh "lhs_eq" in let rhs' := fresh "rhs" in let rhs_eq := fresh "rhs_eq" in compute_assertion lhs_eq lhs' lhs; compute_assertion rhs_eq rhs' rhs; let H := fresh "fld_eqn" in refine (_ (lemma lhs' lhs_eq rhs' rhs_eq _ _)); (* main goal *) [intro H;protect_fv "field" in H; revert H (* ring-nf(lhs') = ring-nf(rhs') *) | vm_compute; reflexivity || fail "field cannot prove this equality" (* denominator condition *) | simpl_PCond FLD]; clear lhs_eq rhs_eq; subst lhs' rhs'. Ltac prove_with_field ope c := gen_with_field ltac:(prove_field_eqn ope) c. (* Prove an equation x=ope(x) and rewrite with it *) Ltac prove_rw ope x := prove_with_field ope x; [ let H := fresh "Heq_maple" in intro H; rewrite H; clear H |..]. (* Apply ope (FExpr->FExpr) on an expression *) Ltac reduce_field_expr ope kont FLD fv expr := let evfun := get_FEeval FLD in let res := ope expr in let c := (eval simpl_field_expr in (evfun fv res)) in kont c. (* Hack to let a Ltac return a term in the context of a primitive tactic *) Ltac return_term x := generalize (eq_refl x). Ltac get_term := match goal with | |- ?x = _ -> _ => x end. (* Turn an operation on field expressions (FExpr) into a reduction on terms (in the field carrier). Because of field_lookup, the tactic cannot return a term directly, so it is returned via the conclusion of the goal (return_term). *) Ltac reduce_field_ope ope c := gen_with_field ltac:(reduce_field_expr ope return_term) c. (* Adding a new field *) Ltac ring_of_field f := match type of f with | almost_field_theory _ _ _ _ _ _ _ _ _ => constr:(AF_AR f) | field_theory _ _ _ _ _ _ _ _ _ => constr:(F_R f) | semi_field_theory _ _ _ _ _ _ _ => constr:(SF_SR f) end. Ltac coerce_to_almost_field set ext f := match type of f with | almost_field_theory _ _ _ _ _ _ _ _ _ => f | field_theory _ _ _ _ _ _ _ _ _ => constr:(F2AF set ext f) | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f) end. Ltac field_elements set ext fspec pspec sspec dspec rk := let afth := coerce_to_almost_field set ext fspec in let rspec := ring_of_field fspec in ring_elements set ext rspec pspec sspec dspec rk ltac:(fun arth ext_r morph p_spec s_spec d_spec f => f afth ext_r morph p_spec s_spec d_spec). Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk := let get_lemma := match pspec with None => fun x y => x | _ => fun x y => y end in let simpl_eq_lemma := get_lemma Field_simplify_eq_correct Field_simplify_eq_pow_correct in let simpl_eq_in_lemma := get_lemma Field_simplify_eq_in_correct Field_simplify_eq_pow_in_correct in let rw_lemma := get_lemma Field_rw_correct Field_rw_pow_correct in field_elements set ext fspec pspec sspec dspec rk ltac:(fun afth ext_r morph p_spec s_spec d_spec => match morph with | _ => let field_ok1 := constr:(Field_correct set ext_r inv_m afth morph) in match p_spec with | mkhypo ?pp_spec => let field_ok2 := constr:(field_ok1 _ _ _ pp_spec) in match s_spec with | mkhypo ?ss_spec => let field_ok3 := constr:(field_ok2 _ ss_spec) in match d_spec with | mkhypo ?dd_spec => let field_ok := constr:(field_ok3 _ dd_spec) in let mk_lemma lemma := constr:(lemma _ _ _ _ _ _ _ _ _ _ set ext_r inv_m afth _ _ _ _ _ _ _ _ _ morph _ _ _ pp_spec _ ss_spec _ dd_spec) in let field_simpl_eq_ok := mk_lemma simpl_eq_lemma in let field_simpl_ok := mk_lemma rw_lemma in let field_simpl_eq_in := mk_lemma simpl_eq_in_lemma in let cond1_ok := constr:(Pcond_simpl_gen set ext_r afth morph pp_spec dd_spec) in let cond2_ok := constr:(Pcond_simpl_complete set ext_r afth morph pp_spec dd_spec) in (fun f => f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok field_simpl_eq_in cond1_ok cond2_ok) | _ => fail 4 "field: bad coefficiant division specification" end | _ => fail 3 "field: bad sign specification" end | _ => fail 2 "field: bad power specification" end | _ => fail 1 "field internal error : field_lemmas, please report" end). coq-8.4pl4/plugins/setoid_ring/RealField.v0000644000175000017500000000624712326224777017651 0ustar stephstephRequire Import Nnat. Require Import ArithRing. Require Export Ring Field. Require Import Rdefinitions. Require Import Rpow_def. Require Import Raxioms. Local Open Scope R_scope. Lemma RTheory : ring_theory 0 1 Rplus Rmult Rminus Ropp (eq (A:=R)). Proof. constructor. intro; apply Rplus_0_l. exact Rplus_comm. symmetry ; apply Rplus_assoc. intro; apply Rmult_1_l. exact Rmult_comm. symmetry ; apply Rmult_assoc. intros m n p. rewrite Rmult_comm. rewrite (Rmult_comm n p). rewrite (Rmult_comm m p). apply Rmult_plus_distr_l. reflexivity. exact Rplus_opp_r. Qed. Lemma Rfield : field_theory 0 1 Rplus Rmult Rminus Ropp Rdiv Rinv (eq(A:=R)). Proof. constructor. exact RTheory. exact R1_neq_R0. reflexivity. exact Rinv_l. Qed. Lemma Rlt_n_Sn : forall x, x < x + 1. Proof. intro. elim archimed with x; intros. destruct H0. apply Rlt_trans with (IZR (up x)); trivial. replace (IZR (up x)) with (x + (IZR (up x) - x))%R. apply Rplus_lt_compat_l; trivial. unfold Rminus. rewrite (Rplus_comm (IZR (up x)) (- x)). rewrite <- Rplus_assoc. rewrite Rplus_opp_r. apply Rplus_0_l. elim H0. unfold Rminus. rewrite (Rplus_comm (IZR (up x)) (- x)). rewrite <- Rplus_assoc. rewrite Rplus_opp_r. rewrite Rplus_0_l; trivial. Qed. Notation Rset := (Eqsth R). Notation Rext := (Eq_ext Rplus Rmult Ropp). Lemma Rlt_0_2 : 0 < 2. apply Rlt_trans with (0 + 1). apply Rlt_n_Sn. rewrite Rplus_comm. apply Rplus_lt_compat_l. replace 1 with (0 + 1). apply Rlt_n_Sn. apply Rplus_0_l. Qed. Lemma Rgen_phiPOS : forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x > 0. unfold Rgt. induction x; simpl; intros. apply Rlt_trans with (1 + 0). rewrite Rplus_comm. apply Rlt_n_Sn. apply Rplus_lt_compat_l. rewrite <- (Rmul_0_l Rset Rext RTheory 2). rewrite Rmult_comm. apply Rmult_lt_compat_l. apply Rlt_0_2. trivial. rewrite <- (Rmul_0_l Rset Rext RTheory 2). rewrite Rmult_comm. apply Rmult_lt_compat_l. apply Rlt_0_2. trivial. replace 1 with (0 + 1). apply Rlt_n_Sn. apply Rplus_0_l. Qed. Lemma Rgen_phiPOS_not_0 : forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x <> 0. red; intros. specialize (Rgen_phiPOS x). rewrite H; intro. apply (Rlt_asym 0 0); trivial. Qed. Lemma Zeq_bool_complete : forall x y, InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp x = InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp y -> Zeq_bool x y = true. Proof gen_phiZ_complete Rset Rext Rfield Rgen_phiPOS_not_0. Lemma Rdef_pow_add : forall (x:R) (n m:nat), pow x (n + m) = pow x n * pow x m. Proof. intros x n; elim n; simpl; auto with real. intros n0 H' m; rewrite H'; auto with real. Qed. Lemma R_power_theory : power_theory 1%R Rmult (@eq R) N.to_nat pow. Proof. constructor. destruct n. reflexivity. simpl. induction p. - rewrite Pos2Nat.inj_xI. simpl. now rewrite plus_0_r, Rdef_pow_add, IHp. - rewrite Pos2Nat.inj_xO. simpl. now rewrite plus_0_r, Rdef_pow_add, IHp. - simpl. rewrite Rmult_comm;apply Rmult_1_l. Qed. Ltac Rpow_tac t := match isnatcst t with | false => constr:(InitialRing.NotConstant) | _ => constr:(N.of_nat t) end. Add Field RField : Rfield (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]). coq-8.4pl4/plugins/setoid_ring/Ncring_polynom.v0000644000175000017500000004067212326224777021017 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* : non commutative polynomials on a commutative ring A *) Set Implicit Arguments. Require Import Setoid. Require Import BinList. Require Import BinPos. Require Import BinNat. Require Import BinInt. Require Export Ring_polynom. (* n'utilise que PExpr *) Require Export Ncring. Section MakeRingPol. Context (C R:Type) `{Rh:Ring_morphism C R}. Variable phiCR_comm: forall (c:C)(x:R), x * [c] == [c] * x. Ltac rsimpl := repeat (gen_rewrite || rewrite phiCR_comm). Ltac add_push := gen_add_push . (* Definition of non commutative multivariable polynomials with coefficients in C : *) Inductive Pol : Type := | Pc : C -> Pol | PX : Pol -> positive -> positive -> Pol -> Pol. (* PX P i n Q represents P * X_i^n + Q *) Definition cO:C . exact ring0. Defined. Definition cI:C . exact ring1. Defined. Definition P0 := Pc 0. Definition P1 := Pc 1. Variable Ceqb:C->C->bool. Class Equalityb (A : Type):= {equalityb : A -> A -> bool}. Notation "x =? y" := (equalityb x y) (at level 70, no associativity). Variable Ceqb_eq: forall x y:C, Ceqb x y = true -> (x == y). Instance equalityb_coef : Equalityb C := {equalityb x y := Ceqb x y}. Fixpoint Peq (P P' : Pol) {struct P'} : bool := match P, P' with | Pc c, Pc c' => c =? c' | PX P i n Q, PX P' i' n' Q' => match Pos.compare i i', Pos.compare n n' with | Eq, Eq => if Peq P P' then Peq Q Q' else false | _,_ => false end | _, _ => false end. Instance equalityb_pol : Equalityb Pol := {equalityb x y := Peq x y}. (* Q a ses variables de queue < i *) Definition mkPX P i n Q := match P with | Pc c => if c =? 0 then Q else PX P i n Q | PX P' i' n' Q' => match Pos.compare i i' with | Eq => if Q' =? P0 then PX P' i (n + n') Q else PX P i n Q | _ => PX P i n Q end end. Definition mkXi i n := PX P1 i n P0. Definition mkX i := mkXi i 1. (** Opposite of addition *) Fixpoint Popp (P:Pol) : Pol := match P with | Pc c => Pc (- c) | PX P i n Q => PX (Popp P) i n (Popp Q) end. Notation "-- P" := (Popp P)(at level 30). (** Addition et subtraction *) Fixpoint PaddCl (c:C)(P:Pol) {struct P} : Pol := match P with | Pc c1 => Pc (c + c1) | PX P i n Q => PX P i n (PaddCl c Q) end. (* Q quelconque *) Section PaddX. Variable Padd:Pol->Pol->Pol. Variable P:Pol. (* Xi^n * P + Q les variables de tete de Q ne sont pas forcement < i mais Q est normalisé : variables de tete decroissantes *) Fixpoint PaddX (i n:positive)(Q:Pol){struct Q}:= match Q with | Pc c => mkPX P i n Q | PX P' i' n' Q' => match Pos.compare i i' with | (* i > i' *) Gt => mkPX P i n Q | (* i < i' *) Lt => mkPX P' i' n' (PaddX i n Q') | (* i = i' *) Eq => match Z.pos_sub n n' with | (* n > n' *) Zpos k => mkPX (PaddX i k P') i' n' Q' | (* n = n' *) Z0 => mkPX (Padd P P') i n Q' | (* n < n' *) Zneg k => mkPX (Padd P (mkPX P' i k P0)) i n Q' end end end. End PaddX. Fixpoint Padd (P1 P2: Pol) {struct P1} : Pol := match P1 with | Pc c => PaddCl c P2 | PX P' i' n' Q' => PaddX Padd P' i' n' (Padd Q' P2) end. Notation "P ++ P'" := (Padd P P'). Definition Psub(P P':Pol):= P ++ (--P'). Notation "P -- P'" := (Psub P P')(at level 50). (** Multiplication *) Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol := match P with | Pc c' => Pc (c' * c) | PX P i n Q => mkPX (PmulC_aux P c) i n (PmulC_aux Q c) end. Definition PmulC P c := if c =? 0 then P0 else if c =? 1 then P else PmulC_aux P c. Fixpoint Pmul (P1 P2 : Pol) {struct P2} : Pol := match P2 with | Pc c => PmulC P1 c | PX P i n Q => PaddX Padd (Pmul P1 P) i n (Pmul P1 Q) end. Notation "P ** P'" := (Pmul P P')(at level 40). Definition Psquare (P:Pol) : Pol := P ** P. (** Evaluation of a polynomial towards R *) Fixpoint Pphi(l:list R) (P:Pol) {struct P} : R := match P with | Pc c => [c] | PX P i n Q => let x := nth 0 i l in let xn := pow_pos x n in (Pphi l P) * xn + (Pphi l Q) end. Reserved Notation "P @ l " (at level 10, no associativity). Notation "P @ l " := (Pphi l P). (** Proofs *) Ltac destr_pos_sub H := match goal with |- context [Z.pos_sub ?x ?y] => assert (H := Z.pos_sub_discr x y); destruct (Z.pos_sub x y) end. Lemma Peq_ok : forall P P', (P =? P') = true -> forall l, P@l == P'@ l. Proof. induction P;destruct P';simpl;intros ;try easy. - now apply ring_morphism_eq, Ceqb_eq. - specialize (IHP1 P'1). specialize (IHP2 P'2). simpl in IHP1, IHP2. destruct (Pos.compare_spec p p1); try discriminate; destruct (Pos.compare_spec p0 p2); try discriminate. destruct (Peq P2 P'1); try discriminate. subst; now rewrite IHP1, IHP2. Qed. Lemma Pphi0 : forall l, P0@l == 0. Proof. intros;simpl. rewrite ring_morphism0. reflexivity. Qed. Lemma Pphi1 : forall l, P1@l == 1. Proof. intros;simpl; rewrite ring_morphism1. reflexivity. Qed. Lemma mkPX_ok : forall l P i n Q, (mkPX P i n Q)@l == P@l * (pow_pos (nth 0 i l) n) + Q@l. Proof. intros l P i n Q;unfold mkPX. destruct P;try (simpl;reflexivity). assert (Hh := ring_morphism_eq c 0). simpl; case_eq (Ceqb c 0);simpl;try reflexivity. intros. rewrite Hh. rewrite ring_morphism0. rsimpl. apply Ceqb_eq. trivial. destruct (Pos.compare_spec i p). assert (Hh := @Peq_ok P3 P0). case_eq (P3=? P0). intro. simpl. rewrite Hh. rewrite Pphi0. rsimpl. rewrite Pos.add_comm. rewrite pow_pos_add;rsimpl. subst;trivial. reflexivity. trivial. intros. simpl. reflexivity. simpl. reflexivity. simpl. reflexivity. Qed. Ltac Esimpl := repeat (progress ( match goal with | |- context [?P@?l] => match P with | P0 => rewrite (Pphi0 l) | P1 => rewrite (Pphi1 l) | (mkPX ?P ?i ?n ?Q) => rewrite (mkPX_ok l P i n Q) end | |- context [[?c]] => match c with | 0 => rewrite ring_morphism0 | 1 => rewrite ring_morphism1 | ?x + ?y => rewrite ring_morphism_add | ?x * ?y => rewrite ring_morphism_mul | ?x - ?y => rewrite ring_morphism_sub | - ?x => rewrite ring_morphism_opp end end)); simpl; rsimpl. Lemma PaddCl_ok : forall c P l, (PaddCl c P)@l == [c] + P@l . Proof. induction P; simpl; intros; Esimpl; try reflexivity. rewrite IHP2. rsimpl. rewrite (ring_add_comm (P2 @ l * pow_pos (nth 0 p l) p0) [c]). reflexivity. Qed. Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c]. Proof. induction P;simpl;intros. rewrite ring_morphism_mul. try reflexivity. simpl. Esimpl. rewrite IHP1;rewrite IHP2;rsimpl. Qed. Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c]. Proof. intros c P l; unfold PmulC. assert (Hh:= ring_morphism_eq c 0);case_eq (c =? 0). intros. rewrite Hh;Esimpl. apply Ceqb_eq;trivial. assert (H1h:= ring_morphism_eq c 1);case_eq (c =? 1);intros. rewrite H1h;Esimpl. apply Ceqb_eq;trivial. apply PmulC_aux_ok. Qed. Lemma Popp_ok : forall P l, (--P)@l == - P@l. Proof. induction P;simpl;intros. Esimpl. rewrite IHP1;rewrite IHP2;rsimpl. Qed. Ltac Esimpl2 := Esimpl; repeat (progress ( match goal with | |- context [(PaddCl ?c ?P)@?l] => rewrite (PaddCl_ok c P l) | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l) | |- context [(--?P)@?l] => rewrite (Popp_ok P l) end)); Esimpl. Lemma PaddXPX: forall P i n Q, PaddX Padd P i n Q = match Q with | Pc c => mkPX P i n Q | PX P' i' n' Q' => match Pos.compare i i' with | (* i > i' *) Gt => mkPX P i n Q | (* i < i' *) Lt => mkPX P' i' n' (PaddX Padd P i n Q') | (* i = i' *) Eq => match Z.pos_sub n n' with | (* n > n' *) Zpos k => mkPX (PaddX Padd P i k P') i' n' Q' | (* n = n' *) Z0 => mkPX (Padd P P') i n Q' | (* n < n' *) Zneg k => mkPX (Padd P (mkPX P' i k P0)) i n Q' end end end. induction Q; reflexivity. Qed. Lemma PaddX_ok2 : forall P2, (forall P l, (P2 ++ P) @ l == P2 @ l + P @ l) /\ (forall P k n l, (PaddX Padd P2 k n P) @ l == P2 @ l * pow_pos (nth 0 k l) n + P @ l). induction P2;simpl;intros. split. intros. apply PaddCl_ok. induction P. unfold PaddX. intros. rewrite mkPX_ok. simpl. rsimpl. intros. simpl. destruct (Pos.compare_spec k p) as [Hh|Hh|Hh]. destr_pos_sub H1h. Esimpl2. rewrite Hh; trivial. rewrite H1h. reflexivity. simpl. rewrite mkPX_ok. rewrite IHP1. Esimpl2. rewrite Pos.add_comm in H1h. rewrite H1h. rewrite pow_pos_add. Esimpl2. rewrite Hh; trivial. reflexivity. rewrite mkPX_ok. rewrite PaddCl_ok. Esimpl2. rewrite Pos.add_comm in H1h. rewrite H1h. Esimpl2. rewrite pow_pos_add. Esimpl2. rewrite Hh; trivial. reflexivity. rewrite mkPX_ok. rewrite IHP2. Esimpl2. rewrite (ring_add_comm (P2 @ l * pow_pos (nth 0 p l) p0) ([c] * pow_pos (nth 0 k l) n)). reflexivity. assert (H1h := ring_morphism_eq c 0);case_eq (Ceqb c 0); intros; simpl. rewrite H1h;trivial. Esimpl2. apply Ceqb_eq; trivial. reflexivity. decompose [and] IHP2_1. decompose [and] IHP2_2. clear IHP2_1 IHP2_2. split. intros. rewrite H0. rewrite H1. Esimpl2. induction P. unfold PaddX. intros. rewrite mkPX_ok. simpl. reflexivity. intros. rewrite PaddXPX. destruct (Pos.compare_spec k p1) as [H3h|H3h|H3h]. destr_pos_sub H4h. rewrite mkPX_ok. simpl. rewrite H0. rewrite H1. Esimpl2. rewrite H4h. rewrite H3h;trivial. reflexivity. rewrite mkPX_ok. rewrite IHP1. Esimpl2. rewrite H3h;trivial. rewrite Pos.add_comm in H4h. rewrite H4h. rewrite pow_pos_add. Esimpl2. rewrite mkPX_ok. simpl. rewrite H0. rewrite H1. rewrite mkPX_ok. Esimpl2. rewrite H3h;trivial. rewrite Pos.add_comm in H4h. rewrite H4h. rewrite pow_pos_add. Esimpl2. rewrite mkPX_ok. simpl. rewrite IHP2. Esimpl2. gen_add_push (P2 @ l * pow_pos (nth 0 p1 l) p2). try reflexivity. rewrite mkPX_ok. simpl. reflexivity. Qed. Lemma Padd_ok : forall P Q l, (P ++ Q) @ l == P @ l + Q @ l. intro P. elim (PaddX_ok2 P); auto. Qed. Lemma PaddX_ok : forall P2 P k n l, (PaddX Padd P2 k n P) @ l == P2 @ l * pow_pos (nth 0 k l) n + P @ l. intro P2. elim (PaddX_ok2 P2); auto. Qed. Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l. unfold Psub. intros. rewrite Padd_ok. rewrite Popp_ok. rsimpl. Qed. Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. induction P'; simpl; intros. rewrite PmulC_ok. reflexivity. rewrite PaddX_ok. rewrite IHP'1. rewrite IHP'2. Esimpl2. Qed. Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l. Proof. intros. unfold Psquare. apply Pmul_ok. Qed. (** Definition of polynomial expressions *) (* Inductive PExpr : Type := | PEc : C -> PExpr | PEX : positive -> PExpr | PEadd : PExpr -> PExpr -> PExpr | PEsub : PExpr -> PExpr -> PExpr | PEmul : PExpr -> PExpr -> PExpr | PEopp : PExpr -> PExpr | PEpow : PExpr -> N -> PExpr. *) (** Specification of the power function *) Section POWER. Variable Cpow : Set. Variable Cp_phi : N -> Cpow. Variable rpow : R -> Cpow -> R. Record power_theory : Prop := mkpow_th { rpow_pow_N : forall r n, (rpow r (Cp_phi n))== (pow_N r n) }. End POWER. Variable Cpow : Set. Variable Cp_phi : N -> Cpow. Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory Cp_phi rpow. (** evaluation of polynomial expressions towards R *) Fixpoint PEeval (l:list R) (pe:PExpr C) {struct pe} : R := match pe with | PEc c => [c] | PEX j => nth 0 j l | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) | PEopp pe1 => - (PEeval l pe1) | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) end. Strategy expand [PEeval]. Definition mk_X j := mkX j. (** Correctness proofs *) Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l. Proof. destruct p;simpl;intros;Esimpl;trivial. Qed. Ltac Esimpl3 := repeat match goal with | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P1 P2 l) | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P1 P2 l) end;try Esimpl2;try reflexivity;try apply ring_add_comm. (* Power using the chinise algorithm *) Section POWER2. Variable subst_l : Pol -> Pol. Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol := match p with | xH => subst_l (Pmul P res) | xO p => Ppow_pos (Ppow_pos res P p) P p | xI p => subst_l (Pmul P (Ppow_pos (Ppow_pos res P p) P p)) end. Definition Ppow_N P n := match n with | N0 => P1 | Npos p => Ppow_pos P1 P p end. Fixpoint pow_pos_gen (R:Type)(m:R->R->R)(x:R) (i:positive) {struct i}: R := match i with | xH => x | xO i => let p := pow_pos_gen m x i in m p p | xI i => let p := pow_pos_gen m x i in m x (m p p) end. Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> forall res P p, (Ppow_pos res P p)@l == (pow_pos_gen Pmul P p)@l * res@l. Proof. intros l subst_l_ok res P p. generalize res;clear res. induction p;simpl;intros. try rewrite subst_l_ok. repeat rewrite Pmul_ok. repeat rewrite IHp. rsimpl. repeat rewrite Pmul_ok. repeat rewrite IHp. rsimpl. try rewrite subst_l_ok. repeat rewrite Pmul_ok. reflexivity. Qed. Definition pow_N_gen (R:Type)(x1:R)(m:R->R->R)(x:R) (p:N) := match p with | N0 => x1 | Npos p => pow_pos_gen m x p end. Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> forall P n, (Ppow_N P n)@l == (pow_N_gen P1 Pmul P n)@l. Proof. destruct n;simpl. reflexivity. rewrite Ppow_pos_ok; trivial. Esimpl. Qed. End POWER2. (** Normalization and rewriting *) Section NORM_SUBST_REC. Let subst_l (P:Pol) := P. Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2). Let Ppow_subst := Ppow_N subst_l. Fixpoint norm_aux (pe:PExpr C) : Pol := match pe with | PEc c => Pc c | PEX j => mk_X j | PEadd pe1 (PEopp pe2) => Psub (norm_aux pe1) (norm_aux pe2) | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2) | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2) | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) | PEopp pe1 => Popp (norm_aux pe1) | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n end. Definition norm_subst pe := subst_l (norm_aux pe). Lemma norm_aux_spec : forall l pe, PEeval l pe == (norm_aux pe)@l. Proof. intros. induction pe. Esimpl3. Esimpl3. simpl. rewrite IHpe1;rewrite IHpe2. destruct pe2; Esimpl3. unfold Psub. destruct pe1; destruct pe2; rewrite Padd_ok; rewrite Popp_ok; reflexivity. simpl. unfold Psub. rewrite IHpe1;rewrite IHpe2. destruct pe1. destruct pe2; rewrite Padd_ok; rewrite Popp_ok; try reflexivity. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. simpl. rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. reflexivity. simpl. rewrite IHpe; Esimpl3. simpl. rewrite Ppow_N_ok; (intros;try reflexivity). rewrite rpow_pow_N. Esimpl3. induction n;simpl. Esimpl3. induction p; simpl. try rewrite IHp;try rewrite IHpe; repeat rewrite Pms_ok; repeat rewrite Pmul_ok;reflexivity. rewrite Pmul_ok. try rewrite IHp;try rewrite IHpe; repeat rewrite Pms_ok; repeat rewrite Pmul_ok;reflexivity. trivial. exact pow_th. Qed. Lemma norm_subst_spec : forall l pe, PEeval l pe == (norm_subst pe)@l. Proof. intros;unfold norm_subst. unfold subst_l. apply norm_aux_spec. Qed. End NORM_SUBST_REC. Fixpoint interp_PElist (l:list R) (lpe:list (PExpr C * PExpr C)) {struct lpe} : Prop := match lpe with | nil => True | (me,pe)::lpe => match lpe with | nil => PEeval l me == PEeval l pe | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe end end. Lemma norm_subst_ok : forall l pe, PEeval l pe == (norm_subst pe)@l. Proof. intros;apply norm_subst_spec. Qed. Lemma ring_correct : forall l pe1 pe2, (norm_subst pe1 =? norm_subst pe2) = true -> PEeval l pe1 == PEeval l pe2. Proof. simpl;intros. do 2 (rewrite (norm_subst_ok l);trivial). apply Peq_ok;trivial. Qed. End MakeRingPol. coq-8.4pl4/plugins/setoid_ring/Integral_domain.v0000644000175000017500000000243012326224777021104 0ustar stephstephRequire Export Cring. (* Definition of integral domains: commutative ring without zero divisor *) Class Integral_domain {R : Type}`{Rcr:Cring R} := { integral_domain_product: forall x y, x * y == 0 -> x == 0 \/ y == 0; integral_domain_one_zero: not (1 == 0)}. Section integral_domain. Context {R:Type}`{Rid:Integral_domain R}. Lemma integral_domain_minus_one_zero: ~ - (1:R) == 0. red;intro. apply integral_domain_one_zero. assert (0 == - (0:R)). cring. rewrite H0. rewrite <- H. cring. Qed. Definition pow (r : R) (n : nat) := Ring_theory.pow_N 1 mul r (N.of_nat n). Lemma pow_not_zero: forall p n, pow p n == 0 -> p == 0. induction n. unfold pow; simpl. intros. absurd (1 == 0). simpl. apply integral_domain_one_zero. trivial. setoid_replace (pow p (S n)) with (p * (pow p n)). intros. case (integral_domain_product p (pow p n) H). trivial. trivial. unfold pow; simpl. clear IHn. induction n; simpl; try cring. rewrite Ring_theory.pow_pos_succ. cring. apply ring_setoid. apply ring_mult_comp. apply ring_mul_assoc. Qed. Lemma Rintegral_domain_pow: forall c p r, ~c == 0 -> c * (pow p r) == ring0 -> p == ring0. intros. case (integral_domain_product c (pow p r) H0). intros; absurd (c == ring0); auto. intros. apply pow_not_zero with r. trivial. Qed. End integral_domain. coq-8.4pl4/plugins/setoid_ring/Algebra_syntax.v0000644000175000017500000000163412326224777020760 0ustar stephsteph Class Zero (A : Type) := zero : A. Notation "0" := zero. Class One (A : Type) := one : A. Notation "1" := one. Class Addition (A : Type) := addition : A -> A -> A. Notation "_+_" := addition. Notation "x + y" := (addition x y). Class Multiplication {A B : Type} := multiplication : A -> B -> B. Notation "_*_" := multiplication. Notation "x * y" := (multiplication x y). Class Subtraction (A : Type) := subtraction : A -> A -> A. Notation "_-_" := subtraction. Notation "x - y" := (subtraction x y). Class Opposite (A : Type) := opposite : A -> A. Notation "-_" := opposite. Notation "- x" := (opposite(x)). Class Equality {A : Type}:= equality : A -> A -> Prop. Notation "_==_" := equality. Notation "x == y" := (equality x y) (at level 70, no associativity). Class Bracket (A B: Type):= bracket : A -> B. Notation "[ x ]" := (bracket(x)). Class Power {A B: Type} := power : A -> B -> A. Notation "x ^ y" := (power x y). coq-8.4pl4/plugins/setoid_ring/newring_plugin.mllib0000644000175000017500000000003312326224777021666 0ustar stephstephNewring Newring_plugin_mod coq-8.4pl4/plugins/setoid_ring/ZArithRing.v0000644000175000017500000000276612326224777020045 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t | _ => constr:NotConstant end. Ltac isZpow_coef t := match t with | Zpos ?p => isPcst p | Z0 => constr:true | _ => constr:false end. Notation N_of_Z := Z.to_N (only parsing). Ltac Zpow_tac t := match isZpow_coef t with | true => constr:(N_of_Z t) | _ => constr:NotConstant end. Ltac Zpower_neg := repeat match goal with | [|- ?G] => match G with | context c [Z.pow _ (Zneg _)] => let t := context c [Z0] in change t end end. Add Ring Zr : Zth (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Z.succ], power_tac Zpower_theory [Zpow_tac], (* The two following option are not needed, it is the default chose when the set of coefficiant is usual ring Z *) div (InitialRing.Ztriv_div_th (@Eqsth Z) (@IDphi Z)), sign get_signZ_th). coq-8.4pl4/plugins/setoid_ring/Ring_equiv.v0000644000175000017500000000314312326224777020122 0ustar stephstephRequire Import Setoid_ring_theory. Require Import LegacyRing_theory. Require Import Ring_theory. Set Implicit Arguments. Section Old2New. Variable A : Type. Variable Aplus : A -> A -> A. Variable Amult : A -> A -> A. Variable Aone : A. Variable Azero : A. Variable Aopp : A -> A. Variable Aeq : A -> A -> bool. Variable R : Ring_Theory Aplus Amult Aone Azero Aopp Aeq. Let Aminus := fun x y => Aplus x (Aopp y). Lemma ring_equiv1 : ring_theory Azero Aone Aplus Amult Aminus Aopp (eq (A:=A)). Proof. destruct R. split; eauto. Qed. End Old2New. Section New2OldRing. Variable R : Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable Rth : ring_theory rO rI radd rmul rsub ropp (eq (A:=R)). Variable reqb : R -> R -> bool. Variable reqb_ok : forall x y, reqb x y = true -> x = y. Lemma ring_equiv2 : Ring_Theory radd rmul rI rO ropp reqb. Proof. elim Rth; intros; constructor; eauto. intros. apply reqb_ok. destruct (reqb x y); trivial; intros. elim H. Qed. Definition default_eqb : R -> R -> bool := fun x y => false. Lemma default_eqb_ok : forall x y, default_eqb x y = true -> x = y. Proof. discriminate 1. Qed. End New2OldRing. Section New2OldSemiRing. Variable R : Type. Variable (rO rI : R) (radd rmul: R->R->R). Variable SRth : semi_ring_theory rO rI radd rmul (eq (A:=R)). Variable reqb : R -> R -> bool. Variable reqb_ok : forall x y, reqb x y = true -> x = y. Lemma sring_equiv2 : Semi_Ring_Theory radd rmul rI rO reqb. Proof. elim SRth; intros; constructor; eauto. intros. apply reqb_ok. destruct (reqb x y); trivial; intros. elim H. Qed. End New2OldSemiRing. coq-8.4pl4/plugins/setoid_ring/Field.v0000644000175000017500000000110512326224777017031 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr:(N.of_nat t) | _ => constr:InitialRing.NotConstant end. Ltac Ss_to_add f acc := match f with | S ?f1 => Ss_to_add f1 (S acc) | _ => constr:(acc + f)%nat end. Ltac natprering := match goal with |- context C [S ?p] => match p with O => fail 1 (* avoid replacing 1 with 1+0 ! *) | p => match isnatcst p with | true => fail 1 | false => let v := Ss_to_add p (S 0) in fold v; natprering end end | _ => idtac end. Add Ring natr : natSRth (morphism nat_morph_N, constants [natcst], preprocess [natprering]). coq-8.4pl4/plugins/setoid_ring/Ncring_initial.v0000644000175000017500000001376112326224777020752 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 1 | xO p => (1 + 1) * (gen_phiPOS1 p) | xI p => 1 + ((1 + 1) * (gen_phiPOS1 p)) end. Fixpoint gen_phiPOS (p:positive) : R := match p with | xH => 1 | xO xH => (1 + 1) | xO p => (1 + 1) * (gen_phiPOS p) | xI xH => 1 + (1 +1) | xI p => 1 + ((1 + 1) * (gen_phiPOS p)) end. Definition gen_phiZ1 z := match z with | Zpos p => gen_phiPOS1 p | Z0 => 0 | Zneg p => -(gen_phiPOS1 p) end. Definition gen_phiZ z := match z with | Zpos p => gen_phiPOS p | Z0 => 0 | Zneg p => -(gen_phiPOS p) end. Notation "[ x ]" := (gen_phiZ x). Definition get_signZ z := match z with | Zneg p => Some (Zpos p) | _ => None end. Ltac norm := gen_rewrite. Ltac add_push := Ncring.gen_add_push. Ltac rsimpl := simpl. Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x. Proof. induction x;rsimpl. rewrite IHx. destruct x;simpl;norm. rewrite IHx;destruct x;simpl;norm. reflexivity. Qed. Lemma ARgen_phiPOS_Psucc : forall x, gen_phiPOS1 (Pos.succ x) == 1 + (gen_phiPOS1 x). Proof. induction x;rsimpl;norm. rewrite IHx. gen_rewrite. add_push 1. reflexivity. Qed. Lemma ARgen_phiPOS_add : forall x y, gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y). Proof. induction x;destruct y;simpl;norm. rewrite Pos.add_carry_spec. rewrite ARgen_phiPOS_Psucc. rewrite IHx;norm. add_push (gen_phiPOS1 y);add_push 1;reflexivity. rewrite IHx;norm;add_push (gen_phiPOS1 y);reflexivity. rewrite ARgen_phiPOS_Psucc;norm;add_push 1;reflexivity. rewrite IHx;norm;add_push(gen_phiPOS1 y); add_push 1;reflexivity. rewrite IHx;norm;add_push(gen_phiPOS1 y);reflexivity. add_push 1;reflexivity. rewrite ARgen_phiPOS_Psucc;norm;add_push 1;reflexivity. Qed. Lemma ARgen_phiPOS_mult : forall x y, gen_phiPOS1 (x * y) == gen_phiPOS1 x * gen_phiPOS1 y. Proof. induction x;intros;simpl;norm. rewrite ARgen_phiPOS_add;simpl;rewrite IHx;norm. rewrite IHx;reflexivity. Qed. (*morphisms are extensionaly equal*) Lemma same_genZ : forall x, [x] == gen_phiZ1 x. Proof. destruct x;rsimpl; try rewrite same_gen; reflexivity. Qed. Lemma gen_Zeqb_ok : forall x y, Zeq_bool x y = true -> [x] == [y]. Proof. intros x y H7. assert (H10 := Zeq_bool_eq x y H7);unfold IDphi in H10. rewrite H10;reflexivity. Qed. Lemma gen_phiZ1_add_pos_neg : forall x y, gen_phiZ1 (Z.pos_sub x y) == gen_phiPOS1 x + -gen_phiPOS1 y. Proof. intros x y. generalize (Z.pos_sub_discr x y). destruct (Z.pos_sub x y) as [|p|p]; intros; subst. - now rewrite ring_opp_def. - rewrite ARgen_phiPOS_add;simpl;norm. add_push (gen_phiPOS1 p). rewrite ring_opp_def;norm. - rewrite ARgen_phiPOS_add;simpl;norm. rewrite ring_opp_def;norm. Qed. Lemma match_compOpp : forall x (B:Type) (be bl bg:B), match CompOpp x with Eq => be | Lt => bl | Gt => bg end = match x with Eq => be | Lt => bg | Gt => bl end. Proof. destruct x;simpl;intros;trivial. Qed. Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y]. Proof. intros x y; repeat rewrite same_genZ; generalize x y;clear x y. induction x;destruct y;simpl;norm. apply ARgen_phiPOS_add. apply gen_phiZ1_add_pos_neg. rewrite gen_phiZ1_add_pos_neg. rewrite ring_add_comm. reflexivity. rewrite ARgen_phiPOS_add. rewrite ring_opp_add. reflexivity. Qed. Lemma gen_phiZ_opp : forall x, [- x] == - [x]. Proof. intros x. repeat rewrite same_genZ. generalize x ;clear x. induction x;simpl;norm. rewrite ring_opp_opp. reflexivity. Qed. Lemma gen_phiZ_mul : forall x y, [x * y] == [x] * [y]. Proof. intros x y;repeat rewrite same_genZ. destruct x;destruct y;simpl;norm; rewrite ARgen_phiPOS_mult;try (norm;fail). rewrite ring_opp_opp ;reflexivity. Qed. Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y]. Proof. intros;subst;reflexivity. Qed. (*proof that [.] satisfies morphism specifications*) Global Instance gen_phiZ_morph : (@Ring_morphism (Z:Type) R _ _ _ _ _ _ _ Zops Zr _ _ _ _ _ _ _ _ _ gen_phiZ) . (* beurk!*) apply Build_Ring_morphism; simpl;try reflexivity. apply gen_phiZ_add. intros. rewrite ring_sub_def. replace (x-y)%Z with (x + (-y))%Z. now rewrite gen_phiZ_add, gen_phiZ_opp, ring_sub_def. reflexivity. apply gen_phiZ_mul. apply gen_phiZ_opp. apply gen_phiZ_ext. Defined. End ZMORPHISM. Instance multiplication_phi_ring{R:Type}`{Ring R} : Multiplication := {multiplication x y := (gen_phiZ x) * y}. coq-8.4pl4/plugins/setoid_ring/Ring_theory.v0000644000175000017500000004372312326224777020313 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R -> R. Variable req : R -> R -> Prop. Variable Rsth : Equivalence req. Infix "*" := rmul. Infix "==" := req. Hypothesis mul_ext : Proper (req ==> req ==> req) rmul. Hypothesis mul_assoc : forall x y z, x * (y * z) == (x * y) * z. Fixpoint pow_pos (x:R) (i:positive) : R := match i with | xH => x | xO i => let p := pow_pos x i in p * p | xI i => let p := pow_pos x i in x * (p * p) end. Lemma pow_pos_swap x j : pow_pos x j * x == x * pow_pos x j. Proof. induction j; simpl; rewrite <- ?mul_assoc. - f_equiv. now do 2 (rewrite IHj, mul_assoc). - now do 2 (rewrite IHj, mul_assoc). - reflexivity. Qed. Lemma pow_pos_succ x j : pow_pos x (Pos.succ j) == x * pow_pos x j. Proof. induction j; simpl; try reflexivity. rewrite IHj, <- mul_assoc; f_equiv. now rewrite mul_assoc, pow_pos_swap, mul_assoc. Qed. Lemma pow_pos_add x i j : pow_pos x (i + j) == pow_pos x i * pow_pos x j. Proof. induction i using Pos.peano_ind. - now rewrite Pos.add_1_l, pow_pos_succ. - now rewrite Pos.add_succ_l, !pow_pos_succ, IHi, mul_assoc. Qed. Definition pow_N (x:R) (p:N) := match p with | N0 => rI | Npos p => pow_pos x p end. Definition id_phi_N (x:N) : N := x. Lemma pow_N_pow_N x n : pow_N x (id_phi_N n) == pow_N x n. Proof. reflexivity. Qed. End Power. Section DEFINITIONS. Variable R : Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable req : R -> R -> Prop. Notation "0" := rO. Notation "1" := rI. Infix "==" := req. Infix "+" := radd. Infix "*" := rmul. Infix "-" := rsub. Notation "- x" := (ropp x). (** Semi Ring *) Record semi_ring_theory : Prop := mk_srt { SRadd_0_l : forall n, 0 + n == n; SRadd_comm : forall n m, n + m == m + n ; SRadd_assoc : forall n m p, n + (m + p) == (n + m) + p; SRmul_1_l : forall n, 1*n == n; SRmul_0_l : forall n, 0*n == 0; SRmul_comm : forall n m, n*m == m*n; SRmul_assoc : forall n m p, n*(m*p) == (n*m)*p; SRdistr_l : forall n m p, (n + m)*p == n*p + m*p }. (** Almost Ring *) (*Almost ring are no ring : Ropp_def is missing **) Record almost_ring_theory : Prop := mk_art { ARadd_0_l : forall x, 0 + x == x; ARadd_comm : forall x y, x + y == y + x; ARadd_assoc : forall x y z, x + (y + z) == (x + y) + z; ARmul_1_l : forall x, 1 * x == x; ARmul_0_l : forall x, 0 * x == 0; ARmul_comm : forall x y, x * y == y * x; ARmul_assoc : forall x y z, x * (y * z) == (x * y) * z; ARdistr_l : forall x y z, (x + y) * z == (x * z) + (y * z); ARopp_mul_l : forall x y, -(x * y) == -x * y; ARopp_add : forall x y, -(x + y) == -x + -y; ARsub_def : forall x y, x - y == x + -y }. (** Ring *) Record ring_theory : Prop := mk_rt { Radd_0_l : forall x, 0 + x == x; Radd_comm : forall x y, x + y == y + x; Radd_assoc : forall x y z, x + (y + z) == (x + y) + z; Rmul_1_l : forall x, 1 * x == x; Rmul_comm : forall x y, x * y == y * x; Rmul_assoc : forall x y z, x * (y * z) == (x * y) * z; Rdistr_l : forall x y z, (x + y) * z == (x * z) + (y * z); Rsub_def : forall x y, x - y == x + -y; Ropp_def : forall x, x + (- x) == 0 }. (** Equality is extensional *) Record sring_eq_ext : Prop := mk_seqe { (* SRing operators are compatible with equality *) SRadd_ext : Proper (req ==> req ==> req) radd; SRmul_ext : Proper (req ==> req ==> req) rmul }. Record ring_eq_ext : Prop := mk_reqe { (* Ring operators are compatible with equality *) Radd_ext : Proper (req ==> req ==> req) radd; Rmul_ext : Proper (req ==> req ==> req) rmul; Ropp_ext : Proper (req ==> req) ropp }. (** Interpretation morphisms definition*) Section MORPHISM. Variable C:Type. Variable (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C). Variable ceqb : C->C->bool. (* [phi] est un morphisme de [C] dans [R] *) Variable phi : C -> R. Infix "+!" := cadd. Infix "-!" := csub. Infix "*!" := cmul. Notation "-! x" := (copp x). Infix "?=!" := ceqb. Notation "[ x ]" := (phi x). (*for semi rings*) Record semi_morph : Prop := mkRmorph { Smorph0 : [cO] == 0; Smorph1 : [cI] == 1; Smorph_add : forall x y, [x +! y] == [x]+[y]; Smorph_mul : forall x y, [x *! y] == [x]*[y]; Smorph_eq : forall x y, x?=!y = true -> [x] == [y] }. (* for rings*) Record ring_morph : Prop := mkmorph { morph0 : [cO] == 0; morph1 : [cI] == 1; morph_add : forall x y, [x +! y] == [x]+[y]; morph_sub : forall x y, [x -! y] == [x]-[y]; morph_mul : forall x y, [x *! y] == [x]*[y]; morph_opp : forall x, [-!x] == -[x]; morph_eq : forall x y, x?=!y = true -> [x] == [y] }. Section SIGN. Variable get_sign : C -> option C. Record sign_theory : Prop := mksign_th { sign_spec : forall c c', get_sign c = Some c' -> c ?=! -! c' = true }. End SIGN. Definition get_sign_None (c:C) := @None C. Lemma get_sign_None_th : sign_theory get_sign_None. Proof. constructor;intros;discriminate. Qed. Section DIV. Variable cdiv: C -> C -> C*C. Record div_theory : Prop := mkdiv_th { div_eucl_th : forall a b, let (q,r) := cdiv a b in [a] == [b *! q +! r] }. End DIV. End MORPHISM. (** Identity is a morphism *) Variable Rsth : Equivalence req. Variable reqb : R->R->bool. Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y. Definition IDphi (x:R) := x. Lemma IDmorph : ring_morph rO rI radd rmul rsub ropp reqb IDphi. Proof. now apply (mkmorph rO rI radd rmul rsub ropp reqb IDphi). Qed. (** Specification of the power function *) Section POWER. Variable Cpow : Type. Variable Cp_phi : N -> Cpow. Variable rpow : R -> Cpow -> R. Record power_theory : Prop := mkpow_th { rpow_pow_N : forall r n, req (rpow r (Cp_phi n)) (pow_N rI rmul r n) }. End POWER. Definition pow_N_th := mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth). End DEFINITIONS. Section ALMOST_RING. Variable R : Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable req : R -> R -> Prop. Notation "0" := rO. Notation "1" := rI. Infix "==" := req. Infix "+" := radd. Infix "* " := rmul. Infix "-" := rsub. Notation "- x" := (ropp x). (** Leibniz equality leads to a setoid theory and is extensional*) Lemma Eqsth : Equivalence (@eq R). Proof. exact eq_equivalence. Qed. Lemma Eq_s_ext : sring_eq_ext radd rmul (@eq R). Proof. constructor;solve_proper. Qed. Lemma Eq_ext : ring_eq_ext radd rmul ropp (@eq R). Proof. constructor;solve_proper. Qed. Variable Rsth : Equivalence req. Section SEMI_RING. Variable SReqe : sring_eq_ext radd rmul req. Add Morphism radd : radd_ext1. exact (SRadd_ext SReqe). Qed. Add Morphism rmul : rmul_ext1. exact (SRmul_ext SReqe). Qed. Variable SRth : semi_ring_theory 0 1 radd rmul req. (** Every semi ring can be seen as an almost ring, by taking : -x = x and x - y = x + y *) Definition SRopp (x:R) := x. Notation "- x" := (SRopp x). Definition SRsub x y := x + -y. Notation "x - y " := (SRsub x y). Lemma SRopp_ext : forall x y, x == y -> -x == -y. Proof. intros x y H; exact H. Qed. Lemma SReqe_Reqe : ring_eq_ext radd rmul SRopp req. Proof. constructor. - exact (SRadd_ext SReqe). - exact (SRmul_ext SReqe). - exact SRopp_ext. Qed. Lemma SRopp_mul_l : forall x y, -(x * y) == -x * y. Proof. reflexivity. Qed. Lemma SRopp_add : forall x y, -(x + y) == -x + -y. Proof. reflexivity. Qed. Lemma SRsub_def : forall x y, x - y == x + -y. Proof. reflexivity. Qed. Lemma SRth_ARth : almost_ring_theory 0 1 radd rmul SRsub SRopp req. Proof (mk_art 0 1 radd rmul SRsub SRopp req (SRadd_0_l SRth) (SRadd_comm SRth) (SRadd_assoc SRth) (SRmul_1_l SRth) (SRmul_0_l SRth) (SRmul_comm SRth) (SRmul_assoc SRth) (SRdistr_l SRth) SRopp_mul_l SRopp_add SRsub_def). (** Identity morphism for semi-ring equipped with their almost-ring structure*) Variable reqb : R->R->bool. Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y. Definition SRIDmorph : ring_morph 0 1 radd rmul SRsub SRopp req 0 1 radd rmul SRsub SRopp reqb (@IDphi R). Proof. now apply mkmorph. Qed. (* a semi_morph can be extended to a ring_morph for the almost_ring derived from a semi_ring, provided the ring is a setoid (we only need reflexivity) *) Variable C : Type. Variable (cO cI : C) (cadd cmul: C->C->C). Variable (ceqb : C -> C -> bool). Variable phi : C -> R. Variable Smorph : semi_morph rO rI radd rmul req cO cI cadd cmul ceqb phi. Lemma SRmorph_Rmorph : ring_morph rO rI radd rmul SRsub SRopp req cO cI cadd cmul cadd (fun x => x) ceqb phi. Proof. case Smorph; now constructor. Qed. End SEMI_RING. Variable Reqe : ring_eq_ext radd rmul ropp req. Add Morphism radd : radd_ext2. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext2. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext2. exact (Ropp_ext Reqe). Qed. Section RING. Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. (** Rings are almost rings*) Lemma Rmul_0_l x : 0 * x == 0. Proof. setoid_replace (0*x) with ((0+1)*x + -x). now rewrite (Radd_0_l Rth), (Rmul_1_l Rth), (Ropp_def Rth). rewrite (Rdistr_l Rth), (Rmul_1_l Rth). rewrite <- (Radd_assoc Rth), (Ropp_def Rth). now rewrite (Radd_comm Rth), (Radd_0_l Rth). Qed. Lemma Ropp_mul_l x y : -(x * y) == -x * y. Proof. rewrite <-(Radd_0_l Rth (- x * y)). rewrite (Radd_comm Rth), <-(Ropp_def Rth (x*y)). rewrite (Radd_assoc Rth), <- (Rdistr_l Rth). rewrite (Rth.(Radd_comm) (-x)), (Ropp_def Rth). now rewrite Rmul_0_l, (Radd_0_l Rth). Qed. Lemma Ropp_add x y : -(x + y) == -x + -y. Proof. rewrite <- ((Radd_0_l Rth) (-(x+y))). rewrite <- ((Ropp_def Rth) x). rewrite <- ((Radd_0_l Rth) (x + - x + - (x + y))). rewrite <- ((Ropp_def Rth) y). rewrite ((Radd_comm Rth) x). rewrite ((Radd_comm Rth) y). rewrite <- ((Radd_assoc Rth) (-y)). rewrite <- ((Radd_assoc Rth) (- x)). rewrite ((Radd_assoc Rth) y). rewrite ((Radd_comm Rth) y). rewrite <- ((Radd_assoc Rth) (- x)). rewrite ((Radd_assoc Rth) y). rewrite ((Radd_comm Rth) y), (Ropp_def Rth). rewrite ((Radd_comm Rth) (-x) 0), (Radd_0_l Rth). now apply (Radd_comm Rth). Qed. Lemma Ropp_opp x : - -x == x. Proof. rewrite <- (Radd_0_l Rth (- -x)). rewrite <- (Ropp_def Rth x). rewrite <- (Radd_assoc Rth), (Ropp_def Rth). rewrite ((Radd_comm Rth) x); now apply (Radd_0_l Rth). Qed. Lemma Rth_ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. Proof (mk_art 0 1 radd rmul rsub ropp req (Radd_0_l Rth) (Radd_comm Rth) (Radd_assoc Rth) (Rmul_1_l Rth) Rmul_0_l (Rmul_comm Rth) (Rmul_assoc Rth) (Rdistr_l Rth) Ropp_mul_l Ropp_add (Rsub_def Rth)). (** Every semi morphism between two rings is a morphism*) Variable C : Type. Variable (cO cI : C) (cadd cmul csub: C->C->C) (copp : C -> C). Variable (ceq : C -> C -> Prop) (ceqb : C -> C -> bool). Variable phi : C -> R. Infix "+!" := cadd. Infix "*!" := cmul. Infix "-!" := csub. Notation "-! x" := (copp x). Notation "?=!" := ceqb. Notation "[ x ]" := (phi x). Variable Csth : Equivalence ceq. Variable Ceqe : ring_eq_ext cadd cmul copp ceq. Add Setoid C ceq Csth as C_setoid. Add Morphism cadd : cadd_ext. exact (Radd_ext Ceqe). Qed. Add Morphism cmul : cmul_ext. exact (Rmul_ext Ceqe). Qed. Add Morphism copp : copp_ext. exact (Ropp_ext Ceqe). Qed. Variable Cth : ring_theory cO cI cadd cmul csub copp ceq. Variable Smorph : semi_morph 0 1 radd rmul req cO cI cadd cmul ceqb phi. Variable phi_ext : forall x y, ceq x y -> [x] == [y]. Add Morphism phi : phi_ext1. exact phi_ext. Qed. Lemma Smorph_opp x : [-!x] == -[x]. Proof. rewrite <- (Rth.(Radd_0_l) [-!x]). rewrite <- ((Ropp_def Rth) [x]). rewrite ((Radd_comm Rth) [x]). rewrite <- (Radd_assoc Rth). rewrite <- (Smorph_add Smorph). rewrite (Ropp_def Cth). rewrite (Smorph0 Smorph). rewrite (Radd_comm Rth (-[x])). now apply (Radd_0_l Rth). Qed. Lemma Smorph_sub x y : [x -! y] == [x] - [y]. Proof. rewrite (Rsub_def Cth), (Rsub_def Rth). now rewrite (Smorph_add Smorph), Smorph_opp. Qed. Lemma Smorph_morph : ring_morph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. Proof (mkmorph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi (Smorph0 Smorph) (Smorph1 Smorph) (Smorph_add Smorph) Smorph_sub (Smorph_mul Smorph) Smorph_opp (Smorph_eq Smorph)). End RING. (** Useful lemmas on almost ring *) Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. Lemma ARth_SRth : semi_ring_theory 0 1 radd rmul req. Proof. elim ARth; intros. constructor; trivial. Qed. Instance ARsub_ext : Proper (req ==> req ==> req) rsub. Proof. intros x1 x2 Ex y1 y2 Ey. now rewrite !(ARsub_def ARth), Ex, Ey. Qed. Ltac mrewrite := repeat first [ rewrite (ARadd_0_l ARth) | rewrite <- ((ARadd_comm ARth) 0) | rewrite (ARmul_1_l ARth) | rewrite <- ((ARmul_comm ARth) 1) | rewrite (ARmul_0_l ARth) | rewrite <- ((ARmul_comm ARth) 0) | rewrite (ARdistr_l ARth) | reflexivity | match goal with | |- context [?z * (?x + ?y)] => rewrite ((ARmul_comm ARth) z (x+y)) end]. Lemma ARadd_0_r x : x + 0 == x. Proof. mrewrite. Qed. Lemma ARmul_1_r x : x * 1 == x. Proof. mrewrite. Qed. Lemma ARmul_0_r x : x * 0 == 0. Proof. mrewrite. Qed. Lemma ARdistr_r x y z : z * (x + y) == z*x + z*y. Proof. mrewrite. now rewrite !(ARth.(ARmul_comm) z). Qed. Lemma ARadd_assoc1 x y z : (x + y) + z == (y + z) + x. Proof. now rewrite <-(ARth.(ARadd_assoc) x), (ARth.(ARadd_comm) x). Qed. Lemma ARadd_assoc2 x y z : (y + x) + z == (y + z) + x. Proof. now rewrite <- !(ARadd_assoc ARth), ((ARadd_comm ARth) x). Qed. Lemma ARmul_assoc1 x y z : (x * y) * z == (y * z) * x. Proof. now rewrite <- ((ARmul_assoc ARth) x), ((ARmul_comm ARth) x). Qed. Lemma ARmul_assoc2 x y z : (y * x) * z == (y * z) * x. Proof. now rewrite <- !(ARmul_assoc ARth), ((ARmul_comm ARth) x). Qed. Lemma ARopp_mul_r x y : - (x * y) == x * -y. Proof. rewrite ((ARmul_comm ARth) x y), (ARopp_mul_l ARth). now apply (ARmul_comm ARth). Qed. Lemma ARopp_zero : -0 == 0. Proof. now rewrite <- (ARmul_0_r 0), (ARopp_mul_l ARth), !ARmul_0_r. Qed. End ALMOST_RING. Section AddRing. (* Variable R : Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable req : R -> R -> Prop. *) Inductive ring_kind : Type := | Abstract | Computational (R:Type) (req : R -> R -> Prop) (reqb : R -> R -> bool) (_ : forall x y, (reqb x y) = true -> req x y) | Morphism (R : Type) (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R) (req : R -> R -> Prop) (C : Type) (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C) (ceqb : C->C->bool) phi (_ : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi). End AddRing. (** Some simplification tactics*) Ltac gen_reflexivity Rsth := apply (Seq_refl _ _ Rsth). Ltac gen_srewrite Rsth Reqe ARth := repeat first [ gen_reflexivity Rsth | progress rewrite (ARopp_zero Rsth Reqe ARth) | rewrite (ARadd_0_l ARth) | rewrite (ARadd_0_r Rsth ARth) | rewrite (ARmul_1_l ARth) | rewrite (ARmul_1_r Rsth ARth) | rewrite (ARmul_0_l ARth) | rewrite (ARmul_0_r Rsth ARth) | rewrite (ARdistr_l ARth) | rewrite (ARdistr_r Rsth Reqe ARth) | rewrite (ARadd_assoc ARth) | rewrite (ARmul_assoc ARth) | progress rewrite (ARopp_add ARth) | progress rewrite (ARsub_def ARth) | progress rewrite <- (ARopp_mul_l ARth) | progress rewrite <- (ARopp_mul_r Rsth Reqe ARth) ]. Ltac gen_srewrite_sr Rsth Reqe ARth := repeat first [ gen_reflexivity Rsth | progress rewrite (ARopp_zero Rsth Reqe ARth) | rewrite (ARadd_0_l ARth) | rewrite (ARadd_0_r Rsth ARth) | rewrite (ARmul_1_l ARth) | rewrite (ARmul_1_r Rsth ARth) | rewrite (ARmul_0_l ARth) | rewrite (ARmul_0_r Rsth ARth) | rewrite (ARdistr_l ARth) | rewrite (ARdistr_r Rsth Reqe ARth) | rewrite (ARadd_assoc ARth) | rewrite (ARmul_assoc ARth) ]. Ltac gen_add_push add Rsth Reqe ARth x := repeat (match goal with | |- context [add (add ?y x) ?z] => progress rewrite (ARadd_assoc2 Rsth Reqe ARth x y z) | |- context [add (add x ?y) ?z] => progress rewrite (ARadd_assoc1 Rsth ARth x y z) | |- context [(add x ?y)] => progress rewrite (ARadd_comm ARth x y) end). Ltac gen_mul_push mul Rsth Reqe ARth x := repeat (match goal with | |- context [mul (mul ?y x) ?z] => progress rewrite (ARmul_assoc2 Rsth Reqe ARth x y z) | |- context [mul (mul x ?y) ?z] => progress rewrite (ARmul_assoc1 Rsth ARth x y z) | |- context [(mul x ?y)] => progress rewrite (ARmul_comm ARth x y) end). coq-8.4pl4/plugins/setoid_ring/Rings_Q.v0000644000175000017500000000141312326224777017352 0ustar stephstephRequire Export Cring. Require Export Integral_domain. (* Rational numbers *) Require Import QArith. Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq). Instance Qri : (Ring (Ro:=Qops)). constructor. try apply Q_Setoid. apply Qplus_comp. apply Qmult_comp. apply Qminus_comp. apply Qopp_comp. exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc. exact Qmult_1_l. exact Qmult_1_r. apply Qmult_assoc. apply Qmult_plus_distr_l. intros. apply Qmult_plus_distr_r. reflexivity. exact Qplus_opp_r. Defined. Instance Qcri: (Cring (Rr:=Qri)). red. exact Qmult_comm. Defined. Lemma Q_one_zero: not (Qeq 1%Q 0%Q). unfold Qeq. simpl. auto with *. Qed. Instance Qdi : (Integral_domain (Rcr:=Qcri)). constructor. exact Qmult_integral. exact Q_one_zero. Defined. coq-8.4pl4/plugins/setoid_ring/NArithRing.v0000644000175000017500000000137712326224777020026 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t | _ => constr:NotConstant end. Add Ring Nr : Nth (decidable Neqb_ok, constants [Ncst]). coq-8.4pl4/plugins/setoid_ring/Rings_R.v0000644000175000017500000000162712326224777017362 0ustar stephstephRequire Export Cring. Require Export Integral_domain. (* Real numbers *) Require Import Reals. Require Import RealField. Lemma Rsth : Setoid_Theory R (@eq R). constructor;red;intros;subst;trivial. Qed. Instance Rops: (@Ring_ops R 0%R 1%R Rplus Rmult Rminus Ropp (@eq R)). Instance Rri : (Ring (Ro:=Rops)). constructor; try (try apply Rsth; try (unfold respectful, Proper; unfold equality; unfold eq_notation in *; intros; try rewrite H; try rewrite H0; reflexivity)). exact Rplus_0_l. exact Rplus_comm. symmetry. apply Rplus_assoc. exact Rmult_1_l. exact Rmult_1_r. symmetry. apply Rmult_assoc. exact Rmult_plus_distr_r. intros; apply Rmult_plus_distr_l. exact Rplus_opp_r. Defined. Instance Rcri: (Cring (Rr:=Rri)). red. exact Rmult_comm. Defined. Lemma R_one_zero: 1%R <> 0%R. discrR. Qed. Instance Rdi : (Integral_domain (Rcr:=Rcri)). constructor. exact Rmult_integral. exact R_one_zero. Defined. coq-8.4pl4/plugins/setoid_ring/Ncring.v0000644000175000017500000002241012326224777017230 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* T->T} {mul:T->T->T} {sub:T->T->T} {opp:T->T} {ring_eq:T->T->Prop}. Instance zero_notation(T:Type)`{Ring_ops T}:Zero T:= ring0. Instance one_notation(T:Type)`{Ring_ops T}:One T:= ring1. Instance add_notation(T:Type)`{Ring_ops T}:Addition T:= add. Instance mul_notation(T:Type)`{Ring_ops T}:@Multiplication T T:= mul. Instance sub_notation(T:Type)`{Ring_ops T}:Subtraction T:= sub. Instance opp_notation(T:Type)`{Ring_ops T}:Opposite T:= opp. Instance eq_notation(T:Type)`{Ring_ops T}:@Equality T:= ring_eq. Class Ring `{Ro:Ring_ops}:={ ring_setoid: Equivalence _==_; ring_plus_comp: Proper (_==_ ==> _==_ ==>_==_) _+_; ring_mult_comp: Proper (_==_ ==> _==_ ==>_==_) _*_; ring_sub_comp: Proper (_==_ ==> _==_ ==>_==_) _-_; ring_opp_comp: Proper (_==_==>_==_) -_; ring_add_0_l : forall x, 0 + x == x; ring_add_comm : forall x y, x + y == y + x; ring_add_assoc : forall x y z, x + (y + z) == (x + y) + z; ring_mul_1_l : forall x, 1 * x == x; ring_mul_1_r : forall x, x * 1 == x; ring_mul_assoc : forall x y z, x * (y * z) == (x * y) * z; ring_distr_l : forall x y z, (x + y) * z == x * z + y * z; ring_distr_r : forall x y z, z * ( x + y) == z * x + z * y; ring_sub_def : forall x y, x - y == x + -y; ring_opp_def : forall x, x + -x == 0 }. (* inutile! je sais plus pourquoi j'ai mis ca... Instance ring_Ring_ops(R:Type)`{Ring R} :@Ring_ops R 0 1 addition multiplication subtraction opposite equality. *) Existing Instance ring_setoid. Existing Instance ring_plus_comp. Existing Instance ring_mult_comp. Existing Instance ring_sub_comp. Existing Instance ring_opp_comp. Section Ring_power. Context {R:Type}`{Ring R}. Fixpoint pow_pos (x:R) (i:positive) {struct i}: R := match i with | xH => x | xO i => let p := pow_pos x i in p * p | xI i => let p := pow_pos x i in x * (p * p) end. Definition pow_N (x:R) (p:N) := match p with | N0 => 1 | Npos p => pow_pos x p end. End Ring_power. Definition ZN(x:Z):= match x with Z0 => N0 |Zpos p | Zneg p => Npos p end. Instance power_ring {R:Type}`{Ring R} : Power:= {power x y := pow_N x (ZN y)}. (** Interpretation morphisms definition*) Class Ring_morphism (C R:Type)`{Cr:Ring C} `{Rr:Ring R}`{Rh:Bracket C R}:= { ring_morphism0 : [0] == 0; ring_morphism1 : [1] == 1; ring_morphism_add : forall x y, [x + y] == [x] + [y]; ring_morphism_sub : forall x y, [x - y] == [x] - [y]; ring_morphism_mul : forall x y, [x * y] == [x] * [y]; ring_morphism_opp : forall x, [-x] == -[x]; ring_morphism_eq : forall x y, x == y -> [x] == [y]}. Section Ring. Context {R:Type}`{Rr:Ring R}. (* Powers *) Lemma pow_pos_comm : forall x j, x * pow_pos x j == pow_pos x j * x. Proof. induction j; simpl. rewrite <- ring_mul_assoc. rewrite <- ring_mul_assoc. rewrite <- IHj. rewrite (ring_mul_assoc (pow_pos x j) x (pow_pos x j)). rewrite <- IHj. rewrite <- ring_mul_assoc. reflexivity. rewrite <- ring_mul_assoc. rewrite <- IHj. rewrite ring_mul_assoc. rewrite IHj. rewrite <- ring_mul_assoc. rewrite IHj. reflexivity. reflexivity. Qed. Lemma pow_pos_succ : forall x j, pow_pos x (Pos.succ j) == x * pow_pos x j. Proof. induction j; simpl. rewrite IHj. rewrite <- (ring_mul_assoc x (pow_pos x j) (x * pow_pos x j)). rewrite (ring_mul_assoc (pow_pos x j) x (pow_pos x j)). rewrite <- pow_pos_comm. rewrite <- ring_mul_assoc. reflexivity. reflexivity. reflexivity. Qed. Lemma pow_pos_add : forall x i j, pow_pos x (i + j) == pow_pos x i * pow_pos x j. Proof. intro x;induction i;intros. rewrite Pos.xI_succ_xO;rewrite <- Pos.add_1_r. rewrite <- Pos.add_diag;repeat rewrite <- Pos.add_assoc. repeat rewrite IHi. rewrite Pos.add_comm;rewrite Pos.add_1_r; rewrite pow_pos_succ. simpl;repeat rewrite ring_mul_assoc. reflexivity. rewrite <- Pos.add_diag;repeat rewrite <- Pos.add_assoc. repeat rewrite IHi. rewrite ring_mul_assoc. reflexivity. rewrite Pos.add_comm;rewrite Pos.add_1_r;rewrite pow_pos_succ. simpl. reflexivity. Qed. Definition id_phi_N (x:N) : N := x. Lemma pow_N_pow_N : forall x n, pow_N x (id_phi_N n) == pow_N x n. Proof. intros; reflexivity. Qed. (** Identity is a morphism *) (* Instance IDmorph : Ring_morphism _ _ _ (fun x => x). Proof. apply (Build_Ring_morphism H6 H6 (fun x => x));intros; try reflexivity. trivial. Qed. *) (** rings are almost rings*) Lemma ring_mul_0_l : forall x, 0 * x == 0. Proof. intro x. setoid_replace (0*x) with ((0+1)*x + -x). rewrite ring_add_0_l. rewrite ring_mul_1_l . rewrite ring_opp_def . fold zero. reflexivity. rewrite ring_distr_l . rewrite ring_mul_1_l . rewrite <- ring_add_assoc ; rewrite ring_opp_def . rewrite ring_add_comm ; rewrite ring_add_0_l ;reflexivity. Qed. Lemma ring_mul_0_r : forall x, x * 0 == 0. Proof. intro x; setoid_replace (x*0) with (x*(0+1) + -x). rewrite ring_add_0_l ; rewrite ring_mul_1_r . rewrite ring_opp_def ; fold zero; reflexivity. rewrite ring_distr_r ;rewrite ring_mul_1_r . rewrite <- ring_add_assoc ; rewrite ring_opp_def . rewrite ring_add_comm ; rewrite ring_add_0_l ;reflexivity. Qed. Lemma ring_opp_mul_l : forall x y, -(x * y) == -x * y. Proof. intros x y;rewrite <- (ring_add_0_l (- x * y)). rewrite ring_add_comm . rewrite <- (ring_opp_def (x*y)). rewrite ring_add_assoc . rewrite <- ring_distr_l. rewrite (ring_add_comm (-x));rewrite ring_opp_def . rewrite ring_mul_0_l;rewrite ring_add_0_l ;reflexivity. Qed. Lemma ring_opp_mul_r : forall x y, -(x * y) == x * -y. Proof. intros x y;rewrite <- (ring_add_0_l (x * - y)). rewrite ring_add_comm . rewrite <- (ring_opp_def (x*y)). rewrite ring_add_assoc . rewrite <- ring_distr_r . rewrite (ring_add_comm (-y));rewrite ring_opp_def . rewrite ring_mul_0_r;rewrite ring_add_0_l ;reflexivity. Qed. Lemma ring_opp_add : forall x y, -(x + y) == -x + -y. Proof. intros x y;rewrite <- (ring_add_0_l (-(x+y))). rewrite <- (ring_opp_def x). rewrite <- (ring_add_0_l (x + - x + - (x + y))). rewrite <- (ring_opp_def y). rewrite (ring_add_comm x). rewrite (ring_add_comm y). rewrite <- (ring_add_assoc (-y)). rewrite <- (ring_add_assoc (- x)). rewrite (ring_add_assoc y). rewrite (ring_add_comm y). rewrite <- (ring_add_assoc (- x)). rewrite (ring_add_assoc y). rewrite (ring_add_comm y);rewrite ring_opp_def . rewrite (ring_add_comm (-x) 0);rewrite ring_add_0_l . rewrite ring_add_comm; reflexivity. Qed. Lemma ring_opp_opp : forall x, - -x == x. Proof. intros x; rewrite <- (ring_add_0_l (- -x)). rewrite <- (ring_opp_def x). rewrite <- ring_add_assoc ; rewrite ring_opp_def . rewrite (ring_add_comm x); rewrite ring_add_0_l . reflexivity. Qed. Lemma ring_sub_ext : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2. Proof. intros. setoid_replace (x1 - y1) with (x1 + -y1). setoid_replace (x2 - y2) with (x2 + -y2). rewrite H;rewrite H0;reflexivity. rewrite ring_sub_def. reflexivity. rewrite ring_sub_def. reflexivity. Qed. Ltac mrewrite := repeat first [ rewrite ring_add_0_l | rewrite <- (ring_add_comm 0) | rewrite ring_mul_1_l | rewrite ring_mul_0_l | rewrite ring_distr_l | reflexivity ]. Lemma ring_add_0_r : forall x, (x + 0) == x. Proof. intros; mrewrite. Qed. Lemma ring_add_assoc1 : forall x y z, (x + y) + z == (y + z) + x. Proof. intros;rewrite <- (ring_add_assoc x). rewrite (ring_add_comm x);reflexivity. Qed. Lemma ring_add_assoc2 : forall x y z, (y + x) + z == (y + z) + x. Proof. intros; repeat rewrite <- ring_add_assoc. rewrite (ring_add_comm x); reflexivity. Qed. Lemma ring_opp_zero : -0 == 0. Proof. rewrite <- (ring_mul_0_r 0). rewrite ring_opp_mul_l. repeat rewrite ring_mul_0_r. reflexivity. Qed. End Ring. (** Some simplification tactics*) Ltac gen_reflexivity := reflexivity. Ltac gen_rewrite := repeat first [ reflexivity | progress rewrite ring_opp_zero | rewrite ring_add_0_l | rewrite ring_add_0_r | rewrite ring_mul_1_l | rewrite ring_mul_1_r | rewrite ring_mul_0_l | rewrite ring_mul_0_r | rewrite ring_distr_l | rewrite ring_distr_r | rewrite ring_add_assoc | rewrite ring_mul_assoc | progress rewrite ring_opp_add | progress rewrite ring_sub_def | progress rewrite <- ring_opp_mul_l | progress rewrite <- ring_opp_mul_r ]. Ltac gen_add_push x := repeat (match goal with | |- context [(?y + x) + ?z] => progress rewrite (ring_add_assoc2 x y z) | |- context [(x + ?y) + ?z] => progress rewrite (ring_add_assoc1 x y z) end). coq-8.4pl4/plugins/setoid_ring/Ring_tac.v0000644000175000017500000003300712326224777017542 0ustar stephstephSet Implicit Arguments. Require Import Setoid. Require Import BinPos. Require Import Ring_polynom. Require Import BinList. Require Export ListTactics. Require Import InitialRing. Require Import Quote. Declare ML Module "newring_plugin". (* adds a definition t' on the normal form of t and an hypothesis id stating that t = t' (tries to produces a proof as small as possible) *) Ltac compute_assertion eqn t' t := let nft := eval vm_compute in t in pose (t' := nft); assert (eqn : t = t'); [vm_cast_no_check (eq_refl t')|idtac]. Ltac relation_carrier req := let ty := type of req in match eval hnf in ty with ?R -> _ => R | _ => fail 1000 "Equality has no relation type" end. Ltac Get_goal := match goal with [|- ?G] => G end. (********************************************************************) (* Tacticals to build reflexive tactics *) Ltac OnEquation req := match goal with | |- req ?lhs ?rhs => (fun f => f lhs rhs) | _ => (fun _ => fail "Goal is not an equation (of expected equality)") end. Ltac OnEquationHyp req h := match type of h with | req ?lhs ?rhs => fun f => f lhs rhs | _ => (fun _ => fail "Hypothesis is not an equation (of expected equality)") end. (* Note: auxiliary subgoals in reverse order *) Ltac OnMainSubgoal H ty := match ty with | _ -> ?ty' => let subtac := OnMainSubgoal H ty' in fun kont => lapply H; [clear H; intro H; subtac kont | idtac] | _ => (fun kont => kont()) end. (* A generic pattern to have reflexive tactics do some computation: lemmas of the form [forall x', x=x' -> P(x')] are understood as: compute the normal form of x, instantiate x' with it, prove hypothesis x=x' with vm_compute and reflexivity, and pass the instantiated lemma to the continuation. *) Ltac ProveLemmaHyp lemma := match type of lemma with forall x', ?x = x' -> _ => (fun kont => let x' := fresh "res" in let H := fresh "res_eq" in compute_assertion H x' x; let lemma' := constr:(lemma x' H) in kont lemma'; (clear H||idtac"ProveLemmaHyp: cleanup failed"); subst x') | _ => (fun _ => fail "ProveLemmaHyp: lemma not of the expected form") end. Ltac ProveLemmaHyps lemma := match type of lemma with forall x', ?x = x' -> _ => (fun kont => let x' := fresh "res" in let H := fresh "res_eq" in compute_assertion H x' x; let lemma' := constr:(lemma x' H) in ProveLemmaHyps lemma' kont; (clear H||idtac"ProveLemmaHyps: cleanup failed"); subst x') | _ => (fun kont => kont lemma) end. (* Ltac ProveLemmaHyps lemma := (* expects a continuation *) let try_step := ProveLemmaHyp lemma in (fun kont => try_step ltac:(fun lemma' => ProveLemmaHyps lemma' kont) || kont lemma). *) Ltac ApplyLemmaThen lemma expr kont := let lem := constr:(lemma expr) in ProveLemmaHyp lem ltac:(fun lem' => let Heq := fresh "thm" in assert (Heq:=lem'); OnMainSubgoal Heq ltac:(type of Heq) ltac:(fun _ => kont Heq); (clear Heq||idtac"ApplyLemmaThen: cleanup failed")). (* Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac cont_arg := let pe := match type of (lemma expr) with forall pe', ?pe = pe' -> _ => pe | _ => fail 1 "ApplyLemmaThenAndCont: cannot find norm expression" end in let pe' := fresh "expr_nf" in let nf_pe := fresh "pe_eq" in compute_assertion nf_pe pe' pe; let Heq := fresh "thm" in (assert (Heq:=lemma pe pe' H) || fail "anomaly: failed to apply lemma"); clear nf_pe; OnMainSubgoal Heq ltac:(type of Heq) ltac:(try tac Heq; clear Heq pe';CONT_tac cont_arg)). *) Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac := ApplyLemmaThen lemma expr ltac:(fun lemma' => try tac lemma'; CONT_tac()). (* General scheme of reflexive tactics using of correctness lemma that involves normalisation of one expression - [FV_tac term fv] is a tactic that adds the atomic expressions of [term] into [fv] - [SYN_tac term fv] reifies [term] given the list of atomic expressions - [LEMMA_tac fv kont] computes the correctness lemma and passes it to continuation kont - [MAIN_tac H] process H which is the conclusion of the correctness lemma instantiated with each reified term - [fv] is the initial value of atomic expressions (to be completed by the reification of the terms - [terms] the list (a constr of type list) of terms to reify and process. *) Ltac ReflexiveRewriteTactic FV_tac SYN_tac LEMMA_tac MAIN_tac fv terms := (* extend the atom list *) let fv := list_fold_left FV_tac fv terms in let RW_tac lemma := let fcons term CONT_tac := let expr := SYN_tac term fv in let main H := match type of H with | (?req _ ?rhs) => change (req term rhs) in H end; MAIN_tac H in (ApplyLemmaThenAndCont lemma expr main CONT_tac) in (* rewrite steps *) lazy_list_fold_right fcons ltac:(fun _=>idtac) terms in LEMMA_tac fv RW_tac. (********************************************************) Ltac FV_hypo_tac mkFV req lH := let R := relation_carrier req in let FV_hypo_l_tac h := match h with @mkhypo (req ?pe _) _ => mkFV pe end in let FV_hypo_r_tac h := match h with @mkhypo (req _ ?pe) _ => mkFV pe end in let fv := list_fold_right FV_hypo_l_tac (@nil R) lH in list_fold_right FV_hypo_r_tac fv lH. Ltac mkHyp_tac C req Reify lH := let mkHyp h res := match h with | @mkhypo (req ?r1 ?r2) _ => let pe1 := Reify r1 in let pe2 := Reify r2 in constr:(cons (pe1,pe2) res) | _ => fail 1 "hypothesis is not a ring equality" end in list_fold_right mkHyp (@nil (PExpr C * PExpr C)) lH. Ltac proofHyp_tac lH := let get_proof h := match h with | @mkhypo _ ?p => p end in let rec bh l := match l with | nil => constr:(I) | cons ?h nil => get_proof h | cons ?h ?tl => let l := get_proof h in let r := bh tl in constr:(conj l r) end in bh lH. Ltac get_MonPol lemma := match type of lemma with | context [(mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _)] => constr:(mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb) | _ => fail 1 "ring/field anomaly: bad correctness lemma (get_MonPol)" end. (********************************************************) (* Building the atom list of a ring expression *) Ltac FV Cst CstPow add mul sub opp pow t fv := let rec TFV t fv := let f := match Cst t with | NotConstant => match t with | (add ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv) | (mul ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv) | (sub ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv) | (opp ?t1) => fun _ => TFV t1 fv | (pow ?t1 ?n) => match CstPow n with | InitialRing.NotConstant => fun _ => AddFvTail t fv | _ => fun _ => TFV t1 fv end | _ => fun _ => AddFvTail t fv end | _ => fun _ => fv end in f() in TFV t fv. (* syntaxification of ring expressions *) Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := let rec mkP t := let f := match Cst t with | InitialRing.NotConstant => match t with | (radd ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(PEadd e1 e2) | (rmul ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(PEmul e1 e2) | (rsub ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(PEsub e1 e2) | (ropp ?t1) => fun _ => let e1 := mkP t1 in constr:(PEopp e1) | (rpow ?t1 ?n) => match CstPow n with | InitialRing.NotConstant => fun _ => let p := Find_at t fv in constr:(PEX C p) | ?c => fun _ => let e1 := mkP t1 in constr:(PEpow e1 c) end | _ => fun _ => let p := Find_at t fv in constr:(PEX C p) end | ?c => fun _ => constr:(@PEc C c) end in f () in mkP t. (* packaging the ring structure *) Ltac PackRing F req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post := let RNG := match type of lemma1 with | context [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] => (fun proj => proj cst_tac pow_tac pre post R req add mul sub opp C Cpow powphi pow lemma1 lemma2) | _ => fail 1 "field anomaly: bad correctness lemma (parse)" end in F RNG. Ltac get_Carrier RNG := RNG ltac:(fun cst_tac pow_tac pre post R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => R). Ltac get_Eq RNG := RNG ltac:(fun cst_tac pow_tac pre post R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => req). Ltac get_Pre RNG := RNG ltac:(fun cst_tac pow_tac pre post R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => pre). Ltac get_Post RNG := RNG ltac:(fun cst_tac pow_tac pre post R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => post). Ltac get_NormLemma RNG := RNG ltac:(fun cst_tac pow_tac pre post R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => lemma1). Ltac get_SimplifyLemma RNG := RNG ltac:(fun cst_tac pow_tac pre post R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => lemma2). Ltac get_RingFV RNG := RNG ltac:(fun cst_tac pow_tac pre post R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => FV cst_tac pow_tac add mul sub opp pow). Ltac get_RingMeta RNG := RNG ltac:(fun cst_tac pow_tac pre post R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => mkPolexpr C cst_tac pow_tac add mul sub opp pow). Ltac get_RingHypTac RNG := RNG ltac:(fun cst_tac pow_tac pre post R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => let mkPol := mkPolexpr C cst_tac pow_tac add mul sub opp pow in fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH). (* ring tactics *) Definition ring_subst_niter := (10*10*10)%nat. Ltac Ring RNG lemma lH := let req := get_Eq RNG in OnEquation req ltac:(fun lhs rhs => let mkFV := get_RingFV RNG in let mkPol := get_RingMeta RNG in let mkHyp := get_RingHypTac RNG in let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in let fv := mkFV lhs fv in let fv := mkFV rhs fv in check_fv fv; let pe1 := mkPol lhs fv in let pe2 := mkPol rhs fv in let lpe := mkHyp fv lH in let vlpe := fresh "hyp_list" in let vfv := fresh "fv_list" in pose (vlpe := lpe); pose (vfv := fv); (apply (lemma vfv vlpe pe1 pe2) || fail "typing error while applying ring"); [ ((let prh := proofHyp_tac lH in exact prh) || idtac "can not automatically proof hypothesis :"; idtac " maybe a left member of a hypothesis is not a monomial") | vm_compute; (exact (eq_refl true) || fail "not a valid ring equation")]). Ltac Ring_norm_gen f RNG lemma lH rl := let mkFV := get_RingFV RNG in let mkPol := get_RingMeta RNG in let mkHyp := get_RingHypTac RNG in let mk_monpol := get_MonPol lemma in let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in let lemma_tac fv kont := let lpe := mkHyp fv lH in let vlpe := fresh "list_hyp" in let vlmp := fresh "list_hyp_norm" in let vlmp_eq := fresh "list_hyp_norm_eq" in let prh := proofHyp_tac lH in pose (vlpe := lpe); compute_assertion vlmp_eq vlmp (mk_monpol vlpe); let H := fresh "ring_lemma" in (assert (H := lemma vlpe fv prh vlmp vlmp_eq) || fail "type error when build the rewriting lemma"); clear vlmp_eq; kont H; (clear H||idtac"Ring_norm_gen: cleanup failed"); subst vlpe vlmp in let simpl_ring H := (protect_fv "ring" in H; f H) in ReflexiveRewriteTactic mkFV mkPol lemma_tac simpl_ring fv rl. Ltac Ring_gen RNG lH rl := let lemma := get_NormLemma RNG in get_Pre RNG (); Ring RNG (lemma ring_subst_niter) lH. Tactic Notation (at level 0) "ring" := let G := Get_goal in ring_lookup (PackRing Ring_gen) [] G. Tactic Notation (at level 0) "ring" "[" constr_list(lH) "]" := let G := Get_goal in ring_lookup (PackRing Ring_gen) [lH] G. (* Simplification *) Ltac Ring_simplify_gen f RNG lH rl := let lemma := get_SimplifyLemma RNG in let l := fresh "to_rewrite" in pose (l:= rl); generalize (eq_refl l); unfold l at 2; get_Pre RNG (); let rl := match goal with | [|- l = ?RL -> _ ] => RL | _ => fail 1 "ring_simplify anomaly: bad goal after pre" end in let Heq := fresh "Heq" in intros Heq;clear Heq l; Ring_norm_gen f RNG (lemma ring_subst_niter) lH rl; get_Post RNG (). Ltac Ring_simplify := Ring_simplify_gen ltac:(fun H => rewrite H). Tactic Notation (at level 0) "ring_simplify" constr_list(rl) := let G := Get_goal in ring_lookup (PackRing Ring_simplify) [] rl G. Tactic Notation (at level 0) "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) := let G := Get_goal in ring_lookup (PackRing Ring_simplify) [lH] rl G. (* MON DIEU QUE C'EST MOCHE !!!!!!!!!!!!! *) Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):= let G := Get_goal in let t := type of H in let g := fresh "goal" in set (g:= G); generalize H;clear H; ring_lookup (PackRing Ring_simplify) [] rl t; intro H; unfold g;clear g. Tactic Notation "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H):= let G := Get_goal in let t := type of H in let g := fresh "goal" in set (g:= G); generalize H;clear H; ring_lookup (PackRing Ring_simplify) [lH] rl t; intro H; unfold g;clear g. coq-8.4pl4/plugins/setoid_ring/Cring.v0000644000175000017500000002141512326224777017056 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* idtac | ?e1::?e2::_ => match goal with |- (?op ?u1 ?u2) => change (op (@Ring_polynom.PEeval _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) (@Ring_theory.pow_N _ 1 multiplication) lvar e1) (@Ring_polynom.PEeval _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) (@Ring_theory.pow_N _ 1 multiplication) lvar e2)) end end. Section cring. Context {R:Type}`{Rr:Cring R}. Lemma cring_eq_ext: ring_eq_ext _+_ _*_ -_ _==_. Proof. intros. apply mk_reqe; solve_proper. Defined. Lemma cring_almost_ring_theory: almost_ring_theory (R:=R) zero one _+_ _*_ _-_ -_ _==_. intros. apply mk_art ;intros. rewrite ring_add_0_l; reflexivity. rewrite ring_add_comm; reflexivity. rewrite ring_add_assoc; reflexivity. rewrite ring_mul_1_l; reflexivity. apply ring_mul_0_l. rewrite cring_mul_comm; reflexivity. rewrite ring_mul_assoc; reflexivity. rewrite ring_distr_l; reflexivity. rewrite ring_opp_mul_l; reflexivity. apply ring_opp_add. rewrite ring_sub_def ; reflexivity. Defined. Lemma cring_morph: ring_morph zero one _+_ _*_ _-_ -_ _==_ 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool Ncring_initial.gen_phiZ. intros. apply mkmorph ; intros; simpl; try reflexivity. rewrite Ncring_initial.gen_phiZ_add; reflexivity. rewrite ring_sub_def. unfold Z.sub. rewrite Ncring_initial.gen_phiZ_add. rewrite Ncring_initial.gen_phiZ_opp; reflexivity. rewrite Ncring_initial.gen_phiZ_mul; reflexivity. rewrite Ncring_initial.gen_phiZ_opp; reflexivity. rewrite (Zeqb_ok x y H). reflexivity. Defined. Lemma cring_power_theory : @Ring_theory.power_theory R one _*_ _==_ N (fun n:N => n) (@Ring_theory.pow_N _ 1 multiplication). intros; apply Ring_theory.mkpow_th. reflexivity. Defined. Lemma cring_div_theory: div_theory _==_ Z.add Z.mul Ncring_initial.gen_phiZ Z.quotrem. intros. apply InitialRing.Ztriv_div_th. unfold Setoid_Theory. simpl. apply ring_setoid. Defined. End cring. Ltac cring_gen := match goal with |- ?g => let lterm := lterm_goal g in match eval red in (list_reifyl (lterm:=lterm)) with | (?fv, ?lexpr) => (*idtac "variables:";idtac fv; idtac "terms:"; idtac lterm; idtac "reifications:"; idtac lexpr; *) reify_goal fv lexpr lterm; match goal with |- ?g => generalize (@Ring_polynom.ring_correct _ 0 1 _+_ _*_ _-_ -_ _==_ ring_setoid cring_eq_ext cring_almost_ring_theory Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool Ncring_initial.gen_phiZ cring_morph N (fun n:N => n) (@Ring_theory.pow_N _ 1 multiplication) cring_power_theory Z.quotrem cring_div_theory O fv nil); let rc := fresh "rc"in intro rc; apply rc end end end. Ltac cring_compute:= vm_compute; reflexivity. Ltac cring:= intros; cring_gen; cring_compute. Instance Zcri: (Cring (Rr:=Zr)). red. exact Z.mul_comm. Defined. (* Cring_simplify *) Ltac cring_simplify_aux lterm fv lexpr hyp := match lterm with | ?t0::?lterm => match lexpr with | ?e::?le => let t := constr:(@Ring_polynom.norm_subst Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool Z.quotrem O nil e) in let te := constr:(@Ring_polynom.Pphi_dev _ 0 1 _+_ _*_ _-_ -_ Z 0%Z 1%Z Zeq_bool Ncring_initial.gen_phiZ get_signZ fv t) in let eq1 := fresh "ring" in let nft := eval vm_compute in t in let t':= fresh "t" in pose (t' := nft); assert (eq1 : t = t'); [vm_cast_no_check (eq_refl t')| let eq2 := fresh "ring" in assert (eq2:(@Ring_polynom.PEeval _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) (@Ring_theory.pow_N _ 1 multiplication) fv e) == te); [let eq3 := fresh "ring" in generalize (@ring_rw_correct _ 0 1 _+_ _*_ _-_ -_ _==_ ring_setoid cring_eq_ext cring_almost_ring_theory Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool Ncring_initial.gen_phiZ cring_morph N (fun n:N => n) (@Ring_theory.pow_N _ 1 multiplication) cring_power_theory Z.quotrem cring_div_theory get_signZ get_signZ_th O nil fv I nil (eq_refl nil) ); intro eq3; apply eq3; reflexivity| match hyp with | 1%nat => rewrite eq2 | ?H => try rewrite eq2 in H end]; let P:= fresh "P" in match hyp with | 1%nat => rewrite eq1; pattern (@Ring_polynom.Pphi_dev _ 0 1 _+_ _*_ _-_ -_ Z 0%Z 1%Z Zeq_bool Ncring_initial.gen_phiZ get_signZ fv t'); match goal with |- (?p ?t) => set (P:=p) end; unfold t' in *; clear t' eq1 eq2; unfold Pphi_dev, Pphi_avoid; simpl; repeat (unfold mkmult1, mkmultm1, mkmult_c_pos, mkmult_c, mkadd_mult, mkmult_c_pos, mkmult_pow, mkadd_mult, mkpow;simpl) | ?H => rewrite eq1 in H; pattern (@Ring_polynom.Pphi_dev _ 0 1 _+_ _*_ _-_ -_ Z 0%Z 1%Z Zeq_bool Ncring_initial.gen_phiZ get_signZ fv t') in H; match type of H with | (?p ?t) => set (P:=p) in H end; unfold t' in *; clear t' eq1 eq2; unfold Pphi_dev, Pphi_avoid in H; simpl in H; repeat (unfold mkmult1, mkmultm1, mkmult_c_pos, mkmult_c, mkadd_mult, mkmult_c_pos, mkmult_pow, mkadd_mult, mkpow in H;simpl in H) end; unfold P in *; clear P ]; cring_simplify_aux lterm fv le hyp | nil => idtac end | nil => idtac end. Ltac set_variables fv := match fv with | nil => idtac | ?t::?fv => let v := fresh "X" in set (v:=t) in *; set_variables fv end. Ltac deset n:= match n with | 0%nat => idtac | S ?n1 => match goal with | h:= ?v : ?t |- ?g => unfold h in *; clear h; deset n1 end end. (* a est soit un terme de l'anneau, soit une liste de termes. J'ai pas rÃĐussi à un dÃĐcomposer les Vlists obtenues avec ne_constr_list dans Tactic Notation *) Ltac cring_simplify_gen a hyp := let lterm := match a with | _::_ => a | _ => constr:(a::nil) end in match eval red in (list_reifyl (lterm:=lterm)) with | (?fv, ?lexpr) => idtac lterm; idtac fv; idtac lexpr; let n := eval compute in (length fv) in idtac n; let lt:=fresh "lt" in set (lt:= lterm); let lv:=fresh "fv" in set (lv:= fv); (* les termes de fv sont remplacÃĐs par des variables pour pouvoir utiliser simpl ensuite sans risquer des simplifications indÃĐsirables *) set_variables fv; let lterm1 := eval unfold lt in lt in let lv1 := eval unfold lv in lv in idtac lterm1; idtac lv1; cring_simplify_aux lterm1 lv1 lexpr hyp; clear lt lv; (* on remet les termes de fv *) deset n end. Tactic Notation "cring_simplify" constr(lterm):= cring_simplify_gen lterm 1%nat. Tactic Notation "cring_simplify" constr(lterm) "in" ident(H):= cring_simplify_gen lterm H. coq-8.4pl4/plugins/decl_mode/0000755000175000017500000000000012365131026015212 5ustar stephstephcoq-8.4pl4/plugins/decl_mode/decl_proof_instr.mli0000644000175000017500000000676612326224777021304 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val return_from_tactic_mode: unit -> unit val register_automation_tac: tactic -> unit val automation_tac : tactic val concl_refiner: Termops.meta_type_map -> constr -> Proof_type.goal sigma -> constr val do_instr: Decl_expr.raw_proof_instr -> Proof.proof -> unit val proof_instr: Decl_expr.raw_proof_instr -> unit val tcl_change_info : Decl_mode.pm_info -> tactic val execute_cases : Names.name -> Decl_mode.per_info -> (Term.constr -> Proof_type.tactic) -> (Names.Idset.elt * (Term.constr option * Term.constr list) list) list -> Term.constr list -> int -> Decl_mode.split_tree -> Proof_type.tactic val tree_of_pats : identifier * (int * int) -> (Glob_term.cases_pattern*recpath) list list -> split_tree val add_branch : identifier * (int * int) -> (Glob_term.cases_pattern*recpath) list list -> split_tree -> split_tree val append_branch : identifier *(int * int) -> int -> (Glob_term.cases_pattern*recpath) list list -> (Names.Idset.t * Decl_mode.split_tree) option -> (Names.Idset.t * Decl_mode.split_tree) option val append_tree : identifier * (int * int) -> int -> (Glob_term.cases_pattern*recpath) list list -> split_tree -> split_tree val build_dep_clause : Term.types Decl_expr.statement list -> Decl_expr.proof_pattern -> Decl_mode.per_info -> (Term.types Decl_expr.statement, Term.types Decl_expr.or_thesis) Decl_expr.hyp list -> Proof_type.goal Tacmach.sigma -> Term.types val register_dep_subcase : Names.identifier * (int * int) -> Environ.env -> Decl_mode.per_info -> Glob_term.cases_pattern -> Decl_mode.elim_kind -> Decl_mode.elim_kind val thesis_for : Term.constr -> Term.constr -> Decl_mode.per_info -> Environ.env -> Term.constr val close_previous_case : Proof.proof -> unit val pop_stacks : (Names.identifier * (Term.constr option * Term.constr list) list) list -> (Names.identifier * (Term.constr option * Term.constr list) list) list val push_head : Term.constr -> Names.Idset.t -> (Names.identifier * (Term.constr option * Term.constr list) list) list -> (Names.identifier * (Term.constr option * Term.constr list) list) list val push_arg : Term.constr -> (Names.identifier * (Term.constr option * Term.constr list) list) list -> (Names.identifier * (Term.constr option * Term.constr list) list) list val hrec_for: Names.identifier -> Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> Names.identifier -> Term.constr val consider_match : bool -> (Names.Idset.elt*bool) list -> Names.Idset.elt list -> (Term.types Decl_expr.statement, Term.types) Decl_expr.hyp list -> Proof_type.tactic val init_tree: Names.Idset.t -> Names.inductive -> int option * Declarations.wf_paths -> (int -> (int option * Declarations.recarg Rtree.t) array -> (Names.Idset.t * Decl_mode.split_tree) option) -> Decl_mode.split_tree coq-8.4pl4/plugins/decl_mode/decl_expr.mli0000644000175000017500000000576212326224777017711 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* raw_proof_instr -> glob_proof_instr val interp_proof_instr : Decl_mode.pm_info -> Evd.evar_map -> Environ.env -> glob_proof_instr -> proof_instr coq-8.4pl4/plugins/decl_mode/ppdecl_proof.mli0000644000175000017500000000011412326224777020402 0ustar stephsteph val pr_proof_instr : Environ.env -> Decl_expr.proof_instr -> Pp.std_ppcmds coq-8.4pl4/plugins/decl_mode/decl_mode.ml0000644000175000017500000000607512326224777017504 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Mode_none let check_not_proof_mode str = if get_current_mode () = Mode_proof then error str let get_info sigma gl= match info.get (Goal.V82.extra sigma gl) with | None -> invalid_arg "get_info" | Some pm -> pm let try_get_info sigma gl = info.get (Goal.V82.extra sigma gl) let get_stack pts = let { it = goals ; sigma = sigma } = Proof.V82.subgoals pts in let info = get_info sigma (List.hd goals) in info.pm_stack let proof_focus = Proof.new_focus_kind () let proof_cond = Proof.no_cond proof_focus let focus p = let inf = get_stack p in Proof.focus proof_cond inf 1 p let unfocus = Proof.unfocus proof_focus let maximal_unfocus = Proof_global.maximal_unfocus proof_focus let get_top_stack pts = try Proof.get_at_focus proof_focus pts with Proof.NoSuchFocus -> let { it = gl ; sigma = sigma } = Proof.V82.top_goal pts in let info = get_info sigma gl in info.pm_stack let get_last env = try let (id,_,_) = List.hd (Environ.named_context env) in id with Invalid_argument _ -> error "no previous statement to use" coq-8.4pl4/plugins/decl_mode/g_decl_mode.ml40000644000175000017500000003313012326224777020066 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Decl_proof_instr.go_to_proof_mode () ; Proof_global.set_proof_mode "Declarative" ; Vernacentries.print_subgoals () end (* spiwack: some bureaucracy is not performed here *) let vernac_return () = Proof.transaction (Proof_global.give_me_the_proof ()) begin fun () -> Decl_proof_instr.return_from_tactic_mode () ; Proof_global.set_proof_mode "Declarative" ; Vernacentries.print_subgoals () end let vernac_proof_instr instr = Proof.transaction (Proof_global.give_me_the_proof ()) begin fun () -> Decl_proof_instr.proof_instr instr; Vernacentries.print_subgoals () end (* We create a new parser entry [proof_mode]. The Declarative proof mode will replace the normal parser entry for tactics with this one. *) let proof_mode = Gram.entry_create "vernac:proof_command" (* Auxiliary grammar entry. *) let proof_instr = Gram.entry_create "proofmode:instr" (* Before we can write an new toplevel command (see below) which takes a [proof_instr] as argument, we need to declare how to parse it, print it, globalise it and interprete it. Normally we could do that easily through ARGUMENT EXTEND, but as the parsing is fairly complicated we will do it manually to indirect through the [proof_instr] grammar entry. *) (* spiwack: proposal: doing that directly from argextend.ml4, maybe ? *) (* [Genarg.create_arg] creates a new embedding into Genarg. *) let (wit_proof_instr,globwit_proof_instr,rawwit_proof_instr) = Genarg.create_arg None "proof_instr" let _ = Tacinterp.add_interp_genarg "proof_instr" begin begin fun e x -> (* declares the globalisation function *) Genarg.in_gen globwit_proof_instr (Decl_interp.intern_proof_instr e (Genarg.out_gen rawwit_proof_instr x)) end, begin fun ist gl x -> (* declares the interpretation function *) Tacmach.project gl , Genarg.in_gen wit_proof_instr (interp_proof_instr ist gl (Genarg.out_gen globwit_proof_instr x)) end, begin fun _ x -> x end (* declares the substitution function, irrelevant in our case *) end let _ = Pptactic.declare_extra_genarg_pprule (rawwit_proof_instr, pr_raw_proof_instr) (globwit_proof_instr, pr_glob_proof_instr) (wit_proof_instr, pr_proof_instr) (* We use the VERNAC EXTEND facility with a custom non-terminal to populate [proof_mode] with a new toplevel interpreter. The "-" indicates that the rule does not start with a distinguished string. *) VERNAC proof_mode EXTEND ProofInstr [ - proof_instr(instr) ] -> [ vernac_proof_instr instr ] END (* It is useful to use GEXTEND directly to call grammar entries that have been defined previously VERNAC EXTEND. In this case we allow, in proof mode, the use of commands like Check or Print. VERNAC EXTEND does quite a bit of bureaucracy for us, but it is not needed in this sort of case, and it would require to have an ARGUMENT EXTEND version of the "proof_mode" grammar entry. *) GEXTEND Gram GLOBAL: proof_mode ; proof_mode: LAST [ [ c=G_vernac.subgoal_command -> c (Some 1) ] ] ; END (* We register a new proof mode here *) let _ = Proof_global.register_proof_mode { Proof_global. name = "Declarative" ; (* name for identifying and printing *) (* function [set] goes from No Proof Mode to Declarative Proof Mode performing side effects *) set = begin fun () -> (* We set the command non terminal to [proof_mode] (which we just defined). *) G_vernac.set_command_entry proof_mode ; (* We substitute the goal printer, by the one we built for the proof mode. *) Printer.set_printer_pr { Printer.default_printer_pr with Printer.pr_goal = pr_goal } end ; (* function [reset] goes back to No Proof Mode from Declarative Proof Mode *) reset = begin fun () -> (* We restore the command non terminal to [noedit_mode]. *) G_vernac.set_command_entry G_vernac.noedit_mode ; (* We restore the goal printer to default *) Printer.set_printer_pr Printer.default_printer_pr end } (* Two new vernacular commands *) VERNAC COMMAND EXTEND DeclProof [ "proof" ] -> [ vernac_decl_proof () ] END VERNAC COMMAND EXTEND DeclReturn [ "return" ] -> [ vernac_return () ] END let none_is_empty = function None -> [] | Some l -> l GEXTEND Gram GLOBAL: proof_instr; thesis : [[ "thesis" -> Plain | "thesis"; "for"; i=ident -> (For i) ]]; statement : [[ i=ident ; ":" ; c=constr -> {st_label=Name i;st_it=c} | i=ident -> {st_label=Anonymous; st_it=Topconstr.CRef (Libnames.Ident (loc, i))} | c=constr -> {st_label=Anonymous;st_it=c} ]]; constr_or_thesis : [[ t=thesis -> Thesis t ] | [ c=constr -> This c ]]; statement_or_thesis : [ [ t=thesis -> {st_label=Anonymous;st_it=Thesis t} ] | [ i=ident ; ":" ; cot=constr_or_thesis -> {st_label=Name i;st_it=cot} | i=ident -> {st_label=Anonymous; st_it=This (Topconstr.CRef (Libnames.Ident (loc, i)))} | c=constr -> {st_label=Anonymous;st_it=This c} ] ]; justification_items : [[ -> Some [] | "by"; l=LIST1 constr SEP "," -> Some l | "by"; "*" -> None ]] ; justification_method : [[ -> None | "using"; tac = tactic -> Some tac ]] ; simple_cut_or_thesis : [[ ls = statement_or_thesis; j = justification_items; taco = justification_method -> {cut_stat=ls;cut_by=j;cut_using=taco} ]] ; simple_cut : [[ ls = statement; j = justification_items; taco = justification_method -> {cut_stat=ls;cut_by=j;cut_using=taco} ]] ; elim_type: [[ IDENT "induction" -> ET_Induction | IDENT "cases" -> ET_Case_analysis ]] ; block_type : [[ IDENT "claim" -> B_claim | IDENT "focus" -> B_focus | IDENT "proof" -> B_proof | et=elim_type -> B_elim et ]] ; elim_obj: [[ IDENT "on"; c=constr -> Real c | IDENT "of"; c=simple_cut -> Virtual c ]] ; elim_step: [[ IDENT "consider" ; h=consider_vars ; IDENT "from" ; c=constr -> Pconsider (c,h) | IDENT "per"; et=elim_type; obj=elim_obj -> Pper (et,obj) | IDENT "suffices"; ls=suff_clause; j = justification_items; taco = justification_method -> Psuffices {cut_stat=ls;cut_by=j;cut_using=taco} ]] ; rew_step : [[ "~=" ; c=simple_cut -> (Rhs,c) | "=~" ; c=simple_cut -> (Lhs,c)]] ; cut_step: [[ "then"; tt=elim_step -> Pthen tt | "then"; c=simple_cut_or_thesis -> Pthen (Pcut c) | IDENT "thus"; tt=rew_step -> Pthus (let s,c=tt in Prew (s,c)) | IDENT "thus"; c=simple_cut_or_thesis -> Pthus (Pcut c) | IDENT "hence"; c=simple_cut_or_thesis -> Phence (Pcut c) | tt=elim_step -> tt | tt=rew_step -> let s,c=tt in Prew (s,c); | IDENT "have"; c=simple_cut_or_thesis -> Pcut c; | IDENT "claim"; c=statement -> Pclaim c; | IDENT "focus"; IDENT "on"; c=statement -> Pfocus c; | "end"; bt = block_type -> Pend bt; | IDENT "escape" -> Pescape ]] ; (* examiner s'il est possible de faire R _ et _ R pour R une relation qcq*) loc_id: [[ id=ident -> fun x -> (loc,(id,x)) ]]; hyp: [[ id=loc_id -> id None ; | id=loc_id ; ":" ; c=constr -> id (Some c)]] ; consider_vars: [[ name=hyp -> [Hvar name] | name=hyp; ","; v=consider_vars -> (Hvar name) :: v | name=hyp; IDENT "such"; IDENT "that"; h=consider_hyps -> (Hvar name)::h ]] ; consider_hyps: [[ st=statement; IDENT "and"; h=consider_hyps -> Hprop st::h | st=statement; IDENT "and"; IDENT "consider" ; v=consider_vars -> Hprop st::v | st=statement -> [Hprop st] ]] ; assume_vars: [[ name=hyp -> [Hvar name] | name=hyp; ","; v=assume_vars -> (Hvar name) :: v | name=hyp; IDENT "such"; IDENT "that"; h=assume_hyps -> (Hvar name)::h ]] ; assume_hyps: [[ st=statement; IDENT "and"; h=assume_hyps -> Hprop st::h | st=statement; IDENT "and"; IDENT "we"; IDENT "have" ; v=assume_vars -> Hprop st::v | st=statement -> [Hprop st] ]] ; assume_clause: [[ IDENT "we" ; IDENT "have" ; v=assume_vars -> v | h=assume_hyps -> h ]] ; suff_vars: [[ name=hyp; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> [Hvar name],c | name=hyp; ","; v=suff_vars -> let (q,c) = v in ((Hvar name) :: q),c | name=hyp; IDENT "such"; IDENT "that"; h=suff_hyps -> let (q,c) = h in ((Hvar name) :: q),c ]]; suff_hyps: [[ st=statement; IDENT "and"; h=suff_hyps -> let (q,c) = h in (Hprop st::q),c | st=statement; IDENT "and"; IDENT "to" ; IDENT "have" ; v=suff_vars -> let (q,c) = v in (Hprop st::q),c | st=statement; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> [Hprop st],c ]] ; suff_clause: [[ IDENT "to" ; IDENT "have" ; v=suff_vars -> v | h=suff_hyps -> h ]] ; let_vars: [[ name=hyp -> [Hvar name] | name=hyp; ","; v=let_vars -> (Hvar name) :: v | name=hyp; IDENT "be"; IDENT "such"; IDENT "that"; h=let_hyps -> (Hvar name)::h ]] ; let_hyps: [[ st=statement; IDENT "and"; h=let_hyps -> Hprop st::h | st=statement; IDENT "and"; "let"; v=let_vars -> Hprop st::v | st=statement -> [Hprop st] ]]; given_vars: [[ name=hyp -> [Hvar name] | name=hyp; ","; v=given_vars -> (Hvar name) :: v | name=hyp; IDENT "such"; IDENT "that"; h=given_hyps -> (Hvar name)::h ]] ; given_hyps: [[ st=statement; IDENT "and"; h=given_hyps -> Hprop st::h | st=statement; IDENT "and"; IDENT "given"; v=given_vars -> Hprop st::v | st=statement -> [Hprop st] ]]; suppose_vars: [[name=hyp -> [Hvar name] |name=hyp; ","; v=suppose_vars -> (Hvar name) :: v |name=hyp; OPT[IDENT "be"]; IDENT "such"; IDENT "that"; h=suppose_hyps -> (Hvar name)::h ]] ; suppose_hyps: [[ st=statement_or_thesis; IDENT "and"; h=suppose_hyps -> Hprop st::h | st=statement_or_thesis; IDENT "and"; IDENT "we"; IDENT "have"; v=suppose_vars -> Hprop st::v | st=statement_or_thesis -> [Hprop st] ]] ; suppose_clause: [[ IDENT "we"; IDENT "have"; v=suppose_vars -> v; | h=suppose_hyps -> h ]] ; intro_step: [[ IDENT "suppose" ; h=assume_clause -> Psuppose h | IDENT "suppose" ; IDENT "it"; IDENT "is" ; c=pattern LEVEL "0" ; po=OPT[ "with"; p=LIST1 hyp SEP ","-> p ] ; ho=OPT[ IDENT "and" ; h=suppose_clause -> h ] -> Pcase (none_is_empty po,c,none_is_empty ho) | "let" ; v=let_vars -> Plet v | IDENT "take"; witnesses = LIST1 constr SEP "," -> Ptake witnesses | IDENT "assume"; h=assume_clause -> Passume h | IDENT "given"; h=given_vars -> Pgiven h | IDENT "define"; id=ident; args=LIST0 hyp; "as"; body=constr -> Pdefine(id,args,body) | IDENT "reconsider"; id=ident; "as" ; typ=constr -> Pcast (This id,typ) | IDENT "reconsider"; t=thesis; "as" ; typ=constr -> Pcast (Thesis t ,typ) ]] ; emphasis : [[ -> 0 | "*" -> 1 | "**" -> 2 | "***" -> 3 ]] ; bare_proof_instr: [[ c = cut_step -> c ; | i = intro_step -> i ]] ; proof_instr : [[ e=emphasis;i=bare_proof_instr;"." -> {emph=e;instr=i}]] ; END;; coq-8.4pl4/plugins/decl_mode/decl_mode_plugin.mllib0000644000175000017500000000012512326224777021537 0ustar stephstephDecl_mode Decl_interp Decl_proof_instr Ppdecl_proof G_decl_mode Decl_mode_plugin_mod coq-8.4pl4/plugins/decl_mode/ppdecl_proof.ml0000644000175000017500000001434012326224777020237 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* mt () | Name id -> pr_id id ++ spc () ++ str ":" ++ spc () let pr_justification_items env = function Some [] -> mt () | Some (_::_ as l) -> spc () ++ str "by" ++ spc () ++ prlist_with_sep (fun () -> str ",") (pr_constr env) l | None -> spc () ++ str "by *" let pr_justification_method env = function None -> mt () | Some tac -> spc () ++ str "using" ++ spc () ++ pr_tac env tac let pr_statement pr_it env st = pr_label st.st_label ++ pr_it env st.st_it let pr_or_thesis pr_this env = function Thesis Plain -> str "thesis" | Thesis (For id) -> str "thesis" ++ spc() ++ str "for" ++ spc () ++ pr_id id | This c -> pr_this env c let pr_cut pr_it env c = hov 1 (pr_it env c.cut_stat) ++ pr_justification_items env c.cut_by ++ pr_justification_method env c.cut_using let type_or_thesis = function Thesis _ -> Term.mkProp | This c -> c let _I x = x let rec print_hyps pconstr gtyp env sep _be _have hyps = let pr_sep = if sep then str "and" ++ spc () else mt () in match hyps with (Hvar _ ::_) as rest -> spc () ++ pr_sep ++ str _have ++ print_vars pconstr gtyp env false _be _have rest | Hprop st :: rest -> begin let nenv = match st.st_label with Anonymous -> env | Name id -> Environ.push_named (id,None,gtyp st.st_it) env in spc() ++ pr_sep ++ pr_statement pconstr env st ++ print_hyps pconstr gtyp nenv true _be _have rest end | [] -> mt () and print_vars pconstr gtyp env sep _be _have vars = match vars with Hvar st :: rest -> begin let nenv = match st.st_label with Anonymous -> anomaly "anonymous variable" | Name id -> Environ.push_named (id,None,st.st_it) env in let pr_sep = if sep then pr_comma () else mt () in spc() ++ pr_sep ++ pr_statement pr_constr env st ++ print_vars pconstr gtyp nenv true _be _have rest end | (Hprop _ :: _) as rest -> let _st = if _be then str "be such that" else str "such that" in spc() ++ _st ++ print_hyps pconstr gtyp env false _be _have rest | [] -> mt () let pr_suffices_clause env (hyps,c) = print_hyps pr_constr _I env false false "to have" hyps ++ spc () ++ str "to show" ++ spc () ++ pr_or_thesis pr_constr env c let pr_elim_type = function ET_Case_analysis -> str "cases" | ET_Induction -> str "induction" let pr_casee env =function Real c -> str "on" ++ spc () ++ pr_constr env c | Virtual cut -> str "of" ++ spc () ++ pr_cut (pr_statement pr_constr) env cut let pr_side = function Lhs -> str "=~" | Rhs -> str "~=" let rec pr_bare_proof_instr _then _thus env = function | Pescape -> str "escape" | Pthen i -> pr_bare_proof_instr true _thus env i | Pthus i -> pr_bare_proof_instr _then true env i | Phence i -> pr_bare_proof_instr true true env i | Pcut c -> begin match _then,_thus with false,false -> str "have" ++ spc () ++ pr_cut (pr_statement (pr_or_thesis pr_constr)) env c | false,true -> str "thus" ++ spc () ++ pr_cut (pr_statement (pr_or_thesis pr_constr)) env c | true,false -> str "then" ++ spc () ++ pr_cut (pr_statement (pr_or_thesis pr_constr)) env c | true,true -> str "hence" ++ spc () ++ pr_cut (pr_statement (pr_or_thesis pr_constr)) env c end | Psuffices c -> str "suffices" ++ pr_cut pr_suffices_clause env c | Prew (sid,c) -> (if _thus then str "thus" else str " ") ++ spc () ++ pr_side sid ++ spc () ++ pr_cut (pr_statement pr_constr) env c | Passume hyps -> str "assume" ++ print_hyps pr_constr _I env false false "we have" hyps | Plet hyps -> str "let" ++ print_vars pr_constr _I env false true "let" hyps | Pclaim st -> str "claim" ++ spc () ++ pr_statement pr_constr env st | Pfocus st -> str "focus on" ++ spc () ++ pr_statement pr_constr env st | Pconsider (id,hyps) -> str "consider" ++ print_vars pr_constr _I env false false "consider" hyps ++ spc () ++ str "from " ++ pr_constr env id | Pgiven hyps -> str "given" ++ print_vars pr_constr _I env false false "given" hyps | Ptake witl -> str "take" ++ spc () ++ prlist_with_sep pr_comma (pr_constr env) witl | Pdefine (id,args,body) -> str "define" ++ spc () ++ pr_id id ++ spc () ++ prlist_with_sep spc (fun st -> str "(" ++ pr_statement pr_constr env st ++ str ")") args ++ spc () ++ str "as" ++ (pr_constr env body) | Pcast (id,typ) -> str "reconsider" ++ spc () ++ pr_or_thesis (fun _ -> pr_id) env id ++ spc () ++ str "as" ++ spc () ++ (pr_constr env typ) | Psuppose hyps -> str "suppose" ++ print_hyps pr_constr _I env false false "we have" hyps | Pcase (params,pat,hyps) -> str "suppose it is" ++ spc () ++ pr_pat pat ++ (if params = [] then mt () else (spc () ++ str "with" ++ spc () ++ prlist_with_sep spc (fun st -> str "(" ++ pr_statement pr_constr env st ++ str ")") params ++ spc ())) ++ (if hyps = [] then mt () else (spc () ++ str "and" ++ print_hyps (pr_or_thesis pr_constr) type_or_thesis env false false "we have" hyps)) | Pper (et,c) -> str "per" ++ spc () ++ pr_elim_type et ++ spc () ++ pr_casee env c | Pend (B_elim et) -> str "end" ++ spc () ++ pr_elim_type et | _ -> anomaly "unprintable instruction" let pr_emph = function 0 -> str " " | 1 -> str "* " | 2 -> str "** " | 3 -> str "*** " | _ -> anomaly "unknown emphasis" let pr_proof_instr env instr = pr_emph instr.emph ++ spc () ++ pr_bare_proof_instr false false env instr.instr coq-8.4pl4/plugins/decl_mode/decl_proof_instr.ml0000644000175000017500000013065212326224777021123 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (!strictness)),(fun b -> strictness:=b) let _ = declare_bool_option { optsync = true; optdepr = false; optname = "strict mode"; optkey = ["Strict";"Proofs"]; optread = get_strictness; optwrite = set_strictness } let tcl_change_info_gen info_gen = (fun gls -> let concl = pf_concl gls in let hyps = Goal.V82.hyps (project gls) (sig_it gls) in let extra = Goal.V82.extra (project gls) (sig_it gls) in let (gl,ev,sigma) = Goal.V82.mk_goal (project gls) hyps concl (info_gen extra) in let sigma = Goal.V82.partial_solution sigma (sig_it gls) ev in { it = [gl] ; sigma= sigma } ) open Store.Field let tcl_change_info info gls = let info_gen = Decl_mode.info.set info in tcl_change_info_gen info_gen gls let tcl_erase_info gls = tcl_change_info_gen (Decl_mode.info.remove) gls let special_whd gl= let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in (fun t -> Closure.whd_val infos (Closure.inject t)) let special_nf gl= let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in (fun t -> Closure.norm_val infos (Closure.inject t)) let is_good_inductive env ind = let mib,oib = Inductive.lookup_mind_specif env ind in oib.mind_nrealargs = 0 && not (Inductiveops.mis_is_recursive (ind,mib,oib)) let check_not_per pts = if not (Proof.is_done pts) then match get_stack pts with Per (_,_,_,_)::_ -> error "You are inside a proof per cases/induction.\n\ Please \"suppose\" something or \"end\" it now." | _ -> () let mk_evd metalist gls = let evd0= create_goal_evar_defs (sig_sig gls) in let add_one (meta,typ) evd = meta_declare meta typ evd in List.fold_right add_one metalist evd0 let is_tmp id = (string_of_id id).[0] = '_' let tmp_ids gls = let ctx = pf_hyps gls in match ctx with [] -> [] | _::q -> List.filter is_tmp (ids_of_named_context q) let clean_tmp gls = let clean_id id0 gls0 = tclTRY (clear [id0]) gls0 in let rec clean_all = function [] -> tclIDTAC | id :: rest -> tclTHEN (clean_id id) (clean_all rest) in clean_all (tmp_ids gls) gls let assert_postpone id t = assert_tac (Name id) t (* start a proof *) let start_proof_tac gls= let info={pm_stack=[]} in tcl_change_info info gls let go_to_proof_mode () = Pfedit.by start_proof_tac; let p = Proof_global.give_me_the_proof () in Decl_mode.focus p (* closing gaps *) let daimon_tac gls = set_daimon_flag (); {it=[];sigma=sig_sig gls} (* marking closed blocks *) let rec is_focussing_instr = function Pthus i | Pthen i | Phence i -> is_focussing_instr i | Pescape | Pper _ | Pclaim _ | Pfocus _ | Psuppose _ | Pcase (_,_,_) -> true | _ -> false let mark_rule_as_done = function Decl_proof true -> Decl_proof false | Decl_proof false -> anomaly "already marked as done" | _ -> anomaly "mark_rule_as_done" (* post-instruction focus management *) (* spiwack: This used to fail if there was no focusing command above, but I don't think it ever happened. I hope it doesn't mess things up*) let goto_current_focus pts = Decl_mode.maximal_unfocus pts let goto_current_focus_or_top pts = goto_current_focus pts (* return *) let close_tactic_mode pts = try goto_current_focus pts with Not_found -> error "\"return\" cannot be used outside of Declarative Proof Mode." let return_from_tactic_mode () = close_tactic_mode (Proof_global.give_me_the_proof ()) (* end proof/claim *) let close_block bt pts = if Proof.no_focused_goal pts then goto_current_focus pts else let stack = if Proof.is_done pts then get_top_stack pts else get_stack pts in match bt,stack with B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] -> (goto_current_focus pts) | _, Claim::_ -> error "\"end claim\" expected." | _, Focus_claim::_ -> error "\"end focus\" expected." | _, [] -> error "\"end proof\" expected." | _, (Per (et,_,_,_)::_|Suppose_case::Per (et,_,_,_)::_) -> begin match et with ET_Case_analysis -> error "\"end cases\" expected." | ET_Induction -> error "\"end induction\" expected." end | _,_ -> anomaly "Lonely suppose on stack." (* utility for suppose / suppose it is *) let close_previous_case pts = if Proof.is_done pts then match get_top_stack pts with Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..." | Suppose_case :: Per (et,_,_,_) :: _ -> goto_current_focus (pts) | _ -> error "Not inside a proof per cases or induction." else match get_stack pts with Per (et,_,_,_) :: _ -> () | Suppose_case :: Per (et,_,_,_) :: _ -> goto_current_focus ((pts)) | _ -> error "Not inside a proof per cases or induction." (* Proof instructions *) (* automation *) let filter_hyps f gls = let filter_aux (id,_,_) = if f id then tclIDTAC else tclTRY (clear [id]) in tclMAP filter_aux (pf_hyps gls) gls let local_hyp_prefix = id_of_string "___" let add_justification_hyps keep items gls = let add_aux c gls= match kind_of_term c with Var id -> keep:=Idset.add id !keep; tclIDTAC gls | _ -> let id=pf_get_new_id local_hyp_prefix gls in keep:=Idset.add id !keep; tclTHEN (letin_tac None (Names.Name id) c None Tacexpr.nowhere) (thin_body [id]) gls in tclMAP add_aux items gls let prepare_goal items gls = let tokeep = ref Idset.empty in let auxres = add_justification_hyps tokeep items gls in tclTHENLIST [ (fun _ -> auxres); filter_hyps (let keep = !tokeep in fun id -> Idset.mem id keep)] gls let my_automation_tac = ref (fun gls -> anomaly "No automation registered") let register_automation_tac tac = my_automation_tac:= tac let automation_tac gls = !my_automation_tac gls let justification tac gls= tclORELSE (tclSOLVE [tclTHEN tac assumption]) (fun gls -> if get_strictness () then error "Insufficient justification." else begin msg_warning (str "Insufficient justification."); daimon_tac gls end) gls let default_justification elems gls= justification (tclTHEN (prepare_goal elems) automation_tac) gls (* code for conclusion refining *) let constant dir s = lazy (Coqlib.gen_constant "Declarative" dir s) let _and = constant ["Init";"Logic"] "and" let _and_rect = constant ["Init";"Logic"] "and_rect" let _prod = constant ["Init";"Datatypes"] "prod" let _prod_rect = constant ["Init";"Datatypes"] "prod_rect" let _ex = constant ["Init";"Logic"] "ex" let _ex_ind = constant ["Init";"Logic"] "ex_ind" let _sig = constant ["Init";"Specif"] "sig" let _sig_rect = constant ["Init";"Specif"] "sig_rect" let _sigT = constant ["Init";"Specif"] "sigT" let _sigT_rect = constant ["Init";"Specif"] "sigT_rect" type stackd_elt = {se_meta:metavariable; se_type:types; se_last_meta:metavariable; se_meta_list:(metavariable*types) list; se_evd: evar_map} let rec replace_in_list m l = function [] -> raise Not_found | c::q -> if m=fst c then l@q else c::replace_in_list m l q let enstack_subsubgoals env se stack gls= let hd,params = decompose_app (special_whd gls se.se_type) in match kind_of_term hd with Ind ind when is_good_inductive env ind -> let mib,oib= Inductive.lookup_mind_specif env ind in let gentypes= Inductive.arities_of_constructors ind (mib,oib) in let process i gentyp = let constructor = mkConstruct(ind,succ i) (* constructors numbering*) in let appterm = applist (constructor,params) in let apptype = Term.prod_applist gentyp params in let rc,_ = Reduction.dest_prod env apptype in let rec meta_aux last lenv = function [] -> (last,lenv,[]) | (nam,_,typ)::q -> let nlast=succ last in let (llast,holes,metas) = meta_aux nlast (mkMeta nlast :: lenv) q in (llast,holes,(nlast,special_nf gls (substl lenv typ))::metas) in let (nlast,holes,nmetas) = meta_aux se.se_last_meta [] (List.rev rc) in let refiner = applist (appterm,List.rev holes) in let evd = meta_assign se.se_meta (refiner,(Conv,TypeProcessed (* ? *))) se.se_evd in let ncreated = replace_in_list se.se_meta nmetas se.se_meta_list in let evd0 = List.fold_left (fun evd (m,typ) -> meta_declare m typ evd) evd nmetas in List.iter (fun (m,typ) -> Stack.push {se_meta=m; se_type=typ; se_evd=evd0; se_meta_list=ncreated; se_last_meta=nlast} stack) (List.rev nmetas) in Array.iteri process gentypes | _ -> () let rec nf_list evd = function [] -> [] | (m,typ)::others -> if meta_defined evd m then nf_list evd others else (m,nf_meta evd typ)::nf_list evd others let find_subsubgoal c ctyp skip submetas gls = let env= pf_env gls in let concl = pf_concl gls in let evd = mk_evd ((0,concl)::submetas) gls in let stack = Stack.create () in let max_meta = List.fold_left (fun a (m,_) -> max a m) 0 submetas in let _ = Stack.push {se_meta=0; se_type=concl; se_last_meta=max_meta; se_meta_list=[0,concl]; se_evd=evd} stack in let rec dfs n = let se = Stack.pop stack in try let unifier = Unification.w_unify env se.se_evd Reduction.CUMUL ~flags:Unification.elim_flags ctyp se.se_type in if n <= 0 then {se with se_evd=meta_assign se.se_meta (c,(Conv,TypeNotProcessed (* ?? *))) unifier; se_meta_list=replace_in_list se.se_meta submetas se.se_meta_list} else dfs (pred n) with e when Errors.noncritical e -> begin enstack_subsubgoals env se stack gls; dfs n end in let nse= try dfs skip with Stack.Empty -> raise Not_found in nf_list nse.se_evd nse.se_meta_list,nf_meta nse.se_evd (mkMeta 0) let concl_refiner metas body gls = let concl = pf_concl gls in let evd = sig_sig gls in let env = pf_env gls in let sort = family_of_sort (Typing.sort_of env evd concl) in let rec aux env avoid subst = function [] -> anomaly "concl_refiner: cannot happen" | (n,typ)::rest -> let _A = subst_meta subst typ in let x = id_of_name_using_hdchar env _A Anonymous in let _x = fresh_id avoid x gls in let nenv = Environ.push_named (_x,None,_A) env in let asort = family_of_sort (Typing.sort_of nenv evd _A) in let nsubst = (n,mkVar _x)::subst in if rest = [] then asort,_A,mkNamedLambda _x _A (subst_meta nsubst body) else let bsort,_B,nbody = aux nenv (_x::avoid) ((n,mkVar _x)::subst) rest in let body = mkNamedLambda _x _A nbody in if occur_term (mkVar _x) _B then begin let _P = mkNamedLambda _x _A _B in match bsort,sort with InProp,InProp -> let _AxB = mkApp(Lazy.force _ex,[|_A;_P|]) in InProp,_AxB, mkApp(Lazy.force _ex_ind,[|_A;_P;concl;body|]) | InProp,_ -> let _AxB = mkApp(Lazy.force _sig,[|_A;_P|]) in let _P0 = mkLambda(Anonymous,_AxB,concl) in InType,_AxB, mkApp(Lazy.force _sig_rect,[|_A;_P;_P0;body|]) | _,_ -> let _AxB = mkApp(Lazy.force _sigT,[|_A;_P|]) in let _P0 = mkLambda(Anonymous,_AxB,concl) in InType,_AxB, mkApp(Lazy.force _sigT_rect,[|_A;_P;_P0;body|]) end else begin match asort,bsort with InProp,InProp -> let _AxB = mkApp(Lazy.force _and,[|_A;_B|]) in InProp,_AxB, mkApp(Lazy.force _and_rect,[|_A;_B;concl;body|]) |_,_ -> let _AxB = mkApp(Lazy.force _prod,[|_A;_B|]) in let _P0 = mkLambda(Anonymous,_AxB,concl) in InType,_AxB, mkApp(Lazy.force _prod_rect,[|_A;_B;_P0;body|]) end in let (_,_,prf) = aux env [] [] metas in mkApp(prf,[|mkMeta 1|]) let thus_tac c ctyp submetas gls = let list,proof = try find_subsubgoal c ctyp 0 submetas gls with Not_found -> error "I could not relate this statement to the thesis." in if list = [] then exact_check proof gls else let refiner = concl_refiner list proof gls in Tactics.refine refiner gls (* general forward step *) let mk_stat_or_thesis info gls = function This c -> c | Thesis (For _ ) -> error "\"thesis for ...\" is not applicable here." | Thesis Plain -> pf_concl gls let just_tac _then cut info gls0 = let last_item = if _then then let last_id = try get_last (pf_env gls0) with Failure _ -> error "\"then\" and \"hence\" require at least one previous fact" in [mkVar last_id] else [] in let items_tac gls = match cut.cut_by with None -> tclIDTAC gls | Some items -> prepare_goal (last_item@items) gls in let method_tac gls = match cut.cut_using with None -> automation_tac gls | Some tac -> (Tacinterp.eval_tactic tac) gls in justification (tclTHEN items_tac method_tac) gls0 let instr_cut mkstat _thus _then cut gls0 = let info = get_its_info gls0 in let stat = cut.cut_stat in let (c_id,_) = match stat.st_label with Anonymous -> pf_get_new_id (id_of_string "_fact") gls0,false | Name id -> id,true in let c_stat = mkstat info gls0 stat.st_it in let thus_tac gls= if _thus then thus_tac (mkVar c_id) c_stat [] gls else tclIDTAC gls in tclTHENS (assert_postpone c_id c_stat) [tclTHEN tcl_erase_info (just_tac _then cut info); thus_tac] gls0 (* iterated equality *) let _eq = Libnames.constr_of_global (Coqlib.glob_eq) let decompose_eq id gls = let typ = pf_get_hyp_typ gls id in let whd = (special_whd gls typ) in match kind_of_term whd with App (f,args)-> if eq_constr f _eq && (Array.length args)=3 then (args.(0), args.(1), args.(2)) else error "Previous step is not an equality." | _ -> error "Previous step is not an equality." let instr_rew _thus rew_side cut gls0 = let last_id = try get_last (pf_env gls0) with e when Errors.noncritical e -> error "No previous equality." in let typ,lhs,rhs = decompose_eq last_id gls0 in let items_tac gls = match cut.cut_by with None -> tclIDTAC gls | Some items -> prepare_goal items gls in let method_tac gls = match cut.cut_using with None -> automation_tac gls | Some tac -> (Tacinterp.eval_tactic tac) gls in let just_tac gls = justification (tclTHEN items_tac method_tac) gls in let (c_id,_) = match cut.cut_stat.st_label with Anonymous -> pf_get_new_id (id_of_string "_eq") gls0,false | Name id -> id,true in let thus_tac new_eq gls= if _thus then thus_tac (mkVar c_id) new_eq [] gls else tclIDTAC gls in match rew_side with Lhs -> let new_eq = mkApp(_eq,[|typ;cut.cut_stat.st_it;rhs|]) in tclTHENS (assert_postpone c_id new_eq) [tclTHEN tcl_erase_info (tclTHENS (transitivity lhs) [just_tac;exact_check (mkVar last_id)]); thus_tac new_eq] gls0 | Rhs -> let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in tclTHENS (assert_postpone c_id new_eq) [tclTHEN tcl_erase_info (tclTHENS (transitivity rhs) [exact_check (mkVar last_id);just_tac]); thus_tac new_eq] gls0 (* tactics for claim/focus *) let instr_claim _thus st gls0 = let info = get_its_info gls0 in let (id,_) = match st.st_label with Anonymous -> pf_get_new_id (id_of_string "_claim") gls0,false | Name id -> id,true in let thus_tac gls= if _thus then thus_tac (mkVar id) st.st_it [] gls else tclIDTAC gls in let ninfo1 = {pm_stack= (if _thus then Focus_claim else Claim)::info.pm_stack} in tclTHENS (assert_postpone id st.st_it) [thus_tac; tcl_change_info ninfo1] gls0 (* tactics for assume *) let push_intro_tac coerce nam gls = let (hid,_) = match nam with Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false | Name id -> id,true in tclTHENLIST [intro_mustbe_force hid; coerce hid] gls let assume_tac hyps gls = List.fold_right (fun (Hvar st | Hprop st) -> tclTHEN (push_intro_tac (fun id -> convert_hyp (id,None,st.st_it)) st.st_label)) hyps tclIDTAC gls let assume_hyps_or_theses hyps gls = List.fold_right (function (Hvar {st_label=nam;st_it=c} | Hprop {st_label=nam;st_it=This c}) -> tclTHEN (push_intro_tac (fun id -> convert_hyp (id,None,c)) nam) | Hprop {st_label=nam;st_it=Thesis (tk)} -> tclTHEN (push_intro_tac (fun id -> tclIDTAC) nam)) hyps tclIDTAC gls let assume_st hyps gls = List.fold_right (fun st -> tclTHEN (push_intro_tac (fun id -> convert_hyp (id,None,st.st_it)) st.st_label)) hyps tclIDTAC gls let assume_st_letin hyps gls = List.fold_right (fun st -> tclTHEN (push_intro_tac (fun id -> convert_hyp (id,Some (fst st.st_it),snd st.st_it)) st.st_label)) hyps tclIDTAC gls (* suffices *) let rec metas_from n hyps = match hyps with _ :: q -> n :: metas_from (succ n) q | [] -> [] let rec build_product args body = match args with (Hprop st| Hvar st )::rest -> let pprod= lift 1 (build_product rest body) in let lbody = match st.st_label with Anonymous -> pprod | Name id -> subst_term (mkVar id) pprod in mkProd (st.st_label, st.st_it, lbody) | [] -> body let rec build_applist prod = function [] -> [],prod | n::q -> let (_,typ,_) = destProd prod in let ctx,head = build_applist (Term.prod_applist prod [mkMeta n]) q in (n,typ)::ctx,head let instr_suffices _then cut gls0 = let info = get_its_info gls0 in let c_id = pf_get_new_id (id_of_string "_cofact") gls0 in let ctx,hd = cut.cut_stat in let c_stat = build_product ctx (mk_stat_or_thesis info gls0 hd) in let metas = metas_from 1 ctx in let c_ctx,c_head = build_applist c_stat metas in let c_term = applist (mkVar c_id,List.map mkMeta metas) in let thus_tac gls= thus_tac c_term c_head c_ctx gls in tclTHENS (assert_postpone c_id c_stat) [tclTHENLIST [ assume_tac ctx; tcl_erase_info; just_tac _then cut info]; thus_tac] gls0 (* tactics for consider/given *) let conjunction_arity id gls = let typ = pf_get_hyp_typ gls id in let hd,params = decompose_app (special_whd gls typ) in let env =pf_env gls in match kind_of_term hd with Ind ind when is_good_inductive env ind -> let mib,oib= Inductive.lookup_mind_specif env ind in let gentypes= Inductive.arities_of_constructors ind (mib,oib) in let _ = if Array.length gentypes <> 1 then raise Not_found in let apptype = Term.prod_applist gentypes.(0) params in let rc,_ = Reduction.dest_prod env apptype in List.length rc | _ -> raise Not_found let rec intron_then n ids ltac gls = if n<=0 then ltac ids gls else let id = pf_get_new_id (id_of_string "_tmp") gls in tclTHEN (intro_mustbe_force id) (intron_then (pred n) (id::ids) ltac) gls let rec consider_match may_intro introduced available expected gls = match available,expected with [],[] -> tclIDTAC gls | _,[] -> error "Last statements do not match a complete hypothesis." (* should tell which ones *) | [],hyps -> if may_intro then begin let id = pf_get_new_id (id_of_string "_tmp") gls in tclIFTHENELSE (intro_mustbe_force id) (consider_match true [] [id] hyps) (fun _ -> error "Not enough sub-hypotheses to match statements.") gls end else error "Not enough sub-hypotheses to match statements." (* should tell which ones *) | id::rest_ids,(Hvar st | Hprop st)::rest -> tclIFTHENELSE (convert_hyp (id,None,st.st_it)) begin match st.st_label with Anonymous -> consider_match may_intro ((id,false)::introduced) rest_ids rest | Name hid -> tclTHENLIST [rename_hyp [id,hid]; consider_match may_intro ((hid,true)::introduced) rest_ids rest] end begin (fun gls -> let nhyps = try conjunction_arity id gls with Not_found -> error "Matching hypothesis not found." in tclTHENLIST [general_case_analysis false (mkVar id,NoBindings); intron_then nhyps [] (fun l -> consider_match may_intro introduced (List.rev_append l rest_ids) expected)] gls) end gls let consider_tac c hyps gls = match kind_of_term (strip_outer_cast c) with Var id -> consider_match false [] [id] hyps gls | _ -> let id = pf_get_new_id (id_of_string "_tmp") gls in tclTHEN (forward None (Some (dummy_loc, Genarg.IntroIdentifier id)) c) (consider_match false [] [id] hyps) gls let given_tac hyps gls = consider_match true [] [] hyps gls (* tactics for take *) let rec take_tac wits gls = match wits with [] -> tclIDTAC gls | wit::rest -> let typ = pf_type_of gls wit in tclTHEN (thus_tac wit typ []) (take_tac rest) gls (* tactics for define *) let rec build_function args body = match args with st::rest -> let pfun= lift 1 (build_function rest body) in let id = match st.st_label with Anonymous -> assert false | Name id -> id in mkLambda (Name id, st.st_it, subst_term (mkVar id) pfun) | [] -> body let define_tac id args body gls = let t = build_function args body in letin_tac None (Name id) t None Tacexpr.nowhere gls (* tactics for reconsider *) let cast_tac id_or_thesis typ gls = match id_or_thesis with This id -> let (_,body,_) = pf_get_hyp gls id in convert_hyp (id,body,typ) gls | Thesis (For _ ) -> error "\"thesis for ...\" is not applicable here." | Thesis Plain -> convert_concl typ DEFAULTcast gls (* per cases *) let is_rec_pos (main_ind,wft) = match main_ind with None -> false | Some index -> match fst (Rtree.dest_node wft) with Mrec (_,i) when i = index -> true | _ -> false let rec constr_trees (main_ind,wft) ind = match Rtree.dest_node wft with Norec,_ -> let itree = (snd (Global.lookup_inductive ind)).mind_recargs in constr_trees (None,itree) ind | _,constrs -> main_ind,constrs let ind_args rp ind = let main_ind,constrs = constr_trees rp ind in let args ctree = Array.map (fun t -> main_ind,t) (snd (Rtree.dest_node ctree)) in Array.map args constrs let init_tree ids ind rp nexti = let indargs = ind_args rp ind in let do_i i arp = (Array.map is_rec_pos arp),nexti i arp in Split_patt (ids,ind,Array.mapi do_i indargs) let map_tree_rp rp id_fun mapi = function Split_patt (ids,ind,branches) -> let indargs = ind_args rp ind in let do_i i (recargs,bri) = recargs,mapi i indargs.(i) bri in Split_patt (id_fun ids,ind,Array.mapi do_i branches) | _ -> failwith "map_tree_rp: not a splitting node" let map_tree id_fun mapi = function Split_patt (ids,ind,branches) -> let do_i i (recargs,bri) = recargs,mapi i bri in Split_patt (id_fun ids,ind,Array.mapi do_i branches) | _ -> failwith "map_tree: not a splitting node" let start_tree env ind rp = init_tree Idset.empty ind rp (fun _ _ -> None) let build_per_info etype casee gls = let concl=pf_concl gls in let env=pf_env gls in let ctyp=pf_type_of gls casee in let is_dep = dependent casee concl in let hd,args = decompose_app (special_whd gls ctyp) in let ind = try destInd hd with e when Errors.noncritical e -> error "Case analysis must be done on an inductive object." in let mind,oind = Global.lookup_inductive ind in let nparams,index = match etype with ET_Induction -> mind.mind_nparams_rec,Some (snd ind) | _ -> mind.mind_nparams,None in let params,real_args = list_chop nparams args in let abstract_obj c body = let typ=pf_type_of gls c in lambda_create env (typ,subst_term c body) in let pred= List.fold_right abstract_obj real_args (lambda_create env (ctyp,subst_term casee concl)) in is_dep, {per_casee=casee; per_ctype=ctyp; per_ind=ind; per_pred=pred; per_args=real_args; per_params=params; per_nparams=nparams; per_wf=index,oind.mind_recargs} let per_tac etype casee gls= let env=pf_env gls in let info = get_its_info gls in match casee with Real c -> let is_dep,per_info = build_per_info etype c gls in let ek = if is_dep then EK_dep (start_tree env per_info.per_ind per_info.per_wf) else EK_unknown in tcl_change_info {pm_stack= Per(etype,per_info,ek,[])::info.pm_stack} gls | Virtual cut -> assert (cut.cut_stat.st_label=Anonymous); let id = pf_get_new_id (id_of_string "anonymous_matched") gls in let c = mkVar id in let modified_cut = {cut with cut_stat={cut.cut_stat with st_label=Name id}} in tclTHEN (instr_cut (fun _ _ c -> c) false false modified_cut) (fun gls0 -> let is_dep,per_info = build_per_info etype c gls0 in assert (not is_dep); tcl_change_info {pm_stack= Per(etype,per_info,EK_unknown,[])::info.pm_stack} gls0) gls (* suppose *) let register_nodep_subcase id= function Per(et,pi,ek,clauses)::s -> begin match ek with EK_unknown -> clauses,Per(et,pi,EK_nodep,id::clauses)::s | EK_nodep -> clauses,Per(et,pi,EK_nodep,id::clauses)::s | EK_dep _ -> error "Do not mix \"suppose\" with \"suppose it is\"." end | _ -> anomaly "wrong stack state" let suppose_tac hyps gls0 = let info = get_its_info gls0 in let thesis = pf_concl gls0 in let id = pf_get_new_id (id_of_string "subcase_") gls0 in let clause = build_product hyps thesis in let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in let old_clauses,stack = register_nodep_subcase id info.pm_stack in let ninfo2 = {pm_stack=stack} in tclTHENS (assert_postpone id clause) [tclTHENLIST [tcl_change_info ninfo1; assume_tac hyps; clear old_clauses]; tcl_change_info ninfo2] gls0 (* suppose it is ... *) (* pattern matching compiling *) let rec skip_args rest ids n = if n <= 0 then Close_patt rest else Skip_patt (ids,skip_args rest ids (pred n)) let rec tree_of_pats ((id,_) as cpl) pats = match pats with [] -> End_patt cpl | args::stack -> match args with [] -> Close_patt (tree_of_pats cpl stack) | (patt,rp) :: rest_args -> match patt with PatVar (_,v) -> Skip_patt (Idset.singleton id, tree_of_pats cpl (rest_args::stack)) | PatCstr (_,(ind,cnum),args,nam) -> let nexti i ati = if i = pred cnum then let nargs = list_map_i (fun j a -> (a,ati.(j))) 0 args in Some (Idset.singleton id, tree_of_pats cpl (nargs::rest_args::stack)) else None in init_tree Idset.empty ind rp nexti let rec add_branch ((id,_) as cpl) pats tree= match pats with [] -> begin match tree with End_patt cpl0 -> End_patt cpl0 (* this ensures precedence for overlapping patterns *) | _ -> anomaly "tree is expected to end here" end | args::stack -> match args with [] -> begin match tree with Close_patt t -> Close_patt (add_branch cpl stack t) | _ -> anomaly "we should pop here" end | (patt,rp) :: rest_args -> match patt with PatVar (_,v) -> begin match tree with Skip_patt (ids,t) -> Skip_patt (Idset.add id ids, add_branch cpl (rest_args::stack) t) | Split_patt (_,_,_) -> map_tree (Idset.add id) (fun i bri -> append_branch cpl 1 (rest_args::stack) bri) tree | _ -> anomaly "No pop/stop expected here" end | PatCstr (_,(ind,cnum),args,nam) -> match tree with Skip_patt (ids,t) -> let nexti i ati = if i = pred cnum then let nargs = list_map_i (fun j a -> (a,ati.(j))) 0 args in Some (Idset.add id ids, add_branch cpl (nargs::rest_args::stack) (skip_args t ids (Array.length ati))) else Some (ids, skip_args t ids (Array.length ati)) in init_tree ids ind rp nexti | Split_patt (_,ind0,_) -> if (ind <> ind0) then error (* this can happen with coercions *) "Case pattern belongs to wrong inductive type."; let mapi i ati bri = if i = pred cnum then let nargs = list_map_i (fun j a -> (a,ati.(j))) 0 args in append_branch cpl 0 (nargs::rest_args::stack) bri else bri in map_tree_rp rp (fun ids -> ids) mapi tree | _ -> anomaly "No pop/stop expected here" and append_branch ((id,_) as cpl) depth pats = function Some (ids,tree) -> Some (Idset.add id ids,append_tree cpl depth pats tree) | None -> Some (Idset.singleton id,tree_of_pats cpl pats) and append_tree ((id,_) as cpl) depth pats tree = if depth<=0 then add_branch cpl pats tree else match tree with Close_patt t -> Close_patt (append_tree cpl (pred depth) pats t) | Skip_patt (ids,t) -> Skip_patt (Idset.add id ids,append_tree cpl depth pats t) | End_patt _ -> anomaly "Premature end of branch" | Split_patt (_,_,_) -> map_tree (Idset.add id) (fun i bri -> append_branch cpl (succ depth) pats bri) tree (* suppose it is *) let rec st_assoc id = function [] -> raise Not_found | st::_ when st.st_label = id -> st.st_it | _ :: rest -> st_assoc id rest let thesis_for obj typ per_info env= let rc,hd1=decompose_prod typ in let cind,all_args=decompose_app typ in let ind = destInd cind in let _ = if ind <> per_info.per_ind then errorlabstrm "thesis_for" ((Printer.pr_constr_env env obj) ++ spc () ++ str"cannot give an induction hypothesis (wrong inductive type).") in let params,args = list_chop per_info.per_nparams all_args in let _ = if not (List.for_all2 eq_constr params per_info.per_params) then errorlabstrm "thesis_for" ((Printer.pr_constr_env env obj) ++ spc () ++ str "cannot give an induction hypothesis (wrong parameters).") in let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in compose_prod rc (whd_beta Evd.empty hd2) let rec build_product_dep pat_info per_info args body gls = match args with (Hprop {st_label=nam;st_it=This c} | Hvar {st_label=nam;st_it=c})::rest -> let pprod= lift 1 (build_product_dep pat_info per_info rest body gls) in let lbody = match nam with Anonymous -> body | Name id -> subst_var id pprod in mkProd (nam,c,lbody) | Hprop ({st_it=Thesis tk} as st)::rest -> let pprod= lift 1 (build_product_dep pat_info per_info rest body gls) in let lbody = match st.st_label with Anonymous -> body | Name id -> subst_var id pprod in let ptyp = match tk with For id -> let obj = mkVar id in let typ = try st_assoc (Name id) pat_info.pat_vars with Not_found -> snd (st_assoc (Name id) pat_info.pat_aliases) in thesis_for obj typ per_info (pf_env gls) | Plain -> pf_concl gls in mkProd (st.st_label,ptyp,lbody) | [] -> body let build_dep_clause params pat_info per_info hyps gls = let concl= thesis_for pat_info.pat_constr pat_info.pat_typ per_info (pf_env gls) in let open_clause = build_product_dep pat_info per_info hyps concl gls in let prod_one st body = match st.st_label with Anonymous -> mkProd(Anonymous,st.st_it,lift 1 body) | Name id -> mkNamedProd id st.st_it (lift 1 body) in let let_one_in st body = match st.st_label with Anonymous -> mkLetIn(Anonymous,fst st.st_it,snd st.st_it,lift 1 body) | Name id -> mkNamedLetIn id (fst st.st_it) (snd st.st_it) (lift 1 body) in let aliased_clause = List.fold_right let_one_in pat_info.pat_aliases open_clause in List.fold_right prod_one (params@pat_info.pat_vars) aliased_clause let rec register_dep_subcase id env per_info pat = function EK_nodep -> error "Only \"suppose it is\" can be used here." | EK_unknown -> register_dep_subcase id env per_info pat (EK_dep (start_tree env per_info.per_ind per_info.per_wf)) | EK_dep tree -> EK_dep (add_branch id [[pat,per_info.per_wf]] tree) let case_tac params pat_info hyps gls0 = let info = get_its_info gls0 in let id = pf_get_new_id (id_of_string "subcase_") gls0 in let et,per_info,ek,old_clauses,rest = match info.pm_stack with Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest) | _ -> anomaly "wrong place for cases" in let clause = build_dep_clause params pat_info per_info hyps gls0 in let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in let nek = register_dep_subcase (id,(List.length params,List.length hyps)) (pf_env gls0) per_info pat_info.pat_pat ek in let ninfo2 = {pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in tclTHENS (assert_postpone id clause) [tclTHENLIST [tcl_change_info ninfo1; assume_st (params@pat_info.pat_vars); assume_st_letin pat_info.pat_aliases; assume_hyps_or_theses hyps; clear old_clauses]; tcl_change_info ninfo2] gls0 (* end cases *) type instance_stack = (constr option*(constr list) list) list let initial_instance_stack ids = List.map (fun id -> id,[None,[]]) ids let push_one_arg arg = function [] -> anomaly "impossible" | (head,args) :: ctx -> ((head,(arg::args)) :: ctx) let push_arg arg stacks = List.map (fun (id,stack) -> (id,push_one_arg arg stack)) stacks let push_one_head c ids (id,stack) = let head = if Idset.mem id ids then Some c else None in id,(head,[]) :: stack let push_head c ids stacks = List.map (push_one_head c ids) stacks let pop_one (id,stack) = let nstack= match stack with [] -> anomaly "impossible" | [c] as l -> l | (Some head,args)::(head0,args0)::ctx -> let arg = applist (head,(List.rev args)) in (head0,(arg::args0))::ctx | (None,args)::(head0,args0)::ctx -> (head0,(args@args0))::ctx in id,nstack let pop_stacks stacks = List.map pop_one stacks let hrec_for fix_id per_info gls obj_id = let obj=mkVar obj_id in let typ=pf_get_hyp_typ gls obj_id in let rc,hd1=decompose_prod typ in let cind,all_args=decompose_app typ in let ind = destInd cind in assert (ind=per_info.per_ind); let params,args= list_chop per_info.per_nparams all_args in assert begin try List.for_all2 eq_constr params per_info.per_params with Invalid_argument _ -> false end; let hd2 = applist (mkVar fix_id,args@[obj]) in compose_lam rc (whd_beta gls.sigma hd2) let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = match tree, objs with Close_patt t,_ -> let args0 = pop_stacks args in execute_cases fix_name per_info tacnext args0 objs nhrec t gls | Skip_patt (_,t),skipped::next_objs -> let args0 = push_arg skipped args in execute_cases fix_name per_info tacnext args0 next_objs nhrec t gls | End_patt (id,(nparams,nhyps)),[] -> begin match List.assoc id args with [None,br_args] -> let all_metas = list_tabulate (fun n -> mkMeta (succ n)) (nparams + nhyps) in let param_metas,hyp_metas = list_chop nparams all_metas in tclTHEN (tclDO nhrec introf) (tacnext (applist (mkVar id, List.append param_metas (List.rev_append br_args hyp_metas)))) gls | _ -> anomaly "wrong stack size" end | Split_patt (ids,ind,br), casee::next_objs -> let (mind,oind) as spec = Global.lookup_inductive ind in let nparams = mind.mind_nparams in let concl=pf_concl gls in let env=pf_env gls in let ctyp=pf_type_of gls casee in let hd,all_args = decompose_app (special_whd gls ctyp) in let _ = assert (destInd hd = ind) in (* just in case *) let params,real_args = list_chop nparams all_args in let abstract_obj c body = let typ=pf_type_of gls c in lambda_create env (typ,subst_term c body) in let elim_pred = List.fold_right abstract_obj real_args (lambda_create env (ctyp,subst_term casee concl)) in let case_info = Inductiveops.make_case_info env ind RegularStyle in let gen_arities = Inductive.arities_of_constructors ind spec in let f_ids typ = let sign = (prod_assum (Term.prod_applist typ params)) in find_intro_names sign gls in let constr_args_ids = Array.map f_ids gen_arities in let case_term = mkCase(case_info,elim_pred,casee, Array.mapi (fun i _ -> mkMeta (succ i)) constr_args_ids) in let branch_tac i (recargs,bro) gls0 = let args_ids = constr_args_ids.(i) in let rec aux n = function [] -> assert (n=Array.length recargs); next_objs,[],nhrec | id :: q -> let objs,recs,nrec = aux (succ n) q in if recargs.(n) then (mkVar id::objs),(id::recs),succ nrec else (mkVar id::objs),recs,nrec in let objs,recs,nhrec = aux 0 args_ids in tclTHENLIST [tclMAP intro_mustbe_force args_ids; begin fun gls1 -> let hrecs = List.map (fun id -> hrec_for (out_name fix_name) per_info gls1 id) recs in generalize hrecs gls1 end; match bro with None -> msg_warning (str "missing case"); tacnext (mkMeta 1) | Some (sub_ids,tree) -> let br_args = List.filter (fun (id,_) -> Idset.mem id sub_ids) args in let construct = applist (mkConstruct(ind,succ i),params) in let p_args = push_head construct ids br_args in execute_cases fix_name per_info tacnext p_args objs nhrec tree] gls0 in tclTHENSV (refine case_term) (Array.mapi branch_tac br) gls | Split_patt (_, _, _) , [] -> anomaly "execute_cases : Nothing to split" | Skip_patt _ , [] -> anomaly "execute_cases : Nothing to skip" | End_patt (_,_) , _ :: _ -> anomaly "execute_cases : End of branch with garbage left" let understand_my_constr c gls = let env = pf_env gls in let nc = names_of_rel_context env in let rawc = Detyping.detype false [] nc c in let rec frob = function GEvar _ -> GHole (dummy_loc,QuestionMark Expand) | rc -> map_glob_constr frob rc in Pretyping.Default.understand_tcc (sig_sig gls) env ~expected_type:(pf_concl gls) (frob rawc) let my_refine c gls = let oc = understand_my_constr c gls in Refine.refine oc gls (* end focus/claim *) let end_tac et2 gls = let info = get_its_info gls in let et1,pi,ek,clauses = match info.pm_stack with Suppose_case::_ -> anomaly "This case should already be trapped" | Claim::_ -> error "\"end claim\" expected." | Focus_claim::_ -> error "\"end focus\" expected." | Per(et',pi,ek,clauses)::_ -> (et',pi,ek,clauses) | [] -> anomaly "This case should already be trapped" in let et = if et1 <> et2 then match et1 with ET_Case_analysis -> error "\"end cases\" expected." | ET_Induction -> error "\"end induction\" expected." else et1 in tclTHEN tcl_erase_info begin match et,ek with _,EK_unknown -> tclSOLVE [simplest_elim pi.per_casee] | ET_Case_analysis,EK_nodep -> tclTHEN (general_case_analysis false (pi.per_casee,NoBindings)) (default_justification (List.map mkVar clauses)) | ET_Induction,EK_nodep -> tclTHENLIST [generalize (pi.per_args@[pi.per_casee]); simple_induct (AnonHyp (succ (List.length pi.per_args))); default_justification (List.map mkVar clauses)] | ET_Case_analysis,EK_dep tree -> execute_cases Anonymous pi (fun c -> tclTHENLIST [my_refine c; clear clauses; justification assumption]) (initial_instance_stack clauses) [pi.per_casee] 0 tree | ET_Induction,EK_dep tree -> let nargs = (List.length pi.per_args) in tclTHEN (generalize (pi.per_args@[pi.per_casee])) begin fun gls0 -> let fix_id = pf_get_new_id (id_of_string "_fix") gls0 in let c_id = pf_get_new_id (id_of_string "_main_arg") gls0 in tclTHENLIST [fix (Some fix_id) (succ nargs); tclDO nargs introf; intro_mustbe_force c_id; execute_cases (Name fix_id) pi (fun c -> tclTHENLIST [clear [fix_id]; my_refine c; clear clauses; justification assumption]) (initial_instance_stack clauses) [mkVar c_id] 0 tree] gls0 end end gls (* escape *) let escape_tac gls = (* spiwack: sets an empty info stack to avoid interferences. We could erase the info altogether, but that doesn't play well with the Decl_mode.focus (used in post_processing). *) let info={pm_stack=[]} in tcl_change_info info gls (* General instruction engine *) let rec do_proof_instr_gen _thus _then instr = match instr with Pthus i -> assert (not _thus); do_proof_instr_gen true _then i | Pthen i -> assert (not _then); do_proof_instr_gen _thus true i | Phence i -> assert (not (_then || _thus)); do_proof_instr_gen true true i | Pcut c -> instr_cut mk_stat_or_thesis _thus _then c | Psuffices c -> instr_suffices _then c | Prew (s,c) -> assert (not _then); instr_rew _thus s c | Pconsider (c,hyps) -> consider_tac c hyps | Pgiven hyps -> given_tac hyps | Passume hyps -> assume_tac hyps | Plet hyps -> assume_tac hyps | Pclaim st -> instr_claim false st | Pfocus st -> instr_claim true st | Ptake witl -> take_tac witl | Pdefine (id,args,body) -> define_tac id args body | Pcast (id,typ) -> cast_tac id typ | Pper (et,cs) -> per_tac et cs | Psuppose hyps -> suppose_tac hyps | Pcase (params,pat_info,hyps) -> case_tac params pat_info hyps | Pend (B_elim et) -> end_tac et | Pend _ -> anomaly "Not applicable" | Pescape -> escape_tac let eval_instr {instr=instr} = do_proof_instr_gen false false instr let rec preprocess pts instr = match instr with Phence i |Pthus i | Pthen i -> preprocess pts i | Psuffices _ | Pcut _ | Passume _ | Plet _ | Pclaim _ | Pfocus _ | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Pper _ | Prew _ -> check_not_per pts; true | Pescape -> check_not_per pts; true | Pcase _ | Psuppose _ | Pend (B_elim _) -> close_previous_case pts ; true | Pend bt -> close_block bt pts ; false let rec postprocess pts instr = match instr with Phence i | Pthus i | Pthen i -> postprocess pts i | Pcut _ | Psuffices _ | Passume _ | Plet _ | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Prew (_,_) -> () | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _ -> Decl_mode.focus pts | Pescape -> Decl_mode.focus pts; Proof_global.set_proof_mode "Classic" | Pend (B_elim ET_Induction) -> begin let pfterm = List.hd (Proof.partial_proof pts) in let { it = gls ; sigma = sigma } = Proof.V82.subgoals pts in let env = try Goal.V82.env sigma (List.hd gls) with Failure "hd" -> Global.env () in try Inductiveops.control_only_guard env pfterm; goto_current_focus_or_top pts with Type_errors.TypeError(env, Type_errors.IllFormedRecBody(_,_,_,_,_)) -> anomaly "\"end induction\" generated an ill-formed fixpoint" end | Pend _ -> goto_current_focus_or_top (pts) let do_instr raw_instr pts = let has_tactic = preprocess pts raw_instr.instr in begin if has_tactic then let { it=gls ; sigma=sigma } = Proof.V82.subgoals pts in let gl = { it=List.hd gls ; sigma=sigma } in let env= pf_env gl in let ist = {ltacvars = ([],[]); ltacrecvars = []; gsigma = sigma; genv = env} in let glob_instr = intern_proof_instr ist raw_instr in let instr = interp_proof_instr (get_its_info gl) sigma env glob_instr in Pfedit.by (tclTHEN (eval_instr instr) clean_tmp) else () end; postprocess pts raw_instr.instr; (* spiwack: this should restore a compatible semantics with v8.3 where we never stayed focused on 0 goal. *) Decl_mode.maximal_unfocus pts let proof_instr raw_instr = let p = Proof_global.give_me_the_proof () in do_instr raw_instr p (* (* STUFF FOR ITERATED RELATIONS *) let decompose_bin_app t= let hd,args = destApp let identify_transitivity_lemma c = let varx,tx,c1 = destProd c in let vary,ty,c2 = destProd (pop c1) in let varz,tz,c3 = destProd (pop c2) in let _,p1,c4 = destProd (pop c3) in let _,lp2,lp3 = destProd (pop c4) in let p2=pop lp2 in let p3=pop lp3 in *) coq-8.4pl4/plugins/decl_mode/decl_interp.ml0000644000175000017500000004036612326224777020062 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Thesis n | This c -> This (intern_constr globs c) let add_var id globs= let l1,l2=globs.ltacvars in {globs with ltacvars= (id::l1),(id::l2)} let add_name nam globs= match nam with Anonymous -> globs | Name id -> add_var id globs let intern_hyp iconstr globs = function Hvar (loc,(id,topt)) -> add_var id globs, Hvar (loc,(id,Option.map (intern_constr globs) topt)) | Hprop st -> add_name st.st_label globs, Hprop (intern_statement iconstr globs st) let intern_hyps iconstr globs hyps = snd (list_fold_map (intern_hyp iconstr) globs hyps) let intern_cut intern_it globs cut= let nglobs,nstat=intern_it globs cut.cut_stat in {cut_stat=nstat; cut_by=intern_justification_items nglobs cut.cut_by; cut_using=intern_justification_method nglobs cut.cut_using} let intern_casee globs = function Real c -> Real (intern_constr globs c) | Virtual cut -> Virtual (intern_cut (intern_no_bind (intern_statement intern_constr)) globs cut) let intern_hyp_list args globs = let intern_one globs (loc,(id,opttyp)) = (add_var id globs), (loc,(id,Option.map (intern_constr globs) opttyp)) in list_fold_map intern_one globs args let intern_suffices_clause globs (hyps,c) = let nglobs,nhyps = list_fold_map (intern_hyp intern_constr) globs hyps in nglobs,(nhyps,intern_constr_or_thesis nglobs c) let intern_fundecl args body globs= let nglobs,nargs = intern_hyp_list args globs in nargs,intern_constr nglobs body let rec add_vars_of_simple_pattern globs = function CPatAlias (loc,p,id) -> add_vars_of_simple_pattern (add_var id globs) p (* Loc.raise loc (UserError ("simple_pattern",str "\"as\" is not allowed here"))*) | CPatOr (loc, _)-> Loc.raise loc (UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here")) | CPatDelimiters (_,_,p) -> add_vars_of_simple_pattern globs p | CPatCstr (_,_,pl) | CPatCstrExpl (_,_,pl) -> List.fold_left add_vars_of_simple_pattern globs pl | CPatNotation(_,_,(pl,pll)) -> List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pll)) | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs | _ -> globs let rec intern_bare_proof_instr globs = function Pthus i -> Pthus (intern_bare_proof_instr globs i) | Pthen i -> Pthen (intern_bare_proof_instr globs i) | Phence i -> Phence (intern_bare_proof_instr globs i) | Pcut c -> Pcut (intern_cut (intern_no_bind (intern_statement intern_constr_or_thesis)) globs c) | Psuffices c -> Psuffices (intern_cut intern_suffices_clause globs c) | Prew (s,c) -> Prew (s,intern_cut (intern_no_bind (intern_statement intern_constr)) globs c) | Psuppose hyps -> Psuppose (intern_hyps intern_constr globs hyps) | Pcase (params,pat,hyps) -> let nglobs,nparams = intern_hyp_list params globs in let nnglobs= add_vars_of_simple_pattern nglobs pat in let nhyps = intern_hyps intern_constr_or_thesis nnglobs hyps in Pcase (nparams,pat,nhyps) | Ptake witl -> Ptake (List.map (intern_constr globs) witl) | Pconsider (c,hyps) -> Pconsider (intern_constr globs c, intern_hyps intern_constr globs hyps) | Pper (et,c) -> Pper (et,intern_casee globs c) | Pend bt -> Pend bt | Pescape -> Pescape | Passume hyps -> Passume (intern_hyps intern_constr globs hyps) | Pgiven hyps -> Pgiven (intern_hyps intern_constr globs hyps) | Plet hyps -> Plet (intern_hyps intern_constr globs hyps) | Pclaim st -> Pclaim (intern_statement intern_constr globs st) | Pfocus st -> Pfocus (intern_statement intern_constr globs st) | Pdefine (id,args,body) -> let nargs,nbody = intern_fundecl args body globs in Pdefine (id,nargs,nbody) | Pcast (id,typ) -> Pcast (id,intern_constr globs typ) let rec intern_proof_instr globs instr= {emph = instr.emph; instr = intern_bare_proof_instr globs instr.instr} (* INTERP *) let interp_justification_items sigma env = Option.map (List.map (fun c ->understand sigma env (fst c))) let interp_constr check_sort sigma env c = if check_sort then understand_type sigma env (fst c) else understand sigma env (fst c) let special_whd env = let infos=Closure.create_clos_infos Closure.betadeltaiota env in (fun t -> Closure.whd_val infos (Closure.inject t)) let _eq = Libnames.constr_of_global (Coqlib.glob_eq) let decompose_eq env id = let typ = Environ.named_type id env in let whd = special_whd env typ in match kind_of_term whd with App (f,args)-> if eq_constr f _eq && (Array.length args)=3 then args.(0) else error "Previous step is not an equality." | _ -> error "Previous step is not an equality." let get_eq_typ info env = let typ = decompose_eq env (get_last env) in typ let interp_constr_in_type typ sigma env c = understand sigma env (fst c) ~expected_type:typ let interp_statement interp_it sigma env st = {st_label=st.st_label; st_it=interp_it sigma env st.st_it} let interp_constr_or_thesis check_sort sigma env = function Thesis n -> Thesis n | This c -> This (interp_constr check_sort sigma env c) let abstract_one_hyp inject h glob = match h with Hvar (loc,(id,None)) -> GProd (dummy_loc,Name id, Explicit, GHole (loc,Evd.BinderType (Name id)), glob) | Hvar (loc,(id,Some typ)) -> GProd (dummy_loc,Name id, Explicit, fst typ, glob) | Hprop st -> GProd (dummy_loc,st.st_label, Explicit, inject st.st_it, glob) let glob_constr_of_hyps inject hyps head = List.fold_right (abstract_one_hyp inject) hyps head let glob_prop = GSort (dummy_loc,GProp Null) let rec match_hyps blend names constr = function [] -> [],substl names constr | hyp::q -> let (name,typ,body)=destProd constr in let st= {st_label=name;st_it=substl names typ} in let qnames= match name with Anonymous -> mkMeta 0 :: names | Name id -> mkVar id :: names in let qhyp = match hyp with Hprop st' -> Hprop (blend st st') | Hvar _ -> Hvar st in let rhyps,head = match_hyps blend qnames body q in qhyp::rhyps,head let interp_hyps_gen inject blend sigma env hyps head = let constr=understand sigma env (glob_constr_of_hyps inject hyps head) in match_hyps blend [] constr hyps let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma env hyps glob_prop) let dummy_prefix= id_of_string "__" let rec deanonymize ids = function PatVar (loc,Anonymous) -> let (found,known) = !ids in let new_id=Namegen.next_ident_away dummy_prefix known in let _= ids:= (loc,new_id) :: found , new_id :: known in PatVar (loc,Name new_id) | PatVar (loc,Name id) as pat -> let (found,known) = !ids in let _= ids:= (loc,id) :: found , known in pat | PatCstr(loc,cstr,lpat,nam) -> PatCstr(loc,cstr,List.map (deanonymize ids) lpat,nam) let rec glob_of_pat = function PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable" | PatVar (loc,Name id) -> GVar (loc,id) | PatCstr(loc,((ind,_) as cstr),lpat,_) -> let mind= fst (Global.lookup_inductive ind) in let rec add_params n q = if n<=0 then q else add_params (pred n) (GHole(dummy_loc, Evd.TomatchTypeParameter(ind,n))::q) in let args = List.map glob_of_pat lpat in glob_app(loc,GRef(dummy_loc,Libnames.ConstructRef cstr), add_params mind.Declarations.mind_nparams args) let prod_one_hyp = function (loc,(id,None)) -> (fun glob -> GProd (dummy_loc,Name id, Explicit, GHole (loc,Evd.BinderType (Name id)), glob)) | (loc,(id,Some typ)) -> (fun glob -> GProd (dummy_loc,Name id, Explicit, fst typ, glob)) let prod_one_id (loc,id) glob = GProd (dummy_loc,Name id, Explicit, GHole (loc,Evd.BinderType (Name id)), glob) let let_in_one_alias (id,pat) glob = GLetIn (dummy_loc,Name id, glob_of_pat pat, glob) let rec bind_primary_aliases map pat = match pat with PatVar (_,_) -> map | PatCstr(loc,_,lpat,nam) -> let map1 = match nam with Anonymous -> map | Name id -> (id,pat)::map in List.fold_left bind_primary_aliases map1 lpat let bind_secondary_aliases map subst = List.fold_left (fun map (ids,idp) -> (ids,List.assoc idp map)::map) map subst let bind_aliases patvars subst patt = let map = bind_primary_aliases [] patt in let map1 = bind_secondary_aliases map subst in List.rev map1 let interp_pattern env pat_expr = let patvars,pats = Constrintern.intern_pattern env pat_expr in match pats with [] -> anomaly "empty pattern list" | [subst,patt] -> (patvars,bind_aliases patvars subst patt,patt) | _ -> anomaly "undetected disjunctive pattern" let rec match_args dest names constr = function [] -> [],names,substl names constr | _::q -> let (name,typ,body)=dest constr in let st={st_label=name;st_it=substl names typ} in let qnames= match name with Anonymous -> assert false | Name id -> mkVar id :: names in let args,bnames,body = match_args dest qnames body q in st::args,bnames,body let rec match_aliases names constr = function [] -> [],names,substl names constr | _::q -> let (name,c,typ,body)=destLetIn constr in let st={st_label=name;st_it=(substl names c,substl names typ)} in let qnames= match name with Anonymous -> assert false | Name id -> mkVar id :: names in let args,bnames,body = match_aliases qnames body q in st::args,bnames,body let detype_ground c = Detyping.detype false [] [] c let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = let et,pinfo = match info.pm_stack with Per(et,pi,_,_)::_ -> et,pi | _ -> error "No proof per cases/induction/inversion in progress." in let mib,oib=Global.lookup_inductive pinfo.per_ind in let num_params = pinfo.per_nparams in let _ = let expected = mib.Declarations.mind_nparams - num_params in if List.length params <> expected then errorlabstrm "suppose it is" (str "Wrong number of extra arguments: " ++ (if expected = 0 then str "none" else int expected) ++ spc () ++ str "expected.") in let app_ind = let rind = GRef (dummy_loc,Libnames.IndRef pinfo.per_ind) in let rparams = List.map detype_ground pinfo.per_params in let rparams_rec = List.map (fun (loc,(id,_)) -> GVar (loc,id)) params in let dum_args= list_tabulate (fun _ -> GHole (dummy_loc,Evd.QuestionMark (Evd.Define false))) oib.Declarations.mind_nrealargs in glob_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in let pat_vars,aliases,patt = interp_pattern env pat in let inject = function Thesis (Plain) -> Glob_term.GSort(dummy_loc,GProp Null) | Thesis (For rec_occ) -> if not (List.mem rec_occ pat_vars) then errorlabstrm "suppose it is" (str "Variable " ++ Nameops.pr_id rec_occ ++ str " does not occur in pattern."); Glob_term.GSort(dummy_loc,GProp Null) | This (c,_) -> c in let term1 = glob_constr_of_hyps inject hyps glob_prop in let loc_ids,npatt = let rids=ref ([],pat_vars) in let npatt= deanonymize rids patt in List.rev (fst !rids),npatt in let term2 = GLetIn(dummy_loc,Anonymous, GCast(dummy_loc,glob_of_pat npatt, CastConv (DEFAULTcast,app_ind)),term1) in let term3=List.fold_right let_in_one_alias aliases term2 in let term4=List.fold_right prod_one_id loc_ids term3 in let term5=List.fold_right prod_one_hyp params term4 in let constr = understand sigma env term5 in let tparams,nam4,rest4 = match_args destProd [] constr params in let tpatvars,nam3,rest3 = match_args destProd nam4 rest4 loc_ids in let taliases,nam2,rest2 = match_aliases nam3 rest3 aliases in let (_,pat_pat,pat_typ,rest1) = destLetIn rest2 in let blend st st' = match st'.st_it with Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label} | This _ -> {st_it = This st.st_it;st_label=st.st_label} in let thyps = fst (match_hyps blend nam2 (Termops.pop rest1) hyps) in tparams,{pat_vars=tpatvars; pat_aliases=taliases; pat_constr=pat_pat; pat_typ=pat_typ; pat_pat=patt; pat_expr=pat},thyps let interp_cut interp_it sigma env cut= let nenv,nstat = interp_it sigma env cut.cut_stat in {cut with cut_stat=nstat; cut_by=interp_justification_items sigma nenv cut.cut_by} let interp_no_bind interp_it sigma env x = env,interp_it sigma env x let interp_suffices_clause sigma env (hyps,cot)= let (locvars,_) as res = match cot with This (c,_) -> let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) sigma env hyps c in nhyps,This nc | Thesis Plain as th -> interp_hyps sigma env hyps,th | Thesis (For n) -> error "\"thesis for\" is not applicable here." in let push_one hyp env0 = match hyp with (Hprop st | Hvar st) -> match st.st_label with Name id -> Environ.push_named (id,None,st.st_it) env0 | _ -> env in let nenv = List.fold_right push_one locvars env in nenv,res let interp_casee sigma env = function Real c -> Real (understand sigma env (fst c)) | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut) let abstract_one_arg = function (loc,(id,None)) -> (fun glob -> GLambda (dummy_loc,Name id, Explicit, GHole (loc,Evd.BinderType (Name id)), glob)) | (loc,(id,Some typ)) -> (fun glob -> GLambda (dummy_loc,Name id, Explicit, fst typ, glob)) let glob_constr_of_fun args body = List.fold_right abstract_one_arg args (fst body) let interp_fun sigma env args body = let constr=understand sigma env (glob_constr_of_fun args body) in match_args destLambda [] constr args let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = function Pthus i -> Pthus (interp_bare_proof_instr info sigma env i) | Pthen i -> Pthen (interp_bare_proof_instr info sigma env i) | Phence i -> Phence (interp_bare_proof_instr info sigma env i) | Pcut c -> Pcut (interp_cut (interp_no_bind (interp_statement (interp_constr_or_thesis true))) sigma env c) | Psuffices c -> Psuffices (interp_cut interp_suffices_clause sigma env c) | Prew (s,c) -> Prew (s,interp_cut (interp_no_bind (interp_statement (interp_constr_in_type (get_eq_typ info env)))) sigma env c) | Psuppose hyps -> Psuppose (interp_hyps sigma env hyps) | Pcase (params,pat,hyps) -> let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in Pcase (tparams,tpat,thyps) | Ptake witl -> Ptake (List.map (fun c -> understand sigma env (fst c)) witl) | Pconsider (c,hyps) -> Pconsider (interp_constr false sigma env c, interp_hyps sigma env hyps) | Pper (et,c) -> Pper (et,interp_casee sigma env c) | Pend bt -> Pend bt | Pescape -> Pescape | Passume hyps -> Passume (interp_hyps sigma env hyps) | Pgiven hyps -> Pgiven (interp_hyps sigma env hyps) | Plet hyps -> Plet (interp_hyps sigma env hyps) | Pclaim st -> Pclaim (interp_statement (interp_constr true) sigma env st) | Pfocus st -> Pfocus (interp_statement (interp_constr true) sigma env st) | Pdefine (id,args,body) -> let nargs,_,nbody = interp_fun sigma env args body in Pdefine (id,nargs,nbody) | Pcast (id,typ) -> Pcast(id,interp_constr true sigma env typ) let rec interp_proof_instr info sigma env instr= {emph = instr.emph; instr = interp_bare_proof_instr info sigma env instr.instr} coq-8.4pl4/plugins/decl_mode/decl_mode.mli0000644000175000017500000000377012326224777017654 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val clear_daimon_flag : unit -> unit val get_daimon_flag : unit -> bool type command_mode = Mode_tactic | Mode_proof | Mode_none val mode_of_pftreestate : Proof.proof -> command_mode val get_current_mode : unit -> command_mode val check_not_proof_mode : string -> unit type split_tree= Skip_patt of Idset.t * split_tree | Split_patt of Idset.t * inductive * (bool array * (Idset.t * split_tree) option) array | Close_patt of split_tree | End_patt of (identifier * (int * int)) type elim_kind = EK_dep of split_tree | EK_nodep | EK_unknown type recpath = int option*Declarations.wf_paths type per_info = {per_casee:constr; per_ctype:types; per_ind:inductive; per_pred:constr; per_args:constr list; per_params:constr list; per_nparams:int; per_wf:recpath} type stack_info = Per of Decl_expr.elim_type * per_info * elim_kind * Names.identifier list | Suppose_case | Claim | Focus_claim type pm_info = {pm_stack : stack_info list } val info : pm_info Store.Field.t val get_info : Evd.evar_map -> Proof_type.goal -> pm_info val try_get_info : Evd.evar_map -> Proof_type.goal -> pm_info option val get_stack : Proof.proof -> stack_info list val get_top_stack : Proof.proof -> stack_info list val get_last: Environ.env -> identifier val focus : Proof.proof -> unit val unfocus : Proof.proof -> unit val maximal_unfocus : Proof.proof -> unit coq-8.4pl4/plugins/field/0000755000175000017500000000000012365131025014361 5ustar stephstephcoq-8.4pl4/plugins/field/vo.itarget0000644000175000017500000000012012326224777016375 0ustar stephstephLegacyField_Compl.vo LegacyField_Tactic.vo LegacyField_Theory.vo LegacyField.vo coq-8.4pl4/plugins/field/field_plugin.mllib0000644000175000017500000000002712326224777020060 0ustar stephstephField Field_plugin_mod coq-8.4pl4/plugins/field/field.ml40000644000175000017500000001476212326224777016112 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* mkApp (init_constant "None",[|ac3|]) | Some f -> mkApp (init_constant "Some",[|ac3;constr_of f|]) module Cmap = Map.Make(struct type t = constr let compare = constr_ord end) (* Table of theories *) let th_tab = ref (Cmap.empty : constr Cmap.t) let lookup env typ = try Cmap.find typ !th_tab with Not_found -> errorlabstrm "field" (str "No field is declared for type" ++ spc() ++ Printer.pr_lconstr_env env typ) let _ = let init () = th_tab := Cmap.empty in let freeze () = !th_tab in let unfreeze fs = th_tab := fs in Summary.declare_summary "field" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = init } let load_addfield _ = () let cache_addfield (_,(typ,th)) = th_tab := Cmap.add typ th !th_tab let subst_addfield (subst,(typ,th as obj)) = let typ' = subst_mps subst typ in let th' = subst_mps subst th in if typ' == typ && th' == th then obj else (typ',th') (* Declaration of the Add Field library object *) let in_addfield : types * constr -> Libobject.obj = Libobject.declare_object {(Libobject.default_object "ADD_FIELD") with Libobject.open_function = (fun i o -> if i=1 then cache_addfield o); Libobject.cache_function = cache_addfield; Libobject.subst_function = subst_addfield; Libobject.classify_function = (fun a -> Libobject.Substitute a)} (* Adds a theory to the table *) let add_field a aplus amult aone azero aopp aeq ainv aminus_o adiv_o rth ainv_l = begin (try Ring.add_theory true true false a None None None aplus amult aone azero (Some aopp) aeq rth Quote.ConstrSet.empty with | UserError("Add Semi Ring",_) -> ()); let th = mkApp ((constant ["LegacyField_Theory"] "Build_Field_Theory"), [|a;aplus;amult;aone;azero;aopp;aeq;ainv;aminus_o;adiv_o;rth;ainv_l|]) in begin let _ = type_of (Global.env ()) Evd.empty th in (); Lib.add_anonymous_leaf (in_addfield (a,th)) end end (* Vernac command declaration *) open Extend open Pcoq open Genarg VERNAC ARGUMENT EXTEND divarg | [ "div" ":=" constr(adiv) ] -> [ adiv ] END VERNAC ARGUMENT EXTEND minusarg | [ "minus" ":=" constr(aminus) ] -> [ aminus ] END (* (* The v7->v8 translator needs printers, then temporary use ARGUMENT EXTEND...*) VERNAC ARGUMENT EXTEND minus_div_arg | [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ] | [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ] | [ ] -> [ None, None ] END *) (* For the translator, otherwise the code above is OK *) open Ppconstr let pp_minus_div_arg _prc _prlc _prt (omin,odiv) = if omin=None && odiv=None then mt() else spc() ++ str "with" ++ pr_opt (fun c -> str "minus := " ++ _prc c) omin ++ pr_opt (fun c -> str "div := " ++ _prc c) odiv (* let () = Pptactic.declare_extra_genarg_pprule true (rawwit_minus_div_arg,pp_minus_div_arg) (globwit_minus_div_arg,pp_minus_div_arg) (wit_minus_div_arg,pp_minus_div_arg) *) ARGUMENT EXTEND minus_div_arg TYPED AS constr_opt * constr_opt PRINTED BY pp_minus_div_arg | [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ] | [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ] | [ ] -> [ None, None ] END VERNAC COMMAND EXTEND Field [ "Add" "Legacy" "Field" constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aopp) constr(aeq) constr(ainv) constr(rth) constr(ainv_l) minus_div_arg(md) ] -> [ let (aminus_o, adiv_o) = md in add_field (constr_of a) (constr_of aplus) (constr_of amult) (constr_of aone) (constr_of azero) (constr_of aopp) (constr_of aeq) (constr_of ainv) (constr_of_opt a aminus_o) (constr_of_opt a adiv_o) (constr_of rth) (constr_of ainv_l) ] END (* Guesses the type and calls field_gen with the right theory *) let field g = Coqlib.check_required_library ["Coq";"field";"LegacyField"]; let typ = try match Hipattern.match_with_equation (pf_concl g) with | _,_,Hipattern.PolymorphicLeibnizEq (t,_,_) -> t | _ -> raise Exit with Hipattern.NoEquationFound | Exit -> error "The statement is not built from Leibniz' equality" in let th = VConstr ([],lookup (pf_env g) typ) in (interp_tac_gen [(id_of_string "FT",th)] [] (get_debug ()) <:tactic< match goal with |- (@eq _ _ _) => field_gen FT end >>) g (* Verifies that all the terms have the same type and gives the right theory *) let guess_theory env evc = function | c::tl -> let t = type_of env evc c in if List.exists (fun c1 -> not (Reductionops.is_conv env evc t (type_of env evc c1))) tl then errorlabstrm "Field:" (str" All the terms must have the same type") else lookup env t | [] -> anomaly "Field: must have a non-empty constr list here" (* Guesses the type and calls Field_Term with the right theory *) let field_term l g = Coqlib.check_required_library ["Coq";"field";"LegacyField"]; let env = (pf_env g) and evc = (project g) in let th = valueIn (VConstr ([],guess_theory env evc l)) and nl = List.map (fun x -> valueIn (VConstr ([],x))) (Quote.sort_subterm g l) in (List.fold_right (fun c a -> let tac = (Tacinterp.interp <:tactic<(Field_Term $th $c)>>) in Tacticals.tclTHENFIRSTn tac [|a|]) nl Tacticals.tclIDTAC) g (* Declaration of Field *) TACTIC EXTEND legacy_field | [ "legacy" "field" ] -> [ field ] | [ "legacy" "field" ne_constr_list(l) ] -> [ field_term l ] END coq-8.4pl4/plugins/field/LegacyField_Compl.v0000644000175000017500000000245112326224777020072 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* e2}) (lst:list (prod A B)) {struct lst} : B -> A -> A := fun (key:B) (default:A) => match lst with | nil => default | (v,e) :: l => match eq_dec e key with | left _ => v | right _ => assoc_2nd_rec A B eq_dec l key default end end). Definition mem := (fix mem (A:Set) (eq_dec:forall e1 e2:A, {e1 = e2} + {e1 <> e2}) (a:A) (l:list A) {struct l} : bool := match l with | nil => false | a1 :: l1 => match eq_dec a a1 with | left _ => true | right _ => mem A eq_dec a l1 end end). coq-8.4pl4/plugins/field/LegacyField_Tactic.v0000644000175000017500000003025412326224777020231 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ExprA ****) Ltac get_component a s := eval cbv beta iota delta [a] in (a s). Ltac body_of s := eval cbv beta iota delta [s] in s. Ltac mem_assoc var lvar := match constr:lvar with | nil => constr:false | ?X1 :: ?X2 => match constr:(X1 = var) with | (?X1 = ?X1) => constr:true | _ => mem_assoc var X2 end end. Ltac number lvar := let rec number_aux lvar cpt := match constr:lvar with | (@nil ?X1) => constr:(@nil (prod X1 nat)) | ?X2 :: ?X3 => let l2 := number_aux X3 (S cpt) in constr:((X2,cpt) :: l2) end in number_aux lvar 0. Ltac build_varlist FT trm := let rec seek_var lvar trm := let AT := get_component A FT with AzeroT := get_component Azero FT with AoneT := get_component Aone FT with AplusT := get_component Aplus FT with AmultT := get_component Amult FT with AoppT := get_component Aopp FT with AinvT := get_component Ainv FT in match constr:trm with | AzeroT => lvar | AoneT => lvar | (AplusT ?X1 ?X2) => let l1 := seek_var lvar X1 in seek_var l1 X2 | (AmultT ?X1 ?X2) => let l1 := seek_var lvar X1 in seek_var l1 X2 | (AoppT ?X1) => seek_var lvar X1 | (AinvT ?X1) => seek_var lvar X1 | ?X1 => let res := mem_assoc X1 lvar in match constr:res with | true => lvar | false => constr:(X1 :: lvar) end end in let AT := get_component A FT in let lvar := seek_var (@nil AT) trm in number lvar. Ltac assoc elt lst := match constr:lst with | nil => fail | (?X1,?X2) :: ?X3 => match constr:(elt = X1) with | (?X1 = ?X1) => constr:X2 | _ => assoc elt X3 end end. Ltac interp_A FT lvar trm := let AT := get_component A FT with AzeroT := get_component Azero FT with AoneT := get_component Aone FT with AplusT := get_component Aplus FT with AmultT := get_component Amult FT with AoppT := get_component Aopp FT with AinvT := get_component Ainv FT in match constr:trm with | AzeroT => constr:EAzero | AoneT => constr:EAone | (AplusT ?X1 ?X2) => let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in constr:(EAplus e1 e2) | (AmultT ?X1 ?X2) => let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in constr:(EAmult e1 e2) | (AoppT ?X1) => let e := interp_A FT lvar X1 in constr:(EAopp e) | (AinvT ?X1) => let e := interp_A FT lvar X1 in constr:(EAinv e) | ?X1 => let idx := assoc X1 lvar in constr:(EAvar idx) end. (************************) (* Simplification *) (************************) (**** Generation of the multiplier ****) Ltac remove e l := match constr:l with | nil => l | e :: ?X2 => constr:X2 | ?X2 :: ?X3 => let nl := remove e X3 in constr:(X2 :: nl) end. Ltac union l1 l2 := match constr:l1 with | nil => l2 | ?X2 :: ?X3 => let nl2 := remove X2 l2 in let nl := union X3 nl2 in constr:(X2 :: nl) end. Ltac raw_give_mult trm := match constr:trm with | (EAinv ?X1) => constr:(X1 :: nil) | (EAopp ?X1) => raw_give_mult X1 | (EAplus ?X1 ?X2) => let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in union l1 l2 | (EAmult ?X1 ?X2) => let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in eval compute in (app l1 l2) | _ => constr:(@nil ExprA) end. Ltac give_mult trm := let ltrm := raw_give_mult trm in constr:(mult_of_list ltrm). (**** Associativity ****) Ltac apply_assoc FT lvar trm := let t := eval compute in (assoc trm) in match constr:(t = trm) with | (?X1 = ?X1) => idtac | _ => rewrite <- (assoc_correct FT trm); change (assoc trm) with t end. (**** Distribution *****) Ltac apply_distrib FT lvar trm := let t := eval compute in (distrib trm) in match constr:(t = trm) with | (?X1 = ?X1) => idtac | _ => rewrite <- (distrib_correct FT trm); change (distrib trm) with t end. (**** Multiplication by the inverse product ****) Ltac grep_mult := match goal with | id:(interp_ExprA _ _ _ <> _) |- _ => id end. Ltac weak_reduce := match goal with | |- context [(interp_ExprA ?X1 ?X2 _)] => cbv beta iota zeta delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list X1 X2 A Azero Aone Aplus Amult Aopp Ainv] end. Ltac multiply mul := match goal with | |- (interp_ExprA ?FT ?X2 ?X3 = interp_ExprA ?FT ?X2 ?X4) => let AzeroT := get_component Azero FT in cut (interp_ExprA FT X2 mul <> AzeroT); [ intro; (let id := grep_mult in apply (mult_eq FT X3 X4 mul X2 id)) | weak_reduce; (let AoneT := get_component Aone ltac:(body_of FT) with AmultT := get_component Amult ltac:(body_of FT) in try match goal with | |- context [(AmultT _ AoneT)] => rewrite (AmultT_1r FT) end; clear FT X2) ] end. Ltac apply_multiply FT lvar trm := let t := eval compute in (multiply trm) in match constr:(t = trm) with | (?X1 = ?X1) => idtac | _ => rewrite <- (multiply_correct FT trm); change (multiply trm) with t end. (**** Permutations and simplification ****) Ltac apply_inverse mul FT lvar trm := let t := eval compute in (inverse_simplif mul trm) in match constr:(t = trm) with | (?X1 = ?X1) => idtac | _ => rewrite <- (inverse_correct FT trm mul); [ change (inverse_simplif mul trm) with t | assumption ] end. (**** Inverse test ****) Ltac strong_fail tac := first [ tac | fail 2 ]. Ltac inverse_test_aux FT trm := let AplusT := get_component Aplus FT with AmultT := get_component Amult FT with AoppT := get_component Aopp FT with AinvT := get_component Ainv FT in match constr:trm with | (AinvT _) => fail 1 | (AoppT ?X1) => strong_fail ltac:(inverse_test_aux FT X1; idtac) | (AplusT ?X1 ?X2) => strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2) | (AmultT ?X1 ?X2) => strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2) | _ => idtac end. Ltac inverse_test FT := let AplusT := get_component Aplus FT in match goal with | |- (?X1 = ?X2) => inverse_test_aux FT (AplusT X1 X2) end. (**** Field itself ****) Ltac apply_simplif sfun := match goal with | |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA _ _ _) => sfun X1 X2 X3 end; match goal with | |- (interp_ExprA _ _ _ = interp_ExprA ?X1 ?X2 ?X3) => sfun X1 X2 X3 end. Ltac unfolds FT := match get_component Aminus FT with | Some ?X1 => unfold X1 | _ => idtac end; match get_component Adiv FT with | Some ?X1 => unfold X1 | _ => idtac end. Ltac reduce FT := let AzeroT := get_component Azero FT with AoneT := get_component Aone FT with AplusT := get_component Aplus FT with AmultT := get_component Amult FT with AoppT := get_component Aopp FT with AinvT := get_component Ainv FT in (cbv beta iota zeta delta -[AzeroT AoneT AplusT AmultT AoppT AinvT] || compute). Ltac field_gen_aux FT := let AplusT := get_component Aplus FT in match goal with | |- (?X1 = ?X2) => let lvar := build_varlist FT (AplusT X1 X2) in let trm1 := interp_A FT lvar X1 with trm2 := interp_A FT lvar X2 in let mul := give_mult (EAplus trm1 trm2) in cut (let ft := FT in let vm := lvar in interp_ExprA ft vm trm1 = interp_ExprA ft vm trm2); [ compute; auto | intros ft vm; apply_simplif apply_distrib; apply_simplif apply_assoc; multiply mul; [ apply_simplif apply_multiply; apply_simplif ltac:(apply_inverse mul); (let id := grep_mult in clear id; weak_reduce; clear ft vm; first [ inverse_test FT; legacy ring | field_gen_aux FT ]) | idtac ] ] end. Ltac field_gen FT := unfolds FT; (inverse_test FT; legacy ring) || field_gen_aux FT. (*****************************) (* Term Simplification *) (*****************************) (**** Minus and division expansions ****) Ltac init_exp FT trm := let e := (match get_component Aminus FT with | Some ?X1 => eval cbv beta delta [X1] in trm | _ => trm end) in match get_component Adiv FT with | Some ?X1 => eval cbv beta delta [X1] in e | _ => e end. (**** Inverses simplification ****) Ltac simpl_inv trm := match constr:trm with | (EAplus ?X1 ?X2) => let e1 := simpl_inv X1 with e2 := simpl_inv X2 in constr:(EAplus e1 e2) | (EAmult ?X1 ?X2) => let e1 := simpl_inv X1 with e2 := simpl_inv X2 in constr:(EAmult e1 e2) | (EAopp ?X1) => let e := simpl_inv X1 in constr:(EAopp e) | (EAinv ?X1) => SimplInvAux X1 | ?X1 => constr:X1 end with SimplInvAux trm := match constr:trm with | (EAinv ?X1) => simpl_inv X1 | (EAmult ?X1 ?X2) => let e1 := simpl_inv (EAinv X1) with e2 := simpl_inv (EAinv X2) in constr:(EAmult e1 e2) | ?X1 => let e := simpl_inv X1 in constr:(EAinv e) end. (**** Monom simplification ****) Ltac map_tactic fcn lst := match constr:lst with | nil => lst | ?X2 :: ?X3 => let r := fcn X2 with t := map_tactic fcn X3 in constr:(r :: t) end. Ltac build_monom_aux lst trm := match constr:lst with | nil => eval compute in (assoc trm) | ?X1 :: ?X2 => build_monom_aux X2 (EAmult trm X1) end. Ltac build_monom lnum lden := let ildn := map_tactic ltac:(fun e => constr:(EAinv e)) lden in let ltot := eval compute in (app lnum ildn) in let trm := build_monom_aux ltot EAone in match constr:trm with | (EAmult _ ?X1) => constr:X1 | ?X1 => constr:X1 end. Ltac simpl_monom_aux lnum lden trm := match constr:trm with | (EAmult (EAinv ?X1) ?X2) => let mma := mem_assoc X1 lnum in match constr:mma with | true => let newlnum := remove X1 lnum in simpl_monom_aux newlnum lden X2 | false => simpl_monom_aux lnum (X1 :: lden) X2 end | (EAmult ?X1 ?X2) => let mma := mem_assoc X1 lden in match constr:mma with | true => let newlden := remove X1 lden in simpl_monom_aux lnum newlden X2 | false => simpl_monom_aux (X1 :: lnum) lden X2 end | (EAinv ?X1) => let mma := mem_assoc X1 lnum in match constr:mma with | true => let newlnum := remove X1 lnum in build_monom newlnum lden | false => build_monom lnum (X1 :: lden) end | ?X1 => let mma := mem_assoc X1 lden in match constr:mma with | true => let newlden := remove X1 lden in build_monom lnum newlden | false => build_monom (X1 :: lnum) lden end end. Ltac simpl_monom trm := simpl_monom_aux (@nil ExprA) (@nil ExprA) trm. Ltac simpl_all_monomials trm := match constr:trm with | (EAplus ?X1 ?X2) => let e1 := simpl_monom X1 with e2 := simpl_all_monomials X2 in constr:(EAplus e1 e2) | ?X1 => simpl_monom X1 end. (**** Associativity and distribution ****) Ltac assoc_distrib trm := eval compute in (assoc (distrib trm)). (**** The tactic Field_Term ****) Ltac eval_weak_reduce trm := eval cbv beta iota zeta delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list A Azero Aone Aplus Amult Aopp Ainv] in trm. Ltac field_term FT exp := let newexp := init_exp FT exp in let lvar := build_varlist FT newexp in let trm := interp_A FT lvar newexp in let tma := eval compute in (assoc trm) in let tsmp := simpl_all_monomials ltac:(assoc_distrib ltac:(simpl_all_monomials ltac:(simpl_inv tma))) in let trep := eval_weak_reduce (interp_ExprA FT lvar tsmp) in (replace exp with trep; [ legacy ring trep | field_gen FT ]). coq-8.4pl4/plugins/field/LegacyField_Theory.v0000644000175000017500000004676412326224777020311 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* A -> A; Amult : A -> A -> A; Aone : A; Azero : A; Aopp : A -> A; Aeq : A -> A -> bool; Ainv : A -> A; Aminus : option (A -> A -> A); Adiv : option (A -> A -> A); RT : Ring_Theory Aplus Amult Aone Azero Aopp Aeq; Th_inv_def : forall n:A, n <> Azero -> Amult (Ainv n) n = Aone}. (* The reflexion structure *) Inductive ExprA : Set := | EAzero : ExprA | EAone : ExprA | EAplus : ExprA -> ExprA -> ExprA | EAmult : ExprA -> ExprA -> ExprA | EAopp : ExprA -> ExprA | EAinv : ExprA -> ExprA | EAvar : nat -> ExprA. (**** Decidability of equality ****) Lemma eqExprA_O : forall e1 e2:ExprA, {e1 = e2} + {e1 <> e2}. Proof. double induction e1 e2; try intros; try (left; reflexivity) || (try (right; discriminate)). elim (H1 e0); intro y; elim (H2 e); intro y0; try (left; rewrite y; rewrite y0; auto) || (right; red; intro; inversion H3; auto). elim (H1 e0); intro y; elim (H2 e); intro y0; try (left; rewrite y; rewrite y0; auto) || (right; red; intro; inversion H3; auto). elim (H0 e); intro y. left; rewrite y; auto. right; red; intro; inversion H1; auto. elim (H0 e); intro y. left; rewrite y; auto. right; red; intro; inversion H1; auto. elim (eq_nat_dec n n0); intro y. left; rewrite y; auto. right; red; intro; inversion H; auto. Defined. Definition eq_nat_dec := Eval compute in eq_nat_dec. Definition eqExprA := Eval compute in eqExprA_O. (**** Generation of the multiplier ****) Fixpoint mult_of_list (e:list ExprA) : ExprA := match e with | nil => EAone | e1 :: l1 => EAmult e1 (mult_of_list l1) end. Section Theory_of_fields. Variable T : Field_Theory. Let AT := A T. Let AplusT := Aplus T. Let AmultT := Amult T. Let AoneT := Aone T. Let AzeroT := Azero T. Let AoppT := Aopp T. Let AeqT := Aeq T. Let AinvT := Ainv T. Let RTT := RT T. Let Th_inv_defT := Th_inv_def T. Add Legacy Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) ( Azero T) (Aopp T) (Aeq T) (RT T). Add Legacy Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT. (***************************) (* Lemmas to be used *) (***************************) Lemma AplusT_comm : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1. Proof. intros; legacy ring. Qed. Lemma AplusT_assoc : forall r1 r2 r3:AT, AplusT (AplusT r1 r2) r3 = AplusT r1 (AplusT r2 r3). Proof. intros; legacy ring. Qed. Lemma AmultT_comm : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1. Proof. intros; legacy ring. Qed. Lemma AmultT_assoc : forall r1 r2 r3:AT, AmultT (AmultT r1 r2) r3 = AmultT r1 (AmultT r2 r3). Proof. intros; legacy ring. Qed. Lemma AplusT_Ol : forall r:AT, AplusT AzeroT r = r. Proof. intros; legacy ring. Qed. Lemma AmultT_1l : forall r:AT, AmultT AoneT r = r. Proof. intros; legacy ring. Qed. Lemma AplusT_AoppT_r : forall r:AT, AplusT r (AoppT r) = AzeroT. Proof. intros; legacy ring. Qed. Lemma AmultT_AplusT_distr : forall r1 r2 r3:AT, AmultT r1 (AplusT r2 r3) = AplusT (AmultT r1 r2) (AmultT r1 r3). Proof. intros; legacy ring. Qed. Lemma r_AplusT_plus : forall r r1 r2:AT, AplusT r r1 = AplusT r r2 -> r1 = r2. Proof. intros; transitivity (AplusT (AplusT (AoppT r) r) r1). legacy ring. transitivity (AplusT (AplusT (AoppT r) r) r2). repeat rewrite AplusT_assoc; rewrite <- H; reflexivity. legacy ring. Qed. Lemma r_AmultT_mult : forall r r1 r2:AT, AmultT r r1 = AmultT r r2 -> r <> AzeroT -> r1 = r2. Proof. intros; transitivity (AmultT (AmultT (AinvT r) r) r1). rewrite Th_inv_defT; [ symmetry ; apply AmultT_1l; auto | auto ]. transitivity (AmultT (AmultT (AinvT r) r) r2). repeat rewrite AmultT_assoc; rewrite H; trivial. rewrite Th_inv_defT; [ apply AmultT_1l; auto | auto ]. Qed. Lemma AmultT_Or : forall r:AT, AmultT r AzeroT = AzeroT. Proof. intro; legacy ring. Qed. Lemma AmultT_Ol : forall r:AT, AmultT AzeroT r = AzeroT. Proof. intro; legacy ring. Qed. Lemma AmultT_1r : forall r:AT, AmultT r AoneT = r. Proof. intro; legacy ring. Qed. Lemma AinvT_r : forall r:AT, r <> AzeroT -> AmultT r (AinvT r) = AoneT. Proof. intros; rewrite AmultT_comm; apply Th_inv_defT; auto. Qed. Lemma Rmult_neq_0_reg : forall r1 r2:AT, AmultT r1 r2 <> AzeroT -> r1 <> AzeroT /\ r2 <> AzeroT. Proof. intros r1 r2 H; split; red; intro; apply H; rewrite H0; legacy ring. Qed. (************************) (* Interpretation *) (************************) (**** ExprA --> A ****) Fixpoint interp_ExprA (lvar:list (AT * nat)) (e:ExprA) {struct e} : AT := match e with | EAzero => AzeroT | EAone => AoneT | EAplus e1 e2 => AplusT (interp_ExprA lvar e1) (interp_ExprA lvar e2) | EAmult e1 e2 => AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2) | EAopp e => Aopp T (interp_ExprA lvar e) | EAinv e => Ainv T (interp_ExprA lvar e) | EAvar n => assoc_2nd AT nat eq_nat_dec lvar n AzeroT end. (************************) (* Simplification *) (************************) (**** Associativity ****) Definition merge_mult := (fix merge_mult (e1:ExprA) : ExprA -> ExprA := fun e2:ExprA => match e1 with | EAmult t1 t2 => match t2 with | EAmult t2 t3 => EAmult t1 (EAmult t2 (merge_mult t3 e2)) | _ => EAmult t1 (EAmult t2 e2) end | _ => EAmult e1 e2 end). Fixpoint assoc_mult (e:ExprA) : ExprA := match e with | EAmult e1 e3 => match e1 with | EAmult e1 e2 => merge_mult (merge_mult (assoc_mult e1) (assoc_mult e2)) (assoc_mult e3) | _ => EAmult e1 (assoc_mult e3) end | _ => e end. Definition merge_plus := (fix merge_plus (e1:ExprA) : ExprA -> ExprA := fun e2:ExprA => match e1 with | EAplus t1 t2 => match t2 with | EAplus t2 t3 => EAplus t1 (EAplus t2 (merge_plus t3 e2)) | _ => EAplus t1 (EAplus t2 e2) end | _ => EAplus e1 e2 end). Fixpoint assoc (e:ExprA) : ExprA := match e with | EAplus e1 e3 => match e1 with | EAplus e1 e2 => merge_plus (merge_plus (assoc e1) (assoc e2)) (assoc e3) | _ => EAplus (assoc_mult e1) (assoc e3) end | _ => assoc_mult e end. Lemma merge_mult_correct1 : forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (merge_mult (EAmult e1 e2) e3) = interp_ExprA lvar (EAmult e1 (merge_mult e2 e3)). Proof. intros e1 e2; generalize e1; generalize e2; clear e1 e2. simple induction e2; auto; intros. unfold merge_mult at 1; fold merge_mult; unfold interp_ExprA at 2; fold interp_ExprA; rewrite (H0 e e3 lvar); unfold interp_ExprA at 1; fold interp_ExprA; unfold interp_ExprA at 5; fold interp_ExprA; auto. Qed. Lemma merge_mult_correct : forall (e1 e2:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (merge_mult e1 e2) = interp_ExprA lvar (EAmult e1 e2). Proof. simple induction e1; auto; intros. elim e0; try (intros; simpl; legacy ring). unfold interp_ExprA in H2; fold interp_ExprA in H2; cut (AmultT (interp_ExprA lvar e2) (AmultT (interp_ExprA lvar e4) (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e3))) = AmultT (AmultT (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e4)) (interp_ExprA lvar e2)) (interp_ExprA lvar e3)). intro H3; rewrite H3; rewrite <- H2; rewrite merge_mult_correct1; simpl; legacy ring. legacy ring. Qed. Lemma assoc_mult_correct1 : forall (e1 e2:ExprA) (lvar:list (AT * nat)), AmultT (interp_ExprA lvar (assoc_mult e1)) (interp_ExprA lvar (assoc_mult e2)) = interp_ExprA lvar (assoc_mult (EAmult e1 e2)). Proof. simple induction e1; auto; intros. rewrite <- (H e0 lvar); simpl; rewrite merge_mult_correct; simpl; rewrite merge_mult_correct; simpl; auto. Qed. Lemma assoc_mult_correct : forall (e:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (assoc_mult e) = interp_ExprA lvar e. Proof. simple induction e; auto; intros. elim e0; intros. intros; simpl; legacy ring. simpl; rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1))); rewrite (AmultT_1l (interp_ExprA lvar e1)); apply H0. simpl; rewrite (H0 lvar); auto. simpl; rewrite merge_mult_correct; simpl; rewrite merge_mult_correct; simpl; rewrite AmultT_assoc; rewrite assoc_mult_correct1; rewrite H2; simpl; rewrite <- assoc_mult_correct1 in H1; unfold interp_ExprA at 3 in H1; fold interp_ExprA in H1; rewrite (H0 lvar) in H1; rewrite (AmultT_comm (interp_ExprA lvar e3) (interp_ExprA lvar e1)); rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc; legacy ring. simpl; rewrite (H0 lvar); auto. simpl; rewrite (H0 lvar); auto. simpl; rewrite (H0 lvar); auto. Qed. Lemma merge_plus_correct1 : forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (merge_plus (EAplus e1 e2) e3) = interp_ExprA lvar (EAplus e1 (merge_plus e2 e3)). Proof. intros e1 e2; generalize e1; generalize e2; clear e1 e2. simple induction e2; auto; intros. unfold merge_plus at 1; fold merge_plus; unfold interp_ExprA at 2; fold interp_ExprA; rewrite (H0 e e3 lvar); unfold interp_ExprA at 1; fold interp_ExprA; unfold interp_ExprA at 5; fold interp_ExprA; auto. Qed. Lemma merge_plus_correct : forall (e1 e2:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (merge_plus e1 e2) = interp_ExprA lvar (EAplus e1 e2). Proof. simple induction e1; auto; intros. elim e0; try intros; try (simpl; legacy ring). unfold interp_ExprA in H2; fold interp_ExprA in H2; cut (AplusT (interp_ExprA lvar e2) (AplusT (interp_ExprA lvar e4) (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e3))) = AplusT (AplusT (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e4)) (interp_ExprA lvar e2)) (interp_ExprA lvar e3)). intro H3; rewrite H3; rewrite <- H2; rewrite merge_plus_correct1; simpl; legacy ring. legacy ring. Qed. Lemma assoc_plus_correct : forall (e1 e2:ExprA) (lvar:list (AT * nat)), AplusT (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)) = interp_ExprA lvar (assoc (EAplus e1 e2)). Proof. simple induction e1; auto; intros. rewrite <- (H e0 lvar); simpl; rewrite merge_plus_correct; simpl; rewrite merge_plus_correct; simpl; auto. Qed. Lemma assoc_correct : forall (e:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (assoc e) = interp_ExprA lvar e. Proof. simple induction e; auto; intros. elim e0; intros. simpl; rewrite (H0 lvar); auto. simpl; rewrite (H0 lvar); auto. simpl; rewrite merge_plus_correct; simpl; rewrite merge_plus_correct; simpl; rewrite AplusT_assoc; rewrite assoc_plus_correct; rewrite H2; simpl; apply (r_AplusT_plus (interp_ExprA lvar (assoc e1)) (AplusT (interp_ExprA lvar (assoc e2)) (AplusT (interp_ExprA lvar e3) (interp_ExprA lvar e1))) (AplusT (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e3)) (interp_ExprA lvar e1))); rewrite <- AplusT_assoc; rewrite (AplusT_comm (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2))) ; rewrite assoc_plus_correct; rewrite H1; simpl; rewrite (H0 lvar); rewrite <- (AplusT_assoc (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e1)) (interp_ExprA lvar e3) (interp_ExprA lvar e1)) ; rewrite (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e1) (interp_ExprA lvar e3)); rewrite (AplusT_comm (interp_ExprA lvar e1) (interp_ExprA lvar e3)); rewrite <- (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3) (interp_ExprA lvar e1)); apply AplusT_comm. unfold assoc; fold assoc; unfold interp_ExprA; fold interp_ExprA; rewrite assoc_mult_correct; rewrite (H0 lvar); simpl; auto. simpl; rewrite (H0 lvar); auto. simpl; rewrite (H0 lvar); auto. simpl; rewrite (H0 lvar); auto. unfold assoc; fold assoc; unfold interp_ExprA; fold interp_ExprA; rewrite assoc_mult_correct; simpl; auto. Qed. (**** Distribution *****) Fixpoint distrib_EAopp (e:ExprA) : ExprA := match e with | EAplus e1 e2 => EAplus (distrib_EAopp e1) (distrib_EAopp e2) | EAmult e1 e2 => EAmult (distrib_EAopp e1) (distrib_EAopp e2) | EAopp e => EAmult (EAopp EAone) (distrib_EAopp e) | e => e end. Definition distrib_mult_right := (fix distrib_mult_right (e1:ExprA) : ExprA -> ExprA := fun e2:ExprA => match e1 with | EAplus t1 t2 => EAplus (distrib_mult_right t1 e2) (distrib_mult_right t2 e2) | _ => EAmult e1 e2 end). Fixpoint distrib_mult_left (e1 e2:ExprA) {struct e1} : ExprA := match e1 with | EAplus t1 t2 => EAplus (distrib_mult_left t1 e2) (distrib_mult_left t2 e2) | _ => distrib_mult_right e2 e1 end. Fixpoint distrib_main (e:ExprA) : ExprA := match e with | EAmult e1 e2 => distrib_mult_left (distrib_main e1) (distrib_main e2) | EAplus e1 e2 => EAplus (distrib_main e1) (distrib_main e2) | EAopp e => EAopp (distrib_main e) | _ => e end. Definition distrib (e:ExprA) : ExprA := distrib_main (distrib_EAopp e). Lemma distrib_mult_right_correct : forall (e1 e2:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (distrib_mult_right e1 e2) = AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2). Proof. simple induction e1; try intros; simpl; auto. rewrite AmultT_comm; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar); rewrite (H0 e2 lvar); legacy ring. Qed. Lemma distrib_mult_left_correct : forall (e1 e2:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (distrib_mult_left e1 e2) = AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2). Proof. simple induction e1; try intros; simpl. rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl; apply AmultT_Or. rewrite distrib_mult_right_correct; simpl; apply AmultT_comm. rewrite AmultT_comm; rewrite (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e) (interp_ExprA lvar e0)); rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e)); rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e0)); rewrite (H e2 lvar); rewrite (H0 e2 lvar); auto. rewrite distrib_mult_right_correct; simpl; apply AmultT_comm. rewrite distrib_mult_right_correct; simpl; apply AmultT_comm. rewrite distrib_mult_right_correct; simpl; apply AmultT_comm. rewrite distrib_mult_right_correct; simpl; apply AmultT_comm. Qed. Lemma distrib_correct : forall (e:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (distrib e) = interp_ExprA lvar e. Proof. simple induction e; intros; auto. simpl; rewrite <- (H lvar); rewrite <- (H0 lvar); unfold distrib; simpl; auto. simpl; rewrite <- (H lvar); rewrite <- (H0 lvar); unfold distrib; simpl; apply distrib_mult_left_correct. simpl; fold AoppT; rewrite <- (H lvar); unfold distrib; simpl; rewrite distrib_mult_right_correct; simpl; fold AoppT; legacy ring. Qed. (**** Multiplication by the inverse product ****) Lemma mult_eq : forall (e1 e2 a:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar a <> AzeroT -> interp_ExprA lvar (EAmult a e1) = interp_ExprA lvar (EAmult a e2) -> interp_ExprA lvar e1 = interp_ExprA lvar e2. Proof. simpl; intros; apply (r_AmultT_mult (interp_ExprA lvar a) (interp_ExprA lvar e1) (interp_ExprA lvar e2)); assumption. Qed. Fixpoint multiply_aux (a e:ExprA) {struct e} : ExprA := match e with | EAplus e1 e2 => EAplus (EAmult a e1) (multiply_aux a e2) | _ => EAmult a e end. Definition multiply (e:ExprA) : ExprA := match e with | EAmult a e1 => multiply_aux a e1 | _ => e end. Lemma multiply_aux_correct : forall (a e:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (multiply_aux a e) = AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). Proof. simple induction e; simpl; intros; try rewrite merge_mult_correct; auto. simpl; rewrite (H0 lvar); legacy ring. Qed. Lemma multiply_correct : forall (e:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (multiply e) = interp_ExprA lvar e. Proof. simple induction e; simpl; auto. intros; apply multiply_aux_correct. Qed. (**** Permutations and simplification ****) Fixpoint monom_remove (a m:ExprA) {struct m} : ExprA := match m with | EAmult m0 m1 => match eqExprA m0 (EAinv a) with | left _ => m1 | right _ => EAmult m0 (monom_remove a m1) end | _ => match eqExprA m (EAinv a) with | left _ => EAone | right _ => EAmult a m end end. Definition monom_simplif_rem := (fix monom_simplif_rem (a:ExprA) : ExprA -> ExprA := fun m:ExprA => match a with | EAmult a0 a1 => monom_simplif_rem a1 (monom_remove a0 m) | _ => monom_remove a m end). Definition monom_simplif (a m:ExprA) : ExprA := match m with | EAmult a' m' => match eqExprA a a' with | left _ => monom_simplif_rem a m' | right _ => m end | _ => m end. Fixpoint inverse_simplif (a e:ExprA) {struct e} : ExprA := match e with | EAplus e1 e2 => EAplus (monom_simplif a e1) (inverse_simplif a e2) | _ => monom_simplif a e end. Lemma monom_remove_correct : forall (e a:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar a <> AzeroT -> interp_ExprA lvar (monom_remove a e) = AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). Proof. simple induction e; intros. simpl; case (eqExprA EAzero (EAinv a)); intros; [ inversion e0 | simpl; trivial ]. simpl; case (eqExprA EAone (EAinv a)); intros; [ inversion e0 | simpl; trivial ]. simpl; case (eqExprA (EAplus e0 e1) (EAinv a)); intros; [ inversion e2 | simpl; trivial ]. simpl; case (eqExprA e0 (EAinv a)); intros. rewrite e2; simpl; fold AinvT. rewrite <- (AmultT_assoc (interp_ExprA lvar a) (AinvT (interp_ExprA lvar a)) (interp_ExprA lvar e1)); rewrite AinvT_r; [ legacy ring | assumption ]. simpl; rewrite H0; auto; legacy ring. simpl; fold AoppT; case (eqExprA (EAopp e0) (EAinv a)); intros; [ inversion e1 | simpl; trivial ]. unfold monom_remove; case (eqExprA (EAinv e0) (EAinv a)); intros. case (eqExprA e0 a); intros. rewrite e2; simpl; fold AinvT; rewrite AinvT_r; auto. inversion e1; simpl; exfalso; auto. simpl; trivial. unfold monom_remove; case (eqExprA (EAvar n) (EAinv a)); intros; [ inversion e0 | simpl; trivial ]. Qed. Lemma monom_simplif_rem_correct : forall (a e:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar a <> AzeroT -> interp_ExprA lvar (monom_simplif_rem a e) = AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). Proof. simple induction a; simpl; intros; try rewrite monom_remove_correct; auto. elim (Rmult_neq_0_reg (interp_ExprA lvar e) (interp_ExprA lvar e0) H1); intros. rewrite (H0 (monom_remove e e1) lvar H3); rewrite monom_remove_correct; auto. legacy ring. Qed. Lemma monom_simplif_correct : forall (e a:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar a <> AzeroT -> interp_ExprA lvar (monom_simplif a e) = interp_ExprA lvar e. Proof. simple induction e; intros; auto. simpl; case (eqExprA a e0); intros. rewrite <- e2; apply monom_simplif_rem_correct; auto. simpl; trivial. Qed. Lemma inverse_correct : forall (e a:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar a <> AzeroT -> interp_ExprA lvar (inverse_simplif a e) = interp_ExprA lvar e. Proof. simple induction e; intros; auto. simpl; rewrite (H0 a lvar H1); rewrite monom_simplif_correct; auto. unfold inverse_simplif; rewrite monom_simplif_correct; auto. Qed. End Theory_of_fields. (* Compatibility *) Notation AplusT_sym := AplusT_comm (only parsing). Notation AmultT_sym := AmultT_comm (only parsing). coq-8.4pl4/plugins/field/LegacyField.v0000644000175000017500000000131512326224777016736 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [ id ] | [ string(s) ] -> [ s ] END let pr_int_or_id _ _ _ = function | ArgInt i -> int i | ArgId id -> pr_id id ARGUMENT EXTEND int_or_id TYPED AS int_or_id PRINTED BY pr_int_or_id | [ preident(id) ] -> [ ArgId (id_of_string id) ] | [ integer(i) ] -> [ ArgInt i ] END let pr_language = function | Ocaml -> str "Ocaml" | Haskell -> str "Haskell" | Scheme -> str "Scheme" VERNAC ARGUMENT EXTEND language PRINTED BY pr_language | [ "Ocaml" ] -> [ Ocaml ] | [ "Haskell" ] -> [ Haskell ] | [ "Scheme" ] -> [ Scheme ] END (* Extraction commands *) VERNAC COMMAND EXTEND Extraction (* Extraction in the Coq toplevel *) | [ "Extraction" global(x) ] -> [ simple_extraction x ] | [ "Recursive" "Extraction" ne_global_list(l) ] -> [ full_extraction None l ] (* Monolithic extraction to a file *) | [ "Extraction" string(f) ne_global_list(l) ] -> [ full_extraction (Some f) l ] END VERNAC COMMAND EXTEND SeparateExtraction (* Same, with content splitted in several files *) | [ "Separate" "Extraction" ne_global_list(l) ] -> [ separate_extraction l ] END (* Modular extraction (one Coq library = one ML module) *) VERNAC COMMAND EXTEND ExtractionLibrary | [ "Extraction" "Library" ident(m) ] -> [ extraction_library false m ] END VERNAC COMMAND EXTEND RecursiveExtractionLibrary | [ "Recursive" "Extraction" "Library" ident(m) ] -> [ extraction_library true m ] END (* Target Language *) VERNAC COMMAND EXTEND ExtractionLanguage | [ "Extraction" "Language" language(l) ] -> [ extraction_language l ] END VERNAC COMMAND EXTEND ExtractionInline (* Custom inlining directives *) | [ "Extraction" "Inline" ne_global_list(l) ] -> [ extraction_inline true l ] END VERNAC COMMAND EXTEND ExtractionNoInline | [ "Extraction" "NoInline" ne_global_list(l) ] -> [ extraction_inline false l ] END VERNAC COMMAND EXTEND PrintExtractionInline | [ "Print" "Extraction" "Inline" ] -> [ print_extraction_inline () ] END VERNAC COMMAND EXTEND ResetExtractionInline | [ "Reset" "Extraction" "Inline" ] -> [ reset_extraction_inline () ] END VERNAC COMMAND EXTEND ExtractionImplicit (* Custom implicit arguments of some csts/inds/constructors *) | [ "Extraction" "Implicit" global(r) "[" int_or_id_list(l) "]" ] -> [ extraction_implicit r l ] END VERNAC COMMAND EXTEND ExtractionBlacklist (* Force Extraction to not use some filenames *) | [ "Extraction" "Blacklist" ne_ident_list(l) ] -> [ extraction_blacklist l ] END VERNAC COMMAND EXTEND PrintExtractionBlacklist | [ "Print" "Extraction" "Blacklist" ] -> [ print_extraction_blacklist () ] END VERNAC COMMAND EXTEND ResetExtractionBlacklist | [ "Reset" "Extraction" "Blacklist" ] -> [ reset_extraction_blacklist () ] END (* Overriding of a Coq object by an ML one *) VERNAC COMMAND EXTEND ExtractionConstant | [ "Extract" "Constant" global(x) string_list(idl) "=>" mlname(y) ] -> [ extract_constant_inline false x idl y ] END VERNAC COMMAND EXTEND ExtractionInlinedConstant | [ "Extract" "Inlined" "Constant" global(x) "=>" mlname(y) ] -> [ extract_constant_inline true x [] y ] END VERNAC COMMAND EXTEND ExtractionInductive | [ "Extract" "Inductive" global(x) "=>" mlname(id) "[" mlname_list(idl) "]" string_opt(o) ] -> [ extract_inductive x id idl o ] END coq-8.4pl4/plugins/extraction/extract_env.mli0000644000175000017500000000210412326224777020516 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val full_extraction : string option -> reference list -> unit val separate_extraction : reference list -> unit val extraction_library : bool -> identifier -> unit (* For debug / external output via coqtop.byte + Drop : *) val mono_environment : global_reference list -> module_path list -> Miniml.ml_structure (* Used by the Relation Extraction plugin *) val print_one_decl : Miniml.ml_structure -> module_path -> Miniml.ml_decl -> unit coq-8.4pl4/plugins/extraction/ocaml.ml0000644000175000017500000006177312326224777017137 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* '\'' then str ("'"^s) else str ("' "^s) let pp_abst = function | [] -> mt () | l -> str "fun " ++ prlist_with_sep (fun () -> str " ") pr_id l ++ str " ->" ++ spc () let pp_parameters l = (pp_boxed_tuple pp_tvar l ++ space_if (l<>[])) let pp_string_parameters l = (pp_boxed_tuple str l ++ space_if (l<>[])) let pp_letin pat def body = let fstline = str "let " ++ pat ++ str " =" ++ spc () ++ def in hv 0 (hv 0 (hov 2 fstline ++ spc () ++ str "in") ++ spc () ++ hov 0 body) (*s Ocaml renaming issues. *) let keywords = List.fold_right (fun s -> Idset.add (id_of_string s)) [ "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do"; "done"; "downto"; "else"; "end"; "exception"; "external"; "false"; "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; "inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module"; "mutable"; "new"; "object"; "of"; "open"; "or"; "parser"; "private"; "rec"; "sig"; "struct"; "then"; "to"; "true"; "try"; "type"; "val"; "virtual"; "when"; "while"; "with"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ] Idset.empty let pp_open mp = str ("open "^ string_of_modfile mp ^"\n") let preamble _ used_modules usf = prlist pp_open used_modules ++ (if used_modules = [] then mt () else fnl ()) ++ (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n" else mt()) ++ (if usf.mldummy then str "let __ = let rec f _ = Obj.repr f in Obj.repr f\n" else mt ()) ++ (if usf.tdummy || usf.tunknown || usf.mldummy then fnl () else mt ()) let sig_preamble _ used_modules usf = prlist pp_open used_modules ++ (if used_modules = [] then mt () else fnl ()) ++ (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n\n" else mt()) (*s The pretty-printer for Ocaml syntax*) (* Beware of the side-effects of [pp_global] and [pp_modname]. They are used to update table of content for modules. Many [let] below should not be altered since they force evaluation order. *) let str_global k r = if is_inline_custom r then find_custom r else Common.pp_global k r let pp_global k r = str (str_global k r) let pp_modname mp = str (Common.pp_module mp) let is_infix r = is_inline_custom r && (let s = find_custom r in let l = String.length s in l >= 2 && s.[0] = '(' && s.[l-1] = ')') let get_infix r = let s = find_custom r in String.sub s 1 (String.length s - 2) let get_ind = function | IndRef _ as r -> r | ConstructRef (ind,_) -> IndRef ind | _ -> assert false let pp_one_field r i = function | Some r -> pp_global Term r | None -> pp_global Type (get_ind r) ++ str "__" ++ int i let pp_field r fields i = pp_one_field r i (List.nth fields i) let pp_fields r fields = list_map_i (pp_one_field r) 0 fields (*s Pretty-printing of types. [par] is a boolean indicating whether parentheses are needed or not. *) let rec pp_type par vl t = let rec pp_rec par = function | Tmeta _ | Tvar' _ | Taxiom -> assert false | Tvar i -> (try pp_tvar (List.nth vl (pred i)) with e when Errors.noncritical e -> (str "'a" ++ int i)) | Tglob (r,[a1;a2]) when is_infix r -> pp_par par (pp_rec true a1 ++ str (get_infix r) ++ pp_rec true a2) | Tglob (r,[]) -> pp_global Type r | Tglob (IndRef(kn,0),l) when not (keep_singleton ()) && kn = mk_ind "Coq.Init.Specif" "sig" -> pp_tuple_light pp_rec l | Tglob (r,l) -> pp_tuple_light pp_rec l ++ spc () ++ pp_global Type r | Tarr (t1,t2) -> pp_par par (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) | Tdummy _ -> str "__" | Tunknown -> str "__" in hov 0 (pp_rec par t) (*s Pretty-printing of expressions. [par] indicates whether parentheses are needed or not. [env] is the list of names for the de Bruijn variables. [args] is the list of collected arguments (already pretty-printed). *) let is_bool_patt p s = try let r = match p with | Pusual r -> r | Pcons (r,[]) -> r | _ -> raise Not_found in find_custom r = s with Not_found -> false let is_ifthenelse = function | [|([],p1,_);([],p2,_)|] -> is_bool_patt p1 "true" && is_bool_patt p2 "false" | _ -> false let expr_needs_par = function | MLlam _ -> true | MLcase (_,_,[|_|]) -> false | MLcase (_,_,pv) -> not (is_ifthenelse pv) | _ -> false let rec pp_expr par env args = let apply st = pp_apply st par args and apply2 st = pp_apply2 st par args in function | MLrel n -> let id = get_db_name n env in apply (pr_id id) | MLapp (f,args') -> let stl = List.map (pp_expr true env []) args' in pp_expr par env (stl @ args) f | MLlam _ as a -> let fl,a' = collect_lams a in let fl = List.map id_of_mlid fl in let fl,env' = push_vars fl env in let st = pp_abst (List.rev fl) ++ pp_expr false env' [] a' in apply2 st | MLletin (id,a1,a2) -> let i,env' = push_vars [id_of_mlid id] env in let pp_id = pr_id (List.hd i) and pp_a1 = pp_expr false env [] a1 and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in hv 0 (apply2 (pp_letin pp_id pp_a1 pp_a2)) | MLglob r -> (try let args = list_skipn (projection_arity r) args in let record = List.hd args in pp_apply (record ++ str "." ++ pp_global Term r) par (List.tl args) with e when Errors.noncritical e -> apply (pp_global Term r)) | MLfix (i,ids,defs) -> let ids',env' = push_vars (List.rev (Array.to_list ids)) env in pp_fix par env' i (Array.of_list (List.rev ids'),defs) args | MLexn s -> (* An [MLexn] may be applied, but I don't really care. *) pp_par par (str "assert false" ++ spc () ++ str ("(* "^s^" *)")) | MLdummy -> str "__" (* An [MLdummy] may be applied, but I don't really care. *) | MLmagic a -> pp_apply (str "Obj.magic") par (pp_expr true env [] a :: args) | MLaxiom -> pp_par par (str "failwith \"AXIOM TO BE REALIZED\"") | MLcons (_,r,a) as c -> assert (args=[]); begin match a with | _ when is_native_char c -> pp_native_char c | [a1;a2] when is_infix r -> let pp = pp_expr true env [] in pp_par par (pp a1 ++ str (get_infix r) ++ pp a2) | _ when is_coinductive r -> let ne = (a<>[]) in let tuple = space_if ne ++ pp_tuple (pp_expr true env []) a in pp_par par (str "lazy " ++ pp_par ne (pp_global Cons r ++ tuple)) | [] -> pp_global Cons r | _ -> let fds = get_record_fields r in if fds <> [] then pp_record_pat (pp_fields r fds, List.map (pp_expr true env []) a) else let tuple = pp_tuple (pp_expr true env []) a in if str_global Cons r = "" (* hack Extract Inductive prod *) then tuple else pp_par par (pp_global Cons r ++ spc () ++ tuple) end | MLtuple l -> assert (args = []); pp_boxed_tuple (pp_expr true env []) l | MLcase (_, t, pv) when is_custom_match pv -> if not (is_regular_match pv) then error "Cannot mix yet user-given match and general patterns."; let mkfun (ids,_,e) = if ids <> [] then named_lams (List.rev ids) e else dummy_lams (ast_lift 1 e) 1 in let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in let inner = str (find_custom_match pv) ++ fnl () ++ prvect pp_branch pv ++ pp_expr true env [] t in apply2 (hov 2 inner) | MLcase (typ, t, pv) -> let head = if not (is_coinductive_type typ) then pp_expr false env [] t else (str "Lazy.force" ++ spc () ++ pp_expr true env [] t) in (* First, can this match be printed as a mere record projection ? *) (try pp_record_proj par env typ t pv args with Impossible -> (* Second, can this match be printed as a let-in ? *) if Array.length pv = 1 then let s1,s2 = pp_one_pat env pv.(0) in hv 0 (apply2 (pp_letin s1 head s2)) else (* Third, can this match be printed as [if ... then ... else] ? *) (try apply2 (pp_ifthenelse env head pv) with Not_found -> (* Otherwise, standard match *) apply2 (v 0 (str "match " ++ head ++ str " with" ++ fnl () ++ pp_pat env pv)))) and pp_record_proj par env typ t pv args = (* Can a match be printed as a mere record projection ? *) let fields = record_fields_of_type typ in if fields = [] then raise Impossible; if Array.length pv <> 1 then raise Impossible; if has_deep_pattern pv then raise Impossible; let (ids,pat,body) = pv.(0) in let n = List.length ids in let no_patvar a = not (List.exists (ast_occurs_itvl 1 n) a) in let rel_i,a = match body with | MLrel i when i <= n -> i,[] | MLapp(MLrel i, a) when i<=n && no_patvar a -> i,a | _ -> raise Impossible in let rec lookup_rel i idx = function | Prel j :: l -> if i = j then idx else lookup_rel i (idx+1) l | Pwild :: l -> lookup_rel i (idx+1) l | _ -> raise Impossible in let r,idx = match pat with | Pusual r -> r, n-rel_i | Pcons (r,l) -> r, lookup_rel rel_i 0 l | _ -> raise Impossible in if is_infix r then raise Impossible; let env' = snd (push_vars (List.rev_map id_of_mlid ids) env) in let pp_args = (List.map (pp_expr true env' []) a) @ args in let pp_head = pp_expr true env [] t ++ str "." ++ pp_field r fields idx in pp_apply pp_head par pp_args and pp_record_pat (fields, args) = str "{ " ++ prlist_with_sep (fun () -> str ";" ++ spc ()) (fun (f,a) -> f ++ str " =" ++ spc () ++ a) (List.combine fields args) ++ str " }" and pp_cons_pat r ppl = if is_infix r && List.length ppl = 2 then List.hd ppl ++ str (get_infix r) ++ List.hd (List.tl ppl) else let fields = get_record_fields r in if fields <> [] then pp_record_pat (pp_fields r fields, ppl) else if str_global Cons r = "" then pp_boxed_tuple identity ppl (* Hack Extract Inductive prod *) else pp_global Cons r ++ space_if (ppl<>[]) ++ pp_boxed_tuple identity ppl and pp_gen_pat ids env = function | Pcons (r, l) -> pp_cons_pat r (List.map (pp_gen_pat ids env) l) | Pusual r -> pp_cons_pat r (List.map pr_id ids) | Ptuple l -> pp_boxed_tuple (pp_gen_pat ids env) l | Pwild -> str "_" | Prel n -> pr_id (get_db_name n env) and pp_ifthenelse env expr pv = match pv with | [|([],tru,the);([],fal,els)|] when (is_bool_patt tru "true") && (is_bool_patt fal "false") -> hv 0 (hov 2 (str "if " ++ expr) ++ spc () ++ hov 2 (str "then " ++ hov 2 (pp_expr (expr_needs_par the) env [] the)) ++ spc () ++ hov 2 (str "else " ++ hov 2 (pp_expr (expr_needs_par els) env [] els))) | _ -> raise Not_found and pp_one_pat env (ids,p,t) = let ids',env' = push_vars (List.rev_map id_of_mlid ids) env in pp_gen_pat (List.rev ids') env' p, pp_expr (expr_needs_par t) env' [] t and pp_pat env pv = prvecti (fun i x -> let s1,s2 = pp_one_pat env x in hv 2 (hov 4 (str "| " ++ s1 ++ str " ->") ++ spc () ++ hov 2 s2) ++ if i = Array.length pv - 1 then mt () else fnl ()) pv and pp_function env t = let bl,t' = collect_lams t in let bl,env' = push_vars (List.map id_of_mlid bl) env in match t' with | MLcase(Tglob(r,_),MLrel 1,pv) when not (is_coinductive r) && get_record_fields r = [] && not (is_custom_match pv) -> if not (ast_occurs 1 (MLcase(Tunknown,MLdummy,pv))) then pr_binding (List.rev (List.tl bl)) ++ str " = function" ++ fnl () ++ v 0 (pp_pat env' pv) else pr_binding (List.rev bl) ++ str " = match " ++ pr_id (List.hd bl) ++ str " with" ++ fnl () ++ v 0 (pp_pat env' pv) | _ -> pr_binding (List.rev bl) ++ str " =" ++ fnl () ++ str " " ++ hov 2 (pp_expr false env' [] t') (*s names of the functions ([ids]) are already pushed in [env], and passed here just for convenience. *) and pp_fix par env i (ids,bl) args = pp_par par (v 0 (str "let rec " ++ prvect_with_sep (fun () -> fnl () ++ str "and ") (fun (fi,ti) -> pr_id fi ++ pp_function env ti) (array_map2 (fun id b -> (id,b)) ids bl) ++ fnl () ++ hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args))) let pp_val e typ = hov 4 (str "(** val " ++ e ++ str " :" ++ spc () ++ pp_type false [] typ ++ str " **)") ++ fnl2 () (*s Pretty-printing of [Dfix] *) let pp_Dfix (rv,c,t) = let names = Array.map (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv in let rec pp init i = if i >= Array.length rv then (if init then failwith "empty phrase" else mt ()) else let void = is_inline_custom rv.(i) || (not (is_custom rv.(i)) && c.(i) = MLexn "UNUSED") in if void then pp init (i+1) else let def = if is_custom rv.(i) then str " = " ++ str (find_custom rv.(i)) else pp_function (empty_env ()) c.(i) in (if init then mt () else fnl2 ()) ++ pp_val names.(i) t.(i) ++ str (if init then "let rec " else "and ") ++ names.(i) ++ def ++ pp false (i+1) in pp true 0 (*s Pretty-printing of inductive types declaration. *) let pp_equiv param_list name = function | NoEquiv, _ -> mt () | Equiv kn, i -> str " = " ++ pp_parameters param_list ++ pp_global Type (IndRef (mind_of_kn kn,i)) | RenEquiv ren, _ -> str " = " ++ pp_parameters param_list ++ str (ren^".") ++ name let pp_comment s = str "(* " ++ s ++ str " *)" let pp_one_ind prefix ip_equiv pl name cnames ctyps = let pl = rename_tvars keywords pl in let pp_constructor i typs = (if i=0 then mt () else fnl ()) ++ hov 3 (str "| " ++ cnames.(i) ++ (if typs = [] then mt () else str " of ") ++ prlist_with_sep (fun () -> spc () ++ str "* ") (pp_type true pl) typs) in pp_parameters pl ++ str prefix ++ name ++ pp_equiv pl name ip_equiv ++ str " =" ++ if Array.length ctyps = 0 then str " unit (* empty inductive *)" else fnl () ++ v 0 (prvecti pp_constructor ctyps) let pp_logical_ind packet = pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ fnl () ++ pp_comment (str "with constructors : " ++ prvect_with_sep spc pr_id packet.ip_consnames) ++ fnl () let pp_singleton kn packet = let name = pp_global Type (IndRef (kn,0)) in let l = rename_tvars keywords packet.ip_vars in hov 2 (str "type " ++ pp_parameters l ++ name ++ str " =" ++ spc () ++ pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ pp_comment (str "singleton inductive, whose constructor was " ++ pr_id packet.ip_consnames.(0))) let pp_record kn fields ip_equiv packet = let ind = IndRef (kn,0) in let name = pp_global Type ind in let fieldnames = pp_fields ind fields in let l = List.combine fieldnames packet.ip_types.(0) in let pl = rename_tvars keywords packet.ip_vars in str "type " ++ pp_parameters pl ++ name ++ pp_equiv pl name ip_equiv ++ str " = { "++ hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ()) (fun (p,t) -> p ++ str " : " ++ pp_type true pl t) l) ++ str " }" let pp_coind pl name = let pl = rename_tvars keywords pl in pp_parameters pl ++ name ++ str " = " ++ pp_parameters pl ++ str "__" ++ name ++ str " Lazy.t" ++ fnl() ++ str "and " let pp_ind co kn ind = let prefix = if co then "__" else "" in let some = ref false in let init= ref (str "type ") in let names = Array.mapi (fun i p -> if p.ip_logical then mt () else pp_global Type (IndRef (kn,i))) ind.ind_packets in let cnames = Array.mapi (fun i p -> if p.ip_logical then [||] else Array.mapi (fun j _ -> pp_global Cons (ConstructRef ((kn,i),j+1))) p.ip_types) ind.ind_packets in let rec pp i = if i >= Array.length ind.ind_packets then mt () else let ip = (kn,i) in let ip_equiv = ind.ind_equiv, i in let p = ind.ind_packets.(i) in if is_custom (IndRef ip) then pp (i+1) else begin some := true; if p.ip_logical then pp_logical_ind p ++ pp (i+1) else let s = !init in begin init := (fnl () ++ str "and "); s ++ (if co then pp_coind p.ip_vars names.(i) else mt ()) ++ pp_one_ind prefix ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++ pp (i+1) end end in let st = pp 0 in if !some then st else failwith "empty phrase" (*s Pretty-printing of a declaration. *) let pp_mind kn i = match i.ind_kind with | Singleton -> pp_singleton kn i.ind_packets.(0) | Coinductive -> pp_ind true kn i | Record fields -> pp_record kn fields (i.ind_equiv,0) i.ind_packets.(0) | Standard -> pp_ind false kn i let pp_decl = function | Dtype (r,_,_) when is_inline_custom r -> failwith "empty phrase" | Dterm (r,_,_) when is_inline_custom r -> failwith "empty phrase" | Dind (kn,i) -> pp_mind kn i | Dtype (r, l, t) -> let name = pp_global Type r in let l = rename_tvars keywords l in let ids, def = try let ids,s = find_type_custom r in pp_string_parameters ids, str "=" ++ spc () ++ str s with Not_found -> pp_parameters l, if t = Taxiom then str "(* AXIOM TO BE REALIZED *)" else str "=" ++ spc () ++ pp_type false l t in hov 2 (str "type " ++ ids ++ name ++ spc () ++ def) | Dterm (r, a, t) -> let def = if is_custom r then str (" = " ^ find_custom r) else if is_projection r then (prvect str (Array.make (projection_arity r) " _")) ++ str " x = x." else pp_function (empty_env ()) a in let name = pp_global Term r in let postdef = if is_projection r then name else mt () in pp_val name t ++ hov 0 (str "let " ++ name ++ def ++ postdef) | Dfix (rv,defs,typs) -> pp_Dfix (rv,defs,typs) let pp_alias_decl ren = function | Dind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren } | Dtype (r, l, _) -> let name = pp_global Type r in let l = rename_tvars keywords l in let ids = pp_parameters l in hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ str (ren^".") ++ name) | Dterm (r, a, t) -> let name = pp_global Term r in hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name) | Dfix (rv, _, _) -> prvecti (fun i r -> if is_inline_custom r then mt () else let name = pp_global Term r in hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name) ++ fnl ()) rv let pp_spec = function | Sval (r,_) when is_inline_custom r -> failwith "empty phrase" | Stype (r,_,_) when is_inline_custom r -> failwith "empty phrase" | Sind (kn,i) -> pp_mind kn i | Sval (r,t) -> let def = pp_type false [] t in let name = pp_global Term r in hov 2 (str "val " ++ name ++ str " :" ++ spc () ++ def) | Stype (r,vl,ot) -> let name = pp_global Type r in let l = rename_tvars keywords vl in let ids, def = try let ids, s = find_type_custom r in pp_string_parameters ids, str "= " ++ str s with Not_found -> let ids = pp_parameters l in match ot with | None -> ids, mt () | Some Taxiom -> ids, str "(* AXIOM TO BE REALIZED *)" | Some t -> ids, str "=" ++ spc () ++ pp_type false l t in hov 2 (str "type " ++ ids ++ name ++ spc () ++ def) let pp_alias_spec ren = function | Sind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren } | Stype (r,l,_) -> let name = pp_global Type r in let l = rename_tvars keywords l in let ids = pp_parameters l in hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ str (ren^".") ++ name) | Sval _ -> assert false let rec pp_specif = function | (_,Spec (Sval _ as s)) -> pp_spec s | (l,Spec s) -> (try let ren = Common.check_duplicate (top_visible_mp ()) l in hov 1 (str ("module "^ren^" : sig ") ++ fnl () ++ pp_spec s) ++ fnl () ++ str "end" ++ fnl () ++ pp_alias_spec ren s with Not_found -> pp_spec s) | (l,Smodule mt) -> let def = pp_module_type [] mt in let def' = pp_module_type [] mt in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 (str "module " ++ name ++ str " : " ++ fnl () ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in fnl () ++ hov 1 (str ("module "^ren^" : ") ++ fnl () ++ def') with Not_found -> Pp.mt ()) | (l,Smodtype mt) -> let def = pp_module_type [] mt in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in fnl () ++ str ("module type "^ren^" = ") ++ name with Not_found -> Pp.mt ()) and pp_module_type params = function | MTident kn -> pp_modname kn | MTfunsig (mbid, mt, mt') -> let typ = pp_module_type [] mt in let name = pp_modname (MPbound mbid) in let def = pp_module_type (MPbound mbid :: params) mt' in str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def | MTsig (mp, sign) -> push_visible mp params; let l = map_succeed pp_specif sign in pop_visible (); str "sig " ++ fnl () ++ v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ fnl () ++ str "end" | MTwith(mt,ML_With_type(idl,vl,typ)) -> let ids = pp_parameters (rename_tvars keywords vl) in let mp_mt = msid_of_mt mt in let l,idl' = list_sep_last idl in let mp_w = List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl' in let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l)) in push_visible mp_mt []; let pp_w = str " with type " ++ ids ++ pp_global Type r in pop_visible(); pp_module_type [] mt ++ pp_w ++ str " = " ++ pp_type false vl typ | MTwith(mt,ML_With_module(idl,mp)) -> let mp_mt = msid_of_mt mt in let mp_w = List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) mp_mt idl in push_visible mp_mt []; let pp_w = str " with module " ++ pp_modname mp_w in pop_visible (); pp_module_type [] mt ++ pp_w ++ str " = " ++ pp_modname mp let is_short = function MEident _ | MEapply _ -> true | _ -> false let rec pp_structure_elem = function | (l,SEdecl d) -> (try let ren = Common.check_duplicate (top_visible_mp ()) l in hov 1 (str ("module "^ren^" = struct ") ++ fnl () ++ pp_decl d) ++ fnl () ++ str "end" ++ fnl () ++ pp_alias_decl ren d with Not_found -> pp_decl d) | (l,SEmodule m) -> let typ = (* virtual printing of the type, in order to have a correct mli later*) if Common.get_phase () = Pre then str ": " ++ pp_module_type [] m.ml_mod_type else mt () in let def = pp_module_expr [] m.ml_mod_expr in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 (str "module " ++ name ++ typ ++ str " = " ++ (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in fnl () ++ str ("module "^ren^" = ") ++ name with Not_found -> mt ()) | (l,SEmodtype m) -> let def = pp_module_type [] m in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in fnl () ++ str ("module type "^ren^" = ") ++ name with Not_found -> mt ()) and pp_module_expr params = function | MEident mp -> pp_modname mp | MEapply (me, me') -> pp_module_expr [] me ++ str "(" ++ pp_module_expr [] me' ++ str ")" | MEfunctor (mbid, mt, me) -> let name = pp_modname (MPbound mbid) in let typ = pp_module_type [] mt in let def = pp_module_expr (MPbound mbid :: params) me in str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def | MEstruct (mp, sel) -> push_visible mp params; let l = map_succeed pp_structure_elem sel in pop_visible (); str "struct " ++ fnl () ++ v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ fnl () ++ str "end" let do_struct f s = let pp s = try f s ++ fnl2 () with Failure "empty phrase" -> mt () in let ppl (mp,sel) = push_visible mp []; let p = prlist_strict pp sel in (* for monolithic extraction, we try to simulate the unavailability of [MPfile] in names by artificially nesting these [MPfile] *) (if modular () then pop_visible ()); p in let p = prlist_strict ppl s in (if not (modular ()) then repeat (List.length s) pop_visible ()); p let pp_struct s = do_struct pp_structure_elem s let pp_signature s = do_struct pp_specif s let pp_decl d = try pp_decl d with Failure "empty phrase" -> mt () let ocaml_descr = { keywords = keywords; file_suffix = ".ml"; preamble = preamble; pp_struct = pp_struct; sig_suffix = Some ".mli"; sig_preamble = sig_preamble; pp_sig = pp_signature; pp_decl = pp_decl; } coq-8.4pl4/plugins/extraction/vo.itarget0000644000175000017500000000023512326224777017501 0ustar stephstephExtrOcamlBasic.vo ExtrOcamlIntConv.vo ExtrOcamlBigIntConv.vo ExtrOcamlNatInt.vo ExtrOcamlNatBigInt.vo ExtrOcamlZInt.vo ExtrOcamlZBigInt.vo ExtrOcamlString.vocoq-8.4pl4/plugins/extraction/modutil.mli0000644000175000017500000000310412326224777017652 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool) -> ml_structure -> bool val struct_type_search : (ml_type -> bool) -> ml_structure -> bool type do_ref = global_reference -> unit val decl_iter_references : do_ref -> do_ref -> do_ref -> ml_decl -> unit val spec_iter_references : do_ref -> do_ref -> do_ref -> ml_spec -> unit val signature_of_structure : ml_structure -> ml_signature val msid_of_mt : ml_module_type -> module_path val get_decl_in_structure : global_reference -> ml_structure -> ml_decl (* Some transformations of ML terms. [optimize_struct] simplify all beta redexes (when the argument does not occur, it is just thrown away; when it occurs exactly once it is substituted; otherwise a let-in redex is created for clarity) and iota redexes, plus some other optimizations. The first argument is the list of objects we want to appear. *) val optimize_struct : global_reference list * module_path list -> ml_structure -> ml_structure coq-8.4pl4/plugins/extraction/README0000644000175000017500000001130212326224777016351 0ustar stephsteph Coq Extraction ============== What is it ? ------------ The extraction is a mechanism allowing to produce functional code (Ocaml/Haskell/Scheme) out of any Coq terms (either programs or proofs). Who did it ? ------------ The current implementation (from version 7.0 up to now) has been done by P. Letouzey during his PhD, helped by J.C. Filliâtre and supervised by C. Paulin. An earlier implementation (versions 6.x) was due to B. Werner and C. Paulin. Where can we find more information ? ------------------------------------ - Coq Reference Manual includes a full chapter about extraction - P. Letouzey's PhD thesis [3] forms a complete document about both theory and implementation and test-cases of Coq-extraction - A more recent article [4] proposes a short overview of extraction - earlier documents [1] [2] may also be useful. Why a complete re-implementation ? ---------------------------------- Extraction code has been completely rewritten since version V6.3. 1) Principles The main goal of the new extraction is to handle any Coq term, even those upon sort Type, and to produce code that always compiles. Thus it will never answer something like "Not an ML type", but rather a dummy term like the ML unit. Translation between Coq and ML is based upon the following principles: - Terms of sort Prop don't have any computational meaning, so they are merged into one ML term "__". This part is done according to P. Letouzey's works [1] and [2]. This dummy constant "__" used to be implemented by the unit (), but we recently found that this constant might be applied in some cases. So "__" is now in Ocaml a fixpoint that forgets its arguments: let __ = let rec f _ = Obj.repr f in Obj.repr f - Terms that are type schemes (i.e. something of type ( : )( : )...s with s a sort ) don't have any ML counterpart at the term level, since they are types transformers. In fact they do not have any computational meaning either. So we also merge them into that dummy term "__". - A Coq term gives a ML term or a ML type depending of its type: type schemes will (try to) give ML types, and all other terms give ML terms. And the rest of the translation is (almost) straightforward: an inductive gives an inductive, etc... This gives ML code that have no special reason to typecheck, due to the incompatibilities between Coq and ML typing systems. In fact most of the time everything goes right. We now verify during extraction that the produced code is typecheckable, and if it is not we insert unsafe type casting at critical points in the code, with either "Obj.magic" in Ocaml or "unsafeCoerce" in Haskell. 2) Differences with previous extraction (V6.3 and before) 2.a) The pros The ability to extract every Coq term, as explain in the previous paragraph. The ability to extract from a file an ML module (cf Extraction Library in the documentation) You can have a taste of extraction directly at the toplevel by using the "Extraction " or the "Recursive Extraction ". This toplevel extraction was already there in V6.3, but was printing Fw terms. It now prints in the language of your choice: Ocaml, Haskell or Scheme. The optimization done on extracted code has been ported between V6.3 and V7 and enhanced, and in particular the mechanism of automatic expansion. 2.b) The cons The presence of some parasite "__" as dummy arguments in functions. This denotes the rests of a proof part. The previous extraction was able to remove them totally. The current implementation removes a good deal of them, but not all. This problem is due to extraction upon Type. For example, let's take this pathological term: (if b then Set else Prop) : Type The only way to know if this is an Set (to keep) or a Prop (to remove) is to compute the boolean b, and we do not want to do that during extraction. There is no more "ML import" feature. You can compensate by using Axioms, and then "Extract Constant ..." [1]: Exécution de termes de preuves: une nouvelle méthode d'extraction pour le Calcul des Constructions Inductives, Pierre Letouzey, DEA thesis, 2000, http://www.pps.jussieu.fr/~letouzey/download/rapport_dea.ps.gz [2]: A New Extraction for Coq, Pierre Letouzey, Types 2002 Post-Workshop Proceedings. http://www.pps.jussieu.fr/~letouzey/download/extraction2002.ps.gz [3]: Programmation fonctionnelle certifiée: l'extraction de programmes dans l'assistant Coq. Pierre Letouzey, PhD thesis, 2004. http://www.pps.jussieu.fr/~letouzey/download/these_letouzey.ps.gz http://www.pps.jussieu.fr/~letouzey/download/these_letouzey_English.ps.gz [4]: Coq Extraction, An overview. Pierre Letouzey. CiE2008. http://www.pps.jussieu.fr/~letouzey/download/letouzey_extr_cie08.pdf coq-8.4pl4/plugins/extraction/table.mli0000644000175000017500000001437612326224777017301 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* identifier (*s Warning and Error messages. *) val warning_axioms : unit -> unit val warning_opaques : bool -> unit val warning_both_mod_and_cst : qualid -> module_path -> global_reference -> unit val warning_id : string -> unit val error_axiom_scheme : global_reference -> int -> 'a val error_constant : global_reference -> 'a val error_inductive : global_reference -> 'a val error_nb_cons : unit -> 'a val error_module_clash : module_path -> module_path -> 'a val error_no_module_expr : module_path -> 'a val error_singleton_become_prop : identifier -> 'a val error_unknown_module : qualid -> 'a val error_scheme : unit -> 'a val error_not_visible : global_reference -> 'a val error_MPfile_as_mod : module_path -> bool -> 'a val check_inside_module : unit -> unit val check_inside_section : unit -> unit val check_loaded_modfile : module_path -> unit val msg_non_implicit : global_reference -> int -> name -> string val error_non_implicit : string -> 'a val info_file : string -> unit (*s utilities about [module_path] and [kernel_names] and [global_reference] *) val occur_kn_in_ref : mutual_inductive -> global_reference -> bool val repr_of_r : global_reference -> module_path * dir_path * label val modpath_of_r : global_reference -> module_path val label_of_r : global_reference -> label val current_toplevel : unit -> module_path val base_mp : module_path -> module_path val is_modfile : module_path -> bool val string_of_modfile : module_path -> string val file_of_modfile : module_path -> string val is_toplevel : module_path -> bool val at_toplevel : module_path -> bool val visible_con : constant -> bool val mp_length : module_path -> int val prefixes_mp : module_path -> MPset.t val common_prefix_from_list : module_path -> module_path list -> module_path option val get_nth_label_mp : int -> module_path -> label val labels_of_ref : global_reference -> module_path * label list (*s Some table-related operations *) val add_term : constant -> ml_decl -> unit val lookup_term : constant -> ml_decl val add_type : constant -> ml_schema -> unit val lookup_type : constant -> ml_schema val add_ind : mutual_inductive -> mutual_inductive_body -> ml_ind -> unit val lookup_ind : mutual_inductive -> mutual_inductive_body * ml_ind val add_inductive_kind : mutual_inductive -> inductive_kind -> unit val is_coinductive : global_reference -> bool val is_coinductive_type : ml_type -> bool (* What are the fields of a record (empty for a non-record) *) val get_record_fields : global_reference -> global_reference option list val record_fields_of_type : ml_type -> global_reference option list val add_recursors : Environ.env -> mutual_inductive -> unit val is_recursor : global_reference -> bool val add_projection : int -> constant -> unit val is_projection : global_reference -> bool val projection_arity : global_reference -> int val add_info_axiom : global_reference -> unit val remove_info_axiom : global_reference -> unit val add_log_axiom : global_reference -> unit val add_opaque : global_reference -> unit val remove_opaque : global_reference -> unit val reset_tables : unit -> unit (*s AccessOpaque parameter *) val access_opaque : unit -> bool (*s AutoInline parameter *) val auto_inline : unit -> bool (*s TypeExpand parameter *) val type_expand : unit -> bool (*s KeepSingleton parameter *) val keep_singleton : unit -> bool (*s Optimize parameter *) type opt_flag = { opt_kill_dum : bool; (* 1 *) opt_fix_fun : bool; (* 2 *) opt_case_iot : bool; (* 4 *) opt_case_idr : bool; (* 8 *) opt_case_idg : bool; (* 16 *) opt_case_cst : bool; (* 32 *) opt_case_fun : bool; (* 64 *) opt_case_app : bool; (* 128 *) opt_let_app : bool; (* 256 *) opt_lin_let : bool; (* 512 *) opt_lin_beta : bool } (* 1024 *) val optims : unit -> opt_flag (*s Target language. *) type lang = Ocaml | Haskell | Scheme val lang : unit -> lang (*s Extraction modes: modular or monolithic, library or minimal ? Nota: - Recursive Extraction : monolithic, minimal - Separate Extraction : modular, minimal - Extraction Library : modular, library *) val set_modular : bool -> unit val modular : unit -> bool val set_library : bool -> unit val library : unit -> bool (*s Table for custom inlining *) val to_inline : global_reference -> bool val to_keep : global_reference -> bool (*s Table for implicits arguments *) val implicits_of_global : global_reference -> int list (*s Table for user-given custom ML extractions. *) (* UGLY HACK: registration of a function defined in [extraction.ml] *) val register_type_scheme_nb_args : (Environ.env -> Term.constr -> int) -> unit val is_custom : global_reference -> bool val is_inline_custom : global_reference -> bool val find_custom : global_reference -> string val find_type_custom : global_reference -> string list * string val is_custom_match : ml_branch array -> bool val find_custom_match : ml_branch array -> string (*s Extraction commands. *) val extraction_language : lang -> unit val extraction_inline : bool -> reference list -> unit val print_extraction_inline : unit -> unit val reset_extraction_inline : unit -> unit val extract_constant_inline : bool -> reference -> string list -> string -> unit val extract_inductive : reference -> string -> string list -> string option -> unit type int_or_id = ArgInt of int | ArgId of identifier val extraction_implicit : reference -> int_or_id list -> unit (*s Table of blacklisted filenames *) val extraction_blacklist : identifier list -> unit val reset_extraction_blacklist : unit -> unit val print_extraction_blacklist : unit -> unit coq-8.4pl4/plugins/extraction/haskell.mli0000644000175000017500000000107112326224777017621 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* kn = kn' | ConstRef _ -> false | VarRef _ -> assert false let repr_of_r = function | ConstRef kn -> repr_con kn | IndRef (kn,_) | ConstructRef ((kn,_),_) -> repr_mind kn | VarRef _ -> assert false let modpath_of_r r = let mp,_,_ = repr_of_r r in mp let label_of_r r = let _,_,l = repr_of_r r in l let rec base_mp = function | MPdot (mp,l) -> base_mp mp | mp -> mp let is_modfile = function | MPfile _ -> true | _ -> false let raw_string_of_modfile = function | MPfile f -> String.capitalize (string_of_id (List.hd (repr_dirpath f))) | _ -> assert false let current_toplevel () = fst (Lib.current_prefix ()) let is_toplevel mp = mp = initial_path || mp = current_toplevel () let at_toplevel mp = is_modfile mp || is_toplevel mp let rec mp_length mp = let mp0 = current_toplevel () in let rec len = function | mp when mp = mp0 -> 1 | MPdot (mp,_) -> 1 + len mp | _ -> 1 in len mp let visible_con kn = at_toplevel (base_mp (con_modpath kn)) let rec prefixes_mp mp = match mp with | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp') | _ -> MPset.singleton mp let rec get_nth_label_mp n = function | MPdot (mp,l) -> if n=1 then l else get_nth_label_mp (n-1) mp | _ -> failwith "get_nth_label: not enough MPdot" let common_prefix_from_list mp0 mpl = let prefixes = prefixes_mp mp0 in let rec f = function | [] -> None | mp :: l -> if MPset.mem mp prefixes then Some mp else f l in f mpl let rec parse_labels2 ll mp1 = function | mp when mp1=mp -> mp,ll | MPdot (mp,l) -> parse_labels2 (l::ll) mp1 mp | mp -> mp,ll let labels_of_ref r = let mp_top = current_toplevel () in let mp,_,l = repr_of_r r in parse_labels2 [l] mp_top mp (*S The main tables: constants, inductives, records, ... *) (* Theses tables are not registered within coq save/undo mechanism since we reset their contents at each run of Extraction *) (*s Constants tables. *) let terms = ref (Cmap_env.empty : ml_decl Cmap_env.t) let init_terms () = terms := Cmap_env.empty let add_term kn d = terms := Cmap_env.add kn d !terms let lookup_term kn = Cmap_env.find kn !terms let types = ref (Cmap_env.empty : ml_schema Cmap_env.t) let init_types () = types := Cmap_env.empty let add_type kn s = types := Cmap_env.add kn s !types let lookup_type kn = Cmap_env.find kn !types (*s Inductives table. *) let inductives = ref (Mindmap_env.empty : (mutual_inductive_body * ml_ind) Mindmap_env.t) let init_inductives () = inductives := Mindmap_env.empty let add_ind kn mib ml_ind = inductives := Mindmap_env.add kn (mib,ml_ind) !inductives let lookup_ind kn = Mindmap_env.find kn !inductives let inductive_kinds = ref (Mindmap_env.empty : inductive_kind Mindmap_env.t) let init_inductive_kinds () = inductive_kinds := Mindmap_env.empty let add_inductive_kind kn k = inductive_kinds := Mindmap_env.add kn k !inductive_kinds let is_coinductive r = let kn = match r with | ConstructRef ((kn,_),_) -> kn | IndRef (kn,_) -> kn | _ -> assert false in try Mindmap_env.find kn !inductive_kinds = Coinductive with Not_found -> false let is_coinductive_type = function | Tglob (r,_) -> is_coinductive r | _ -> false let get_record_fields r = let kn = match r with | ConstructRef ((kn,_),_) -> kn | IndRef (kn,_) -> kn | _ -> assert false in try match Mindmap_env.find kn !inductive_kinds with | Record f -> f | _ -> [] with Not_found -> [] let record_fields_of_type = function | Tglob (r,_) -> get_record_fields r | _ -> [] (*s Recursors table. *) (* NB: here we can use the equivalence between canonical and user constant names : Cset is fine, no need for [Cset_env] *) let recursors = ref Cset.empty let init_recursors () = recursors := Cset.empty let add_recursors env kn = let mk_con id = make_con_equiv (modpath (user_mind kn)) (modpath (canonical_mind kn)) empty_dirpath (label_of_id id) in let mib = Environ.lookup_mind kn env in Array.iter (fun mip -> let id = mip.mind_typename in let c_rec = mk_con (Nameops.add_suffix id "_rec") and c_rect = mk_con (Nameops.add_suffix id "_rect") in recursors := Cset.add c_rec (Cset.add c_rect !recursors)) mib.mind_packets let is_recursor = function | ConstRef kn -> Cset.mem kn !recursors | _ -> false (*s Record tables. *) (* NB: here, working modulo name equivalence is ok *) let projs = ref (Refmap.empty : int Refmap.t) let init_projs () = projs := Refmap.empty let add_projection n kn = projs := Refmap.add (ConstRef kn) n !projs let is_projection r = Refmap.mem r !projs let projection_arity r = Refmap.find r !projs (*s Table of used axioms *) let info_axioms = ref Refset'.empty let log_axioms = ref Refset'.empty let init_axioms () = info_axioms := Refset'.empty; log_axioms := Refset'.empty let add_info_axiom r = info_axioms := Refset'.add r !info_axioms let remove_info_axiom r = info_axioms := Refset'.remove r !info_axioms let add_log_axiom r = log_axioms := Refset'.add r !log_axioms let opaques = ref Refset'.empty let init_opaques () = opaques := Refset'.empty let add_opaque r = opaques := Refset'.add r !opaques let remove_opaque r = opaques := Refset'.remove r !opaques (*s Extraction modes: modular or monolithic, library or minimal ? Nota: - Recursive Extraction : monolithic, minimal - Separate Extraction : modular, minimal - Extraction Library : modular, library *) let modular_ref = ref false let library_ref = ref false let set_modular b = modular_ref := b let modular () = !modular_ref let set_library b = library_ref := b let library () = !library_ref (*s Printing. *) (* The following functions work even on objects not in [Global.env ()]. Warning: for inductive objects, this only works if an [extract_inductive] have been done earlier, otherwise we can only ask the Nametab about currently visible objects. *) let safe_basename_of_global r = let last_chance r = try Nametab.basename_of_global r with Not_found -> anomaly "Inductive object unknown to extraction and not globally visible" in match r with | ConstRef kn -> id_of_label (con_label kn) | IndRef (kn,0) -> id_of_label (mind_label kn) | IndRef (kn,i) -> (try (snd (lookup_ind kn)).ind_packets.(i).ip_typename with Not_found -> last_chance r) | ConstructRef ((kn,i),j) -> (try (snd (lookup_ind kn)).ind_packets.(i).ip_consnames.(j-1) with Not_found -> last_chance r) | VarRef _ -> assert false let string_of_global r = try string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty r) with e when Errors.noncritical e -> string_of_id (safe_basename_of_global r) let safe_pr_global r = str (string_of_global r) (* idem, but with qualification, and only for constants. *) let safe_pr_long_global r = try Printer.pr_global r with e when Errors.noncritical e -> match r with | ConstRef kn -> let mp,_,l = repr_con kn in str ((string_of_mp mp)^"."^(string_of_label l)) | _ -> assert false let pr_long_mp mp = let lid = repr_dirpath (Nametab.dirpath_of_module mp) in str (String.concat "." (List.map string_of_id (List.rev lid))) let pr_long_global ref = pr_path (Nametab.path_of_global ref) (*S Warning and Error messages. *) let err s = errorlabstrm "Extraction" s let warning_axioms () = let info_axioms = Refset'.elements !info_axioms in if info_axioms = [] then () else begin let s = if List.length info_axioms = 1 then "axiom" else "axioms" in msg_warning (str ("The following "^s^" must be realized in the extracted code:") ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global info_axioms) ++ str "." ++ fnl ()) end; let log_axioms = Refset'.elements !log_axioms in if log_axioms = [] then () else begin let s = if List.length log_axioms = 1 then "axiom was" else "axioms were" in msg_warning (str ("The following logical "^s^" encountered:") ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global log_axioms ++ str ".\n") ++ str "Having invalid logical axiom in the environment when extracting" ++ spc () ++ str "may lead to incorrect or non-terminating ML terms." ++ fnl ()) end; if !Flags.load_proofs = Flags.Dont && info_axioms@log_axioms <> [] then msg_warning (str "Some of these axioms might be due to option -dont-load-proofs.") let warning_opaques accessed = let opaques = Refset'.elements !opaques in if opaques = [] then () else let lst = hov 1 (spc () ++ prlist_with_sep spc safe_pr_global opaques) in if accessed then msg_warning (str "The extraction is currently set to bypass opacity,\n" ++ str "the following opaque constant bodies have been accessed :" ++ lst ++ str "." ++ fnl ()) else msg_warning (str "The extraction now honors the opacity constraints by default,\n" ++ str "the following opaque constants have been extracted as axioms :" ++ lst ++ str "." ++ fnl () ++ str "If necessary, use \"Set Extraction AccessOpaque\" to change this." ++ fnl ()) let warning_both_mod_and_cst q mp r = msg_warning (str "The name " ++ pr_qualid q ++ str " is ambiguous, " ++ str "do you mean module " ++ pr_long_mp mp ++ str " or object " ++ pr_long_global r ++ str " ?" ++ fnl () ++ str "First choice is assumed, for the second one please use " ++ str "fully qualified name." ++ fnl ()) let error_axiom_scheme r i = err (str "The type scheme axiom " ++ spc () ++ safe_pr_global r ++ spc () ++ str "needs " ++ pr_int i ++ str " type variable(s).") let check_inside_module () = if Lib.is_modtype () then err (str "You can't do that within a Module Type." ++ fnl () ++ str "Close it and try again.") else if Lib.is_module () then msg_warning (str "Extraction inside an opened module is experimental.\n" ++ str "In case of problem, close it first.\n") let check_inside_section () = if Lib.sections_are_opened () then err (str "You can't do that within a section." ++ fnl () ++ str "Close it and try again.") let warning_id s = msg_warning (str ("The identifier "^s^ " contains __ which is reserved for the extraction")) let error_constant r = err (safe_pr_global r ++ str " is not a constant.") let error_inductive r = err (safe_pr_global r ++ spc () ++ str "is not an inductive type.") let error_nb_cons () = err (str "Not the right number of constructors.") let error_module_clash mp1 mp2 = err (str "The Coq modules " ++ pr_long_mp mp1 ++ str " and " ++ pr_long_mp mp2 ++ str " have the same ML name.\n" ++ str "This is not supported yet. Please do some renaming first.") let error_no_module_expr mp = err (str "The module " ++ pr_long_mp mp ++ str " has no body, it probably comes from\n" ++ str "some Declare Module outside any Module Type.\n" ++ str "This situation is currently unsupported by the extraction.") let error_singleton_become_prop id = err (str "The informative inductive type " ++ pr_id id ++ str " has a Prop instance.\n" ++ str "This happens when a sort-polymorphic singleton inductive type\n" ++ str "has logical parameters, such as (I,I) : (True * True) : Prop.\n" ++ str "The Ocaml extraction cannot handle this situation yet.\n" ++ str "Instead, use a sort-monomorphic type such as (True /\\ True)\n" ++ str "or extract to Haskell.") let error_unknown_module m = err (str "Module" ++ spc () ++ pr_qualid m ++ spc () ++ str "not found.") let error_scheme () = err (str "No Scheme modular extraction available yet.") let error_not_visible r = err (safe_pr_global r ++ str " is not directly visible.\n" ++ str "For example, it may be inside an applied functor.\n" ++ str "Use Recursive Extraction to get the whole environment.") let error_MPfile_as_mod mp b = let s1 = if b then "asked" else "required" in let s2 = if b then "extract some objects of this module or\n" else "" in err (str ("Extraction of file "^(raw_string_of_modfile mp)^ ".v as a module is "^s1^".\n"^ "Monolithic Extraction cannot deal with this situation.\n"^ "Please "^s2^"use (Recursive) Extraction Library instead.\n")) let msg_non_implicit r n id = let name = match id with | Anonymous -> "" | Name id -> "(" ^ string_of_id id ^ ") " in "The " ^ (ordinal n) ^ " argument " ^ name ^ "of " ^ (string_of_global r) let error_non_implicit msg = err (str (msg ^ " still occurs after extraction.") ++ fnl () ++ str "Please check the Extraction Implicit declarations.") let check_loaded_modfile mp = match base_mp mp with | MPfile dp -> if not (Library.library_is_loaded dp) then begin match base_mp (current_toplevel ()) with | MPfile dp' when dp<>dp' -> err (str ("Please load library "^(string_of_dirpath dp^" first."))) | _ -> () end | _ -> () let info_file f = Flags.if_verbose message ("The file "^f^" has been created by extraction.") (*S The Extraction auxiliary commands *) (* The objects defined below should survive an arbitrary time, so we register them to coq save/undo mechanism. *) let my_bool_option name initval = let flag = ref initval in let access = fun () -> !flag in let _ = declare_bool_option {optsync = true; optdepr = false; optname = "Extraction "^name; optkey = ["Extraction"; name]; optread = access; optwrite = (:=) flag } in access (*s Extraction AccessOpaque *) let access_opaque = my_bool_option "AccessOpaque" true (*s Extraction AutoInline *) let auto_inline = my_bool_option "AutoInline" false (*s Extraction TypeExpand *) let type_expand = my_bool_option "TypeExpand" true (*s Extraction KeepSingleton *) let keep_singleton = my_bool_option "KeepSingleton" false (*s Extraction Optimize *) type opt_flag = { opt_kill_dum : bool; (* 1 *) opt_fix_fun : bool; (* 2 *) opt_case_iot : bool; (* 4 *) opt_case_idr : bool; (* 8 *) opt_case_idg : bool; (* 16 *) opt_case_cst : bool; (* 32 *) opt_case_fun : bool; (* 64 *) opt_case_app : bool; (* 128 *) opt_let_app : bool; (* 256 *) opt_lin_let : bool; (* 512 *) opt_lin_beta : bool } (* 1024 *) let kth_digit n k = (n land (1 lsl k) <> 0) let flag_of_int n = { opt_kill_dum = kth_digit n 0; opt_fix_fun = kth_digit n 1; opt_case_iot = kth_digit n 2; opt_case_idr = kth_digit n 3; opt_case_idg = kth_digit n 4; opt_case_cst = kth_digit n 5; opt_case_fun = kth_digit n 6; opt_case_app = kth_digit n 7; opt_let_app = kth_digit n 8; opt_lin_let = kth_digit n 9; opt_lin_beta = kth_digit n 10 } (* For the moment, we allow by default everything except : - the type-unsafe optimization [opt_case_idg], which anyway cannot be activated currently (cf [Mlutil.branch_as_fun]) - the linear let and beta reduction [opt_lin_let] and [opt_lin_beta] (may lead to complexity blow-up, subsumed by finer reductions when inlining recursors). *) let int_flag_init = 1 + 2 + 4 + 8 (*+ 16*) + 32 + 64 + 128 + 256 (*+ 512 + 1024*) let int_flag_ref = ref int_flag_init let opt_flag_ref = ref (flag_of_int int_flag_init) let chg_flag n = int_flag_ref := n; opt_flag_ref := flag_of_int n let optims () = !opt_flag_ref let _ = declare_bool_option {optsync = true; optdepr = false; optname = "Extraction Optimize"; optkey = ["Extraction"; "Optimize"]; optread = (fun () -> !int_flag_ref <> 0); optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))} let _ = declare_int_option { optsync = true; optdepr = false; optname = "Extraction Flag"; optkey = ["Extraction";"Flag"]; optread = (fun _ -> Some !int_flag_ref); optwrite = (function | None -> chg_flag 0 | Some i -> chg_flag (max i 0))} (*s Extraction Lang *) type lang = Ocaml | Haskell | Scheme let lang_ref = ref Ocaml let lang () = !lang_ref let extr_lang : lang -> obj = declare_object {(default_object "Extraction Lang") with cache_function = (fun (_,l) -> lang_ref := l); load_function = (fun _ (_,l) -> lang_ref := l)} let _ = declare_summary "Extraction Lang" { freeze_function = (fun () -> !lang_ref); unfreeze_function = ((:=) lang_ref); init_function = (fun () -> lang_ref := Ocaml) } let extraction_language x = Lib.add_anonymous_leaf (extr_lang x) (*s Extraction Inline/NoInline *) let empty_inline_table = (Refset'.empty,Refset'.empty) let inline_table = ref empty_inline_table let to_inline r = Refset'.mem r (fst !inline_table) let to_keep r = Refset'.mem r (snd !inline_table) let add_inline_entries b l = let f b = if b then Refset'.add else Refset'.remove in let i,k = !inline_table in inline_table := (List.fold_right (f b) l i), (List.fold_right (f (not b)) l k) (* Registration of operations for rollback. *) let inline_extraction : bool * global_reference list -> obj = declare_object {(default_object "Extraction Inline") with cache_function = (fun (_,(b,l)) -> add_inline_entries b l); load_function = (fun _ (_,(b,l)) -> add_inline_entries b l); classify_function = (fun o -> Substitute o); discharge_function = (fun (_,(b,l)) -> Some (b, List.map pop_global_reference l)); subst_function = (fun (s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l))) } let _ = declare_summary "Extraction Inline" { freeze_function = (fun () -> !inline_table); unfreeze_function = ((:=) inline_table); init_function = (fun () -> inline_table := empty_inline_table) } (* Grammar entries. *) let extraction_inline b l = let refs = List.map Smartlocate.global_with_alias l in List.iter (fun r -> match r with | ConstRef _ -> () | _ -> error_constant r) refs; Lib.add_anonymous_leaf (inline_extraction (b,refs)) (* Printing part *) let print_extraction_inline () = let (i,n)= !inline_table in let i'= Refset'.filter (function ConstRef _ -> true | _ -> false) i in msg (str "Extraction Inline:" ++ fnl () ++ Refset'.fold (fun r p -> (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) i' (mt ()) ++ str "Extraction NoInline:" ++ fnl () ++ Refset'.fold (fun r p -> (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) n (mt ())) (* Reset part *) let reset_inline : unit -> obj = declare_object {(default_object "Reset Extraction Inline") with cache_function = (fun (_,_)-> inline_table := empty_inline_table); load_function = (fun _ (_,_)-> inline_table := empty_inline_table)} let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ()) (*s Extraction Implicit *) type int_or_id = ArgInt of int | ArgId of identifier let implicits_table = ref Refmap'.empty let implicits_of_global r = try Refmap'.find r !implicits_table with Not_found -> [] let add_implicits r l = let typ = Global.type_of_global r in let rels,_ = decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in let names = List.rev_map fst rels in let n = List.length names in let check = function | ArgInt i -> if 1 <= i && i <= n then i else err (int i ++ str " is not a valid argument number for " ++ safe_pr_global r) | ArgId id -> (try list_index (Name id) names with Not_found -> err (str "No argument " ++ pr_id id ++ str " for " ++ safe_pr_global r)) in let l' = List.map check l in implicits_table := Refmap'.add r l' !implicits_table (* Registration of operations for rollback. *) let implicit_extraction : global_reference * int_or_id list -> obj = declare_object {(default_object "Extraction Implicit") with cache_function = (fun (_,(r,l)) -> add_implicits r l); load_function = (fun _ (_,(r,l)) -> add_implicits r l); classify_function = (fun o -> Substitute o); subst_function = (fun (s,(r,l)) -> (fst (subst_global s r), l)) } let _ = declare_summary "Extraction Implicit" { freeze_function = (fun () -> !implicits_table); unfreeze_function = ((:=) implicits_table); init_function = (fun () -> implicits_table := Refmap'.empty) } (* Grammar entries. *) let extraction_implicit r l = check_inside_section (); Lib.add_anonymous_leaf (implicit_extraction (Smartlocate.global_with_alias r,l)) (*s Extraction Blacklist of filenames not to use while extracting *) let blacklist_table = ref Idset.empty let modfile_ids = ref [] let modfile_mps = ref MPmap.empty let reset_modfile () = modfile_ids := Idset.elements !blacklist_table; modfile_mps := MPmap.empty let string_of_modfile mp = try MPmap.find mp !modfile_mps with Not_found -> let id = id_of_string (raw_string_of_modfile mp) in let id' = next_ident_away id !modfile_ids in let s' = string_of_id id' in modfile_ids := id' :: !modfile_ids; modfile_mps := MPmap.add mp s' !modfile_mps; s' (* same as [string_of_modfile], but preserves the capital/uncapital 1st char *) let file_of_modfile mp = let s0 = match mp with | MPfile f -> string_of_id (List.hd (repr_dirpath f)) | _ -> assert false in let s = String.copy (string_of_modfile mp) in if s.[0] <> s0.[0] then s.[0] <- s0.[0]; s let add_blacklist_entries l = blacklist_table := List.fold_right (fun s -> Idset.add (id_of_string (String.capitalize s))) l !blacklist_table (* Registration of operations for rollback. *) let blacklist_extraction : string list -> obj = declare_object {(default_object "Extraction Blacklist") with cache_function = (fun (_,l) -> add_blacklist_entries l); load_function = (fun _ (_,l) -> add_blacklist_entries l); subst_function = (fun (_,x) -> x) } let _ = declare_summary "Extraction Blacklist" { freeze_function = (fun () -> !blacklist_table); unfreeze_function = ((:=) blacklist_table); init_function = (fun () -> blacklist_table := Idset.empty) } (* Grammar entries. *) let extraction_blacklist l = let l = List.rev_map string_of_id l in Lib.add_anonymous_leaf (blacklist_extraction l) (* Printing part *) let print_extraction_blacklist () = msgnl (prlist_with_sep fnl pr_id (Idset.elements !blacklist_table)) (* Reset part *) let reset_blacklist : unit -> obj = declare_object {(default_object "Reset Extraction Blacklist") with cache_function = (fun (_,_)-> blacklist_table := Idset.empty); load_function = (fun _ (_,_)-> blacklist_table := Idset.empty)} let reset_extraction_blacklist () = Lib.add_anonymous_leaf (reset_blacklist ()) (*s Extract Constant/Inductive. *) (* UGLY HACK: to be defined in [extraction.ml] *) let use_type_scheme_nb_args, register_type_scheme_nb_args = let r = ref (fun _ _ -> 0) in (fun x y -> !r x y), (:=) r let customs = ref Refmap'.empty let add_custom r ids s = customs := Refmap'.add r (ids,s) !customs let is_custom r = Refmap'.mem r !customs let is_inline_custom r = (is_custom r) && (to_inline r) let find_custom r = snd (Refmap'.find r !customs) let find_type_custom r = Refmap'.find r !customs let custom_matchs = ref Refmap'.empty let add_custom_match r s = custom_matchs := Refmap'.add r s !custom_matchs let indref_of_match pv = if Array.length pv = 0 then raise Not_found; let (_,pat,_) = pv.(0) in match pat with | Pusual (ConstructRef (ip,_)) -> IndRef ip | Pcons (ConstructRef (ip,_),_) -> IndRef ip | _ -> raise Not_found let is_custom_match pv = try Refmap'.mem (indref_of_match pv) !custom_matchs with Not_found -> false let find_custom_match pv = Refmap'.find (indref_of_match pv) !custom_matchs (* Registration of operations for rollback. *) let in_customs : global_reference * string list * string -> obj = declare_object {(default_object "ML extractions") with cache_function = (fun (_,(r,ids,s)) -> add_custom r ids s); load_function = (fun _ (_,(r,ids,s)) -> add_custom r ids s); classify_function = (fun o -> Substitute o); subst_function = (fun (s,(r,ids,str)) -> (fst (subst_global s r), ids, str)) } let _ = declare_summary "ML extractions" { freeze_function = (fun () -> !customs); unfreeze_function = ((:=) customs); init_function = (fun () -> customs := Refmap'.empty) } let in_custom_matchs : global_reference * string -> obj = declare_object {(default_object "ML extractions custom matchs") with cache_function = (fun (_,(r,s)) -> add_custom_match r s); load_function = (fun _ (_,(r,s)) -> add_custom_match r s); classify_function = (fun o -> Substitute o); subst_function = (fun (subs,(r,s)) -> (fst (subst_global subs r), s)) } let _ = declare_summary "ML extractions custom match" { freeze_function = (fun () -> !custom_matchs); unfreeze_function = ((:=) custom_matchs); init_function = (fun () -> custom_matchs := Refmap'.empty) } (* Grammar entries. *) let extract_constant_inline inline r ids s = check_inside_section (); let g = Smartlocate.global_with_alias r in match g with | ConstRef kn -> let env = Global.env () in let typ = Typeops.type_of_constant env kn in let typ = Reduction.whd_betadeltaiota env typ in if Reduction.is_arity env typ then begin let nargs = use_type_scheme_nb_args env typ in if List.length ids <> nargs then error_axiom_scheme g nargs end; Lib.add_anonymous_leaf (inline_extraction (inline,[g])); Lib.add_anonymous_leaf (in_customs (g,ids,s)) | _ -> error_constant g let extract_inductive r s l optstr = check_inside_section (); let g = Smartlocate.global_with_alias r in Dumpglob.add_glob (loc_of_reference r) g; match g with | IndRef ((kn,i) as ip) -> let mib = Global.lookup_mind kn in let n = Array.length mib.mind_packets.(i).mind_consnames in if n <> List.length l then error_nb_cons (); Lib.add_anonymous_leaf (inline_extraction (true,[g])); Lib.add_anonymous_leaf (in_customs (g,[],s)); Option.iter (fun s -> Lib.add_anonymous_leaf (in_custom_matchs (g,s))) optstr; list_iter_i (fun j s -> let g = ConstructRef (ip,succ j) in Lib.add_anonymous_leaf (inline_extraction (true,[g])); Lib.add_anonymous_leaf (in_customs (g,[],s))) l | _ -> error_inductive g (*s Tables synchronization. *) let reset_tables () = init_terms (); init_types (); init_inductives (); init_inductive_kinds (); init_recursors (); init_projs (); init_axioms (); init_opaques (); reset_modfile () coq-8.4pl4/plugins/extraction/miniml.mli0000644000175000017500000001404412326224777017467 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* module_path list -> unsafe_needs -> std_ppcmds; pp_struct : ml_structure -> std_ppcmds; (* Concerning a possible interface file *) sig_suffix : string option; sig_preamble : identifier -> module_path list -> unsafe_needs -> std_ppcmds; pp_sig : ml_signature -> std_ppcmds; (* for an isolated declaration print *) pp_decl : ml_decl -> std_ppcmds; } coq-8.4pl4/plugins/extraction/modutil.ml0000644000175000017500000003272712326224777017516 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* mp | MTwith(mt,_)-> msid_of_mt mt | _ -> anomaly "Extraction:the With operator isn't applied to a name" (*s Apply some functions upon all [ml_decl] and [ml_spec] found in a [ml_structure]. *) let se_iter do_decl do_spec do_mp = let rec mt_iter = function | MTident mp -> do_mp mp | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt' | MTwith (mt,ML_With_type(idl,l,t))-> let mp_mt = msid_of_mt mt in let l',idl' = list_sep_last idl in let mp_w = List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl' in let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l')) in mt_iter mt; do_decl (Dtype(r,l,t)) | MTwith (mt,ML_With_module(idl,mp))-> let mp_mt = msid_of_mt mt in let mp_w = List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl in mt_iter mt; do_mp mp_w; do_mp mp | MTsig (_, sign) -> List.iter spec_iter sign and spec_iter = function | (_,Spec s) -> do_spec s | (_,Smodule mt) -> mt_iter mt | (_,Smodtype mt) -> mt_iter mt in let rec se_iter = function | (_,SEdecl d) -> do_decl d | (_,SEmodule m) -> me_iter m.ml_mod_expr; mt_iter m.ml_mod_type | (_,SEmodtype m) -> mt_iter m and me_iter = function | MEident mp -> do_mp mp | MEfunctor (_,mt,me) -> me_iter me; mt_iter mt | MEapply (me,me') -> me_iter me; me_iter me' | MEstruct (msid, sel) -> List.iter se_iter sel in se_iter let struct_iter do_decl do_spec do_mp s = List.iter (function (_,sel) -> List.iter (se_iter do_decl do_spec do_mp) sel) s (*s Apply some fonctions upon all references in [ml_type], [ml_ast], [ml_decl], [ml_spec] and [ml_structure]. *) type do_ref = global_reference -> unit let record_iter_references do_term = function | Record l -> List.iter (Option.iter do_term) l | _ -> () let type_iter_references do_type t = let rec iter = function | Tglob (r,l) -> do_type r; List.iter iter l | Tarr (a,b) -> iter a; iter b | _ -> () in iter t let patt_iter_references do_cons p = let rec iter = function | Pcons (r,l) -> do_cons r; List.iter iter l | Pusual r -> do_cons r | Ptuple l -> List.iter iter l | Prel _ | Pwild -> () in iter p let ast_iter_references do_term do_cons do_type a = let rec iter a = ast_iter iter a; match a with | MLglob r -> do_term r | MLcons (_,r,_) -> do_cons r | MLcase (ty,_,v) -> type_iter_references do_type ty; Array.iter (fun (_,p,_) -> patt_iter_references do_cons p) v | MLrel _ | MLlam _ | MLapp _ | MLletin _ | MLtuple _ | MLfix _ | MLexn _ | MLdummy | MLaxiom | MLmagic _ -> () in iter a let ind_iter_references do_term do_cons do_type kn ind = let type_iter = type_iter_references do_type in let cons_iter cp l = do_cons (ConstructRef cp); List.iter type_iter l in let packet_iter ip p = do_type (IndRef ip); if lang () = Ocaml then (match ind.ind_equiv with | Miniml.Equiv kne -> do_type (IndRef (mind_of_kn kne, snd ip)); | _ -> ()); Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types in if lang () = Ocaml then record_iter_references do_term ind.ind_kind; Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets let decl_iter_references do_term do_cons do_type = let type_iter = type_iter_references do_type and ast_iter = ast_iter_references do_term do_cons do_type in function | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind | Dtype (r,_,t) -> do_type r; type_iter t | Dterm (r,a,t) -> do_term r; ast_iter a; type_iter t | Dfix(rv,c,t) -> Array.iter do_term rv; Array.iter ast_iter c; Array.iter type_iter t let spec_iter_references do_term do_cons do_type = function | Sind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind | Stype (r,_,ot) -> do_type r; Option.iter (type_iter_references do_type) ot | Sval (r,t) -> do_term r; type_iter_references do_type t (*s Searching occurrences of a particular term (no lifting done). *) exception Found let rec ast_search f a = if f a then raise Found else ast_iter (ast_search f) a let decl_ast_search f = function | Dterm (_,a,_) -> ast_search f a | Dfix (_,c,_) -> Array.iter (ast_search f) c | _ -> () let struct_ast_search f s = try struct_iter (decl_ast_search f) (fun _ -> ()) (fun _ -> ()) s; false with Found -> true let rec type_search f = function | Tarr (a,b) -> type_search f a; type_search f b | Tglob (r,l) -> List.iter (type_search f) l | u -> if f u then raise Found let decl_type_search f = function | Dind (_,{ind_packets=p}) -> Array.iter (fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p | Dterm (_,_,u) -> type_search f u | Dfix (_,_,v) -> Array.iter (type_search f) v | Dtype (_,_,u) -> type_search f u let spec_type_search f = function | Sind (_,{ind_packets=p}) -> Array.iter (fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p | Stype (_,_,ot) -> Option.iter (type_search f) ot | Sval (_,u) -> type_search f u let struct_type_search f s = try struct_iter (decl_type_search f) (spec_type_search f) (fun _ -> ()) s; false with Found -> true (*s Generating the signature. *) let rec msig_of_ms = function | [] -> [] | (l,SEdecl (Dind (kn,i))) :: ms -> (l,Spec (Sind (kn,i))) :: (msig_of_ms ms) | (l,SEdecl (Dterm (r,_,t))) :: ms -> (l,Spec (Sval (r,t))) :: (msig_of_ms ms) | (l,SEdecl (Dtype (r,v,t))) :: ms -> (l,Spec (Stype (r,v,Some t))) :: (msig_of_ms ms) | (l,SEdecl (Dfix (rv,_,tv))) :: ms -> let msig = ref (msig_of_ms ms) in for i = Array.length rv - 1 downto 0 do msig := (l,Spec (Sval (rv.(i),tv.(i))))::!msig done; !msig | (l,SEmodule m) :: ms -> (l,Smodule m.ml_mod_type) :: (msig_of_ms ms) | (l,SEmodtype m) :: ms -> (l,Smodtype m) :: (msig_of_ms ms) let signature_of_structure s = List.map (fun (mp,ms) -> mp,msig_of_ms ms) s (*s Searching one [ml_decl] in a [ml_structure] by its [global_reference] *) let is_modular = function | SEdecl _ -> false | SEmodule _ | SEmodtype _ -> true let rec search_structure l m = function | [] -> raise Not_found | (lab,d)::_ when lab=l && is_modular d = m -> d | _::fields -> search_structure l m fields let get_decl_in_structure r struc = try let base_mp,ll = labels_of_ref r in if not (at_toplevel base_mp) then error_not_visible r; let sel = List.assoc base_mp struc in let rec go ll sel = match ll with | [] -> assert false | l :: ll -> match search_structure l (ll<>[]) sel with | SEdecl d -> d | SEmodtype m -> assert false | SEmodule m -> match m.ml_mod_expr with | MEstruct (_,sel) -> go ll sel | _ -> error_not_visible r in go ll sel with Not_found -> anomaly "reference not found in extracted structure" (*s Optimization of a [ml_structure]. *) (* Some transformations of ML terms. [optimize_struct] simplify all beta redexes (when the argument does not occur, it is just thrown away; when it occurs exactly once it is substituted; otherwise a let-in redex is created for clarity) and iota redexes, plus some other optimizations. *) let dfix_to_mlfix rv av i = let rec make_subst n s = if n < 0 then s else make_subst (n-1) (Refmap'.add rv.(n) (n+1) s) in let s = make_subst (Array.length rv - 1) Refmap'.empty in let rec subst n t = match t with | MLglob ((ConstRef kn) as refe) -> (try MLrel (n + (Refmap'.find refe s)) with Not_found -> t) | _ -> ast_map_lift subst n t in let ids = Array.map (fun r -> id_of_label (label_of_r r)) rv in let c = Array.map (subst 0) av in MLfix(i, ids, c) (* [optim_se] applies the [normalize] function everywhere and does the inlining of code. The inlined functions are kept for the moment in order to preserve the global interface, later [depcheck_se] will get rid of them if possible *) let rec optim_se top to_appear s = function | [] -> [] | (l,SEdecl (Dterm (r,a,t))) :: lse -> let a = normalize (ast_glob_subst !s a) in let i = inline r a in if i then s := Refmap'.add r a !s; let d = match optimize_fix a with | MLfix (0, _, [|c|]) -> Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|]) | a -> Dterm (r, a, t) in (l,SEdecl d) :: (optim_se top to_appear s lse) | (l,SEdecl (Dfix (rv,av,tv))) :: lse -> let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in (* This fake body ensures that no fixpoint will be auto-inlined. *) let fake_body = MLfix (0,[||],[||]) in for i = 0 to Array.length rv - 1 do if inline rv.(i) fake_body then s := Refmap'.add rv.(i) (dfix_to_mlfix rv av i) !s done; (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse) | (l,SEmodule m) :: lse -> let m = { m with ml_mod_expr = optim_me to_appear s m.ml_mod_expr} in (l,SEmodule m) :: (optim_se top to_appear s lse) | se :: lse -> se :: (optim_se top to_appear s lse) and optim_me to_appear s = function | MEstruct (msid, lse) -> MEstruct (msid, optim_se false to_appear s lse) | MEident mp as me -> me | MEapply (me, me') -> MEapply (optim_me to_appear s me, optim_me to_appear s me') | MEfunctor (mbid,mt,me) -> MEfunctor (mbid,mt, optim_me to_appear s me) (* After these optimisations, some dependencies may not be needed anymore. For non-library extraction, we recompute a minimal set of dependencies for first-level definitions (no module pruning yet). *) exception NoDepCheck let base_r = function | ConstRef c as r -> r | IndRef (kn,_) -> IndRef (kn,0) | ConstructRef ((kn,_),_) -> IndRef (kn,0) | _ -> assert false let reset_needed, add_needed, add_needed_mp, found_needed, is_needed = let needed = ref Refset'.empty and needed_mps = ref MPset.empty in ((fun l -> needed := Refset'.empty; needed_mps := MPset.empty), (fun r -> needed := Refset'.add (base_r r) !needed), (fun mp -> needed_mps := MPset.add mp !needed_mps), (fun r -> needed := Refset'.remove (base_r r) !needed), (fun r -> let r = base_r r in Refset'.mem r !needed || MPset.mem (modpath_of_r r) !needed_mps)) let declared_refs = function | Dind (kn,_) -> [IndRef (kn,0)] | Dtype (r,_,_) -> [r] | Dterm (r,_,_) -> [r] | Dfix (rv,_,_) -> Array.to_list rv (* Computes the dependencies of a declaration, except in case of custom extraction. *) let compute_deps_decl = function | Dind (kn,ind) -> (* Todo Later : avoid dependencies when Extract Inductive *) ind_iter_references add_needed add_needed add_needed kn ind | Dtype (r,ids,t) -> if not (is_custom r) then type_iter_references add_needed t | Dterm (r,u,t) -> type_iter_references add_needed t; if not (is_custom r) then ast_iter_references add_needed add_needed add_needed u | Dfix _ as d -> decl_iter_references add_needed add_needed add_needed d let compute_deps_spec = function | Sind (kn,ind) -> (* Todo Later : avoid dependencies when Extract Inductive *) ind_iter_references add_needed add_needed add_needed kn ind | Stype (r,ids,t) -> if not (is_custom r) then Option.iter (type_iter_references add_needed) t | Sval (r,t) -> type_iter_references add_needed t let rec depcheck_se = function | [] -> [] | ((l,SEdecl d) as t) :: se -> let se' = depcheck_se se in let refs = declared_refs d in let refs' = List.filter is_needed refs in if refs' = [] then (List.iter remove_info_axiom refs; List.iter remove_opaque refs; se') else begin List.iter found_needed refs'; (* Hack to avoid extracting unused part of a Dfix *) match d with | Dfix (rv,trms,tys) when (List.for_all is_custom refs') -> let trms' = Array.create (Array.length rv) (MLexn "UNUSED") in ((l,SEdecl (Dfix (rv,trms',tys))) :: se') | _ -> (compute_deps_decl d; t::se') end | t :: se -> let se' = depcheck_se se in se_iter compute_deps_decl compute_deps_spec add_needed_mp t; t :: se' let rec depcheck_struct = function | [] -> [] | (mp,lse)::struc -> let struc' = depcheck_struct struc in let lse' = depcheck_se lse in if lse' = [] then struc' else (mp,lse')::struc' let check_implicits = function | MLexn s -> if String.length s > 8 && (s.[0] = 'U' || s.[0] = 'I') then begin if String.sub s 0 7 = "UNBOUND" then assert false; if String.sub s 0 8 = "IMPLICIT" then error_non_implicit (String.sub s 9 (String.length s - 9)); end; false | _ -> false let optimize_struct to_appear struc = let subst = ref (Refmap'.empty : ml_ast Refmap'.t) in let opt_struc = List.map (fun (mp,lse) -> (mp, optim_se true (fst to_appear) subst lse)) struc in ignore (struct_ast_search check_implicits opt_struc); if library () then List.filter (fun (_,lse) -> lse<>[]) opt_struc else begin reset_needed (); List.iter add_needed (fst to_appear); List.iter add_needed_mp (snd to_appear); depcheck_struct opt_struc end coq-8.4pl4/plugins/extraction/extraction.mli0000644000175000017500000000217512326224777020364 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constant -> constant_body -> ml_decl val extract_constant_spec : env -> constant -> constant_body -> ml_spec val extract_with_type : env -> constant_body -> ( identifier list * ml_type ) option val extract_fixpoint : env -> constant array -> (constr, types) prec_declaration -> ml_decl val extract_inductive : env -> mutual_inductive -> ml_ind (*s Is a [ml_decl] or a [ml_spec] logical ? *) val logical_decl : ml_decl -> bool val logical_spec : ml_spec -> bool coq-8.4pl4/plugins/extraction/extract_env.ml0000644000175000017500000005110112326224777020346 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let mp,_,l = repr_kn kn in let seb = match Libobject.object_tag o with | "CONSTANT" -> SFBconst (Global.lookup_constant (constant_of_kn kn)) | "INDUCTIVE" -> SFBmind (Global.lookup_mind (mind_of_kn kn)) | "MODULE" -> SFBmodule (Global.lookup_module (MPdot (mp,l))) | "MODULE TYPE" -> SFBmodtype (Global.lookup_modtype (MPdot (mp,l))) | _ -> failwith "caught" in l,seb | _ -> failwith "caught" in SEBstruct (List.rev (map_succeed get_reference seg)) let environment_until dir_opt = let rec parse = function | [] when dir_opt = None -> [current_toplevel (), toplevel_env ()] | [] -> [] | d :: l -> match (Global.lookup_module (MPfile d)).mod_expr with | Some meb -> if dir_opt = Some d then [MPfile d, meb] else (MPfile d, meb) :: (parse l) | _ -> assert false in parse (Library.loaded_libraries ()) (*s Visit: a structure recording the needed dependencies for the current extraction *) module type VISIT = sig (* Reset the dependencies by emptying the visit lists *) val reset : unit -> unit (* Add the module_path and all its prefixes to the mp visit list *) val add_mp : module_path -> unit (* Same, but we'll keep all fields of these modules *) val add_mp_all : module_path -> unit (* Add kernel_name / constant / reference / ... in the visit lists. These functions silently add the mp of their arg in the mp list *) val add_ind : mutual_inductive -> unit val add_con : constant -> unit val add_ref : global_reference -> unit val add_decl_deps : ml_decl -> unit val add_spec_deps : ml_spec -> unit (* Test functions: is a particular object a needed dependency for the current extraction ? *) val needed_ind : mutual_inductive -> bool val needed_con : constant -> bool val needed_mp : module_path -> bool val needed_mp_all : module_path -> bool end module Visit : VISIT = struct (* What used to be in a single KNset should now be split into a KNset (for inductives and modules names) and a Cset_env for constants (and still the remaining MPset) *) type must_visit = { mutable ind : KNset.t; mutable con : KNset.t; mutable mp : MPset.t; mutable mp_all : MPset.t } (* the imperative internal visit lists *) let v = { ind = KNset.empty ; con = KNset.empty ; mp = MPset.empty; mp_all = MPset.empty } (* the accessor functions *) let reset () = v.ind <- KNset.empty; v.con <- KNset.empty; v.mp <- MPset.empty; v.mp_all <- MPset.empty let needed_ind i = KNset.mem (user_mind i) v.ind let needed_con c = KNset.mem (user_con c) v.con let needed_mp mp = MPset.mem mp v.mp || MPset.mem mp v.mp_all let needed_mp_all mp = MPset.mem mp v.mp_all let add_mp mp = check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp let add_mp_all mp = check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp; v.mp_all <- MPset.add mp v.mp_all let add_ind i = let kn = user_mind i in v.ind <- KNset.add kn v.ind; add_mp (modpath kn) let add_con c = let kn = user_con c in v.con <- KNset.add kn v.con; add_mp (modpath kn) let add_ref = function | ConstRef c -> add_con c | IndRef (ind,_) | ConstructRef ((ind,_),_) -> add_ind ind | VarRef _ -> assert false let add_decl_deps = decl_iter_references add_ref add_ref add_ref let add_spec_deps = spec_iter_references add_ref add_ref add_ref end exception Impossible let check_arity env cb = let t = Typeops.type_of_constant_type env cb.const_type in if Reduction.is_arity env t then raise Impossible let check_fix env cb i = match cb.const_body with | Def lbody -> (match kind_of_term (Declarations.force lbody) with | Fix ((_,j),recd) when i=j -> check_arity env cb; (true,recd) | CoFix (j,recd) when i=j -> check_arity env cb; (false,recd) | _ -> raise Impossible) | Undef _ | OpaqueDef _ -> raise Impossible let prec_declaration_equal (na1, ca1, ta1) (na2, ca2, ta2) = na1 = na2 && array_equal eq_constr ca1 ca2 && array_equal eq_constr ta1 ta2 let factor_fix env l cb msb = let _,recd as check = check_fix env cb 0 in let n = Array.length (let fi,_,_ = recd in fi) in if n = 1 then [|l|], recd, msb else begin if List.length msb < n-1 then raise Impossible; let msb', msb'' = list_chop (n-1) msb in let labels = Array.make n l in list_iter_i (fun j -> function | (l,SFBconst cb') -> let check' = check_fix env cb' (j+1) in if not (fst check = fst check' && prec_declaration_equal (snd check) (snd check')) then raise Impossible; labels.(j+1) <- l; | _ -> raise Impossible) msb'; labels, recd, msb'' end (** Expanding a [struct_expr_body] into a version without abbreviations or functor applications. This is done via a detour to entries (hack proposed by Elie) *) let rec seb2mse = function | SEBapply (s,s',_) -> Entries.MSEapply(seb2mse s, seb2mse s') | SEBident mp -> Entries.MSEident mp | _ -> failwith "seb2mse: received a non-atomic seb" let expand_seb env mp seb = let seb,_,_,_ = let inl = Some (Flags.get_inline_level()) in Mod_typing.translate_struct_module_entry env mp inl (seb2mse seb) in seb (** When possible, we use the nicer, shorter, algebraic type structures instead of the expanded ones. *) let my_type_of_mb mb = let m0 = mb.mod_type in match mb.mod_type_alg with Some m -> m0,m | None -> m0,m0 let my_type_of_mtb mtb = let m0 = mtb.typ_expr in match mtb.typ_expr_alg with Some m -> m0,m | None -> m0,m0 (** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def]. To check with Elie. *) let rec msid_of_seb = function | SEBident mp -> mp | SEBwith (seb,_) -> msid_of_seb seb | _ -> assert false let env_for_mtb_with_def env mp seb idl = let sig_b = match seb with | SEBstruct(sig_b) -> sig_b | _ -> assert false in let l = label_of_id (List.hd idl) in let spot = function (l',SFBconst _) -> l = l' | _ -> false in let before = fst (list_split_when spot sig_b) in Modops.add_signature mp before empty_delta_resolver env (* From a [structure_body] (i.e. a list of [structure_field_body]) to specifications. *) let rec extract_sfb_spec env mp = function | [] -> [] | (l,SFBconst cb) :: msig -> let kn = make_con mp empty_dirpath l in let s = extract_constant_spec env kn cb in let specs = extract_sfb_spec env mp msig in if logical_spec s then specs else begin Visit.add_spec_deps s; (l,Spec s) :: specs end | (l,SFBmind _) :: msig -> let mind = make_mind mp empty_dirpath l in let s = Sind (mind, extract_inductive env mind) in let specs = extract_sfb_spec env mp msig in if logical_spec s then specs else begin Visit.add_spec_deps s; (l,Spec s) :: specs end | (l,SFBmodule mb) :: msig -> let specs = extract_sfb_spec env mp msig in let spec = extract_seb_spec env mb.mod_mp (my_type_of_mb mb) in (l,Smodule spec) :: specs | (l,SFBmodtype mtb) :: msig -> let specs = extract_sfb_spec env mp msig in let spec = extract_seb_spec env mtb.typ_mp (my_type_of_mtb mtb) in (l,Smodtype spec) :: specs (* From [struct_expr_body] to specifications *) (* Invariant: the [seb] given to [extract_seb_spec] should either come from a [mod_type] or [type_expr] field, or their [_alg] counterparts. This way, any encountered [SEBident] should be a true module type. *) and extract_seb_spec env mp1 (seb,seb_alg) = match seb_alg with | SEBident mp -> Visit.add_mp_all mp; MTident mp | SEBwith(seb',With_definition_body(idl,cb))-> let env' = env_for_mtb_with_def env (msid_of_seb seb') seb idl in let mt = extract_seb_spec env mp1 (seb,seb') in (match extract_with_type env' cb with (* cb peut contenir des kn *) | None -> mt | Some (vl,typ) -> MTwith(mt,ML_With_type(idl,vl,typ))) | SEBwith(seb',With_module_body(idl,mp))-> Visit.add_mp_all mp; MTwith(extract_seb_spec env mp1 (seb,seb'), ML_With_module(idl,mp)) | SEBfunctor (mbid, mtb, seb_alg') -> let seb' = match seb with | SEBfunctor (mbid',_,seb') when mbid' = mbid -> seb' | _ -> assert false in let mp = MPbound mbid in let env' = Modops.add_module (Modops.module_body_of_type mp mtb) env in MTfunsig (mbid, extract_seb_spec env mp (my_type_of_mtb mtb), extract_seb_spec env' mp1 (seb',seb_alg')) | SEBstruct (msig) -> let env' = Modops.add_signature mp1 msig empty_delta_resolver env in MTsig (mp1, extract_sfb_spec env' mp1 msig) | SEBapply _ -> if seb <> seb_alg then extract_seb_spec env mp1 (seb,seb) else assert false (* From a [structure_body] (i.e. a list of [structure_field_body]) to implementations. NB: when [all=false], the evaluation order of the list is important: last to first ensures correct dependencies. *) let rec extract_sfb env mp all = function | [] -> [] | (l,SFBconst cb) :: msb -> (try let vl,recd,msb = factor_fix env l cb msb in let vc = Array.map (make_con mp empty_dirpath) vl in let ms = extract_sfb env mp all msb in let b = array_exists Visit.needed_con vc in if all || b then let d = extract_fixpoint env vc recd in if (not b) && (logical_decl d) then ms else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms with Impossible -> let ms = extract_sfb env mp all msb in let c = make_con mp empty_dirpath l in let b = Visit.needed_con c in if all || b then let d = extract_constant env c cb in if (not b) && (logical_decl d) then ms else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms) | (l,SFBmind mib) :: msb -> let ms = extract_sfb env mp all msb in let mind = make_mind mp empty_dirpath l in let b = Visit.needed_ind mind in if all || b then let d = Dind (mind, extract_inductive env mind) in if (not b) && (logical_decl d) then ms else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms | (l,SFBmodule mb) :: msb -> let ms = extract_sfb env mp all msb in let mp = MPdot (mp,l) in if all || Visit.needed_mp mp then (l,SEmodule (extract_module env mp true mb)) :: ms else ms | (l,SFBmodtype mtb) :: msb -> let ms = extract_sfb env mp all msb in let mp = MPdot (mp,l) in if all || Visit.needed_mp mp then (l,SEmodtype (extract_seb_spec env mp (my_type_of_mtb mtb))) :: ms else ms (* From [struct_expr_body] to implementations *) and extract_seb env mp all = function | (SEBident _ | SEBapply _) as seb when lang () <> Ocaml -> (* in Haskell/Scheme, we expand everything *) extract_seb env mp all (expand_seb env mp seb) | SEBident mp -> if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false; Visit.add_mp_all mp; MEident mp | SEBapply (meb, meb',_) -> MEapply (extract_seb env mp true meb, extract_seb env mp true meb') | SEBfunctor (mbid, mtb, meb) -> let mp1 = MPbound mbid in let env' = Modops.add_module (Modops.module_body_of_type mp1 mtb) env in MEfunctor (mbid, extract_seb_spec env mp1 (my_type_of_mtb mtb), extract_seb env' mp true meb) | SEBstruct (msb) -> let env' = Modops.add_signature mp msb empty_delta_resolver env in MEstruct (mp,extract_sfb env' mp all msb) | SEBwith (_,_) -> anomaly "Not available yet" and extract_module env mp all mb = (* A module has an empty [mod_expr] when : - it is a module variable (for instance X inside a Module F [X:SIG]) - it is a module assumption (Declare Module). Since we look at modules from outside, we shouldn't have variables. But a Declare Module at toplevel seems legal (cf #2525). For the moment we don't support this situation. *) match mb.mod_expr with | None -> error_no_module_expr mp | Some me -> { ml_mod_expr = extract_seb env mp all me; ml_mod_type = extract_seb_spec env mp (my_type_of_mb mb) } let unpack = function MEstruct (_,sel) -> sel | _ -> assert false let mono_environment refs mpl = Visit.reset (); List.iter Visit.add_ref refs; List.iter Visit.add_mp_all mpl; let env = Global.env () in let l = List.rev (environment_until None) in List.rev_map (fun (mp,m) -> mp, unpack (extract_seb env mp (Visit.needed_mp_all mp) m)) l (**************************************) (*S Part II : Input/Output primitives *) (**************************************) let descr () = match lang () with | Ocaml -> Ocaml.ocaml_descr | Haskell -> Haskell.haskell_descr | Scheme -> Scheme.scheme_descr (* From a filename string "foo.ml" or "foo", builds "foo.ml" and "foo.mli" Works similarly for the other languages. *) let default_id = id_of_string "Main" let mono_filename f = let d = descr () in match f with | None -> None, None, default_id | Some f -> let f = if Filename.check_suffix f d.file_suffix then Filename.chop_suffix f d.file_suffix else f in let id = if lang () <> Haskell then default_id else try id_of_string (Filename.basename f) with e when Errors.noncritical e -> error "Extraction: provided filename is not a valid identifier" in Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id (* Builds a suitable filename from a module id *) let module_filename mp = let f = file_of_modfile mp in let d = descr () in Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id_of_string f (*s Extraction of one decl to stdout. *) let print_one_decl struc mp decl = let d = descr () in reset_renaming_tables AllButExternal; set_phase Pre; ignore (d.pp_struct struc); set_phase Impl; push_visible mp []; msgnl (d.pp_decl decl); pop_visible () (*s Extraction of a ml struct to a file. *) (** For Recursive Extraction, writing directly on stdout won't work with coqide, we use a buffer instead *) let buf = Buffer.create 1000 let formatter dry file = let ft = if dry then Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) else match file with | Some f -> Pp_control.with_output_to f | None -> Format.formatter_of_buffer buf in (* We never want to see ellipsis ... in extracted code *) Format.pp_set_max_boxes ft max_int; (* We reuse the width information given via "Set Printing Width" *) (match Pp_control.get_margin () with | None -> () | Some i -> Format.pp_set_margin ft i; Format.pp_set_max_indent ft (i-10)); (* note: max_indent should be < margin above, otherwise it's ignored *) ft let print_structure_to_file (fn,si,mo) dry struc = Buffer.clear buf; let d = descr () in reset_renaming_tables AllButExternal; let unsafe_needs = { mldummy = struct_ast_search ((=) MLdummy) struc; tdummy = struct_type_search Mlutil.isDummy struc; tunknown = struct_type_search ((=) Tunknown) struc; magic = if lang () <> Haskell then false else struct_ast_search (function MLmagic _ -> true | _ -> false) struc } in (* First, a dry run, for computing objects to rename or duplicate *) set_phase Pre; let devnull = formatter true None in msg_with devnull (d.pp_struct struc); let opened = opened_libraries () in (* Print the implementation *) let cout = if dry then None else Option.map open_out fn in let ft = formatter dry cout in begin try (* The real printing of the implementation *) set_phase Impl; msg_with ft (d.preamble mo opened unsafe_needs); msg_with ft (d.pp_struct struc); Option.iter close_out cout; with reraise -> Option.iter close_out cout; raise reraise end; if not dry then Option.iter info_file fn; (* Now, let's print the signature *) Option.iter (fun si -> let cout = open_out si in let ft = formatter false (Some cout) in begin try set_phase Intf; msg_with ft (d.sig_preamble mo opened unsafe_needs); msg_with ft (d.pp_sig (signature_of_structure struc)); close_out cout; with reraise -> close_out cout; raise reraise end; info_file si) (if dry then None else si); (* Print the buffer content via Coq standard formatter (ok with coqide). *) if Buffer.length buf <> 0 then begin Pp.message (Buffer.contents buf); Buffer.reset buf end (*********************************************) (*s Part III: the actual extraction commands *) (*********************************************) let reset () = Visit.reset (); reset_tables (); reset_renaming_tables Everything let init modular library = check_inside_section (); check_inside_module (); set_keywords (descr ()).keywords; set_modular modular; set_library library; reset (); if modular && lang () = Scheme then error_scheme () let warns () = warning_opaques (access_opaque ()); warning_axioms () (* From a list of [reference], let's retrieve whether they correspond to modules or [global_reference]. Warn the user if both is possible. *) let rec locate_ref = function | [] -> [],[] | r::l -> let q = snd (qualid_of_reference r) in let mpo = try Some (Nametab.locate_module q) with Not_found -> None and ro = try Some (Smartlocate.global_with_alias r) with e when Errors.noncritical e -> None in match mpo, ro with | None, None -> Nametab.error_global_not_found q | None, Some r -> let refs,mps = locate_ref l in r::refs,mps | Some mp, None -> let refs,mps = locate_ref l in refs,mp::mps | Some mp, Some r -> warning_both_mod_and_cst q mp r; let refs,mps = locate_ref l in refs,mp::mps (*s Recursive extraction in the Coq toplevel. The vernacular command is \verb!Recursive Extraction! [qualid1] ... [qualidn]. Also used when extracting to a file with the command: \verb!Extraction "file"! [qualid1] ... [qualidn]. *) let full_extr f (refs,mps) = init false false; List.iter (fun mp -> if is_modfile mp then error_MPfile_as_mod mp true) mps; let struc = optimize_struct (refs,mps) (mono_environment refs mps) in warns (); print_structure_to_file (mono_filename f) false struc; reset () let full_extraction f lr = full_extr f (locate_ref lr) (*s Separate extraction is similar to recursive extraction, with the output decomposed in many files, one per Coq .v file *) let separate_extraction lr = init true false; let refs,mps = locate_ref lr in let struc = optimize_struct (refs,mps) (mono_environment refs mps) in warns (); let print = function | (MPfile dir as mp, sel) as e -> print_structure_to_file (module_filename mp) false [e] | _ -> assert false in List.iter print struc; reset () (*s Simple extraction in the Coq toplevel. The vernacular command is \verb!Extraction! [qualid]. *) let simple_extraction r = Vernacentries.dump_global (Genarg.AN r); match locate_ref [r] with | ([], [mp]) as p -> full_extr None p | [r],[] -> init false false; let struc = optimize_struct ([r],[]) (mono_environment [r] []) in let d = get_decl_in_structure r struc in warns (); if is_custom r then msgnl (str "(** User defined extraction *)"); print_one_decl struc (modpath_of_r r) d; reset () | _ -> assert false (*s (Recursive) Extraction of a library. The vernacular command is \verb!(Recursive) Extraction Library! [M]. *) let extraction_library is_rec m = init true true; let dir_m = let q = qualid_of_ident m in try Nametab.full_name_module q with Not_found -> error_unknown_module q in Visit.add_mp_all (MPfile dir_m); let env = Global.env () in let l = List.rev (environment_until (Some dir_m)) in let select l (mp,meb) = if Visit.needed_mp mp then (mp, unpack (extract_seb env mp true meb)) :: l else l in let struc = List.fold_left select [] l in let struc = optimize_struct ([],[]) struc in warns (); let print = function | (MPfile dir as mp, sel) as e -> let dry = not is_rec && dir <> dir_m in print_structure_to_file (module_filename mp) dry [e] | _ -> assert false in List.iter print struc; reset () coq-8.4pl4/plugins/extraction/common.mli0000644000175000017500000000562112326224777017473 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* std_ppcmds val fnl2 : unit -> std_ppcmds val space_if : bool -> std_ppcmds val pp_par : bool -> std_ppcmds -> std_ppcmds (** [pp_apply] : a head part applied to arguments, possibly with parenthesis *) val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds (** Same as [pp_apply], but with also protection of the head by parenthesis *) val pp_apply2 : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds val pp_tuple_light : (bool -> 'a -> std_ppcmds) -> 'a list -> std_ppcmds val pp_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds val pp_boxed_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds val pr_binding : identifier list -> std_ppcmds val rename_id : identifier -> Idset.t -> identifier type env = identifier list * Idset.t val empty_env : unit -> env val rename_vars: Idset.t -> identifier list -> env val rename_tvars: Idset.t -> identifier list -> identifier list val push_vars : identifier list -> env -> identifier list * env val get_db_name : int -> env -> identifier type phase = Pre | Impl | Intf val set_phase : phase -> unit val get_phase : unit -> phase val opened_libraries : unit -> module_path list type kind = Term | Type | Cons | Mod val pp_global : kind -> global_reference -> string val pp_module : module_path -> string val top_visible_mp : unit -> module_path (* In [push_visible], the [module_path list] corresponds to module parameters, the innermost one coming first in the list *) val push_visible : module_path -> module_path list -> unit val pop_visible : unit -> unit val check_duplicate : module_path -> label -> string type reset_kind = AllButExternal | Everything val reset_renaming_tables : reset_kind -> unit val set_keywords : Idset.t -> unit (** For instance: [mk_ind "Coq.Init.Datatypes" "nat"] *) val mk_ind : string -> string -> mutual_inductive (** Special hack for constants of type Ascii.ascii : if an [Extract Inductive ascii => char] has been declared, then the constants are directly turned into chars *) val is_native_char : ml_ast -> bool val pp_native_char : ml_ast -> std_ppcmds coq-8.4pl4/plugins/extraction/CHANGES0000644000175000017500000003341712326224777016477 0ustar stephsteph8.0 -> today See the main CHANGES file in the archive 7.4 -> 8.0 No revolution this time. Mostly "behind-the-scene" clean-up and bug-fixes, but also a few steps toward a more user-friendly extraction: * syntax of extraction: - The old (Recursive) Extraction Module M. is now (Recursive) Extraction Library M. The old name was misleading since this command only works with M being a library M.v, and not a module produced by interactive command Module M. - The other commands Extraction foo. Recursive Extraction foo bar. Extraction "myfile.ml" foo bar. now accept that foo can be a module name instead of just a constant name. * Support of type scheme axioms (i.e. axiom whose type is an arity (x1:X1)...(xn:Xn)s with s a sort). For example: Axiom myprod : Set -> Set -> Set. Extract Constant myprod "'a" "'b" => "'a * 'b". Recursive Extraction myprod. -------> type ('a,'b) myprod = 'a * 'b * More flexible support of axioms. When an axiom isn't realized via Extract Constant before extraction, a warning is produced (instead of an error), and the extracted code must be completed later by hand. To find what needs to be completed, search for the following string: AXIOM TO BE REALIZED * Cosmetics: When extraction produces a file, it tells it. * (Experimental) It is allowed to extract under a opened interactive module (but still outside sections). Feature to be used with caution. * A problem has been identified concerning .v files used as normal interactive modules, like in Definition foo :=O. Require A. Module M:=A Extraction M. I might try to support that in the future. In the meanwhile, the current behaviour of extraction is to forbid this. * bug fixes: - many concerning Records. - a Stack Overflow with mutual inductive (PR#320) - some optimizations have been removed since they were not type-safe: For example if e has type: type 'x a = A Then: match e with A -> A -----X----> e To be investigated further. 7.3 -> 7.4 * The two main new features: - Automatic generation of Obj.magic when the extracted code in Ocaml is not directly typable. - An experimental extraction of Coq's new modules to Ocaml modules. * Concerning those Obj.magic: - The extraction now computes the expected type of any terms. Then it compares it with the actual type of the produced code. And when a mismatch is found, a Obj.magic is inserted. - As a rule, any extracted development that was compiling out of the box should not contain any Obj.magic. At the other hand, generation of Obj.magic is not optimized yet: there might be several of them at a place were one would have been enough. - Examples of code needing those Obj.magic: * plugins/extraction/test_extraction.v in the Coq source * in the users' contributions: Lannion Lyon/CIRCUITS Rocq/HIGMAN - As a side-effect of this Obj.magic feature, we now print the types of the extracted terms, both in .ml files as commented documentation and in interfaces .mli files - This feature hasn't been ported yet to Haskell. We are aware of some unsafe casting functions like "unsafeCoerce" on some Haskell implems. So it will eventually be done. * Concerning the extraction of Coq's new modules: - Taking in account the new Coq's modules system has implied a *huge* rewrite of most of the extraction code. - The extraction core (translation from Coq to an abstract mini-ML) is now complete and fairly stable, and supports modules, modules type and functors and all that stuff. - The ocaml pretty-print part, especially the renaming issue, is clearly weaker, and certainly still contains bugs. - Nothing done for translating these Coq Modules to Haskell. - A temporary drawback of this module extraction implementation is that efficiency (especially extraction speed) has been somehow neglected. To improve ... - As an interesting side-effect, definitions are now printed according to the user's original order. No more of this "dependency-correct but weird" order. In particular realized axioms via Extract Constant are now at their right place, and not at the beginning. * Other news: - Records are now printed using the Ocaml record syntax - Syntax output toward Scheme. Quite funny, but quite experimental and not documented. I recommend using the bigloo compiler since it contains natively some pattern matching. - the dummy constant "__" have changed. see README - a few bug-fixes (#191 and others) 7.2 -> 7.3 * Improved documentation in the Reference Manual. * Theoretical bad news: - a naughty example (see the end of test_extraction.v) forced me to stop eliminating lambdas and arguments corresponding to so-called "arity" in the general case. - The dummy constant used in extraction ( let prop = () in ocaml ) may in some cases be applied to arguments. This problem is dealt by generating sufficient abstraction before the (). * Theoretical good news: - there is now a mechanism that remove useless prop/arity lambdas at the top of function declarations. If your function had signature nat -> prop -> nat in the previous extraction, it will now be nat -> nat. So the extractions of common terms should look very much like the old V6.2 one, except in some particular cases (functions as parameters, partial applications, etc). In particular the bad news above have nearly no impact... * By the way there is no more "let prop = ()" in ocaml. Those () are directly inlined. And in Haskell the dummy constant is now __ (two underscore) and is defined by __ = Prelude.error "Logical or arity value used" This dummy constant should never be evaluated when computing an informative value, thanks to the lazy strategy. Hence the error message. * Syntax changes, see Documentation for details: Extraction Language Ocaml. Extraction Language Haskell. Extraction Language Toplevel. That fixes the target language of extraction. Default is Ocaml, even in the coq toplevel: you can now do copy-paste from the coq toplevel without renaming problems. Toplevel language is the ocaml pseudo-language used previously used inside the coq toplevel: coq names are printed with the coq way, i.e. with no renaming. So there is no more particular commands for Haskell, like Haskell Extraction "file" id. Just set your favourite language and go... * Haskell extraction has been tested at last (and corrected...). See specificities in Documentation. * Extraction of CoInductive in Ocaml language is now correct: it uses the Lazy.force and lazy features of Ocaml. * Modular extraction in Ocaml is now far more readable: instead of qualifying everywhere (A.foo), there are now some "open" at the beginning of files. Possible clashes are dealt with. * By default, any recursive function associated with an inductive type (foo_rec and foo_rect when foo is inductive type) will now be inlined in extracted code. * A few constants are explicitely declared to be inlined in extracted code. For the moment there are: Wf.Acc_rec Wf.Acc_rect Wf.well_founded_induction Wf.well_founded_induction_type Those constants does not match the auto-inlining criterion based on strictness. Of course, you can still overide this behaviour via some Extraction NoInline. * There is now a web page showing the extraction of all standard theories: http://www.lri.fr/~letouzey/extraction 7.1 -> 7.2 : * Syntax changes, see Documentation for more details: Set/Unset Extraction Optimize. Default is Set. This control all optimizations made on the ML terms (mostly reduction of dummy beta/iota redexes, but also simplications on Cases, etc). Put this option to Unset if you what a ML term as close as possible to the Coq term. Set/Unset Extraction AutoInline. Default in Set, so by default, the extraction mechanism feels free to inline the bodies of some defined constants, according to some heuristics like size of bodies, useness of some arguments, etc. Those heuristics are not always perfect, you may want to disable this feature, do it by Unset. Extraction Inline toto foo. Extraction NoInline titi faa bor. In addition to the automatic inline feature, you can now tell precisely to inline some more constants by the Extraction Inline command. Conversely, you can forbid the inlining of some specific constants by automatic inlining. Those two commands enable a precise control of what is inlined and what is not. Print Extraction Inline. Sum up the current state of the table recording the custom inlings (Extraction (No)Inline). Reset Extraction Inline. Put the table recording the custom inlings back to empty. As a consequence, there is no more need for options inside the commands of extraction: Extraction foo. Recursive Extraction foo bar. Extraction "file" foo bar. Extraction Module Mymodule. Recursive Extraction Module Mymodule. New: The last syntax extracts the module Mymodule and all the modules it depends on. You can also try the Haskell versions (not tested yet): Haskell Extraction foo. Haskell Recursive Extraction foo bar. Haskell Extraction "file" foo bar. Haskell Extraction Module Mymodule. Haskell Recursive Extraction Module Mymodule. And there's still the realization syntax: Extract Constant coq_bla => "caml_bla". Extract Inlined Constant coq_bla => "caml_bla". Extract Inductive myinductive => mycamlind [my_caml_constr1 ... ]. Note that now, the Extract Inlined Constant command is sugar for an Extract Constant followed by a Extraction Inline. So be careful with Reset Extraction Inline. * Lot of works around optimization of produced code. Should make code more readable. - fixpoint definitions : there should be no more stupid printings like let foo x = let rec f x = .... (f y) .... in f x but rather let rec foo x = .... (foo y) .... - generalized iota (in particular iota and permutation cases/cases): A generalized iota redex is a "Cases e of ...." where e is ok. And the recursive predicate "ok" is given by: e is ok if e is a Constructor or a Cases where all branches are ok. In the case of generalized iota redex, it might be good idea to reduce it, so we do it. Example: match (match t with O -> Left | S n -> match n with O -> Right | S m -> Left) with Left -> blabla | Right -> bloblo After simplification, that gives: match t with O -> blabla | S n -> match n with O -> bloblo | S n -> blabla As shown on the example, code duplication can occur. In practice it seems not to happen frequently. - "constant" case: In V7.1 we used to simplify cases where all branches are the same. In V7.2 we can simplify in addition terms like cases e of C1 x y -> f (C x y) | C2 z -> f (C2 z) If x y z don't occur in f, we can produce (f e). - permutation cases/fun: extracted code has frequenty functions in branches of cases: let foo x = match x with O -> fun _ -> .... | S y -> fun _ -> .... the optimization consist in lifting the common "fun _ ->", and that gives let foo x _ = match x with O -> ..... | S y -> .... * Some bug corrections (many thanks in particular to Michel Levy). * Testing in coq contributions: If you are interested in extraction, you can look at the extraction tests I'have put in the following coq contributions Bordeaux/Additions computation of fibonacci(2000) Bordeaux/EXCEPTIONS multiplication using exception. Bordeaux/SearchTrees list -> binary tree. maximum. Dyade/BDDS boolean tautology checker. Lyon/CIRCUITS multiplication via a modelization of a circuit. Lyon/FIRING-SQUAD print the states of the firing squad. Marseille/CIRCUITS compares integers via a modelization of a circuit. Nancy/FOUnify unification of two first-order terms. Rocq/ARITH/Chinese computation of the chinese remainder. Rocq/COC small coc typechecker. (test by B. Barras, not by me) Rocq/HIGMAN run the proof on one example. Rocq/GRAPHS linear constraints checker in Z. Sophia-Antipolis/Stalmarck boolean tautology checker. Suresnes/BDD boolean tautology checker. Just do "make" in those contributions, the extraction test is integrated. More tests will follow on more contributions. 7.0 -> 7.1 : mostly bug corrections. No theoretical problems dealed with. * The semantics of Extract Constant changed: If you provide a extraction for p by Extract Constant p => "0", your generated ML file will begin by a let p = 0. The old semantics, which was to replace p everywhere by the provided terms, is still available via the Extract Inlined Constant p => "0" syntax. * There are more optimizations applied to the generated code: - identity cases: match e with P x y -> P x y | Q z -> Q z | ... is simplified into e. Especially interesting with the sumbool terms: there will be no more match ... with Left -> Left | Right -> Right - constant cases: match e with P x y -> c | Q z -> c | ... is simplified into c as soon as x, y, z do not occur in c. So no more match ... with Left -> Left | Right -> Left. * the extraction at Toplevel (Extraction foo and Recursive Extraction foo), which was only a development tool at the beginning, is now closer to the real extraction to a file. In particular optimizations are done, and constants like recursors ( ..._rec ) are expanded. * the singleton optimization is now protected against circular type. ( Remind : this optimization is the one that simplify type 'a sig = Exists of 'a into type 'a sig = 'a and match e with (Exists c) -> d into let c = e in d ) * Fixed one bug concerning casted code * The inductives generated should now have always correct type-var list ('a,'b,'c...) * Code cleanup until three days before release. Messing-up code in the last three days before release. 6.x -> 7.0 : Everything changed. See README coq-8.4pl4/plugins/extraction/ExtrOcamlZInt.v0000644000175000017500000000622712326224777020375 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int [ "(fun p->1+2*p)" "(fun p->2*p)" "1" ] "(fun f2p1 f2p f1 p -> if p<=1 then f1 () else if p mod 2 = 0 then f2p (p/2) else f2p1 (p/2))". Extract Inductive Z => int [ "0" "" "(~-)" ] "(fun f0 fp fn z -> if z=0 then f0 () else if z>0 then fp z else fn (-z))". Extract Inductive N => int [ "0" "" ] "(fun f0 fp n -> if n=0 then f0 () else fp n)". (** Nota: the "" above is used as an identity function "(fun p->p)" *) (** Efficient (but uncertified) versions for usual functions *) Extract Constant Pos.add => "(+)". Extract Constant Pos.succ => "Pervasives.succ". Extract Constant Pos.pred => "fun n -> Pervasives.max 1 (n-1)". Extract Constant Pos.sub => "fun n m -> Pervasives.max 1 (n-m)". Extract Constant Pos.mul => "( * )". Extract Constant Pos.min => "Pervasives.min". Extract Constant Pos.max => "Pervasives.max". Extract Constant Pos.compare => "fun x y -> if x=y then Eq else if x "fun x y c -> if x=y then c else if x "(+)". Extract Constant N.succ => "Pervasives.succ". Extract Constant N.pred => "fun n -> Pervasives.max 0 (n-1)". Extract Constant N.sub => "fun n m -> Pervasives.max 0 (n-m)". Extract Constant N.mul => "( * )". Extract Constant N.min => "Pervasives.min". Extract Constant N.max => "Pervasives.max". Extract Constant N.div => "fun a b -> if b=0 then 0 else a/b". Extract Constant N.modulo => "fun a b -> if b=0 then a else a mod b". Extract Constant N.compare => "fun x y -> if x=y then Eq else if x "(+)". Extract Constant Z.succ => "Pervasives.succ". Extract Constant Z.pred => "Pervasives.pred". Extract Constant Z.sub => "(-)". Extract Constant Z.mul => "( * )". Extract Constant Z.opp => "(~-)". Extract Constant Z.abs => "Pervasives.abs". Extract Constant Z.min => "Pervasives.min". Extract Constant Z.max => "Pervasives.max". Extract Constant Z.compare => "fun x y -> if x=y then Eq else if x "fun p -> p". Extract Constant Z.abs_N => "Pervasives.abs". (** Z.div and Z.modulo are quite complex to define in terms of (/) and (mod). For the moment we don't even try *) coq-8.4pl4/plugins/extraction/ExtrOcamlBigIntConv.v0000644000175000017500000000734612326224777021516 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bigint. Parameter bigint_opp : bigint -> bigint. Parameter bigint_twice : bigint -> bigint. Extract Inlined Constant bigint => "Big.big_int". Extract Inlined Constant bigint_zero => "Big.zero". Extract Inlined Constant bigint_succ => "Big.succ". Extract Inlined Constant bigint_opp => "Big.opp". Extract Inlined Constant bigint_twice => "Big.double". Definition bigint_of_nat : nat -> bigint := (fix loop acc n := match n with | O => acc | S n => loop (bigint_succ acc) n end) bigint_zero. Fixpoint bigint_of_pos p := match p with | xH => bigint_succ bigint_zero | xO p => bigint_twice (bigint_of_pos p) | xI p => bigint_succ (bigint_twice (bigint_of_pos p)) end. Fixpoint bigint_of_z z := match z with | Z0 => bigint_zero | Zpos p => bigint_of_pos p | Zneg p => bigint_opp (bigint_of_pos p) end. Fixpoint bigint_of_n n := match n with | N0 => bigint_zero | Npos p => bigint_of_pos p end. (** NB: as for [pred] or [minus], [nat_of_bigint], [n_of_bigint] and [pos_of_bigint] are total and return zero (resp. one) for non-positive inputs. *) Parameter bigint_natlike_rec : forall A, A -> (A->A) -> bigint -> A. Extract Constant bigint_natlike_rec => "Big.nat_rec". Definition nat_of_bigint : bigint -> nat := bigint_natlike_rec _ O S. Parameter bigint_poslike_rec : forall A, (A->A) -> (A->A) -> A -> bigint -> A. Extract Constant bigint_poslike_rec => "Big.positive_rec". Definition pos_of_bigint : bigint -> positive := bigint_poslike_rec _ xI xO xH. Parameter bigint_zlike_case : forall A, A -> (bigint->A) -> (bigint->A) -> bigint -> A. Extract Constant bigint_zlike_case => "Big.z_rec". Definition z_of_bigint : bigint -> Z := bigint_zlike_case _ Z0 (fun i => Zpos (pos_of_bigint i)) (fun i => Zneg (pos_of_bigint i)). Definition n_of_bigint : bigint -> N := bigint_zlike_case _ N0 (fun i => Npos (pos_of_bigint i)) (fun _ => N0). (* Tests: Definition small := 1234%nat. Definition big := 12345678901234567890%positive. Definition nat_0 := nat_of_bigint (bigint_of_nat 0). Definition nat_1 := nat_of_bigint (bigint_of_nat small). Definition pos_1 := pos_of_bigint (bigint_of_pos 1). Definition pos_2 := pos_of_bigint (bigint_of_pos big). Definition n_0 := n_of_bigint (bigint_of_n 0). Definition n_1 := n_of_bigint (bigint_of_n 1). Definition n_2 := n_of_bigint (bigint_of_n (Npos big)). Definition z_0 := z_of_bigint (bigint_of_z 0). Definition z_1 := z_of_bigint (bigint_of_z 1). Definition z_2 := z_of_bigint (bigint_of_z (Zpos big)). Definition z_m1 := z_of_bigint (bigint_of_z (-1)). Definition z_m2 := z_of_bigint (bigint_of_z (Zneg big)). Definition test := (nat_0, nat_1, pos_1, pos_2, n_0, n_1, n_2, z_0, z_1, z_2, z_m1, z_m2). Definition check := (O, small, xH, big, 0%N, 1%N, Npos big, 0%Z, 1%Z, Zpos big, (-1)%Z, Zneg big). Extraction "/tmp/test.ml" check test. ... and we check that test=check *)coq-8.4pl4/plugins/extraction/ExtrOcamlZBigInt.v0000644000175000017500000000662312326224777021017 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* "Big.big_int" [ "Big.doubleplusone" "Big.double" "Big.one" ] "Big.positive_case". Extract Inductive Z => "Big.big_int" [ "Big.zero" "" "Big.opp" ] "Big.z_case". Extract Inductive N => "Big.big_int" [ "Big.zero" "" ] "Big.n_case". (** Nota: the "" above is used as an identity function "(fun p->p)" *) (** Efficient (but uncertified) versions for usual functions *) Extract Constant Pos.add => "Big.add". Extract Constant Pos.succ => "Big.succ". Extract Constant Pos.pred => "fun n -> Big.max Big.one (Big.pred n)". Extract Constant Pos.sub => "fun n m -> Big.max Big.one (Big.sub n m)". Extract Constant Pos.mul => "Big.mult". Extract Constant Pos.min => "Big.min". Extract Constant Pos.max => "Big.max". Extract Constant Pos.compare => "fun x y -> Big.compare_case Eq Lt Gt x y". Extract Constant Pos.compare_cont => "fun x y c -> Big.compare_case c Lt Gt x y". Extract Constant N.add => "Big.add". Extract Constant N.succ => "Big.succ". Extract Constant N.pred => "fun n -> Big.max Big.zero (Big.pred n)". Extract Constant N.sub => "fun n m -> Big.max Big.zero (Big.sub n m)". Extract Constant N.mul => "Big.mult". Extract Constant N.min => "Big.min". Extract Constant N.max => "Big.max". Extract Constant N.div => "fun a b -> if Big.eq b Big.zero then Big.zero else Big.div a b". Extract Constant N.modulo => "fun a b -> if Big.eq b Big.zero then Big.zero else Big.modulo a b". Extract Constant N.compare => "Big.compare_case Eq Lt Gt". Extract Constant Z.add => "Big.add". Extract Constant Z.succ => "Big.succ". Extract Constant Z.pred => "Big.pred". Extract Constant Z.sub => "Big.sub". Extract Constant Z.mul => "Big.mult". Extract Constant Z.opp => "Big.opp". Extract Constant Z.abs => "Big.abs". Extract Constant Z.min => "Big.min". Extract Constant Z.max => "Big.max". Extract Constant Z.compare => "Big.compare_case Eq Lt Gt". Extract Constant Z.of_N => "fun p -> p". Extract Constant Z.abs_N => "Big.abs". (** Z.div and Z.modulo are quite complex to define in terms of (/) and (mod). For the moment we don't even try *) (** Test: Require Import ZArith NArith. Extraction "/tmp/test.ml" Pos.add Pos.pred Pos.sub Pos.mul Pos.compare N.pred N.sub N.div N.modulo N.compare Z.add Z.mul Z.compare Z.of_N Z.abs_N Z.div Z.modulo. *) coq-8.4pl4/plugins/extraction/scheme.mli0000644000175000017500000000106712326224777017447 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* anonymous_name | Name id when id = dummy_name -> anonymous_name | Name id -> id let id_of_mlid = function | Dummy -> dummy_name | Id id -> id | Tmp id -> id let tmp_id = function | Id id -> Tmp id | a -> a let is_tmp = function Tmp _ -> true | _ -> false (*S Operations upon ML types (with meta). *) let meta_count = ref 0 let reset_meta_count () = meta_count := 0 let new_meta _ = incr meta_count; Tmeta {id = !meta_count; contents = None} (* Simultaneous substitution of [[Tvar 1; ... ; Tvar n]] by [l] in a ML type. *) let type_subst_list l t = let rec subst t = match t with | Tvar j -> List.nth l (j-1) | Tmeta {contents=None} -> t | Tmeta {contents=Some u} -> subst u | Tarr (a,b) -> Tarr (subst a, subst b) | Tglob (r, l) -> Tglob (r, List.map subst l) | a -> a in subst t (* Simultaneous substitution of [[|Tvar 1; ... ; Tvar n|]] by [v] in a ML type. *) let type_subst_vect v t = let rec subst t = match t with | Tvar j -> v.(j-1) | Tmeta {contents=None} -> t | Tmeta {contents=Some u} -> subst u | Tarr (a,b) -> Tarr (subst a, subst b) | Tglob (r, l) -> Tglob (r, List.map subst l) | a -> a in subst t (*s From a type schema to a type. All [Tvar] become fresh [Tmeta]. *) let instantiation (nb,t) = type_subst_vect (Array.init nb new_meta) t (*s Occur-check of a free meta in a type *) let rec type_occurs alpha t = match t with | Tmeta {id=beta; contents=None} -> alpha = beta | Tmeta {contents=Some u} -> type_occurs alpha u | Tarr (t1, t2) -> type_occurs alpha t1 || type_occurs alpha t2 | Tglob (r,l) -> List.exists (type_occurs alpha) l | _ -> false (*s Most General Unificator *) let rec mgu = function | Tmeta m, Tmeta m' when m.id = m'.id -> () | Tmeta m, t | t, Tmeta m -> (match m.contents with | Some u -> mgu (u, t) | None when type_occurs m.id t -> raise Impossible | None -> m.contents <- Some t) | Tarr(a, b), Tarr(a', b') -> mgu (a, a'); mgu (b, b') | Tglob (r,l), Tglob (r',l') when r = r' -> List.iter mgu (List.combine l l') | (Tdummy _, _ | _, Tdummy _) when lang() = Haskell -> () | Tdummy _, Tdummy _ -> () | t, u when t = u -> () (* for Tvar, Tvar', Tunknown, Taxiom *) | _ -> raise Impossible let needs_magic p = try mgu p; false with Impossible -> true let put_magic_if b a = if b && lang () <> Scheme then MLmagic a else a let put_magic p a = if needs_magic p && lang () <> Scheme then MLmagic a else a let generalizable a = lang () <> Ocaml || match a with | MLapp _ -> false | _ -> true (* TODO, this is just an approximation for the moment *) (*S ML type env. *) module Mlenv = struct let meta_cmp m m' = compare m.id m'.id module Metaset = Set.Make(struct type t = ml_meta let compare = meta_cmp end) (* Main MLenv type. [env] is the real environment, whereas [free] (tries to) record the free meta variables occurring in [env]. *) type t = { env : ml_schema list; mutable free : Metaset.t} (* Empty environment. *) let empty = { env = []; free = Metaset.empty } (* [get] returns a instantiated copy of the n-th most recently added type in the environment. *) let get mle n = assert (List.length mle.env >= n); instantiation (List.nth mle.env (n-1)) (* [find_free] finds the free meta in a type. *) let rec find_free set = function | Tmeta m when m.contents = None -> Metaset.add m set | Tmeta {contents = Some t} -> find_free set t | Tarr (a,b) -> find_free (find_free set a) b | Tglob (_,l) -> List.fold_left find_free set l | _ -> set (* The [free] set of an environment can be outdate after some unifications. [clean_free] takes care of that. *) let clean_free mle = let rem = ref Metaset.empty and add = ref Metaset.empty in let clean m = match m.contents with | None -> () | Some u -> rem := Metaset.add m !rem; add := find_free !add u in Metaset.iter clean mle.free; mle.free <- Metaset.union (Metaset.diff mle.free !rem) !add (* From a type to a type schema. If a [Tmeta] is still uninstantiated and does appears in the [mle], then it becomes a [Tvar]. *) let generalization mle t = let c = ref 0 in let map = ref (Intmap.empty : int Intmap.t) in let add_new i = incr c; map := Intmap.add i !c !map; !c in let rec meta2var t = match t with | Tmeta {contents=Some u} -> meta2var u | Tmeta ({id=i} as m) -> (try Tvar (Intmap.find i !map) with Not_found -> if Metaset.mem m mle.free then t else Tvar (add_new i)) | Tarr (t1,t2) -> Tarr (meta2var t1, meta2var t2) | Tglob (r,l) -> Tglob (r, List.map meta2var l) | t -> t in !c, meta2var t (* Adding a type in an environment, after generalizing. *) let push_gen mle t = clean_free mle; { env = generalization mle t :: mle.env; free = mle.free } (* Adding a type with no [Tvar], hence no generalization needed. *) let push_type {env=e;free=f} t = { env = (0,t) :: e; free = find_free f t} (* Adding a type with no [Tvar] nor [Tmeta]. *) let push_std_type {env=e;free=f} t = { env = (0,t) :: e; free = f} end (*S Operations upon ML types (without meta). *) (*s Does a section path occur in a ML type ? *) let rec type_mem_kn kn = function | Tmeta {contents = Some t} -> type_mem_kn kn t | Tglob (r,l) -> occur_kn_in_ref kn r || List.exists (type_mem_kn kn) l | Tarr (a,b) -> (type_mem_kn kn a) || (type_mem_kn kn b) | _ -> false (*s Greatest variable occurring in [t]. *) let type_maxvar t = let rec parse n = function | Tmeta {contents = Some t} -> parse n t | Tvar i -> max i n | Tarr (a,b) -> parse (parse n a) b | Tglob (_,l) -> List.fold_left parse n l | _ -> n in parse 0 t (*s What are the type variables occurring in [t]. *) let intset_union_map_list f l = List.fold_left (fun s t -> Intset.union s (f t)) Intset.empty l let intset_union_map_array f a = Array.fold_left (fun s t -> Intset.union s (f t)) Intset.empty a let rec type_listvar = function | Tmeta {contents = Some t} -> type_listvar t | Tvar i | Tvar' i -> Intset.singleton i | Tarr (a,b) -> Intset.union (type_listvar a) (type_listvar b) | Tglob (_,l) -> intset_union_map_list type_listvar l | _ -> Intset.empty (*s From [a -> b -> c] to [[a;b],c]. *) let rec type_decomp = function | Tmeta {contents = Some t} -> type_decomp t | Tarr (a,b) -> let l,h = type_decomp b in a::l, h | a -> [],a (*s The converse: From [[a;b],c] to [a -> b -> c]. *) let rec type_recomp (l,t) = match l with | [] -> t | a::l -> Tarr (a, type_recomp (l,t)) (*s Translating [Tvar] to [Tvar'] to avoid clash. *) let rec var2var' = function | Tmeta {contents = Some t} -> var2var' t | Tvar i -> Tvar' i | Tarr (a,b) -> Tarr (var2var' a, var2var' b) | Tglob (r,l) -> Tglob (r, List.map var2var' l) | a -> a type abbrev_map = global_reference -> ml_type option (*s Delta-reduction of type constants everywhere in a ML type [t]. [env] is a function of type [ml_type_env]. *) let type_expand env t = let rec expand = function | Tmeta {contents = Some t} -> expand t | Tglob (r,l) -> (match env r with | Some mlt -> expand (type_subst_list l mlt) | None -> Tglob (r, List.map expand l)) | Tarr (a,b) -> Tarr (expand a, expand b) | a -> a in if Table.type_expand () then expand t else t let type_simpl = type_expand (fun _ -> None) (*s Generating a signature from a ML type. *) let type_to_sign env t = match type_expand env t with | Tdummy d -> Kill d | _ -> Keep let type_to_signature env t = let rec f = function | Tmeta {contents = Some t} -> f t | Tarr (Tdummy d, b) -> Kill d :: f b | Tarr (_, b) -> Keep :: f b | _ -> [] in f (type_expand env t) let isKill = function Kill _ -> true | _ -> false let isDummy = function Tdummy _ -> true | _ -> false let sign_of_id = function | Dummy -> Kill Kother | _ -> Keep (* Classification of signatures *) type sign_kind = | EmptySig | NonLogicalSig (* at least a [Keep] *) | UnsafeLogicalSig (* No [Keep], at least a [Kill Kother] *) | SafeLogicalSig (* only [Kill Ktype] *) let rec sign_kind = function | [] -> EmptySig | Keep :: _ -> NonLogicalSig | Kill k :: s -> match sign_kind s with | NonLogicalSig -> NonLogicalSig | UnsafeLogicalSig -> UnsafeLogicalSig | SafeLogicalSig | EmptySig -> if k = Kother then UnsafeLogicalSig else SafeLogicalSig (* Removing the final [Keep] in a signature *) let rec sign_no_final_keeps = function | [] -> [] | k :: s -> let s' = k :: sign_no_final_keeps s in if s' = [Keep] then [] else s' (*s Removing [Tdummy] from the top level of a ML type. *) let type_expunge_from_sign env s t = let rec expunge s t = if s = [] then t else match t with | Tmeta {contents = Some t} -> expunge s t | Tarr (a,b) -> let t = expunge (List.tl s) b in if List.hd s = Keep then Tarr (a, t) else t | Tglob (r,l) -> (match env r with | Some mlt -> expunge s (type_subst_list l mlt) | None -> assert false) | _ -> assert false in let t = expunge (sign_no_final_keeps s) t in if lang () <> Haskell && sign_kind s = UnsafeLogicalSig then Tarr (Tdummy Kother, t) else t let type_expunge env t = type_expunge_from_sign env (type_to_signature env t) t (*S Generic functions over ML ast terms. *) let mlapp f a = if a = [] then f else MLapp (f,a) (*s [ast_iter_rel f t] applies [f] on every [MLrel] in t. It takes care of the number of bingings crossed before reaching the [MLrel]. *) let ast_iter_rel f = let rec iter n = function | MLrel i -> f (i-n) | MLlam (_,a) -> iter (n+1) a | MLletin (_,a,b) -> iter n a; iter (n+1) b | MLcase (_,a,v) -> iter n a; Array.iter (fun (l,_,t) -> iter (n + (List.length l)) t) v | MLfix (_,ids,v) -> let k = Array.length ids in Array.iter (iter (n+k)) v | MLapp (a,l) -> iter n a; List.iter (iter n) l | MLcons (_,_,l) | MLtuple l -> List.iter (iter n) l | MLmagic a -> iter n a | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () in iter 0 (*s Map over asts. *) let ast_map_branch f (c,ids,a) = (c,ids,f a) (* Warning: in [ast_map] we assume that [f] does not change the type of [MLcons] and of [MLcase] heads *) let ast_map f = function | MLlam (i,a) -> MLlam (i, f a) | MLletin (i,a,b) -> MLletin (i, f a, f b) | MLcase (typ,a,v) -> MLcase (typ,f a, Array.map (ast_map_branch f) v) | MLfix (i,ids,v) -> MLfix (i, ids, Array.map f v) | MLapp (a,l) -> MLapp (f a, List.map f l) | MLcons (typ,c,l) -> MLcons (typ,c, List.map f l) | MLtuple l -> MLtuple (List.map f l) | MLmagic a -> MLmagic (f a) | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a (*s Map over asts, with binding depth as parameter. *) let ast_map_lift_branch f n (ids,p,a) = (ids,p, f (n+(List.length ids)) a) (* Same warning as for [ast_map]... *) let ast_map_lift f n = function | MLlam (i,a) -> MLlam (i, f (n+1) a) | MLletin (i,a,b) -> MLletin (i, f n a, f (n+1) b) | MLcase (typ,a,v) -> MLcase (typ,f n a,Array.map (ast_map_lift_branch f n) v) | MLfix (i,ids,v) -> let k = Array.length ids in MLfix (i,ids,Array.map (f (k+n)) v) | MLapp (a,l) -> MLapp (f n a, List.map (f n) l) | MLcons (typ,c,l) -> MLcons (typ,c, List.map (f n) l) | MLtuple l -> MLtuple (List.map (f n) l) | MLmagic a -> MLmagic (f n a) | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a (*s Iter over asts. *) let ast_iter_branch f (c,ids,a) = f a let ast_iter f = function | MLlam (i,a) -> f a | MLletin (i,a,b) -> f a; f b | MLcase (_,a,v) -> f a; Array.iter (ast_iter_branch f) v | MLfix (i,ids,v) -> Array.iter f v | MLapp (a,l) -> f a; List.iter f l | MLcons (_,_,l) | MLtuple l -> List.iter f l | MLmagic a -> f a | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () (*S Operations concerning De Bruijn indices. *) (*s [ast_occurs k t] returns [true] if [(Rel k)] occurs in [t]. *) let ast_occurs k t = try ast_iter_rel (fun i -> if i = k then raise Found) t; false with Found -> true (*s [occurs_itvl k k' t] returns [true] if there is a [(Rel i)] in [t] with [k<=i<=k'] *) let ast_occurs_itvl k k' t = try ast_iter_rel (fun i -> if (k <= i) && (i <= k') then raise Found) t; false with Found -> true (* Number of occurences of [Rel 1] in [t], with special treatment of match: occurences in different branches aren't added, but we rather use max. *) let nb_occur_match = let rec nb k = function | MLrel i -> if i = k then 1 else 0 | MLcase(_,a,v) -> (nb k a) + Array.fold_left (fun r (ids,_,a) -> max r (nb (k+(List.length ids)) a)) 0 v | MLletin (_,a,b) -> (nb k a) + (nb (k+1) b) | MLfix (_,ids,v) -> let k = k+(Array.length ids) in Array.fold_left (fun r a -> r+(nb k a)) 0 v | MLlam (_,a) -> nb (k+1) a | MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l | MLcons (_,_,l) | MLtuple l -> List.fold_left (fun r a -> r+(nb k a)) 0 l | MLmagic a -> nb k a | MLglob _ | MLexn _ | MLdummy | MLaxiom -> 0 in nb 1 (*s Lifting on terms. [ast_lift k t] lifts the binding depth of [t] across [k] bindings. *) let ast_lift k t = let rec liftrec n = function | MLrel i as a -> if i-n < 1 then a else MLrel (i+k) | a -> ast_map_lift liftrec n a in if k = 0 then t else liftrec 0 t let ast_pop t = ast_lift (-1) t (*s [permut_rels k k' c] translates [Rel 1 ... Rel k] to [Rel (k'+1) ... Rel (k'+k)] and [Rel (k+1) ... Rel (k+k')] to [Rel 1 ... Rel k'] *) let permut_rels k k' = let rec permut n = function | MLrel i as a -> let i' = i-n in if i'<1 || i'>k+k' then a else if i'<=k then MLrel (i+k') else MLrel (i-k) | a -> ast_map_lift permut n a in permut 0 (*s Substitution. [ml_subst e t] substitutes [e] for [Rel 1] in [t]. Lifting (of one binder) is done at the same time. *) let ast_subst e = let rec subst n = function | MLrel i as a -> let i' = i-n in if i'=1 then ast_lift n e else if i'<1 then a else MLrel (i-1) | a -> ast_map_lift subst n a in subst 0 (*s Generalized substitution. [gen_subst v d t] applies to [t] the substitution coded in the [v] array: [(Rel i)] becomes [v.(i-1)]. [d] is the correction applies to [Rel] greater than [Array.length v]. *) let gen_subst v d t = let rec subst n = function | MLrel i as a -> let i'= i-n in if i' < 1 then a else if i' <= Array.length v then match v.(i'-1) with | None -> MLexn ("UNBOUND " ^ string_of_int i') | Some u -> ast_lift n u else MLrel (i+d) | a -> ast_map_lift subst n a in subst 0 t (*S Operations concerning match patterns *) let is_basic_pattern = function | Prel _ | Pwild -> true | Pusual _ | Pcons _ | Ptuple _ -> false let has_deep_pattern br = let deep = function | Pcons (_,l) | Ptuple l -> not (List.for_all is_basic_pattern l) | Pusual _ | Prel _ | Pwild -> false in array_exists (function (_,pat,_) -> deep pat) br let is_regular_match br = if Array.length br = 0 then false (* empty match becomes MLexn *) else try let get_r (ids,pat,c) = match pat with | Pusual r -> r | Pcons (r,l) -> if not (list_for_all_i (fun i -> (=) (Prel i)) 1 (List.rev l)) then raise Impossible; r | _ -> raise Impossible in let ind = match get_r br.(0) with | ConstructRef (ind,_) -> ind | _ -> raise Impossible in array_for_all_i (fun i tr -> get_r tr = ConstructRef (ind,i+1)) 0 br with Impossible -> false (*S Operations concerning lambdas. *) (*s [collect_lams MLlam(id1,...MLlam(idn,t)...)] returns [[idn;...;id1]] and the term [t]. *) let collect_lams = let rec collect acc = function | MLlam(id,t) -> collect (id::acc) t | x -> acc,x in collect [] (*s [collect_n_lams] does the same for a precise number of [MLlam]. *) let collect_n_lams = let rec collect acc n t = if n = 0 then acc,t else match t with | MLlam(id,t) -> collect (id::acc) (n-1) t | _ -> assert false in collect [] (*s [remove_n_lams] just removes some [MLlam]. *) let rec remove_n_lams n t = if n = 0 then t else match t with | MLlam(_,t) -> remove_n_lams (n-1) t | _ -> assert false (*s [nb_lams] gives the number of head [MLlam]. *) let rec nb_lams = function | MLlam(_,t) -> succ (nb_lams t) | _ -> 0 (*s [named_lams] does the converse of [collect_lams]. *) let rec named_lams ids a = match ids with | [] -> a | id :: ids -> named_lams ids (MLlam (id,a)) (*s The same for a specific identifier (resp. anonymous, dummy) *) let rec many_lams id a = function | 0 -> a | n -> many_lams id (MLlam (id,a)) (pred n) let anonym_tmp_lams a n = many_lams (Tmp anonymous_name) a n let dummy_lams a n = many_lams Dummy a n (*s mixed according to a signature. *) let rec anonym_or_dummy_lams a = function | [] -> a | Keep :: s -> MLlam(anonymous, anonym_or_dummy_lams a s) | Kill _ :: s -> MLlam(Dummy, anonym_or_dummy_lams a s) (*S Operations concerning eta. *) (*s The following function creates [MLrel n;...;MLrel 1] *) let rec eta_args n = if n = 0 then [] else (MLrel n)::(eta_args (pred n)) (*s Same, but filtered by a signature. *) let rec eta_args_sign n = function | [] -> [] | Keep :: s -> (MLrel n) :: (eta_args_sign (n-1) s) | Kill _ :: s -> eta_args_sign (n-1) s (*s This one tests [MLrel (n+k); ... ;MLrel (1+k)] *) let rec test_eta_args_lift k n = function | [] -> n=0 | a :: q -> (a = (MLrel (k+n))) && (test_eta_args_lift k (pred n) q) (*s Computes an eta-reduction. *) let eta_red e = let ids,t = collect_lams e in let n = List.length ids in if n = 0 then e else match t with | MLapp (f,a) -> let m = List.length a in let ids,body,args = if m = n then [], f, a else if m < n then list_skipn m ids, f, a else (* m > n *) let a1,a2 = list_chop (m-n) a in [], MLapp (f,a1), a2 in let p = List.length args in if test_eta_args_lift 0 p args && not (ast_occurs_itvl 1 p body) then named_lams ids (ast_lift (-p) body) else e | _ -> e (*s Computes all head linear beta-reductions possible in [(t a)]. Non-linear head beta-redex become let-in. *) let rec linear_beta_red a t = match a,t with | [], _ -> t | a0::a, MLlam (id,t) -> (match nb_occur_match t with | 0 -> linear_beta_red a (ast_pop t) | 1 -> linear_beta_red a (ast_subst a0 t) | _ -> let a = List.map (ast_lift 1) a in MLletin (id, a0, linear_beta_red a t)) | _ -> MLapp (t, a) let rec tmp_head_lams = function | MLlam (id, t) -> MLlam (tmp_id id, tmp_head_lams t) | e -> e (*s Applies a substitution [s] of constants by their body, plus linear beta reductions at modified positions. Moreover, we mark some lambdas as suitable for later linear reduction (this helps the inlining of recursors). *) let rec ast_glob_subst s t = match t with | MLapp ((MLglob ((ConstRef kn) as refe)) as f, a) -> let a = List.map (fun e -> tmp_head_lams (ast_glob_subst s e)) a in (try linear_beta_red a (Refmap'.find refe s) with Not_found -> MLapp (f, a)) | MLglob ((ConstRef kn) as refe) -> (try Refmap'.find refe s with Not_found -> t) | _ -> ast_map (ast_glob_subst s) t (*S Auxiliary functions used in simplification of ML cases. *) (* Factorisation of some match branches into a common "x -> f x" branch may break types sometimes. Example: [type 'x a = A]. Then [let id = function A -> A] has type ['x a -> 'y a], which is incompatible with the type of [let id x = x]. We now check that the type arguments of the inductive are preserved by our transformation. TODO: this verification should be done someday modulo expansion of type definitions. *) (*s [branch_as_function b typ (l,p,c)] tries to see branch [c] as a function [f] applied to [MLcons(r,l)]. For that it transforms any [MLcons(r,l)] in [MLrel 1] and raises [Impossible] if any variable in [l] occurs outside such a [MLcons] *) let branch_as_fun typ (l,p,c) = let nargs = List.length l in let cons = match p with | Pusual r -> MLcons (typ, r, eta_args nargs) | Pcons (r,pl) -> let pat2rel = function Prel i -> MLrel i | _ -> raise Impossible in MLcons (typ, r, List.map pat2rel pl) | _ -> raise Impossible in let rec genrec n = function | MLrel i as c -> let i' = i-n in if i'<1 then c else if i'>nargs then MLrel (i-nargs+1) else raise Impossible | MLcons _ as cons' when cons' = ast_lift n cons -> MLrel (n+1) | a -> ast_map_lift genrec n a in genrec 0 c (*s [branch_as_cst (l,p,c)] tries to see branch [c] as a constant independent from the pattern [MLcons(r,l)]. For that is raises [Impossible] if any variable in [l] occurs in [c], and otherwise returns [c] lifted to appear like a function with one arg (for uniformity with [branch_as_fun]). NB: [MLcons(r,l)] might occur nonetheless in [c], but only when [l] is empty, i.e. when [r] is a constant constructor *) let branch_as_cst (l,_,c) = let n = List.length l in if ast_occurs_itvl 1 n c then raise Impossible; ast_lift (1-n) c (* A branch [MLcons(r,l)->c] can be seen at the same time as a function branch and a constant branch, either because: - [MLcons(r,l)] doesn't occur in [c]. For example : "A -> B" - this constructor is constant (i.e. [l] is empty). For example "A -> A" When searching for the best factorisation below, we'll try both. *) (* The following structure allows to record which element occurred at what position, and then finally return the most frequent element and its positions. *) let census_add, census_max, census_clean = let h = Hashtbl.create 13 in let clear () = Hashtbl.clear h in let add e i = let s = try Hashtbl.find h e with Not_found -> Intset.empty in Hashtbl.replace h e (Intset.add i s) in let max e0 = let len = ref 0 and lst = ref Intset.empty and elm = ref e0 in Hashtbl.iter (fun e s -> let n = Intset.cardinal s in if n > !len then begin len := n; lst := s; elm := e end) h; (!elm,!lst) in (add,max,clear) (* [factor_branches] return the longest possible list of branches that have the same factorization, either as a function or as a constant. *) let is_opt_pat (_,p,_) = match p with | Prel _ | Pwild -> true | _ -> false let factor_branches o typ br = if array_exists is_opt_pat br then None (* already optimized *) else begin census_clean (); for i = 0 to Array.length br - 1 do if o.opt_case_idr then (try census_add (branch_as_fun typ br.(i)) i with Impossible -> ()); if o.opt_case_cst then (try census_add (branch_as_cst br.(i)) i with Impossible -> ()); done; let br_factor, br_set = census_max MLdummy in census_clean (); let n = Intset.cardinal br_set in if n = 0 then None else if Array.length br >= 2 && n < 2 then None else Some (br_factor, br_set) end (*s If all branches are functions, try to permut the case and the functions. *) let rec merge_ids ids ids' = match ids,ids' with | [],l -> l | l,[] -> l | i::ids, i'::ids' -> (if i = Dummy then i' else i) :: (merge_ids ids ids') let is_exn = function MLexn _ -> true | _ -> false let rec permut_case_fun br acc = let nb = ref max_int in Array.iter (fun (_,_,t) -> let ids, c = collect_lams t in let n = List.length ids in if (n < !nb) && (not (is_exn c)) then nb := n) br; if !nb = max_int || !nb = 0 then ([],br) else begin let br = Array.copy br in let ids = ref [] in for i = 0 to Array.length br - 1 do let (l,p,t) = br.(i) in let local_nb = nb_lams t in if local_nb < !nb then (* t = MLexn ... *) br.(i) <- (l,p,remove_n_lams local_nb t) else begin let local_ids,t = collect_n_lams !nb t in ids := merge_ids !ids local_ids; br.(i) <- (l,p,permut_rels !nb (List.length l) t) end done; (!ids,br) end (*S Generalized iota-reduction. *) (* Definition of a generalized iota-redex: it's a [MLcase(e,br)] where the head [e] is a [MLcons] or made of [MLcase]'s with [MLcons] as leaf branches. A generalized iota-redex is transformed into beta-redexes. *) (* In [iota_red], we try to simplify a [MLcase(_,MLcons(typ,r,a),br)]. Argument [i] is the branch we consider, we should lift what comes from [br] by [lift] *) let rec iota_red i lift br ((typ,r,a) as cons) = if i >= Array.length br then raise Impossible; let (ids,p,c) = br.(i) in match p with | Pusual r' | Pcons (r',_) when r'<>r -> iota_red (i+1) lift br cons | Pusual r' -> let c = named_lams (List.rev ids) c in let c = ast_lift lift c in MLapp (c,a) | Prel 1 when List.length ids = 1 -> let c = MLlam (List.hd ids, c) in let c = ast_lift lift c in MLapp(c,[MLcons(typ,r,a)]) | Pwild when ids = [] -> ast_lift lift c | _ -> raise Impossible (* TODO: handle some more cases *) (* [iota_gen] is an extension of [iota_red] where we allow to traverse matches in the head of the first match *) let iota_gen br hd = let rec iota k = function | MLcons (typ,r,a) -> iota_red 0 k br (typ,r,a) | MLcase(typ,e,br') -> let new_br = Array.map (fun (i,p,c)->(i,p,iota (k+(List.length i)) c)) br' in MLcase(typ,e,new_br) | _ -> raise Impossible in iota 0 hd let is_atomic = function | MLrel _ | MLglob _ | MLexn _ | MLdummy -> true | _ -> false let is_imm_apply = function MLapp (MLrel 1, _) -> true | _ -> false (** Program creates a let-in named "program_branch_NN" for each branch of match. Unfolding them leads to more natural code (and more dummy removal) *) let is_program_branch = function | Id id -> let s = string_of_id id in let br = "program_branch_" in let n = String.length br in (try ignore (int_of_string (String.sub s n (String.length s - n))); String.sub s 0 n = br with e when Errors.noncritical e -> false) | Tmp _ | Dummy -> false let expand_linear_let o id e = o.opt_lin_let || is_tmp id || is_program_branch id || is_imm_apply e (*S The main simplification function. *) (* Some beta-iota reductions + simplifications. *) let rec simpl o = function | MLapp (f, []) -> simpl o f | MLapp (f, a) -> simpl_app o (List.map (simpl o) a) (simpl o f) | MLcase (typ,e,br) -> let br = Array.map (fun (l,p,t) -> (l,p,simpl o t)) br in simpl_case o typ br (simpl o e) | MLletin(Dummy,_,e) -> simpl o (ast_pop e) | MLletin(id,c,e) -> let e = simpl o e in if (is_atomic c) || (is_atomic e) || (let n = nb_occur_match e in (n = 0 || (n=1 && expand_linear_let o id e))) then simpl o (ast_subst c e) else MLletin(id, simpl o c, e) | MLfix(i,ids,c) -> let n = Array.length ids in if ast_occurs_itvl 1 n c.(i) then MLfix (i, ids, Array.map (simpl o) c) else simpl o (ast_lift (-n) c.(i)) (* Dummy fixpoint *) | a -> ast_map (simpl o) a (* invariant : list [a] of arguments is non-empty *) and simpl_app o a = function | MLapp (f',a') -> simpl_app o (a'@a) f' | MLlam (Dummy,t) -> simpl o (MLapp (ast_pop t, List.tl a)) | MLlam (id,t) -> (* Beta redex *) (match nb_occur_match t with | 0 -> simpl o (MLapp (ast_pop t, List.tl a)) | 1 when (is_tmp id || o.opt_lin_beta) -> simpl o (MLapp (ast_subst (List.hd a) t, List.tl a)) | _ -> let a' = List.map (ast_lift 1) (List.tl a) in simpl o (MLletin (id, List.hd a, MLapp (t, a')))) | MLletin (id,e1,e2) when o.opt_let_app -> (* Application of a letin: we push arguments inside *) MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a))) | MLcase (typ,e,br) when o.opt_case_app -> (* Application of a case: we push arguments inside *) let br' = Array.map (fun (l,p,t) -> let k = List.length l in let a' = List.map (ast_lift k) a in (l, p, simpl o (MLapp (t,a')))) br in simpl o (MLcase (typ,e,br')) | (MLdummy | MLexn _) as e -> e (* We just discard arguments in those cases. *) | f -> MLapp (f,a) (* Invariant : all empty matches should now be [MLexn] *) and simpl_case o typ br e = try (* Generalized iota-redex *) if not o.opt_case_iot then raise Impossible; simpl o (iota_gen br e) with Impossible -> (* Swap the case and the lam if possible *) let ids,br = if o.opt_case_fun then permut_case_fun br [] else [],br in let n = List.length ids in if n <> 0 then simpl o (named_lams ids (MLcase (typ, ast_lift n e, br))) else (* Can we merge several branches as the same constant or function ? *) if lang() = Scheme || is_custom_match br then MLcase (typ, e, br) else match factor_branches o typ br with | Some (f,ints) when Intset.cardinal ints = Array.length br -> (* If all branches have been factorized, we remove the match *) simpl o (MLletin (Tmp anonymous_name, e, f)) | Some (f,ints) -> let last_br = if ast_occurs 1 f then ([Tmp anonymous_name], Prel 1, f) else ([], Pwild, ast_pop f) in let brl = Array.to_list br in let brl_opt = list_filter_i (fun i _ -> not (Intset.mem i ints)) brl in let brl_opt = brl_opt @ [last_br] in MLcase (typ, e, Array.of_list brl_opt) | None -> MLcase (typ, e, br) (*S Local prop elimination. *) (* We try to eliminate as many [prop] as possible inside an [ml_ast]. *) (*s In a list, it selects only the elements corresponding to a [Keep] in the boolean list [l]. *) let rec select_via_bl l args = match l,args with | [],_ -> args | Keep::l,a::args -> a :: (select_via_bl l args) | Kill _::l,a::args -> select_via_bl l args | _ -> assert false (*s [kill_some_lams] removes some head lambdas according to the signature [bl]. This list is build on the identifier list model: outermost lambda is on the right. [Rels] corresponding to removed lambdas are supposed not to occur, and the other [Rels] are made correct via a [gen_subst]. Output is not directly a [ml_ast], compose with [named_lams] if needed. *) let kill_some_lams bl (ids,c) = let n = List.length bl in let n' = List.fold_left (fun n b -> if b=Keep then (n+1) else n) 0 bl in if n = n' then ids,c else if n' = 0 then [],ast_lift (-n) c else begin let v = Array.make n None in let rec parse_ids i j = function | [] -> () | Keep :: l -> v.(i) <- Some (MLrel j); parse_ids (i+1) (j+1) l | Kill _ :: l -> parse_ids (i+1) j l in parse_ids 0 1 bl; select_via_bl bl ids, gen_subst v (n'-n) c end (*s [kill_dummy_lams] uses the last function to kill the lambdas corresponding to a [dummy_name]. It can raise [Impossible] if there is nothing to do, or if there is no lambda left at all. *) let kill_dummy_lams c = let ids,c = collect_lams c in let bl = List.map sign_of_id ids in if not (List.mem Keep bl) then raise Impossible; let rec fst_kill n = function | [] -> raise Impossible | Kill _ :: bl -> n | Keep :: bl -> fst_kill (n+1) bl in let skip = max 0 ((fst_kill 0 bl) - 1) in let ids_skip, ids = list_chop skip ids in let _, bl = list_chop skip bl in let c = named_lams ids_skip c in let ids',c = kill_some_lams bl (ids,c) in ids, named_lams ids' c (*s [eta_expansion_sign] takes a function [fun idn ... id1 -> c] and a signature [s] and builds a eta-long version. *) (* For example, if [s = [Keep;Keep;Kill Prop;Keep]] then the output is : [fun idn ... id1 x x _ x -> (c' 4 3 __ 1)] with [c' = lift 4 c] *) let eta_expansion_sign s (ids,c) = let rec abs ids rels i = function | [] -> let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels in ids, MLapp (ast_lift (i-1) c, a) | Keep :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l | Kill _ :: l -> abs (Dummy :: ids) (MLdummy :: rels) (i+1) l in abs ids [] 1 s (*s If [s = [b1; ... ; bn]] then [case_expunge] decomposes [e] in [n] lambdas (with eta-expansion if needed) and removes all dummy lambdas corresponding to [Del] in [s]. *) let case_expunge s e = let m = List.length s in let n = nb_lams e in let p = if m <= n then collect_n_lams m e else eta_expansion_sign (list_skipn n s) (collect_lams e) in kill_some_lams (List.rev s) p (*s [term_expunge] takes a function [fun idn ... id1 -> c] and a signature [s] and remove dummy lams. The difference with [case_expunge] is that we here leave one dummy lambda if all lambdas are logical dummy and the target language is strict. *) let term_expunge s (ids,c) = if s = [] then c else let ids,c = kill_some_lams (List.rev s) (ids,c) in if ids = [] && lang () <> Haskell && List.mem (Kill Kother) s then MLlam (Dummy, ast_lift 1 c) else named_lams ids c (*s [kill_dummy_args ids r t] looks for occurences of [MLrel r] in [t] and purge the args of [MLrel r] corresponding to a [dummy_name]. It makes eta-expansion if needed. *) let kill_dummy_args ids r t = let m = List.length ids in let bl = List.rev_map sign_of_id ids in let rec found n = function | MLrel r' when r' = r + n -> true | MLmagic e -> found n e | _ -> false in let rec killrec n = function | MLapp(e, a) when found n e -> let k = max 0 (m - (List.length a)) in let a = List.map (killrec n) a in let a = List.map (ast_lift k) a in let a = select_via_bl bl (a @ (eta_args k)) in named_lams (list_firstn k ids) (MLapp (ast_lift k e, a)) | e when found n e -> let a = select_via_bl bl (eta_args m) in named_lams ids (MLapp (ast_lift m e, a)) | e -> ast_map_lift killrec n e in killrec 0 t (*s The main function for local [dummy] elimination. *) let rec kill_dummy = function | MLfix(i,fi,c) -> (try let ids,c = kill_dummy_fix i c in ast_subst (MLfix (i,fi,c)) (kill_dummy_args ids 1 (MLrel 1)) with Impossible -> MLfix (i,fi,Array.map kill_dummy c)) | MLapp (MLfix (i,fi,c),a) -> let a = List.map kill_dummy a in (try let ids,c = kill_dummy_fix i c in let fake = MLapp (MLrel 1, List.map (ast_lift 1) a) in let fake' = kill_dummy_args ids 1 fake in ast_subst (MLfix (i,fi,c)) fake' with Impossible -> MLapp(MLfix(i,fi,Array.map kill_dummy c),a)) | MLletin(id, MLfix (i,fi,c),e) -> (try let ids,c = kill_dummy_fix i c in let e = kill_dummy (kill_dummy_args ids 1 e) in MLletin(id, MLfix(i,fi,c),e) with Impossible -> MLletin(id, MLfix(i,fi,Array.map kill_dummy c),kill_dummy e)) | MLletin(id,c,e) -> (try let ids,c = kill_dummy_lams (kill_dummy_hd c) in let e = kill_dummy (kill_dummy_args ids 1 e) in let c = kill_dummy c in if is_atomic c then ast_subst c e else MLletin (id, c, e) with Impossible -> MLletin(id,kill_dummy c,kill_dummy e)) | a -> ast_map kill_dummy a (* Similar function, but acting only on head lambdas and let-ins *) and kill_dummy_hd = function | MLlam(id,e) -> MLlam(id, kill_dummy_hd e) | MLletin(id,c,e) -> (try let ids,c = kill_dummy_lams (kill_dummy_hd c) in let e = kill_dummy_hd (kill_dummy_args ids 1 e) in let c = kill_dummy c in if is_atomic c then ast_subst c e else MLletin (id, c, e) with Impossible -> MLletin(id,kill_dummy c,kill_dummy_hd e)) | a -> a and kill_dummy_fix i c = let n = Array.length c in let ids,ci = kill_dummy_lams (kill_dummy_hd c.(i)) in let c = Array.copy c in c.(i) <- ci; for j = 0 to (n-1) do c.(j) <- kill_dummy (kill_dummy_args ids (n-i) c.(j)) done; ids,c (*s Putting things together. *) let normalize a = let o = optims () in let rec norm a = let a' = if o.opt_kill_dum then kill_dummy (simpl o a) else simpl o a in if a = a' then a else norm a' in norm a (*S Special treatment of fixpoint for pretty-printing purpose. *) let general_optimize_fix f ids n args m c = let v = Array.make n 0 in for i=0 to (n-1) do v.(i)<-i done; let aux i = function | MLrel j when v.(j-1)>=0 -> if ast_occurs (j+1) c then raise Impossible else v.(j-1)<-(-i-1) | _ -> raise Impossible in list_iter_i aux args; let args_f = List.rev_map (fun i -> MLrel (i+m+1)) (Array.to_list v) in let new_f = anonym_tmp_lams (MLapp (MLrel (n+m+1),args_f)) m in let new_c = named_lams ids (normalize (MLapp ((ast_subst new_f c),args))) in MLfix(0,[|f|],[|new_c|]) let optimize_fix a = if not (optims()).opt_fix_fun then a else let ids,a' = collect_lams a in let n = List.length ids in if n = 0 then a else match a' with | MLfix(_,[|f|],[|c|]) -> let new_f = MLapp (MLrel (n+1),eta_args n) in let new_c = named_lams ids (normalize (ast_subst new_f c)) in MLfix(0,[|f|],[|new_c|]) | MLapp(a',args) -> let m = List.length args in (match a' with | MLfix(_,_,_) when (test_eta_args_lift 0 n args) && not (ast_occurs_itvl 1 m a') -> a' | MLfix(_,[|f|],[|c|]) -> (try general_optimize_fix f ids n args m c with Impossible -> a) | _ -> a) | _ -> a (*S Inlining. *) (* Utility functions used in the decision of inlining. *) let ml_size_branch size pv = Array.fold_left (fun a (_,_,t) -> a + size t) 0 pv let rec ml_size = function | MLapp(t,l) -> List.length l + ml_size t + ml_size_list l | MLlam(_,t) -> 1 + ml_size t | MLcons(_,_,l) | MLtuple l -> ml_size_list l | MLcase(_,t,pv) -> 1 + ml_size t + ml_size_branch ml_size pv | MLfix(_,_,f) -> ml_size_array f | MLletin (_,_,t) -> ml_size t | MLmagic t -> ml_size t | MLglob _ | MLrel _ | MLexn _ | MLdummy | MLaxiom -> 0 and ml_size_list l = List.fold_left (fun a t -> a + ml_size t) 0 l and ml_size_array a = Array.fold_left (fun a t -> a + ml_size t) 0 a let is_fix = function MLfix _ -> true | _ -> false (*s Strictness *) (* A variable is strict if the evaluation of the whole term implies the evaluation of this variable. Non-strict variables can be found behind Match, for example. Expanding a term [t] is a good idea when it begins by at least one non-strict lambda, since the corresponding argument to [t] might be unevaluated in the expanded code. *) exception Toplevel let lift n l = List.map ((+) n) l let pop n l = List.map (fun x -> if x<=n then raise Toplevel else x-n) l (* This function returns a list of de Bruijn indices of non-strict variables, or raises [Toplevel] if it has an internal non-strict variable. In fact, not all variables are checked for strictness, only the ones which de Bruijn index is in the candidates list [cand]. The flag [add] controls the behaviour when going through a lambda: should we add the corresponding variable to the candidates? We use this flag to check only the external lambdas, those that will correspond to arguments. *) let rec non_stricts add cand = function | MLlam (id,t) -> let cand = lift 1 cand in let cand = if add then 1::cand else cand in pop 1 (non_stricts add cand t) | MLrel n -> List.filter ((<>) n) cand | MLapp (t,l)-> let cand = non_stricts false cand t in List.fold_left (non_stricts false) cand l | MLcons (_,_,l) -> List.fold_left (non_stricts false) cand l | MLletin (_,t1,t2) -> let cand = non_stricts false cand t1 in pop 1 (non_stricts add (lift 1 cand) t2) | MLfix (_,i,f)-> let n = Array.length i in let cand = lift n cand in let cand = Array.fold_left (non_stricts false) cand f in pop n cand | MLcase (_,t,v) -> (* The only interesting case: for a variable to be non-strict, *) (* it is sufficient that it appears non-strict in at least one branch, *) (* so we make an union (in fact a merge). *) let cand = non_stricts false cand t in Array.fold_left (fun c (i,_,t)-> let n = List.length i in let cand = lift n cand in let cand = pop n (non_stricts add cand t) in Sort.merge (<=) cand c) [] v (* [merge] may duplicates some indices, but I don't mind. *) | MLmagic t -> non_stricts add cand t | _ -> cand (* The real test: we are looking for internal non-strict variables, so we start with no candidates, and the only positive answer is via the [Toplevel] exception. *) let is_not_strict t = try let _ = non_stricts true [] t in false with Toplevel -> true (*s Inlining decision *) (* [inline_test] answers the following question: If we could inline [t] (the user said nothing special), should we inline ? We expand small terms with at least one non-strict variable (i.e. a variable that may not be evaluated). Futhermore we don't expand fixpoints. Moreover, as mentionned by X. Leroy (bug #2241), inling a constant from inside an opaque module might break types. To avoid that, we require below that both [r] and its body are globally visible. This isn't fully satisfactory, since [r] might not be visible (functor), and anyway it might be interesting to inline [r] at least inside its own structure. But to be safe, we adopt this restriction for the moment. *) open Declarations let inline_test r t = if not (auto_inline ()) then false else let c = match r with ConstRef c -> c | _ -> assert false in let has_body = try constant_has_body (Global.lookup_constant c) with e when Errors.noncritical e -> false in has_body && (let t1 = eta_red t in let t2 = snd (collect_lams t1) in not (is_fix t2) && ml_size t < 12 && is_not_strict t) let con_of_string s = let null = empty_dirpath in match repr_dirpath (dirpath_of_string s) with | id :: d -> make_con (MPfile (make_dirpath d)) null (label_of_id id) | [] -> assert false let manual_inline_set = List.fold_right (fun x -> Cset_env.add (con_of_string x)) [ "Coq.Init.Wf.well_founded_induction_type"; "Coq.Init.Wf.well_founded_induction"; "Coq.Init.Wf.Acc_iter"; "Coq.Init.Wf.Fix_F"; "Coq.Init.Wf.Fix"; "Coq.Init.Datatypes.andb"; "Coq.Init.Datatypes.orb"; "Coq.Init.Logic.eq_rec_r"; "Coq.Init.Logic.eq_rect_r"; "Coq.Init.Specif.proj1_sig"; ] Cset_env.empty let manual_inline = function | ConstRef c -> Cset_env.mem c manual_inline_set | _ -> false (* If the user doesn't say he wants to keep [t], we inline in two cases: \begin{itemize} \item the user explicitly requests it \item [expansion_test] answers that the inlining is a good idea, and we are free to act (AutoInline is set) \end{itemize} *) let inline r t = not (to_keep r) (* The user DOES want to keep it *) && not (is_inline_custom r) && (to_inline r (* The user DOES want to inline it *) || (lang () <> Haskell && not (is_projection r) && (is_recursor r || manual_inline r || inline_test r t))) coq-8.4pl4/plugins/extraction/ExtrOcamlString.v0000644000175000017500000000267212326224777020757 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* char [ "(* If this appears, you're using Ascii internals. Please don't *) (fun (b0,b1,b2,b3,b4,b5,b6,b7) -> let f b i = if b then 1 lsl i else 0 in Char.chr (f b0 0 + f b1 1 + f b2 2 + f b3 3 + f b4 4 + f b5 5 + f b6 6 + f b7 7))" ] "(* If this appears, you're using Ascii internals. Please don't *) (fun f c -> let n = Char.code c in let h i = (n land (1 lsl i)) <> 0 in f (h 0) (h 1) (h 2) (h 3) (h 4) (h 5) (h 6) (h 7))". Extract Constant zero => "'\000'". Extract Constant one => "'\001'". Extract Constant shift => "fun b c -> Char.chr (((Char.code c) lsl 1) land 255 + if b then 1 else 0)". Extract Inlined Constant ascii_dec => "(=)". Extract Inductive string => "char list" [ "[]" "(::)" ]. (* Definition test := "ceci est un test"%string. Recursive Extraction test Ascii.zero Ascii.one. *) coq-8.4pl4/plugins/extraction/big.ml0000644000175000017500000001326312326224777016574 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 then fp z else fn (opp z) let compare_case e l g x y = let s = compare x y in if s = 0 then e else if s<0 then l else g let nat_rec fO fS = let rec loop acc n = if sign n <= 0 then acc else loop (fS acc) (pred n) in loop fO let positive_rec f2p1 f2p f1 = let rec loop n = if le n one then f1 else let (q,r) = quomod n two in if eq r zero then f2p (loop q) else f2p1 (loop q) in loop let z_rec fO fp fn = z_case (fun _ -> fO) fp fn coq-8.4pl4/plugins/extraction/haskell.ml0000644000175000017500000002734612326224777017465 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Idset.add (id_of_string s)) [ "case"; "class"; "data"; "default"; "deriving"; "do"; "else"; "if"; "import"; "in"; "infix"; "infixl"; "infixr"; "instance"; "let"; "module"; "newtype"; "of"; "then"; "type"; "where"; "_"; "__"; "as"; "qualified"; "hiding" ; "unit" ; "unsafeCoerce" ] Idset.empty let preamble mod_name used_modules usf = let pp_import mp = str ("import qualified "^ string_of_modfile mp ^"\n") in (if not usf.magic then mt () else str "{-# OPTIONS_GHC -cpp -fglasgow-exts #-}\n" ++ str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}\n\n") ++ str "module " ++ pr_upper_id mod_name ++ str " where" ++ fnl2 () ++ str "import qualified Prelude" ++ fnl () ++ prlist pp_import used_modules ++ fnl () ++ (if used_modules = [] then mt () else fnl ()) ++ (if not usf.magic then mt () else str "\ \nunsafeCoerce :: a -> b\ \n#ifdef __GLASGOW_HASKELL__\ \nimport qualified GHC.Base\ \nunsafeCoerce = GHC.Base.unsafeCoerce#\ \n#else\ \n-- HUGS\ \nimport qualified IOExts\ \nunsafeCoerce = IOExts.unsafeCoerce\ \n#endif" ++ fnl2 ()) ++ (if not usf.mldummy then mt () else str "__ :: any" ++ fnl () ++ str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ()) let pp_abst = function | [] -> (mt ()) | l -> (str "\\" ++ prlist_with_sep (fun () -> (str " ")) pr_id l ++ str " ->" ++ spc ()) (*s The pretty-printer for haskell syntax *) let pp_global k r = if is_inline_custom r then str (find_custom r) else str (Common.pp_global k r) (*s Pretty-printing of types. [par] is a boolean indicating whether parentheses are needed or not. *) let kn_sig = let specif = MPfile (dirpath_of_string "Coq.Init.Specif") in make_mind specif empty_dirpath (mk_label "sig") let rec pp_type par vl t = let rec pp_rec par = function | Tmeta _ | Tvar' _ -> assert false | Tvar i -> (try pr_id (List.nth vl (pred i)) with e when Errors.noncritical e -> (str "a" ++ int i)) | Tglob (r,[]) -> pp_global Type r | Tglob (IndRef(kn,0),l) when not (keep_singleton ()) && kn = mk_ind "Coq.Init.Specif" "sig" -> pp_type true vl (List.hd l) | Tglob (r,l) -> pp_par par (pp_global Type r ++ spc () ++ prlist_with_sep spc (pp_type true vl) l) | Tarr (t1,t2) -> pp_par par (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) | Tdummy _ -> str "()" | Tunknown -> str "()" | Taxiom -> str "() -- AXIOM TO BE REALIZED\n" in hov 0 (pp_rec par t) (*s Pretty-printing of expressions. [par] indicates whether parentheses are needed or not. [env] is the list of names for the de Bruijn variables. [args] is the list of collected arguments (already pretty-printed). *) let expr_needs_par = function | MLlam _ -> true | MLcase _ -> false (* now that we use the case ... of { ... } syntax *) | _ -> false let rec pp_expr par env args = let apply st = pp_apply st par args and apply2 st = pp_apply2 st par args in function | MLrel n -> let id = get_db_name n env in apply (pr_id id) | MLapp (f,args') -> let stl = List.map (pp_expr true env []) args' in pp_expr par env (stl @ args) f | MLlam _ as a -> let fl,a' = collect_lams a in let fl,env' = push_vars (List.map id_of_mlid fl) env in let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in apply2 st | MLletin (id,a1,a2) -> let i,env' = push_vars [id_of_mlid id] env in let pp_id = pr_id (List.hd i) and pp_a1 = pp_expr false env [] a1 and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in let pp_def = str "let {" ++ cut () ++ hov 1 (pp_id ++ str " = " ++ pp_a1 ++ str "}") in apply2 (hv 0 (hv 0 (hv 1 pp_def ++ spc () ++ str "in") ++ spc () ++ hov 0 pp_a2)) | MLglob r -> apply (pp_global Term r) | MLcons (_,r,a) as c -> assert (args=[]); begin match a with | _ when is_native_char c -> pp_native_char c | [] -> pp_global Cons r | [a] -> pp_par par (pp_global Cons r ++ spc () ++ pp_expr true env [] a) | _ -> pp_par par (pp_global Cons r ++ spc () ++ prlist_with_sep spc (pp_expr true env []) a) end | MLtuple l -> assert (args=[]); pp_boxed_tuple (pp_expr true env []) l | MLcase (_,t, pv) when is_custom_match pv -> if not (is_regular_match pv) then error "Cannot mix yet user-given match and general patterns."; let mkfun (ids,_,e) = if ids <> [] then named_lams (List.rev ids) e else dummy_lams (ast_lift 1 e) 1 in let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in let inner = str (find_custom_match pv) ++ fnl () ++ prvect pp_branch pv ++ pp_expr true env [] t in apply2 (hov 2 inner) | MLcase (typ,t,pv) -> apply2 (v 0 (str "case " ++ pp_expr false env [] t ++ str " of {" ++ fnl () ++ pp_pat env pv)) | MLfix (i,ids,defs) -> let ids',env' = push_vars (List.rev (Array.to_list ids)) env in pp_fix par env' i (Array.of_list (List.rev ids'),defs) args | MLexn s -> (* An [MLexn] may be applied, but I don't really care. *) pp_par par (str "Prelude.error" ++ spc () ++ qs s) | MLdummy -> str "__" (* An [MLdummy] may be applied, but I don't really care. *) | MLmagic a -> pp_apply (str "unsafeCoerce") par (pp_expr true env [] a :: args) | MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"") and pp_cons_pat par r ppl = pp_par par (pp_global Cons r ++ space_if (ppl<>[]) ++ prlist_with_sep spc identity ppl) and pp_gen_pat par ids env = function | Pcons (r,l) -> pp_cons_pat par r (List.map (pp_gen_pat true ids env) l) | Pusual r -> pp_cons_pat par r (List.map pr_id ids) | Ptuple l -> pp_boxed_tuple (pp_gen_pat false ids env) l | Pwild -> str "_" | Prel n -> pr_id (get_db_name n env) and pp_one_pat env (ids,p,t) = let ids',env' = push_vars (List.rev_map id_of_mlid ids) env in hov 2 (str " " ++ pp_gen_pat false (List.rev ids') env' p ++ str " ->" ++ spc () ++ pp_expr (expr_needs_par t) env' [] t) and pp_pat env pv = prvecti (fun i x -> pp_one_pat env pv.(i) ++ if i = Array.length pv - 1 then str "}" else (str ";" ++ fnl ())) pv (*s names of the functions ([ids]) are already pushed in [env], and passed here just for convenience. *) and pp_fix par env i (ids,bl) args = pp_par par (v 0 (v 1 (str "let {" ++ fnl () ++ prvect_with_sep (fun () -> str ";" ++ fnl ()) (fun (fi,ti) -> pp_function env (pr_id fi) ti) (array_map2 (fun a b -> a,b) ids bl) ++ str "}") ++ fnl () ++ str "in " ++ pp_apply (pr_id ids.(i)) false args)) and pp_function env f t = let bl,t' = collect_lams t in let bl,env' = push_vars (List.map id_of_mlid bl) env in (f ++ pr_binding (List.rev bl) ++ str " =" ++ fnl () ++ str " " ++ hov 2 (pp_expr false env' [] t')) (*s Pretty-printing of inductive types declaration. *) let pp_comment s = str "-- " ++ s ++ fnl () let pp_logical_ind packet = pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ pp_comment (str "with constructors : " ++ prvect_with_sep spc pr_id packet.ip_consnames) let pp_singleton kn packet = let l = rename_tvars keywords packet.ip_vars in let l' = List.rev l in hov 2 (str "type " ++ pp_global Type (IndRef (kn,0)) ++ spc () ++ prlist_with_sep spc pr_id l ++ (if l <> [] then str " " else mt ()) ++ str "=" ++ spc () ++ pp_type false l' (List.hd packet.ip_types.(0)) ++ fnl () ++ pp_comment (str "singleton inductive, whose constructor was " ++ pr_id packet.ip_consnames.(0))) let pp_one_ind ip pl cv = let pl = rename_tvars keywords pl in let pp_constructor (r,l) = (pp_global Cons r ++ match l with | [] -> (mt ()) | _ -> (str " " ++ prlist_with_sep (fun () -> (str " ")) (pp_type true pl) l)) in str (if Array.length cv = 0 then "type " else "data ") ++ pp_global Type (IndRef ip) ++ prlist_strict (fun id -> str " " ++ pr_lower_id id) pl ++ str " =" ++ if Array.length cv = 0 then str " () -- empty inductive" else (fnl () ++ str " " ++ v 0 (str " " ++ prvect_with_sep (fun () -> fnl () ++ str "| ") pp_constructor (Array.mapi (fun i c -> ConstructRef (ip,i+1),c) cv))) let rec pp_ind first kn i ind = if i >= Array.length ind.ind_packets then if first then mt () else fnl () else let ip = (kn,i) in let p = ind.ind_packets.(i) in if is_custom (IndRef (kn,i)) then pp_ind first kn (i+1) ind else if p.ip_logical then pp_logical_ind p ++ pp_ind first kn (i+1) ind else pp_one_ind ip p.ip_vars p.ip_types ++ fnl () ++ pp_ind false kn (i+1) ind (*s Pretty-printing of a declaration. *) let pp_decl = function | Dind (kn,i) when i.ind_kind = Singleton -> pp_singleton kn i.ind_packets.(0) ++ fnl () | Dind (kn,i) -> hov 0 (pp_ind true kn 0 i) | Dtype (r, l, t) -> if is_inline_custom r then mt () else let l = rename_tvars keywords l in let st = try let ids,s = find_type_custom r in prlist (fun id -> str (id^" ")) ids ++ str "=" ++ spc () ++ str s with Not_found -> prlist (fun id -> pr_id id ++ str " ") l ++ if t = Taxiom then str "= () -- AXIOM TO BE REALIZED\n" else str "=" ++ spc () ++ pp_type false l t in hov 2 (str "type " ++ pp_global Type r ++ spc () ++ st) ++ fnl2 () | Dfix (rv, defs, typs) -> let names = Array.map (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv in prvecti (fun i r -> let void = is_inline_custom r || (not (is_custom r) && defs.(i) = MLexn "UNUSED") in if void then mt () else names.(i) ++ str " :: " ++ pp_type false [] typs.(i) ++ fnl () ++ (if is_custom r then (names.(i) ++ str " = " ++ str (find_custom r)) else (pp_function (empty_env ()) names.(i) defs.(i))) ++ fnl2 ()) rv | Dterm (r, a, t) -> if is_inline_custom r then mt () else let e = pp_global Term r in e ++ str " :: " ++ pp_type false [] t ++ fnl () ++ if is_custom r then hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl2 ()) else hov 0 (pp_function (empty_env ()) e a ++ fnl2 ()) let rec pp_structure_elem = function | (l,SEdecl d) -> pp_decl d | (l,SEmodule m) -> pp_module_expr m.ml_mod_expr | (l,SEmodtype m) -> mt () (* for the moment we simply discard module type *) and pp_module_expr = function | MEstruct (mp,sel) -> prlist_strict pp_structure_elem sel | MEfunctor _ -> mt () (* for the moment we simply discard unapplied functors *) | MEident _ | MEapply _ -> assert false (* should be expansed in extract_env *) let pp_struct = let pp_sel (mp,sel) = push_visible mp []; let p = prlist_strict pp_structure_elem sel in pop_visible (); p in prlist_strict pp_sel let haskell_descr = { keywords = keywords; file_suffix = ".hs"; preamble = preamble; pp_struct = pp_struct; sig_suffix = None; sig_preamble = (fun _ _ _ -> mt ()); pp_sig = (fun _ -> mt ()); pp_decl = pp_decl; } coq-8.4pl4/plugins/extraction/ExtrOcamlNatBigInt.v0000644000175000017500000000514512326224777021326 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* "Big.big_int" [ "Big.zero" "Big.succ" ] "Big.nat_case". (** Efficient (but uncertified) versions for usual [nat] functions *) Extract Constant plus => "Big.add". Extract Constant mult => "Big.mult". Extract Constant pred => "fun n -> Big.max Big.zero (Big.pred n)". Extract Constant minus => "fun n m -> Big.max Big.zero (Big.sub n m)". Extract Constant max => "Big.max". Extract Constant min => "Big.min". (*Extract Constant nat_beq => "Big.eq".*) Extract Constant EqNat.beq_nat => "Big.eq". Extract Constant EqNat.eq_nat_decide => "Big.eq". Extract Constant Peano_dec.eq_nat_dec => "Big.eq". Extract Constant Compare_dec.nat_compare => "Big.compare_case Eq Lt Gt". Extract Constant Compare_dec.leb => "Big.le". Extract Constant Compare_dec.le_lt_dec => "Big.le". Extract Constant Compare_dec.lt_eq_lt_dec => "Big.compare_case (Some false) (Some true) None". Extract Constant Even.even_odd_dec => "fun n -> Big.sign (Big.mod n Big.two) = 0". Extract Constant Div2.div2 => "fun n -> Big.div n Big.two". Extract Inductive Euclid.diveucl => "(Big.big_int * Big.big_int)" [""]. Extract Constant Euclid.eucl_dev => "fun n m -> Big.quomod m n". Extract Constant Euclid.quotient => "fun n m -> Big.div m n". Extract Constant Euclid.modulo => "fun n m -> Big.modulo m n". (* Require Import Euclid. Definition test n m (H:m>0) := let (q,r,_,_) := eucl_dev m H n in nat_compare n (q*m+r). Extraction "/tmp/test.ml" test fact pred minus max min Div2.div2. *) coq-8.4pl4/plugins/extraction/ExtrOcamlNatInt.v0000644000175000017500000000645312326224777020707 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int [ "0" "Pervasives.succ" ] "(fun fO fS n -> if n=0 then fO () else fS (n-1))". (** Efficient (but uncertified) versions for usual [nat] functions *) Extract Constant plus => "(+)". Extract Constant pred => "fun n -> Pervasives.max 0 (n-1)". Extract Constant minus => "fun n m -> Pervasives.max 0 (n-m)". Extract Constant mult => "( * )". Extract Inlined Constant max => "Pervasives.max". Extract Inlined Constant min => "Pervasives.min". (*Extract Inlined Constant nat_beq => "(=)".*) Extract Inlined Constant EqNat.beq_nat => "(=)". Extract Inlined Constant EqNat.eq_nat_decide => "(=)". Extract Inlined Constant Peano_dec.eq_nat_dec => "(=)". Extract Constant Compare_dec.nat_compare => "fun n m -> if n=m then Eq else if n "(<=)". Extract Inlined Constant Compare_dec.le_lt_dec => "(<=)". Extract Constant Compare_dec.lt_eq_lt_dec => "fun n m -> if n>m then None else Some (n "fun n -> n mod 2 = 0". Extract Constant Div2.div2 => "fun n -> n/2". Extract Inductive Euclid.diveucl => "(int * int)" [ "" ]. Extract Constant Euclid.eucl_dev => "fun n m -> (m/n, m mod n)". Extract Constant Euclid.quotient => "fun n m -> m/n". Extract Constant Euclid.modulo => "fun n m -> m mod n". (* Definition test n m (H:m>0) := let (q,r,_,_) := eucl_dev m H n in nat_compare n (q*m+r). Recursive Extraction test fact. *) coq-8.4pl4/plugins/extraction/extraction.ml0000644000175000017500000011476012326224777020217 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* error_singleton_become_prop id let sort_of env c = try let polyprop = (lang() = Haskell) in Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast c) with SingletonInductiveBecomesProp id -> error_singleton_become_prop id (*S Generation of flags and signatures. *) (* The type [flag] gives us information about any Coq term: \begin{itemize} \item [TypeScheme] denotes a type scheme, that is something that will become a type after enough applications. More formally, a type scheme has type $(x_1:X_1)\ldots(x_n:X_n)s$ with [s = Set], [Prop] or [Type] \item [Default] denotes the other cases. It may be inexact after instanciation. For example [(X:Type)X] is [Default] and may give [Set] after instanciation, which is rather [TypeScheme] \item [Logic] denotes a term of sort [Prop], or a type scheme on sort [Prop] \item [Info] is the opposite. The same example [(X:Type)X] shows that an [Info] term might in fact be [Logic] later on. \end{itemize} *) type info = Logic | Info type scheme = TypeScheme | Default type flag = info * scheme (*s [flag_of_type] transforms a type [t] into a [flag]. Really important function. *) let rec flag_of_type env t = let t = whd_betadeltaiota env none t in match kind_of_term t with | Prod (x,t,c) -> flag_of_type (push_rel (x,None,t) env) c | Sort (Prop Null) -> (Logic,TypeScheme) | Sort _ -> (Info,TypeScheme) | _ -> if (sort_of env t) = InProp then (Logic,Default) else (Info,Default) (*s Two particular cases of [flag_of_type]. *) let is_default env t = (flag_of_type env t = (Info, Default)) exception NotDefault of kill_reason let check_default env t = match flag_of_type env t with | _,TypeScheme -> raise (NotDefault Ktype) | Logic,_ -> raise (NotDefault Kother) | _ -> () let is_info_scheme env t = (flag_of_type env t = (Info, TypeScheme)) (*s [type_sign] gernerates a signature aimed at treating a type application. *) let rec type_sign env c = match kind_of_term (whd_betadeltaiota env none c) with | Prod (n,t,d) -> (if is_info_scheme env t then Keep else Kill Kother) :: (type_sign (push_rel_assum (n,t) env) d) | _ -> [] let rec type_scheme_nb_args env c = match kind_of_term (whd_betadeltaiota env none c) with | Prod (n,t,d) -> let n = type_scheme_nb_args (push_rel_assum (n,t) env) d in if is_info_scheme env t then n+1 else n | _ -> 0 let _ = register_type_scheme_nb_args type_scheme_nb_args (*s [type_sign_vl] does the same, plus a type var list. *) let rec type_sign_vl env c = match kind_of_term (whd_betadeltaiota env none c) with | Prod (n,t,d) -> let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in if not (is_info_scheme env t) then Kill Kother::s, vl else Keep::s, (next_ident_away (id_of_name n) vl) :: vl | _ -> [],[] let rec nb_default_params env c = match kind_of_term (whd_betadeltaiota env none c) with | Prod (n,t,d) -> let n = nb_default_params (push_rel_assum (n,t) env) d in if is_default env t then n+1 else n | _ -> 0 (* Enriching a signature with implicit information *) let sign_with_implicits r s nb_params = let implicits = implicits_of_global r in let rec add_impl i = function | [] -> [] | sign::s -> let sign' = if sign = Keep && List.mem i implicits then Kill Kother else sign in sign' :: add_impl (succ i) s in add_impl (1+nb_params) s (* Enriching a exception message *) let rec handle_exn r n fn_name = function | MLexn s -> (try Scanf.sscanf s "UNBOUND %d" (fun i -> assert ((0 < i) && (i <= n)); MLexn ("IMPLICIT "^ msg_non_implicit r (n+1-i) (fn_name i))) with e when Errors.noncritical e -> MLexn s) | a -> ast_map (handle_exn r n fn_name) a (*S Management of type variable contexts. *) (* A De Bruijn variable context (db) is a context for translating Coq [Rel] into ML type [Tvar]. *) (*s From a type signature toward a type variable context (db). *) let db_from_sign s = let rec make i acc = function | [] -> acc | Keep :: l -> make (i+1) (i::acc) l | Kill _ :: l -> make i (0::acc) l in make 1 [] s (*s Create a type variable context from indications taken from an inductive type (see just below). *) let rec db_from_ind dbmap i = if i = 0 then [] else (try Intmap.find i dbmap with Not_found -> 0)::(db_from_ind dbmap (i-1)) (*s [parse_ind_args] builds a map: [i->j] iff the i-th Coq argument of a constructor corresponds to the j-th type var of the ML inductive. *) (* \begin{itemize} \item [si] : signature of the inductive \item [i] : counter of Coq args for [(I args)] \item [j] : counter of ML type vars \item [relmax] : total args number of the constructor \end{itemize} *) let parse_ind_args si args relmax = let rec parse i j = function | [] -> Intmap.empty | Kill _ :: s -> parse (i+1) j s | Keep :: s -> (match kind_of_term args.(i-1) with | Rel k -> Intmap.add (relmax+1-k) j (parse (i+1) (j+1) s) | _ -> parse (i+1) (j+1) s) in parse 1 1 si let oib_equal o1 o2 = id_ord o1.mind_typename o2.mind_typename = 0 && list_equal eq_rel_declaration o1.mind_arity_ctxt o2.mind_arity_ctxt && begin match o1.mind_arity, o2.mind_arity with | Monomorphic {mind_user_arity=c1; mind_sort=s1}, Monomorphic {mind_user_arity=c2; mind_sort=s2} -> eq_constr c1 c2 && s1 = s2 | ma1, ma2 -> ma1 = ma2 end && o1.mind_consnames = o2.mind_consnames let mib_equal m1 m2 = array_equal oib_equal m1.mind_packets m1.mind_packets && m1.mind_record = m2.mind_record && m1.mind_finite = m2.mind_finite && m1.mind_ntypes = m2.mind_ntypes && list_equal eq_named_declaration m1.mind_hyps m2.mind_hyps && m1.mind_nparams = m2.mind_nparams && m1.mind_nparams_rec = m2.mind_nparams_rec && list_equal eq_rel_declaration m1.mind_params_ctxt m2.mind_params_ctxt && m1.mind_constraints = m2.mind_constraints (*S Extraction of a type. *) (* [extract_type env db c args] is used to produce an ML type from the coq term [(c args)], which is supposed to be a Coq type. *) (* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *) (* [j] stands for the next ML type var. [j=0] means we do not generate ML type var anymore (in subterms for example). *) let rec extract_type env db j c args = match kind_of_term (whd_betaiotazeta Evd.empty c) with | App (d, args') -> (* We just accumulate the arguments. *) extract_type env db j d (Array.to_list args' @ args) | Lambda (_,_,d) -> (match args with | [] -> assert false (* A lambda cannot be a type. *) | a :: args -> extract_type env db j (subst1 a d) args) | Prod (n,t,d) -> assert (args = []); let env' = push_rel_assum (n,t) env in (match flag_of_type env t with | (Info, Default) -> (* Standard case: two [extract_type] ... *) let mld = extract_type env' (0::db) j d [] in (match expand env mld with | Tdummy d -> Tdummy d | _ -> Tarr (extract_type env db 0 t [], mld)) | (Info, TypeScheme) when j > 0 -> (* A new type var. *) let mld = extract_type env' (j::db) (j+1) d [] in (match expand env mld with | Tdummy d -> Tdummy d | _ -> Tarr (Tdummy Ktype, mld)) | _,lvl -> let mld = extract_type env' (0::db) j d [] in (match expand env mld with | Tdummy d -> Tdummy d | _ -> let reason = if lvl=TypeScheme then Ktype else Kother in Tarr (Tdummy reason, mld))) | Sort _ -> Tdummy Ktype (* The two logical cases. *) | _ when sort_of env (applist (c, args)) = InProp -> Tdummy Kother | Rel n -> (match lookup_rel n env with | (_,Some t,_) -> extract_type env db j (lift n t) args | _ -> (* Asks [db] a translation for [n]. *) if n > List.length db then Tunknown else let n' = List.nth db (n-1) in if n' = 0 then Tunknown else Tvar n') | Const kn -> let r = ConstRef kn in let cb = lookup_constant kn env in let typ = Typeops.type_of_constant_type env cb.const_type in (match flag_of_type env typ with | (Logic,_) -> assert false (* Cf. logical cases above *) | (Info, TypeScheme) -> let mlt = extract_type_app env db (r, type_sign env typ) args in (match cb.const_body with | Undef _ | OpaqueDef _ -> mlt | Def _ when is_custom r -> mlt | Def lbody -> let newc = applist (Declarations.force lbody, args) in let mlt' = extract_type env db j newc [] in (* ML type abbreviations interact badly with Coq *) (* reduction, so [mlt] and [mlt'] might be different: *) (* The more precise is [mlt'], extracted after reduction *) (* The shortest is [mlt], which use abbreviations *) (* If possible, we take [mlt], otherwise [mlt']. *) if expand env mlt = expand env mlt' then mlt else mlt') | (Info, Default) -> (* Not an ML type, for example [(c:forall X, X->X) Type nat] *) (match cb.const_body with | Undef _ | OpaqueDef _ -> Tunknown (* Brutal approx ... *) | Def lbody -> (* We try to reduce. *) let newc = applist (Declarations.force lbody, args) in extract_type env db j newc [])) | Ind (kn,i) -> let s = (extract_ind env kn).ind_packets.(i).ip_sign in extract_type_app env db (IndRef (kn,i),s) args | Case _ | Fix _ | CoFix _ -> Tunknown | _ -> assert false (*s Auxiliary function dealing with type application. Precondition: [r] is a type scheme represented by the signature [s], and is completely applied: [List.length args = List.length s]. *) and extract_type_app env db (r,s) args = let ml_args = List.fold_right (fun (b,c) a -> if b=Keep then let p = List.length (fst (splay_prod env none (type_of env c))) in let db = iterate (fun l -> 0 :: l) p db in (extract_type_scheme env db c p) :: a else a) (List.combine s args) [] in Tglob (r, ml_args) (*S Extraction of a type scheme. *) (* [extract_type_scheme env db c p] works on a Coq term [c] which is an informative type scheme. It means that [c] is not a Coq type, but will be when applied to sufficiently many arguments ([p] in fact). This function decomposes p lambdas, with eta-expansion if needed. *) (* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *) and extract_type_scheme env db c p = if p=0 then extract_type env db 0 c [] else let c = whd_betaiotazeta Evd.empty c in match kind_of_term c with | Lambda (n,t,d) -> extract_type_scheme (push_rel_assum (n,t) env) db d (p-1) | _ -> let rels = fst (splay_prod env none (type_of env c)) in let env = push_rels_assum rels env in let eta_args = List.rev_map mkRel (interval 1 p) in extract_type env db 0 (lift p c) eta_args (*S Extraction of an inductive type. *) and extract_ind env kn = (* kn is supposed to be in long form *) let mib = Environ.lookup_mind kn env in try (* For a same kn, we can get various bodies due to module substitutions. We hence check that the mib has not changed from recording time to retrieving time. Ideally we should also check the env. *) let (mib0,ml_ind) = lookup_ind kn in if not (mib_equal mib mib0) then raise Not_found; ml_ind with Not_found -> (* First, if this inductive is aliased via a Module, we process the original inductive if possible. When at toplevel of the monolithic case, we cannot do much (cf Vector and bug #2570) *) let equiv = if lang () <> Ocaml || (not (modular ()) && at_toplevel (mind_modpath kn)) || kn_ord (canonical_mind kn) (user_mind kn) = 0 then NoEquiv else begin ignore (extract_ind env (mind_of_kn (canonical_mind kn))); Equiv (canonical_mind kn) end in (* Everything concerning parameters. *) (* We do that first, since they are common to all the [mib]. *) let mip0 = mib.mind_packets.(0) in let npar = mib.mind_nparams in let epar = push_rel_context mib.mind_params_ctxt env in (* First pass: we store inductive signatures together with *) (* their type var list. *) let packets = Array.map (fun mip -> let b = snd (mind_arity mip) <> InProp in let ar = Inductive.type_of_inductive env (mib,mip) in let s,v = if b then type_sign_vl env ar else [],[] in let t = Array.make (Array.length mip.mind_nf_lc) [] in { ip_typename = mip.mind_typename; ip_consnames = mip.mind_consnames; ip_logical = (not b); ip_sign = s; ip_vars = v; ip_types = t }) mib.mind_packets in add_ind kn mib {ind_kind = Standard; ind_nparams = npar; ind_packets = packets; ind_equiv = equiv }; (* Second pass: we extract constructors *) for i = 0 to mib.mind_ntypes - 1 do let p = packets.(i) in if not p.ip_logical then let types = arities_of_constructors env (kn,i) in for j = 0 to Array.length types - 1 do let t = snd (decompose_prod_n npar types.(j)) in let prods,head = dest_prod epar t in let nprods = List.length prods in let args = match kind_of_term head with | App (f,args) -> args (* [kind_of_term f = Ind ip] *) | _ -> [||] in let dbmap = parse_ind_args p.ip_sign args (nprods + npar) in let db = db_from_ind dbmap npar in p.ip_types.(j) <- extract_type_cons epar db dbmap t (npar+1) done done; (* Third pass: we determine special cases. *) let ind_info = try let ip = (kn, 0) in let r = IndRef ip in if is_custom r then raise (I Standard); if not mib.mind_finite then raise (I Coinductive); if mib.mind_ntypes <> 1 then raise (I Standard); let p = packets.(0) in if p.ip_logical then raise (I Standard); if Array.length p.ip_types <> 1 then raise (I Standard); let typ = p.ip_types.(0) in let l = List.filter (fun t -> not (isDummy (expand env t))) typ in if not (keep_singleton ()) && List.length l = 1 && not (type_mem_kn kn (List.hd l)) then raise (I Singleton); if l = [] then raise (I Standard); if not mib.mind_record then raise (I Standard); (* Now we're sure it's a record. *) (* First, we find its field names. *) let rec names_prod t = match kind_of_term t with | Prod(n,_,t) -> n::(names_prod t) | LetIn(_,_,_,t) -> names_prod t | Cast(t,_,_) -> names_prod t | _ -> [] in let field_names = list_skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in assert (List.length field_names = List.length typ); let projs = ref Cset.empty in let mp,d,_ = repr_mind kn in let rec select_fields l typs = match l,typs with | [],[] -> [] | _::l, typ::typs when isDummy (expand env typ) -> select_fields l typs | Anonymous::l, typ::typs -> None :: (select_fields l typs) | Name id::l, typ::typs -> let knp = make_con mp d (label_of_id id) in (* Is it safe to use [id] for projections [foo.id] ? *) if List.for_all ((=) Keep) (type2signature env typ) then projs := Cset.add knp !projs; Some (ConstRef knp) :: (select_fields l typs) | _ -> assert false in let field_glob = select_fields field_names typ in (* Is this record officially declared with its projections ? *) (* If so, we use this information. *) begin try let n = nb_default_params env (Inductive.type_of_inductive env (mib,mip0)) in let check_proj kn = if Cset.mem kn !projs then add_projection n kn in List.iter (Option.iter check_proj) (lookup_projections ip) with Not_found -> () end; Record field_glob with (I info) -> info in let i = {ind_kind = ind_info; ind_nparams = npar; ind_packets = packets; ind_equiv = equiv } in add_ind kn mib i; add_inductive_kind kn i.ind_kind; i (*s [extract_type_cons] extracts the type of an inductive constructor toward the corresponding list of ML types. - [db] is a context for translating Coq [Rel] into ML type [Tvar] - [dbmap] is a translation map (produced by a call to [parse_in_args]) - [i] is the rank of the current product (initially [params_nb+1]) *) and extract_type_cons env db dbmap c i = match kind_of_term (whd_betadeltaiota env none c) with | Prod (n,t,d) -> let env' = push_rel_assum (n,t) env in let db' = (try Intmap.find i dbmap with Not_found -> 0) :: db in let l = extract_type_cons env' db' dbmap d (i+1) in (extract_type env db 0 t []) :: l | _ -> [] (*s Recording the ML type abbreviation of a Coq type scheme constant. *) and mlt_env env r = match r with | ConstRef kn -> (try if not (visible_con kn) then raise Not_found; match lookup_term kn with | Dtype (_,vl,mlt) -> Some mlt | _ -> None with Not_found -> let cb = Environ.lookup_constant kn env in let typ = Typeops.type_of_constant_type env cb.const_type in match cb.const_body with | Undef _ | OpaqueDef _ -> None | Def l_body -> (match flag_of_type env typ with | Info,TypeScheme -> let body = Declarations.force l_body in let s,vl = type_sign_vl env typ in let db = db_from_sign s in let t = extract_type_scheme env db body (List.length s) in add_term kn (Dtype (r, vl, t)); Some t | _ -> None)) | _ -> None and expand env = type_expand (mlt_env env) and type2signature env = type_to_signature (mlt_env env) let type2sign env = type_to_sign (mlt_env env) let type_expunge env = type_expunge (mlt_env env) let type_expunge_from_sign env = type_expunge_from_sign (mlt_env env) (*s Extraction of the type of a constant. *) let record_constant_type env kn opt_typ = try if not (visible_con kn) then raise Not_found; lookup_type kn with Not_found -> let typ = match opt_typ with | None -> Typeops.type_of_constant env kn | Some typ -> typ in let mlt = extract_type env [] 1 typ [] in let schema = (type_maxvar mlt, mlt) in add_type kn schema; schema (*S Extraction of a term. *) (* Precondition: [(c args)] is not a type scheme, and is informative. *) (* [mle] is a ML environment [Mlenv.t]. *) (* [mlt] is the ML type we want our extraction of [(c args)] to have. *) let rec extract_term env mle mlt c args = match kind_of_term c with | App (f,a) -> extract_term env mle mlt f (Array.to_list a @ args) | Lambda (n, t, d) -> let id = id_of_name n in (match args with | a :: l -> (* We make as many [LetIn] as possible. *) let d' = mkLetIn (Name id,a,t,applistc d (List.map (lift 1) l)) in extract_term env mle mlt d' [] | [] -> let env' = push_rel_assum (Name id, t) env in let id, a = try check_default env t; Id id, new_meta() with NotDefault d -> Dummy, Tdummy d in let b = new_meta () in (* If [mlt] cannot be unified with an arrow type, then magic! *) let magic = needs_magic (mlt, Tarr (a, b)) in let d' = extract_term env' (Mlenv.push_type mle a) b d [] in put_magic_if magic (MLlam (id, d'))) | LetIn (n, c1, t1, c2) -> let id = id_of_name n in let env' = push_rel (Name id, Some c1, t1) env in (* We directly push the args inside the [LetIn]. TODO: the opt_let_app flag is supposed to prevent that *) let args' = List.map (lift 1) args in (try check_default env t1; let a = new_meta () in let c1' = extract_term env mle a c1 [] in (* The type of [c1'] is generalized and stored in [mle]. *) let mle' = if generalizable c1' then Mlenv.push_gen mle a else Mlenv.push_type mle a in MLletin (Id id, c1', extract_term env' mle' mlt c2 args') with NotDefault d -> let mle' = Mlenv.push_std_type mle (Tdummy d) in ast_pop (extract_term env' mle' mlt c2 args')) | Const kn -> extract_cst_app env mle mlt kn args | Construct cp -> extract_cons_app env mle mlt cp args | Rel n -> (* As soon as the expected [mlt] for the head is known, *) (* we unify it with an fresh copy of the stored type of [Rel n]. *) let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n) in extract_app env mle mlt extract_rel args | Case ({ci_ind=ip},_,c0,br) -> extract_app env mle mlt (extract_case env mle (ip,c0,br)) args | Fix ((_,i),recd) -> extract_app env mle mlt (extract_fix env mle i recd) args | CoFix (i,recd) -> extract_app env mle mlt (extract_fix env mle i recd) args | Cast (c,_,_) -> extract_term env mle mlt c args | Ind _ | Prod _ | Sort _ | Meta _ | Evar _ | Var _ -> assert false (*s [extract_maybe_term] is [extract_term] for usual terms, else [MLdummy] *) and extract_maybe_term env mle mlt c = try check_default env (type_of env c); extract_term env mle mlt c [] with NotDefault d -> put_magic (mlt, Tdummy d) MLdummy (*s Generic way to deal with an application. *) (* We first type all arguments starting with unknown meta types. This gives us the expected type of the head. Then we use the [mk_head] to produce the ML head from this type. *) and extract_app env mle mlt mk_head args = let metas = List.map new_meta args in let type_head = type_recomp (metas, mlt) in let mlargs = List.map2 (extract_maybe_term env mle) metas args in mlapp (mk_head type_head) mlargs (*s Auxiliary function used to extract arguments of constant or constructor. *) and make_mlargs env e s args typs = let rec f = function | [], [], _ -> [] | a::la, t::lt, [] -> extract_maybe_term env e t a :: (f (la,lt,[])) | a::la, t::lt, Keep::s -> extract_maybe_term env e t a :: (f (la,lt,s)) | _::la, _::lt, _::s -> f (la,lt,s) | _ -> assert false in f (args,typs,s) (*s Extraction of a constant applied to arguments. *) and extract_cst_app env mle mlt kn args = (* First, the [ml_schema] of the constant, in expanded version. *) let nb,t = record_constant_type env kn None in let schema = nb, expand env t in (* Can we instantiate types variables for this constant ? *) (* In Ocaml, inside the definition of this constant, the answer is no. *) let instantiated = if lang () = Ocaml && List.mem kn !current_fixpoints then var2var' (snd schema) else instantiation schema in (* Then the expected type of this constant. *) let a = new_meta () in (* We compare stored and expected types in two steps. *) (* First, can [kn] be applied to all args ? *) let metas = List.map new_meta args in let magic1 = needs_magic (type_recomp (metas, a), instantiated) in (* Second, is the resulting type compatible with the expected type [mlt] ? *) let magic2 = needs_magic (a, mlt) in (* The internal head receives a magic if [magic1] *) let head = put_magic_if magic1 (MLglob (ConstRef kn)) in (* Now, the extraction of the arguments. *) let s_full = type2signature env (snd schema) in let s_full = sign_with_implicits (ConstRef kn) s_full 0 in let s = sign_no_final_keeps s_full in let ls = List.length s in let la = List.length args in (* The ml arguments, already expunged from known logical ones *) let mla = make_mlargs env mle s args metas in let mla = if magic1 || lang () <> Ocaml then mla else try (* for better optimisations later, we discard dependent args of projections and replace them by fake args that will be removed during final pretty-print. *) let l,l' = list_chop (projection_arity (ConstRef kn)) mla in if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l' else mla with e when Errors.noncritical e -> mla in (* For strict languages, purely logical signatures with at least one [Kill Kother] lead to a dummy lam. So a [MLdummy] is left accordingly. *) let optdummy = match sign_kind s_full with | UnsafeLogicalSig when lang () <> Haskell -> [MLdummy] | _ -> [] in (* Different situations depending of the number of arguments: *) if la >= ls then (* Enough args, cleanup already done in [mla], we only add the additionnal dummy if needed. *) put_magic_if (magic2 && not magic1) (mlapp head (optdummy @ mla)) else (* Partially applied function with some logical arg missing. We complete via eta and expunge logical args. *) let ls' = ls-la in let s' = list_skipn la s in let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in let e = anonym_or_dummy_lams (mlapp head mla) s' in put_magic_if magic2 (remove_n_lams (List.length optdummy) e) (*s Extraction of an inductive constructor applied to arguments. *) (* \begin{itemize} \item In ML, contructor arguments are uncurryfied. \item We managed to suppress logical parts inside inductive definitions, but they must appears outside (for partial applications for instance) \item We also suppressed all Coq parameters to the inductives, since they are fixed, and thus are not used for the computation. \end{itemize} *) and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args = (* First, we build the type of the constructor, stored in small pieces. *) let mi = extract_ind env kn in let params_nb = mi.ind_nparams in let oi = mi.ind_packets.(i) in let nb_tvars = List.length oi.ip_vars and types = List.map (expand env) oi.ip_types.(j-1) in let list_tvar = List.map (fun i -> Tvar i) (interval 1 nb_tvars) in let type_cons = type_recomp (types, Tglob (IndRef ip, list_tvar)) in let type_cons = instantiation (nb_tvars, type_cons) in (* Then, the usual variables [s], [ls], [la], ... *) let s = List.map (type2sign env) types in let s = sign_with_implicits (ConstructRef cp) s params_nb in let ls = List.length s in let la = List.length args in assert (la <= ls + params_nb); let la' = max 0 (la - params_nb) in let args' = list_lastn la' args in (* Now, we build the expected type of the constructor *) let metas = List.map new_meta args' in (* If stored and expected types differ, then magic! *) let a = new_meta () in let magic1 = needs_magic (type_cons, type_recomp (metas, a)) in let magic2 = needs_magic (a, mlt) in let head mla = if mi.ind_kind = Singleton then put_magic_if magic1 (List.hd mla) (* assert (List.length mla = 1) *) else let typeargs = match snd (type_decomp type_cons) with | Tglob (_,l) -> List.map type_simpl l | _ -> assert false in let typ = Tglob(IndRef ip, typeargs) in put_magic_if magic1 (MLcons (typ, ConstructRef cp, mla)) in (* Different situations depending of the number of arguments: *) if la < params_nb then let head' = head (eta_args_sign ls s) in put_magic_if magic2 (dummy_lams (anonym_or_dummy_lams head' s) (params_nb - la)) else let mla = make_mlargs env mle s args' metas in if la = ls + params_nb then put_magic_if (magic2 && not magic1) (head mla) else (* [ params_nb <= la <= ls + params_nb ] *) let ls' = params_nb + ls - la in let s' = list_lastn ls' s in let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in put_magic_if magic2 (anonym_or_dummy_lams (head mla) s') (*S Extraction of a case. *) and extract_case env mle ((kn,i) as ip,c,br) mlt = (* [br]: bodies of each branch (in functional form) *) (* [ni]: number of arguments without parameters in each branch *) let ni = mis_constr_nargs_env env ip in let br_size = Array.length br in assert (Array.length ni = br_size); if br_size = 0 then begin add_recursors env kn; (* May have passed unseen if logical ... *) MLexn "absurd case" end else (* [c] has an inductive type, and is not a type scheme type. *) let t = type_of env c in (* The only non-informative case: [c] is of sort [Prop] *) if (sort_of env t) = InProp then begin add_recursors env kn; (* May have passed unseen if logical ... *) (* Logical singleton case: *) (* [match c with C i j k -> t] becomes [t'] *) assert (br_size = 1); let s = iterate (fun l -> Kill Kother :: l) ni.(0) [] in let mlt = iterate (fun t -> Tarr (Tdummy Kother, t)) ni.(0) mlt in let e = extract_maybe_term env mle mlt br.(0) in snd (case_expunge s e) end else let mi = extract_ind env kn in let oi = mi.ind_packets.(i) in let metas = Array.init (List.length oi.ip_vars) new_meta in (* The extraction of the head. *) let type_head = Tglob (IndRef ip, Array.to_list metas) in let a = extract_term env mle type_head c [] in (* The extraction of each branch. *) let extract_branch i = let r = ConstructRef (ip,i+1) in (* The types of the arguments of the corresponding constructor. *) let f t = type_subst_vect metas (expand env t) in let l = List.map f oi.ip_types.(i) in (* the corresponding signature *) let s = List.map (type2sign env) oi.ip_types.(i) in let s = sign_with_implicits r s mi.ind_nparams in (* Extraction of the branch (in functional form). *) let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in (* We suppress dummy arguments according to signature. *) let ids,e = case_expunge s e in let e' = handle_exn r (List.length s) (fun _ -> Anonymous) e in (List.rev ids, Pusual r, e') in if mi.ind_kind = Singleton then begin (* Informative singleton case: *) (* [match c with C i -> t] becomes [let i = c' in t'] *) assert (br_size = 1); let (ids,_,e') = extract_branch 0 in assert (List.length ids = 1); MLletin (tmp_id (List.hd ids),a,e') end else (* Standard case: we apply [extract_branch]. *) let typs = List.map type_simpl (Array.to_list metas) in let typ = Tglob (IndRef ip,typs) in MLcase (typ, a, Array.init br_size extract_branch) (*s Extraction of a (co)-fixpoint. *) and extract_fix env mle i (fi,ti,ci as recd) mlt = let env = push_rec_types recd env in let metas = Array.map new_meta fi in metas.(i) <- mlt; let mle = Array.fold_left Mlenv.push_type mle metas in let ei = array_map2 (extract_maybe_term env mle) metas ci in MLfix (i, Array.map id_of_name fi, ei) (*S ML declarations. *) (* [decomp_lams_eta env c t] finds the number [n] of products in the type [t], and decompose the term [c] in [n] lambdas, with eta-expansion if needed. *) let rec decomp_lams_eta_n n m env c t = let rels = fst (splay_prod_n env none n t) in let rels = List.map (fun (id,_,c) -> (id,c)) rels in let rels',c = decompose_lam c in let d = n - m in (* we'd better keep rels' as long as possible. *) let rels = (list_firstn d rels) @ rels' in let eta_args = List.rev_map mkRel (interval 1 d) in rels, applist (lift d c,eta_args) (* Let's try to identify some situation where extracted code will allow generalisation of type variables *) let rec gentypvar_ok c = match kind_of_term c with | Lambda _ | Const _ -> true | App (c,v) -> (* if all arguments are variables, these variables will disappear after extraction (see [empty_s] below) *) array_for_all isRel v && gentypvar_ok c | Cast (c,_,_) -> gentypvar_ok c | _ -> false (*s From a constant to a ML declaration. *) let extract_std_constant env kn body typ = reset_meta_count (); (* The short type [t] (i.e. possibly with abbreviations). *) let t = snd (record_constant_type env kn (Some typ)) in (* The real type [t']: without head products, expanded, *) (* and with [Tvar] translated to [Tvar'] (not instantiable). *) let l,t' = type_decomp (expand env (var2var' t)) in let s = List.map (type2sign env) l in (* Check for user-declared implicit information *) let s = sign_with_implicits (ConstRef kn) s 0 in (* Decomposing the top level lambdas of [body]. If there isn't enough, it's ok, as long as remaining args aren't to be pruned (and initial lambdas aren't to be all removed if the target language is strict). In other situations, eta-expansions create artificially enough lams (but that may break user's clever let-ins and partial applications). *) let rels, c = let n = List.length s and m = nb_lam body in if n <= m then decompose_lam_n n body else let s,s' = list_chop m s in if List.for_all ((=) Keep) s' && (lang () = Haskell || sign_kind s <> UnsafeLogicalSig) then decompose_lam_n m body else decomp_lams_eta_n n m env body typ in (* Should we do one eta-expansion to avoid non-generalizable '_a ? *) let rels, c = let n = List.length rels in let s,s' = list_chop n s in let k = sign_kind s in let empty_s = (k = EmptySig || k = SafeLogicalSig) in if lang () = Ocaml && empty_s && not (gentypvar_ok c) && s' <> [] && type_maxvar t <> 0 then decomp_lams_eta_n (n+1) n env body typ else rels,c in let n = List.length rels in let s = list_firstn n s in let l,l' = list_chop n l in let t' = type_recomp (l',t') in (* The initial ML environment. *) let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in (* The lambdas names. *) let ids = List.map (fun (n,_) -> Id (id_of_name n)) rels in (* The according Coq environment. *) let env = push_rels_assum rels env in (* The real extraction: *) let e = extract_term env mle t' c [] in (* Expunging term and type from dummy lambdas. *) let trm = term_expunge s (ids,e) in let trm = handle_exn (ConstRef kn) n (fun i -> fst (List.nth rels (i-1))) trm in trm, type_expunge_from_sign env s t (* Extracts the type of an axiom, honors the Extraction Implicit declaration. *) let extract_axiom env kn typ = reset_meta_count (); (* The short type [t] (i.e. possibly with abbreviations). *) let t = snd (record_constant_type env kn (Some typ)) in (* The real type [t']: without head products, expanded, *) (* and with [Tvar] translated to [Tvar'] (not instantiable). *) let l,_ = type_decomp (expand env (var2var' t)) in let s = List.map (type2sign env) l in (* Check for user-declared implicit information *) let s = sign_with_implicits (ConstRef kn) s 0 in type_expunge_from_sign env s t let extract_fixpoint env vkn (fi,ti,ci) = let n = Array.length vkn in let types = Array.make n (Tdummy Kother) and terms = Array.make n MLdummy in let kns = Array.to_list vkn in current_fixpoints := kns; (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *) let sub = List.rev_map mkConst kns in for i = 0 to n-1 do if sort_of env ti.(i) <> InProp then begin let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in terms.(i) <- e; types.(i) <- t; end done; current_fixpoints := []; Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types) let extract_constant env kn cb = let r = ConstRef kn in let typ = Typeops.type_of_constant_type env cb.const_type in let warn_info () = if not (is_custom r) then add_info_axiom r in let warn_log () = if not (constant_has_body cb) then add_log_axiom r in let mk_typ_ax () = let n = type_scheme_nb_args env typ in let ids = iterate (fun l -> anonymous_name::l) n [] in Dtype (r, ids, Taxiom) in let mk_typ c = let s,vl = type_sign_vl env typ in let db = db_from_sign s in let t = extract_type_scheme env db c (List.length s) in Dtype (r, vl, t) in let mk_ax () = let t = extract_axiom env kn typ in Dterm (r, MLaxiom, t) in let mk_def c = let e,t = extract_std_constant env kn c typ in Dterm (r,e,t) in match flag_of_type env typ with | (Logic,TypeScheme) -> warn_log (); Dtype (r, [], Tdummy Ktype) | (Logic,Default) -> warn_log (); Dterm (r, MLdummy, Tdummy Kother) | (Info,TypeScheme) -> (match cb.const_body with | Undef _ -> warn_info (); mk_typ_ax () | Def c -> mk_typ (force c) | OpaqueDef c -> add_opaque r; if access_opaque () then mk_typ (force_opaque c) else mk_typ_ax ()) | (Info,Default) -> (match cb.const_body with | Undef _ -> warn_info (); mk_ax () | Def c -> mk_def (force c) | OpaqueDef c -> add_opaque r; if access_opaque () then mk_def (force_opaque c) else mk_ax ()) let extract_constant_spec env kn cb = let r = ConstRef kn in let typ = Typeops.type_of_constant_type env cb.const_type in match flag_of_type env typ with | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype)) | (Logic, Default) -> Sval (r, Tdummy Kother) | (Info, TypeScheme) -> let s,vl = type_sign_vl env typ in (match cb.const_body with | Undef _ | OpaqueDef _ -> Stype (r, vl, None) | Def body -> let db = db_from_sign s in let t = extract_type_scheme env db (force body) (List.length s) in Stype (r, vl, Some t)) | (Info, Default) -> let t = snd (record_constant_type env kn (Some typ)) in Sval (r, type_expunge env t) let extract_with_type env cb = let typ = Typeops.type_of_constant_type env cb.const_type in match flag_of_type env typ with | (Info, TypeScheme) -> let s,vl = type_sign_vl env typ in let db = db_from_sign s in let c = match cb.const_body with | Def body -> force body (* A "with Definition ..." is necessarily transparent *) | Undef _ | OpaqueDef _ -> assert false in let t = extract_type_scheme env db c (List.length s) in Some (vl, t) | _ -> None let extract_inductive env kn = let ind = extract_ind env kn in add_recursors env kn; let f i j l = let implicits = implicits_of_global (ConstructRef ((kn,i),j+1)) in let rec filter i = function | [] -> [] | t::l -> let l' = filter (succ i) l in if isDummy (expand env t) || List.mem i implicits then l' else t::l' in filter (1+ind.ind_nparams) l in let packets = Array.mapi (fun i p -> { p with ip_types = Array.mapi (f i) p.ip_types }) ind.ind_packets in { ind with ind_packets = packets } (*s Is a [ml_decl] logical ? *) let logical_decl = function | Dterm (_,MLdummy,Tdummy _) -> true | Dtype (_,[],Tdummy _) -> true | Dfix (_,av,tv) -> (array_for_all ((=) MLdummy) av) && (array_for_all isDummy tv) | Dind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets | _ -> false (*s Is a [ml_spec] logical ? *) let logical_spec = function | Stype (_, [], Some (Tdummy _)) -> true | Sval (_,Tdummy _) -> true | Sind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets | _ -> false coq-8.4pl4/plugins/extraction/ExtrOcamlIntConv.v0000644000175000017500000000564112326224777021070 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int. Parameter int_opp : int -> int. Parameter int_twice : int -> int. Extract Inlined Constant int => int. Extract Inlined Constant int_zero => "0". Extract Inlined Constant int_succ => "succ". Extract Inlined Constant int_opp => "-". Extract Inlined Constant int_twice => "2 *". Definition int_of_nat : nat -> int := (fix loop acc n := match n with | O => acc | S n => loop (int_succ acc) n end) int_zero. Fixpoint int_of_pos p := match p with | xH => int_succ int_zero | xO p => int_twice (int_of_pos p) | xI p => int_succ (int_twice (int_of_pos p)) end. Fixpoint int_of_z z := match z with | Z0 => int_zero | Zpos p => int_of_pos p | Zneg p => int_opp (int_of_pos p) end. Fixpoint int_of_n n := match n with | N0 => int_zero | Npos p => int_of_pos p end. (** NB: as for [pred] or [minus], [nat_of_int], [n_of_int] and [pos_of_int] are total and return zero (resp. one) for non-positive inputs. *) Parameter int_natlike_rec : forall A, A -> (A->A) -> int -> A. Extract Constant int_natlike_rec => "fun fO fS -> let rec loop acc i = if i <= 0 then acc else loop (fS acc) (i-1) in loop fO". Definition nat_of_int : int -> nat := int_natlike_rec _ O S. Parameter int_poslike_rec : forall A, A -> (A->A) -> (A->A) -> int -> A. Extract Constant int_poslike_rec => "fun f1 f2x f2x1 -> let rec loop i = if i <= 1 then f1 else if i land 1 = 0 then f2x (loop (i lsr 1)) else f2x1 (loop (i lsr 1)) in loop". Definition pos_of_int : int -> positive := int_poslike_rec _ xH xO xI. Parameter int_zlike_case : forall A, A -> (int->A) -> (int->A) -> int -> A. Extract Constant int_zlike_case => "fun f0 fpos fneg i -> if i = 0 then f0 else if i>0 then fpos i else fneg (-i)". Definition z_of_int : int -> Z := int_zlike_case _ Z0 (fun i => Zpos (pos_of_int i)) (fun i => Zneg (pos_of_int i)). Definition n_of_int : int -> N := int_zlike_case _ N0 (fun i => Npos (pos_of_int i)) (fun _ => N0). (** Warning: [z_of_int] is currently wrong for Ocaml's [min_int], since [min_int] has no positive opposite ([-min_int = min_int]). *) (* Extraction "/tmp/test.ml" nat_of_int int_of_nat pos_of_int int_of_pos z_of_int int_of_z n_of_int int_of_n. *)coq-8.4pl4/plugins/extraction/scheme.ml0000644000175000017500000001550012326224777017273 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Idset.add (id_of_string s)) [ "define"; "let"; "lambda"; "lambdas"; "match"; "apply"; "car"; "cdr"; "error"; "delay"; "force"; "_"; "__"] Idset.empty let preamble _ _ usf = str ";; This extracted scheme code relies on some additional macros\n" ++ str ";; available at http://www.pps.jussieu.fr/~letouzey/scheme\n" ++ str "(load \"macros_extr.scm\")\n\n" ++ (if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ()) let pr_id id = let s = string_of_id id in for i = 0 to String.length s - 1 do if s.[i] = '\'' then s.[i] <- '~' done; str s let paren = pp_par true let pp_abst st = function | [] -> assert false | [id] -> paren (str "lambda " ++ paren (pr_id id) ++ spc () ++ st) | l -> paren (str "lambdas " ++ paren (prlist_with_sep spc pr_id l) ++ spc () ++ st) let pp_apply st _ = function | [] -> st | [a] -> hov 2 (paren (st ++ spc () ++ a)) | args -> hov 2 (paren (str "@ " ++ st ++ (prlist_strict (fun x -> spc () ++ x) args))) (*s The pretty-printer for Scheme syntax *) let pp_global k r = str (Common.pp_global k r) (*s Pretty-printing of expressions. *) let rec pp_expr env args = let apply st = pp_apply st true args in function | MLrel n -> let id = get_db_name n env in apply (pr_id id) | MLapp (f,args') -> let stl = List.map (pp_expr env []) args' in pp_expr env (stl @ args) f | MLlam _ as a -> let fl,a' = collect_lams a in let fl,env' = push_vars (List.map id_of_mlid fl) env in apply (pp_abst (pp_expr env' [] a') (List.rev fl)) | MLletin (id,a1,a2) -> let i,env' = push_vars [id_of_mlid id] env in apply (hv 0 (hov 2 (paren (str "let " ++ paren (paren (pr_id (List.hd i) ++ spc () ++ pp_expr env [] a1)) ++ spc () ++ hov 0 (pp_expr env' [] a2))))) | MLglob r -> apply (pp_global Term r) | MLcons (_,r,args') -> assert (args=[]); let st = str "`" ++ paren (pp_global Cons r ++ (if args' = [] then mt () else spc ()) ++ prlist_with_sep spc (pp_cons_args env) args') in if is_coinductive r then paren (str "delay " ++ st) else st | MLtuple _ -> error "Cannot handle tuples in Scheme yet." | MLcase (_,_,pv) when not (is_regular_match pv) -> error "Cannot handle general patterns in Scheme yet." | MLcase (_,t,pv) when is_custom_match pv -> let mkfun (ids,_,e) = if ids <> [] then named_lams (List.rev ids) e else dummy_lams (ast_lift 1 e) 1 in apply (paren (hov 2 (str (find_custom_match pv) ++ fnl () ++ prvect (fun tr -> pp_expr env [] (mkfun tr) ++ fnl ()) pv ++ pp_expr env [] t))) | MLcase (typ,t, pv) -> let e = if not (is_coinductive_type typ) then pp_expr env [] t else paren (str "force" ++ spc () ++ pp_expr env [] t) in apply (v 3 (paren (str "match " ++ e ++ fnl () ++ pp_pat env pv))) | MLfix (i,ids,defs) -> let ids',env' = push_vars (List.rev (Array.to_list ids)) env in pp_fix env' i (Array.of_list (List.rev ids'),defs) args | MLexn s -> (* An [MLexn] may be applied, but I don't really care. *) paren (str "error" ++ spc () ++ qs s) | MLdummy -> str "__" (* An [MLdummy] may be applied, but I don't really care. *) | MLmagic a -> pp_expr env args a | MLaxiom -> paren (str "error \"AXIOM TO BE REALIZED\"") and pp_cons_args env = function | MLcons (_,r,args) when is_coinductive r -> paren (pp_global Cons r ++ (if args = [] then mt () else spc ()) ++ prlist_with_sep spc (pp_cons_args env) args) | e -> str "," ++ pp_expr env [] e and pp_one_pat env (ids,p,t) = let r = match p with | Pusual r -> r | Pcons (r,l) -> r (* cf. the check [is_regular_match] above *) | _ -> assert false in let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in let args = if ids = [] then mt () else (str " " ++ prlist_with_sep spc pr_id (List.rev ids)) in (pp_global Cons r ++ args), (pp_expr env' [] t) and pp_pat env pv = prvect_with_sep fnl (fun x -> let s1,s2 = pp_one_pat env x in hov 2 (str "((" ++ s1 ++ str ")" ++ spc () ++ s2 ++ str ")")) pv (*s names of the functions ([ids]) are already pushed in [env], and passed here just for convenience. *) and pp_fix env j (ids,bl) args = paren (str "letrec " ++ (v 0 (paren (prvect_with_sep fnl (fun (fi,ti) -> paren ((pr_id fi) ++ spc () ++ (pp_expr env [] ti))) (array_map2 (fun id b -> (id,b)) ids bl)) ++ fnl () ++ hov 2 (pp_apply (pr_id (ids.(j))) true args)))) (*s Pretty-printing of a declaration. *) let pp_decl = function | Dind _ -> mt () | Dtype _ -> mt () | Dfix (rv, defs,_) -> let names = Array.map (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv in prvecti (fun i r -> let void = is_inline_custom r || (not (is_custom r) && defs.(i) = MLexn "UNUSED") in if void then mt () else hov 2 (paren (str "define " ++ names.(i) ++ spc () ++ (if is_custom r then str (find_custom r) else pp_expr (empty_env ()) [] defs.(i))) ++ fnl ()) ++ fnl ()) rv | Dterm (r, a, _) -> if is_inline_custom r then mt () else hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++ (if is_custom r then str (find_custom r) else pp_expr (empty_env ()) [] a))) ++ fnl2 () let rec pp_structure_elem = function | (l,SEdecl d) -> pp_decl d | (l,SEmodule m) -> pp_module_expr m.ml_mod_expr | (l,SEmodtype m) -> mt () (* for the moment we simply discard module type *) and pp_module_expr = function | MEstruct (mp,sel) -> prlist_strict pp_structure_elem sel | MEfunctor _ -> mt () (* for the moment we simply discard unapplied functors *) | MEident _ | MEapply _ -> assert false (* should be expansed in extract_env *) let pp_struct = let pp_sel (mp,sel) = push_visible mp []; let p = prlist_strict pp_structure_elem sel in pop_visible (); p in prlist_strict pp_sel let scheme_descr = { keywords = keywords; file_suffix = ".scm"; preamble = preamble; pp_struct = pp_struct; sig_suffix = None; sig_preamble = (fun _ _ _ -> mt ()); pp_sig = (fun _ -> mt ()); pp_decl = pp_decl; } coq-8.4pl4/plugins/extraction/ExtrOcamlBasic.v0000644000175000017500000000262712326224777020532 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool [ true false ]. Extract Inductive option => option [ Some None ]. Extract Inductive unit => unit [ "()" ]. Extract Inductive list => list [ "[]" "( :: )" ]. Extract Inductive prod => "( * )" [ "" ]. (** NB: The "" above is a hack, but produce nicer code than "(,)" *) (** Mapping sumbool to bool and sumor to option is not always nicer, but it helps when realizing stuff like [lt_eq_lt_dec] *) Extract Inductive sumbool => bool [ true false ]. Extract Inductive sumor => option [ Some None ]. (** Restore lazyness of andb, orb. NB: without these Extract Constant, andb/orb would be inlined by extraction in order to have lazyness, producing inelegant (if ... then ... else false) and (if ... then true else ...). *) Extract Inlined Constant andb => "(&&)". Extract Inlined Constant orb => "(||)". coq-8.4pl4/plugins/extraction/mlutil.mli0000644000175000017500000001022512326224777017505 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val new_meta : 'a -> ml_type val type_subst_list : ml_type list -> ml_type -> ml_type val type_subst_vect : ml_type array -> ml_type -> ml_type val instantiation : ml_schema -> ml_type val needs_magic : ml_type * ml_type -> bool val put_magic_if : bool -> ml_ast -> ml_ast val put_magic : ml_type * ml_type -> ml_ast -> ml_ast val generalizable : ml_ast -> bool (*s ML type environment. *) module Mlenv : sig type t val empty : t (* get the n-th more recently entered schema and instantiate it. *) val get : t -> int -> ml_type (* Adding a type in an environment, after generalizing free meta *) val push_gen : t -> ml_type -> t (* Adding a type with no [Tvar] *) val push_type : t -> ml_type -> t (* Adding a type with no [Tvar] nor [Tmeta] *) val push_std_type : t -> ml_type -> t end (*s Utility functions over ML types without meta *) val type_mem_kn : mutual_inductive -> ml_type -> bool val type_maxvar : ml_type -> int val type_decomp : ml_type -> ml_type list * ml_type val type_recomp : ml_type list * ml_type -> ml_type val var2var' : ml_type -> ml_type type abbrev_map = global_reference -> ml_type option val type_expand : abbrev_map -> ml_type -> ml_type val type_simpl : ml_type -> ml_type val type_to_sign : abbrev_map -> ml_type -> sign val type_to_signature : abbrev_map -> ml_type -> signature val type_expunge : abbrev_map -> ml_type -> ml_type val type_expunge_from_sign : abbrev_map -> signature -> ml_type -> ml_type val isDummy : ml_type -> bool val isKill : sign -> bool val case_expunge : signature -> ml_ast -> ml_ident list * ml_ast val term_expunge : signature -> ml_ident list * ml_ast -> ml_ast (*s Special identifiers. [dummy_name] is to be used for dead code and will be printed as [_] in concrete (Caml) code. *) val anonymous_name : identifier val dummy_name : identifier val id_of_name : name -> identifier val id_of_mlid : ml_ident -> identifier val tmp_id : ml_ident -> ml_ident (*s [collect_lambda MLlam(id1,...MLlam(idn,t)...)] returns the list [idn;...;id1] and the term [t]. *) val collect_lams : ml_ast -> ml_ident list * ml_ast val collect_n_lams : int -> ml_ast -> ml_ident list * ml_ast val remove_n_lams : int -> ml_ast -> ml_ast val nb_lams : ml_ast -> int val named_lams : ml_ident list -> ml_ast -> ml_ast val dummy_lams : ml_ast -> int -> ml_ast val anonym_or_dummy_lams : ml_ast -> signature -> ml_ast val eta_args_sign : int -> signature -> ml_ast list (*s Utility functions over ML terms. *) val mlapp : ml_ast -> ml_ast list -> ml_ast val ast_map : (ml_ast -> ml_ast) -> ml_ast -> ml_ast val ast_map_lift : (int -> ml_ast -> ml_ast) -> int -> ml_ast -> ml_ast val ast_iter : (ml_ast -> unit) -> ml_ast -> unit val ast_occurs : int -> ml_ast -> bool val ast_occurs_itvl : int -> int -> ml_ast -> bool val ast_lift : int -> ml_ast -> ml_ast val ast_pop : ml_ast -> ml_ast val ast_subst : ml_ast -> ml_ast -> ml_ast val ast_glob_subst : ml_ast Refmap'.t -> ml_ast -> ml_ast val normalize : ml_ast -> ml_ast val optimize_fix : ml_ast -> ml_ast val inline : global_reference -> ml_ast -> bool val is_basic_pattern : ml_pattern -> bool val has_deep_pattern : ml_branch array -> bool val is_regular_match : ml_branch array -> bool exception Impossible (* Classification of signatures *) type sign_kind = | EmptySig | NonLogicalSig (* at least a [Keep] *) | UnsafeLogicalSig (* No [Keep], at least a [Kill Kother] *) | SafeLogicalSig (* only [Kill Ktype] *) val sign_kind : signature -> sign_kind val sign_no_final_keeps : signature -> signature coq-8.4pl4/plugins/extraction/common.ml0000644000175000017500000004711312326224777017324 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | _ -> false (*s Some pretty-print utility functions. *) let pp_par par st = if par then str "(" ++ st ++ str ")" else st (** [pp_apply] : a head part applied to arguments, possibly with parenthesis *) let pp_apply st par args = match args with | [] -> st | _ -> hov 2 (pp_par par (st ++ spc () ++ prlist_with_sep spc identity args)) (** Same as [pp_apply], but with also protection of the head by parenthesis *) let pp_apply2 st par args = let par' = args <> [] || par in pp_apply (pp_par par' st) par args let pr_binding = function | [] -> mt () | l -> str " " ++ prlist_with_sep (fun () -> str " ") pr_id l let pp_tuple_light f = function | [] -> mt () | [x] -> f true x | l -> pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) (f false) l) let pp_tuple f = function | [] -> mt () | [x] -> f x | l -> pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) f l) let pp_boxed_tuple f = function | [] -> mt () | [x] -> f x | l -> pp_par true (hov 0 (prlist_with_sep (fun () -> str "," ++ spc ()) f l)) (** By default, in module Format, you can do horizontal placing of blocks even if they include newlines, as long as the number of chars in the blocks is less that a line length. To avoid this awkward situation, we attach a big virtual size to [fnl] newlines. *) let fnl () = stras (1000000,"") ++ fnl () let fnl2 () = fnl () ++ fnl () let space_if = function true -> str " " | false -> mt () let is_digit = function | '0'..'9' -> true | _ -> false let begins_with_CoqXX s = let n = String.length s in n >= 4 && s.[0] = 'C' && s.[1] = 'o' && s.[2] = 'q' && let i = ref 3 in try while !i < n do if s.[!i] = '_' then i:=n (*Stop*) else if is_digit s.[!i] then incr i else raise Not_found done; true with Not_found -> false let unquote s = if lang () <> Scheme then s else let s = String.copy s in for i=0 to String.length s - 1 do if s.[i] = '\'' then s.[i] <- '~' done; s let rec qualify delim = function | [] -> assert false | [s] -> s | ""::l -> qualify delim l | s::l -> s^delim^(qualify delim l) let dottify = qualify "." let pseudo_qualify = qualify "__" (*s Uppercase/lowercase renamings. *) let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false let lowercase_id id = id_of_string (String.uncapitalize (string_of_id id)) let uppercase_id id = let s = string_of_id id in assert (s<>""); if s.[0] = '_' then id_of_string ("Coq_"^s) else id_of_string (String.capitalize s) type kind = Term | Type | Cons | Mod let upperkind = function | Type -> lang () = Haskell | Term -> false | Cons | Mod -> true let kindcase_id k id = if upperkind k then uppercase_id id else lowercase_id id (*s de Bruijn environments for programs *) type env = identifier list * Idset.t (*s Generic renaming issues for local variable names. *) let rec rename_id id avoid = if Idset.mem id avoid then rename_id (lift_subscript id) avoid else id let rec rename_vars avoid = function | [] -> [], avoid | id :: idl when id == dummy_name -> (* we don't rename dummy binders *) let (idl', avoid') = rename_vars avoid idl in (id :: idl', avoid') | id :: idl -> let (idl, avoid) = rename_vars avoid idl in let id = rename_id (lowercase_id id) avoid in (id :: idl, Idset.add id avoid) let rename_tvars avoid l = let rec rename avoid = function | [] -> [],avoid | id :: idl -> let id = rename_id (lowercase_id id) avoid in let idl, avoid = rename (Idset.add id avoid) idl in (id :: idl, avoid) in fst (rename avoid l) let push_vars ids (db,avoid) = let ids',avoid' = rename_vars avoid ids in ids', (ids' @ db, avoid') let get_db_name n (db,_) = let id = List.nth db (pred n) in if id = dummy_name then id_of_string "__" else id (*S Renamings of global objects. *) (*s Tables of global renamings *) let register_cleanup, do_cleanup = let funs = ref [] in (fun f -> funs:=f::!funs), (fun () -> List.iter (fun f -> f ()) !funs) type phase = Pre | Impl | Intf let set_phase, get_phase = let ph = ref Impl in ((:=) ph), (fun () -> !ph) let set_keywords, get_keywords = let k = ref Idset.empty in ((:=) k), (fun () -> !k) let add_global_ids, get_global_ids = let ids = ref Idset.empty in register_cleanup (fun () -> ids := get_keywords ()); let add s = ids := Idset.add s !ids and get () = !ids in (add,get) let empty_env () = [], get_global_ids () let mktable autoclean = let h = Hashtbl.create 97 in if autoclean then register_cleanup (fun () -> Hashtbl.clear h); (Hashtbl.replace h, Hashtbl.find h, fun () -> Hashtbl.clear h) (* We might have built [global_reference] whose canonical part is inaccurate. We must hence compare only the user part, hence using a Hashtbl might be incorrect *) let mktable_ref autoclean = let m = ref Refmap'.empty in let clear () = m := Refmap'.empty in if autoclean then register_cleanup clear; (fun r v -> m := Refmap'.add r v !m), (fun r -> Refmap'.find r !m), clear (* A table recording objects in the first level of all MPfile *) let add_mpfiles_content,get_mpfiles_content,clear_mpfiles_content = mktable false let get_mpfiles_content mp = try get_mpfiles_content mp with Not_found -> failwith "get_mpfiles_content" (*s The list of external modules that will be opened initially *) let mpfiles_add, mpfiles_mem, mpfiles_list, mpfiles_clear = let m = ref MPset.empty in let add mp = m:=MPset.add mp !m and mem mp = MPset.mem mp !m and list () = MPset.elements !m and clear () = m:=MPset.empty in register_cleanup clear; (add,mem,list,clear) (*s List of module parameters that we should alpha-rename *) let params_ren_add, params_ren_mem = let m = ref MPset.empty in let add mp = m:=MPset.add mp !m and mem mp = MPset.mem mp !m and clear () = m:=MPset.empty in register_cleanup clear; (add,mem) (*s table indicating the visible horizon at a precise moment, i.e. the stack of structures we are inside. - The sequence of [mp] parts should have the following form: a [MPfile] at the beginning, and then more and more [MPdot] over this [MPfile], or [MPbound] when inside the type of a module parameter. - the [params] are the [MPbound] when [mp] is a functor, the innermost [MPbound] coming first in the list. - The [content] part is used to record all the names already seen at this level. *) type visible_layer = { mp : module_path; params : module_path list; content : ((kind*string),label) Hashtbl.t } let pop_visible, push_visible, get_visible = let vis = ref [] in register_cleanup (fun () -> vis := []); let pop () = match !vis with | [] -> assert false | v :: vl -> vis := vl; (* we save the 1st-level-content of MPfile for later use *) if get_phase () = Impl && modular () && is_modfile v.mp then add_mpfiles_content v.mp v.content and push mp mps = vis := { mp = mp; params = mps; content = Hashtbl.create 97 } :: !vis and get () = !vis in (pop,push,get) let get_visible_mps () = List.map (function v -> v.mp) (get_visible ()) let top_visible () = match get_visible () with [] -> assert false | v::_ -> v let top_visible_mp () = (top_visible ()).mp let add_visible ks l = Hashtbl.add (top_visible ()).content ks l (* table of local module wrappers used to provide non-ambiguous names *) let add_duplicate, check_duplicate = let index = ref 0 and dups = ref Gmap.empty in register_cleanup (fun () -> index := 0; dups := Gmap.empty); let add mp l = incr index; let ren = "Coq__" ^ string_of_int (!index) in dups := Gmap.add (mp,l) ren !dups and check mp l = Gmap.find (mp, l) !dups in (add,check) type reset_kind = AllButExternal | Everything let reset_renaming_tables flag = do_cleanup (); if flag = Everything then clear_mpfiles_content () (*S Renaming functions *) (* This function creates from [id] a correct uppercase/lowercase identifier. This is done by adding a [Coq_] or [coq_] prefix. To avoid potential clashes with previous [Coq_id] variable, these prefixes are duplicated if already existing. *) let modular_rename k id = let s = string_of_id id in let prefix,is_ok = if upperkind k then "Coq_",is_upper else "coq_",is_lower in if not (is_ok s) || (Idset.mem id (get_keywords ())) || (String.length s >= 4 && String.sub s 0 4 = prefix) then prefix ^ s else s (*s For monolithic extraction, first-level modules might have to be renamed with unique numbers *) let modfstlev_rename = let add_prefixes,get_prefixes,_ = mktable true in fun l -> let coqid = id_of_string "Coq" in let id = id_of_label l in try let coqset = get_prefixes id in let nextcoq = next_ident_away coqid coqset in add_prefixes id (nextcoq::coqset); (string_of_id nextcoq)^"_"^(string_of_id id) with Not_found -> let s = string_of_id id in if is_lower s || begins_with_CoqXX s then (add_prefixes id [coqid]; "Coq_"^s) else (add_prefixes id []; s) (*s Creating renaming for a [module_path] : first, the real function ... *) let rec mp_renaming_fun mp = match mp with | _ when not (modular ()) && at_toplevel mp -> [""] | MPdot (mp,l) -> let lmp = mp_renaming mp in if lmp = [""] then (modfstlev_rename l)::lmp else (modular_rename Mod (id_of_label l))::lmp | MPbound mbid -> let s = modular_rename Mod (id_of_mbid mbid) in if not (params_ren_mem mp) then [s] else let i,_,_ = repr_mbid mbid in [s^"__"^string_of_int i] | MPfile _ -> assert (modular ()); (* see [at_toplevel] above *) assert (get_phase () = Pre); let current_mpfile = (list_last (get_visible ())).mp in if mp <> current_mpfile then mpfiles_add mp; [string_of_modfile mp] (* ... and its version using a cache *) and mp_renaming = let add,get,_ = mktable true in fun x -> try if is_mp_bound (base_mp x) then raise Not_found; get x with Not_found -> let y = mp_renaming_fun x in add x y; y (*s Renamings creation for a [global_reference]: we build its fully-qualified name in a [string list] form (head is the short name). *) let ref_renaming_fun (k,r) = let mp = modpath_of_r r in let l = mp_renaming mp in let l = if lang () <> Ocaml && not (modular ()) then [""] else l in let s = let idg = safe_basename_of_global r in if l = [""] (* this happens only at toplevel of the monolithic case *) then let globs = Idset.elements (get_global_ids ()) in let id = next_ident_away (kindcase_id k idg) globs in string_of_id id else modular_rename k idg in add_global_ids (id_of_string s); s::l (* Cached version of the last function *) let ref_renaming = let add,get,_ = mktable_ref true in fun ((k,r) as x) -> try if is_mp_bound (base_mp (modpath_of_r r)) then raise Not_found; get r with Not_found -> let y = ref_renaming_fun x in add r y; y (* [visible_clash mp0 (k,s)] checks if [mp0-s] of kind [k] can be printed as [s] in the current context of visible modules. More precisely, we check if there exists a visible [mp] that contains [s]. The verification stops if we encounter [mp=mp0]. *) let rec clash mem mp0 ks = function | [] -> false | mp :: _ when mp = mp0 -> false | mp :: _ when mem mp ks -> true | _ :: mpl -> clash mem mp0 ks mpl let mpfiles_clash mp0 ks = clash (fun mp -> Hashtbl.mem (get_mpfiles_content mp)) mp0 ks (List.rev (mpfiles_list ())) let rec params_lookup mp0 ks = function | [] -> false | param :: _ when mp0 = param -> true | param :: params -> if ks = (Mod, List.hd (mp_renaming param)) then params_ren_add param; params_lookup mp0 ks params let visible_clash mp0 ks = let rec clash = function | [] -> false | v :: _ when v.mp = mp0 -> false | v :: vis -> let b = Hashtbl.mem v.content ks in if b && not (is_mp_bound mp0) then true else begin if b then params_ren_add mp0; if params_lookup mp0 ks v.params then false else clash vis end in clash (get_visible ()) (* Same, but with verbose output (and mp0 shouldn't be a MPbound) *) let visible_clash_dbg mp0 ks = let rec clash = function | [] -> None | v :: _ when v.mp = mp0 -> None | v :: vis -> try Some (v.mp,Hashtbl.find v.content ks) with Not_found -> if params_lookup mp0 ks v.params then None else clash vis in clash (get_visible ()) (* After the 1st pass, we can decide which modules will be opened initially *) let opened_libraries () = if not (modular ()) then [] else let used_files = mpfiles_list () in let used_ks = List.map (fun mp -> Mod,string_of_modfile mp) used_files in (* By default, we open all used files. Ambiguities will be resolved later by using qualified names. Nonetheless, we don't open any file A that contains an immediate submodule A.B hiding another file B : otherwise, after such an open, there's no unambiguous way to refer to objects of B. *) let to_open = List.filter (fun mp -> not (List.exists (Hashtbl.mem (get_mpfiles_content mp)) used_ks)) used_files in mpfiles_clear (); List.iter mpfiles_add to_open; mpfiles_list () (*s On-the-fly qualification issues for both monolithic or modular extraction. *) (* [pp_ocaml_gen] below is a function that factorize the printing of both [global_reference] and module names for ocaml. When [k=Mod] then [olab=None], otherwise it contains the label of the reference to print. [rls] is the string list giving the qualified name, short name at the end. *) (* In Coq, we can qualify [M.t] even if we are inside [M], but in Ocaml we cannot do that. So, if [t] gets hidden and we need a long name for it, we duplicate the _definition_ of t in a Coq__XXX module, and similarly for a sub-module [M.N] *) let pp_duplicate k' prefix mp rls olab = let rls', lbl = if k'<>Mod then (* Here rls=[s], the ref to print is ., and olab<>None *) rls, Option.get olab else (* Here rls=s::rls', we search the label for s inside mp *) List.tl rls, get_nth_label_mp (mp_length mp - mp_length prefix) mp in try dottify (check_duplicate prefix lbl :: rls') with Not_found -> assert (get_phase () = Pre); (* otherwise it's too late *) add_duplicate prefix lbl; dottify rls let fstlev_ks k = function | [] -> assert false | [s] -> k,s | s::_ -> Mod,s (* [pp_ocaml_local] : [mp] has something in common with [top_visible ()] but isn't equal to it *) let pp_ocaml_local k prefix mp rls olab = (* what is the largest prefix of [mp] that belongs to [visible]? *) assert (k <> Mod || mp <> prefix); (* mp as whole module isn't in itself *) let rls' = list_skipn (mp_length prefix) rls in let k's = fstlev_ks k rls' in (* Reference r / module path mp is of the form [.s.<...>]. *) if not (visible_clash prefix k's) then dottify rls' else pp_duplicate (fst k's) prefix mp rls' olab (* [pp_ocaml_bound] : [mp] starts with a [MPbound], and we are not inside (i.e. we are not printing the type of the module parameter) *) let pp_ocaml_bound base rls = (* clash with a MPbound will be detected and fixed by renaming this MPbound *) if get_phase () = Pre then ignore (visible_clash base (Mod,List.hd rls)); dottify rls (* [pp_ocaml_extern] : [mp] isn't local, it is defined in another [MPfile]. *) let pp_ocaml_extern k base rls = match rls with | [] -> assert false | base_s :: rls' -> if (not (modular ())) (* Pseudo qualification with "" *) || (rls' = []) (* Case of a file A.v used as a module later *) || (not (mpfiles_mem base)) (* Module not opened *) || (mpfiles_clash base (fstlev_ks k rls')) (* Conflict in opened files *) || (visible_clash base (fstlev_ks k rls')) (* Local conflict *) then (* We need to fully qualify. Last clash situation is unsupported *) match visible_clash_dbg base (Mod,base_s) with | None -> dottify rls | Some (mp,l) -> error_module_clash base (MPdot (mp,l)) else (* Standard situation : object in an opened file *) dottify rls' (* [pp_ocaml_gen] : choosing between [pp_ocaml_extern] or [pp_ocaml_extern] *) let pp_ocaml_gen k mp rls olab = match common_prefix_from_list mp (get_visible_mps ()) with | Some prefix -> pp_ocaml_local k prefix mp rls olab | None -> let base = base_mp mp in if is_mp_bound base then pp_ocaml_bound base rls else pp_ocaml_extern k base rls (* For Haskell, things are simplier: we have removed (almost) all structures *) let pp_haskell_gen k mp rls = match rls with | [] -> assert false | s::rls' -> let str = pseudo_qualify rls' in let str = if is_upper str && not (upperkind k) then ("_"^str) else str in let prf = if base_mp mp <> top_visible_mp () then s ^ "." else "" in prf ^ str (* Main name printing function for a reference *) let pp_global k r = let ls = ref_renaming (k,r) in assert (List.length ls > 1); let s = List.hd ls in let mp,_,l = repr_of_r r in if mp = top_visible_mp () then (* simpliest situation: definition of r (or use in the same context) *) (* we update the visible environment *) (add_visible (k,s) l; unquote s) else let rls = List.rev ls in (* for what come next it's easier this way *) match lang () with | Scheme -> unquote s (* no modular Scheme extraction... *) | Haskell -> if modular () then pp_haskell_gen k mp rls else s | Ocaml -> pp_ocaml_gen k mp rls (Some l) (* The next function is used only in Ocaml extraction...*) let pp_module mp = let ls = mp_renaming mp in match mp with | MPdot (mp0,l) when mp0 = top_visible_mp () -> (* simpliest situation: definition of mp (or use in the same context) *) (* we update the visible environment *) let s = List.hd ls in add_visible (Mod,s) l; s | _ -> pp_ocaml_gen Mod mp (List.rev ls) None (** Special hack for constants of type Ascii.ascii : if an [Extract Inductive ascii => char] has been declared, then the constants are directly turned into chars *) let mk_ind path s = make_mind (MPfile (dirpath_of_string path)) empty_dirpath (mk_label s) let ind_ascii = mk_ind "Coq.Strings.Ascii" "ascii" let check_extract_ascii () = try let char_type = match lang () with | Ocaml -> "char" | Haskell -> "Char" | _ -> raise Not_found in find_custom (IndRef (ind_ascii,0)) = char_type with Not_found -> false let is_list_cons l = List.for_all (function MLcons (_,ConstructRef(_,_),[]) -> true | _ -> false) l let is_native_char = function | MLcons(_,ConstructRef ((kn,0),1),l) -> kn = ind_ascii && check_extract_ascii () && is_list_cons l | _ -> false let pp_native_char c = let rec cumul = function | [] -> 0 | MLcons(_,ConstructRef(_,j),[])::l -> (2-j) + 2 * (cumul l) | _ -> assert false in let l = match c with MLcons(_,_,l) -> l | _ -> assert false in str ("'"^Char.escaped (Char.chr (cumul l))^"'") coq-8.4pl4/doc/0000755000175000017500000000000012365131026012363 5ustar stephstephcoq-8.4pl4/doc/Makefile.rt0000644000175000017500000000337212326224777014471 0ustar stephsteph# Makefile for building Coq Technical Reports # if coqc,coqtop,coq-tex are not in your PATH, you need the environment # variable COQBIN to be correctly set # (COQTOP is autodetected) # (some files are preprocessed using Coq and some part of the documentation # is automatically built from the theories sources) # To compile documentation, you need the following tools: # Dvi: latex (latex2e), bibtex, makeindex, dviselect (package RPM dviutils) # Ps: dvips, psutils (ftp://ftp.dcs.ed.ac.uk/pub/ajcd/psutils.tar.gz) # Pdf: pdflatex # Html: # - hevea: http://para.inria.fr/~maranget/hevea/ # - htmlSplit: http://coq.inria.fr/~delahaye # Rapports INRIA: dviselect, rrkit (par Michel Mauny) include ./Makefile ################### # RT ################### # Fabrication d'un RT INRIA (utilise rrkit de Michel Mauny) rt/Reference-Manual-RT.dvi: refman/Reference-Manual.dvi rt/RefMan-cover.tex dviselect -i refman/Reference-Manual.dvi -o rt/RefMan-body.dvi 3: (cd rt; $(LATEX) RefMan-cover.tex) set a=`tail -1 refman/Reference-Manual.log`;\ set a=expr \("$$a" : '.*(\(.*\) pages.*'\) % 2;\ (cd rt; if $(TEST) "$$a = 0";\ then rrkit RefMan-cover.dvi RefMan-body.dvi Reference-Manual-RT.dvi;\ else rrkit -odd RefMan-cover.dvi RefMan-body.dvi Reference-Manual-RT.dvi;\ fi) # Fabrication d'un RT INRIA (utilise rrkit de Michel Mauny) rt/Tutorial-RT.dvi : tutorial/Tutorial.v.dvi rt/Tutorial-cover.tex dviselect -i rt/Tutorial.v.dvi -o rt/Tutorial-body.dvi 3: (cd rt; $(LATEX) Tutorial-cover.tex) set a=`tail -1 tutorial/Tutorial.v.log`;\ set a=expr \("$$a" : '.*(\(.*\) pages.*'\) % 2;\ (cd rt; if $(TEST) "$$a = 0";\ then rrkit Tutorial-cover.dvi Tutorial-body.dvi Tutorial-RT.dvi;\ else rrkit -odd Tutorial-cover.dvi Tutorial-body.dvi Tutorial-RT.dvi;\ fi) coq-8.4pl4/doc/LICENSE0000644000175000017500000007724112326224777013420 0ustar stephstephThe Coq Reference Manual is a collective work from the Coq Development Team whose members are listed in the file CREDITS of the Coq source package. All related documents (the LaTeX and BibTeX sources, the embedded png files, and the PostScript, PDF and html outputs) are copyright (c) INRIA 1999-2006. The material connected to the Reference Manual may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at http://www.opencontent.org/openpub/). Options A and B are *not* elected. The Coq Tutorial is a work by Gérard Huet, Gilles Kahn and Christine Paulin-Mohring. All documents (the LaTeX source and the PostScript, PDF and html outputs) are copyright (c) INRIA 1999-2006. The material connected to the Coq Tutorial may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at http://www.opencontent.org/openpub/). Options A and B are *not* elected. The Coq Standard Library is a collective work from the Coq Development Team whose members are listed in the file CREDITS of the Coq source package. All related documents (the Coq vernacular source files and the PostScript, PDF and html outputs) are copyright (c) INRIA 1999-2006. The material connected to the Standard Library is distributed under the terms of the Lesser General Public License version 2.1 or later. The FAQ (Coq for the Clueless) is a work by Pierre Castéran, Hugo Herbelin, Florent Kirchner, Benjamin Monate, and Julien Narboux. All documents (the LaTeX source and the PostScript, PDF and html outputs) are copyright (c) INRIA 2004-2006. The material connected to the FAQ (Coq for the Clueless) may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at http://www.opencontent.org/openpub/). Options A and B are *not* elected. The Tutorial on [Co-]Inductive Types in Coq is a work by Pierre Castéran and Eduardo Gimenez. All related documents (the LaTeX and BibTeX sources and the PostScript, PDF and html outputs) are copyright (c) INRIA 1997-2006. The material connected to the Tutorial on [Co-]Inductive Types in Coq may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at http://www.opencontent.org/openpub/). Options A and B are *not* elected. ---------------------------------------------------------------------- *Open Publication License* v1.0, 8 June 1999 *I. REQUIREMENTS ON BOTH UNMODIFIED AND MODIFIED VERSIONS* The Open Publication works may be reproduced and distributed in whole or in part, in any medium physical or electronic, provided that the terms of this license are adhered to, and that this license or an incorporation of it by reference (with any options elected by the author(s) and/or publisher) is displayed in the reproduction. Proper form for an incorporation by reference is as follows: Copyright (c) by . This material may be distributed only subject to the terms and conditions set forth in the Open Publication License, vX.Y or later (the latest version is presently available at http://www.opencontent.org/openpub/). The reference must be immediately followed with any options elected by the author(s) and/or publisher of the document (see section VI). Commercial redistribution of Open Publication-licensed material is permitted. Any publication in standard (paper) book form shall require the citation of the original publisher and author. The publisher and author's names shall appear on all outer surfaces of the book. On all outer surfaces of the book the original publisher's name shall be as large as the title of the work and cited as possessive with respect to the title. *II. COPYRIGHT* The copyright to each Open Publication is owned by its author(s) or designee. *III. SCOPE OF LICENSE* The following license terms apply to all Open Publication works, unless otherwise explicitly stated in the document. Mere aggregation of Open Publication works or a portion of an Open Publication work with other works or programs on the same media shall not cause this license to apply to those other works. The aggregate work shall contain a notice specifying the inclusion of the Open Publication material and appropriate copyright notice. SEVERABILITY. If any part of this license is found to be unenforceable in any jurisdiction, the remaining portions of the license remain in force. NO WARRANTY. Open Publication works are licensed and provided "as is" without warranty of any kind, express or implied, including, but not limited to, the implied warranties of merchantability and fitness for a particular purpose or a warranty of non-infringement. *IV. REQUIREMENTS ON MODIFIED WORKS* All modified versions of documents covered by this license, including translations, anthologies, compilations and partial documents, must meet the following requirements: 1. The modified version must be labeled as such. 2. The person making the modifications must be identified and the modifications dated. 3. Acknowledgement of the original author and publisher if applicable must be retained according to normal academic citation practices. 4. The location of the original unmodified document must be identified. 5. The original author's (or authors') name(s) may not be used to assert or imply endorsement of the resulting document without the original author's (or authors') permission. *V. GOOD-PRACTICE RECOMMENDATIONS * In addition to the requirements of this license, it is requested from and strongly recommended of redistributors that: 1. If you are distributing Open Publication works on hardcopy or CD-ROM, you provide email notification to the authors of your intent to redistribute at least thirty days before your manuscript or media freeze, to give the authors time to provide updated documents. This notification should describe modifications, if any, made to the document. 2. All substantive modifications (including deletions) be either clearly marked up in the document or else described in an attachment to the document. 3. Finally, while it is not mandatory under this license, it is considered good form to offer a free copy of any hardcopy and CD-ROM expression of an Open Publication-licensed work to its author(s). *VI. LICENSE OPTIONS* The author(s) and/or publisher of an Open Publication-licensed document may elect certain options by appending language to the reference to or copy of the license. These options are considered part of the license instance and must be included with the license (or its incorporation by reference) in derived works. A. To prohibit distribution of substantively modified versions without the explicit permission of the author(s). "Substantive modification" is defined as a change to the semantic content of the document, and excludes mere changes in format or typographical corrections. To accomplish this, add the phrase `Distribution of substantively modified versions of this document is prohibited without the explicit permission of the copyright holder.' to the license reference or copy. B. To prohibit any publication of this work or derivative works in whole or in part in standard (paper) book form for commercial purposes is prohibited unless prior permission is obtained from the copyright holder. To accomplish this, add the phrase 'Distribution of the work or derivative of the work in any standard (paper) book form is prohibited unless prior permission is obtained from the copyright holder.' to the license reference or copy. ---------------------------------------------------------------------- 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 coq-8.4pl4/doc/stdlib/0000755000175000017500000000000012326224777013661 5ustar stephstephcoq-8.4pl4/doc/stdlib/hidden-files0000644000175000017500000000000012326224777016125 0ustar stephstephcoq-8.4pl4/doc/stdlib/Library.tex0000755000175000017500000000420112326224777016007 0ustar stephsteph\documentclass[11pt]{report} \usepackage[utf8x]{inputenc} \usepackage[T1]{fontenc} \usepackage{fullpage} \usepackage{amsfonts} \usepackage[color]{../../coqdoc} \input{../common/version} \input{../common/title} \input{../common/macros} \begin{document} \coverpage{The standard library}% {\ } {This material is distributed under the terms of the GNU Lesser General Public License Version 2.1.} \tableofcontents \newpage % \section*{The \Coq\ standard library} This document is a short description of the \Coq\ standard library. This library comes with the system as a complement of the core library (the {\bf Init} library ; see the Reference Manual for a description of this library). It provides a set of modules directly available through the \verb!Require! command. The standard library is composed of the following subdirectories: \begin{description} \item[Logic] Classical logic and dependent equality \item[Bool] Booleans (basic functions and results) \item[Arith] Basic Peano arithmetic \item[ZArith] Basic integer arithmetic \item[Reals] Classical Real Numbers and Analysis \item[Lists] Monomorphic and polymorphic lists (basic functions and results), Streams (infinite sequences defined with co-inductive types) \item[Sets] Sets (classical, constructive, finite, infinite, power set, etc.) \item[Relations] Relations (definitions and basic results). \item[Sorting] Sorted list (basic definitions and heapsort correctness). \item[Wellfounded] Well-founded relations (basic results). \item[Program] Tactics to deal with dependently-typed programs and their proofs. \item[Classes] Standard type class instances on relations and Coq part of the setoid rewriting tactic. \end{description} Each of these subdirectories contains a set of modules, whose specifications (\gallina{} files) have been roughly, and automatically, pasted in the following pages. There is also a version of this document in HTML format on the WWW, which you can access from the \Coq\ home page at \texttt{http://coq.inria.fr/library}. \input{Library.coqdoc} \end{document} coq-8.4pl4/doc/stdlib/make-library-index0000755000175000017500000000360212326224777017274 0ustar stephsteph#!/bin/sh # Instantiate links to library files in index template FILE=$1 HIDDEN=$2 cp -f $FILE.template tmp echo -n Building file index-list.prehtml ... #LIBDIRS="Init Logic Structures Bool Arith PArith NArith ZArith QArith Relations Sets Classes Setoids Lists Vectors Sorting Wellfounded MSets FSets Reals Program Numbers Numbers/Natural/Abstract Numbers/Natural/Peano Numbers/Natural/Binary Numbers/Natural/BigN Numbers/Natural/SpecViaZ Numbers/Integer/Abstract Numbers/Integer/NatPairs Numbers/Integer/Binary Numbers/Integer/SpecViaZ Numbers/Integer/BigZ Numbers/NatInt Numbers/Cyclic/Abstract Numbers/Cyclic/Int31 Numbers/Cyclic/ZModulo Numbers/Cyclic/DoubleCyclic Numbers/Rational/BigQ Numbers/Rational/SpecViaQ Strings" LIBDIRS=`find theories/* -type d | sed -e "s:^theories/::"` for k in $LIBDIRS; do i=theories/$k echo $i d=`basename $i` if [ "$d" != "CVS" ]; then ls $i | grep -q \.v'$' if [ $? = 0 ]; then for j in $i/*.v; do b=`basename $j .v` rm -f tmp2 grep -q theories/$k/$b.v tmp a=$? grep -q theories/$k/$b.v $HIDDEN h=$? if [ $a = 0 ]; then if [ $h = 0 ]; then echo Error: $FILE and $HIDDEN both mention theories/$k/$b.v; exit 1 else p=`echo $k | sed 's:/:.:g'` sed -e "s:theories/$k/$b.v:$b:g" tmp > tmp2 mv -f tmp2 tmp fi else if [ $h = 0 ]; then echo Error: theories/$k/$b.v is missing in the template file exit 1 else echo Error: none of $FILE and $HIDDEN mention theories/$k/$b.v exit 1 fi fi done fi fi rm -f tmp2 sed -e "s/#$d#//" tmp > tmp2 mv -f tmp2 tmp done a=`grep theories tmp` if [ $? = 0 ]; then echo Error: extra files:; echo $a; exit 1; fi mv tmp $FILE echo Done coq-8.4pl4/doc/stdlib/make-library-files0000755000175000017500000000234112326224777017266 0ustar stephsteph#!/bin/sh # Needs COQSRC and GALLINA set # On garde la liste de tous les *.v avec dates dans library.files.ls # Si elle a change depuis la derniere fois ou library.files n'existe pas # on fabrique des .g (si besoin) et la liste library.files dans # l'ordre de ls -tr des *.vo # Ce dernier trie les fichiers dans l'ordre inverse de leur date de création # En supposant que make fait son boulot, ca fait un tri topologique du # graphe des dépendances LIBDIRS="Arith PArith NArith ZArith Reals Logic Bool Lists Relations Sets Sorting Wellfounded Setoids Program Classes Numbers" rm -f library.files.ls.tmp (cd $COQSRC/theories; find $LIBDIR -name "*.v" -ls) > library.files.ls.tmp if ! test -e library.files || ! cmp library.files.ls library.files.ls.tmp; then mv -f library.files.ls.tmp library.files.ls rm -f library.files; touch library.files ABSOLUTE=`pwd`/library.files cd $COQSRC/theories echo $LIBDIRS for rep in $LIBDIRS ; do (cd $rep echo $rep/intro.tex >> $ABSOLUTE VOFILES=`ls -tr *.vo` for file in $VOFILES ; do VF=`basename $file \.vo` if [ \( ! -e $VF.g \) -o \( $VF.v -nt $VF.g \) ] ; then $GALLINA $VF.v fi echo $rep/$VF.g >> $ABSOLUTE done ) done fi coq-8.4pl4/doc/stdlib/index-list.html.template0000644000175000017500000004225512326224777020451 0ustar stephsteph

    The Coq Standard Library

    Here is a short description of the Coq standard library, which is distributed with the system. It provides a set of modules directly available through the Require Import command.

    The standard library is composed of the following subdirectories:

    Init: The core library (automatically loaded when starting Coq)
    theories/Init/Notations.v theories/Init/Datatypes.v theories/Init/Logic.v theories/Init/Logic_Type.v theories/Init/Peano.v theories/Init/Specif.v theories/Init/Tactics.v theories/Init/Wf.v (theories/Init/Prelude.v)
    Logic: Classical logic and dependent equality
    theories/Logic/SetIsType.v theories/Logic/Classical_Pred_Set.v theories/Logic/Classical_Pred_Type.v theories/Logic/Classical_Prop.v theories/Logic/Classical_Type.v (theories/Logic/Classical.v) theories/Logic/ClassicalFacts.v theories/Logic/Decidable.v theories/Logic/Eqdep_dec.v theories/Logic/EqdepFacts.v theories/Logic/Eqdep.v theories/Logic/JMeq.v theories/Logic/ChoiceFacts.v theories/Logic/RelationalChoice.v theories/Logic/ClassicalChoice.v theories/Logic/ClassicalDescription.v theories/Logic/ClassicalEpsilon.v theories/Logic/ClassicalUniqueChoice.v theories/Logic/Berardi.v theories/Logic/Diaconescu.v theories/Logic/Hurkens.v theories/Logic/ProofIrrelevance.v theories/Logic/ProofIrrelevanceFacts.v theories/Logic/ConstructiveEpsilon.v theories/Logic/Description.v theories/Logic/Epsilon.v theories/Logic/IndefiniteDescription.v theories/Logic/FunctionalExtensionality.v theories/Logic/ExtensionalityFacts.v
    Structures: Algebraic structures (types with equality, with order, ...). DecidableType* and OrderedType* are there only for compatibility.
    theories/Structures/Equalities.v theories/Structures/EqualitiesFacts.v theories/Structures/Orders.v theories/Structures/OrdersTac.v theories/Structures/OrdersAlt.v theories/Structures/OrdersEx.v theories/Structures/OrdersFacts.v theories/Structures/OrdersLists.v theories/Structures/GenericMinMax.v theories/Structures/DecidableType.v theories/Structures/DecidableTypeEx.v theories/Structures/OrderedType.v theories/Structures/OrderedTypeAlt.v theories/Structures/OrderedTypeEx.v
    Bool: Booleans (basic functions and results)
    theories/Bool/Bool.v theories/Bool/BoolEq.v theories/Bool/DecBool.v theories/Bool/IfProp.v theories/Bool/Sumbool.v theories/Bool/Zerob.v theories/Bool/Bvector.v
    Arith: Basic Peano arithmetic
    theories/Arith/Arith_base.v theories/Arith/Le.v theories/Arith/Lt.v theories/Arith/Plus.v theories/Arith/Minus.v theories/Arith/Mult.v theories/Arith/Gt.v theories/Arith/Between.v theories/Arith/Peano_dec.v theories/Arith/Compare_dec.v (theories/Arith/Arith.v) theories/Arith/Min.v theories/Arith/Max.v theories/Arith/Compare.v theories/Arith/Div2.v theories/Arith/EqNat.v theories/Arith/Euclid.v theories/Arith/Even.v theories/Arith/Bool_nat.v theories/Arith/Factorial.v theories/Arith/Wf_nat.v
    PArith: Binary positive integers
    theories/PArith/BinPosDef.v theories/PArith/BinPos.v theories/PArith/Pnat.v theories/PArith/POrderedType.v (theories/PArith/PArith.v)
    NArith: Binary natural numbers
    theories/NArith/BinNatDef.v theories/NArith/BinNat.v theories/NArith/Nnat.v theories/NArith/Ndigits.v theories/NArith/Ndist.v theories/NArith/Ndec.v theories/NArith/Ndiv_def.v theories/NArith/Ngcd_def.v theories/NArith/Nsqrt_def.v (theories/NArith/NArith.v)
    ZArith: Binary integers
    theories/ZArith/BinIntDef.v theories/ZArith/BinInt.v theories/ZArith/Zorder.v theories/ZArith/Zcompare.v theories/ZArith/Znat.v theories/ZArith/Zmin.v theories/ZArith/Zmax.v theories/ZArith/Zminmax.v theories/ZArith/Zabs.v theories/ZArith/Zeven.v theories/ZArith/auxiliary.v theories/ZArith/ZArith_dec.v theories/ZArith/Zbool.v theories/ZArith/Zmisc.v theories/ZArith/Wf_Z.v theories/ZArith/Zhints.v (theories/ZArith/ZArith_base.v) theories/ZArith/Zcomplements.v theories/ZArith/Zsqrt_compat.v theories/ZArith/Zpow_def.v theories/ZArith/Zpow_alt.v theories/ZArith/Zpower.v theories/ZArith/ZOdiv_def.v theories/ZArith/ZOdiv.v theories/ZArith/Zdiv.v theories/ZArith/Zquot.v theories/ZArith/Zeuclid.v theories/ZArith/Zlogarithm.v (theories/ZArith/ZArith.v) theories/ZArith/Zgcd_alt.v theories/ZArith/Zwf.v theories/ZArith/Znumtheory.v theories/ZArith/Int.v theories/ZArith/Zpow_facts.v theories/ZArith/Zdigits.v
    QArith: Rational numbers
    theories/QArith/QArith_base.v theories/QArith/Qabs.v theories/QArith/Qpower.v theories/QArith/Qreduction.v theories/QArith/Qring.v theories/QArith/Qfield.v (theories/QArith/QArith.v) theories/QArith/Qreals.v theories/QArith/Qcanon.v theories/QArith/Qround.v theories/QArith/QOrderedType.v theories/QArith/Qminmax.v
    Numbers: An experimental modular architecture for arithmetic
      Prelude:
    theories/Numbers/BinNums.v theories/Numbers/NumPrelude.v theories/Numbers/BigNumPrelude.v theories/Numbers/NaryFunctions.v
      NatInt: Abstract mixed natural/integer/cyclic arithmetic
    theories/Numbers/NatInt/NZAdd.v theories/Numbers/NatInt/NZAddOrder.v theories/Numbers/NatInt/NZAxioms.v theories/Numbers/NatInt/NZBase.v theories/Numbers/NatInt/NZMul.v theories/Numbers/NatInt/NZDiv.v theories/Numbers/NatInt/NZMulOrder.v theories/Numbers/NatInt/NZOrder.v theories/Numbers/NatInt/NZDomain.v theories/Numbers/NatInt/NZProperties.v theories/Numbers/NatInt/NZParity.v theories/Numbers/NatInt/NZPow.v theories/Numbers/NatInt/NZSqrt.v theories/Numbers/NatInt/NZLog.v theories/Numbers/NatInt/NZGcd.v theories/Numbers/NatInt/NZBits.v
      Cyclic: Abstract and 31-bits-based cyclic arithmetic
    theories/Numbers/Cyclic/Abstract/CyclicAxioms.v theories/Numbers/Cyclic/Abstract/NZCyclic.v theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v theories/Numbers/Cyclic/Int31/Cyclic31.v theories/Numbers/Cyclic/Int31/Ring31.v theories/Numbers/Cyclic/Int31/Int31.v theories/Numbers/Cyclic/ZModulo/ZModulo.v
      Natural: Abstract and 31-bits-words-based natural arithmetic
    theories/Numbers/Natural/Abstract/NAdd.v theories/Numbers/Natural/Abstract/NAddOrder.v theories/Numbers/Natural/Abstract/NAxioms.v theories/Numbers/Natural/Abstract/NBase.v theories/Numbers/Natural/Abstract/NDefOps.v theories/Numbers/Natural/Abstract/NIso.v theories/Numbers/Natural/Abstract/NMulOrder.v theories/Numbers/Natural/Abstract/NOrder.v theories/Numbers/Natural/Abstract/NStrongRec.v theories/Numbers/Natural/Abstract/NSub.v theories/Numbers/Natural/Abstract/NDiv.v theories/Numbers/Natural/Abstract/NMaxMin.v theories/Numbers/Natural/Abstract/NParity.v theories/Numbers/Natural/Abstract/NPow.v theories/Numbers/Natural/Abstract/NSqrt.v theories/Numbers/Natural/Abstract/NLog.v theories/Numbers/Natural/Abstract/NGcd.v theories/Numbers/Natural/Abstract/NLcm.v theories/Numbers/Natural/Abstract/NBits.v theories/Numbers/Natural/Abstract/NProperties.v theories/Numbers/Natural/Binary/NBinary.v theories/Numbers/Natural/Peano/NPeano.v theories/Numbers/Natural/SpecViaZ/NSig.v theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v theories/Numbers/Natural/BigN/BigN.v theories/Numbers/Natural/BigN/Nbasic.v theories/Numbers/Natural/BigN/NMake.v theories/Numbers/Natural/BigN/NMake_gen.v
      Integer: Abstract and concrete (especially 31-bits-words-based) integer arithmetic
    theories/Numbers/Integer/Abstract/ZAdd.v theories/Numbers/Integer/Abstract/ZAddOrder.v theories/Numbers/Integer/Abstract/ZAxioms.v theories/Numbers/Integer/Abstract/ZBase.v theories/Numbers/Integer/Abstract/ZLt.v theories/Numbers/Integer/Abstract/ZMul.v theories/Numbers/Integer/Abstract/ZMulOrder.v theories/Numbers/Integer/Abstract/ZSgnAbs.v theories/Numbers/Integer/Abstract/ZMaxMin.v theories/Numbers/Integer/Abstract/ZParity.v theories/Numbers/Integer/Abstract/ZPow.v theories/Numbers/Integer/Abstract/ZGcd.v theories/Numbers/Integer/Abstract/ZLcm.v theories/Numbers/Integer/Abstract/ZBits.v theories/Numbers/Integer/Abstract/ZProperties.v theories/Numbers/Integer/Abstract/ZDivEucl.v theories/Numbers/Integer/Abstract/ZDivFloor.v theories/Numbers/Integer/Abstract/ZDivTrunc.v theories/Numbers/Integer/Binary/ZBinary.v theories/Numbers/Integer/NatPairs/ZNatPairs.v theories/Numbers/Integer/SpecViaZ/ZSig.v theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v theories/Numbers/Integer/BigZ/BigZ.v theories/Numbers/Integer/BigZ/ZMake.v
      Rational: Abstract and 31-bits-words-based rational arithmetic
    theories/Numbers/Rational/SpecViaQ/QSig.v theories/Numbers/Rational/BigQ/BigQ.v theories/Numbers/Rational/BigQ/QMake.v
    Relations: Relations (definitions and basic results)
    theories/Relations/Relation_Definitions.v theories/Relations/Relation_Operators.v theories/Relations/Relations.v theories/Relations/Operators_Properties.v
    Sets: Sets (classical, constructive, finite, infinite, powerset, etc.)
    theories/Sets/Classical_sets.v theories/Sets/Constructive_sets.v theories/Sets/Cpo.v theories/Sets/Ensembles.v theories/Sets/Finite_sets_facts.v theories/Sets/Finite_sets.v theories/Sets/Image.v theories/Sets/Infinite_sets.v theories/Sets/Integers.v theories/Sets/Multiset.v theories/Sets/Partial_Order.v theories/Sets/Permut.v theories/Sets/Powerset_Classical_facts.v theories/Sets/Powerset_facts.v theories/Sets/Powerset.v theories/Sets/Relations_1_facts.v theories/Sets/Relations_1.v theories/Sets/Relations_2_facts.v theories/Sets/Relations_2.v theories/Sets/Relations_3_facts.v theories/Sets/Relations_3.v theories/Sets/Uniset.v
    Classes:
    theories/Classes/Init.v theories/Classes/RelationClasses.v theories/Classes/Morphisms.v theories/Classes/Morphisms_Prop.v theories/Classes/Morphisms_Relations.v theories/Classes/Equivalence.v theories/Classes/EquivDec.v theories/Classes/SetoidTactics.v theories/Classes/SetoidClass.v theories/Classes/SetoidDec.v theories/Classes/RelationPairs.v
    Setoids:
    theories/Setoids/Setoid.v
    Lists: Polymorphic lists, Streams (infinite sequences)
    theories/Lists/List.v theories/Lists/ListSet.v theories/Lists/SetoidList.v theories/Lists/SetoidPermutation.v theories/Lists/Streams.v theories/Lists/StreamMemo.v theories/Lists/ListTactics.v
    Vectors: Dependent datastructures storing their length
    theories/Vectors/Fin.v theories/Vectors/VectorDef.v theories/Vectors/VectorSpec.v (theories/Vectors/Vector.v)
    Sorting: Axiomatizations of sorts
    theories/Sorting/Heap.v theories/Sorting/Permutation.v theories/Sorting/Sorting.v theories/Sorting/PermutEq.v theories/Sorting/PermutSetoid.v theories/Sorting/Mergesort.v theories/Sorting/Sorted.v
    Wellfounded: Well-founded Relations
    theories/Wellfounded/Disjoint_Union.v theories/Wellfounded/Inclusion.v theories/Wellfounded/Inverse_Image.v theories/Wellfounded/Lexicographic_Exponentiation.v theories/Wellfounded/Lexicographic_Product.v theories/Wellfounded/Transitive_Closure.v theories/Wellfounded/Union.v theories/Wellfounded/Wellfounded.v theories/Wellfounded/Well_Ordering.v
    MSets: Modular implementation of finite sets using lists or efficient trees. This is a modernization of FSets.
    theories/MSets/MSetInterface.v theories/MSets/MSetFacts.v theories/MSets/MSetDecide.v theories/MSets/MSetProperties.v theories/MSets/MSetEqProperties.v theories/MSets/MSetWeakList.v theories/MSets/MSetList.v theories/MSets/MSetGenTree.v theories/MSets/MSetAVL.v theories/MSets/MSetRBT.v theories/MSets/MSetPositive.v theories/MSets/MSetToFiniteSet.v (theories/MSets/MSets.v)
    FSets: Modular implementation of finite sets/maps using lists or efficient trees. For sets, please consider the more modern MSets.
    theories/FSets/FSetInterface.v theories/FSets/FSetBridge.v theories/FSets/FSetFacts.v theories/FSets/FSetDecide.v theories/FSets/FSetProperties.v theories/FSets/FSetEqProperties.v theories/FSets/FSetList.v theories/FSets/FSetWeakList.v theories/FSets/FSetCompat.v theories/FSets/FSetAVL.v theories/FSets/FSetPositive.v (theories/FSets/FSets.v) theories/FSets/FSetToFiniteSet.v theories/FSets/FMapInterface.v theories/FSets/FMapWeakList.v theories/FSets/FMapList.v theories/FSets/FMapPositive.v theories/FSets/FMapFacts.v (theories/FSets/FMaps.v) theories/FSets/FMapAVL.v theories/FSets/FMapFullAVL.v
    Strings Implementation of string as list of ascii characters
    theories/Strings/Ascii.v theories/Strings/String.v
    Reals: Formalization of real numbers
    theories/Reals/Rdefinitions.v theories/Reals/Raxioms.v theories/Reals/RIneq.v theories/Reals/DiscrR.v theories/Reals/ROrderedType.v theories/Reals/Rminmax.v (theories/Reals/Rbase.v) theories/Reals/RList.v theories/Reals/Ranalysis.v theories/Reals/Rbasic_fun.v theories/Reals/Rderiv.v theories/Reals/Rfunctions.v theories/Reals/Rgeom.v theories/Reals/R_Ifp.v theories/Reals/Rlimit.v theories/Reals/Rseries.v theories/Reals/Rsigma.v theories/Reals/R_sqr.v theories/Reals/Rtrigo_fun.v theories/Reals/Rtrigo1.v theories/Reals/Rtrigo.v theories/Reals/Ratan.v theories/Reals/Machin.v theories/Reals/SplitAbsolu.v theories/Reals/SplitRmult.v theories/Reals/Alembert.v theories/Reals/AltSeries.v theories/Reals/ArithProp.v theories/Reals/Binomial.v theories/Reals/Cauchy_prod.v theories/Reals/Cos_plus.v theories/Reals/Cos_rel.v theories/Reals/Exp_prop.v theories/Reals/Integration.v theories/Reals/MVT.v theories/Reals/NewtonInt.v theories/Reals/PSeries_reg.v theories/Reals/PartSum.v theories/Reals/R_sqrt.v theories/Reals/Ranalysis1.v theories/Reals/Ranalysis2.v theories/Reals/Ranalysis3.v theories/Reals/Ranalysis4.v theories/Reals/Ranalysis5.v theories/Reals/Ranalysis_reg.v theories/Reals/Rcomplete.v theories/Reals/RiemannInt.v theories/Reals/RiemannInt_SF.v theories/Reals/Rpow_def.v theories/Reals/Rpower.v theories/Reals/Rprod.v theories/Reals/Rsqrt_def.v theories/Reals/Rtopology.v theories/Reals/Rtrigo_alt.v theories/Reals/Rtrigo_calc.v theories/Reals/Rtrigo_def.v theories/Reals/Rtrigo_reg.v theories/Reals/SeqProp.v theories/Reals/SeqSeries.v theories/Reals/Sqrt_reg.v theories/Reals/Rlogic.v theories/Reals/LegacyRfield.v (theories/Reals/Reals.v)
    Program: Support for dependently-typed programming.
    theories/Program/Basics.v theories/Program/Wf.v theories/Program/Subset.v theories/Program/Equality.v theories/Program/Tactics.v theories/Program/Utils.v theories/Program/Syntax.v theories/Program/Program.v theories/Program/Combinators.v
    Unicode: Unicode-based notations
    theories/Unicode/Utf8_core.v theories/Unicode/Utf8.v
    coq-8.4pl4/doc/common/0000755000175000017500000000000012365131026013653 5ustar stephstephcoq-8.4pl4/doc/common/styles/0000755000175000017500000000000012326224777015213 5ustar stephstephcoq-8.4pl4/doc/common/styles/html/0000755000175000017500000000000012326224777016157 5ustar stephstephcoq-8.4pl4/doc/common/styles/html/coqremote/0000755000175000017500000000000012365131026020140 5ustar stephstephcoq-8.4pl4/doc/common/styles/html/coqremote/header.html0000644000175000017500000000352212326224777022275 0ustar stephsteph Standard Library | The Coq Proof Assistant
    coq-8.4pl4/doc/common/styles/html/coqremote/footer.html0000644000175000017500000000163312326224777022344 0ustar stephsteph
    coq-8.4pl4/doc/common/styles/html/simple/0000755000175000017500000000000012326224777017450 5ustar stephstephcoq-8.4pl4/doc/common/styles/html/simple/style.css0000644000175000017500000000030512326224777021320 0ustar stephsteph#footer { border-top: solid black 1pt; text-align: center; text-indent: 0pt; } .menu { } .menu li { display: inline; margin: 0pt; padding: .5ex 1em; list-style: none }coq-8.4pl4/doc/common/styles/html/simple/header.html0000644000175000017500000000060312326224777021565 0ustar stephsteph The Coq Standard Library coq-8.4pl4/doc/common/styles/html/simple/footer.html0000644000175000017500000000002012326224777021624 0ustar stephsteph coq-8.4pl4/states/0000755000175000017500000000000012365131025013120 5ustar stephstephcoq-8.4pl4/states/MakeInitial.v0000644000175000017500000000110012326224777015504 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* raise Not_found) (* std_ppcmds *) let pppp x = pp x (* name printers *) let ppid id = pp (pr_id id) let pplab l = pp (pr_lab l) let ppmbid mbid = pp (str (debug_string_of_mbid mbid)) let ppdir dir = pp (pr_dirpath dir) let ppmp mp = pp(str (string_of_mp mp)) let ppcon con = pp(debug_pr_con con) let ppkn kn = pp(pr_kn kn) let ppmind kn = pp(debug_pr_mind kn) let ppsp sp = pp(pr_path sp) let ppqualid qid = pp(pr_qualid qid) let ppclindex cl = pp(Classops.pr_cl_index cl) (* term printers *) let rawdebug = ref false let ppconstr x = pp (Termops.print_constr x) let ppconstrdb x = pp(Flags.with_option rawdebug Termops.print_constr x) let ppterm = ppconstr let ppsconstr x = ppconstr (Declarations.force x) let ppconstr_univ x = Constrextern.with_universes ppconstr x let ppglob_constr = (fun x -> pp(pr_lglob_constr x)) let pppattern = (fun x -> pp(pr_constr_pattern x)) let pptype = (fun x -> try pp(pr_ltype x) with e -> pp (str (Printexc.to_string e))) let ppfconstr c = ppconstr (Closure.term_of_fconstr c) let ppbigint n = pp (str (Bigint.to_string n));; let prset pr l = str "[" ++ hov 0 (prlist_with_sep spc pr l) ++ str "]" let ppintset l = pp (prset int (Intset.elements l)) let ppidset l = pp (prset pr_id (Idset.elements l)) let prset' pr l = str "[" ++ hov 0 (prlist_with_sep pr_comma pr l) ++ str "]" let ppidmap pr l = let pr (id,b) = pr_id id ++ str "=>" ++ pr id b in pp (prset' pr (Idmap.fold (fun a b l -> (a,b)::l) l [])) let ppevarsubst = ppidmap (fun id0 -> prset (fun (c,copt,id) -> hov 0 (Termops.print_constr c ++ (match copt with None -> mt () | Some c -> spc () ++ str "") ++ (if id = id0 then mt () else spc () ++ str "")))) let pP s = pp (hov 0 s) let safe_pr_global = function | ConstRef kn -> pp (str "CONSTREF(" ++ debug_pr_con kn ++ str ")") | IndRef (kn,i) -> pp (str "INDREF(" ++ debug_pr_mind kn ++ str "," ++ int i ++ str ")") | ConstructRef ((kn,i),j) -> pp (str "INDREF(" ++ debug_pr_mind kn ++ str "," ++ int i ++ str "," ++ int j ++ str ")") | VarRef id -> pp (str "VARREF(" ++ pr_id id ++ str ")") let ppglobal x = try pp(pr_global x) with _ -> safe_pr_global x let ppconst (sp,j) = pp (str"#" ++ pr_kn sp ++ str"=" ++ pr_lconstr j.uj_val) let ppvar ((id,a)) = pp (str"#" ++ pr_id id ++ str":" ++ pr_lconstr a) let genppj f j = let (c,t) = f j in (c ++ str " : " ++ t) let ppj j = pp (genppj pr_ljudge j) let prsubst s = pp (Mod_subst.debug_pr_subst s) let prdelta s = pp (Mod_subst.debug_pr_delta s) let pp_idpred s = pp (pr_idpred s) let pp_cpred s = pp (pr_cpred s) let pp_transparent_state s = pp (pr_transparent_state s) (* proof printers *) let ppmetas metas = pp(pr_metaset metas) let ppevm evd = pp(pr_evar_map (Some 2) evd) let ppevmall evd = pp(pr_evar_map None evd) let pr_existentialset evars = prlist_with_sep spc pr_meta (ExistentialSet.elements evars) let ppexistentialset evars = pp (pr_existentialset evars) let ppclenv clenv = pp(pr_clenv clenv) let ppgoalgoal gl = pp(Goal.pr_goal gl) let ppgoal g = pp(Printer.pr_goal g) (* spiwack: deactivated until a replacement is found let pppftreestate p = pp(print_pftreestate p) *) (* let ppgoal g = pp(db_pr_goal g) *) (* let pr_gls gls = *) (* hov 0 (pr_evar_defs (sig_sig gls) ++ fnl () ++ db_pr_goal (sig_it gls)) *) (* let pr_glls glls = *) (* hov 0 (pr_evar_defs (sig_sig glls) ++ fnl () ++ *) (* prlist_with_sep pr_fnl db_pr_goal (sig_it glls)) *) (* let ppsigmagoal g = pp(pr_goal (sig_it g)) *) (* let prgls gls = pp(pr_gls gls) *) (* let prglls glls = pp(pr_glls glls) *) (* let pproof p = pp(print_proof Evd.empty empty_named_context p) *) let ppuni u = pp(pr_uni u) let ppuniverses u = pp (str"[" ++ pr_universes u ++ str"]") let ppconstraints c = pp (pr_constraints c) let ppenv e = pp (str "[" ++ pr_named_context_of e ++ str "]" ++ spc() ++ str "[" ++ pr_rel_context e (rel_context e) ++ str "]") let pptac = (fun x -> pp(Pptactic.pr_glob_tactic (Global.env()) x)) let ppinsts c = pp (pr_instance_gmap c) let ppobj obj = Format.print_string (Libobject.object_tag obj) let cnt = ref 0 let cast_kind_display k = match k with | VMcast -> "VMcast" | DEFAULTcast -> "DEFAULTcast" | REVERTcast -> "REVERTcast" let constr_display csr = let rec term_display c = match kind_of_term c with | Rel n -> "Rel("^(string_of_int n)^")" | Meta n -> "Meta("^(string_of_int n)^")" | Var id -> "Var("^(string_of_id id)^")" | Sort s -> "Sort("^(sort_display s)^")" | Cast (c,k, t) -> "Cast("^(term_display c)^","^(cast_kind_display k)^","^(term_display t)^")" | Prod (na,t,c) -> "Prod("^(name_display na)^","^(term_display t)^","^(term_display c)^")\n" | Lambda (na,t,c) -> "Lambda("^(name_display na)^","^(term_display t)^","^(term_display c)^")\n" | LetIn (na,b,t,c) -> "LetIn("^(name_display na)^","^(term_display b)^"," ^(term_display t)^","^(term_display c)^")" | App (c,l) -> "App("^(term_display c)^","^(array_display l)^")\n" | Evar (e,l) -> "Evar("^(string_of_int e)^","^(array_display l)^")" | Const c -> "Const("^(string_of_con c)^")" | Ind (sp,i) -> "MutInd("^(string_of_mind sp)^","^(string_of_int i)^")" | Construct ((sp,i),j) -> "MutConstruct(("^(string_of_mind sp)^","^(string_of_int i)^")," ^(string_of_int j)^")" | Case (ci,p,c,bl) -> "MutCase(,"^(term_display p)^","^(term_display c)^"," ^(array_display bl)^")" | Fix ((t,i),(lna,tl,bl)) -> "Fix(([|"^(Array.fold_right (fun x i -> (string_of_int x)^(if not(i="") then (";"^i) else "")) t "")^"|],"^(string_of_int i)^")," ^(array_display tl)^",[|" ^(Array.fold_right (fun x i -> (name_display x)^(if not(i="") then (";"^i) else "")) lna "")^"|]," ^(array_display bl)^")" | CoFix(i,(lna,tl,bl)) -> "CoFix("^(string_of_int i)^")," ^(array_display tl)^"," ^(Array.fold_right (fun x i -> (name_display x)^(if not(i="") then (";"^i) else "")) lna "")^"," ^(array_display bl)^")" and array_display v = "[|"^ (Array.fold_right (fun x i -> (term_display x)^(if not(i="") then (";"^i) else "")) v "")^"|]" and sort_display = function | Prop(Pos) -> "Prop(Pos)" | Prop(Null) -> "Prop(Null)" | Type u -> incr cnt; pp (str "with " ++ int !cnt ++ pr_uni u ++ fnl ()); "Type("^(string_of_int !cnt)^")" and name_display = function | Name id -> "Name("^(string_of_id id)^")" | Anonymous -> "Anonymous" in msg (str (term_display csr) ++fnl ()) open Format;; let print_pure_constr csr = let rec term_display c = match kind_of_term c with | Rel n -> print_string "#"; print_int n | Meta n -> print_string "Meta("; print_int n; print_string ")" | Var id -> print_string (string_of_id id) | Sort s -> sort_display s | Cast (c,_, t) -> open_hovbox 1; print_string "("; (term_display c); print_cut(); print_string "::"; (term_display t); print_string ")"; close_box() | Prod (Name(id),t,c) -> open_hovbox 1; print_string"("; print_string (string_of_id id); print_string ":"; box_display t; print_string ")"; print_cut(); box_display c; close_box() | Prod (Anonymous,t,c) -> print_string"("; box_display t; print_cut(); print_string "->"; box_display c; print_string ")"; | Lambda (na,t,c) -> print_string "["; name_display na; print_string ":"; box_display t; print_string "]"; print_cut(); box_display c; | LetIn (na,b,t,c) -> print_string "["; name_display na; print_string "="; box_display b; print_cut(); print_string ":"; box_display t; print_string "]"; print_cut(); box_display c; | App (c,l) -> print_string "("; box_display c; Array.iter (fun x -> print_space (); box_display x) l; print_string ")" | Evar (e,l) -> print_string "Evar#"; print_int e; print_string "{"; Array.iter (fun x -> print_space (); box_display x) l; print_string"}" | Const c -> print_string "Cons("; sp_con_display c; print_string ")" | Ind (sp,i) -> print_string "Ind("; sp_display sp; print_string ","; print_int i; print_string ")" | Construct ((sp,i),j) -> print_string "Constr("; sp_display sp; print_string ","; print_int i; print_string ","; print_int j; print_string ")" | Case (ci,p,c,bl) -> open_vbox 0; print_string "<"; box_display p; print_string ">"; print_cut(); print_string "Case"; print_space(); box_display c; print_space (); print_string "of"; open_vbox 0; Array.iter (fun x -> print_cut(); box_display x) bl; close_box(); print_cut(); print_string "end"; close_box() | Fix ((t,i),(lna,tl,bl)) -> print_string "Fix("; print_int i; print_string ")"; print_cut(); open_vbox 0; let rec print_fix () = for k = 0 to (Array.length tl) - 1 do open_vbox 0; name_display lna.(k); print_string "/"; print_int t.(k); print_cut(); print_string ":"; box_display tl.(k) ; print_cut(); print_string ":="; box_display bl.(k); close_box (); print_cut() done in print_string"{"; print_fix(); print_string"}" | CoFix(i,(lna,tl,bl)) -> print_string "CoFix("; print_int i; print_string ")"; print_cut(); open_vbox 0; let rec print_fix () = for k = 0 to (Array.length tl) - 1 do open_vbox 1; name_display lna.(k); print_cut(); print_string ":"; box_display tl.(k) ; print_cut(); print_string ":="; box_display bl.(k); close_box (); print_cut(); done in print_string"{"; print_fix (); print_string"}" and box_display c = open_hovbox 1; term_display c; close_box() and sort_display = function | Prop(Pos) -> print_string "Set" | Prop(Null) -> print_string "Prop" | Type u -> open_hbox(); print_string "Type("; pp (pr_uni u); print_string ")"; close_box() and name_display = function | Name id -> print_string (string_of_id id) | Anonymous -> print_string "_" (* Remove the top names for library and Scratch to avoid long names *) and sp_display sp = (* let dir,l = decode_kn sp in let ls = match List.rev (List.map string_of_id (repr_dirpath dir)) with ("Top"::l)-> l | ("Coq"::_::l) -> l | l -> l in List.iter (fun x -> print_string x; print_string ".") ls;*) print_string (debug_string_of_mind sp) and sp_con_display sp = (* let dir,l = decode_kn sp in let ls = match List.rev (List.map string_of_id (repr_dirpath dir)) with ("Top"::l)-> l | ("Coq"::_::l) -> l | l -> l in List.iter (fun x -> print_string x; print_string ".") ls;*) print_string (debug_string_of_con sp) in try box_display csr; print_flush() with e -> print_string (Printexc.to_string e);print_flush (); raise e let ppfconstr c = ppconstr (Closure.term_of_fconstr c) let pploc x = let (l,r) = unloc x in print_string"(";print_int l;print_string",";print_int r;print_string")" (* extendable tactic arguments *) let rec pr_argument_type = function (* Basic types *) | BoolArgType -> str"bool" | IntArgType -> str"int" | IntOrVarArgType -> str"int-or-var" | StringArgType -> str"string" | PreIdentArgType -> str"pre-ident" | IntroPatternArgType -> str"intro-pattern" | IdentArgType true -> str"ident" | IdentArgType false -> str"pattern_ident" | VarArgType -> str"var" | RefArgType -> str"ref" (* Specific types *) | SortArgType -> str"sort" | ConstrArgType -> str"constr" | ConstrMayEvalArgType -> str"constr-may-eval" | QuantHypArgType -> str"qhyp" | OpenConstrArgType _ -> str"open-constr" | ConstrWithBindingsArgType -> str"constr-with-bindings" | BindingsArgType -> str"bindings" | RedExprArgType -> str"redexp" | List0ArgType t -> pr_argument_type t ++ str" list0" | List1ArgType t -> pr_argument_type t ++ str" list1" | OptArgType t -> pr_argument_type t ++ str" opt" | PairArgType (t1,t2) -> str"("++ pr_argument_type t1 ++ str"*" ++ pr_argument_type t2 ++str")" | ExtraArgType s -> str"\"" ++ str s ++ str "\"" let pp_argument_type t = pp (pr_argument_type t) let pp_generic_argument arg = pp(str"") (**********************************************************************) (* Vernac-level debugging commands *) let in_current_context f c = let (evmap,sign) = try Pfedit.get_current_goal_context () with e when Logic.catchable_exception e -> (Evd.empty, Global.env()) in f (Constrintern.interp_constr evmap sign c) (* We expand the result of preprocessing to be independent of camlp4 VERNAC COMMAND EXTEND PrintPureConstr | [ "PrintPureConstr" constr(c) ] -> [ in_current_context print_pure_constr c ] END VERNAC COMMAND EXTEND PrintConstr [ "PrintConstr" constr(c) ] -> [ in_current_context constr_display c ] END *) open Pcoq open Genarg open Egrammar let _ = try Vernacinterp.vinterp_add "PrintConstr" (function [c] when genarg_tag c = ConstrArgType && true -> let c = out_gen rawwit_constr c in (fun () -> in_current_context constr_display c) | _ -> failwith "Vernac extension: cannot occur") with e -> Pp.pp (Errors.print e) let _ = extend_vernac_command_grammar "PrintConstr" None [[GramTerminal "PrintConstr"; GramNonTerminal (dummy_loc,ConstrArgType,Aentry ("constr","constr"), Some (Names.id_of_string "c"))]] let _ = try Vernacinterp.vinterp_add "PrintPureConstr" (function [c] when genarg_tag c = ConstrArgType && true -> let c = out_gen rawwit_constr c in (fun () -> in_current_context print_pure_constr c) | _ -> failwith "Vernac extension: cannot occur") with e -> Pp.pp (Errors.print e) let _ = extend_vernac_command_grammar "PrintPureConstr" None [[GramTerminal "PrintPureConstr"; GramNonTerminal (dummy_loc,ConstrArgType,Aentry ("constr","constr"), Some (Names.id_of_string "c"))]] (* Setting printer of unbound global reference *) open Names open Nameops open Libnames let encode_path loc prefix mpdir suffix id = let dir = match mpdir with | None -> [] | Some (mp,dir) -> (repr_dirpath (dirpath_of_string (string_of_mp mp))@ repr_dirpath dir) in Qualid (loc, make_qualid (make_dirpath (List.rev (id_of_string prefix::dir@suffix))) id) let raw_string_of_ref loc _ = function | ConstRef cst -> let (mp,dir,id) = repr_con cst in encode_path loc "CST" (Some (mp,dir)) [] (id_of_label id) | IndRef (kn,i) -> let (mp,dir,id) = repr_mind kn in encode_path loc "IND" (Some (mp,dir)) [id_of_label id] (id_of_string ("_"^string_of_int i)) | ConstructRef ((kn,i),j) -> let (mp,dir,id) = repr_mind kn in encode_path loc "CSTR" (Some (mp,dir)) [id_of_label id;id_of_string ("_"^string_of_int i)] (id_of_string ("_"^string_of_int j)) | VarRef id -> encode_path loc "SECVAR" None [] id let short_string_of_ref loc _ = function | VarRef id -> Ident (loc,id) | ConstRef cst -> Ident (loc,id_of_label (pi3 (repr_con cst))) | IndRef (kn,0) -> Ident (loc,id_of_label (pi3 (repr_mind kn))) | IndRef (kn,i) -> encode_path loc "IND" None [id_of_label (pi3 (repr_mind kn))] (id_of_string ("_"^string_of_int i)) | ConstructRef ((kn,i),j) -> encode_path loc "CSTR" None [id_of_label (pi3 (repr_mind kn));id_of_string ("_"^string_of_int i)] (id_of_string ("_"^string_of_int j)) (* Anticipate that printers can be used from ocamldebug and that pretty-printer should not make calls to the global env since ocamldebug runs in a different process and does not have the proper env at hand *) let _ = Constrextern.in_debugger := true let _ = Constrextern.set_extern_reference (if !rawdebug then raw_string_of_ref else short_string_of_ref) coq-8.4pl4/dev/set_raw_db0000644000175000017500000000005012326224777014440 0ustar stephstephinstall_printer Top_printers.ppconstrdb coq-8.4pl4/dev/db0000644000175000017500000000232512326224777012723 0ustar stephstephload_printer "gramlib.cma" load_printer "printers.cma" install_printer Top_printers.ppid install_printer Top_printers.ppidset install_printer Top_printers.ppevarsubst install_printer Top_printers.ppintset install_printer Top_printers.pplab install_printer Top_printers.ppdir install_printer Top_printers.ppmp install_printer Top_printers.ppkn install_printer Top_printers.ppcon install_printer Top_printers.ppmind install_printer Top_printers.ppsp install_printer Top_printers.ppqualid install_printer Top_printers.ppclindex install_printer Top_printers.ppbigint install_printer Top_printers.pppattern install_printer Top_printers.ppglob_constr install_printer Top_printers.ppconstr install_printer Top_printers.ppuni install_printer Top_printers.ppuniverses install_printer Top_printers.ppconstraints install_printer Top_printers.pptype install_printer Top_printers.ppj install_printer Top_printers.ppenv install_printer Top_printers.ppmetas install_printer Top_printers.ppevm install_printer Top_printers.ppgoal install_printer Top_printers.pptac install_printer Top_printers.ppobj install_printer Top_printers.pploc install_printer Top_printers.prsubst install_printer Top_printers.prdelta install_printer Top_printers.ppfconstr coq-8.4pl4/dev/tools/0000755000175000017500000000000012365131026013534 5ustar stephstephcoq-8.4pl4/dev/tools/Makefile.dir0000644000175000017500000000617112326224777015773 0ustar stephsteph# make a link to this file if you are working hard in one directory of Coq # ln -s ../dev/tools/Makefile.dir Makefile # if you are working in a sub/dir/ make a link to dev/tools/Makefile.subdir instead # this Makefile provides many useful facilities to develop Coq # it is not completely compatible with .ml4 files unfortunately ifndef TOPDIR TOPDIR=.. endif # this complicated thing should work for subsubdirs as well BASEDIR=$(shell (dir=`pwd`; cd $(TOPDIR); top=`pwd`; echo $$dir | sed -e "s|$$top/||")) noargs: dir test-dir: @echo TOPDIR=$(TOPDIR) @echo BASEDIR=$(BASEDIR) include $(TOPDIR)/dev/tools/Makefile.common # make this directory dir: $(MAKE) -C $(TOPDIR) $(notdir $(BASEDIR)) # make all cmo's in this directory. Useful in case the main Makefile is not # up-to-date all: @( ( for i in *.ml; do \ echo -n $(BASEDIR)/`basename $$i .ml`.cmo "" ; \ done; \ for i in *.ml4; do \ echo -n $(BASEDIR)/`basename $$i .ml4`.cmo "" ; \ done ) \ | xargs $(MAKE) -C $(TOPDIR) ) # lists all files that should be compiled in this directory list: @(for i in *.mli; do \ ls -l `basename $$i .mli`.cmi; \ done) @(for i in *.ml; do \ ls -l `basename $$i .ml`.cmo; \ done) @(for i in *.ml4; do \ ls -l `basename $$i .ml4`.cmo; \ done) clean:: rm -f *.cmi *.cmo *.cmx *.o # if grammar.cmo files cannot be compiled and main .depend cannot be # rebuilt, this is quite useful depend: (cd $(TOPDIR); ocamldep -I $(BASEDIR) $(BASEDIR)/*.ml $(BASEDIR)/*.mli > .depend.devel) # displays the dependency graph of the current directory (vertically, # unlike in doc/) graph: (ocamldep *.ml *.mli | ocamldot | dot -Tps | gv -) & # the pretty entry draws a dependency graph marking red those nodes # which do not have their .cmo files .INTERMEDIATE: depend.dot depend.2.dot .PHONY: depend.ps depend.dot: ocamldep *.ml *.mli | ocamldot > $@ depend.2.dot: depend.dot (i=`cat $< | wc -l`; i=`expr $$i - 1`; head -n $$i $<) > $@ (for ml in *.ml; do \ base=`basename $$ml .ml`; \ fst=`echo $$base | cut -c1 | tr [:lower:] [:upper:]`; \ rest=`echo $$base | cut -c2-`; \ name=`echo $$fst $$rest | tr -d " "`; \ cmo=$$base.cmo; \ if [ ! -e $$cmo ]; then \ echo \"$$name\" [color=red]\; >> $@;\ fi;\ done;\ echo } >> $@) depend.ps: depend.2.dot dot -Tps $< > $@ clean:: rm -f depend.ps pretty: depend.ps (gv -spartan $<; rm $<) & # gv -spartan $< & # generating file.ml.mli by tricking make to pass -i to ocamlc %.ml.mli: FORCE @(cmo=`basename $@ .ml.mli`.cmo ; \ mv -f $$cmo $$cmo.tmp ; \ $(MAKE) -s -C $(TOPDIR) $(BASEDIR)/$$cmo CAMLDEBUG=-i > $@ ; \ echo Generated interface file $@ ; \ mv -f $$cmo.tmp $$cmo) %.annot: FORCE @(cmo=`basename $@ .annot`.cmo ; \ mv -f $$cmo $$cmo.tmp ; \ $(MAKE) -s -C $(TOPDIR) $(BASEDIR)/$$cmo CAMLDEBUG=-dtypes ; \ echo Generated annotation file $@ ; \ mv -f $$cmo.tmp $$cmo) FORCE: clean:: rm -f *.ml.mli # this is not perfect but mostly WORKS! It just calls the main makefile %.cmi: FORCE $(MAKE) -C $(TOPDIR) $(BASEDIR)/$@ %.cmo: FORCE $(MAKE) -C $(TOPDIR) $(BASEDIR)/$@ coqtop: $(MAKE) -C $(TOPDIR) bin/coqtop.byte coq-8.4pl4/dev/tools/change-header0000755000175000017500000000256412326224777016161 0ustar stephsteph#!/bin/sh #This script changes the header of .ml* files if [ ! $# = 2 ]; then echo Usage: change-header old-header-file new-header-file exit 1 fi oldheader=$1 newheader=$2 if [ ! -f $oldheader ]; then echo Cannot read file $oldheader; exit 1; fi if [ ! -f $newheader ]; then echo Cannot read file $newheader; exit 1; fi n=`wc -l $oldheader | sed -e "s/ *\([0-9]*\).*/\1/g"` nsucc=`expr $n + 1` linea='(* -*- coding:utf-8 -*- *)' lineb='(* -*- compile-command: "make -C ../.. bin/coqdoc" -*- *)' modified=0 kept=0 for i in `find . -name \*.mli -o -name \*.ml -o -name \*.ml4 -o -name \*.mll -o -name \*.mly -o -name \*.mlp -o -name \*.v`; do headline=`head -n 1 $i` if `echo $headline | grep "(\* -\*- .* \*)" > /dev/null`; then # Has emacs header head -n +$nsucc $i | tail -n $n > $i.head.tmp$$ hasheadline=1 nnext=`expr $nsucc + 1` else head -n +$n $i > $i.head.tmp$$ hasheadline=0 nnext=$nsucc fi if diff -a -q $oldheader $i.head.tmp$$ > /dev/null; then echo "$i: header changed" if [ $hasheadline = 1 ]; then echo $headline > $i.tmp$$ else touch $i.tmp$$ fi cat $newheader >> $i.tmp$$ tail -n +$nnext $i >> $i.tmp$$ mv $i.tmp$$ $i modified=`expr $modified + 1` else kept=`expr $kept + 1` fi rm $i.head.tmp$$ done echo $modified files updated echo $kept files unchanged coq-8.4pl4/dev/tools/objects.el0000644000175000017500000000757012326224777015535 0ustar stephsteph(defun add-survive-module nil (interactive) (query-replace-regexp " \\([ ]*\\)\\(Summary\.\\)?survive_section" " \\1\\2survive_module = false; \\1\\2survive_section") ) (global-set-key [f2] 'add-survive-module) ; functions to change old style object declaration to new style (defun repl-open nil (interactive) (query-replace-regexp "open_function\\([ ]*\\)=\\([ ]*\\)cache_\\([a-zA-Z0-9'_]*\\)\\( *\\);" "open_function\\1=\\2(fun i o -> if i=1 then cache_\\3 o)\\4;") ) (global-set-key [f6] 'repl-open) (defun repl-load nil (interactive) (query-replace-regexp "load_function\\([ ]*\\)=\\([ ]*\\)cache_\\([a-zA-Z0-9'_]*\\)\\( *\\);" "load_function\\1=\\2(fun _ -> cache_\\3)\\4;") ) (global-set-key [f7] 'repl-load) (defun repl-decl nil (interactive) (query-replace-regexp "\\(Libobject\.\\)?declare_object[ ]*([ ]*\\(.*\\)[ ]*,[ ]* \\([ ]*\\){\\([ ]*\\)\\([^ ][^}]*\\)}[ ]*)" "\\1declare_object {(\\1default_object \\2) with \\3 \\4\\5}") ; "|$1=\\1|$2=\\2|$3=\\3|$4=\\4|") ) (global-set-key [f9] 'repl-decl) ; eval the above and try f9 f6 f7 on the following: let (inThing,outThing) = declare_object ("THING", { load_function = cache_thing; cache_function = cache_thing; open_function = cache_thing; export_function = (function x -> Some x) }) ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ; functions helping writing non-copying substitutions (defun make-subst (name) (interactive "s") (defun f (l) (save-excursion (query-replace-regexp (concat "\\([a-zA-z_0-9]*\\)[ ]*:[ ]*" (car l) "\\([ ]*;\\|[ ]*\}\\)") (concat "let \\1\' = " (cdr l) " " name "\\1 in")) ) ) (mapcar 'f '(("constr"."subst_mps subst") ("Coqast.t"."subst_ast subst") ("Coqast.t list"."list_smartmap (subst_ast subst)") ("'pat"."subst_pat subst") ("'pat unparsing_hunk"."subst_hunk subst_pat subst") ("'pat unparsing_hunk list"."list_smartmap (subst_hunk subst_pat subst)") ("'pat syntax_entry"."subst_syntax_entry subst_pat subst") ("'pat syntax_entry list"."list_smartmap (subst_syntax_entry subst_pat subst)") ("constr option"."option_smartmap (subst_mps subst)") ("constr list"."list_smartmap (subst_mps subst)") ("constr array"."array_smartmap (subst_mps subst)") ("constr_pattern"."subst_pattern subst") ("constr_pattern option"."option_smartmap (subst_pattern subst)") ("constr_pattern array"."array_smartmap (subst_pattern subst)") ("constr_pattern list"."list_smartmap (subst_pattern subst)") ("global_reference"."subst_global subst") ("extended_global_reference"."subst_ext subst") ("obj_typ"."subst_obj subst") ) ) ) (global-set-key [f2] 'make-subst) (defun make-if (name) (interactive "s") (save-excursion (query-replace-regexp "\\([a-zA-z_0-9]*\\)[ ]*:[ ]*['a-zA-z_. ]*\\(;\\|[ ]*\}\\)" (concat "&& \\1\' == " name "\\1") ) ) ) (global-set-key [f4] 'make-if) (defun make-record nil (interactive) (save-excursion (query-replace-regexp "\\([a-zA-z_0-9]*\\)[ ]*:[ ]*['a-zA-z_. ]*\\(;\\|[ ]*\}\\)" (concat "\\1 = \\1\' ;") ) ) ) (global-set-key [f5] 'make-record) (defun make-prim nil (interactive) (save-excursion (query-replace-regexp "\\<[a-zA-Z'_0-9]*\\>" "\\&'")) ) (global-set-key [f6] 'make-prim) ; eval the above, yank the text below and do ; paste f2 morph. ; paste f4 morph. ; paste f5 lem : constr; profil : bool list; arg_types : constr list; lem2 : constr option } ; and you almost get Setoid_replace.subst_morph :) ; and now f5 on this: (ref,(c1,c2)) coq-8.4pl4/dev/tools/Makefile.devel0000644000175000017500000000351112326224777016307 0ustar stephsteph# to be linked to makefile (lowercase - takes precedence over Makefile) # in main directory # make devel in main directory should do this for you. TOPDIR=. BASEDIR= SOURCEDIRS=lib kernel library pretyping parsing proofs tactics toplevel default: usage noargument usage:: @echo Usage: make \ @echo Targets are: usage:: @echo " setup-devel -- set the devel makefile" setup-devel: @ln -sfv dev/tools/Makefile.devel makefile @(for i in $(SOURCEDIRS); do \ (cd $(TOPDIR)/$$i; ln -sfv ../dev/tools/Makefile.dir Makefile) \ done) usage:: @echo " clean-devel -- clear all devel files" clean-devel: echo rm -f makefile .depend.devel echo rm -f $(foreach dir,$(SOURCEDIRS), $(TOPDIR)/$(dir)/Makefile) usage:: @echo " coqtop -- make until the bytecode executable, make the link" coqtop: bin/coqtop.byte ln -sf bin/coqtop.byte coqtop usage:: @echo " quick -- make bytecode executable and states" quick: $(MAKE) states BEST=byte include Makefile include $(TOPDIR)/dev/tools/Makefile.common # this file is better described in dev/tools/Makefile.dir include .depend.devel #if dev/tools/Makefile.local exists, it is included ifneq ($(wildcard $(TOPDIR)/dev/tools/Makefile.local),) include $(TOPDIR)/dev/tools/Makefile.local endif usage:: @echo " total -- runs coqtop with all theories required" total: ledit ./bin/coqtop.byte $(foreach th,$(THEORIESVO),-require $(notdir $(basename $(th)))) usage:: @echo " run -- makes and runs bytecode coqtop using ledit and the history file" @echo " if you want to pass arguments to coqtop, use make run ARG=" run: $(TOPDIR)/coqtop ledit -h $(TOPDIR)/dev/debug_history -x $(TOPDIR)/coqtop $(ARG) $(ARGS) usage:: @echo " vars -- echos commands to set COQTOP and COQBIN variables" vars: @(cd $(TOPDIR); \ echo export COQTOP=`pwd`/ ; \ echo export COQBIN=`pwd`/bin/ ) coq-8.4pl4/dev/tools/Makefile.subdir0000644000175000017500000000040012326224777016472 0ustar stephsteph# if you work in a sub/sub-rectory of Coq # you should make a link to that makefile # ln -s ../../dev/tools/Makefile.subdir Makefile # in order to have all the facilities of dev/tools/Makefile.dir TOPDIR=../.. include $(TOPDIR)/dev/tools/Makefile.dir coq-8.4pl4/dev/tools/Makefile.common0000644000175000017500000000000012326224777016466 0ustar stephstephcoq-8.4pl4/dev/README0000644000175000017500000000336112326224777013274 0ustar stephstephThis directory contains informations and tools to help developing the Coq system ====================== Debugging and profiling (in current directory - see doc/debugging.txt) ----------------------- ocamldebug-coq: to launch ocaml debugger db: to install pretty-printers from ocaml debugger base_db: to install raw pretty-printers from ocaml debugger include: to install pretty-printers from ocaml toplevel base_include: to install raw pretty-printers from ocaml toplevel vm_printers.ml, dev_printers.ml: ML pretty-printers for debugging Miscellaneous informations about the code (directory doc) ----------------------------------------- changes.txt: (partial) per-version summary of the evolutions of Coq ML source style.txt: a few style recommendations for writing Coq ML files debugging.txt: help for debugging or profiling universes.txt: help to debug universes translate.txt: help to use coq translator extensions.txt: some help about TACTIC EXTEND header: standard header for Coq ML files perf-analysis: analysis of perfs measured on the compilation of user contribs cic.dtd: official dtd of the calc. of ind. constr. for im/ex-portation Documentation of ML interfaces using ocamldoc (directory ocamldoc/html) ---------------------------------------- "make mli-doc" in coq root directory. Other development tools (directory tools) ----------------------- Makefile.dir: makefile dedicated to intensive work in a given directory Makefile.subdir: makefile dedicated to intensive work in a given subdirectory Makefile.devel: utilities to automatically launch coq in various states Makefile.common: used by other Makefiles objects.el: various development utilities at emacs level coq-8.4pl4/dev/ocamldebug-coq.template0000644000175000017500000000221512326224777017030 0ustar stephsteph#!/bin/sh # wrap around ocamldebug for Coq export COQTOP=COQTOPDIRECTORY export COQLIB=COQLIBDIRECTORY export COQTH=$COQLIB/theories CAMLBIN=CAMLBINDIRECTORY CAMLP4LIB=CAMLP4LIBDIRECTORY OCAMLDEBUG=$CAMLBIN/ocamldebug exec $OCAMLDEBUG \ -I $CAMLP4LIB \ -I $COQTOP \ -I $COQTOP/config \ -I $COQTOP/lib -I $COQTOP/kernel \ -I $COQTOP/library -I $COQTOP/pretyping -I $COQTOP/parsing \ -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics \ -I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config \ -I $COQTOP/plugins/cc -I $COQTOP/plugins/dp \ -I $COQTOP/plugins/extraction -I $COQTOP/plugins/field \ -I $COQTOP/plugins/firstorder -I $COQTOP/plugins/fourier \ -I $COQTOP/plugins/funind -I $COQTOP/plugins/groebner \ -I $COQTOP/plugins/interface -I $COQTOP/plugins/micromega \ -I $COQTOP/plugins/omega -I $COQTOP/plugins/quote \ -I $COQTOP/plugins/ring -I $COQTOP/plugins/romega \ -I $COQTOP/plugins/rtauto -I $COQTOP/plugins/setoid_ring \ -I $COQTOP/plugins/subtac -I $COQTOP/plugins/syntax \ -I $COQTOP/plugins/xml \ -I $COQTOP/ide \ $* coq-8.4pl4/dev/printers.mllib0000644000175000017500000000231112326224777015275 0ustar stephstephCoq_config Pp_control Pp Compat Flags Segmenttree Unicodetable Util Errors Bigint Hashcons Dyn System Envars Store Gmap Fset Fmap Gmapl Profile Explore Predicate Rtree Heap Option Dnet Hashtbl_alt Names Univ Esubst Term Mod_subst Sign Cbytecodes Copcodes Cemitcodes Declarations Retroknowledge Pre_env Cbytegen Environ Conv_oracle Closure Reduction Type_errors Entries Modops Inductive Typeops Indtypes Cooking Term_typing Subtyping Mod_typing Safe_typing Summary Nameops Libnames Global Nametab Libobject Lib Goptions Decls Heads Assumptions Termops Namegen Evd Glob_term Reductionops Inductiveops Retyping Cbv Pretype_errors Evarutil Term_dnet Recordops Evarconv Arguments_renaming Typing Pattern Matching Tacred Classops Typeclasses_errors Typeclasses Detyping Indrec Coercion Unification Cases Pretyping Declaremods Tok Lexer Ppextend Genarg Topconstr Notation Dumpglob Reserve Impargs Syntax_def Implicit_quantifiers Smartlocate Constrintern Modintern Constrextern Tacexpr Proof_type Goal Logic Refiner Clenv Evar_refiner Proofview Proof Proof_global Pfedit Tactic_debug Decl_mode Ppconstr Extend Extrawit Pcoq Printer Pptactic Ppdecl_proof Tactic_printer Egrammar Himsg Cerrors Vernacexpr Vernacinterp Top_printers coq-8.4pl4/dev/header0000644000175000017500000000101512326224777013561 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* pas de undo, ni de reset - conversion : déplier la constante la plus récente - un cache pour type_of_const, type_of_inductive, type_of_constructor, lookup_mind_specif o Toplevel - parsing de la ligne de commande : utiliser Arg ??? coq-8.4pl4/dev/db_printers.ml0000644000175000017500000000124612326224777015261 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* $CMXS.startup.fixed.s # Recompile fixed startup code as -o $CMXS.startup.o $CMXS.startup.fixed.s # Build fixed .cmxs (assume all object files are at the same place) ld -bundle -flat_namespace -undefined warning -read_only_relocs suppress -o $CMXS $OBJS $CMXS.startup.o rm $CMXS.startup.o $CMXS.startup.s $CMXS.startup.fixed.scoq-8.4pl4/dev/doc/0000755000175000017500000000000012365131026013141 5ustar stephstephcoq-8.4pl4/dev/doc/cic.dtd0000644000175000017500000001267212326224777014421 0ustar stephsteph coq-8.4pl4/dev/doc/universes.txt0000644000175000017500000000117212326224777015743 0ustar stephstephHow to debug universes? 1. There is a command Print Universes in Coq toplevel Print Universes. prints the graph of universes in the form of constraints Print Universes "file". produces the "file" containing universe constraints in the form univ1 # univ2 ; where # can be either > >= or = If "file" ends with .gv or .dot, the resulting file will be in dot format. *) for dot see http://www.research.att.com/sw/tools/graphviz/ 2. There is a printing option {Set,Unset} Printing Universes. which, when set, makes all pretty-printed Type's annotated with the name of the universe. coq-8.4pl4/dev/doc/translate.txt0000644000175000017500000003724712326224777015731 0ustar stephsteph How to use the translator ========================= (temporary version to be included in the official TeX document describing the translator) The translator is a smart, robust and powerful tool to improve the readibility of your script. The current document describes the possibilities of the translator. In case of problem recompiling the translated files, don't waste time to modify the translated file by hand, read first the following document telling on how to modify the original files to get a smooth uniform safe translation. All 60000 lines of Coq lines on our user-contributions server have been translated without any change afterwards, and 0,5 % of the lines of the original files (mainly notations) had to be modified beforehand to get this result. Table of contents ----------------- I) Implicit Arguments 1) Strict Implicit Arguments 2) Implicit Arguments in standard library II) Notations 1) Translating a V7 notation as it was 2) Translating a V7 notation which conflicts with the new syntax a) Associativity conflicts b) Conflicts with other notations b1) A notation hides another notation b2) A notation conflicts with the V8 grammar b3) My notation is already defined at another level c) How to use V8only with Distfix ? d) Can I overload a notation in V8, e.g. use "*" and "+" ? 3) Using the translator to have simplest notations 4) Setting the translator to automatically use new notations that wasn't used in old syntax 5) Defining a construction and its notation simultaneously III) Various pitfalls 1) New keywords 2) Old "Case" and "Match" 3) Change of definition or theorem names 4) Change of tactic names --------------------------------------------------------------------- I) Implicit Arguments ------------------ 1) Strict Implicit Arguments "Set Implicit Arguments" changes its meaning in V8: the default is to turn implicit only the arguments that are _strictly_ implicit (or rigid), i.e. that remains inferable whatever the other arguments are. E.g "x" inferable from "P x" is not strictly inferable since it can disappears if "P" is instanciated by a term which erase "x". To respect the old semantics, the default behaviour of the translator is to replace each occurrence "Set Implicit Arguments" by Set Implicit Arguments. Unset Strict Implicits. However, you may wish to adopt the new semantics of "Set Implicit Arguments" (for instance because you think that the choice of arguments it setsimplicit is more "natural" for you). In this case, add the option -strict-implicit to the translator. Warning: Changing the number of implicit arguments can break the notations. Then use the V8only modifier of Notations. 2) Implicit Arguments in standard library Main definitions of standard library have now implicit arguments. These arguments are dropped in the translated files. This can exceptionally be a source of incompatibilities which has to be solved by hand (it typically happens for polymorphic functions applied to "nil" or "None"). II) Notations --------- Grammar (on constr) and Syntax are no longer supported. Replace them by Notation before translation. Precedence levels are now from 0 to 200. In V8, the precedence and associativity of an operator cannot be redefined. Typical level are (refer to the chapter on notations in the Reference Manual for the full list): <-> : 95 (no associativity) -> : 90 (right associativity) \/ : 85 (right associativity) /\ : 80 (right associativity) ~ : 75 (right associativity) =, <, >, <=, >=, <> : 70 (no associativity) +, - : 50 (left associativity) *, / : 40 (left associativity) ^ : 30 (right associativity) 1) Translating a V7 notation as it was By default, the translator keeps the associativity given in V7 while the levels are mapped according to the following table: the V7 levels [ 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10] are resp. mapped in V8 to [ 0; 20; 30; 40; 50; 70; 80; 85; 90; 95; 100] with predefined assoc [ No; L; R; L; L; No; R; R; R; No; L] If this is OK for you, just simply apply the translator. 2) Translating a V7 notation which conflicts with the new syntax a) Associativity conflict Since the associativity of the levels obtained by translating a V7 level (as shown on table above) cannot be changed, you have to choose another level with a compatible associativity. You can choose any level between 0 and 200, knowing that the standard operators are already set at the levels shown on the list above. Example 1: Assume you have a notation Infix NONA 2 "=_S" my_setoid_eq. By default, the translator moves it to level 30 which is right associative, hence a conflict with the expected no associativity. To solve the problem, just add the "V8only" modifier to reset the level and enforce the associativity as follows: Infix NONA 2 "=_S" my_setoid_eq V8only (at level 70, no associativity). The translator now knows that it has to translate "=_S" at level 70 with no associativity. Rem: 70 is the "natural" level for relations, hence the choice of 70 here, but any other level accepting a no-associativity would have been OK. Example 2: Assume you have a notation Infix RIGHTA 1 "o" my_comp. By default, the translator moves it to level 20 which is left associative, hence a conflict with the expected right associativity. To solve the problem, just add the "V8only" modifier to reset the level and enforce the associativity as follows: Infix RIGHTA 1 "o" my_comp V8only (at level 20, right associativity). The translator now knows that it has to translate "o" at level 20 which has the correct "right associativity". Rem: We assumed here that the user wants a strong precedence for composition, in such a way, say, that "f o g + h" is parsed as "(f o g) + h". To get "o" binding less than the arithmetical operators, an appropriated level would have been close of 70, and below, e.g. 65. b) Conflicts with other notations Since the new syntax comes with new keywords and new predefined symbols, new conflicts can occur. Again, you can use the option V8only to inform the translator of the new syntax to use. b1) A notation hides another notation Rem: use Print Grammar constr in V8 to diagnose the overlap and see the section on factorization in the chapter on notations of the Reference Manual for hints on how to factorize. Example: Notation "{ x }" := (my_embedding x) (at level 1). overlaps in V8 with notation "{ x : A & P }" at level 0 and with x at level 99. The conflicts can be solved by left-factorizing the notation as follows: Notation "{ x }" := (my_embedding x) (at level 1) V8only (at level 0, x at level 99). b2) A notation conflicts with the V8 grammar. Again, use the V8only modifier to tell the translator to automatically take in charge the new syntax. Example: Infix 3 "@" app. Since "@" is used in the new syntax for deactivating the implicit arguments, another symbol has to be used, e.g. "@@". This is done via the V8only option as follows: Infix 3 "@" app V8only "@@" (at level 40, left associativity). or, alternatively by Notation "x @ y" := (app x y) (at level 3, left associativity) V8only "x @@ y" (at level 40, left associativity). b3) My notation is already defined at another level (or with another associativity) In V8, the level and associativity of a given notation can no longer be changed. Then, either you adopt the standard reserved levels and associativity for this notation (as given on the list above) or you change your notation. - To change the notation, follow the directions in section b2. - To adopt the standard level, just use V8only without any argument. Example. Infix 6 "*" my_mult. is not accepted as such in V8. Write Infix 6 "*" my_mult V8only. to tell the translator to use "*" at the reserved level (i.e. 40 with left associativity). Even better, use interpretation scopes (look at the Reference Manual). c) How to use V8only with Distfix ? You can't, use Notation instead of Distfix. d) Can I overload a notation in V8, e.g. use "*" and "+" for my own algebraic operations ? Yes, using interpretation scopes (see the corresponding chapter in the Reference Manual). 3) Using the translator to have simplest notations Thanks to the new syntax, * has now the expected left associativity, and the symbols <, >, <= and >= are now available. Thanks to the interpretation scopes, you can overload the interpretation of these operators with the default interpretation provided in Coq. This may be a motivation to use the translator to automatically change the notations while switching to the new syntax. See sections b) and d) above for examples. 4) Setting the translator to automatically use new notations that wasn't used in old syntax Thanks to the "Notation" mechanism, defining symbolic notations is simpler than in the previous versions of Coq. Thanks to the new syntax and interpretation scopes, new symbols and overloading is available. This may be a motivation for using the translator to automatically change the notations while switching to the new syntax. Use for that the commands V8Notation and V8Infix. Examples: V8Infix "==>" my_relation (at level 65, right associativity). tells the translator to write an infix "==>" instead of my_relation in the translated files. V8Infix ">=" my_ge. tells the translator to write an infix ">=" instead of my_ge in the translated files and that the level and associativity are the standard one (as defined in the chart above). V8Infix ">=" my_ge : my_scope. tells the translator to write an infix ">=" instead of my_ge in the translated files, that the level and associativity are the standard one (as defined in the chart above), but only if scope my_scope is open or if a delimiting key is available for "my_scope" (see the Reference Manual). 5) Defining a construction and its notation simultaneously This is permitted by the new syntax. Look at the Reference Manual for explanation. The translator is not fully able to take this in charge... III) Various pitfalls ---------------- 1) New keywords The following identifiers are new keywords "forall"; "fun"; "match"; "fix"; "cofix"; "for"; "if"; "then"; "else"; "return"; "mod"; "at"; "let"; "_"; ".(" The translator automatically add a "_" to names clashing with a keyword, except for files. Hence users may need to rename the files whose name clashes with a keyword. Remark: "in"; "with"; "end"; "as"; "Prop"; "Set"; "Type" were already keywords 2) Old "Case" and "Match" "Case" and "Match" are normally automatically translated into "match" or "match" and "fix", but sometimes it fails to do so. It typically fails when the Case or Match is argument of a tactic whose typing context is unknown because of a preceding Intro/Intros, as e.g. in Intros; Exists [m:nat](Case m of t [p:nat](f m) end) The solution is then to replace the invocation of the sequence of tactics into several invocation of the elementary tactics as follows Intros. Exists [m:nat](Case m of t [p:nat](f m) end) ^^^ 3) Change of definition or theorem names Type "entier" from fast_integer.v is renamed into "N" by the translator. As a consequence, user-defined objects of same name "N" are systematically qualified even tough it may not be necessary. The same apply for names "GREATER", "EQUAL", "LESS", etc... [COMPLETE LIST TO GIVE]. 4) Change of tactics names Since tactics names are now lowercase, this can clash with user-defined tactic definitions. To pally this, clashing names are renamed by adding an extra "_" to their name. ====================================================================== Main examples for new syntax ---------------------------- 1) Constructions Applicative terms don't any longer require to be surrounded by parentheses as e.g in "x = f y -> S x = S (f y)" Product is written "forall x y : T, U" "forall x y, U" "forall (x y : T) z (v w : V), U" etc. Abstraction is written "fun x y : T, U" "fun x y, U" "fun (x y : T) z (v w : V), U" etc. Pattern-matching is written "match x with c1 x1 x2 => t | c2 y as z => u end" "match v1, v2 with c1 x1 x2, _ => t | c2 y, d z => u end" "match v1 as y in le _ n, v2 as z in I p q return P n y p q z with c1 x1 x2, _ => t | c2 y, d z => u end" The last example is the new form of what was written "<[n;y:(le ? n);p;q;z:(I p q)](P n y p q z)>Cases v1 v2 of (c1 x1 x2) _ => t | (c2 y) (d z) => u end" Pattern-matching of type with one constructors and no dependencies of the arguments in the resulting type can be written "let (x,y,z) as u return P u := t in v" Local fixpoints are written "fix f (n m:nat) z (x : X) {struct m} : nat := ... with ..." and "struct" tells which argument is structurally decreasing. Explicitation of implicit arguments is written "f @1:=u v @3:=w t" "@f u v w t" 2) Tactics The main change is that tactics names are now lowercase. Besides this, the following renaming are applied: "NewDestruct" -> "destruct" "NewInduction" -> "induction" "Induction" -> "simple induction" "Destruct" -> "simple destruct" For tactics with occurrences, the occurrences now comes after and repeated use is separated by comma as in "Pattern 1 3 c d 4 e" -> "pattern c at 3 1, d, e at 4" "Unfold 1 3 f 4 g" -> "unfold f at 1 3, g at 4" "Simpl 1 3 e" -> "simpl e at 1 3" 3) Tactic language Definitions are now introduced with keyword "Ltac" (instead of "Tactic"/"Meta" "Definition") and are implicitly recursive ("Recursive" is no longer used). The new rule for distinguishing terms from ltac expressions is: Write "ltac:" in front of any tactic in argument position and "constr:" in front of any construction in head position 4) Vernacular language a) Assumptions The syntax for commands is mainly unchanged. Declaration of assumptions is now done as follows Variable m : t. Variables m n p : t. Variables (m n : t) (u v : s) (w : r). b) Definitions Definitions are done as follows Definition f m n : t := ... . Definition f m n := ... . Definition f m n := ... : t. Definition f (m n : u) : t := ... . Definition f (m n : u) := ... : t. Definition f (m n : u) := ... . Definition f a b (p q : v) r s (m n : t) : t := ... . Definition f a b (p q : v) r s (m n : t) := ... . Definition f a b (p q : v) r s (m n : t) := ... : t. c) Fixpoints Fixpoints are done this way Fixpoint f x (y : t) z a (b c : u) {struct z} : v := ... with ... . Fixpoint f x : v := ... . Fixpoint f (x : t) : v := ... . It is possible to give a concrete notation to a fixpoint as follows Fixpoint plus (n m:nat) {struct n} : nat as "n + m" := match n with | O => m | S p => S (p + m) end. d) Inductive types The syntax for inductive types is as follows Inductive t (a b : u) (d : e) : v := c1 : w1 | c2 : w2 | ... . Inductive t (a b : u) (d : e) : v := c1 : w1 | c2 : w2 | ... . Inductive t (a b : u) (d : e) : v := c1 (x y : t) : w1 | c2 (z : r) : w2 | ... . As seen in the last example, arguments of the constructors can be given before the colon. If the type itself is omitted (allowed only in case the inductive type has no real arguments), this yields an ML-style notation as follows Inductive nat : Set := O | S (n:nat). Inductive bool : Set := true | false. It is even possible to define a syntax at the same time, as follows: Inductive or (A B:Prop) : Prop as "A \/ B":= | or_introl (a:A) : A \/ B | or_intror (b:B) : A \/ B. Inductive and (A B:Prop) : Prop as "A /\ B" := conj (a:A) (b:B). coq-8.4pl4/dev/doc/newsyntax.tex0000644000175000017500000005777112326224777015761 0ustar stephsteph %% -*-french-tex-*- \documentclass{article} \usepackage{verbatim} \usepackage[T1]{fontenc} \usepackage[latin1]{inputenc} \usepackage[french]{babel} \usepackage{amsmath} \usepackage{amssymb} \usepackage{array} \author{B.~Barras} \title{Proposition de syntaxe pour Coq} %% Le _ est un caractčre normal \catcode`\_=13 \let\subscr=_ \def_{\ifmmode\sb\else\subscr\fi} %% Macros pour les grammaires \def\NT#1{\langle\textit{#1}\rangle} \def\TERM#1{\textsf{#1}} \def\STAR#1{#1\!*} \def\PLUS#1{#1\!+} %% Tableaux de definition de non-terminaux \newenvironment{cadre} {\begin{array}{|c|}\hline\\} {\\\\\hline\end{array}} \newenvironment{rulebox} {$$\begin{cadre}\begin{array}{r@{~}c@{~}l@{}r}} {\end{array}\end{cadre}$$} \def\DEFNT#1{\NT{#1} & ::= &} \def\EXTNT#1{\NT{#1} & ::= & ... \\&|&} \def\RNAME#1{(\textsc{#1})} \def\SEPDEF{\\\\} \def\nlsep{\\&|&} \begin{document} \maketitle \section{Grammaire des tactiques} \label{tacticsyntax} La réflexion de la rénovation de la syntaxe des tactiques n'est pas encore aussi poussée que pour les termes (section~\ref{constrsyntax}), mais cette section vise ā énoncer les quelques principes que l'on souhaite suivre. \begin{itemize} \item Réutiliser les mots-clés de la syntaxe des termes (i.e. en minuscules) pour les constructions similaires de tactiques (let_in, match, and, etc.). Le connecteur logique \texttt{and} n'étant que rarement utilisé autrement que sous la forme \texttt{$\wedge$} (sauf dans le code ML), on pourrait dégager ce mot-clé. \item Les arguments passés aux tactiques sont principalement des termes, on préconise l'utilisation d'un symbole spécial (par exemple l'apostrophe) pour passer une tactique ou une expression (AST). L'idée étant que l'on écrit plus souvent des tactiques prenant des termes en argument que des tacticals. \end{itemize} \begin{figure} \begin{rulebox} \DEFNT{tactic} \NT{tactic} ~\TERM{\&} ~\NT{tactic} & \RNAME{then} \nlsep \TERM{[} ~\NT{tactic}~\TERM{|}~... ~\TERM{|}~\NT{tactic}~\TERM{]} & \RNAME{par} \nlsep \NT{ident} ~\STAR{\NT{tactic-arg}} ~~~ & \RNAME{apply} \nlsep \TERM{fun} ~.... & \RNAME{function} \nlsep \NT{simple-tactic} \SEPDEF \DEFNT{tactic-arg} \NT{constr} \nlsep \TERM{'} ~\NT{tactic} \SEPDEF \DEFNT{simple-tactic} \TERM{Apply} ~\NT{binding-term} \nlsep \NT{elim-kw} ~\NT{binding-term} \nlsep \NT{elim-kw} ~\NT{binding-term} ~\TERM{using} ~\NT{binding-term} \nlsep \TERM{Intros} ~\NT{intro-pattern} \SEPDEF \DEFNT{elim-kw} \TERM{Elim} ~\mid~ \TERM{Case} ~\mid~ \TERM{Induction} ~\mid~ \TERM{Destruct} \end{rulebox} \caption{Grammaire des tactiques} \label{tactic} \end{figure} \subsection{Arguments de tactiques} La syntaxe actuelle des arguments de tactiques est que l'on parse par défaut une expression de tactique, ou bien l'on parse un terme si celui-ci est préfixé par \TERM{'} (sauf dans le cas des variables). Cela est gęnant pour les utilisateurs qui doivent écrire des \TERM{'} pour leurs tactiques. Ā mon avis, il n'est pas souhaitable pour l'utilisateur de l'obliger ā marquer une différence entre les tactiques ``primitives'' (en fait ``systčme'') et les tactiques définies par Ltac. En effet, on se dirige inévitablement vers une situation oų il existera des librairies de tactiques et il va devenir difficile de savoir facilement s'il faut ou non mettre des \TERM{'}. \subsection{Bindings} Dans un premier temps, les ``bindings'' sont toujours considérés comme une construction du langage des tactiques, mais il est intéressant de prévoir l'extension de ce procédé aux termes, puisqu'il s'agit simplement de construire un n{\oe}ud d'application dans lequel on donne les arguments par nom ou par position, les autres restant ā inférer. Le principal point est de trouver comment combiner de maničre uniforme ce procédé avec les arguments implicites. Il est toutefois important de réfléchir dčs maintenant ā une syntaxe pour éviter de rechanger encore la syntaxe. Intégrer la notation \TERM{with} aux termes peut poser des problčmes puisque ce mot-clé est utilisé pour le filtrage: comment parser (en LL(1)) l'expression: \begin{verbatim} Cases x with y ... \end{verbatim} Soit on trouve un autre mot-clé, soit on joue avec les niveaus de priorité en obligeant a parenthéser le \TERM{with} des ``bindings'': \begin{verbatim} Cases (x with y) with (C z) => ... \end{verbatim} ce qui introduit un constructeur moralement équivalent ā une application situé ā une priorité totalement différente (les ``bindings'' seraient au plus haut niveau alors que l'application est ā un niveau bas). \begin{figure} \begin{rulebox} \DEFNT{binding-term} \NT{constr} ~\TERM{with} ~\STAR{\NT{binding}} \SEPDEF \DEFNT{binding} \NT{constr} \end{rulebox} \caption{Grammaire des bindings} \label{bindings} \end{figure} \subsection{Enregistrements} Il faudrait aménager la syntaxe des enregistrements dans l'optique d'avoir des enregistrements anonymes (termes de premičre classe), męme si pour l'instant, on ne dispose que d'enregistrements définis a toplevel. Exemple de syntaxe pour les types d'enregistrements: \begin{verbatim} { x1 : A1; x2 : A2(x1); _ : T; (* Pas de projection disponible *) y; (* Type infere *) ... (* ; optionnel pour le dernier champ *) } \end{verbatim} Exemple de syntaxe pour le constructeur: \begin{verbatim} { x1 = O; x2 : A2(x1) = v1; _ = v2; ... } \end{verbatim} Quant aux dépendences, une convention pourrait ętre de considérer les champs non annotés par le type comme non dépendants. Plusieurs interrogations: \begin{itemize} \item l'ordre des champs doit-il ętre respecté ? sinon, que faire pour les champs sans projection ? \item autorise-t-on \texttt{v1} a mentionner \texttt{x1} (comme dans la définition d'un module), ce qui se comporterait comme si on avait écrit \texttt{v1} ā la place. Cela pourrait ętre une autre maničre de déclarer les dépendences \end{itemize} La notation pointée pour les projections pose un problčme de parsing, sauf si l'on a une convention lexicale qui discrimine les noms de modules des projections et identificateurs: \texttt{x.y.z} peut ętre compris comme \texttt{(x.y).z} ou texttt{x.(y.z)}. \section{Grammaire des termes} \label{constrsyntax} \subsection{Quelques principes} \begin{enumerate} \item Diminuer le nombre de niveaux de priorité en regroupant les rčgles qui se ressemblent: infixes, préfixes, lieurs (constructions ouvertes ā droite), etc. \item Éviter de surcharger la signification d'un symbole (ex: \verb+( )+ comme parenthésage et produit dans la V7). \item Faire en sorte que les membres gauches (motifs de Cases, lieurs d'abstraction ou de produits) utilisent une syntaxe compatible avec celle des membres droits (branches de Cases et corps de fonction). \end{enumerate} \subsection{Présentation de la grammaire} \begin{figure} \begin{rulebox} \DEFNT{paren-constr} \NT{cast-constr}~\TERM{,}~\NT{paren-constr} &\RNAME{pair} \nlsep \NT{cast-constr} \SEPDEF \DEFNT{cast-constr} \NT{constr}~\TERM{\!\!:}~\NT{cast-constr} &\RNAME{cast} \nlsep \NT{constr} \SEPDEF \DEFNT{constr} \NT{appl-constr}~\NT{infix}~\NT{constr} &\RNAME{infix} \nlsep \NT{prefix}~\NT{constr} &\RNAME{prefix} \nlsep \NT{constr}~\NT{postfix} &\RNAME{postfix} \nlsep \NT{appl-constr} \SEPDEF \DEFNT{appl-constr} \NT{appl-constr}~\PLUS{\NT{appl-arg}} &\RNAME{apply} \nlsep \TERM{@}~\NT{global}~\PLUS{\NT{simple-constr}} &\RNAME{expl-apply} \nlsep \NT{simple-constr} \SEPDEF \DEFNT{appl-arg} \TERM{@}~\NT{int}~\TERM{\!:=}~\NT{simple-constr} &\RNAME{impl-arg} \nlsep \NT{simple-constr} \SEPDEF \DEFNT{simple-constr} \NT{atomic-constr} \nlsep \TERM{(}~\NT{paren-constr}~\TERM{)} \nlsep \NT{match-constr} \nlsep \NT{fix-constr} %% \nlsep \TERM{<\!\!:ast\!\!:<}~\NT{ast}~\TERM{>\!>} &\RNAME{quotation} \end{rulebox} \caption{Grammaire des termes} \label{constr} \end{figure} \begin{figure} \begin{rulebox} \DEFNT{prefix} \TERM{!}~\PLUS{\NT{binder}}~\TERM{.}~ &\RNAME{prod} \nlsep \TERM{fun} ~\PLUS{\NT{binder}} ~\TERM{$\Rightarrow$} &\RNAME{lambda} \nlsep \TERM{let}~\NT{ident}~\STAR{\NT{binder}} ~\TERM{=}~\NT{constr} ~\TERM{in} &\RNAME{let} %\nlsep \TERM{let (}~\NT{comma-ident-list}~\TERM{) =}~\NT{constr} % ~\TERM{in} &~~~\RNAME{let-case} \nlsep \TERM{if}~\NT{constr}~\TERM{then}~\NT{constr}~\TERM{else} &\RNAME{if-case} \nlsep \TERM{eval}~\NT{red-fun}~\TERM{in} &\RNAME{eval} \SEPDEF \DEFNT{infix} \TERM{$\rightarrow$} & \RNAME{impl} \SEPDEF \DEFNT{atomic-constr} \TERM{_} \nlsep \TERM{?}\NT{int} \nlsep \NT{sort} \nlsep \NT{global} \SEPDEF \DEFNT{binder} \NT{ident} &\RNAME{infer} \nlsep \TERM{(}~\NT{ident}~\NT{type}~\TERM{)} &\RNAME{binder} \SEPDEF \DEFNT{type} \TERM{\!:}~\NT{constr} \nlsep \epsilon \end{rulebox} \caption{Grammaires annexes aux termes} \label{gram-annexes} \end{figure} La grammaire des termes (correspondant ā l'état \texttt{barestate}) est décrite figures~\ref{constr} et~\ref{gram-annexes}. On constate par rapport aux précédentes versions de Coq d'importants changements de priorité, le plus marquant étant celui de l'application qui se trouve désormais juste au dessus\footnote{La convention est de considérer les opérateurs moins lieurs comme ``au dessus'', c'est-ā-dire ayant un niveau de priorité plus élévé (comme c'est le cas avec le niveau de la grammaire actuelle des termes).} des constructions fermées ā gauche et ā droite. La grammaire des noms globaux est la suivante: \begin{eqnarray*} \DEFNT{global} \NT{ident} %% \nlsep \TERM{\$}\NT{ident} \nlsep \NT{ident}\TERM{.}\NT{global} \end{eqnarray*} Le $\TERM{_}$ dénote les termes ā synthétiser. Les métavariables sont reconnues au niveau du lexer pour ne pas entrer en conflit avec le $\TERM{?}$ de l'existentielle. Les opérateurs infixes ou préfixes sont tous au męme niveau de priorité du point de vue de Camlp4. La solution envisagée est de les gérer ā la maničre de Yacc, avec une pile (voir discussions plus bas). Ainsi, l'implication est un infixe normal; la quantification universelle et le let sont vus comme des opérateurs préfixes avec un niveau de priorité plus haut (i.e. moins lieur). Il subsiste des problčmes si l'on ne veut pas écrire de parenthčses dans: \begin{verbatim} A -> (!x. B -> (let y = C in D)) \end{verbatim} La solution proposée est d'analyser le membre droit d'un infixe de maničre ā autoriser les préfixes et les infixes de niveau inférieur, et d'exiger le parenthésage que pour les infixes de niveau supérieurs. En revanche, ā l'affichage, certains membres droits seront plus lisibles s'ils n'utilisent pas cette astuce: \begin{verbatim} (fun x => x) = fun x => x \end{verbatim} La proposition est d'autoriser ce type d'écritures au parsing, mais l'afficheur écrit de maničre standardisée en mettant quelques parenthčses superflues: $\TERM{=}$ serait symétrique alors que $\rightarrow$ appellerait l'afficheur de priorité élevée pour son sous-terme droit. Les priorités des opérateurs primitifs sont les suivantes (le signe $*$ signifie que pour le membre droit les opérateurs préfixes seront affichés sans parenthčses quel que soit leur priorité): $$ \begin{array}{c|l} $symbole$ & $priorité$ \\ \hline \TERM{!} & 200\,R* \\ \TERM{fun} & 200\,R* \\ \TERM{let} & 200\,R* \\ \TERM{if} & 200\,R \\ \TERM{eval} & 200\,R \\ \rightarrow & 90\,R* \end{array} $$ Il y a deux points d'entrée pour les termes: $\NT{constr}$ et $\NT{simple-constr}$. Le premier peut ętre utilisé lorsqu'il est suivi d'un séparateur particulier. Dans le cas oų l'on veut une liste de termes séparés par un espace, il faut lire des $\NT{simple-constr}$. Les constructions $\TERM{fix}$ et $\TERM{cofix}$ (voir aussi figure~\ref{gram-fix}) sont fermées par end pour simplifier l'analyse. Sinon, une expression de point fixe peut ętre suivie par un \TERM{in} ou un \TERM{and}, ce qui pose les męmes problčmes que le ``dangling else'': dans \begin{verbatim} fix f1 x {x} = fix f2 y {y} = ... and ... in ... \end{verbatim} il faut définir une stratégie pour associer le \TERM{and} et le \TERM{in} au bon point fixe. Un autre avantage est de faire apparaitre que le \TERM{fix} est un constructeur de terme de premičre classe et pas un lieur: \begin{verbatim} fix f1 ... and f2 ... in f1 end x \end{verbatim} Les propositions précédentes laissaient \texttt{f1} et \texttt{x} accolés, ce qui est source de confusion lorsque l'on fait par exemple \texttt{Pattern (f1 x)}. Les corps de points fixes et co-points fixes sont identiques, bien que ces derniers n'aient pas d'information de décroissance. Cela fonctionne puisque l'annotation est optionnelle. Cela préfigure des cas oų l'on arrive ā inférer quel est l'argument qui décroit structurellement (en particulier dans le cas oų il n'y a qu'un seul argument). \begin{figure} \begin{rulebox} \DEFNT{fix-expr} \TERM{fix}~\NT{fix-decls} ~\NT{fix-select} ~\TERM{end} &\RNAME{fix} \nlsep \TERM{cofix}~\NT{cofix-decls}~\NT{fix-select} ~\TERM{end} &\RNAME{cofix} \SEPDEF \DEFNT{fix-decls} \NT{fix-decl}~\TERM{and}~\NT{fix-decls} \nlsep \NT{fix-decl} \SEPDEF \DEFNT{fix-decl} \NT{ident}~\PLUS{\NT{binder}}~\NT{type}~\NT{annot} ~\TERM{=}~\NT{constr} \SEPDEF \DEFNT{annot} \TERM{\{}~\NT{ident}~\TERM{\}} \nlsep \epsilon \SEPDEF \DEFNT{fix-select} \TERM{in}~\NT{ident} \nlsep \epsilon \end{rulebox} \caption{Grammaires annexes des points fixes} \label{gram-fix} \end{figure} La construction $\TERM{Case}$ peut-ętre considérée comme obsolčte. Quant au $\TERM{Match}$ de la V6, il disparaît purement et simplement. \begin{figure} \begin{rulebox} \DEFNT{match-expr} \TERM{match}~\NT{case-items}~\NT{case-type}~\TERM{with}~ \NT{branches}~\TERM{end} &\RNAME{match} \nlsep \TERM{match}~\NT{case-items}~\TERM{with}~ \NT{branches}~\TERM{end} &\RNAME{infer-match} %%\nlsep \TERM{case}~\NT{constr}~\NT{case-predicate}~\TERM{of}~ %% \STAR{\NT{constr}}~\TERM{end} &\RNAME{case} \SEPDEF \DEFNT{case-items} \NT{case-item} ~\TERM{\&} ~\NT{case-items} \nlsep \NT{case-item} \SEPDEF \DEFNT{case-item} \NT{constr}~\NT{pred-pattern} &\RNAME{dep-case} \nlsep \NT{constr} &\RNAME{nodep-case} \SEPDEF \DEFNT{case-type} \TERM{$\Rightarrow$}~\NT{constr} \nlsep \epsilon \SEPDEF \DEFNT{pred-pattern} \TERM{as}~\NT{ident} ~\TERM{\!:}~\NT{constr} \SEPDEF \DEFNT{branches} \TERM{|} ~\NT{patterns} ~\TERM{$\Rightarrow$} ~\NT{constr} ~\NT{branches} \nlsep \epsilon \SEPDEF \DEFNT{patterns} \NT{pattern} ~\TERM{\&} ~\NT{patterns} \nlsep \NT{pattern} \SEPDEF \DEFNT{pattern} ... \end{rulebox} \caption{Grammaires annexes du filtrage} \label{gram-match} \end{figure} De maničre globale, l'introduction de définitions dans les termes se fait avec le symbole $=$, et le $\!:=$ est réservé aux définitions au niveau vernac. Il y avait un manque de cohérence dans la V6, puisque l'on utilisait $=$ pour le $\TERM{let}$ et $\!:=$ pour les points fixes et les commandes vernac. % OBSOLETE: lieurs multiples supprimes %On peut remarquer que $\NT{binder}$ est un sous-ensemble de %$\NT{simple-constr}$, ā l'exception de $\texttt{(a,b\!\!:T)}$: en tant %que lieur, {\tt a} et {\tt b} sont tous deux contraints, alors qu'en %tant que terme, seul {\tt b} l'est. Cela qui signifie que l'objectif %de rendre compatibles les membres gauches et droits est {\it presque} %atteint. \subsection{Infixes} \subsubsection{Infixes extensibles} Le problčme de savoir si la liste des symboles pouvant apparaître en infixe est fixée ou extensible par l'utilisateur reste ā voir. Notons que la solution oų les symboles infixes sont des identificateurs que l'on peut définir paraît difficilement praticable: par exemple $\texttt{Logic.eq}$ n'est pas un opérateur binaire, mais ternaire. Il semble plus simple de garder des déclarations infixes qui relient un symbole infixe ā un terme avec deux ``trous''. Par exemple: $$\begin{array}{c|l} $infixe$ & $identificateur$ \\ \hline = & \texttt{Logic.eq _ ?1 ?2} \\ == & \texttt{JohnMajor.eq _ ?1 _ ?2} \end{array}$$ La syntaxe d'une déclaration d'infixe serait par exemple: \begin{verbatim} Infix "=" 50 := Logic.eq _ ?1 ?2; \end{verbatim} \subsubsection{Gestion des précédences} Les infixes peuvent ętre soit laissé ā Camlp4, ou bien (comme ici) considérer que tous les opérateurs ont la męme précédence et gérer soit męme la recomposition des termes ā l'aide d'une pile (comme Yacc). \subsection{Extensions de syntaxe} \subsubsection{Litéraux numériques} La proposition est de considerer les litéraux numériques comme de simples identificateurs. Comme il en existe une infinité, il faut un nouveau mécanisme pour leur associer une définition. Par exemple, en ce qui concerne \texttt{Arith}, la définition de $5$ serait $\texttt{S}~4$. Pour \texttt{ZArith}, $5$ serait $\texttt{xI}~2$. Comme les infixes, les constantes numériques peuvent ętre qualifiées pour indiquer dans quels module est le type que l'on veut référencer. Par exemple (si on renomme \texttt{Arith} en \texttt{N} et \texttt{ZArith} en \texttt{Z}): \verb+N.5+, \verb+Z.5+. \begin{eqnarray*} \EXTNT{global} \NT{int} \end{eqnarray*} \subsubsection{Nouveaux lieurs} $$ \begin{array}{rclr} \EXTNT{constr} \TERM{ex}~\PLUS{\NT{binder}}~\TERM{.}~\NT{constr} &\RNAME{ex} \nlsep \TERM{ex}~\PLUS{\NT{binder}}~\TERM{.}~\NT{constr}~\TERM{,}~\NT{constr} &\RNAME{ex2} \nlsep \TERM{ext}~\PLUS{\NT{binder}}~\TERM{.}~\NT{constr} &\RNAME{exT} \nlsep \TERM{ext}~\PLUS{\NT{binder}}~\TERM{.}~\NT{constr}~\TERM{,}~\NT{constr} &\RNAME{exT2} \end{array} $$ Pour l'instant l'existentielle n'admet qu'une seule variable, ce qui oblige ā écrire des cascades de $\TERM{ex}$. Pour parser les existentielles avec deux prédicats, on peut considérer \TERM{\&} comme un infixe intermédiaire et l'opérateur existentiel en présence de cet infixe se transforme en \texttt{ex2}. \subsubsection{Nouveaux infixes} Précédences des opérateurs infixes (les plus grands associent moins fort): $$ \begin{array}{l|l|c|l} $identificateur$ & $module$ & $infixe/préfixe$ & $précédence$ \\ \hline \texttt{iff} & $Logic$ & \longleftrightarrow & 100 \\ \texttt{or} & $Logic$ & \vee & 80\, R \\ \texttt{sum} & $Datatypes$ & + & 80\, R \\ \texttt{and} & $Logic$ & \wedge & 70\, R \\ \texttt{prod} & $Datatypes$ & * & 70\, R \\ \texttt{not} & $Logic$ & \tilde{} & 60\, L \\ \texttt{eq _} & $Logic$ & = & 50 \\ \texttt{eqT _} & $Logic_Type$ & = & 50 \\ \texttt{identityT _} & $Data_Type$ & = & 50 \\ \texttt{le} & $Peano$ & $<=$ & 50 \\ \texttt{lt} & $Peano$ & $<$ & 50 \\ \texttt{ge} & $Peano$ & $>=$ & 50 \\ \texttt{gt} & $Peano$ & $>$ & 50 \\ \texttt{Zle} & $zarith_aux$ & $<=$ & 50 \\ \texttt{Zlt} & $zarith_aux$ & $<$ & 50 \\ \texttt{Zge} & $zarith_aux$ & $>=$ & 50 \\ \texttt{Zgt} & $zarith_aux$ & $>$ & 50 \\ \texttt{Rle} & $Rdefinitions$ & $<=$ & 50 \\ \texttt{Rlt} & $Rdefinitions$ & $<$ & 50 \\ \texttt{Rge} & $Rdefinitions$ & $>=$ & 50 \\ \texttt{Rgt} & $Rdefinitions$ & $>$ & 50 \\ \texttt{plus} & $Peano$ & + & 40\,L \\ \texttt{Zplus} & $fast_integer$ & + & 40\,L \\ \texttt{Rplus} & $Rdefinitions$ & + & 40\,L \\ \texttt{minus} & $Minus$ & - & 40\,L \\ \texttt{Zminus} & $zarith_aux$ & - & 40\,L \\ \texttt{Rminus} & $Rdefinitions$ & - & 40\,L \\ \texttt{Zopp} & $fast_integer$ & - & 40\,L \\ \texttt{Ropp} & $Rdefinitions$ & - & 40\,L \\ \texttt{mult} & $Peano$ & * & 30\,L \\ \texttt{Zmult} & $fast_integer$ & * & 30\,L \\ \texttt{Rmult} & $Rdefinitions$ & * & 30\,L \\ \texttt{Rdiv} & $Rdefinitions$ & / & 30\,L \\ \texttt{pow} & $Rfunctions$ & \hat & 20\,L \\ \texttt{fact} & $Rfunctions$ & ! & 20\,L \\ \end{array} $$ Notons qu'il faudrait découper {\tt Logic_Type} en deux car celui-ci définit deux égalités, ou alors les mettre dans des modules différents. \subsection{Exemples} \begin{verbatim} Definition not (A:Prop) := A->False; Inductive eq (A:Set) (x:A) : A->Prop := refl_equal : eq A x x; Inductive ex (A:Set) (P:A->Prop) : Prop := ex_intro : !x. P x -> ex A P; Lemma not_all_ex_not : !(P:U->Prop). ~(!n. P n) -> ?n. ~ P n; Fixpoint plus n m : nat {struct n} := match n with O => m | (S k) => S (plus k m) end; \end{verbatim} \subsection{Questions ouvertes} Voici les points sur lesquels la discussion est particuličrement ouverte: \begin{itemize} \item choix d'autres symboles pour les quantificateurs \TERM{!} et \TERM{?}. En l'état actuel des discussions, on garderait le \TERM{!} pour la qunatification universelle, mais on choisirait quelquechose comme \TERM{ex} pour l'existentielle, afin de ne pas suggérer trop de symétrie entre ces quantificateurs (l'un est primitif, l'autre pas). \item syntaxe particuličre pour les \texttt{sig}, \texttt{sumor}, etc. \item la possibilité d'introduire plusieurs variables du męme type est pour l'instant supprimée au vu des problčmes de compatibilité de syntaxe entre les membres gauches et membres droits. L'idée étant que l'inference de type permet d'éviter le besoin de déclarer tous les types. \end{itemize} \subsection{Autres extensions} \subsubsection{Lieur multiple} L'écriture de types en présence de polymorphisme est souvent assez pénible: \begin{verbatim} Check !(A:Set) (x:A) (B:Set) (y:B). P A x B y; \end{verbatim} On pourrait avoir des déclarations introduisant ā la fois un type d'une certaine sorte et une variable de ce type: \begin{verbatim} Check !(x:A:Set) (y:B:Set). P A x B y; \end{verbatim} Noter que l'on aurait pu écrire: \begin{verbatim} Check !A x B y. P A (x:A:Set) B (y:B:Set); \end{verbatim} \section{Syntaxe des tactiques} \subsection{Questions diverses} Changer ``Pattern nl c ... nl c'' en ``Pattern [ nl ] c ... [ nl ] c'' pour permettre des chiffres seuls dans la catégorie syntaxique des termes. Par uniformité remplacer ``Unfold nl c'' par ``Unfold [ nl ] c'' ? Męme problčme pour l'entier de Specialize (ou virer Specialize ?) ? \subsection{Questions en suspens} \verb=EAuto= : deux syntaxes différentes pour la recherche en largeur et en profondeur ? Quelle recherche par défaut ? \section*{Remarques pęle-męle (HH)} Autoriser la syntaxe \begin{verbatim} Variable R (a : A) (b : B) : Prop. Hypotheses H (a : A) (b : B) : Prop; Y (u : U) : V. Variables H (a : A) (b : B), J (k : K) : nat; Z (v : V) : Set. \end{verbatim} Renommer eqT, refl_eqT, eqT_ind, eqT_rect, eqT_rec en eq, refl_equal, etc. Remplacer == en =. Mettre des \verb=?x= plutot que des \verb=?1= dans les motifs de ltac ?? \section{Moulinette} \begin{itemize} \item Mettre \verb=/= et * au męme niveau dans R. \item Changer la précédence du - unaire dans R. \item Ajouter Require Arith par necessite si Require ArithRing ou Require ZArithRing. \item Ajouter Require ZArith par necessite si Require ZArithRing ou Require Omega. \item Enlever le Export de Bool, Arith et ZARith de Ring quand inapproprié et l'ajouter ā côté des Require Ring. \item Remplacer "Check n" par "n:Check ..." \item Renommer Variable/Hypothesis hors section en Parameter/Axiom. \item Renommer les \verb=command0=, \verb=command1=, ... \verb=lcommand= etc en \verb=constr0=, \verb=constr1=, ... \verb=lconstr=. \item Remplacer les noms Coq.omega.Omega par Coq.Omega ... \item Remplacer AddPath par Add LoadPath (ou + court) \item Unify + and \{\}+\{\} and +\{\} using Prop $\leq$ Set ?? \item Remplacer Implicit Arguments On/Off par Set/Unset Implicit Arguments. \item La syntaxe \verb=Intros (a,b)= est inutile, \verb=Intros [a b]= fait l'affaire. \item Virer \verb=Goal= sans argument (synonyme de \verb=Proof= et sans effets). \item Remplacer Save. par Qed. \item Remplacer \verb=Zmult_Zplus_distr= par \verb=Zmult_plus_distr_r= et \verb=Zmult_plus_distr= par \verb=Zmult_plus_distr_l=. \end{itemize} \end{document} coq-8.4pl4/dev/doc/build-system.dev.txt0000644000175000017500000001340412326224777017117 0ustar stephsteph Since July 2007, Coq features a build system overhauled by Pierre Corbineau and Lionel Elie Mamane. --------------------------------------------------------------------- WARNING: In March 2010 this build system has been heavily adapted by Pierre Letouzey. In particular there no more explicit stage1,2. Stage3 was removed some time ago when coqdep was splitted into coqdep_boot and full coqdep. Ideas are still similar to what is describe below, but: 1) .ml4 are explicitely turned into .ml files, which stay after build 2) we let "make" handle the inclusion of .d without trying to guess what could be done at what time. Some initial inclusions hence _fail_, but "make" tries again later and succeed. TODO: remove obsolete sections below and better describe the new approach ----------------------------------------------------------------------- This file documents internals of the implementation of the build system. For what a Coq developer needs to know about the build system, see build-system.txt . .ml4 files ---------- .ml files corresponding to .ml4 files are created to keep ocamldep happy only. To ensure they are not used for compilation, they contain invalid OCaml. multi-stage build ----------------- Le processus de construction est sÃĐparÃĐ en trois ÃĐtapes qui correspondent aux outils nÃĐcessaires pour calculer les dÃĐpendances de cette ÃĐtape: stage1: ocamldep, sed , camlp4 sans fichiers de Coq stage2: camlp4 avec grammar.cma et/ou q_constr.cmo stage3: coqdep (.vo) Le Makefile a ÃĐtÃĐ sÃĐparÃĐ en plusieurs fichiers : - Makefile: coquille vide qui dÃĐlÃĻgue les cibles à la bonne ÃĐtape sauf clean et les fichiers pour emacs (car ils sont en quelque sorte en "stage0": aucun calcul de dÃĐpendance nÃĐcessaire). - Makefile.common : dÃĐfinitions des variables (essentiellement des listes de fichiers) - Makefile.build : les rÃĻgles de compilation sans inclure de dÃĐpendances - Makefile.stage* : fichiers qui incluent les dÃĐpendances calculables à cette ÃĐtape ainsi que Makefile.build. The build needs to be cut in stages because make will not take into account one include when making another include. ParallÃĐlisation --------------- Le dÃĐcoupage en ÃĐtapes veut dire que le makefile est un petit peu moins parallÃĐlisable que strictement possible en thÃĐorie: par exemple, certaines choses faites en stage2 pourraient Être faites en parallÃĻle avec des choses de stage1. Nous essayons de minimiser cet effet, mais nous ne l'avons pas complÃĻtement ÃĐliminÃĐ parce que cela mÃĻnerait à un makefile trÃĻs complexe. La minimisation est principalement que si on demande un objet spÃĐcifique (par exemple "make parsing/g_constr.cmx"), il est fait dans l'ÃĐtape la plus basse possible (simplement), mais si un objet est fait comme dÃĐpendance de la cible demandÃĐe (par exemple dans un "make world"), il est fait le plus tard possible (par exemple, tout code OCaml non nÃĐcessaire pour coqdep ni grammar.cma ni q_constr.cmo est compilÃĐ en stage3 lors d'un "make world"; cela permet le parallÃĐlisme de compilation de code OCaml et de fichiers Coq (.v)). Le "(simplement)" ci-dessus veut dire que savoir si un fichier non nÃĐcessaire pour grammar.cma/q_constr.cmo peut en fait Être fait en stage1 est compliquÃĐ avec make, alors nous retombons en gÃĐnÃĐral sur le stage2. La sÃĐparation entre le stage2 et stage3 est plus facile, donc l'optimisation ci-dessus s'y applique pleinement. En d'autres mots, nous avons au niveau conceptuel deux assignations d'ÃĐtape pour chaque fichier: - l'ÃĐtape la plus petite oÃđ nous savons qu'il peut Être fait. - l'ÃĐtape la plus grande oÃđ il peut Être fait. Mais seule la premiÃĻre est gÃĐrÃĐe explicitement, la seconde est implicite. FIND_VCS_CLAUSE --------------- The recommended style of using FIND_VCS_CLAUSE is for example find . $(FIND_VCS_CLAUSE) '(' -name '*.example' ')' -print find . $(FIND_VCS_CLAUSE) '(' -name '*.example' -or -name '*.foo' ')' -print 1) The parentheses even in the one-criteria case is so that if one adds other conditions, e.g. change the first example to the second find . $(FIND_VCS_CLAUSE) '(' -name '*.example' -and -not -name '*.bak.example' ')' -print one is not tempted to write find . $(FIND_VCS_CLAUSE) -name '*.example' -and -not -name '*.bak.example' -print because this will not necessarily work as expected; $(FIND_VCS_CLAUSE) ends with an -or, and how it combines with what comes later depends on operator precedence and all that. Much safer to override it with parentheses. In short, it protects against the -or one doesn't see. 2) As to the -print at the end, yes it is necessary. Here's why. You are used to write: find . -name '*.example' and it works fine. But the following will not: find . $(FIND_VCS_CLAUSE) -name '*.example' it will also list things directly matched by FIND_VCS_CLAUSE (directories we want to prune, in which we don't want to find anything). C'est subtil... Il y a effectivement un -print implicite à la fin, qui fait que la commande habituelle sans print fonctionne bien, mais dÃĻs que l'on introduit d'autres commandes dans le lot (le -prune de FIND_VCS_CLAUSE), ça se corse à cause d'histoires de parenthÃĻses du -print implicite par rapport au parenthÃĐsage dans la forme recommandÃĐe d'utilisation: Si on explicite le -print et les parenthÃĻses implicites, cela devient: find . '(' '(' '(' -name .git -or -name debian ')' -prune ')' -or \ '(' -name '*.example' ')' ')' -print Le print agit TOUT ce qui prÃĐcÃĻde, soit sur ce qui matche "'(' -name .git -or -name debian ')'" ET sur ce qui matche "'(' -name '*.example' ')'". alors qu'ajouter le print explicite change cela en find . '(' '(' -name .git -or -name debian ')' -prune ')' -or \ '(' '(' -name '*.example' ')' -print ')' Le print n'agit plus que sur ce qui matche "'(' -name '*.example' ')'" coq-8.4pl4/dev/doc/about-hints0000644000175000017500000002474112326224777015346 0ustar stephstephAn investigation of how ZArith lemmas could be classified in different automation classes - Reversible lemmas relating operators (to be declared as hints but needing precedences) - Equivalent notions (one has to be considered as primitive and the other rewritten into the canonical one) - Isomorphisms between structure (one structure has to be considered as more primitive than the other for a give operator) - Irreversible simplifications (to be declared with precedences) - Reversible bottom-up simplifications (to be used in hypotheses) - Irreversible bottom-up simplifications (to be used in hypotheses with precedences) - Rewriting rules (relevant for autorewrite, or for an improved auto) Note: this analysis, made in 2001, was previously stored in theories/ZArith/Zhints.v. It has been moved here to avoid obfuscating the standard library. (**********************************************************************) (** * Reversible lemmas relating operators *) (** Probably to be declared as hints but need to define precedences *) (** ** Conversion between comparisons/predicates and arithmetic operators *) (** Lemmas ending by eq *) (** << Zegal_left: (x,y:Z)`x = y`->`x+(-y) = 0` Zabs_eq: (x:Z)`0 <= x`->`|x| = x` Zeven_div2: (x:Z)(Zeven x)->`x = 2*(Zdiv2 x)` Zodd_div2: (x:Z)`x >= 0`->(Zodd x)->`x = 2*(Zdiv2 x)+1` >> *) (** Lemmas ending by Zgt *) (** << Zgt_left_rev: (x,y:Z)`x+(-y) > 0`->`x > y` Zgt_left_gt: (x,y:Z)`x > y`->`x+(-y) > 0` >> *) (** Lemmas ending by Zlt *) (** << Zlt_left_rev: (x,y:Z)`0 < y+(-x)`->`x < y` Zlt_left_lt: (x,y:Z)`x < y`->`0 < y+(-x)` Zlt_O_minus_lt: (n,m:Z)`0 < n-m`->`m < n` >> *) (** Lemmas ending by Zle *) (** << Zle_left: (x,y:Z)`x <= y`->`0 <= y+(-x)` Zle_left_rev: (x,y:Z)`0 <= y+(-x)`->`x <= y` Zlt_left: (x,y:Z)`x < y`->`0 <= y+(-1)+(-x)` Zge_left: (x,y:Z)`x >= y`->`0 <= x+(-y)` Zgt_left: (x,y:Z)`x > y`->`0 <= x+(-1)+(-y)` >> *) (** ** Conversion between nat comparisons and Z comparisons *) (** Lemmas ending by eq *) (** << inj_eq: (x,y:nat)x=y->`(inject_nat x) = (inject_nat y)` >> *) (** Lemmas ending by Zge *) (** << inj_ge: (x,y:nat)(ge x y)->`(inject_nat x) >= (inject_nat y)` >> *) (** Lemmas ending by Zgt *) (** << inj_gt: (x,y:nat)(gt x y)->`(inject_nat x) > (inject_nat y)` >> *) (** Lemmas ending by Zlt *) (** << inj_lt: (x,y:nat)(lt x y)->`(inject_nat x) < (inject_nat y)` >> *) (** Lemmas ending by Zle *) (** << inj_le: (x,y:nat)(le x y)->`(inject_nat x) <= (inject_nat y)` >> *) (** ** Conversion between comparisons *) (** Lemmas ending by Zge *) (** << not_Zlt: (x,y:Z)~`x < y`->`x >= y` Zle_ge: (m,n:Z)`m <= n`->`n >= m` >> *) (** Lemmas ending by Zgt *) (** << Zle_gt_S: (n,p:Z)`n <= p`->`(Zs p) > n` not_Zle: (x,y:Z)~`x <= y`->`x > y` Zlt_gt: (m,n:Z)`m < n`->`n > m` Zle_S_gt: (n,m:Z)`(Zs n) <= m`->`m > n` >> *) (** Lemmas ending by Zlt *) (** << not_Zge: (x,y:Z)~`x >= y`->`x < y` Zgt_lt: (m,n:Z)`m > n`->`n < m` Zle_lt_n_Sm: (n,m:Z)`n <= m`->`n < (Zs m)` >> *) (** Lemmas ending by Zle *) (** << Zlt_ZERO_pred_le_ZERO: (x:Z)`0 < x`->`0 <= (Zpred x)` not_Zgt: (x,y:Z)~`x > y`->`x <= y` Zgt_le_S: (n,p:Z)`p > n`->`(Zs n) <= p` Zgt_S_le: (n,p:Z)`(Zs p) > n`->`n <= p` Zge_le: (m,n:Z)`m >= n`->`n <= m` Zlt_le_S: (n,p:Z)`n < p`->`(Zs n) <= p` Zlt_n_Sm_le: (n,m:Z)`n < (Zs m)`->`n <= m` Zlt_le_weak: (n,m:Z)`n < m`->`n <= m` Zle_refl: (n,m:Z)`n = m`->`n <= m` >> *) (** ** Irreversible simplification involving several comparaisons *) (** useful with clear precedences *) (** Lemmas ending by Zlt *) (** << Zlt_le_reg :(a,b,c,d:Z)`a < b`->`c <= d`->`a+c < b+d` Zle_lt_reg : (a,b,c,d:Z)`a <= b`->`c < d`->`a+c < b+d` >> *) (** ** What is decreasing here ? *) (** Lemmas ending by eq *) (** << Zplus_minus: (n,m,p:Z)`n = m+p`->`p = n-m` >> *) (** Lemmas ending by Zgt *) (** << Zgt_pred: (n,p:Z)`p > (Zs n)`->`(Zpred p) > n` >> *) (** Lemmas ending by Zlt *) (** << Zlt_pred: (n,p:Z)`(Zs n) < p`->`n < (Zpred p)` >> *) (**********************************************************************) (** * Useful Bottom-up lemmas *) (** ** Bottom-up simplification: should be used *) (** Lemmas ending by eq *) (** << Zeq_add_S: (n,m:Z)`(Zs n) = (Zs m)`->`n = m` Zsimpl_plus_l: (n,m,p:Z)`n+m = n+p`->`m = p` Zplus_unit_left: (n,m:Z)`n+0 = m`->`n = m` Zplus_unit_right: (n,m:Z)`n = m+0`->`n = m` >> *) (** Lemmas ending by Zgt *) (** << Zsimpl_gt_plus_l: (n,m,p:Z)`p+n > p+m`->`n > m` Zsimpl_gt_plus_r: (n,m,p:Z)`n+p > m+p`->`n > m` Zgt_S_n: (n,p:Z)`(Zs p) > (Zs n)`->`p > n` >> *) (** Lemmas ending by Zlt *) (** << Zsimpl_lt_plus_l: (n,m,p:Z)`p+n < p+m`->`n < m` Zsimpl_lt_plus_r: (n,m,p:Z)`n+p < m+p`->`n < m` Zlt_S_n: (n,m:Z)`(Zs n) < (Zs m)`->`n < m` >> *) (** Lemmas ending by Zle *) (** << Zsimpl_le_plus_l: (p,n,m:Z)`p+n <= p+m`->`n <= m` Zsimpl_le_plus_r: (p,n,m:Z)`n+p <= m+p`->`n <= m` Zle_S_n: (n,m:Z)`(Zs m) <= (Zs n)`->`m <= n` >> *) (** ** Bottom-up irreversible (syntactic) simplification *) (** Lemmas ending by Zle *) (** << Zle_trans_S: (n,m:Z)`(Zs n) <= m`->`n <= m` >> *) (** ** Other unclearly simplifying lemmas *) (** Lemmas ending by Zeq *) (** << Zmult_eq: (x,y:Z)`x <> 0`->`y*x = 0`->`y = 0` >> *) (* Lemmas ending by Zgt *) (** << Zmult_gt: (x,y:Z)`x > 0`->`x*y > 0`->`y > 0` >> *) (* Lemmas ending by Zlt *) (** << pZmult_lt: (x,y:Z)`x > 0`->`0 < y*x`->`0 < y` >> *) (* Lemmas ending by Zle *) (** << Zmult_le: (x,y:Z)`x > 0`->`0 <= y*x`->`0 <= y` OMEGA1: (x,y:Z)`x = y`->`0 <= x`->`0 <= y` >> *) (**********************************************************************) (** * Irreversible lemmas with meta-variables *) (** To be used by EAuto *) (* Hints Immediate *) (** Lemmas ending by eq *) (** << Zle_antisym: (n,m:Z)`n <= m`->`m <= n`->`n = m` >> *) (** Lemmas ending by Zge *) (** << Zge_trans: (n,m,p:Z)`n >= m`->`m >= p`->`n >= p` >> *) (** Lemmas ending by Zgt *) (** << Zgt_trans: (n,m,p:Z)`n > m`->`m > p`->`n > p` Zgt_trans_S: (n,m,p:Z)`(Zs n) > m`->`m > p`->`n > p` Zle_gt_trans: (n,m,p:Z)`m <= n`->`m > p`->`n > p` Zgt_le_trans: (n,m,p:Z)`n > m`->`p <= m`->`n > p` >> *) (** Lemmas ending by Zlt *) (** << Zlt_trans: (n,m,p:Z)`n < m`->`m < p`->`n < p` Zlt_le_trans: (n,m,p:Z)`n < m`->`m <= p`->`n < p` Zle_lt_trans: (n,m,p:Z)`n <= m`->`m < p`->`n < p` >> *) (** Lemmas ending by Zle *) (** << Zle_trans: (n,m,p:Z)`n <= m`->`m <= p`->`n <= p` >> *) (**********************************************************************) (** * Unclear or too specific lemmas *) (** Not to be used ? *) (** ** Irreversible and too specific (not enough regular) *) (** Lemmas ending by Zle *) (** << Zle_mult: (x,y:Z)`x > 0`->`0 <= y`->`0 <= y*x` Zle_mult_approx: (x,y,z:Z)`x > 0`->`z > 0`->`0 <= y`->`0 <= y*x+z` OMEGA6: (x,y,z:Z)`0 <= x`->`y = 0`->`0 <= x+y*z` OMEGA7: (x,y,z,t:Z)`z > 0`->`t > 0`->`0 <= x`->`0 <= y`->`0 <= x*z+y*t` >> *) (** ** Expansion and too specific ? *) (** Lemmas ending by Zge *) (** << Zge_mult_simpl: (a,b,c:Z)`c > 0`->`a*c >= b*c`->`a >= b` >> *) (** Lemmas ending by Zgt *) (** << Zgt_mult_simpl: (a,b,c:Z)`c > 0`->`a*c > b*c`->`a > b` Zgt_square_simpl: (x,y:Z)`x >= 0`->`y >= 0`->`x*x > y*y`->`x > y` >> *) (** Lemmas ending by Zle *) (** << Zle_mult_simpl: (a,b,c:Z)`c > 0`->`a*c <= b*c`->`a <= b` Zmult_le_approx: (x,y,z:Z)`x > 0`->`x > z`->`0 <= y*x+z`->`0 <= y` >> *) (** ** Reversible but too specific ? *) (** Lemmas ending by Zlt *) (** << Zlt_minus: (n,m:Z)`0 < m`->`n-m < n` >> *) (**********************************************************************) (** * Lemmas to be used as rewrite rules *) (** but can also be used as hints *) (** Left-to-right simplification lemmas (a symbol disappears) *) (** << Zcompare_n_S: (n,m:Z)(Zcompare (Zs n) (Zs m))=(Zcompare n m) Zmin_n_n: (n:Z)`(Zmin n n) = n` Zmult_1_n: (n:Z)`1*n = n` Zmult_n_1: (n:Z)`n*1 = n` Zminus_plus: (n,m:Z)`n+m-n = m` Zle_plus_minus: (n,m:Z)`n+(m-n) = m` Zopp_Zopp: (x:Z)`(-(-x)) = x` Zero_left: (x:Z)`0+x = x` Zero_right: (x:Z)`x+0 = x` Zplus_inverse_r: (x:Z)`x+(-x) = 0` Zplus_inverse_l: (x:Z)`(-x)+x = 0` Zopp_intro: (x,y:Z)`(-x) = (-y)`->`x = y` Zmult_one: (x:Z)`1*x = x` Zero_mult_left: (x:Z)`0*x = 0` Zero_mult_right: (x:Z)`x*0 = 0` Zmult_Zopp_Zopp: (x,y:Z)`(-x)*(-y) = x*y` >> *) (** Right-to-left simplification lemmas (a symbol disappears) *) (** << Zpred_Sn: (m:Z)`m = (Zpred (Zs m))` Zs_pred: (n:Z)`n = (Zs (Zpred n))` Zplus_n_O: (n:Z)`n = n+0` Zmult_n_O: (n:Z)`0 = n*0` Zminus_n_O: (n:Z)`n = n-0` Zminus_n_n: (n:Z)`0 = n-n` Zred_factor6: (x:Z)`x = x+0` Zred_factor0: (x:Z)`x = x*1` >> *) (** Unclear orientation (no symbol disappears) *) (** << Zplus_n_Sm: (n,m:Z)`(Zs (n+m)) = n+(Zs m)` Zmult_n_Sm: (n,m:Z)`n*m+n = n*(Zs m)` Zmin_SS: (n,m:Z)`(Zs (Zmin n m)) = (Zmin (Zs n) (Zs m))` Zplus_assoc_l: (n,m,p:Z)`n+(m+p) = n+m+p` Zplus_assoc_r: (n,m,p:Z)`n+m+p = n+(m+p)` Zplus_permute: (n,m,p:Z)`n+(m+p) = m+(n+p)` Zplus_Snm_nSm: (n,m:Z)`(Zs n)+m = n+(Zs m)` Zminus_plus_simpl: (n,m,p:Z)`n-m = p+n-(p+m)` Zminus_Sn_m: (n,m:Z)`(Zs (n-m)) = (Zs n)-m` Zmult_plus_distr_l: (n,m,p:Z)`(n+m)*p = n*p+m*p` Zmult_minus_distr: (n,m,p:Z)`(n-m)*p = n*p-m*p` Zmult_assoc_r: (n,m,p:Z)`n*m*p = n*(m*p)` Zmult_assoc_l: (n,m,p:Z)`n*(m*p) = n*m*p` Zmult_permute: (n,m,p:Z)`n*(m*p) = m*(n*p)` Zmult_Sm_n: (n,m:Z)`n*m+m = (Zs n)*m` Zmult_Zplus_distr: (x,y,z:Z)`x*(y+z) = x*y+x*z` Zmult_plus_distr: (n,m,p:Z)`(n+m)*p = n*p+m*p` Zopp_Zplus: (x,y:Z)`(-(x+y)) = (-x)+(-y)` Zplus_sym: (x,y:Z)`x+y = y+x` Zplus_assoc: (x,y,z:Z)`x+(y+z) = x+y+z` Zmult_sym: (x,y:Z)`x*y = y*x` Zmult_assoc: (x,y,z:Z)`x*(y*z) = x*y*z` Zopp_Zmult: (x,y:Z)`(-x)*y = (-(x*y))` Zplus_S_n: (x,y:Z)`(Zs x)+y = (Zs (x+y))` Zopp_one: (x:Z)`(-x) = x*(-1)` Zopp_Zmult_r: (x,y:Z)`(-(x*y)) = x*(-y)` Zmult_Zopp_left: (x,y:Z)`(-x)*y = x*(-y)` Zopp_Zmult_l: (x,y:Z)`(-(x*y)) = (-x)*y` Zred_factor1: (x:Z)`x+x = x*2` Zred_factor2: (x,y:Z)`x+x*y = x*(1+y)` Zred_factor3: (x,y:Z)`x*y+x = x*(1+y)` Zred_factor4: (x,y,z:Z)`x*y+x*z = x*(y+z)` Zminus_Zplus_compatible: (x,y,n:Z)`x+n-(y+n) = x-y` Zmin_plus: (x,y,n:Z)`(Zmin (x+n) (y+n)) = (Zmin x y)+n` >> *) (** nat <-> Z *) (** << inj_S: (y:nat)`(inject_nat (S y)) = (Zs (inject_nat y))` inj_plus: (x,y:nat)`(inject_nat (plus x y)) = (inject_nat x)+(inject_nat y)` inj_mult: (x,y:nat)`(inject_nat (mult x y)) = (inject_nat x)*(inject_nat y)` inj_minus1: (x,y:nat)(le y x)->`(inject_nat (minus x y)) = (inject_nat x)-(inject_nat y)` inj_minus2: (x,y:nat)(gt y x)->`(inject_nat (minus x y)) = 0` >> *) (** Too specific ? *) (** << Zred_factor5: (x,y:Z)`x*0+y = y` >> *) coq-8.4pl4/dev/doc/style.txt0000644000175000017500000000312712326224777015062 0ustar stephsteph << L'uniformité du style est plus importante que le style lui-męme. >> (Kernigan & Pike, The Practice of Programming) Mode Emacs ========== Tuareg, que l'on trouve ici : http://www.prism.uvsq.fr/~acohen/tuareg/ avec le réglage suivant : (setq tuareg-in-indent 2) Types récursifs et filtrages ============================ Une barre de séparation y compris sur le premier constructeur type t = | A | B of machin match expr with | A -> ... | B x -> ... Remarque : ā partir de la 8.2 environ, la tendance est ā utiliser le format suivant qui permet de limiter l'escalade d'indentation tout en produisant un aspect visuel intéressant de bloc : type t = | A | B of machin match expr with | A -> ... | B x -> ... let f expr = match expr with | A -> ... | B x -> ... let f expr = function | A -> ... | B x -> ... Le deuxičme cas est obtenu sous tuareg avec les réglages (setq tuareg-with-indent 0) (setq tuareg-function-indent 0) (setq tuareg-let-always-indent nil) /// notons que cette derničre est bien /// pour les let mais pas pour les let-in Conditionnelles =============== if condition then premier-cas else deuxieme-cas Si effets de bord dans les branches, utilisez begin ... end et non des parenthčses i.e. if condition then begin instr1; instr2 end else begin instr3; instr4 end Si la premičre branche lčve une exception, évitez le else i.e. if condition then if condition then error "machin"; error "machin" -----> suite else suite coq-8.4pl4/dev/doc/build-system.txt0000644000175000017500000003240712326224777016346 0ustar stephstephSince July 2007, Coq features a build system overhauled by Pierre Corbineau and Lionel Elie Mamane. --------------------------------------------------------------------- WARNING: In March 2010 this build system has been heavily adapted by Pierre Letouzey. In particular there no more explicit stage1,2. Stage3 was removed some time ago when coqdep was splitted into coqdep_boot and full coqdep. Ideas are still similar to what is describe below, but: 1) .ml4 are explicitely turned into .ml files, which stay after build 2) we let "make" handle the inclusion of .d without trying to guess what could be done at what time. Some initial inclusions hence _fail_, but "make" tries again later and succeed. TODO: remove obsolete sections below and better describe the new approach ----------------------------------------------------------------------- This file documents what a Coq developer needs to know about the build system. If you want to enhance the build system itself (or are curious about its implementation details), see build-system.dev.txt . The build system is not at its optimal state, see TODO section. FAQ: special features used in this Makefile ------------------------------------------- * Order-only dependencies: | Dependencies placed after a bar (|) should be built before the current rule, but having one of them is out-of-date do not trigger a rebuild of the current rule. See http://www.gnu.org/software/make/manual/make.htmlPrerequisite-Types * Annotation before commands: +/-/@ a command starting by - is always successful (errors are ignored) a command starting by + is runned even if option -n is given to make a command starting by @ is not echoed before being runned * Custom functions Definition via "define foo" followed by commands (arg is $(1) etc) Call via "$(call foo,arg1)" * Useful builtin functions $(subst ...), $(patsubst ...), $(shell ...), $(foreach ...), $(if ...) * Behavior of -include If the file given to -include doesn't exist, make tries to build it, but doesn't care if this build fails. This can be quite surprising, see in particular the -include in Makefile.stage* Stages in build system ---------------------- The build system is separated into three stages, corresponding to the tool(s) necessary to compute the dependencies necessary at this stage: stage1: ocamldep, sed, camlp4 without Coq extensions stage2: camlp4 with grammar.cma and/or q_constr.cmo stage3: coqdep (.vo) The file "Makefile" itself serves as minimum stage for targets that should not need any dependency (such as *clean*). Changes (for old-timers) ------------------------ The contents of the old Makefile has been mostly split into: - variable declarations for file lists in Makefile.common. These declarations are now static (for faster Makefile execution), so their definitions are order-dependent. - actual building rules and compiler flags variables in Makefile.build The handling of globals is now: the globals of FOO.v are in FOO.glob and the global glob.dump is created by concatenation of all .glob files. In particular, .glob files are now always created. See also section "cleaning targets" Reducing build system overhead ------------------------------ When you are actively working on a file in a "make a change, make to test, make a change, make to test", etc mode, here are a few tips to save precious time: - Always ask for what you want directly (e.g. bin/coqtop, foo/bar.cmo, ...), don't do "make world" and interrupt it when it has done what you want. This will try to minimise the stage at which what you ask for is done (instead of maximising it in order to maximise parallelism of the build process). For example, if you only want to test whether bin/coqtop still builds (and eventually start it to test your bugfix or new feature), don't do "make world" and interrupt it when bin/coqtop is built. Use "make bin/coqtop" or "make coqbinaries" or something like that. This will avoid entering the stage 3, and cut build system overhead by 50% (1.2s instead of 2.4 on writer's machine). - You can turn off rebuilding of the standard library each time bin/coqtop is rebuilt with NO_RECOMPILE_LIB=1. - If you want to avoid all .ml4 files being recompiled only because grammar.cma was rebuilt, do "make ml4depclean" once and then use NO_RECOMPILE_ML4=1. - The CM_STAGE1=1 option to make will build all .cm* files mentioned as targets on the command line in stage1. Whether this will work is your responsibility. It should work for .ml files that don't depend (nor directly nor indirectly through transitive closure of the dependencies) on any .ml4 file, or where those dependencies can be safely ignored in the current situation (e.g. all these .ml4 files don't need to be recompiled). This will avoid entering the stage2 (a reduction of 33% in overhead, 0.4s on the writer's machine). - To jump directly into a stage (e.g. because you know nothing is to be done in stage 1 or (1 and 2) or because you know that the target you give can be, in this situation, done in a lower stage than the build system dares to), use GOTO_STAGE=n. This will jump into stage n and try to do the targets you gave in that stage. - To disable all dependency recalculation, use the NO_RECALC_DEPS=1 option. It disables REcalculation of dependencies, not calculation of dependencies. In other words, if a .d file does not exist, it is still created, but it is not updated every time the source file (e.g. .ml) is changed. General speed improvements: - When building both the native and bytecode versions, the KEEP_ML4_PREPROCESSED=1 option may reduce global compilation time by running camlp4o only once on every .ml4 file, at the expense of readability of compilation error messages for .ml4 files. Dependencies ------------ There are no dependencies in the archive anymore, they are always bootstrapped. The dependencies of a file FOO are in FOO.d . This enables partial recalculation of dependencies (only the dependencies of changed files are recomputed). If you add a dependency to a Coq camlp4 extension (grammar.cma or q_constr.cmo), then see sections ".ml4 files" and "new files". Cleaning Targets ---------------- Targets for cleaning various parts: - distclean: clean everything; must leave only what should end up in distribution tarball and/or is in a svn checkout. - clean: clean everything except effect of "./configure" and documentation. - cleanconfig: clean effect of "./configure" only - archclean: remove all architecture-dependent generated files - indepclean: remove all architecture-independent generated files (not documentation) - objclean: clean all generated files, but not Makefile meta-data (e.g. dependencies), nor debugging/development information nor other cruft (e.g. editor backup files), nor documentation - docclean: clean documentation .ml4 files ---------- The camlp4-preprocessed version of FOO.ml4 is FOO.ml4-preprocessed and can be obtained with: make FOO.ml4-preprocessed If a .ml4 file uses a grammar extension from Coq (such as grammar.cma or q_constr.cmo), it must contain a line like: (*i camlp4deps: "grammar.cma q_constr.cmo" i*) If it uses a standard grammar extension, it must contain a line like: (*i camlp4use: "pa_ifdef.cmo" i*) It can naturally contain both a camlp4deps and a camlp4use line. Both are used for preprocessing. It is thus _not_ necessary to add a specific rule for a .ml4 file in the Makefile.build just because it uses grammar extensions. By default, the build system is geared towards development that may use the Coq grammar extensions, but not development of Coq's grammar extensions themselves. This means that .ml4 files are compiled directly (using ocamlc/opt's -pp option), without use of an intermediary .ml (or .ml4-preprocessed) file. This is so that if a compilation error occurs, the location in the error message is a location in the .ml4 file. If you are modifying the grammar extensions, you may be more interested in the location of the error in the .ml4-preprocessed file, so that you can see what your new grammar extension made wrong. In that case, use the KEEP_ML4_PREPROCESSED=1 option. This will make compilation of a .ml4 file a two-stage process: 1) create the .ml4-preprocessed file with camlp4o 2) compile it with straight ocamlc/opt without preprocessor and will instruct make not to delete .ml4-preprocessed files automatically just because they are intermediary files, so that you can inspect them. If you add a _new_ grammar extension to Coq: - if it can be built at stage1, that is the .ml4 file does not use a Coq grammar extension itself, then add it, and all .cmo files it needs to STAGE1_TARGETS and STAGE_ML4 in Makefile.common. See the handling of grammar.cma and q_constr.cmo for an example. - if it cannot be built at stage1, that is the .ml4 file itself needs to be preprocessed with a Coq camlp4 grammar extension, then, congratulations, you need to add a new stage between stage1 and stage2. New files --------- For a new file, in most cases, you just have to add it to the proper file list(s) in Makefile.common, such as ARITHVO or TACTICS. The list of all ml4 files is not handled manually anymore. Exceptions are: - The file is necessary at stage1, that it is necessary to build the Coq camlp4 grammar extensions. In this case, make sure it ends up in STAGE1_CMO and (for .ml4 files) STAGE1_ML4. See the handling of grammar.cma and/or q_constr.cmo for an example. - if the file needs to be compiled with -rectypes, add it to RECTYPESML in Makefile.common. If it is a .ml4 file, implement RECTYPESML4 or '(*i ocamlflags i*)'; see TODO. - the file needs a specific Makefile entry; add it to Makefile.build - the files produced from the added file do not match an existing pattern or entry in "Makefile". (All the common cases of .ml{,i,l,y,4}, .v, .c, ... files that produces (respectively) .cm[iox], .vo, .glob, .o, ... files with the same basename are already covered.) In this case, see section "New targets". New targets ----------- If you want to add: - a new PHONY target to the build system, that is a target that is not the name of the file it creates, - a normal target is not already mapped to a stage by "Makefile" then: - add the necessary rule to Makefile.build, if any - add the target to STAGEn_TARGETS, with n being the smallest stage it can be built at, that is: * 1 for OCaml code that doesn't use any Coq camlp4 grammar extension * 2 for OCaml code that uses (directly or indirectly) a Coq camlp4 grammar extension. Indirectly means a dependency of it does. * 3 for Coq (.v) code. *or* add a pattern matching the target to the pattern lists for the smallest stage it can be built at in "Makefile". TODO ---- delegate pa_extend.cmo to camlp4use statements and remove it from standard camlp4 options. maybe manage compilation flags (such as -rectypes or the CoqIDE ones) from a (*i ocamlflags: "-rectypes" i*) statement in the .ml(4) files themselves, like camlp4use. The CoqIDE files could have (*i ocamlflags: "${COQIDEFLAGS}" i*) and COQIDEFLAGS is still defined (and exported by) the Makefile.build. Clean up doc/Makefile config/Makefile looks like it contains a lot of unused variables, clean that up (are any maybe used by nightly scripts on pauillac?). Also, the COQTOP variable from config/Makefile (and used in contribs) has a very poorly chosen name, because "coqtop" is the name of a Coq executable! In the coq Makefiles, $(COQTOPEXE) is used to refer to that executable. Promote the granular .glob handling to official way of doing things for Coq developments, that is implement it in coq_makefile and the contribs. Here are a few hints: >> Les fichiers de constantes produits par -dump-glob sont maintenant >> produits par fichier et sont ensuite concatÃĐnÃĐs dans >> glob.dump. Ilsont produits par dÃĐfaut (avec les bonnes >> dÃĐpendances). > C'est une chose que l'on voulait faire aussi. (J'ai testÃĐ et dÃĐboguÃĐ ce concept sur CoRN dans les derniers mois.) > Est-ce que vous sauriez modifier coq_makefile pour qu'il procÃĻde de > la mÊme façon Dans cette optique, il serait alors plus propre de changer coqdep pour qu'il produise directement l'output que nous mettons maintenant dans les .v.d (qui est celui de coqdoc post-processÃĐ avec sed). Si cette maniÃĻre de gÃĐrer les glob devient le standard bÃĐni officiellement par "the Coq development team", ne voudrions nous pas changer coqc pour qu'il produise FOO.glob lors de la compilation de FOO.v par dÃĐfaut (sans argument "-dump-glob")? > et que la production de a.html par coqdoc n'ait une dÃĐpendance qu'en > les a.v et a.glob correspondant ? Je crois que coqdoc exige un glob-dump unique, il convient donc de concatÃĐner les .glob correspondants. Soit un glob-dump global par projet (par Makefile), soit un glob-dump global par .v(o), qui contient son .glob et ceux de tous les .v(o) atteignables par le graphe des dÃĐpendances. CoRN contient dÃĐjà un outil de calcul de partie atteignable du graphe des dÃĐpendances (il y est pour un autre usage, pour calculer les .v à mettre dans les diffÃĐrents tarballs sur http://corn.cs.ru.nl/download.html; les parties partielles sont dÃĐfinies par liste de fichiers .v + toutes leurs dÃĐpendances (in)directes), il serait alors adÃĐquat de le mettre dans les tools de Coq. coq-8.4pl4/dev/doc/minicoq.tex0000644000175000017500000000560312326224777015343 0ustar stephsteph\documentclass{article} \usepackage{fullpage} \input{./macros.tex} \newcommand{\minicoq}{\textsf{minicoq}} \newcommand{\nonterm}[1]{\textit{#1}} \newcommand{\terminal}[1]{\textsf{#1}} \newcommand{\listzero}{\textit{LIST$_0$}} \newcommand{\listun}{\textit{LIST$_1$}} \newcommand{\sep}{\textit{SEP}} \title{Minicoq: a type-checker for the pure \\ Calculus of Inductive Constructions} \begin{document} \maketitle \section{Introduction} \minicoq\ is a minimal toplevel for the \Coq\ kernel. \section{Grammar of terms} The grammar of \minicoq's terms is given in Figure~\ref{fig:terms}. \begin{figure}[htbp] \hrulefill \begin{center} \begin{tabular}{lrl} term & ::= & identifier \\ & $|$ & \terminal{Rel} integer \\ & $|$ & \terminal{Set} \\ & $|$ & \terminal{Prop} \\ & $|$ & \terminal{Type} \\ & $|$ & \terminal{Const} identifier \\ & $|$ & \terminal{Ind} identifier integer \\ & $|$ & \terminal{Construct} identifier integer integer \\ & $|$ & \terminal{[} name \terminal{:} term \terminal{]} term \\ & $|$ & \terminal{(} name \terminal{:} term \terminal{)} term \\ & $|$ & term \verb!->! term \\ & $|$ & \terminal{(} \listun\ term \terminal{)} \\ & $|$ & \terminal{(} term \terminal{::} term \terminal{)} \\ & $|$ & \verb!! \terminal{Case} term \terminal{of} \listzero\ term \terminal{end} \\[1em] name & ::= & \verb!_! \\ & $|$ & identifier \end{tabular} \end{center} \hrulefill \caption{Grammar of terms} \label{fig:terms} \end{figure} \section{Commands} The grammar of \minicoq's commands are given in Figure~\ref{fig:commands}. All commands end with a dot. \begin{figure}[htbp] \hrulefill \begin{center} \begin{tabular}{lrl} command & ::= & \terminal{Definition} identifier \terminal{:=} term. \\ & $|$ & \terminal{Definition} identifier \terminal{:} term \terminal{:=} term. \\ & $|$ & \terminal{Parameter} identifier \terminal{:} term. \\ & $|$ & \terminal{Variable} identifier \terminal{:} term. \\ & $|$ & \terminal{Inductive} \terminal{[} \listzero\ param \terminal{]} \listun\ inductive \sep\ \terminal{with}. \\ & $|$ & \terminal{Check} term. \\[1em] param & ::= & identifier \\[1em] inductive & ::= & identifier \terminal{:} term \terminal{:=} \listzero\ constructor \sep\ \terminal{$|$} \\[1em] constructor & ::= & identifier \terminal{:} term \end{tabular} \end{center} \hrulefill \caption{Commands} \label{fig:commands} \end{figure} \end{document} %%% Local Variables: %%% mode: latex %%% TeX-master: t %%% End: coq-8.4pl4/dev/doc/naming-conventions.tex0000644000175000017500000005443112326224777017523 0ustar stephsteph\documentclass[a4paper]{article} \usepackage{fullpage} \usepackage[latin1]{inputenc} \usepackage[T1]{fontenc} \usepackage{amsfonts} \parindent=0pt \parskip=10pt %%%%%%%%%%%%% % Macros \newcommand\itemrule[3]{ \subsubsection{#1} \begin{quote} \begin{tt} #3 \end{tt} \end{quote} \begin{quote} Name: \texttt{#2} \end{quote}} \newcommand\formula[1]{\begin{tt}#1\end{tt}} \newcommand\tactic[1]{\begin{tt}#1\end{tt}} \newcommand\command[1]{\begin{tt}#1\end{tt}} \newcommand\term[1]{\begin{tt}#1\end{tt}} \newcommand\library[1]{\texttt{#1}} \newcommand\name[1]{\texttt{#1}} \newcommand\zero{\texttt{zero}} \newcommand\op{\texttt{op}} \newcommand\opPrime{\texttt{op'}} \newcommand\opSecond{\texttt{op''}} \newcommand\phimapping{\texttt{phi}} \newcommand\D{\texttt{D}} \newcommand\elt{\texttt{elt}} \newcommand\rel{\texttt{rel}} \newcommand\relp{\texttt{rel'}} %%%%%%%%%%%%% \begin{document} \begin{center} \begin{huge} Proposed naming conventions for the Coq standard library \end{huge} \end{center} \bigskip The following document describes a proposition of canonical naming schemes for the Coq standard library. Obviously and unfortunately, the current state of the library is not as homogeneous as it would be if it would systematically follow such a scheme. To tend in this direction, we however recommend to follow the following suggestions. \tableofcontents \section{General conventions} \subsection{Variable names} \begin{itemize} \item Variables are preferably quantified at the head of the statement, even if some premisses do not depend of one of them. For instance, one would state \begin{quote} \begin{tt} {forall x y z:D, x <= y -> x+z <= y+z} \end{tt} \end{quote} and not \begin{quote} \begin{tt} {forall x y:D, x <= y -> forall z:D, x+z <= y+z} \end{tt} \end{quote} \item Variables are preferably quantified (and named) in the order of ``importance'', then of appearance, from left to right, even if for the purpose of some tactics it would have been more convenient to have, say, the variables not occurring in the conclusion first. For instance, one would state \begin{quote} \begin{tt} {forall x y z:D, x+z <= y+z -> x <= y} \end{tt} \end{quote} and not \begin{quote} \begin{tt} {forall z x y:D, x+z <= y+z -> x <= y} \end{tt} \end{quote} nor \begin{quote} \begin{tt} {forall x y z:D, y+x <= z+x -> y <= z} \end{tt} \end{quote} \item Choice of effective names is domain-dependent. For instance, on natural numbers, the convention is to use the variables $n$, $m$, $p$, $q$, $r$, $s$ in this order. On generic domains, the convention is to use the letters $x$, $y$, $z$, $t$. When more than three variables are needed, indexing variables It is conventional to use specific names for variables having a special meaning. For instance, $eps$ or $\epsilon$ can be used to denote a number intended to be as small as possible. Also, $q$ and $r$ can be used to denote a quotient and a rest. This is good practice. \end{itemize} \subsection{Disjunctive statements} A disjunctive statement with a computational content will be suffixed by \name{\_inf}. For instance, if \begin{quote} \begin{tt} {forall x y, op x y = zero -> x = zero \/ y = zero} \end{tt} \end{quote} has name \texttt{D\_integral}, then \begin{quote} \begin{tt} {forall x y, op x y = zero -> \{x = zero\} + \{y = zero\}} \end{tt} \end{quote} will have name \texttt{D\_integral\_inf}. As an exception, decidability statements, such as \begin{quote} \begin{tt} {forall x y, \{x = y\} + \{x <> y\}} \end{tt} \end{quote} will have a named ended in \texttt{\_dec}. Idem for cotransitivity lemmas which are inherently computational that are ended in \texttt{\_cotrans}. \subsection{Inductive types constructor names} As a general rule, constructor names start with the name of the inductive type being defined as in \texttt{Inductive Z := Z0 : Z | Zpos : Z -> Z | Zneg : Z -> Z} to the exception of very standard types like \texttt{bool}, \texttt{nat}, \texttt{list}... For inductive predicates, constructor names also start with the name of the notion being defined with one or more suffixes separated with \texttt{\_} for discriminating the different cases as e.g. in \begin{verbatim} Inductive even : nat -> Prop := | even_O : even 0 | even_S n : odd n -> even (S n) with odd : nat -> Prop := | odd_S n : even n -> odd (S n). \end{verbatim} As a general rule, inductive predicate names should be lowercase (to the exception of notions referring to a proper name, e.g. \texttt{Bezout}) and multiple words must be separated by ``{\_}''. As an exception, when extending libraries whose general rule is that predicates names start with a capital letter, the convention of this library should be kept and the separation between multiple words is done by making the initial of each work a capital letter (if one of these words is a proper name, then a ``{\_}'' is added to emphasize that the capital letter is proper and not an application of the rule for marking the change of word). Inductive predicates that characterize the specification of a function should be named after the function it specifies followed by \texttt{\_spec} as in: \begin{verbatim} Inductive nth_spec : list A -> nat -> A -> Prop := | nth_spec_O a l : nth_spec (a :: l) 0 a | nth_spec_S n a b l : nth_spec l n a -> nth_spec (b :: l) (S n) a. \end{verbatim} \section{Equational properties of operations} \subsection{General conventions} If the conclusion is in the other way than listed below, add suffix \name{\_reverse} to the lemma name. \subsection{Specific conventions} \itemrule{Associativity of binary operator {\op} on domain {\D}}{Dop\_assoc} {forall x y z:D, op x (op y z) = op (op x y) z} Remark: Symmetric form: \name{Dop\_assoc\_reverse}: \formula{forall x y z:D, op (op x y) z = op x (op y z)} \itemrule{Commutativity of binary operator {\op} on domain {\D}}{Dop\_comm} {forall x y:D, op x y = op y x} Remark: Avoid \formula{forall x y:D, op y x = op x y}, or at worst, call it \name{Dop\_comm\_reverse} \itemrule{Left neutrality of element elt for binary operator {\op}}{Dop\_elt\_l} {forall x:D, op elt x = x} Remark: In English, ``{\elt} is an identity for {\op}'' seems to be a more common terminology. \itemrule{Right neutrality of element elt for binary operator {\op}}{Dop\_elt\_r} {forall x:D, op x elt = x} Remark: By convention, if the identities are reminiscent to zero or one, they are written 1 and 0 in the name of the property. \itemrule{Left absorption of element elt for binary operator {\op}}{Dop\_elt\_l} {forall x:D, op elt x = elt} Remarks: \begin{itemize} \item In French school, this property is named "elt est absorbant pour op" \item English, the property seems generally named "elt is a zero of op" \item In the context of lattices, this a boundedness property, it may be called "elt is a bound on D", or referring to a (possibly arbitrarily oriented) order "elt is a least element of D" or "elt is a greatest element of D" \end{itemize} \itemrule{Right absorption of element {\elt} for binary operator {\op}}{Dop\_elt\_l [BAD ??]} {forall x:D, op x elt = elt} \itemrule{Left distributivity of binary operator {\op} over {\opPrime} on domain {\D}}{Dop\_op'\_distr\_l} {forall x y z:D, op (op' x y) z = op' (op x z) (op y z)} Remark: Some authors say ``distribution''. \itemrule{Right distributivity of binary operator {\op} over {\opPrime} on domain {\D}}{Dop\_op'\_distr\_r} {forall x y z:D, op z (op' x y) = op' (op z x) (op z y)} Remark: Note the order of arguments. \itemrule{Distributivity of unary operator {\op} over binary op' on domain {\D}}{Dop\_op'\_distr} {forall x y:D, op (op' x y) = op' (op x) (op y)} \itemrule{Distributivity of unary operator {\op} over binary op' on domain {\D}}{Dop\_op'\_distr} {forall x y:D, op (op' x y) = op' (op x) (op y)} Remark: For a non commutative operation with inversion of arguments, as in \formula{forall x y z:D, op (op' x y) = op' (op y) (op y z)}, we may probably still call the property distributivity since there is no ambiguity. Example: \formula{forall n m : Z, -(n+m) = (-n)+(-m)}. Example: \formula{forall l l' : list A, rev (l++l') = (rev l)++(rev l')}. \itemrule{Left extrusion of unary operator {\op} over binary op' on domain {\D}}{Dop\_op'\_distr\_l} {forall x y:D, op (op' x y) = op' (op x) y} Question: Call it left commutativity ?? left swap ? \itemrule{Right extrusion of unary operator {\op} over binary op' on domain {\D}}{Dop\_op'\_distr\_r} {forall x y:D, op (op' x y) = op' x (op y)} \itemrule{Idempotency of binary operator {\op} on domain {\D}}{Dop\_idempotent} {forall x:D, op x n = x} \itemrule{Idempotency of unary operator {\op} on domain {\D}}{Dop\_idempotent} {forall x:D, op (op x) = op x} Remark: This is actually idempotency of {\op} wrt to composition and identity. \itemrule{Idempotency of element elt for binary operator {\op} on domain {\D}}{Dop\_elt\_idempotent} {op elt elt = elt} Remark: Generally useless in CIC for concrete, computable operators Remark: The general definition is ``exists n, iter n op x = x''. \itemrule{Nilpotency of element elt wrt a ring D with additive neutral element {\zero} and multiplicative binary operator {\op}}{Delt\_nilpotent} {op elt elt = zero} Remark: We leave the ring structure of D implicit; the general definition is ``exists n, iter n op elt = zero''. \itemrule{Zero-product property in a ring D with additive neutral element {\zero} and multiplicative binary operator {\op}}{D\_integral} {forall x y, op x y = zero -> x = zero \/ y = zero} Remark: We leave the ring structure of D implicit; the Coq library uses either \texttt{\_is\_O} (for \texttt{nat}), \texttt{\_integral} (for \texttt{Z}, \texttt{Q} and \texttt{R}), \texttt{eq\_mul\_0} (for \texttt{NZ}). Remark: The French school says ``integrité''. \itemrule{Nilpotency of binary operator {\op} wrt to its absorbing element zero in D}{Dop\_nilpotent} {forall x, op x x = zero} Remark: Did not find this definition on the web, but it used in the Coq library (to characterize \name{xor}). \itemrule{Involutivity of unary op on D}{Dop\_involutive} {forall x:D, op (op x) = x} \itemrule{Absorption law on the left for binary operator {\op} over binary operator {\op}' on the left}{Dop\_op'\_absorption\_l\_l} {forall x y:D, op x (op' x y) = x} \itemrule{Absorption law on the left for binary operator {\op} over binary operator {\op}' on the right}{Dop\_op'\_absorption\_l\_r} {forall x y:D, op x (op' y x) = x} Remark: Similarly for \name{Dop\_op'\_absorption\_r\_l} and \name{Dop\_op'\_absorption\_r\_r}. \itemrule{De Morgan law's for binary operators {\opPrime} and {\opSecond} wrt to unary op on domain {\D}}{Dop'\_op''\_de\_morgan, Dop''\_op'\_de\_morgan ?? \mbox{leaving the complementing operation implicit})} {forall x y:D, op (op' x y) = op'' (op x) (op y)\\ forall x y:D, op (op'' x y) = op' (op x) (op y)} \itemrule{Left complementation of binary operator {\op} by means of unary {\opPrime} wrt neutral element {\elt} of {\op} on domain {\D}}{Dop\_op'\_opp\_l} {forall x:D, op (op' x) x = elt} Remark: If the name of the opposite function is reminiscent of the notion of complement (e.g. if it is called \texttt{opp}), one can simply say {Dop\_opp\_l}. \itemrule{Right complementation of binary operator {\op} by means of unary {\op'} wrt neutral element {\elt} of {\op} on domain {\D}}{Dop\_opp\_r} {forall x:D, op x (op' x) = elt} Example: \formula{Radd\_opp\_l: forall r : R, - r + r = 0} \itemrule{Associativity of binary operators {\op} and {\op'}}{Dop\_op'\_assoc} {forall x y z, op x (op' y z) = op (op' x y) z} Example: \formula{forall x y z, x + (y - z) = (x + y) - z} \itemrule{Right extrusion of binary operator {\opPrime} over binary operator {\op}}{Dop\_op'\_extrusion\_r} {forall x y z, op x (op' y z) = op' (op x y) z} Remark: This requires {\op} and {\opPrime} to have their right and left argument respectively and their return types identical. Example: \formula{forall x y z, x + (y - z) = (x + y) - z} Remark: Other less natural combinations are possible, such as \formula{forall x y z, op x (op' y z) = op' y (op x z)}. \itemrule{Left extrusion of binary operator {\opPrime} over binary operator {\op}}{Dop\_op'\_extrusion\_l} {forall x y z, op (op' x y) z = op' x (op y z)} Remark: Operations are not necessarily internal composition laws. It is only required that {\op} and {\opPrime} have their right and left argument respectively and their return type identical. Remark: When the type are heterogeneous, only one extrusion law is possible and it can simply be named {Dop\_op'\_extrusion}. Example: \formula{app\_cons\_extrusion : forall a l l', (a :: l) ++ l' = a :: (l ++ l')}. %====================================================================== %\section{Properties of elements} %Remark: Not used in current library %====================================================================== \section{Preservation and compatibility properties of operations} \subsection{With respect to equality} \itemrule{Injectivity of unary operator {\op}}{Dop\_inj} {forall x y:D, op x = op y -> x = y} \itemrule{Left regularity of binary operator {\op}}{Dop\_reg\_l, Dop\_inj\_l, or Dop\_cancel\_l} {forall x y z:D, op z x = op z y -> x = y} Remark: Note the order of arguments. Remark: The Coq usage is to called it regularity but the English standard seems to be cancellation. The recommended form is not decided yet. Remark: Shall a property like $n^p \leq n^q \rightarrow p \leq q$ (for $n\geq 1$) be called cancellation or should it be reserved for operators that have an inverse? \itemrule{Right regularity of binary operator {\op}}{Dop\_reg\_r, Dop\_inj\_r, Dop\_cancel\_r} {forall x y z:D, op x z = op y z -> x = y} \subsection{With respect to a relation {\rel}} \itemrule{Compatibility of unary operator {\op}}{Dop\_rel\_compat} {forall x y:D, rel x y -> rel (op x) (op y)} \itemrule{Left compatibility of binary operator {\op}}{Dop\_rel\_compat\_l} {forall x y z:D, rel x y -> rel (op z x) (op z y)} \itemrule{Right compatibility of binary operator {\op}}{Dop\_rel\_compat\_r} {forall x y z:D, rel x y -> rel (op x z) (op y z)} Remark: For equality, use names of the form \name{Dop\_eq\_compat\_l} or \name{Dop\_eq\_compat\_r} (\formula{forall x y z:D, y = x -> op y z = op x z} and \formula{forall x y z:D, y = x -> op y z = op x z}) Remark: Should we admit (or even prefer) the name \name{Dop\_rel\_monotone}, \name{Dop\_rel\_monotone\_l}, \name{Dop\_rel\_monotone\_r} when {\rel} is an order ? \itemrule{Left regularity of binary operator {\op}}{Dop\_rel\_reg\_l} {forall x y z:D, rel (op z x) (op z y) -> rel x y} \itemrule{Right regularity of binary operator {\op}}{Dop\_rel\_reg\_r} {forall x y z:D, rel (op x z) (op y z) -> rel x y} Question: Would it be better to have \name{z} as first argument, since it is missing in the conclusion ?? (or admit we shall use the options ``\texttt{with p}''?) \itemrule{Left distributivity of binary operator {\op} over {\opPrime} along relation {\rel} on domain {\D}}{Dop\_op'\_rel\_distr\_l} {forall x y z:D, rel (op (op' x y) z) (op' (op x z) (op y z))} Example: standard property of (not necessarily distributive) lattices Remark: In a (non distributive) lattice, by swapping join and meet, one would like also, \formula{forall x y z:D, rel (op' (op x z) (op y z)) (op (op' x y) z)}. How to name it with a symmetric name (use \name{Dop\_op'\_rel\_distr\_mon\_l} and \name{Dop\_op'\_rel\_distr\_anti\_l})? \itemrule{Commutativity of binary operator {\op} along (equivalence) relation {\rel} on domain {\D}}{Dop\_op'\_rel\_comm} {forall x y z:D, rel (op x y) (op y x)} Example: \formula{forall l l':list A, Permutation (l++l') (l'++l)} \itemrule{Irreducibility of binary operator {\op} on domain {\D}}{Dop\_irreducible} {forall x y z:D, z = op x y -> z = x $\backslash/$ z = y} Question: What about the constructive version ? Call it \name{Dop\_irreducible\_inf} ? \formula{forall x y z:D, z = op x y -> \{z = x\} + \{z = y\}} \itemrule{Primality of binary operator {\op} along relation {\rel} on domain {\D}}{Dop\_rel\_prime} {forall x y z:D, rel z (op x y) -> rel z x $\backslash/$ rel z y} %====================================================================== \section{Morphisms} \itemrule{Morphism between structures {\D} and {\D'}}{\name{D'\_of\_D}}{D -> D'} Remark: If the domains are one-letter long, one can used \texttt{IDD'} as for \name{INR} or \name{INZ}. \itemrule{Morphism {\phimapping} mapping unary operators {\op} to {\op'}}{phi\_op\_op', phi\_op\_op'\_morphism} {forall x:D, phi (op x) = op' (phi x)} Remark: If the operators have the same name in both domains, one use \texttt{D'\_of\_D\_op} or \texttt{IDD'\_op}. Example: \formula{Z\_of\_nat\_mult: forall n m : nat, Z\_of\_nat (n * m) = (Z\_of\_nat n * Z\_of\_nat m)\%Z}. Remark: If the operators have different names on distinct domains, one can use \texttt{op\_op'}. \itemrule{Morphism {\phimapping} mapping binary operators {\op} to {\op'}}{phi\_op\_op', phi\_op\_op'\_morphism} {forall x y:D, phi (op x y) = op' (phi x) (phi y)} Remark: If the operators have the same name in both domains, one use \texttt{D'\_of\_D\_op} or \texttt{IDD'\_op}. Remark: If the operators have different names on distinct domains, one can use \texttt{op\_op'}. \itemrule{Morphism {\phimapping} mapping binary operator {\op} to binary relation {\rel}}{phi\_op\_rel, phi\_op\_rel\_morphism} {forall x y:D, phi (op x y) <-> rel (phi x) (phi y)} Remark: If the operator and the relation have similar name, one uses \texttt{phi\_op}. Question: How to name each direction? (add \_elim for -> and \_intro for <- ?? -- as done in Bool.v ??) Example: \formula{eq\_true\_neg: \~{} eq\_true b <-> eq\_true (negb b)}. %====================================================================== \section{Preservation and compatibility properties of operations wrt order} \itemrule{Compatibility of binary operator {\op} wrt (strict order) {\rel} and (large order) {\rel'}}{Dop\_rel\_rel'\_compat} {forall x y z t:D, rel x y -> rel' z t -> rel (op x z) (op y t)} \itemrule{Compatibility of binary operator {\op} wrt (large order) {\relp} and (strict order) {\rel}}{Dop\_rel'\_rel\_compat} {forall x y z t:D, rel' x y -> rel z t -> rel (op x z) (op y t)} %====================================================================== \section{Properties of relations} \itemrule{Reflexivity of relation {\rel} on domain {\D}}{Drel\_refl} {forall x:D, rel x x} \itemrule{Symmetry of relation {\rel} on domain {\D}}{Drel\_sym} {forall x y:D, rel x y -> rel y x} \itemrule{Transitivity of relation {\rel} on domain {\D}}{Drel\_trans} {forall x y z:D, rel x y -> rel y z -> rel x z} \itemrule{Antisymmetry of relation {\rel} on domain {\D}}{Drel\_antisym} {forall x y:D, rel x y -> rel y x -> x = y} \itemrule{Irreflexivity of relation {\rel} on domain {\D}}{Drel\_irrefl} {forall x:D, \~{} rel x x} \itemrule{Asymmetry of relation {\rel} on domain {\D}}{Drel\_asym} {forall x y:D, rel x y -> \~{} rel y x} \itemrule{Cotransitivity of relation {\rel} on domain {\D}}{Drel\_cotrans} {forall x y z:D, rel x y -> \{rel z y\} + \{rel x z\}} \itemrule{Linearity of relation {\rel} on domain {\D}}{Drel\_trichotomy} {forall x y:D, \{rel x y\} + \{x = y\} + \{rel y x\}} Questions: Or call it \name{Drel\_total}, or \name{Drel\_linear}, or \name{Drel\_connected}? Use $\backslash/$ ? or use a ternary sumbool, or a ternary disjunction, for nicer elimination. \itemrule{Informative decidability of relation {\rel} on domain {\D}}{Drel\_dec (or Drel\_dect, Drel\_dec\_inf ?)} {forall x y:D, \{rel x y\} + \{\~{} rel x y\}} Remark: If equality: \name{D\_eq\_dec} or \name{D\_dec} (not like \name{eq\_nat\_dec}) \itemrule{Non informative decidability of relation {\rel} on domain {\D}}{Drel\_dec\_prop (or Drel\_dec)} {forall x y:D, rel x y $\backslash/$ \~{} rel x y} \itemrule{Inclusion of relation {\rel} in relation {\rel}' on domain {\D}}{Drel\_rel'\_incl (or Drel\_incl\_rel')} {forall x y:D, rel x y -> rel' x y} Remark: Use \name{Drel\_rel'\_weak} for a strict inclusion ?? %====================================================================== \section{Relations between properties} \itemrule{Equivalence of properties \texttt{P} and \texttt{Q}}{P\_Q\_iff} {forall x1 .. xn, P <-> Q} Remark: Alternatively use \name{P\_iff\_Q} if it is too difficult to recover what pertains to \texttt{P} and what pertains to \texttt{Q} in their concatenation (as e.g. in \texttt{Godel\_Dummett\_iff\_right\_distr\_implication\_over\_disjunction}). %====================================================================== \section{Arithmetical conventions} \begin{minipage}{6in} \renewcommand{\thefootnote}{\thempfootnote} % For footnotes... \begin{tabular}{lll} Zero on domain {\D} & D0 & (notation \verb=0=)\\ One on domain {\D} & D1 (if explicitly defined) & (notation \verb=1=)\\ Successor on domain {\D} & Dsucc\\ Predessor on domain {\D} & Dpred\\ Addition on domain {\D} & Dadd/Dplus\footnote{Coq historically uses \texttt{plus} and \texttt{mult} for addition and multiplication which are inconsistent notations, the recommendation is to use \texttt{add} and \texttt{mul} except in existng libraries that already use \texttt{plus} and \texttt{mult}} & (infix notation \verb=+= [50,L])\\ Multiplication on domain {\D} & Dmul/Dmult\footnotemark[\value{footnote}] & (infix notation \verb=*= [40,L]))\\ Soustraction on domain {\D} & Dminus & (infix notation \verb=-= [50,L])\\ Opposite on domain {\D} & Dopp (if any) & (prefix notation \verb=-= [35,R]))\\ Inverse on domain {\D} & Dinv (if any) & (prefix notation \verb=/= [35,R]))\\ Power on domain {\D} & Dpower & (infix notation \verb=^= [30,R])\\ Minimal element on domain {\D} & Dmin\\ Maximal element on domain {\D} & Dmax\\ Large less than order on {\D} & Dle & (infix notations \verb!<=! and \verb!>=! [70,N]))\\ Strict less than order on {\D} & Dlt & (infix notations \verb=<= and \verb=>= [70,N]))\\ \end{tabular} \bigskip \end{minipage} \bigskip The status of \verb!>=! and \verb!>! is undecided yet. It will eithet be accepted only as parsing notations or may also accepted as a {\em definition} for the \verb!<=! and \verb!= 4 & + String.sub (Sys.ocaml_version) 0 4 = \"3.10\" + then + (* ocaml 3.10 does not have #rectypes but needs it *) + (* simulate a call with option -rectypes before *) + (* jumping to the ocaml toplevel *) + for i = 1 to Array.length Sys.argv - 1 do + Sys.argv.(i) <- \"-rectypes\" + done + else + () in + Mltop.set_top {Mltop.load_obj= (fun f -> if not (Topdirs.load_file ppf f) then failwith \"error\"); Mltop.use_file=Topdirs.dir_use ppf; Mltop.add_dir=Topdirs.dir_directory; - Mltop.ml_loop=(fun () -> Toploop.loop ppf) };;\n" + Mltop.ml_loop=(fun () -> set_rectypes_hack(); Topmain.main()) };;\n" (* create a temporary main file to link *) let create_tmp_main_file modules = coq-8.4pl4/dev/doc/changes.txt0000644000175000017500000005754012326224777015342 0ustar stephsteph========================================= = CHANGES BETWEEN COQ V8.3 AND COQ V8.4 = ========================================= ** Functions in unification.ml have now the evar_map coming just after the env ** Removal of Tacinterp.constr_of_id ** Use instead either global_reference or construct_reference in constrintern.ml. ** Optimizing calls to Evd functions ** Evars are split into defined evars and undefined evars; for efficiency, when an evar is known to be undefined, it is preferable to use specific functions about undefined evars since these ones are generally fewer than the defined ones. ** Type changes in TACTIC EXTEND rules ** Arguments bound with tactic(_) in TACTIC EXTEND rules are now of type glob_tactic_expr, instead of glob_tactic_expr * tactic. Only the first component is kept, the second one can be obtained via Tacinterp.eval_tactic. ** ARGUMENT EXTEND ** It is now forbidden to use TYPED simultaneously with {RAW,GLOB}_TYPED in ARGUMENT EXTEND statements. ** Renaming of rawconstr to glob_constr ** The "rawconstr" type has been renamed to "glob_constr" for consistency. The "raw" in everything related to former rawconstr has been changed to "glob". For more details about the rationale and scripts to migrate code using Coq's internals, see commits 13743, 13744, 13755, 13756, 13757, 13758, 13761 (by glondu, end of December 2010) in Subversion repository. Contribs have been fixed too, and commit messages there might also be helpful for migrating. ========================================= = CHANGES BETWEEN COQ V8.2 AND COQ V8.3 = ========================================= ** Light cleaning in evarutil.ml ** whd_castappevar is now whd_head_evar obsolete whd_ise disappears ** Restructuration of the syntax of binders ** binders_let -> binders binders_let_fixannot -> binders_fixannot binder_let -> closed_binder (and now covers only bracketed binders) binder was already obsolete and has been removed ** Semantical change of h_induction_destruct ** Warning, the order of the isrec and evar_flag was inconsistent and has been permuted. Tactic induction_destruct in tactics.ml is unchanged. ** Internal tactics renamed There is no more difference between bindings and ebindings. The following tactics are therefore renamed apply_with_ebindings_gen -> apply_with_bindings_gen left_with_ebindings -> left_with_bindings right_with_ebindings -> right_with_bindings split_with_ebindings -> split_with_bindings and the following tactics are removed apply_with_ebindings (use instead apply_with_bindings) eapply_with_ebindings (use instead eapply_with_bindings) ** Obsolete functions in typing.ml For mtype_of, msort_of, mcheck, now use type_of, sort_of, check ** Renaming functions renamed concrete_name -> compute_displayed_name_in concrete_let_name -> compute_displayed_let_name_in rename_rename_bound_var -> rename_bound_vars_as_displayed lookup_name_as_renamed -> lookup_name_as_displayed next_global_ident_away true -> next_ident_away_in_goal next_global_ident_away false -> next_global_ident_away ** Cleaning in commmand.ml Functions about starting/ending a lemma are in lemmas.ml Functions about inductive schemes are in indschemes.ml Functions renamed: declare_one_assumption -> declare_assumption declare_assumption -> declare_assumptions Command.syntax_definition -> Metasyntax.add_syntactic_definition declare_interning_data merged with add_notation_interpretation compute_interning_datas -> compute_full_internalization_env implicits_env -> internalization_env full_implicits_env -> full_internalization_env build_mutual -> do_mutual_inductive build_recursive -> do_fixpoint build_corecursive -> do_cofixpoint build_induction_scheme -> build_mutual_induction_scheme build_indrec -> build_induction_scheme instantiate_type_indrec_scheme -> weaken_sort_scheme instantiate_indrec_scheme -> modify_sort_scheme make_case_dep, make_case_nodep -> build_case_analysis_scheme make_case_gen -> build_case_analysis_scheme_default Types: decl_notation -> decl_notation option ** Cleaning in libnames/nametab interfaces Functions: dirpath_prefix -> pop_dirpath extract_dirpath_prefix pop_dirpath_n extend_dirpath -> add_dirpath_suffix qualid_of_sp -> qualid_of_path pr_sp -> pr_path make_short_qualid -> qualid_of_ident sp_of_syntactic_definition -> path_of_syntactic_definition sp_of_global -> path_of_global id_of_global -> basename_of_global absolute_reference -> global_of_path locate_syntactic_definition -> locate_syndef path_of_syntactic_definition -> path_of_syndef push_syntactic_definition -> push_syndef Types: section_path -> full_path ** Cleaning in parsing extensions (commit 12108) Many moves and renamings, one new file (Extrawit, that contains wit_tactic). ** Cleaning in tactical.mli tclLAST_HYP -> onLastHyp tclLAST_DECL -> onLastDecl tclLAST_NHYPS -> onNLastHypsId tclNTH_DECL -> onNthDecl tclNTH_HYP -> onNthHyp onLastHyp -> onLastHypId onNLastHyps -> onNLastDecls onClauses -> onClause allClauses -> allHypsAndConcl + removal of various unused combinators on type "clause" ========================================= = CHANGES BETWEEN COQ V8.1 AND COQ V8.2 = ========================================= A few differences in Coq ML interfaces between Coq V8.1 and V8.2 ================================================================ ** Datatypes List of occurrences moved from "int list" to "Termops.occurrences" (an alias to "bool * int list") ETIdent renamed to ETName ** Functions Eauto: e_resolve_constr, vernac_e_resolve_constr -> simplest_eapply Tactics: apply_with_bindings -> apply_with_bindings_wo_evars Eauto.simplest_apply -> Hiddentac.h_simplest_apply Evarutil.define_evar_as_arrow -> define_evar_as_product Old version of Tactics.assert_tac disappears Tactics.true_cut renamed into Tactics.assert_tac Constrintern.interp_constrpattern -> intern_constr_pattern Hipattern.match_with_conjunction is a bit more restrictive Hipattern.match_with_disjunction is a bit more restrictive ** Universe names (univ.mli) base_univ -> type0_univ (* alias of Set is the Type hierarchy *) prop_univ -> type1_univ (* the type of Set in the Type hierarchy *) neutral_univ -> lower_univ (* semantic alias of Prop in the Type hierarchy *) is_base_univ -> is_type1_univ is_empty_univ -> is_lower_univ ** Sort names (term.mli) mk_Set -> set_sort mk_Prop -> prop_sort type_0 -> type1_sort ========================================= = CHANGES BETWEEN COQ V8.0 AND COQ V8.1 = ========================================= A few differences in Coq ML interfaces between Coq V8.0 and V8.1 ================================================================ ** Functions Util: option_app -> option_map Term: substl_decl -> subst_named_decl Lib: library_part -> remove_section_part Printer: prterm -> pr_lconstr Printer: prterm_env -> pr_lconstr_env Ppconstr: pr_sort -> pr_rawsort Evd: in_dom, etc got standard ocaml names (i.e. mem, etc) Pretyping: - understand_gen_tcc and understand_gen_ltac merged into understand_ltac - type_constraints can now say typed by a sort (use OfType to get the previous behavior) Library: import_library -> import_module ** Constructors Declarations: mind_consnrealargs -> mind_consnrealdecls NoRedun -> NoDup Cast and RCast have an extra argument: you can recover the previous behavior by setting the extra argument to "CastConv DEFAULTcast" and "DEFAULTcast" respectively Names: "kernel_name" is now "constant" when argument of Term.Const Tacexpr: TacTrueCut and TacForward(false,_,_) merged into new TacAssert Tacexpr: TacForward(true,_,_) branched to TacLetTac ** Modules module Decl_kinds: new interface module Bigint: new interface module Tacred spawned module Redexpr module Symbols -> Notation module Coqast, Ast, Esyntax, Termast, and all other modules related to old syntax are removed module Instantiate: integrated to Evd module Pretyping now a functor: use Pretyping.Default instead ** Internal names OBJDEF and OBJDEF1 -> CANONICAL-STRUCTURE ** Tactic extensions - printers have an extra parameter which is a constr printer at high precedence - the tactic printers have an extra arg which is the expected precedence - level is now a precedence in declare_extra_tactic_pprule - "interp" functions now of types the actual arg type, not its encapsulation as a generic_argument ========================================= = CHANGES BETWEEN COQ V7.4 AND COQ V8.0 = ========================================= See files in dev/syntax-v8 ============================================== = MAIN CHANGES BETWEEN COQ V7.3 AND COQ V7.4 = ============================================== CHANGES DUE TO INTRODUCTION OF MODULES ====================================== 1.Kernel -------- The module level has no effect on constr except for the structure of section_path. The type of unique names for constructions (what section_path served) is now called a kernel name and is defined by type uniq_ident = int * string * dir_path (* int may be enough *) type module_path = | MPfile of dir_path (* reference to physical module, e.g. file *) | MPbound of uniq_ident (* reference to a module parameter in a functor *) | MPself of uniq_ident (* reference to one of the containing module *) | MPdot of module_path * label type label = identifier type kernel_name = module_path * dir_path * label ^^^^^^^^^^^ ^^^^^^^^ ^^^^^ | | \ | | the base name | \ / the (true) section path example: (non empty only inside open sections) L = (* i.e. some file of logical name L *) struct module A = struct Def a = ... end end M = (* i.e. some file of logical name M *) struct Def t = ... N = functor (X : sig module T = struct Def b = ... end end) -> struct module O = struct Def u = ... end Def x := ... .t ... .O.u ... X.T.b ... L.A.a and are self-references, X is a bound reference and L is a reference to a physical module. Notice that functor application is not part of a path: it must be named by a "module M = F(A)" declaration to be used in a kernel name. Notice that Jacek chose a practical approach, making directories not modules. Another approach could have been to replace the constructor MPfile by a constant constructor MProot representing the root of the world. Other relevant informations are in kernel/entries.ml (type module_expr) and kernel/declarations.ml (type module_body and module_type_body). 2. Library ---------- i) tables [Summaries] - the only change is the special treatment of the global environmet. ii) objects [Libobject] declares persistent objects, given with methods: * cache_function specifying how to add the object in the current scope; * load_function, specifying what to do when the module containing the object is loaded; * open_function, specifying what to do when the module containing the object is opened (imported); * classify_function, specyfying what to do with the object, when the current module (containing the object) is ended. * subst_function * export_function, to signal end_section survival (Almost) Each of these methods is called with a parameter of type object_name = section_path * kernel_name where section_path is the full user name of the object (such as Coq.Init.Datatypes.Fst) and kernel_name is its substitutive internal version such as (MPself,[],"Fst") (see above) What happens at the end of an interactive module ? ================================================== (or when a file is stored and reloaded from disk) All summaries (except Global environment) are reverted to the state from before the beginning of the module, and: a) the objects (again, since last Declaremods.start_module or Library.start_library) are classified using the classify_function. To simplify consider only those who returned Substitute _ or Keep _. b) If the module is not a functor, the subst_function for each object of the first group is called with the substitution [MPself "" |-> MPfile "Coq.Init.Datatypes"]. Then the load_function is called for substituted objects and the "keep" object. (If the module is a library the substitution is done at reloading). c) The objects which returned substitute are stored in the modtab together with the self ident of the module, and functor argument names if the module was a functor. They will be used (substituted and loaded) when a command like Module M := F(N) or Module Z := N is evaluated The difference between "substitute" and "keep" objects ======================================================== i) The "keep" objects can _only_ reference other objects by section_paths and qualids. They do not need the substitution function. They will work after end_module (or reloading a compiled library), because these operations do not change section_path's They will obviously not work after Module Z:=N. These would typically be grammar rules, pretty printing rules etc. ii) The "substitute" objects can _only_ reference objects by kernel_names. They must have a valid subst_function. They will work after end_module _and_ after Module Z:=N or Module Z:=F(M). Other kinds of objects: iii) "Dispose" - objects which do not survive end_module As a consequence, objects which reference other objects sometimes by kernel_names and sometimes by section_path must be of this kind... iv) "Anticipate" - objects which must be treated individually by end_module (typically "REQUIRE" objects) Writing subst_thing functions ============================= The subst_thing shoud not copy the thing if it hasn't actually changed. There are some cool emacs macros in dev/objects.el to help writing subst functions this way quickly and without errors. Also there are *_smartmap functions in Util. The subst_thing functions are already written for many types, including constr (Term.subst_mps), global_reference (Libnames.subst_global), rawconstr (Rawterm.subst_raw) etc They are all (apart from constr, for now) written in the non-copying way. Nametab ======= Nametab has been made more uniform. For every kind of thing there is only one "push" function and one "locate" function. Lib === library_segment is now a list of object_name * library_item, where object_name = section_path * kernel_name (see above) New items have been added for open modules and module types Declaremods ========== Functions to declare interactive and noninteractive modules and module types. Library ======= Uses Declaremods to actually communicate with Global and to register objects. OTHER CHANGES ============= Internal representation of tactics bindings has changed (see type Rawterm.substitution). New parsing model for tactics and vernacular commands - Introduction of a dedicated type for tactic expressions (Tacexpr.raw_tactic_expr) - Introduction of a dedicated type for vernac expressions (Vernacexpr.vernac_expr) - Declaration of new vernacular parsing rules by a new camlp4 macro GRAMMAR COMMAND EXTEND ... END to be used in ML files - Declaration of new tactics parsing/printing rules by a new camlp4 macro TACTIC EXTEND ... END to be used in ML files New organisation of THENS: tclTHENS tac tacs : tacs is now an array tclTHENSFIRSTn tac1 tacs tac2 : apply tac1 then, apply the array tacs on the first n subgoals and tac2 on the remaining subgoals (previously tclTHENST) tclTHENSLASTn tac1 tac2 tacs : apply tac1 then, apply tac2 on the first subgoals and apply the array tacs on the last n subgoals tclTHENFIRSTn tac1 tacs = tclTHENSFIRSTn tac1 tacs tclIDTAC (prev. tclTHENSI) tclTHENLASTn tac1 tacs = tclTHENSLASTn tac1 tclIDTAC tacs tclTHENFIRST tac1 tac2 = tclTHENFIRSTn tac1 [|tac2|] tclTHENLAST tac1 tac2 = tclTHENLASTn tac1 [|tac2|] (previously tclTHENL) tclTHENS tac1 tacs = tclTHENSFIRSTn tac1 tacs (fun _ -> error "wrong number") tclTHENSV same as tclTHENS but with an array tclTHENSi : no longer available Proof_type: subproof field in type proof_tree glued with the ref field Tacmach: no more echo from functions of module Refiner Files plugins/*/g_*.ml4 take the place of files plugins/*/*.v. Files parsing/{vernac,tac}extend.ml{4,i} implements TACTIC EXTEND andd VERNAC COMMAND EXTEND macros File syntax/PPTactic.v moved to parsing/pptactic.ml Tactics about False and not now in tactics/contradiction.ml Tactics depending on Init now tactics/*.ml4 (no longer in tactics/*.v) File tacinterp.ml moved from proofs to directory tactics ========================================== = MAIN CHANGES FROM COQ V7.1 TO COQ V7.2 = ========================================== The core of Coq (kernel) has meen minimized with the following effects: kernel/term.ml split into kernel/term.ml, pretyping/termops.ml kernel/reduction.ml split into kernel/reduction.ml, pretyping/reductionops.ml kernel/names.ml split into kernel/names.ml, library/nameops.ml kernel/inductive.ml split into kernel/inductive.ml, pretyping/inductiveops.ml the prefixes "Is" ans "IsMut" have been dropped from kind_of_term constructors, e.g. IsRel is now Rel, IsMutCase is now Case, etc. ======================================================= = PRINCIPAUX CHANGEMENTS ENTRE COQ V6.3.1 ET COQ V7.0 = ======================================================= Changements d'organisation / modules : -------------------------------------- Std, More_util -> lib/util.ml Names -> kernel/names.ml et kernel/sign.ml (les parties noms et signatures ont été séparées) Avm,Mavm,Fmavm,Mhm -> utiliser plutôt Map (et freeze alors gratuit) Mhb -> Bij Generic est intégré ā Term (et un petit peu ā Closure) Changements dans les types de données : --------------------------------------- dans Generic: free_rels : constr -> int Listset.t devient : constr -> Intset.t type_judgement -> typed_type environment -> context context -> typed_type signature ATTENTION: ---------- Il y a maintenant d'autres exceptions que UserError (TypeError, RefinerError, etc.) Il ne faut donc plus se contenter (pour rattraper) de faire try . .. with UserError _ -> ... mais écrire ā la place try ... with e when Logic.catchable_exception e -> ... Changements dans les fonctions : -------------------------------- Vectops. it_vect -> Array.fold_left vect_it -> Array.fold_right exists_vect -> Util.array_exists for_all2eq_vect -> Util.array_for_all2 tabulate_vect -> Array.init hd_vect -> Util.array_hd tl_vect -> Util.array_tl last_vect -> Util.array_last it_vect_from -> array_fold_left_from vect_it_from -> array_fold_right_from app_tl_vect -> array_app_tl cons_vect -> array_cons map_i_vect -> Array.mapi map2_vect -> array_map2 list_of_tl_vect -> array_list_of_tl Names sign_it -> fold_var_context (se fait sur env maintenant) it_sign -> fold_var_context_reverse (sur env maintenant) Generic noccur_bet -> noccur_between substn_many -> substnl Std comp -> Util.compose rev_append -> List.rev_append Termenv mind_specif_of_mind -> Global.lookup_mind_specif ou Environ.lookup_mind_specif si on a un env sous la main mis_arity -> instantiate_arity mis_lc -> instantiate_lc Ex-Environ mind_of_path -> Global.lookup_mind Printer gentermpr -> gen_pr_term term0 -> prterm_env pr_sign -> pr_var_context pr_context_opt -> pr_context_of pr_ne_env -> pr_ne_context_of Typing, Machops type_of_type -> judge_of_type fcn_proposition -> judge_of_prop_contents safe_fmachine -> safe_infer Reduction, Clenv whd_betadeltat -> whd_betaevar whd_betadeltatiota -> whd_betaiotaevar find_mrectype -> Inductive.find_mrectype find_minductype -> Inductive.find_inductive find_mcoinductype -> Inductive.find_coinductive Astterm constr_of_com_casted -> interp_casted_constr constr_of_com_sort -> interp_type constr_of_com -> interp_constr rawconstr_of_com -> interp_rawconstr type_of_com -> type_judgement_of_rawconstr judgement_of_com -> judgement_of_rawconstr Termast bdize -> ast_of_constr Tacmach pf_constr_of_com_sort -> pf_interp_type pf_constr_of_com -> pf_interp_constr pf_get_hyp -> pf_get_hyp_typ pf_hyps, pf_untyped_hyps -> pf_env (tout se fait sur env maintenant) Pattern raw_sopattern_of_compattern -> Astterm.interp_constrpattern somatch -> is_matching dest_somatch -> matches Tacticals matches -> gl_is_matching dest_match -> gl_matches suff -> utiliser sort_of_goal lookup_eliminator -> utiliser sort_of_goal pour le dernier arg Divers initial_sign -> var_context Sign ids_of_sign -> ids_of_var_context (or Environ.ids_of_context) empty_sign -> empty_var_context Pfedit list_proofs -> get_all_proof_names get_proof -> get_current_proof_name abort_goal -> abort_proof abort_goals -> abort_all_proofs abort_cur_goal -> abort_current_proof get_evmap_sign -> get_goal_context/get_current_goal_context unset_undo -> reset_undo Proof_trees mkGOAL -> mk_goal Declare machine_constant -> declare_constant (+ modifs) ex-Trad, maintenant Pretyping inh_cast_rel -> Coercion.inh_conv_coerce_to inh_conv_coerce_to -> Coercion.inh_conv_coerce_to_fail ise_resolve1 -> understand, understand_type ise_resolve -> understand_judgment, understand_type_judgment ex-Tradevar, maintenant Evarutil mt_tycon -> empty_tycon Recordops struc_info -> find_structure Changements dans les inductifs ------------------------------ Nouveaux types "constructor" et "inductive" dans Term La plupart des fonctions de typage des inductives prennent maintenant un inductive au lieu d'un oonstr comme argument. Les seules fonctions ā traduire un constr en inductive sont les find_rectype and co. Changements dans les grammaires ------------------------------- . le lexer (parsing/lexer.mll) est maintenant un lexer ocamllex . attention : LIDENT -> IDENT (les identificateurs n'ont pas de casse particuličre dans Coq) . Le mot "command" est remplacé par "constr" dans les noms de fichiers, noms de modules et non-terminaux relatifs au parsing des termes; aussi les changements suivants "COMMAND"/"CONSTR" dans g_vernac.ml4, VARG_COMMAND/VARG_CONSTR dans vernac*.ml* . Les constructeurs d'arguments de tactiques IDENTIFIER, CONSTR, ...n passent en minuscule Identifier, Constr, ... . Plusieurs parsers ont changé de format (ex: sortarg) Changements dans le pretty-printing ----------------------------------- . Découplage de la traduction de constr -> rawconstr (dans detyping) et de rawconstr -> ast (dans termast) . Déplacement des options d'affichage de printer vers termast . Déplacement des réaiguillage d'univers du pp de printer vers esyntax Changements divers ------------------ . il n'y a plus de script coqtop => coqtop et coqtop.byte sont directement le résultat du link du code => debuggage et profiling directs . il n'y a plus d'installation locale dans bin/$ARCH . #use "include.ml" => #use "include" go() => loop() . il y a "make depend" et "make dependcamlp4" car ce dernier prend beaucoup de temps coq-8.4pl4/dev/doc/unification.txt0000644000175000017500000001222512326224777016231 0ustar stephstephSome notes about the use of unification in Coq ---------------------------------------------- There are several applications of unification and pattern-matching ** Unification of types ** - For type inference, inference of implicit arguments * this basically amounts to solve problems of the form T <= U or T = U where T and U are types coming from a given typing problem * this kind of problem has to succeed and all the power of unification is a priori expected (full beta/delta/iota/zeta/nu/mu, pattern-unification, pruning, imitation/projection heuristics, ...) - For lemma application (apply, auto, ...) * these are also problems of the form T <= U on types but with T coming from a lemma and U from the goal * it is not obvious that we always want unification and not matching * it is not clear which amounts of delta one wants to use ** Looking for subterms ** - For tactics applying on subterms: induction, destruct, rewrite - As part of unification of types in the presence of higher-order evars (e.g. when applying a lemma of conclusion "?P t") ---------------------------------------------------------------------- Here are examples of features one may want or not when looking for subterms A- REWRITING 1- Full conversion on closed terms 1a- Full conversion on closed terms in the presence of at least one evars (meta) Section A1. Variable y: nat. Hypothesis H: forall x, x+2 = 0. Goal y+(1+1) = 0. rewrite H. (* 0 = 0 *) Abort. Goal 2+(1+1) = 0. rewrite H. (* 0 = 0 *) Abort. (* This exists since the very beginning of Chet's unification for tactics *) (* But this fails for setoid rewrite *) 1b- Full conversion on closed terms without any evars in the lemma 1b.1- Fails on rewrite (because Unification.w_unify_to_subterm_list replaces unification by check for a syntactic subterm if terms has no evar/meta) Goal 0+1 = 0 -> 0+(1+0) = 0. intros H; rewrite H. (* fails *) Abort. 1b.2- Works with setoid rewrite Require Import Setoid. Goal 0+1 = 0 -> 0+(1+0) = 0. intros H; rewrite H at 1. (* 0 = 0 *) Abort. 2- Using known instances in full conversion on closed terms Section A2. Hypothesis H: forall x, x+(2+x) = 0. Goal 1+(1+2) = 0. rewrite H. Abort. End A2. (* This exists since 8.2 (HH) *) 3- Pattern-unification on Rels Section A3a. Variable F: (nat->nat->nat)->nat. Goal exists f, F (fun x y => f x y) = 0 -> F (fun x y => plus y x) = 0. eexists. intro H; rewrite H. (* 0 = 0 *) Abort. End A3a. (* Works since pattern unification on Meta applied to Rel was introduced *) (* in unification.ml (8.1, Sep 2006, HH) *) Section A3b. Variables x y: nat. Variable H: forall f, f x y = 0. Goal plus y x = 0. rewrite H. (* 0 = 0 *) Abort. End A3b. (* Works since pattern unification on all Meta was supported *) (* in unification.ml (8.4, Jun 2011, HH) *) 4- Unification with open terms Section A4. Hypothesis H: forall x, S x = 0. Goal S 0 = 0. rewrite (H _). (* 0 = 0 *) Abort. End A4. (* Works since unification on Evar was introduced so as to support rewriting *) (* with open terms (8.2, MS, r11543, Unification.w_unify_to_subterm_list ) *) 5- Unification of pre-existing evars 5a- Basic unification of pre-existing evars Section A4. Variables x y: nat. Goal exists z, S z = 0 -> S (plus y x) = 0. eexists. intro H; rewrite H. (* 0 = 0 *) Abort. End A4. (* This worked in 8.2 and 8.3 as a side-effect of support for rewriting *) (* with open terms (8.2, MS, r11543) *) 5b- Pattern-unification of pre-existing evars in rewriting lemma Goal exists f, forall x y, f x y = 0 -> plus y x = 0. eexists. intros x y H; rewrite H. (* 0 = 0 *) Abort. (* Works since pattern-unification on Evar was introduced *) (* in unification.ml (8.3, HH, r12229) *) (* currently governed by a flag: use_evars_pattern_unification *) 5c- Pattern-unification of pre-existing evars in goal Goal exists f, forall x y, plus x y = 0 -> f y x = 0. eexists. intros x y H; rewrite H. (* 0 = 0 *) Abort. (* This worked in 8.2 and 8.3 but was removed for autorewrite in 8.4 *) 5d- Mixing pattern-unification of pre-existing evars in goal and evars in lemma Goal exists f, forall x, (forall y, plus x y = 0) -> forall y:nat, f y x = 0. eexists. intros x H y. rewrite H. (* 0 = 0 *) Abort. (* This worked in 8.2 and 8.3 but was removed for autorewrite in 8.4 *) 6- Multiple non-identical but convertible occurrences Tactic rewrite only considers the first one, from left-to-right, e.g.: Section A6. Variable y: nat. Hypothesis H: forall x, x+2 = 0. Goal (y+(2+0))+(y+(1+1)) = (y+(1+1))+(y+(2+0)). rewrite H. (* 0+(y+(1+1)) = y+(1+1)+0 *) Abort. End A6. Tactic setoid rewrite first looks for syntactically equal terms and if not uses the leftmost occurrence modulo delta. Require Import Setoid. Section A6. Variable y: nat. Hypothesis H: forall x, x+2 = 0. Goal (y+(2+0))+(y+2) = (y+2)+(y+(2+0)). rewrite H at 1 2 3 4. (* (y+(2+0))+0 = 0+(y+(2+0)) *) Abort. Goal (y+(2+0))+(y+(1+1)) = (y+(1+1))+(y+(2+0)). rewrite H at 1 2 3 4. (* 0+(y+(1+1)) = y+(1+1)+0 *) Abort. End A6. 7- Conversion Section A6. Variable y: nat. Hypothesis H: forall x, S x = 0. Goal id 1 = 0. rewrite H. B- ELIMINATION (INDUCTION / CASE ANALYSIS) This is simpler because open terms are not allowed and no unification is involved (8.3). coq-8.4pl4/dev/doc/perf-analysis0000644000175000017500000001312312326224777015656 0ustar stephstephPerformance analysis (trunk repository) --------------------------------------- Jun 7, 2010: delayed re-typing of Ltac instances in matching (-1% on HighSchoolGeometry, -2% on JordanCurveTheorem) Jun 4, 2010: improvement in eauto and type classes inference by removing systematic preparation of debugging pretty-printing streams (std_ppcmds) (-7% in ATBR, visible only on V8.3 logs since ATBR is broken in trunk; -6% in HighSchoolGeometry) Apr 19, 2010: small improvement obtained by reducing evar instantiation from O(n^3) to O(n^2) in the size of the instance (-2% in Compcert, -2% AreaMethod, -15% in Ssreflect) Apr 17, 2010: small improvement obtained by not repeating unification twice in auto (-2% in Compcert, -2% in Algebra) Feb 15, 2010: Global decrease due to unicode inefficiency repaired Jan 8, 2010: Global increase due to an inefficiency in unicode treatment Dec 1, 2009 - Dec 19, 2009: Temporary addition of [forall x, P x] hints to exact (generally not significative but, e.g., +25% on Subst, +8% on ZFC, +5% on AreaMethod) Oct 19, 2009: Change in modules (CoLoR +35%) Aug 9, 2009: new files added in AreaMethod May 21, 2008: New version of CoRN (needs +84% more time to compile) Apr 25-29, 2008: Temporary attempt with delta in eauto (Matthieu) (+28% CoRN) Apr 17, 2008: improvement probably due to commit 10807 or 10813 (bug fixes, control of zeta in rewrite, auto (??)) (-18% Buchberger, -40% PAutomata, -28% IntMap, -43% CoRN, -13% LinAlg, but CatsInZFC -0.5% only, PiCalc stable, PersistentUnionFind -1%) Mar 11, 2008: (+19% PersistentUnionFind wrt Mar 3, +21% Angles, +270% Continuations between 7/3 and 18/4) Mar 7, 2008: (-10% PersistentUnionFind wrt Mar 3) Feb 20, 2008: temporary 1-day slow down (+64% LinAlg) Feb 14, 2008: (-10% PersistentUnionFind, -19% Groups) Feb 7, 8, 2008: temporary 2-days long slow down (+20 LinAlg, +50% BDDs) Feb 2, 2008: many updates of the module system (-13% LinAlg, -50% AMM11262, -5% Goedel, -1% PersistentUnionFind, -42% ExactRealArithmetic, -41% Icharate, -42% Kildall, -74% SquareMatrices) Jan 1, 2008: merge of TypeClasses branch (+8% PersistentUnionFind, +36% LinAlg, +76% Goedel) Nov 16, 17, 2007: (+18% Cantor, +4% LinAlg, +27% IEEE1394 on 2 days) Nov 8, 2007: (+18% Cantor, +16% LinAlg, +55% Continuations, +200% IEEE1394, +170% CTLTCTL, +220% SquareMatrices) Oct 29, V8.1 (+ 3% geometry but CoRN, Godel, Kildall, Stalmark stables) Between Oct 12 and Oct 27, 2007: inefficiency temporarily introduced in the tactic interpreter (from revision 10222 to 10267) (+22% CoRN, +10% geometry, ...) Sep 16, 2007: (+16% PersistentUnionFind on 3 days, LinAlg stable, Sep 4, 2007: (+26% PersistentUnionFind, LinAlg stable, Jun 6, 2007: optimization of the need for type unification in with-bindings (-3.5% Stalmark, -6% Kildall) May 20, 21, 22, 2007: improved inference of with-bindings (including activation of unification on types) (+4% PICALC, +5% Stalmark, +7% Kildall) May 11, 2007: added primitive integers (+6% CoLoR, +7% CoRN, +5% FSets, ...) Between Feb 22 and March 16, 2007: bench temporarily moved on JMN's computer (-25% CoRN, -25% Fairisle, ...) Oct 29 and Oct 30, 2006: abandoned attempt to add polymorphism on definitions (+4% in general during these two days) Oct 17, 2006: improvement in new field [r9248] (QArith -3%, geometry: -2%) Oct 5, 2006: fixing wrong unification of Meta below binders (e.g. CatsInZFC: +10%, CoRN: -2.5%, Godel: +4%, LinAlg: +7%, DISTRIBUTED_REFERENCE_COUNTING: +10%, CoLoR: +1%) Sep 26, 2006: new field [r9178-9181] (QArith: -16%, geometry: -5%, Float: +6%, BDDS:+5% but no ring in it) Sep 12, 2006: Rocq/AREA_METHOD extended (~ 530s) Aug 12, 2006: Rocq/AREA_METHOD added (~ 480s) May 30, 2006: Nancy/CoLoR added (~ 319s) May 23, 2006: new, lighter version of polymorphic inductive types (CoRN: -27%, back to Mar-24 time) May 17, 2006: changes in List.v (DISTRIBUTED_REFERENCE_COUNTING: -) May 5, 2006: improvement in closure (array instead of lists) (e.g. CatsInZFC: -10%, CoRN: -3%, May 23, 2006: polymorphic inductive types (precise, heavy algorithm) (CoRN: +37%) Dec 29, 2005: new test and use of -vm in Stalmarck Dec 27, 2005: contrib Karatsuba added (~ 30s) Dec 28, 2005: size decrease mainly due to Defined moved to Qed in FSets (reduction from 95M to 7Mo) Dec 1-14, 2005: benchmarking server down between the two dates: Godel: -10%, CoRN: -10% probably due to changes around vm (new informative Cast, change of equality in named_context_val) Oct 6, 2005: contribs IPC and Tait added (~ 22s and ~ 25s) Aug 19, 2005: time decrease after application of "Array.length x=0" Xavier's suggestions for optimisation (e.g. Nijmegen/QArith: -3%, Nijmegen/CoRN: -7%, Godel: -3%) Aug 1, 2005: contrib Kildall added (~ 65s) Jul 26-Aug 2, 2005: bench down Jul 14-15, 2005: 4 contribs failed including CoRN Jul 14, 2005: time increase after activation of "closure optimisation" (e.g. Nijmegen/QArith: +8%, Nijmegen/CoRN: +3%, Godel: +13%) Jul 7, 2005: adding contrib Fermat4 Jun 17, 2005: contrib Goodstein extended and moved to CantorOrdinals (~ 30s) May 19, 2005: contrib Goodstein and prfx (~ 9s) added Apr 21, 2005: strange time decrease (could it be due to the change of Back and Reset mechanism) (e.g. Nijmegen/CoRN: -2%, Nijmegen/QARITH: -4%, Godel: -11%) Mar 20, 2005: fixed Logic.with_check bug global time decrease (e.g. Nijmegen/CoRN: -3%, Nijmegen/QARITH: -1.5%) Jan 31-Feb 8, 2005: small instability (e.g. CoRN: ~2015s -> ~1999s -> ~2032s, Godel: ~340s -> ~370s) Jan 13, 2005: contrib SumOfTwoSquare added (~ 38s) coq-8.4pl4/dev/doc/extensions.txt0000644000175000017500000000131312326224777016114 0ustar stephstephComment ajouter une nouvelle entrée primitive pour les TACTIC EXTEND ? ====================================================================== Exemple de l'ajout de l'entrée "clause": - ajouter un type ClauseArgType dans interp/genarg.ml{,i}, avec les wit_, rawwit_, et globwit_ correspondants - ajouter partout oų Genarg.argument_type est filtré le cas traitant de ce nouveau ClauseArgType - utiliser le rawwit_clause pour définir une entrée clause du bon type et du bon nom dans le module Tactic de pcoq.ml4 - il faut aussi exporter la rčgle hors de g_tactic.ml4. Pour cela, il faut rejouter clause dans le GLOBAL du GEXTEND - seulement aprčs, le nom clause sera accessible dans les TACTIC EXTEND ! coq-8.4pl4/dev/doc/debugging.txt0000644000175000017500000000641512326224777015660 0ustar stephstephDebugging from Coq toplevel using Caml trace mechanism ====================================================== 1. Launch bytecode version of Coq (coqtop.byte or coqtop -byte) 2. Access Ocaml toplevel using vernacular command 'Drop.' 3. Install load paths and pretty printers for terms, idents, ... using Ocaml command '#use "base_include";;' (use '#use "include";;' for installing the advanced term pretty printers) 4. Use #trace to tell which function(s) to trace 5. Go back to Coq toplevel with 'go();;' 6. Test your Coq command and observe the result of tracing your functions 7. Freely switch from Coq to Ocaml toplevels with 'Drop.' and 'go();;' You can avoid typing #use "include" (or "base_include") after Drop by adding the following lines in your $HOME/.ocamlinit : if Filename.basename Sys.argv.(0) = "coqtop.byte" then ignore (Toploop.use_silently Format.std_formatter "include") Hints: To remove high-level pretty-printing features (coercions, notations, ...), use "Set Printing All". It will affect the #trace printers too. Note for Ocaml 3.10.x: Ocaml 3.10.x requires that modules compiled with -rectypes are loaded in an environment with -rectypes set but there is no way to tell the toplevel to support -rectypes. To make it works, use "patch -p0 < dev/doc/patch.ocaml-3.10.drop.rectypes" to hack script/coqmktop.ml, then recompile coqtop.byte. The procedure above then works as soon as coqtop.byte is called with at least one argument (add neutral option -byte to ensure at least one argument). Debugging from Caml debugger ============================ Needs tuareg mode in Emacs Coq must be configured with -debug and -local (./configure -debug -local) 1. M-x camldebug 2. give the binary name bin/coqtop.byte 3. give ../dev/ocamldebug-coq 4. source db (to get pretty-printers) 5. add breakpoints with C-x C-a C-b from the buffer displaying the ocaml source 6. get more help from ocamldebug manual run step back start next last print x (abbreviated into p x) ... 7. some hints: - To debug a failure/error/anomaly, add a breakpoint in Vernac.vernac_com at the with clause of the "try ... interp com with ..." block, then go "back" a few steps to find where the failure/error/anomaly has been raised - Alternatively, for an error or an anomaly, add breakpoints in the middle of each of error* functions or anomaly* functions in lib/util.ml - If "source db" fails, recompile printers.cma with "make dev/printers.cma" and try again Global gprof-based profiling ============================ Coq must be configured with option -profile 1. Run native Coq which must end normally (use Quit or option -batch) 2. gprof ./coqtop gmon.out Per function profiling ====================== 1. To profile function foo in file bar.ml, add the following lines, just after the definition of the function: let fookey = Profile.declare_profile "foo";; let foo a b c = Profile.profile3 fookey foo a b c;; where foo is assumed to have three arguments (adapt using Profile.profile1, Profile. profile2, etc). This has the effect to cumulate the time passed in foo under a line of name "foo" which is displayed at the time coqtop exits. coq-8.4pl4/dev/doc/notes-on-conversion0000644000175000017500000000501512326224777017027 0ustar stephsteph(**********************************************************************) (* A few examples showing the current limits of the conversion algorithm *) (**********************************************************************) (*** We define (pseudo-)divergence from Ackermann function ***) Definition ack (n : nat) := (fix F (n0 : nat) : nat -> nat := match n0 with | O => S | S n1 => fun m : nat => (fix F0 (n2 : nat) : nat := match n2 with | O => F n1 1 | S n3 => F n1 (F0 n3) end) m end) n. Notation OMEGA := (ack 4 4). Definition f (x:nat) := x. (* Evaluation in tactics can somehow be controled *) Lemma l1 : OMEGA = OMEGA. reflexivity. (* succeed: identity *) Qed. (* succeed: identity *) Lemma l2 : OMEGA = f OMEGA. reflexivity. (* fail: conversion wants to convert OMEGA with f OMEGA *) Abort. (* but it reduces the right side first! *) Lemma l3 : f OMEGA = OMEGA. reflexivity. (* succeed: reduce left side first *) Qed. (* succeed: expected concl (the one with f) is on the left *) Lemma l4 : OMEGA = OMEGA. assert (f OMEGA = OMEGA) by reflexivity. (* succeed *) unfold f in H. (* succeed: no type-checking *) exact H. (* succeed: identity *) Qed. (* fail: "f" is on the left *) (* This example would fail whatever the preferred side is *) Lemma l5 : OMEGA = f OMEGA. unfold f. assert (f OMEGA = OMEGA) by reflexivity. unfold f in H. exact H. Qed. (* needs to convert (f OMEGA = OMEGA) and (OMEGA = f OMEGA) *) (**********************************************************************) (* Analysis of the inefficiency in Nijmegen/LinAlg/LinAlg/subspace_dim.v *) (* (proof of span_ind_uninject_prop *) In the proof, a problem of the form (Equal S t1 t2) is "simpl"ified, then "red"uced to (Equal S' t1 t1) where the new t1's are surrounded by invisible coercions. A reflexivity steps conclude the proof. The trick is that Equal projects the equality in the setoid S, and that (Equal S) itself reduces to some (fun x y => Equal S' (f x) (g y)). At the Qed time, the problem to solve is (Equal S t1 t2) = (Equal S' t1 t1) and the algorithm is to first compare S and S', and t1 and t2. Unfortunately it does not work, and since t1 and t2 involve concrete instances of algebraic structures, it takes a lot of time to realize that it is not convertible. The only hope to improve this problem is to observe that S' hides (behind two indirections) a Setoid constructor. This could be the argument to solve the problem. coq-8.4pl4/dev/base_include0000644000175000017500000001076712326224777014764 0ustar stephsteph (* File to include to get some Coq facilities under the ocaml toplevel. This file is loaded by include *) #cd".";; #directory "parsing";; #directory "interp";; #directory "toplevel";; #directory "library";; #directory "kernel";; #directory "pretyping";; #directory "lib";; #directory "proofs";; #directory "tactics";; #directory "translate";; #directory "+camlp4";; (* lazy solution: add both of camlp4/5 so that *) #directory "+camlp5";; (* Gramext is found in top_printers.ml *) #use "top_printers.ml";; #use "vm_printers.ml";; #install_printer (* identifier *) ppid;; #install_printer (* identifier *) ppidset;; #install_printer (* Intset.t *) ppintset;; #install_printer (* label *) pplab;; #install_printer (* mod_bound_id *) ppmbid;; #install_printer (* dir_path *) ppdir;; #install_printer (* module_path *) ppmp;; #install_printer (* section_path *) ppsp;; #install_printer (* qualid *) ppqualid;; #install_printer (* kernel_name *) ppkn;; #install_printer (* constant *) ppcon;; #install_printer (* cl_index *) ppclindex;; #install_printer (* constr *) print_pure_constr;; #install_printer (* patch *) ppripos;; #install_printer (* values *) ppvalues;; #install_printer (* Idpred.t *) pp_idpred;; #install_printer (* Cpred.t *) pp_cpred;; #install_printer ppzipper;; #install_printer ppstack;; #install_printer ppatom;; #install_printer ppwhd;; #install_printer ppvblock;; #install_printer (* bigint *) ppbigint;; #install_printer (* loc *) pploc;; #install_printer (* substitution *) prsubst;; (* Open main files *) open Names open Term open Typeops open Term_typing open Univ open Inductive open Indtypes open Cooking open Closure open Reduction open Safe_typing open Declare open Declaremods open Impargs open Libnames open Nametab open Library open Cases open Pattern open Cbv open Classops open Pretyping open Pretyping.Default open Pretyping.Default.Cases open Cbv open Classops open Clenv open Clenvtac open Glob_term open Coercion open Coercion.Default open Recordops open Detyping open Reductionops open Evarconv open Retyping open Evarutil open Tacred open Evd open Termops open Namegen open Indrec open Typing open Inductiveops open Unification open Matching open Constrextern open Constrintern open Coqlib open Genarg open Modintern open Notation open Ppextend open Reserve open Syntax_def open Topconstr open Prettyp open Search open Evar_refiner open Logic open Pfedit open Proof_type open Redexpr open Refiner open Tacmach open Decl_proof_instr open Tactic_debug open Decl_mode open Auto open Autorewrite open Contradiction open Eauto open Elim open Equality open Evar_tactics open Extraargs open Extratactics open Hiddentac open Hipattern open Inv open Leminv open Refine open Tacinterp open Tacticals open Tactics open Eqschemes open Cerrors open Class open Command open Indschemes open Ind_tables open Auto_ind_decl open Lemmas open Coqinit open Coqtop open Discharge open Himsg open Metasyntax open Mltop open Record open Toplevel open Vernacentries open Vernacinterp open Vernac (* Various utilities *) let qid = Libnames.qualid_of_string;; (* parsing of terms *) let parse_constr = Pcoq.parse_string Pcoq.Constr.constr;; let parse_tac = Pcoq.parse_string Pcoq.Tactic.tactic;; let parse_vernac = Pcoq.parse_string Pcoq.Vernac_.vernac;; (* build a term of type glob_constr without type-checking or resolution of implicit syntax *) let e s = Constrintern.intern_constr Evd.empty (Global.env()) (parse_constr s);; (* build a term of type constr with type-checking and resolution of implicit syntax *) let constr_of_string s = Constrintern.interp_constr Evd.empty (Global.env()) (parse_constr s);; (* get the body of a constant *) open Declarations;; let constbody_of_string s = let b = Global.lookup_constant (Nametab.locate_constant (qualid_of_string s)) in Option.get (body_of_constant b);; (* Get the current goal *) (* let getgoal x = top_goal_of_pftreestate (Pfedit.get_pftreestate x);; let get_nth_goal n = nth_goal_of_pftreestate n (Pfedit.get_pftreestate ());; let current_goal () = get_nth_goal 1;; *) let pf_e gl s = Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s);; (* Set usual printing since the global env is available from the tracer *) let _ = Constrextern.in_debugger := false let _ = Constrextern.set_extern_reference (fun loc _ r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Idset.empty r));; open Toplevel let go = loop let _ = print_string ("\n\tOcaml toplevel with Coq printers and utilities (use go();; to exit)\n\n"); flush_all() coq-8.4pl4/dev/vm_printers.ml0000644000175000017500000000444712326224777015324 0ustar stephstephopen Format open Term open Names open Cbytecodes open Cemitcodes open Vm let ppripos (ri,pos) = (match ri with | Reloc_annot a -> let sp,i = a.ci.ci_ind in print_string ("annot : MutInd("^(string_of_mind sp)^","^(string_of_int i)^")\n") | Reloc_const _ -> print_string "structured constant\n" | Reloc_getglobal kn -> print_string ("getglob "^(string_of_con kn)^"\n")); print_flush () let print_vfix () = print_string "vfix" let print_vfix_app () = print_string "vfix_app" let print_vswith () = print_string "switch" let ppsort = function | Prop(Pos) -> print_string "Set" | Prop(Null) -> print_string "Prop" | Type u -> print_string "Type" let print_idkey idk = match idk with | ConstKey sp -> print_string "Cons("; print_string (string_of_con sp); print_string ")" | VarKey id -> print_string (string_of_id id) | RelKey i -> print_string "~";print_int i let rec ppzipper z = match z with | Zapp args -> let n = nargs args in open_hbox (); for i = 0 to n-2 do ppvalues (arg args i);print_string ";";print_space() done; if n-1 >= 0 then ppvalues (arg args (n-1)); close_box() | Zfix _ -> print_string "Zfix" | Zswitch _ -> print_string "Zswitch" and ppstack s = open_hovbox 0; print_string "["; List.iter (fun z -> ppzipper z;print_string " | ") s; print_string "]"; close_box() and ppatom a = match a with | Aid idk -> print_idkey idk | Aiddef(idk,_) -> print_string "&";print_idkey idk | Aind(sp,i) -> print_string "Ind("; print_string (string_of_mind sp); print_string ","; print_int i; print_string ")" and ppwhd whd = match whd with | Vsort s -> ppsort s | Vprod _ -> print_string "product" | Vfun _ -> print_string "function" | Vfix _ -> print_vfix() | Vcofix _ -> print_string "cofix" | Vconstr_const i -> print_string "C(";print_int i;print_string")" | Vconstr_block b -> ppvblock b | Vatom_stk(a,s) -> open_hbox();ppatom a;close_box(); print_string"@";ppstack s and ppvblock b = open_hbox(); print_string "Cb(";print_int (btag b); let n = bsize b in for i = 0 to n -1 do print_string ",";ppvalues (bfield b i) done; print_string")"; close_box() and ppvalues v = open_hovbox 0;ppwhd (whd_val v);close_box(); print_flush() coq-8.4pl4/dev/ocamldoc/0000755000175000017500000000000012365131026014155 5ustar stephstephcoq-8.4pl4/dev/ocamldoc/html/0000755000175000017500000000000012326224777015136 5ustar stephstephcoq-8.4pl4/dev/ocamldoc/html/style.css0000644000175000017500000000625012326224777017013 0ustar stephstepha:visited { color: #416DFF; text-decoration: none; } a:link { color: #416DFF; text-decoration: none; } a:hover { color: Red; text-decoration: none; background-color: #5FFF88 } a:active { color: Red; text-decoration: underline; } .keyword { font-weight: bold; color: Red } .keywordsign { color: #C04600 } .superscript { font-size: 8 } .subscript { font-size: 8 } .comment { color: Green } .constructor { color: Blue } .type { color: #5C6585 } .string { color: Maroon } .warning { color: Red; font-weight: bold } .info { margin-left: 3em; margin-right: 3em } .param_info { margin-top: 4px; margin-left: 3em; margin-right: 3em } .code { color: #465F91; } h1 { font-size: 20pt; text-align: center; } h5, h6, div.h7, div.h8, div.h9 { font-size: 20pt; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px; text-align: center; padding: 2px; } h5 { background-color: #90FDFF; } h6 { background-color: #016699; color: white; } div.h7 { background-color: #E0FFFF; } div.h8 { background-color: #F0FFFF; } div.h9 { background-color: #FFFFFF; } .typetable, .indextable, .paramstable { border-style: hidden; } .paramstable { padding: 5pt 5pt; } body { background-color: white; } tr { background-color: white; } td.typefieldcomment { background-color: #FFFFFF; font-size: smaller; } pre { margin-bottom: 4px; } div.sig_block { margin-left: 2em; } h2 { font-family: Arial, Helvetica, sans-serif; font-size: 16pt; font-weight: normal; border-bottom: 1px solid #dadada; border-top: 1px solid #dadada; color: #101010; background: #eeeeff; margin: 25px 0px 10px 0px; padding: 1px 1px 1px 1px; } h3 { font-family: Arial, Helvetica, sans-serif; font-size: 12pt; color: #016699; font-weight: bold; padding: 15px 0 0 0ex; margin: 5px 0 0 0; } h4 { font-family: Arial, Helvetica, sans-serif; font-size: 10pt; color: #016699; padding: 15px 0 0 0ex; margin: 5px 0 0 0; } /* Here starts the overwrite of default rules to give a better look */ body { font-family: Calibri, Georgia, Garamond, Baskerville, serif; font-size: 12pt; background-color: white; } a:link, a { color: #6895c3 !important; } a:hover { color: #2F4459 !important; background-color: white; } hr { height: 1px; color: #016699; background-color: #016699; border-width: 0; } h1, h1 a:link, h1 a:visited, h1 a { font-family: Cambria, Georgia, Garamond, Baskerville, serif; color: #016699; } .navbar { float: left; } .navbar a, .navbar a:link, .navbar a:visited { color: #016699; font-family: Arial, Helvetica, sans-serif; font-weight: bold; font-size: 80%; } .keyword { color: #c13939; } .constructor { color: #3c8f7e; } pre, code { font-family: "DejaVu Sans Mono", "Bitstream Vera Mono", "Courrier New", monospace; white-space: normal; font-size: 9pt; font-weight: bold; } .type br { display: none; } .info { margin-left: 1em; font-size: 12pt; } coq-8.4pl4/dev/ocamldoc/docintro0000644000175000017500000000302012326224777015731 0ustar stephsteph{!indexlist} This is Coq, a proof assistant for the Calculus of Inductive Constructions. This document describes the implementation of Coq. It has been automatically generated from the source of Coq using {{:http://caml.inria.fr/}ocamldoc}. The source files are organized in several directories ordered like that: {ol {- Utility libraries : lib describes the various utility libraries used in the code of Coq.} {- Kernel : kernel describes the Coq kernel, which is a type checker for the Calculus of Inductive Constructions.} {- Library : library describes the Coq library, which is made of two parts: - a general mechanism to keep a trace of all operations and of the state of the system, with backtrack capabilities; - a global environment for the CCI, with functions to export and import compiled modules. } {- Pretyping : pretyping } {- Front abstract syntax of terms : interp describes the translation from Coq context-dependent front abstract syntax of terms {v constr_expr v} to and from the context-free, untyped, globalized form of constructions {v glob_constr v}.} {- Parsers and printers : parsing describes the implementation of the Coq parsers and printers.} {- Proof engine : proofs describes the Coq proof engine, which is also called the ``refiner'', since it provides a way to build terms by successive refining steps. Those steps are either primitive rules or higher-level tactics.} {- Tacticts : tactics describes the Coq main tactics.} {- Toplevel : toplevel describes the highest modules of the Coq system.} } coq-8.4pl4/dev/v8-syntax/0000755000175000017500000000000012365131026014255 5ustar stephstephcoq-8.4pl4/dev/v8-syntax/syntax-v8.tex0000644000175000017500000011637412326224777016711 0ustar stephsteph \documentclass{article} \usepackage{verbatim} \usepackage{amsmath} \usepackage{amssymb} \usepackage{array} \usepackage{fullpage} \author{B.~Barras} \title{Syntax of Coq V8} %% Le _ est un caractÃĻre normal \catcode`\_=13 \let\subscr=_ \def_{\ifmmode\sb\else\subscr\fi} \def\bfbar{\ensuremath{|\hskip -0.22em{}|\hskip -0.24em{}|}} \def\TERMbar{\bfbar} \def\TERMbarbar{\bfbar\bfbar} \def\notv{\text{_}} \def\infx#1{\notv#1\notv} %% Macros pour les grammaires \def\GR#1{\text{\large(}#1\text{\large)}} \def\NT#1{\langle\textit{#1}\rangle} \def\NTL#1#2{\langle\textit{#1}\rangle_{#2}} \def\TERM#1{{\bf\textrm{\bf #1}}} %\def\TERM#1{{\bf\textsf{#1}}} \def\KWD#1{\TERM{#1}} \def\ETERM#1{\TERM{#1}} \def\CHAR#1{\TERM{#1}} \def\STAR#1{#1*} \def\STARGR#1{\GR{#1}*} \def\PLUS#1{#1+} \def\PLUSGR#1{\GR{#1}+} \def\OPT#1{#1?} \def\OPTGR#1{\GR{#1}?} %% Tableaux de definition de non-terminaux \newenvironment{cadre} {\begin{array}{|c|}\hline\\} {\\\\\hline\end{array}} \newenvironment{rulebox} {$$\begin{cadre}\begin{array}{r@{~}c@{~}l@{}l@{}r}} {\end{array}\end{cadre}$$} \def\DEFNT#1{\NT{#1} & ::= &} \def\EXTNT#1{\NT{#1} & ::= & ... \\&|&} \def\RNAME#1{(\textsc{#1})} \def\SEPDEF{\\\\} \def\nlsep{\\&|&} \def\nlcont{\\&&} \newenvironment{rules} {\begin{center}\begin{rulebox}} {\end{rulebox}\end{center}} \begin{document} \maketitle \section{Meta notations used in this document} Non-terminals are printed between angle brackets (e.g. $\NT{non-terminal}$) and terminal symbols are printed in bold font (e.g. $\ETERM{terminal}$). Lexemes are displayed as non-terminals. The usual operators on regular expressions: \begin{center} \begin{tabular}{l|l} \hfil notation & \hfil meaning \\ \hline $\STAR{regexp}$ & repeat $regexp$ 0 or more times \\ $\PLUS{regexp}$ & repeat $regexp$ 1 or more times \\ $\OPT{regexp}$ & $regexp$ is optional \\ $regexp_1~\mid~regexp_2$ & alternative \end{tabular} \end{center} Parenthesis are used to group regexps. Beware to distinguish this operator $\GR{~}$ from the terminals $\ETERM{( )}$, and $\mid$ from terminal \TERMbar. Rules are optionaly annotated in the right margin with: \begin{itemize} \item a precedence and associativity (L for left, R for right and N for no associativity), indicating how to solve conflicts; lower levels are tighter; \item a rule name. \end{itemize} In order to solve some conflicts, a non-terminal may be invoked with a precedence (notation: $\NTL{entry}{prec}$), meaning that rules with higher precedence do not apply. \section{Lexical conventions} Lexical categories are: \begin{rules} \DEFNT{ident} \STARGR{\NT{letter}\mid\CHAR{_}} \STARGR{\NT{letter}\mid \NT{digit} \mid \CHAR{'} \mid \CHAR{_}} \SEPDEF \DEFNT{field} \CHAR{.}\NT{ident} \SEPDEF \DEFNT{meta-ident} \CHAR{?}\NT{ident} \SEPDEF \DEFNT{num} \PLUS{\NT{digit}} \SEPDEF \DEFNT{int} \NT{num} \mid \CHAR{-}\NT{num} \SEPDEF \DEFNT{digit} \CHAR{0}-\CHAR{9} \SEPDEF \DEFNT{letter} \CHAR{a}-\CHAR{z}\mid\CHAR{A}-\CHAR{Z} \mid\NT{unicode-letter} \SEPDEF \DEFNT{string} \CHAR{"}~\STARGR{\CHAR{""}\mid\NT{unicode-char-but-"}}~\CHAR{"} \end{rules} Reserved identifiers for the core syntax are: \begin{quote} \KWD{as}, \KWD{cofix}, \KWD{else}, \KWD{end}, \KWD{fix}, \KWD{for}, \KWD{forall}, \KWD{fun}, \KWD{if}, \KWD{in}, \KWD{let}, \KWD{match}, \KWD{Prop}, \KWD{return}, \KWD{Set}, \KWD{then}, \KWD{Type}, \KWD{with} \end{quote} Symbols used in the core syntax: $$ \KWD{(} ~~ \KWD{)} ~~ \KWD{\{} ~~ \KWD{\}} ~~ \KWD{:} ~~ \KWD{,} ~~ \Rightarrow ~~ \rightarrow ~~ \KWD{:=} ~~ \KWD{_} ~~ \TERMbar ~~ \KWD{@} ~~ \KWD{\%} ~~ \KWD{.(} $$ Note that \TERM{struct} is not a reserved identifier. \section{Syntax of terms} \subsection{Core syntax} The main entry point of the term grammar is $\NTL{constr}{9}$. When no conflict can appear, $\NTL{constr}{200}$ is also used as entry point. \begin{rules} \DEFNT{constr} \NT{binder-constr} &200R~~ &\RNAME{binders} \nlsep \NT{constr}~\KWD{:}~\NT{constr} &100R &\RNAME{cast} \nlsep \NT{constr}~\KWD{:}~\NT{binder-constr} &100R &\RNAME{cast'} \nlsep \NT{constr}~\KWD{$\rightarrow$}~\NT{constr} &80R &\RNAME{arrow} \nlsep \NT{constr}~\KWD{$\rightarrow$}~\NT{binder-constr} &80R &\RNAME{arrow'} \nlsep \NT{constr}~\PLUS{\NT{appl-arg}} &10L &\RNAME{apply} \nlsep \KWD{@}~\NT{reference}~\STAR{\NTL{constr}{9}} &10L &\RNAME{expl-apply} \nlsep \NT{constr}~\KWD{.(} ~\NT{reference}~\STAR{\NT{appl-arg}}~\TERM{)} &1L & \RNAME{proj} \nlsep \NT{constr}~\KWD{.(}~\TERM{@} ~\NT{reference}~\STAR{\NTL{constr}{9}}~\TERM{)} &1L & \RNAME{expl-proj} \nlsep \NT{constr} ~ \KWD{\%} ~ \NT{ident} &1L &\RNAME{scope-chg} \nlsep \NT{atomic-constr} &0 \nlsep \NT{match-expr} &0 \nlsep \KWD{(}~\NT{constr}~\KWD{)} &0 \SEPDEF \DEFNT{binder-constr} \KWD{forall}~\NT{binder-list}~\KWD{,}~\NTL{constr}{200} &&\RNAME{prod} \nlsep \KWD{fun} ~\NT{binder-list} ~\KWD{$\Rightarrow$}~\NTL{constr}{200} &&\RNAME{lambda} \nlsep \NT{fix-expr} \nlsep \KWD{let}~\NT{ident-with-params} ~\KWD{:=}~\NTL{constr}{200} ~\KWD{in}~\NTL{constr}{200} &&\RNAME{let} \nlsep \KWD{let}~\NT{single-fix} ~\KWD{in}~\NTL{constr}{200} &&\RNAME{rec-let} \nlsep \KWD{let}~\KWD{(}~\OPT{\NT{let-pattern}}~\KWD{)}~\OPT{\NT{return-type}} ~\KWD{:=}~\NTL{constr}{200}~\KWD{in}~\NTL{constr}{200} &&\RNAME{let-case} \nlsep \KWD{if}~\NT{if-item} ~\KWD{then}~\NTL{constr}{200}~\KWD{else}~\NTL{constr}{200} &&\RNAME{if-case} \SEPDEF \DEFNT{appl-arg} \KWD{(}~\NT{ident}~\!\KWD{:=}~\NTL{constr}{200}~\KWD{)} &&\RNAME{impl-arg} \nlsep \KWD{(}~\NT{num}~\!\KWD{:=}~\NTL{constr}{200}~\KWD{)} &&\RNAME{impl-arg} \nlsep \NTL{constr}{9} \SEPDEF \DEFNT{atomic-constr} \NT{reference} && \RNAME{variables} \nlsep \NT{sort} && \RNAME{CIC-sort} \nlsep \NT{num} && \RNAME{number} \nlsep \KWD{_} && \RNAME{hole} \nlsep \NT{meta-ident} && \RNAME{meta/evar} \end{rules} \begin{rules} \DEFNT{ident-with-params} \NT{ident}~\STAR{\NT{binder-let}}~\NT{type-cstr} \SEPDEF \DEFNT{binder-list} \NT{binder}~\STAR{\NT{binder-let}} \nlsep \PLUS{\NT{name}}~\KWD{:}~\NT{constr} \SEPDEF \DEFNT{binder} \NT{name} &&\RNAME{infer} \nlsep \KWD{(}~\PLUS{\NT{name}}~\KWD{:}~\NT{constr} ~\KWD{)} &&\RNAME{binder} \SEPDEF \DEFNT{binder-let} \NT{binder} \nlsep \KWD{(}~\NT{name}~\NT{type-cstr}~\KWD{:=}~\NT{constr}~\KWD{)} \SEPDEF \DEFNT{let-pattern} \NT{name} \nlsep \NT{name} ~\KWD{,} ~\NT{let-pattern} \SEPDEF \DEFNT{type-cstr} \OPTGR{\KWD{:}~\NT{constr}} \SEPDEF \DEFNT{reference} \NT{ident} && \RNAME{short-ident} \nlsep \NT{ident}~\PLUS{\NT{field}} && \RNAME{qualid} \SEPDEF \DEFNT{sort} \KWD{Prop} ~\mid~ \KWD{Set} ~\mid~ \KWD{Type} \SEPDEF \DEFNT{name} \NT{ident} ~\mid~ \KWD{_} \end{rules} \begin{rules} \DEFNT{fix-expr} \NT{single-fix} \nlsep \NT{single-fix}~\PLUSGR{\KWD{with}~\NT{fix-decl}} ~\KWD{for}~\NT{ident} \SEPDEF \DEFNT{single-fix} \NT{fix-kw}~\NT{fix-decl} \SEPDEF \DEFNT{fix-kw} \KWD{fix} ~\mid~ \KWD{cofix} \SEPDEF \DEFNT{fix-decl} \NT{ident}~\STAR{\NT{binder-let}}~\OPT{\NT{annot}}~\NT{type-cstr} ~\KWD{:=}~\NTL{constr}{200} \SEPDEF \DEFNT{annot} \KWD{\{}~\TERM{struct}~\NT{ident}~\KWD{\}} \end{rules} \begin{rules} \DEFNT{match-expr} \KWD{match}~\NT{match-items}~\OPT{\NT{return-type}}~\KWD{with} ~\OPT{\TERMbar}~\OPT{\NT{branches}}~\KWD{end} &&\RNAME{match} \SEPDEF \DEFNT{match-items} \NT{match-item} ~\KWD{,} ~\NT{match-items} \nlsep \NT{match-item} \SEPDEF \DEFNT{match-item} \NTL{constr}{100}~\OPTGR{\KWD{as}~\NT{name}} ~\OPTGR{\KWD{in}~\NTL{constr}{100}} \SEPDEF \DEFNT{return-type} \KWD{return}~\NTL{constr}{100} \SEPDEF \DEFNT{if-item} \NT{constr}~\OPTGR{\OPTGR{\KWD{as}~\NT{name}}~\NT{return-type}} \SEPDEF \DEFNT{branches} \NT{eqn}~\TERMbar~\NT{branches} \nlsep \NT{eqn} \SEPDEF \DEFNT{eqn} \NT{pattern} ~\STARGR{\KWD{,}~\NT{pattern}} ~\KWD{$\Rightarrow$}~\NT{constr} \SEPDEF \DEFNT{pattern} \NT{reference}~\PLUS{\NT{pattern}} &1L~~ & \RNAME{constructor} \nlsep \NT{pattern}~\KWD{as}~\NT{ident} &1L & \RNAME{alias} \nlsep \NT{pattern}~\KWD{\%}~\NT{ident} &1L & \RNAME{scope-change} \nlsep \NT{reference} &0 & \RNAME{pattern-var} \nlsep \KWD{_} &0 & \RNAME{hole} \nlsep \NT{num} &0 \nlsep \KWD{(}~\NT{tuple-pattern}~\KWD{)} \SEPDEF \DEFNT{tuple-pattern} \NT{pattern} \nlsep \NT{tuple-pattern}~\KWD{,}~\NT{pattern} && \RNAME{pair} \end{rules} \subsection{Notations of the prelude (logic and basic arithmetic)} Reserved notations: $$ \begin{array}{l|c} \text{Symbol} & \text{precedence} \\ \hline \infx{,} & 250L \\ \KWD{IF}~\notv~\KWD{then}~\notv~\KWD{else}~\notv & 200R \\ \infx{:} & 100R \\ \infx{\leftrightarrow} & 95N \\ \infx{\rightarrow} & 90R \\ \infx{\vee} & 85R \\ \infx{\wedge} & 80R \\ \tilde{}\notv & 75R \\ \begin{array}[c]{@{}l@{}} \infx{=}\quad \infx{=}\KWD{$:>$}\notv \quad \infx{=}=\notv \quad \infx{\neq} \quad \infx{\neq}\KWD{$:>$}\notv \\ \infx{<}\quad\infx{>} \quad \infx{\leq}\quad\infx{\geq} \quad \infx{<}<\notv \quad \infx{<}\leq\notv \quad \infx{\leq}<\notv \quad \infx{\leq}\leq\notv \end{array} & 70N \\ \infx{+}\quad\infx{-}\quad -\notv & 50L \\ \infx{*}\quad\infx{/}\quad /\notv & 40L \\ \end{array} $$ Existential quantifiers follows the \KWD{forall} notation (with same precedence 200), but only one quantified variable is allowed. \begin{rules} \EXTNT{binder-constr} \NT{quantifier-kwd}~\NT{name}~\NT{type-cstr}~\KWD{,}~\NTL{constr}{200} \\ \SEPDEF \DEFNT{quantifier-kwd} \TERM{exists} && \RNAME{ex} \nlsep \TERM{exists2} && \RNAME{ex2} \end{rules} $$ \begin{array}{l|c|l} \text{Symbol} & \text{precedence} \\ \hline \notv+\{\notv\} & 50 & \RNAME{sumor} \\ \{\notv:\notv~|~\notv\} & 0 & \RNAME{sig} \\ \{\notv:\notv~|~\notv \& \notv \} & 0 & \RNAME{sig2} \\ \{\notv:\notv~\&~\notv \} & 0 & \RNAME{sigS} \\ \{\notv:\notv~\&~\notv \& \notv \} & 0 & \RNAME{sigS2} \\ \{\notv\}+\{\notv\} & 0 & \RNAME{sumbool} \\ \end{array} $$ %% Strange: nat + {x:nat|x=x} * nat == ( + ) * \section{Grammar of tactics} \def\tacconstr{\NTL{constr}{9}} \def\taclconstr{\NTL{constr}{200}} Additional symbols are: $$ \TERM{'} ~~ \KWD{;} ~~ \TERM{()} ~~ \TERMbarbar ~~ \TERM{$\vdash$} ~~ \TERM{[} ~~ \TERM{]} ~~ \TERM{$\leftarrow$} $$ Additional reserved keywords are: $$ \KWD{at} ~~ \TERM{using} $$ \subsection{Basic tactics} \begin{rules} \DEFNT{simple-tactic} \TERM{intros}~\TERM{until}~\NT{quantified-hyp} \nlsep \TERM{intros}~\NT{intro-patterns} \nlsep \TERM{intro}~\OPT{\NT{ident}}~\OPTGR{\TERM{after}~\NT{ident}} %% \nlsep \TERM{assumption} \nlsep \TERM{exact}~\tacconstr %% \nlsep \TERM{apply}~\NT{constr-with-bindings} \nlsep \TERM{elim}~\NT{constr-with-bindings}~\OPT{\NT{eliminator}} \nlsep \TERM{elimtype}~\tacconstr \nlsep \TERM{case}~\NT{constr-with-bindings} \nlsep \TERM{casetype}~\tacconstr \nlsep \KWD{fix}~\OPT{\NT{ident}}~\NT{num} \nlsep \KWD{fix}~\NT{ident}~\NT{num}~\KWD{with}~\PLUS{\NT{fix-spec}} \nlsep \KWD{cofix}~\OPT{\NT{ident}} \nlsep \KWD{cofix}~\NT{ident}~\PLUS{\NT{fix-spec}} %% \nlsep \TERM{cut}~\tacconstr \nlsep \TERM{assert}~\tacconstr \nlsep \TERM{assert}~ \TERM{(}~\NT{ident}~\KWD{:}~\taclconstr~\TERM{)} \nlsep \TERM{assert}~ \TERM{(}~\NT{ident}~\KWD{:=}~\taclconstr~\TERM{)} \nlsep \TERM{pose}~\tacconstr \nlsep \TERM{pose}~ \TERM{(}~\NT{ident}~\KWD{:=}~\taclconstr~\TERM{)} \nlsep \TERM{generalize}~\PLUS{\tacconstr} \nlsep \TERM{generalize}~\TERM{dependent}~\tacconstr \nlsep \TERM{set}~\tacconstr~\OPT{\NT{clause}} \nlsep \TERM{set}~ \TERM{(}~\NT{ident}~\KWD{:=}~\taclconstr~\TERM{)}~\OPT{\NT{clause}} \nlsep \TERM{instantiate}~ \TERM{(}~\NT{num}~\TERM{:=}~\taclconstr~\TERM{)}~\OPT{\NT{clause}} %% \nlsep \TERM{specialize}~\OPT{\NT{num}}~\NT{constr-with-bindings} \nlsep \TERM{lapply}~\tacconstr %% \nlsep \TERM{simple}~\TERM{induction}~\NT{quantified-hyp} \nlsep \TERM{induction}~\NT{induction-arg}~\OPT{\NT{with-names}} ~\OPT{\NT{eliminator}} \nlsep \TERM{double}~\TERM{induction}~\NT{quantified-hyp}~\NT{quantified-hyp} \nlsep \TERM{simple}~\TERM{destruct}~\NT{quantified-hyp} \nlsep \TERM{destruct}~\NT{induction-arg}~\OPT{\NT{with-names}} ~\OPT{\NT{eliminator}} \nlsep \TERM{decompose}~\TERM{record}~\tacconstr \nlsep \TERM{decompose}~\TERM{sum}~\tacconstr \nlsep \TERM{decompose}~\TERM{[}~\PLUS{\NT{reference}}~\TERM{]} ~\tacconstr %% \nlsep ... \end{rules} \begin{rules} \EXTNT{simple-tactic} \TERM{trivial}~\OPT{\NT{hint-bases}} \nlsep \TERM{auto}~\OPT{\NT{num}}~\OPT{\NT{hint-bases}} %% %%\nlsep \TERM{autotdb}~\OPT{\NT{num}} %%\nlsep \TERM{cdhyp}~\NT{ident} %%\nlsep \TERM{dhyp}~\NT{ident} %%\nlsep \TERM{dconcl} %%\nlsep \TERM{superauto}~\NT{auto-args} \nlsep \TERM{auto}~\OPT{\NT{num}}~\TERM{decomp}~\OPT{\NT{num}} %% \nlsep \TERM{clear}~\PLUS{\NT{ident}} \nlsep \TERM{clearbody}~\PLUS{\NT{ident}} \nlsep \TERM{move}~\NT{ident}~\TERM{after}~\NT{ident} \nlsep \TERM{rename}~\NT{ident}~\TERM{into}~\NT{ident} %% \nlsep \TERM{left}~\OPT{\NT{with-binding-list}} \nlsep \TERM{right}~\OPT{\NT{with-binding-list}} \nlsep \TERM{split}~\OPT{\NT{with-binding-list}} \nlsep \TERM{exists}~\OPT{\NT{binding-list}} \nlsep \TERM{constructor}~\NT{num}~\OPT{\NT{with-binding-list}} \nlsep \TERM{constructor}~\OPT{\NT{tactic}} %% \nlsep \TERM{reflexivity} \nlsep \TERM{symmetry}~\OPTGR{\KWD{in}~\NT{ident}} \nlsep \TERM{transitivity}~\tacconstr %% \nlsep \NT{inversion-kwd}~\NT{quantified-hyp}~\OPT{\NT{with-names}}~\OPT{\NT{clause}} \nlsep \TERM{dependent}~\NT{inversion-kwd}~\NT{quantified-hyp} ~\OPT{\NT{with-names}}~\OPTGR{\KWD{with}~\tacconstr} \nlsep \TERM{inversion}~\NT{quantified-hyp}~\TERM{using}~\tacconstr~\OPT{\NT{clause}} %% \nlsep \NT{red-expr}~\OPT{\NT{clause}} \nlsep \TERM{change}~\NT{conversion}~\OPT{\NT{clause}} \SEPDEF \DEFNT{red-expr} \TERM{red} ~\mid~ \TERM{hnf} ~\mid~ \TERM{compute} \nlsep \TERM{simpl}~\OPT{\NT{pattern-occ}} \nlsep \TERM{cbv}~\PLUS{\NT{red-flag}} \nlsep \TERM{lazy}~\PLUS{\NT{red-flag}} \nlsep \TERM{unfold}~\NT{unfold-occ}~\STARGR{\KWD{,}~\NT{unfold-occ}} \nlsep \TERM{fold}~\PLUS{\tacconstr} \nlsep \TERM{pattern}~\NT{pattern-occ}~\STARGR{\KWD{,}~\NT{pattern-occ}} \SEPDEF \DEFNT{conversion} \NT{pattern-occ}~\KWD{with}~\tacconstr \nlsep \tacconstr \SEPDEF \DEFNT{inversion-kwd} \TERM{inversion} ~\mid~ \TERM{invesion_clear} ~\mid~ \TERM{simple}~\TERM{inversion} \end{rules} Conflicts exists between integers and constrs. \begin{rules} \DEFNT{quantified-hyp} \NT{int}~\mid~\NT{ident} \SEPDEF \DEFNT{induction-arg} \NT{int}~\mid~\tacconstr \SEPDEF \DEFNT{fix-spec} \KWD{(}~\NT{ident}~\STAR{\NT{binder}}~\OPT{\NT{annot}} ~\KWD{:}~\taclconstr~\KWD{)} \SEPDEF \DEFNT{intro-patterns} \STAR{\NT{intro-pattern}} \SEPDEF \DEFNT{intro-pattern} \NT{name} \nlsep \TERM{[}~\NT{intro-patterns}~\STARGR{\TERMbar~\NT{intro-patterns}} ~\TERM{]} \nlsep \KWD{(}~\NT{intro-pattern}~\STARGR{\KWD{,}~\NT{intro-pattern}} ~\KWD{)} \SEPDEF \DEFNT{with-names} % \KWD{as}~\TERM{[}~\STAR{\NT{ident}}~\STARGR{\TERMbar~\STAR{\NT{ident}}} % ~\TERM{]} \KWD{as}~\NT{intro-pattern} \SEPDEF \DEFNT{eliminator} \TERM{using}~\NT{constr-with-bindings} \SEPDEF \DEFNT{constr-with-bindings} % dangling ``with'' of ``fix'' can conflict with ``with'' \tacconstr~\OPT{\NT{with-binding-list}} \SEPDEF \DEFNT{with-binding-list} \KWD{with}~\NT{binding-list} \SEPDEF \DEFNT{binding-list} \PLUS{\tacconstr} \nlsep \PLUS{\NT{simple-binding}} \SEPDEF \DEFNT{simple-binding} \KWD{(}~\NT{quantified-hyp}~\KWD{:=}~\taclconstr~\KWD{)} \SEPDEF \DEFNT{red-flag} \TERM{beta} ~\mid~ \TERM{iota} ~\mid~ \TERM{zeta} ~\mid~ \TERM{delta} ~\mid~ \TERM{delta}~\OPT{\TERM{-}}~\TERM{[}~\PLUS{\NT{reference}}~\TERM{]} \SEPDEF \DEFNT{clause} \KWD{in}~\TERM{*} \nlsep \KWD{in}~\TERM{*}~\KWD{$\vdash$}~\OPT{\NT{concl-occ}} \nlsep \KWD{in}~\OPT{\NT{hyp-ident-list}} ~\KWD{$\vdash$} ~\OPT{\NT{concl-occ}} \nlsep \KWD{in}~\OPT{\NT{hyp-ident-list}} \SEPDEF \DEFNT{hyp-ident-list} \NT{hyp-ident} \nlsep \NT{hyp-ident}~\KWD{,}~\NT{hyp-ident-list} \SEPDEF \DEFNT{hyp-ident} \NT{ident} \nlsep \KWD{(}~\TERM{type}~\TERM{of}~\NT{ident}~\KWD{)} \nlsep \KWD{(}~\TERM{value}~\TERM{of}~\NT{ident}~\KWD{)} \SEPDEF \DEFNT{concl-occ} \TERM{*} ~\NT{occurrences} \SEPDEF \DEFNT{pattern-occ} \tacconstr ~\NT{occurrences} \SEPDEF \DEFNT{unfold-occ} \NT{reference}~\NT{occurrences} \SEPDEF \DEFNT{occurrences} ~\OPTGR{\KWD{at}~\PLUS{\NT{int}}} \SEPDEF \DEFNT{hint-bases} \KWD{with}~\TERM{*} \nlsep \KWD{with}~\PLUS{\NT{ident}} \SEPDEF \DEFNT{auto-args} \OPT{\NT{num}}~\OPTGR{\TERM{adding}~\TERM{[}~\PLUS{\NT{reference}} ~\TERM{]}}~\OPT{\TERM{destructuring}}~\OPTGR{\TERM{using}~\TERM{tdb}} \end{rules} \subsection{Ltac} %% Currently, there are conflicts with keyword \KWD{in}: in the following, %% has the keyword to be associated to \KWD{let} or to tactic \TERM{simpl} ? %% \begin{center} %% \texttt{let x := simpl in ...} %% \end{center} \begin{rules} \DEFNT{tactic} \NT{tactic} ~\KWD{;} ~\NT{tactic} &5 &\RNAME{Then} \nlsep \NT{tactic} ~\KWD{;}~\TERM{[} ~\OPT{\NT{tactic-seq}} ~\TERM{]} &5 &\RNAME{Then-seq} %% \nlsep \TERM{try} ~\NT{tactic} &3R &\RNAME{Try} \nlsep \TERM{do} ~\NT{int-or-var} ~\NT{tactic} \nlsep \TERM{repeat} ~\NT{tactic} \nlsep \TERM{progress} ~\NT{tactic} \nlsep \TERM{info} ~\NT{tactic} \nlsep \TERM{abstract}~\NTL{tactic}{2}~\OPTGR{\TERM{using}~\NT{ident}} %% \nlsep \NT{tactic} ~\TERMbarbar ~\NT{tactic} &2R &\RNAME{Orelse} %% \nlsep \KWD{fun} ~\PLUS{\NT{name}} ~\KWD{$\Rightarrow$} ~\NT{tactic} &1 &\RNAME{Fun-tac} \nlsep \KWD{let} ~\NT{let-clauses} ~\KWD{in} ~\NT{tactic} \nlsep \KWD{let} ~\TERM{rec} ~\NT{rec-clauses} ~\KWD{in} ~\NT{tactic} \nlsep \KWD{match}~\OPT{\TERM{reverse}}~\TERM{goal}~\KWD{with} ~\OPT{\TERMbar}~\OPT{\NT{match-goal-rules}} ~\KWD{end} \nlsep \KWD{match} ~\NT{tactic} ~\KWD{with} ~\OPT{\TERMbar}~\OPT{\NT{match-rules}} ~\KWD{end} \nlsep \TERM{first}~\TERM{[} ~\NT{tactic-seq} ~\TERM{]} \nlsep \TERM{solve}~\TERM{[} ~\NT{tactic-seq} ~\TERM{]} \nlsep \TERM{idtac} \nlsep \TERM{fail} ~\OPT{\NT{num}} ~\OPT{\NT{string}} \nlsep \TERM{constr}~\KWD{:}~\tacconstr \nlsep \TERM{ipattern}~\KWD{:}~\NT{intro-pattern} \nlsep \NT{term-ltac} \nlsep \NT{reference}~\STAR{\NT{tactic-arg}} &&\RNAME{call-tactic} \nlsep \NT{simple-tactic} %% \nlsep \NT{tactic-atom} &0 &\RNAME{atomic} \nlsep \KWD{(} ~\NT{tactic} ~\KWD{)} \SEPDEF \DEFNT{tactic-arg} \TERM{ltac}~\KWD{:}~\NTL{tactic}{0} \nlsep \TERM{ipattern}~\KWD{:}~\NT{intro-pattern} \nlsep \NT{term-ltac} \nlsep \NT{tactic-atom} \nlsep \tacconstr \SEPDEF \DEFNT{term-ltac} \TERM{fresh} ~\OPT{\NT{string}} \nlsep \TERM{context} ~\NT{ident} ~\TERM{[} ~\taclconstr ~\TERM{]} \nlsep \TERM{eval} ~\NT{red-expr} ~\KWD{in} ~\tacconstr \nlsep \TERM{type} ~\tacconstr \SEPDEF \DEFNT{tactic-atom} \NT{reference} \nlsep \TERM{()} \SEPDEF \DEFNT{tactic-seq} \NT{tactic} ~\TERMbar ~\NT{tactic-seq} \nlsep \NT{tactic} \end{rules} \begin{rules} \DEFNT{let-clauses} \NT{let-clause} ~\STARGR{\KWD{with}~\NT{let-clause}} \SEPDEF \DEFNT{let-clause} \NT{ident} ~\STAR{\NT{name}} ~\KWD{:=} ~\NT{tactic} \SEPDEF \DEFNT{rec-clauses} \NT{rec-clause} ~\KWD{with} ~\NT{rec-clauses} \nlsep \NT{rec-clause} \SEPDEF \DEFNT{rec-clause} \NT{ident} ~\PLUS{\NT{name}} ~\KWD{:=} ~\NT{tactic} \SEPDEF \DEFNT{match-goal-rules} \NT{match-goal-rule} \nlsep \NT{match-goal-rule} ~\TERMbar ~\NT{match-goal-rules} \SEPDEF \DEFNT{match-goal-rule} \NT{match-hyps-list} ~\TERM{$\vdash$} ~\NT{match-pattern} ~\KWD{$\Rightarrow$} ~\NT{tactic} \nlsep \KWD{[}~\NT{match-hyps-list} ~\TERM{$\vdash$} ~\NT{match-pattern} ~\KWD{]}~\KWD{$\Rightarrow$} ~\NT{tactic} \nlsep \KWD{_} ~\KWD{$\Rightarrow$} ~\NT{tactic} \SEPDEF \DEFNT{match-hyps-list} \NT{match-hyps} ~\KWD{,} ~\NT{match-hyps-list} \nlsep \NT{match-hyps} \SEPDEF \DEFNT{match-hyps} \NT{name} ~\KWD{:} ~\NT{match-pattern} \SEPDEF \DEFNT{match-rules} \NT{match-rule} \nlsep \NT{match-rule} ~\TERMbar ~\NT{match-rules} \SEPDEF \DEFNT{match-rule} \NT{match-pattern} ~\KWD{$\Rightarrow$} ~\NT{tactic} \nlsep \KWD{_} ~\KWD{$\Rightarrow$} ~\NT{tactic} \SEPDEF \DEFNT{match-pattern} \TERM{context}~\OPT{\NT{ident}} ~\TERM{[} ~\NT{constr-pattern} ~\TERM{]} &&\RNAME{subterm} \nlsep \NT{constr-pattern} \SEPDEF \DEFNT{constr-pattern} \tacconstr \end{rules} \subsection{Other tactics} \begin{rules} \EXTNT{simple-tactic} \TERM{rewrite} ~\NT{orient} ~\NT{constr-with-bindings} ~\OPTGR{\KWD{in}~\NT{ident}} \nlsep \TERM{replace} ~\tacconstr ~\KWD{with} ~\tacconstr ~\OPTGR{\KWD{in}~\NT{ident}} \nlsep \TERM{replace} ~\OPT{\NT{orient}} ~\tacconstr ~\OPTGR{\KWD{in}~\NT{ident}} \nlsep \TERM{symplify_eq} ~\OPT{\NT{quantified-hyp}} \nlsep \TERM{discriminate} ~\OPT{\NT{quantified-hyp}} \nlsep \TERM{injection} ~\OPT{\NT{quantified-hyp}} \nlsep \TERM{conditional}~\NT{tactic}~\TERM{rewrite}~\NT{orient} ~\NT{constr-with-bindings}~\OPTGR{\KWD{in}~\NT{ident}} \nlsep \TERM{dependent}~\TERM{rewrite}~\NT{orient}~\NT{ident} \nlsep \TERM{cutrewrite}~\NT{orient}~\tacconstr ~\OPTGR{\KWD{in}~\NT{ident}} \nlsep \TERM{absurd} ~\tacconstr \nlsep \TERM{contradiction} \nlsep \TERM{autorewrite}~\NT{hint-bases}~\OPTGR{\KWD{using}~\NT{tactic}} \nlsep \TERM{refine}~\tacconstr \nlsep \TERM{setoid_replace} ~\tacconstr ~\KWD{with} ~\tacconstr \nlsep \TERM{setoid_rewrite} ~\NT{orient} ~\tacconstr \nlsep \TERM{subst} ~\STAR{\NT{ident}} %% eqdecide.ml4 \nlsep \TERM{decide}~\TERM{equality} ~\OPTGR{\tacconstr~\tacconstr} \nlsep \TERM{compare}~\tacconstr~\tacconstr %% eauto \nlsep \TERM{eexact}~\tacconstr \nlsep \TERM{eapply}~\NT{constr-with-bindings} \nlsep \TERM{prolog}~\TERM{[}~\STAR{\tacconstr}~\TERM{]} ~\NT{quantified-hyp} \nlsep \TERM{eauto}~\OPT{\NT{quantified-hyp}}~\OPT{\NT{quantified-hyp}} ~\NT{hint-bases} \nlsep \TERM{eautod}~\OPT{\NT{quantified-hyp}}~\OPT{\NT{quantified-hyp}} ~\NT{hint-bases} %% tauto \nlsep \TERM{tauto} \nlsep \TERM{simplif} \nlsep \TERM{intuition}~\OPT{\NTL{tactic}{0}} \nlsep \TERM{linearintuition}~\OPT{\NT{num}} %% plugins/cc \nlsep \TERM{cc} %% plugins/field \nlsep \TERM{field}~\STAR{\tacconstr} %% plugins/firstorder \nlsep \TERM{ground}~\OPT{\NTL{tactic}{0}} \nlsep \TERM{ground}~\OPT{\NTL{tactic}{0}}~\KWD{with}~\PLUS{\NT{reference}} \nlsep \TERM{ground}~\OPT{\NTL{tactic}{0}}~\KWD{using}~\PLUS{\NT{ident}} %%\nlsep \TERM{gtauto} \nlsep \TERM{gintuition}~\OPT{\NTL{tactic}{0}} %% plugins/fourier \nlsep \TERM{fourierZ} %% plugins/funind \nlsep \TERM{functional}~\TERM{induction}~\tacconstr~\PLUS{\tacconstr} %% plugins/jprover \nlsep \TERM{jp}~\OPT{\NT{num}} %% plugins/omega \nlsep \TERM{omega} %% plugins/ring \nlsep \TERM{quote}~\NT{ident}~\OPTGR{\KWD{[}~\PLUS{\NT{ident}}~\KWD{]}} \nlsep \TERM{ring}~\STAR{\tacconstr} %% plugins/romega \nlsep \TERM{romega} \SEPDEF \DEFNT{orient} \KWD{$\rightarrow$}~\mid~\KWD{$\leftarrow$} \end{rules} \section{Grammar of commands} New symbols: $$ \TERM{.} ~~ \TERM{..} ~~ \TERM{\tt >->} ~~ \TERM{:$>$} ~~ \TERM{$<$:} $$ New keyword: $$ \KWD{where} $$ \subsection{Classification of commands} \begin{rules} \DEFNT{vernac} \TERM{Time}~\NT{vernac} &2~~ &\RNAME{Timing} %% \nlsep \NT{gallina}~\TERM{.} &1 \nlsep \NT{command}~\TERM{.} \nlsep \NT{syntax}~\TERM{.} \nlsep \TERM{[}~\PLUS{\NT{vernac}}~\TERM{]}~\TERM{.} %% \nlsep \OPTGR{\NT{num}~\KWD{:}}~\NT{subgoal-command}~\TERM{.} ~~~&0 \SEPDEF \DEFNT{subgoal-command} \NT{check-command} \nlsep %\OPT{\TERM{By}}~ \NT{tactic}~\OPT{\KWD{..}} \end{rules} \subsection{Gallina and extensions} \begin{rules} \DEFNT{gallina} \NT{thm-token}~\NT{ident}~\STAR{\NT{binder-let}}~\KWD{:}~\NT{constr} \nlsep \NT{def-token}~\NT{ident}~\NT{def-body} \nlsep \NT{assum-token}~\NT{assum-list} \nlsep \NT{finite-token}~\NT{inductive-definition} ~\STARGR{\KWD{with}~\NT{inductive-definition}} \nlsep \TERM{Fixpoint}~\NT{fix-decl}~\STARGR{\KWD{with}~\NT{fix-decl}} \nlsep \TERM{CoFixpoint}~\NT{fix-decl}~\STARGR{\KWD{with}~\NT{fix-decl}} \nlsep \TERM{Scheme}~\NT{scheme}~\STARGR{\KWD{with}~\NT{scheme}} %% Extension: record \nlsep \NT{record-tok}~\OPT{\TERM{$>$}}~\NT{ident}~\STAR{\NT{binder-let}} ~\KWD{:}~\NT{constr}~\KWD{:=} ~\OPT{\NT{ident}}~\KWD{\{}~\NT{field-list}~\KWD{\}} \nlsep \TERM{Ltac}~\NT{ltac-def}~\STARGR{~\TERM{with}~\NT{ltac-def}} \end{rules} \begin{rules} \DEFNT{thm-token} \TERM{Theorem} ~\mid~ \TERM{Lemma} ~\mid~ \TERM{Fact} ~\mid~ \TERM{Remark} \SEPDEF \DEFNT{def-token} \TERM{Definition} ~\mid~ \TERM{Let} ~\mid~ \OPT{\TERM{Local}}~\TERM{SubClass} \SEPDEF \DEFNT{assum-token} \TERM{Hypothesis} ~\mid~ \TERM{Variable} ~\mid~ \TERM{Axiom} ~\mid~ \TERM{Parameter} \SEPDEF \DEFNT{finite-token} \TERM{Inductive} ~\mid~ \TERM{CoInductive} \SEPDEF \DEFNT{record-tok} \TERM{Record} ~\mid~ \TERM{Structure} \end{rules} \begin{rules} \DEFNT{def-body} \STAR{\NT{binder-let}}~\NT{type-cstr}~\KWD{:=} ~\OPT{\NT{reduce}}~\NT{constr} \nlsep \STAR{\NT{binder-let}}~\KWD{:}~\NT{constr} \SEPDEF \DEFNT{reduce} \TERM{Eval}~\NT{red-expr}~\KWD{in} \SEPDEF \DEFNT{ltac-def} \NT{ident}~\STAR{\NT{name}}~\KWD{:=}~\NT{tactic} \SEPDEF \DEFNT{rec-definition} \NT{fix-decl}~\OPT{\NT{decl-notation}} \SEPDEF \DEFNT{inductive-definition} \OPT{\NT{string}}~\NT{ident}~\STAR{\NT{binder-let}}~\KWD{:} ~\NT{constr}~\KWD{:=} ~\OPT{\TERMbar}~\OPT{\NT{constructor-list}} ~\OPT{\NT{decl-notation}} \SEPDEF \DEFNT{constructor-list} \NT{constructor}~\TERMbar~\NT{constructor-list} \nlsep \NT{constructor} \SEPDEF \DEFNT{constructor} \NT{ident}~\STAR{\NT{binder-let}}\OPTGR{\NT{coerce-kwd}~\NT{constr}} \SEPDEF \DEFNT{decl-notation} \TERM{where}~\NT{string}~\TERM{:=}~\NT{constr} \SEPDEF \DEFNT{field-list} \NT{field}~\KWD{;}~\NT{field-list} \nlsep \NT{field} \SEPDEF \DEFNT{field} \NT{ident}~\OPTGR{\NT{coerce-kwd}~\NT{constr}} \nlsep \NT{ident}~\NT{type-cstr-coe}~\KWD{:=}~\NT{constr} \SEPDEF \DEFNT{assum-list} \PLUS{\GR{\KWD{(}~\NT{simple-assum-coe}~\KWD{)}}} \nlsep \NT{simple-assum-coe} \SEPDEF \DEFNT{simple-assum-coe} \PLUS{\NT{ident}}~\NT{coerce-kwd}~\NT{constr} \SEPDEF \DEFNT{coerce-kwd} \TERM{:$>$} ~\mid~ \KWD{:} \SEPDEF \DEFNT{type-cstr-coe} \OPTGR{\NT{coerce-kwd}~\NT{constr}} \SEPDEF \DEFNT{scheme} \NT{ident}~\KWD{:=}~\NT{dep-scheme}~\KWD{for}~\NT{reference} ~\TERM{Sort}~\NT{sort} \SEPDEF \DEFNT{dep-scheme} \TERM{Induction}~\mid~\TERM{Minimality} \end{rules} \subsection{Modules and sections} \begin{rules} \DEFNT{gallina} \TERM{Module}~\NT{ident}~\STAR{\NT{mbinder}}~\OPT{\NT{of-mod-type}} ~\OPTGR{\KWD{:=}~\NT{mod-expr}} \nlsep \TERM{Module}~\KWD{Type}~\NT{ident}~\STAR{\NT{mbinder}} ~\OPTGR{\KWD{:=}~\NT{mod-type}} \nlsep \TERM{Declare}~\TERM{Module}~\NT{ident}~\STAR{\NT{mbinder}} ~\OPT{\NT{of-mod-type}} ~\OPTGR{\KWD{:=}~\NT{mod-expr}} \nlsep \TERM{Section}~\NT{ident} \nlsep \TERM{Chapter}~\NT{ident} \nlsep \TERM{End}~\NT{ident} %% \nlsep \TERM{Require}~\OPT{\NT{export-token}}~\OPT{\NT{specif-token}} ~\PLUS{\NT{reference}} \nlsep \TERM{Require}~\OPT{\NT{export-token}}~\OPT{\NT{specif-token}} ~\NT{string} \nlsep \TERM{Import}~\PLUS{\NT{reference}} \nlsep \TERM{Export}~\PLUS{\NT{reference}} \SEPDEF \DEFNT{export-token} \TERM{Import} ~\mid~ \TERM{Export} \SEPDEF \DEFNT{specif-token} \TERM{Implementation} ~\mid~ \TERM{Specification} \SEPDEF \DEFNT{mod-expr} \NT{reference} \nlsep \NT{mod-expr}~\NT{mod-expr} & L \nlsep \KWD{(}~\NT{mod-expr}~\KWD{)} \SEPDEF \DEFNT{mod-type} \NT{reference} \nlsep \NT{mod-type}~\KWD{with}~\NT{with-declaration} \SEPDEF \DEFNT{with-declaration} %on forcera les ( ) %si exceptionnellemt %un fixpoint ici \TERM{Definition}~\NT{ident}~\KWD{:=}~\NTL{constr}{} %{100} \nlsep \TERM{Module}~\NT{ident}~\KWD{:=}~\NT{reference} \SEPDEF \DEFNT{of-mod-type} \KWD{:}~\NT{mod-type} \nlsep \TERM{$<$:}~\NT{mod-type} \SEPDEF \DEFNT{mbinder} \KWD{(}~\PLUS{\NT{ident}}~\KWD{:}~\NT{mod-type}~\KWD{)} \end{rules} \begin{rules} \DEFNT{gallina} \TERM{Transparent}~\PLUS{\NT{reference}} \nlsep \TERM{Opaque}~\PLUS{\NT{reference}} \nlsep \TERM{Canonical}~\TERM{Structure}~\NT{reference}~\OPT{\NT{def-body}} \nlsep \TERM{Coercion}~\OPT{\TERM{Local}}~\NT{reference}~\NT{def-body} \nlsep \TERM{Coercion}~\OPT{\TERM{Local}}~\NT{reference}~\KWD{:} ~\NT{class-rawexpr}~\TERM{$>->$}~\NT{class-rawexpr} \nlsep \TERM{Identity}~\TERM{Coercion}~\OPT{\TERM{Local}}~\NT{ident}~\KWD{:} ~\NT{class-rawexpr}~\TERM{$>->$}~\NT{class-rawexpr} \nlsep \TERM{Implicit}~\TERM{Arguments}~\NT{reference}~\TERM{[}~\STAR{\NT{num}}~\TERM{]} \nlsep \TERM{Implicit}~\TERM{Arguments}~\NT{reference} \nlsep \TERM{Implicit}~\KWD{Type}~\PLUS{\NT{ident}}~\KWD{:}~\NT{constr} \SEPDEF \DEFNT{command} \TERM{Comments}~\STAR{\NT{comment}} \nlsep \TERM{Pwd} \nlsep \TERM{Cd}~\OPT{\NT{string}} \nlsep \TERM{Drop} ~\mid~ \TERM{ProtectedLoop} ~\mid~\TERM{Quit} %% \nlsep \TERM{Load}~\OPT{\TERM{Verbose}}~\NT{ident} \nlsep \TERM{Load}~\OPT{\TERM{Verbose}}~\NT{string} \nlsep \TERM{Declare}~\TERM{ML}~\TERM{Module}~\PLUS{\NT{string}} \nlsep \TERM{Locate}~\NT{locatable} \nlsep \TERM{Add}~\OPT{\TERM{Rec}}~\TERM{LoadPath}~\NT{string}~\OPT{\NT{as-dirpath}} \nlsep \TERM{Remove}~\TERM{LoadPath}~\NT{string} \nlsep \TERM{Add}~\OPT{\TERM{Rec}}~\TERM{ML}~\TERM{Path}~\NT{string} %% \nlsep \KWD{Type}~\NT{constr} \nlsep \TERM{Print}~\NT{printable} \nlsep \TERM{Print}~\NT{reference} \nlsep \TERM{Inspect}~\NT{num} \nlsep \TERM{About}~\NT{reference} %% \nlsep \TERM{Search}~\NT{reference}~\OPT{\NT{in-out-modules}} \nlsep \TERM{SearchPattern}~\NT{constr-pattern}~\OPT{\NT{in-out-modules}} \nlsep \TERM{SearchRewrite}~\NT{constr-pattern}~\OPT{\NT{in-out-modules}} \nlsep \TERM{SearchAbout}~\NT{reference}~\OPT{\NT{in-out-modules}} \nlsep \TERM{SearchAbout}~\TERM{[}~\STAR{\NT{ref-or-string}}~\TERM{]}\OPT{\NT{in-out-modules}} \nlsep \KWD{Set}~\NT{ident}~\OPT{\NT{opt-value}} \nlsep \TERM{Unset}~\NT{ident} \nlsep \KWD{Set}~\NT{ident}~\NT{ident}~\OPT{\NT{opt-value}} \nlsep \KWD{Set}~\NT{ident}~\NT{ident}~\PLUS{\NT{opt-ref-value}} \nlsep \TERM{Unset}~\NT{ident}~\NT{ident}~\STAR{\NT{opt-ref-value}} %% \nlsep \TERM{Print}~\TERM{Table}~\NT{ident}~\NT{ident} \nlsep \TERM{Print}~\TERM{Table}~\NT{ident} \nlsep \TERM{Add}~\NT{ident}~\OPT{\NT{ident}}~\PLUS{\NT{opt-ref-value}} %% \nlsep \TERM{Test}~\NT{ident}~\OPT{\NT{ident}}~\STAR{\NT{opt-ref-value}} %% \nlsep \TERM{Remove}~\NT{ident}~\OPT{\NT{ident}}~\PLUS{\NT{opt-ref-value}} \SEPDEF \DEFNT{check-command} \TERM{Eval}~\NT{red-expr}~\KWD{in}~\NT{constr} \nlsep \TERM{Check}~\NT{constr} \SEPDEF \DEFNT{ref-or-string} \NT{reference} \nlsep \NT{string} \end{rules} \begin{rules} \DEFNT{printable} \TERM{Term}~\NT{reference} \nlsep \TERM{All} \nlsep \TERM{Section}~\NT{reference} \nlsep \TERM{Grammar}~\NT{ident} \nlsep \TERM{LoadPath} \nlsep \TERM{Module}~\OPT{\KWD{Type}}~\NT{reference} \nlsep \TERM{Modules} \nlsep \TERM{ML}~\TERM{Path} \nlsep \TERM{ML}~\TERM{Modules} \nlsep \TERM{Graph} \nlsep \TERM{Classes} \nlsep \TERM{Coercions} \nlsep \TERM{Coercion}~\TERM{Paths}~\NT{class-rawexpr}~\NT{class-rawexpr} \nlsep \TERM{Tables} % \nlsep \TERM{Proof}~\NT{reference} % Obsolete, useful in V6.3 ?? \nlsep \TERM{Hint}~\OPT{\NT{reference}} \nlsep \TERM{Hint}~\TERM{*} \nlsep \TERM{HintDb}~\NT{ident} \nlsep \TERM{Scopes} \nlsep \TERM{Scope}~\NT{ident} \nlsep \TERM{Visibility}~\OPT{\NT{ident}} \nlsep \TERM{Implicit}~\NT{reference} \SEPDEF \DEFNT{class-rawexpr} \TERM{Funclass}~\mid~\TERM{Sortclass}~\mid~\NT{reference} \SEPDEF \DEFNT{locatable} \NT{reference} \nlsep \TERM{File}~\NT{string} \nlsep \TERM{Library}~\NT{reference} \nlsep \NT{string} \SEPDEF \DEFNT{opt-value} \NT{ident} ~\mid~ \NT{string} \SEPDEF \DEFNT{opt-ref-value} \NT{reference} ~\mid~ \NT{string} \SEPDEF \DEFNT{as-dirpath} \KWD{as}~\NT{reference} \SEPDEF \DEFNT{in-out-modules} \TERM{inside}~\PLUS{\NT{reference}} \nlsep \TERM{outside}~\PLUS{\NT{reference}} \SEPDEF \DEFNT{comment} \NT{constr} \nlsep \NT{string} \end{rules} \subsection{Other commands} %% TODO: min/maj pas a jour \begin{rules} \EXTNT{command} \TERM{Debug}~\TERM{On} \nlsep \TERM{Debug}~\TERM{Off} %% TODO: vernac \nlsep \TERM{Add}~\TERM{setoid}~\tacconstr~\tacconstr~\tacconstr \nlsep \TERM{Add}~\TERM{morphism}~\tacconstr~\KWD{:}~\NT{ident} \nlsep \TERM{Derive}~\TERM{inversion_clear} ~\OPT{\NT{num}}~\NT{ident}~\NT{ident} \nlsep \TERM{Derive}~\TERM{inversion_clear} ~\NT{ident}~\KWD{with}~\tacconstr~\OPTGR{\TERM{Sort}~\NT{sort}} \nlsep \TERM{Derive}~\TERM{inversion} ~\OPT{\NT{num}}~\NT{ident}~\NT{ident} \nlsep \TERM{Derive}~\TERM{inversion} ~\NT{ident}~\KWD{with}~\tacconstr~\OPTGR{\TERM{Sort}~\NT{sort}} \nlsep \TERM{Derive}~\TERM{dependent}~\TERM{inversion_clear} ~\NT{ident}~\KWD{with}~\tacconstr~\OPTGR{\TERM{Sort}~\NT{sort}} \nlsep \TERM{Derive}~\TERM{dependent}~\TERM{inversion} ~\NT{ident}~\KWD{with}~\tacconstr~\OPTGR{\TERM{Sort}~\NT{sort}} %% Correctness: obsolete ? %\nlsep Correctness %\nlsep Global Variable %% TODO: extraction \nlsep Extraction ... %% field \nlsep \TERM{Add}~\TERM{Field}~\tacconstr~\tacconstr~\tacconstr ~\tacconstr~\tacconstr~\tacconstr \nlcont~~~~\tacconstr~\tacconstr~\OPT{\NT{minus-div}} %% funind \nlsep \TERM{Functional}~\TERM{Scheme}~\NT{ident}~\KWD{:=} ~\TERM{Induction}~\KWD{for}~\tacconstr ~\OPTGR{\KWD{with}~\PLUS{\tacconstr}} %% ring \nlsep \TERM{Add}~\TERM{Ring}~\tacconstr~\tacconstr~\tacconstr ~\tacconstr~\tacconstr~\tacconstr \nlcont~~~~\tacconstr~\tacconstr~\KWD{[}~\PLUS{\tacconstr}~\KWD{]} \nlsep \TERM{Add}~\TERM{Semi}~\TERM{Ring}~\tacconstr~\tacconstr~\tacconstr ~\tacconstr~\tacconstr~\tacconstr \nlcont~~~~\tacconstr~\KWD{[}~\PLUS{\tacconstr}~\KWD{]} \nlsep \TERM{Add}~\TERM{Abstract}~\TERM{Ring}~\tacconstr~\tacconstr~\tacconstr ~\tacconstr~\tacconstr~\tacconstr \nlcont~~~~\tacconstr~\tacconstr \nlsep \TERM{Add}~\TERM{Abstract}~\TERM{Semi}~\TERM{Ring}~\tacconstr ~\tacconstr~\tacconstr~\tacconstr~\tacconstr~\tacconstr \nlcont~~~~\tacconstr \nlsep \TERM{Add}~\TERM{Setoid}~\TERM{Ring}~\tacconstr~\tacconstr~\tacconstr ~\tacconstr~\tacconstr~\tacconstr \nlcont~~~~\tacconstr~\tacconstr~\tacconstr~\tacconstr~\tacconstr~\tacconstr ~\tacconstr~\KWD{[}~\PLUS{\tacconstr}~\KWD{]} \nlsep \TERM{Add}~\TERM{Setoid}~\TERM{Semi}~\TERM{Ring}~\tacconstr~\tacconstr ~\tacconstr~\tacconstr~\tacconstr~\tacconstr \nlcont~~~~\tacconstr~\tacconstr~\tacconstr~\tacconstr~\tacconstr ~\KWD{[}~\PLUS{tacconstr}~\KWD{]} \SEPDEF \DEFNT{minus-div} \KWD{with}~\NT{minus-arg}~\NT{div-arg} \nlsep \KWD{with}~\NT{div-arg}~\NT{minus-arg} \SEPDEF \DEFNT{minus-arg} \TERM{minus}~\KWD{:=}~\tacconstr \SEPDEF \DEFNT{div-arg} \TERM{div}~\KWD{:=}~\tacconstr \end{rules} \begin{rules} \EXTNT{command} \TERM{Write}~\TERM{State}~\NT{ident} \nlsep \TERM{Write}~\TERM{State}~\NT{string} \nlsep \TERM{Restore}~\TERM{State}~\NT{ident} \nlsep \TERM{Restore}~\TERM{State}~\NT{string} \nlsep \TERM{Reset}~\NT{ident} \nlsep \TERM{Reset}~\TERM{Initial} \nlsep \TERM{Back}~\OPT{\NT{num}} \end{rules} \subsection{Proof-editing commands} \begin{rules} \EXTNT{command} \TERM{Goal}~\NT{constr} \nlsep \TERM{Proof}~\OPT{\NT{constr}} \nlsep \TERM{Proof}~\KWD{with}~\NT{tactic} \nlsep \TERM{Abort}~\OPT{\TERM{All}} \nlsep \TERM{Abort}~\NT{ident} \nlsep \TERM{Existential}~\NT{num}~\KWD{:=}~\NT{constr-body} \nlsep \TERM{Qed} \nlsep \TERM{Save}~\OPTGR{\NT{thm-token}~\NT{ident}} \nlsep \TERM{Defined}~\OPT{\NT{ident}} \nlsep \TERM{Suspend} \nlsep \TERM{Resume}~\OPT{\NT{ident}} \nlsep \TERM{Restart} \nlsep \TERM{Undo}~\OPT{\NT{num}} \nlsep \TERM{Focus}~\OPT{\NT{num}} \nlsep \TERM{Unfocus} \nlsep \TERM{Show}~\OPT{\NT{num}} \nlsep \TERM{Show}~\TERM{Implicit}~\TERM{Arguments}~\OPT{\NT{num}} \nlsep \TERM{Show}~\TERM{Node} \nlsep \TERM{Show}~\TERM{Script} \nlsep \TERM{Show}~\TERM{Existentials} \nlsep \TERM{Show}~\TERM{Tree} \nlsep \TERM{Show}~\TERM{Conjecture} \nlsep \TERM{Show}~\TERM{Proof} \nlsep \TERM{Show}~\TERM{Intro} \nlsep \TERM{Show}~\TERM{Intros} %% Correctness: obsolete ? %%\nlsep \TERM{Show}~\TERM{Programs} \nlsep \TERM{Hint}~\OPT{\TERM{Local}}~\NT{hint}~\OPT{\NT{inbases}} %% PrintConstr not documented \end{rules} \begin{rules} \DEFNT{constr-body} \NT{type-cstr}~\KWD{:=}~\NT{constr} \SEPDEF \DEFNT{hint} \TERM{Resolve}~\PLUS{\NTL{constr}{9}} \nlsep \TERM{Immediate}~\PLUS{\NTL{constr}{9}} \nlsep \TERM{Unfold}~\PLUS{\NT{reference}} \nlsep \TERM{Constructors}~\PLUS{\NT{reference}} \nlsep \TERM{Extern}~\NT{num}~\NT{constr}~\KWD{$\Rightarrow$}~\NT{tactic} \nlsep \TERM{Destruct}~\NT{ident}~\KWD{:=}~\NT{num}~\NT{destruct-loc} ~\NT{constr}~\KWD{$\Rightarrow$}~\NT{tactic} \nlsep \TERM{Rewrite}~\NT{orient}~\PLUS{\NTL{constr}{9}} ~\OPTGR{\KWD{using}~\NT{tactic}} \SEPDEF \DEFNT{inbases} \KWD{:}~\PLUS{\NT{ident}} \SEPDEF \DEFNT{destruct-loc} \TERM{Conclusion} \nlsep \OPT{\TERM{Discardable}}~\TERM{Hypothesis} \end{rules} \subsection{Syntax extensions} \begin{rules} \DEFNT{syntax} \TERM{Open}~\TERM{Scope}~\NT{ident} \nlsep \TERM{Close}~\TERM{Scope}~\NT{ident} \nlsep \TERM{Delimit}~\TERM{Scope}~\NT{ident}~\KWD{with}~\NT{ident} \nlsep \TERM{Bind}~\TERM{Scope}~\NT{ident}~\KWD{with}~\PLUS{\NT{class-rawexpr}} \nlsep \TERM{Arguments}~\TERM{Scope}~\NT{reference} ~\TERM{[}~\PLUS{\NT{name}}~\TERM{]} \nlsep \TERM{Infix}~\OPT{\TERM{Local}} %%% ~\NT{prec}~\OPT{\NT{num}} ~\NT{string}~\KWD{:=}~\NT{reference}~\OPT{\NT{modifiers}} ~\OPT{\NT{in-scope}} \nlsep \TERM{Notation}~\OPT{\TERM{Local}}~\NT{string}~\KWD{:=}~\NT{constr} ~\OPT{\NT{modifiers}}~\OPT{\NT{in-scope}} \nlsep \TERM{Notation}~\OPT{\TERM{Local}}~\NT{ident}~\KWD{:=}~\NT{constr} ~\OPT{\KWD{(}\TERM{only~\TERM{parsing}\KWD{)}}} \nlsep \TERM{Reserved}~\TERM{Notation}~\OPT{\TERM{Local}}~\NT{string} ~\OPT{\NT{modifiers}} \nlsep \TERM{Tactic}~\TERM{Notation}~\NT{string}~\STAR{\NT{tac-production}} ~\KWD{:=}~\NT{tactic} \SEPDEF \DEFNT{modifiers} \KWD{(}~\NT{mod-list}~\KWD{)} \SEPDEF \DEFNT{mod-list} \NT{modifier} \nlsep \NT{modifier}~\KWD{,}~\NT{mod-list} \SEPDEF \DEFNT{modifier} \NT{ident}~\KWD{at}~\NT{num} \nlsep \NT{ident}~\STARGR{\KWD{,}~\NT{ident}}~\KWD{at}~\NT{num} \nlsep \KWD{at}~\TERM{next}~\TERM{level} \nlsep \KWD{at}~\TERM{level}~\NT{num} \nlsep \TERM{left}~\TERM{associativity} \nlsep \TERM{right}~\TERM{associativity} \nlsep \TERM{no}~\TERM{associativity} \nlsep \NT{ident}~\NT{syntax-entry} \nlsep \TERM{only}~\TERM{parsing} \nlsep \TERM{format}~\NT{string} \SEPDEF \DEFNT{in-scope} \KWD{:}~\NT{ident} \SEPDEF \DEFNT{syntax-entry} \TERM{ident}~\mid~\TERM{global}~\mid~\TERM{bigint} \SEPDEF \DEFNT{tac-production} \NT{string} \nlsep \NT{ident}~\TERM{(}~\NT{ident}~\TERM{)} %%% \SEPDEF %%% \DEFNT{prec} %%% \TERM{LeftA}~\mid~\TERM{RightA}~\mid~\TERM{NonA} \end{rules} \end{document} coq-8.4pl4/dev/v8-syntax/memo-v8.tex0000644000175000017500000002305112326224777016305 0ustar stephsteph \documentclass{article} \usepackage{verbatim} \usepackage{amsmath} \usepackage{amssymb} \usepackage{array} \usepackage{fullpage} \author{B.~Barras} \title{An introduction to syntax of Coq V8} %% Le _ est un caractÃĻre normal \catcode`\_=13 \let\subscr=_ \def_{\ifmmode\sb\else\subscr\fi} \def\NT#1{\langle\textit{#1}\rangle} \def\NTL#1#2{\langle\textit{#1}\rangle_{#2}} \def\TERM#1{\textsf{\bf #1}} \newenvironment{transbox} {\begin{center}\tt\begin{tabular}{l|ll} \hfil\textrm{V7} & \hfil\textrm{V8} \\ \hline} {\end{tabular}\end{center}} \def\TRANS#1#2 {\begin{tabular}[t]{@{}l@{}}#1\end{tabular} & \begin{tabular}[t]{@{}l@{}}#2\end{tabular} \\} \def\TRANSCOM#1#2#3 {\begin{tabular}[t]{@{}l@{}}#1\end{tabular} & \begin{tabular}[t]{@{}l@{}}#2\end{tabular} & #3 \\} \begin{document} \maketitle The goal of this document is to introduce by example to the new syntax of Coq. It is strongly recommended to read first the definition of the new syntax, but this document should also be useful for the eager user who wants to start with the new syntax quickly. \section{Changes in lexical conventions w.r.t. V7} \subsection{Identifiers} The lexical conventions changed: \TERM{_} is not a regular identifier anymore. It is used in terms as a placeholder for subterms to be inferred at type-checking, and in patterns as a non-binding variable. Furthermore, only letters (unicode letters), digits, single quotes and _ are allowed after the first character. \subsection{Quoted string} Quoted strings are used typically to give a filename (which may not be a regular identifier). As before they are written between double quotes ("). Unlike for V7, there is no escape character: characters are written normaly but the double quote which is doubled. \section{Main changes in terms w.r.t. V7} \subsection{Precedence of application} In the new syntax, parentheses are not really part of the syntax of application. The precedence of application (10) is tighter than all prefix and infix notations. It makes it possible to remove parentheses in many contexts. \begin{transbox} \TRANS{(A x)->(f x)=(g y)}{A x -> f x = g y} \TRANS{(f [x]x)}{f (fun x => x)} \end{transbox} \subsection{Arithmetics and scopes} The specialized notation for \TERM{Z} and \TERM{R} (introduced by symbols \TERM{`} and \TERM{``}) have disappeared. They have been replaced by the general notion of scope. \begin{center} \begin{tabular}{l|l|l} type & scope name & delimiter \\ \hline types & type_scope & \TERM{T} \\ \TERM{bool} & bool_scope & \\ \TERM{nat} & nat_scope & \TERM{nat} \\ \TERM{Z} & Z_scope & \TERM{Z} \\ \TERM{R} & R_scope & \TERM{R} \\ \TERM{positive} & positive_scope & \TERM{P} \end{tabular} \end{center} In order to use notations of arithmetics on \TERM{Z}, its scope must be opened with command \verb+Open Scope Z_scope.+ Another possibility is using the scope change notation (\TERM{\%}). The latter notation is to be used when notations of several scopes appear in the same expression. In examples below, scope changes are not needed if the appropriate scope has been opened. Scope nat_scope is opened in the initial state of Coq. \begin{transbox} \TRANSCOM{`0+x=x+0`}{0+x=x+0}{\textrm{Z_scope}} \TRANSCOM{``0 + [if b then ``1`` else ``2``]``}{0 + if b then 1 else 2}{\textrm{R_scope}} \TRANSCOM{(0)}{0}{\textrm{nat_scope}} \end{transbox} Below is a table that tells which notation is available in which scope. The relative precedences and associativity of operators is the same as in usual mathematics. See the reference manual for more details. However, it is important to remember that unlike V7, the type operators for product and sum are left associative, in order not to clash with arithmetic operators. \begin{center} \begin{tabular}{l|l} scope & notations \\ \hline nat_scope & $+ ~- ~* ~< ~\leq ~> ~\geq$ \\ Z_scope & $+ ~- ~* ~/ ~\TERM{mod} ~< ~\leq ~> ~\geq ~?=$ \\ R_scope & $+ ~- ~* ~/ ~< ~\leq ~> ~\geq$ \\ type_scope & $* ~+$ \\ bool_scope & $\TERM{\&\&} ~\TERM{$||$} ~\TERM{-}$ \\ list_scope & $\TERM{::} ~\TERM{++}$ \end{tabular} \end{center} (Note: $\leq$ is written \TERM{$<=$}) \subsection{Notation for implicit arguments} The explicitation of arguments is closer to the \emph{bindings} notation in tactics. Argument positions follow the argument names of the head constant. \begin{transbox} \TRANS{f 1!t1 2!t2}{f (x:=t1) (y:=t2)} \TRANS{!f t1 t2}{@f t1 t2} \end{transbox} \subsection{Universal quantification} The universal quantification and dependent product types are now materialized with the \TERM{forall} keyword before the binders and a comma after the binders. The syntax of binders also changed significantly. A binder can simply be a name when its type can be inferred. In other cases, the name and the type of the variable are put between parentheses. When several consecutive variables have the same type, they can be grouped. Finally, if all variables have the same type parentheses can be omitted. \begin{transbox} \TRANS{(x:A)B}{forall (x:~A), B ~~\textrm{or}~~ forall x:~A, B} \TRANS{(x,y:nat)P}{forall (x y :~nat), P ~~\textrm{or}~~ forall x y :~nat, P} \TRANS{(x,y:nat;z:A)P}{forall (x y :~nat) (z:A), P} \TRANS{(x,y,z,t:?)P}{forall x y z t, P} \TRANS{(x,y:nat;z:?)P}{forall (x y :~nat) z, P} \end{transbox} \subsection{Abstraction} The notation for $\lambda$-abstraction follows that of universal quantification. The binders are surrounded by keyword \TERM{fun} and $\Rightarrow$ (\verb+=>+ in ascii). \begin{transbox} \TRANS{[x,y:nat; z](f a b c)}{fun (x y:nat) z => f a b c} \end{transbox} \subsection{Pattern-matching} Beside the usage of the keyword pair \TERM{match}/\TERM{with} instead of \TERM{Cases}/\TERM{of}, the main change is the notation for the type of branches and return type. It is no longer written between \TERM{$<$ $>$} before the \TERM{Cases} keyword, but interleaved with the destructured objects. The idea is that for each destructured object, one may specify a variable name to tell how the branches types depend on this destructured objects (case of a dependent elimination), and also how they depend on the value of the arguments of the inductive type of the destructured objects. The type of branches is then given after the keyword \TERM{return}, unless it can be inferred. Moreover, when the destructured object is a variable, one may use this variable in the return type. \begin{transbox} \TRANS{Cases n of\\~~ O => O \\| (S k) => (1) end}{match n with\\~~ 0 => 0 \\| (S k) => 1 end} \TRANS{Cases m n of \\~~0 0 => t \\| ... end}{match m, n with \\~~0, 0 => t \\| .. end} \TRANS{<[n:nat](P n)>Cases T of ... end}{match T as n return P n with ... end} \TRANS{<[n:nat][p:(even n)]\~{}(odd n)>Cases p of\\~~ ... \\end}{match p in even n return \~{} odd n with\\~~ ...\\end} \end{transbox} \subsection{Fixpoints and cofixpoints} An easier syntax for non-mutual fixpoints is provided, making it very close to the usual notation for non-recursive functions. The decreasing argument is now indicated by an annotation between curly braces, regardless of the binders grouping. The annotation can be omitted if the binders introduce only one variable. The type of the result can be omitted if inferable. \begin{transbox} \TRANS{Fix plus\{plus [n:nat] : nat -> nat :=\\~~ [m]...\}}{fix plus (n m:nat) \{struct n\}: nat := ...} \TRANS{Fix fact\{fact [n:nat]: nat :=\\ ~~Cases n of\\~~~~ O => (1) \\~~| (S k) => (mult n (fact k)) end\}}{fix fact (n:nat) :=\\ ~~match n with \\~~~~0 => 1 \\~~| (S k) => n * fact k end} \end{transbox} There is a syntactic sugar for mutual fixpoints associated to a local definition: \begin{transbox} \TRANS{let f := Fix f \{f [x:A] : T := M\} in\\(g (f y))}{let fix f (x:A) : T := M in\\g (f x)} \end{transbox} The same applies to cofixpoints, annotations are not allowed in that case. \subsection{Notation for type cast} \begin{transbox} \TRANS{O :: nat}{0 : nat} \end{transbox} \section{Main changes in tactics w.r.t. V7} The main change is that all tactic names are lowercase. This also holds for Ltac keywords. \subsection{Ltac} Definitions of macros are introduced by \TERM{Ltac} instead of \TERM{Tactic Definition}, \TERM{Meta Definition} or \TERM{Recursive Definition}. Rules of a match command are not between square brackets anymore. Context (understand a term with a placeholder) instantiation \TERM{inst} became \TERM{context}. Syntax is unified with subterm matching. \begin{transbox} \TRANS{match t with [C[x=y]] => inst C[y=x]}{match t with context C[x=y] => context C[y=x]} \end{transbox} \subsection{Named arguments of theorems} \begin{transbox} \TRANS{Apply thm with x:=t 1:=u}{apply thm with (x:=t) (1:=u)} \end{transbox} \subsection{Occurrences} To avoid ambiguity between a numeric literal and the optionnal occurence numbers of this term, the occurence numbers are put after the term itself. This applies to tactic \TERM{pattern} and also \TERM{unfold} \begin{transbox} \TRANS{Pattern 1 2 (f x) 3 4 d y z}{pattern (f x at 1 2) (d at 3 4) y z} \end{transbox} \section{Main changes in vernacular commands w.r.t. V7} \subsection{Binders} The binders of vernacular commands changed in the same way as those of fixpoints. This also holds for parameters of inductive definitions. \begin{transbox} \TRANS{Definition x [a:A] : T := M}{Definition x (a:A) : T := M} \TRANS{Inductive and [A,B:Prop]: Prop := \\~~conj : A->B->(and A B)}% {Inductive and (A B:Prop): Prop := \\~~conj : A -> B -> and A B} \end{transbox} \subsection{Hints} The syntax of \emph{extern} hints changed: the pattern and the tactic to be applied are separated by a \TERM{$\Rightarrow$}. \begin{transbox} \TRANS{Hint Extern 4 (toto ?) Apply lemma}{Hint Extern 4 (toto _) => apply lemma} \end{transbox} \end{document} coq-8.4pl4/dev/v8-syntax/check-grammar0000755000175000017500000000227112326224777016723 0ustar stephsteph#!/bin/sh # This scripts checks that the new grammar of Coq as defined in syntax-v8.tex # is consistent in the sense that all invoked non-terminals are defined defined_nt() { grep "\\DEFNT{.*}" syntax-v8.tex | sed -e "s|.*DEFNT{\([^}]*\)}.*|\1|"|\ sort | sort -u } used_nt() { cat syntax-v8.tex | tr \\\\ \\n | grep "^NT{.*}" |\ sed -e "s|^NT{\([^}]*\)}.*|\1|" | egrep -v ^\#1\|non-terminal | sort -u } used_term() { cat syntax-v8.tex | tr \\\\ \\n | grep "^TERM{.*}" |\ sed -e "s|^TERM{\([^}]*\)}.*|\1|" -e "s|\\$||g" | egrep -v ^\#1\|terminal | sort -u } used_kwd() { cat syntax-v8.tex | tr \\\\ \\n | grep "^KWD{.*}" |\ sed -e "s|^KWD{\([^}]*\)}.*|\1|" -e "s|\\$||g" | egrep -v ^\#1 | sort -u } defined_nt > def used_nt > use used_term > use-t used_kwd > use-k diff def use > df ############################### echo if grep ^\> df > /dev/null 2>&1 ; then echo Undefined non-terminals: echo ======================== echo grep ^\> df | sed -e "s|^> ||" echo fi if grep ^\< df > /dev/null 2>&1 ; then echo Unused non-terminals: echo ===================== echo grep ^\< df | sed -e "s|^< ||" echo fi #echo Used terminals: #echo =============== #echo #cat use-tcoq-8.4pl4/dev/macosify_accel.sh0000755000175000017500000000016412326224777015712 0ustar stephsteph#!/usr/bin/sed -f s/^;\{0,1\} *\(.*\)\(.*\)$/\1\2/ s/^;\{0,1\} *\(.*\)\(.*\)$/\1\2/ coq-8.4pl4/dev/Makefile.oug0000644000175000017500000000500212326224777014637 0ustar stephsteph####################################################################### # v # The Coq Proof Assistant / The Coq Development Team # # " --useless-elements $@ core_intf.oug: $(OUG) --dump-data $@ -rectypes $(MLINCLUDES) $(COREML) $(COREMLI) core_intf.useless: core_intf.oug $(OUG) --load-data $< --no-reduce --print-loc --roots "" --useless-elements $@ # Analysis of coqchk, considering only files in the checker/ subdir CHECKERML:=$(call local_ml_of_cma,checker/check.cma) CHECKERMLI:=$(call mli_of_ml,$(CHECKERML)) ## BUG: in oug, include dirs have reversed priority compared with ocaml, cannot use CHKLIBS MYCHKINCL:=$(MLINCLUDES) -I checker checker.oug: $(OUG) --dump-data $@ -rectypes $(MYCHKINCL) $(CHECKERML) #$(CHECKERMLI) checker.useless: checker.oug $(OUG) --load-data $< --no-reduce --print-loc --roots "" --useless-elements $@ # Analysis of extraction EXTRACTIONML:=$(call local_ml_of_cma,$(EXTRACTIONCMA)) EXTRACTIONMLI:=$(call mli_of_ml,$(EXTRACTIONMLI)) extraction.oug: $(OUG) --dump-data $@ -rectypes $(MLINCLUDES) $(EXTRACTIONML) #$(EXTRACTIONMLI) extraction.useless: extraction.oug $(OUG) --load-data $< --no-reduce --print-loc --useless-elements $@ # More to come ...coq-8.4pl4/dev/include0000644000175000017500000000355412326224777013766 0ustar stephsteph (* File to include to install the pretty-printers in the ocaml toplevel *) (* Typical usage : $ coqtop.byte # or even better : rlwrap coqtop.byte Coq < Drop. # #use "include";; Alternatively, you can avoid typing #use "include" after each Drop by adding the following lines in your $HOME/.ocamlinit : if Filename.basename Sys.argv.(0) = "coqtop.byte" then ignore (Toploop.use_silently Format.std_formatter "include") *) (* For OCaml 3.10.x: clflags.cmi (a ocaml compilation by-product) must be in the library path. On Debian, install ocaml-compiler-libs, and uncomment the following: #directory "+compiler-libs/utils";; Clflags.recursive_types := true;; *) #cd ".";; #use "base_include";; #install_printer (* pp_stdcmds *) pppp;; #install_printer (* pattern *) pppattern;; #install_printer (* glob_constr *) ppglob_constr;; #install_printer (* constr *) ppconstr;; #install_printer (* constr_substituted *) ppsconstr;; #install_printer (* universe *) ppuni;; #install_printer (* universes *) ppuniverses;; #install_printer (* type_judgement *) pptype;; #install_printer (* judgement *) ppj;; #install_printer (* hint_db *) print_hint_db;; (*#install_printer (* hints_path *) pphintspath;;*) #install_printer (* goal *) ppgoal;; (*#install_printer (* sigma goal *) ppsigmagoal;;*) (*#install_printer (* proof *) pproof;;*) #install_printer (* Goal.goal *) ppgoalgoal;; #install_printer (* metaset.t *) ppmetas;; #install_printer (* evar_map *) ppevm;; #install_printer (* ExistentialSet.t *) ppexistentialset;; #install_printer (* clenv *) ppclenv;; #install_printer (* env *) ppenv;; #install_printer (* tactic *) pptac;; #install_printer (* object *) ppobj;; #install_printer (* global_reference *) ppglobal;; #install_printer (* generic_argument *) pp_generic_argument;; #install_printer (* fconstr *) ppfconstr;; coq-8.4pl4/dev/base_db0000644000175000017500000000025712326224777013717 0ustar stephstephload_printer "gramlib.cma" load_printer "top_printers.cmo" install_printer Top_printers.prid install_printer Top_printers.prsp install_printer Top_printers.print_pure_constr coq-8.4pl4/COMPATIBILITY0000644000175000017500000000415412326224777013573 0ustar stephstephPotential sources of incompatibilities between Coq V8.3 and V8.4 ---------------------------------------------------------------- (see also file CHANGES) The main known incompatibilities between 8.3 and 8.4 are consequences of the following changes: - The reorganization of the library of numbers: Several definitions have new names or are defined in modules of different names, but a special care has been taken to have this renaming transparent for the user thanks to compatibility notations. However some definitions have changed, what might require some adaptations. The most noticeable examples are: - The "?=" notation which now bind to Pos.compare rather than former Pcompare (now Pos.compare_cont). - Changes in names may induce different automatically generated names in proof scripts (e.g. when issuing "destruct Z_le_gt_dec"). - Z.add has a new definition, hence, applying "simpl" on subterms of its body might give different results than before. - BigN.shiftl and BigN.shiftr have reversed arguments order, the power function in BigN now takes two BigN. - Other changes in libraries: - The definition of functions over "vectors" (list of fixed length) have changed. - TheoryList.v has been removed. - Slight changes in tactics: - Less unfolding of fixpoints when applying destruct or inversion on a fixpoint hiding an inductive type (add an extra call to simpl to preserve compatibility). - Less unexpected local definitions when applying "destruct" (incompatibilities solvable by adapting name hypotheses). - Tactic "apply" might succeed more often, e.g. by now solving pattern-matching of the form ?f x y = g(x,y) (compatibility ensured by using "Unset Tactic Pattern Unification"), but also because it supports (full) betaiota (using "simple apply" might then help). - Tactic autorewrite does no longer instantiate pre-existing existential variables. - Tactic "info" is now available only for auto, eauto and trivial. - Miscellaneous changes: - The command "Load" is now atomic for backtracking (use "Unset Atomic Load" for compatibility). coq-8.4pl4/INSTALL.doc0000644000175000017500000000362512326224777013436 0ustar stephsteph The Coq documentation ===================== The Coq documentation includes - A Reference Manual - A Tutorial - A document presenting the Coq standard library - A list of questions/answers in the FAQ style The sources of the documents are mainly made of LaTeX code from which user-readable PostScript or PDF files, or a user-browsable bunch of html files are generated. Prerequisite ------------ To produce the PostScript documents, the following tools are needed: - latex (latex2e) - dvips - bibtex - makeindex - pngtopnm and pnmtops (for the Reference Manual and the FAQ) To produce the PDF documents, the following tools are needed: - pdflatex - bibtex To produce the html documents, the following tools are needed: - hevea (e.g. 1.07 works) Under Debian based operating systems (Debian, Ubuntu, ...) a working set of packages for compiling the documentation for Coq is: texlive texlive-latex-extra texlive-math-extra texlive-fonts-extra texlive-lang-french texlive-humanities texlive-pictures latex-xcolor hevea netpbm Compilation ----------- To produce all documentation about Coq, just run: make doc Alternatively, you can use some specific targets: make doc-ps to produce all PostScript documents make doc-pdf to produce all PDF documents make doc-html to produce all html documents make refman to produce all formats of the reference manual make tutorial to produce all formats of the tutorial make rectutorial to produce all formats of the tutorial on recursive types make faq to produce all formats of the FAQ make stdlib to produce all formats of the Coq standard library Installation ------------ To install all produced documents, do: make DOCDIR=/some/directory/for/documentation install-doc DOCDIR defauts to /usr/share/doc/coq coq-8.4pl4/Makefile0000644000175000017500000002371612326224777013304 0ustar stephsteph####################################################################### # v # The Coq Proof Assistant / The Coq Development Team # # = 3.81. # # This Makefile is now separated into Makefile.{common,build,doc}. # You won't find Makefiles in sub-directories and this is done on purpose. # If you are not yet convinced of the advantages of a single Makefile, please # read # http://miller.emu.id.au/pmiller/books/rmch/ # before complaining. # # When you are working in a subdir, you can compile without moving to the # upper directory using "make -C ..", and the output is still understood # by Emacs' next-error. # # Specific command-line options to this Makefile: # # make VERBOSE=1 # restore the raw echoing of commands # make NO_RECALC_DEPS=1 # avoid recomputing dependencies # make NO_RECOMPILE_LIB=1 # a coqtop rebuild does not trigger a stdlib rebuild # # Nota: the 1 above can be replaced by any non-empty value # # ---------------------------------------------------------------------- # See dev/doc/build-system*.txt for more details/FAQ about this Makefile # ---------------------------------------------------------------------- ########################################################################### # File lists ########################################################################### # NB: due to limitations in Win32, please refrain using 'export' too much # to communicate between make sub-calls (in Win32, 8kb max per env variable, # 32kb total) # !! Before using FIND_VCS_CLAUSE, please read how you should in the !! # !! FIND_VCS_CLAUSE section of dev/doc/build-system.dev.txt !! FIND_VCS_CLAUSE:='(' \ -name '{arch}' -o \ -name '.svn' -o \ -name '_darcs' -o \ -name '.git' -o \ -name '.bzr' -o \ -name 'debian' -o \ -name "$${GIT_DIR}" -o \ -name '_build' \ ')' -prune -o define find $(shell find . $(FIND_VCS_CLAUSE) '(' -name $(1) ')' -print | sed 's|^\./||') endef ## Files in the source tree YACCFILES:=$(call find, '*.mly') LEXFILES := $(call find, '*.mll') export MLLIBFILES := $(call find, '*.mllib') export ML4FILES := $(call find, '*.ml4') export CFILES := $(call find, '*.c') # NB: The lists of currently existing .ml and .mli files will change # before and after a build or a make clean. Hence we do not export # these variables, but cleaned-up versions (see below MLFILES and co) EXISTINGML := $(call find, '*.ml') EXISTINGMLI := $(call find, '*.mli') ## Files that will be generated GENML4FILES:= $(ML4FILES:.ml4=.ml) GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) \ scripts/tolink.ml kernel/copcodes.ml GENMLIFILES:=$(YACCFILES:.mly=.mli) GENPLUGINSMOD:=$(filter plugins/%,$(MLLIBFILES:%.mllib=%_mod.ml)) export GENHFILES:=kernel/byterun/coq_jumptbl.h export GENVFILES:=theories/Numbers/Natural/BigN/NMake_gen.v export GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) $(GENVFILES) $(GENPLUGINSMOD) # NB: all files in $(GENFILES) can be created initially, while # .ml files in $(GENML4FILES) might need some intermediate building. # That's why we keep $(GENML4FILES) out of $(GENFILES) ## More complex file lists define diff $(strip $(foreach f, $(1), $(if $(filter $(f),$(2)),,$f))) endef export MLEXTRAFILES := $(GENMLFILES) $(GENML4FILES) $(GENPLUGINSMOD) export MLSTATICFILES := $(call diff, $(EXISTINGML), $(MLEXTRAFILES)) export MLIFILES := $(sort $(GENMLIFILES) $(EXISTINGMLI)) include Makefile.common ########################################################################### # Starting rules ########################################################################### NOARG: world .PHONY: NOARG help always help: @echo "Please use either" @echo " ./configure" @echo " make world" @echo " make install" @echo " make clean" @echo "or make archclean" @echo @echo "For make to be verbose, add VERBOSE=1" UNSAVED_FILES:=$(shell find . -name '.\#*v' -o -name '.\#*.ml' -o -name '.\#*.ml?') ifdef UNSAVED_FILES $(error You have unsaved changes in your editor (emacs?) [$(UNSAVED_FILES)]; \ cancel them or save before proceeding. Or your editor crashed. \ Then, you may want to consider whether you want to restore the autosaves) #If you try to simply remove this explicit test, the compilation may #fail later. In particular, if a .#*.v file exists, coqdep fails to #run. endif # Apart from clean and tags, everything will be done in a sub-call to make # on Makefile.build. This way, we avoid doing here the -include of .d : # since they trigger some compilations, we do not want them for a mere clean ifdef COQ_CONFIGURED %:: always $(MAKE) --warn-undefined-variable --no-builtin-rules -f Makefile.build "$@" else %:: always @echo "Please run ./configure first" >&2; exit 1 endif always : ; # To speed-up things a bit, let's dissuade make to attempt rebuilding makefiles Makefile Makefile.build Makefile.common config/Makefile : ; ########################################################################### # Cleaning ########################################################################### .PHONY: clean cleankeepvo objclean cruftclean indepclean doclean archclean optclean clean-ide ml4clean ml4depclean depclean cleanconfig distclean voclean devdocclean clean: objclean cruftclean depclean docclean devdocclean cleankeepvo: indepclean clean-ide optclean cruftclean depclean docclean devdocclean objclean: archclean indepclean cruftclean: ml4clean find . -name '*~' -o -name '*.annot' | xargs rm -f rm -f gmon.out core indepclean: rm -f $(GENFILES) rm -f $(COQTOPBYTE) $(COQMKTOPBYTE) $(COQCBYTE) $(CHICKENBYTE) bin/fake_ide find . -name '*~' -o -name '*.cm[ioa]' | xargs rm -f rm -f */*.pp[iox] plugins/*/*.pp[iox] rm -rf $(SOURCEDOCDIR) rm -f toplevel/mltop.byteml toplevel/mltop.optml rm -f test-suite/check.log rm -f glob.dump rm -f config/revision.ml revision $(MAKE) -C test-suite clean docclean: rm -f doc/*/*.dvi doc/*/*.aux doc/*/*.log doc/*/*.bbl doc/*/*.blg doc/*/*.toc \ doc/*/*.idx doc/*/*~ doc/*/*.ilg doc/*/*.ind doc/*/*.dvi.gz doc/*/*.ps.gz doc/*/*.pdf.gz\ doc/*/*.???idx doc/*/*.???ind doc/*/*.v.tex doc/*/*.atoc doc/*/*.lof\ doc/*/*.hatoc doc/*/*.haux doc/*/*.hcomind doc/*/*.herrind doc/*/*.hidx doc/*/*.hind \ doc/*/*.htacind doc/*/*.htoc doc/*/*.v.html rm -f doc/stdlib/index-list.html doc/stdlib/index-body.html \ doc/stdlib/*Library.coqdoc.tex doc/stdlib/library.files \ doc/stdlib/library.files.ls doc/stdlib/FullLibrary.tex rm -f doc/*/*.ps doc/*/*.pdf rm -rf doc/refman/html doc/stdlib/html doc/faq/html doc/tutorial/tutorial.v.html rm -f doc/refman/euclid.ml doc/refman/euclid.mli rm -f doc/refman/heapsort.ml doc/refman/heapsort.mli rm -f doc/common/version.tex rm -f doc/refman/styles.hva doc/refman/cover.html doc/refman/Reference-Manual.html rm -f doc/coq.tex rm -f doc/refman/styles.hva doc/refman/cover.html archclean: clean-ide optclean voclean rm -rf _build myocamlbuild_config.ml rm -f $(ALLSTDLIB).* optclean: rm -f $(COQTOPEXE) $(COQMKTOP) $(COQC) $(CHICKEN) $(COQDEPBOOT) rm -f $(COQTOPOPT) $(COQMKTOPOPT) $(COQCOPT) $(CHICKENOPT) rm -f $(TOOLS) $(CSDPCERT) find . -name '*.cmx' -o -name '*.cmxs' -o -name '*.cmxa' -o -name '*.[soa]' -o -name '*.so' | xargs rm -f clean-ide: rm -f $(COQIDECMO) $(COQIDECMX) $(COQIDECMO:.cmo=.cmi) $(COQIDEBYTE) $(COQIDEOPT) $(COQIDE) rm -f ide/input_method_lexer.ml rm -f ide/highlight.ml ide/config_lexer.ml ide/config_parser.mli ide/config_parser.ml rm -f ide/utf8_convert.ml ml4clean: rm -f $(GENML4FILES) ml4depclean: find . -name '*.ml4.d' | xargs rm -f depclean: find . $(FIND_VCS_CLAUSE) '(' -name '*.d' ')' -print | xargs rm -f cleanconfig: rm -f config/Makefile config/coq_config.ml dev/ocamldebug-v7 ide/undo.mli distclean: clean cleanconfig voclean: rm -f states/*.coq find theories plugins test-suite -name '*.vo' -o -name '*.glob' | xargs rm -f devdocclean: find . -name '*.dep.ps' -o -name '*.dot' | xargs rm -f rm -f $(OCAMLDOCDIR)/*.log $(OCAMLDOCDIR)/*.aux $(OCAMLDOCDIR)/*.toc rm -f $(OCAMLDOCDIR)/ocamldoc.sty $(OCAMLDOCDIR)/coq.tex rm -f $(OCAMLDOCDIR)/html/*.html ########################################################################### # Emacs tags ########################################################################### .PHONY: tags otags tags: echo $(MLIFILES) $(MLSTATICFILES) $(ML4FILES) | sort -r | xargs \ etags --language=none\ "--regex=/let[ \t]+\([^ \t]+\)/\1/" \ "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ "--regex=/and[ \t]+\([^ \t]+\)/\1/" \ "--regex=/type[ \t]+\([^ \t]+\)/\1/" \ "--regex=/exception[ \t]+\([^ \t]+\)/\1/" \ "--regex=/val[ \t]+\([^ \t]+\)/\1/" \ "--regex=/module[ \t]+\([^ \t]+\)/\1/" echo $(ML4FILES) | sort -r | xargs \ etags --append --language=none\ "--regex=/[ \t]*\([^: \t]+\)[ \t]*:/\1/" otags: echo $(MLIFILES) $(MLSTATICFILES) | sort -r | xargs otags echo $(ML4FILES) | sort -r | xargs \ etags --append --language=none\ "--regex=/let[ \t]+\([^ \t]+\)/\1/" \ "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ "--regex=/and[ \t]+\([^ \t]+\)/\1/" \ "--regex=/type[ \t]+\([^ \t]+\)/\1/" \ "--regex=/exception[ \t]+\([^ \t]+\)/\1/" \ "--regex=/val[ \t]+\([^ \t]+\)/\1/" \ "--regex=/module[ \t]+\([^ \t]+\)/\1/" %.elc: %.el ifdef COQ_CONFIGURED echo "(setq load-path (cons \".\" load-path))" > $*.compile echo "(byte-compile-file \"$<\")" >> $*.compile - $(EMACS) -batch -l $*.compile rm -f $*.compile else @echo "Please run ./configure first" >&2; exit 1 endif # Useful to check that the exported variables are within the win32 limits printenv: @env @echo @echo -n "Maxsize (win32 limit is 8k) : " @env | wc -L @echo -n "Total (win32 limit is 32k) : " @env | wc -m coq-8.4pl4/configure0000755000175000017500000011106712326224777013550 0ustar stephsteph#!/bin/sh ################################## # # Configuration script for Coq # ################################## VERSION=8.4pl4 VOMAGIC=08400 STATEMAGIC=58400 DATE=`LC_ALL=C LANG=C date +"%B %Y"` # Create the bin/ directory if non-existent test -d bin || mkdir bin # a local which command for sh which () { IFS=":" # set words separator in PATH to be ':' (it allows spaces in dirnames) for i in $PATH; do if test -z "$i"; then i=.; fi if [ -f "$i/$1" ] ; then IFS=" " echo "$i/$1" break fi done } usage () { printf "Available options for configure are:\n" echo "-help" printf "\tDisplays this help page\n" echo "-prefix " printf "\tSet installation directory to \n" echo "-local" printf "\tSet installation directory to the current source tree\n" echo "-coqrunbyteflags " printf "\tSet link flags for VM-dependent bytecode (coqtop)\n" echo "-coqtoolsbyteflags " printf "\tSet link flags for VM-independant bytecode (coqdep, coqdoc, ...)\n" echo "-custom" printf "\tGenerate all bytecode executables with -custom (not recommended)\n" echo "-src " printf "\tSpecifies the source directory\n" echo "-bindir " echo "-libdir " echo "-configdir " echo "-datadir " echo "-mandir " echo "-docdir " printf "\tSpecifies where to install bin/lib/config/data/man/doc files resp.\n" echo "-emacslib " printf "\tSpecifies where emacs files are to be installed\n" echo "-coqdocdir " printf "\tSpecifies where Coqdoc style files are to be installed\n" echo "-camldir " printf "\tSpecifies the path to the OCaml library\n" echo "-lablgtkdir " printf "\tSpecifies the path to the Lablgtk library\n" echo "-usecamlp5" printf "\tSpecifies to use camlp5 instead of camlp4\n" echo "-usecamlp4" printf "\tSpecifies to use camlp4 instead of camlp5\n" echo "-camlp5dir " printf "\tSpecifies where to look for the Camlp5 library and tells to use it\n" echo "-arch " printf "\tSpecifies the architecture\n" echo "-opt" printf "\tSpecifies whether or not to use OCaml *.opt optimized compilers\n" echo "-natdynlink (yes|no)" printf "\tSpecifies whether or not to use dynamic loading of native code\n" echo "-coqide (opt|byte|no)" printf "\tSpecifies whether or not to compile Coqide\n" echo "-nomacintegration" printf "\tSpecifies to not try to build coqide mac integration\n" echo "-browser " printf "\tUse to open URL %%s\n" echo "-with-doc (yes|no)" printf "\tSpecifies whether or not to compile the documentation\n" echo "-with-geoproof (yes|no)" printf "\tSpecifies whether or not to use Geoproof binding\n" echo "-byte-only" printf "\tCompiles only bytecode version of Coq\n" echo "-debug" printf "\tAdd debugging information in the Coq executables\n" echo "-profile" printf "\tAdd profiling information in the Coq executables\n" echo "-annotate" printf "\tCompiles Coq with -dtypes option\n" echo "-makecmd " printf "\tName of GNU Make command.\n" } # Default OCaml binaries bytecamlc=ocamlc nativecamlc=ocamlopt ocamlmklibexec=ocamlmklib ocamlexec=ocaml ocamldepexec=ocamldep ocamldocexec=ocamldoc ocamllexexec=ocamllex ocamlyaccexec=ocamlyacc ocamlmktopexec=ocamlmktop camlp4oexec=camlp4o coq_debug_flag= coq_debug_flag_opt= coq_profile_flag= coq_annotate_flag= best_compiler=opt cflags="-Wall -Wno-unused" natdynlink=yes local=false coqrunbyteflags_spec=no coqtoolsbyteflags_spec=no custom_spec=no src_spec=no prefix_spec=no bindir_spec=no libdir_spec=no configdir_spec=no datadir_spec=no mandir_spec=no docdir_spec=no emacslib_spec=no emacs_spec=no camldir_spec=no lablgtkdir_spec=no coqdocdir_spec=no arch_spec=no coqide_spec=no nomacintegration_spec=no browser_spec=no wwwcoq_spec=no with_geoproof=false with_doc=all with_doc_spec=no force_caml_version=no force_caml_version_spec=no usecamlp5=yes COQSRC=`pwd` # Parse command-line arguments while : ; do case "$1" in "") break;; -help|--help) usage exit;; -prefix|--prefix) prefix_spec=yes prefix="$2" shift;; -local|--local) local=true;; -coqrunbyteflags|--coqrunbyteflags) coqrunbyteflags_spec=yes coqrunbyteflags="$2" shift;; -coqtoolsbyteflags|--coqtoolsbyteflags) coqtoolsbyteflags_spec=yes coqtoolsbyteflags="$2" shift;; -custom|--custom) custom_spec=yes;; -src|--src) src_spec=yes COQSRC="$2" shift;; -bindir|--bindir) bindir_spec=yes bindir="$2" shift;; -libdir|--libdir) libdir_spec=yes libdir="$2" shift;; -configdir|--configdir) configdir_spec=yes configdir="$2" shift;; -datadir|--datadir) datadir_spec=yes datadir="$2" shift;; -mandir|--mandir) mandir_spec=yes mandir="$2" shift;; -docdir|--docdir) docdir_spec=yes docdir="$2" shift;; -emacslib|--emacslib) emacslib_spec=yes emacslib="$2" shift;; -emacs |--emacs) emacs_spec=yes emacs="$2" printf "Warning: obsolete -emacs option\n" shift;; -coqdocdir|--coqdocdir) coqdocdir_spec=yes coqdocdir="$2" shift;; -camldir|--camldir) camldir_spec=yes camldir="$2" shift;; -lablgtkdir|--lablgtkdir) lablgtkdir_spec=yes lablgtkdir="$2" shift;; -usecamlp5|--usecamlp5) usecamlp5=yes;; -usecamlp4|--usecamlp4) usecamlp5=no;; -camlp5dir|--camlp5dir) usecamlp5=yes camlp5dir="$2" shift;; -arch|--arch) arch_spec=yes arch=$2 shift;; -opt|--opt) bytecamlc=ocamlc.opt camlp4oexec=camlp4o # can't add .opt since dyn load'll be required nativecamlc=ocamlopt.opt;; -natdynlink|--natdynlink) case "$2" in yes) natdynlink=yes;; *) natdynlink=no esac shift;; -coqide|--coqide) coqide_spec=yes case "$2" in byte|opt) COQIDE=$2;; *) COQIDE=no esac shift;; -nomacintegration) nomacintegration_spec=yes shift;; -browser|--browser) browser_spec=yes BROWSER=$2 shift;; -coqwebsite|--coqwebsite) wwwcoq_spec=yes WWWCOQ=$2 shift;; -with-doc|--with-doc) with_doc_spec=yes case "$2" in yes|all) with_doc=all;; *) with_doc=no esac shift;; -with-geoproof|--with-geoproof) case "$2" in yes) with_geoproof=true;; no) with_geoproof=false;; esac shift;; -makecmd|--makecmd) makecmd="$2" shift;; -byte-only|-byteonly|--byteonly|--byte-only) best_compiler=byte;; -debug|--debug) coq_debug_flag=-g;; -profile|--profile) coq_profile_flag=-p;; -annotate|--annotate) coq_annotate_flag=-dtypes;; -force-caml-version|--force-caml-version|-force-ocaml-version|--force-ocaml-version) force_caml_version_spec=yes force_caml_version=yes;; *) echo "Unknown option \"$1\"." 1>&2; usage; exit 2;; esac shift done if [ $prefix_spec = yes -a $local = true ] ; then echo "Options -prefix and -local are incompatible." echo "Configure script failed!" exit 1 fi # compile date DATEPGM=`which date` case $DATEPGM in "") echo "I can't find the program \"date\" in your path." echo "Please give me the current date" read COMPILEDATE;; *) COMPILEDATE=`LC_ALL=C LANG=C date +"%b %d %Y %H:%M:%S"`;; esac # Architecture case $arch_spec in no) # First we test if we are running a Cygwin or Mingw/Msys system if [ `uname -s | cut -c -6` = "CYGWIN" ] ; then ARCH="win32" CYGWIN=yes elif [ `uname -s | cut -c -7` = "MINGW32" ]; then ARCH="win32" else # If not, we determine the architecture if test -x /bin/uname ; then ARCH=`/bin/uname -s` elif test -x /usr/bin/uname ; then ARCH=`/usr/bin/uname -s` elif test -x /bin/arch ; then ARCH=`/bin/arch` elif test -x /usr/bin/arch ; then ARCH=`/usr/bin/arch` elif test -x /usr/ucb/arch ; then ARCH=`/usr/ucb/arch` else echo "I can not automatically find the name of your architecture." printf "%s"\ "Give me a name, please [win32 for Win95, Win98 or WinNT]: " read ARCH fi fi;; yes) ARCH=$arch esac # executable extension case $ARCH in win32) EXE=".exe" DLLEXT=".dll";; *) EXE="" DLLEXT=".so" esac # Is the source tree checked out from a recognised # version control system ? if test -e .svn/entries ; then checkedout=svn elif [ -d '{arch}' ]; then checkedout=gnuarch elif [ -z "${GIT_DIR}" ] && [ -d .git ] || [ -d "${GIT_DIR}" ]; then checkedout=git else checkedout=0 fi # make command MAKE=`which ${makecmd:-make}` if [ "$MAKE" != "" ]; then # Beware of the final \r in Win32 MAKEVERSION=`"$MAKE" -v | head -1 | tr -d "\r" | cut -d" " -f3` MAKEVERSIONMAJOR=`echo $MAKEVERSION | cut -d. -f1` MAKEVERSIONMINOR=`echo $MAKEVERSION | cut -d. -f2` if [ "$MAKEVERSIONMAJOR" -gt 3 -o "$MAKEVERSIONMAJOR" -eq 3 -a "$MAKEVERSIONMINOR" -ge 81 ]; then echo "You have GNU Make $MAKEVERSION. Good!" else OK="no" #Extra support for local installation of make 3.81 #will be useless when make >= 3.81 will be standard if [ -x ./make ]; then MAKEVERSION=`./make -v | head -1` if [ "$MAKEVERSION" = "GNU Make 3.81" ]; then OK="yes"; fi fi if [ $OK = "no" ]; then echo "GNU Make >= 3.81 is needed." echo "Make 3.81 can be downloaded from ftp://ftp.gnu.org/gnu/make/make-3.81.tar.gz" echo "then locally installed on a Unix-style system by issuing:" echo " tar xzvf make-3.81.tar.gz" echo " cd make-3.81" echo " ./configure" echo " make" echo " mv make .." echo " cd .." echo "Restart then the configure script and later use ./make instead of make." exit 1 else echo "You have locally installed GNU Make 3.81. Good!" fi fi else echo "Cannot find GNU Make >= 3.81." fi # Browser command if [ "$browser_spec" = "no" ]; then case $ARCH in win32) BROWSER='start %s' ;; Darwin) BROWSER='open %s' ;; *) BROWSER='firefox -remote "OpenURL(%s,new-tab)" || firefox %s &' ;; esac fi if [ "$wwwcoq_spec" = "no" ]; then WWWCOQ="http://coq.inria.fr/" fi ######################################### # Objective Caml programs case $camldir_spec in no) CAMLC=`which $bytecamlc` case "$CAMLC" in "") echo "$bytecamlc is not present in your path!" echo "Give me manually the path to the $bytecamlc executable [/usr/local/bin by default]: " read CAMLC case "$CAMLC" in "") CAMLC=/usr/local/bin/$bytecamlc;; */ocamlc|*/ocamlc.opt) true;; */) CAMLC="${CAMLC}"$bytecamlc;; *) CAMLC="${CAMLC}"/$bytecamlc;; esac esac CAMLBIN=`dirname "$CAMLC"`;; yes) CAMLC=$camldir/$bytecamlc CAMLBIN=`dirname "$CAMLC"` bytecamlc="$CAMLC" nativecamlc=$CAMLBIN/$nativecamlc ocamlexec=$CAMLBIN/ocaml ocamldepexec=$CAMLBIN/ocamldep ocamldocexec=$CAMLBIN/ocamldoc ocamllexexec=$CAMLBIN/ocamllex ocamlyaccexec=$CAMLBIN/ocamlyacc ocamlmktopexec=$CAMLBIN/ocamlmktop ocamlmklibexec=$CAMLBIN/ocamlmklib camlp4oexec=$CAMLBIN/camlp4o esac if test ! -f "$CAMLC" ; then echo "I can not find the executable '$CAMLC'. Have you installed it?" echo "Configuration script failed!" exit 1 fi # Under Windows, we need to convert from cygwin/mingw paths (/c/Program Files/Ocaml) # to more windows-looking paths (c:/Program Files/Ocaml). Note that / are kept mk_win_path () { case $ARCH,$CYGWIN in win32,yes) cygpath -m "$1" ;; win32*) "$ocamlexec" "tools/mingwpath.ml" "$1" ;; *) echo "$1" ;; esac } case $ARCH,$src_spec in win32,yes) echo "Error: the -src option is currently not supported on Windows" exit 1;; win32) CAMLBIN=`mk_win_path "$CAMLBIN"`;; esac # Beware of the final \r in Win32 CAMLVERSION=`"$CAMLC" -version | tr -d "\r"` CAMLLIB=`"$CAMLC" -where | tr -d "\r"` case $CAMLVERSION in 1.*|2.*|3.0*|3.10*|3.11.[01]) echo "Your version of Objective-Caml is $CAMLVERSION." if [ "$force_caml_version" = "yes" ]; then echo "*Warning* You are compiling Coq with an outdated version of Objective-Caml." else echo " You need Objective-Caml 3.11.2 or later." echo " Configuration script failed!" exit 1 fi;; 3.11.2|3.12*|4.*) CAMLP4COMPAT="-loc loc" echo "You have Objective-Caml $CAMLVERSION. Good!";; *) echo "I found the Objective-Caml compiler but cannot find its version number!" echo "Is it installed properly?" echo "Configuration script failed!" exit 1;; esac CAMLTAG=OCAML`echo $CAMLVERSION | sed -e "s/\([1-9]\)\.\([0-9]*\).*/\1\2/g"` # For coqmktop & bytecode compiler if [ "$coq_debug_flag" = "-g" ]; then case $CAMLTAG in OCAML31*|OCAML4*) # Compilation debug flag coq_debug_flag_opt="-g" ;; esac fi # Native dynlink if [ "$natdynlink" = "yes" -a -f "$CAMLLIB"/dynlink.cmxa ]; then HASNATDYNLINK=true else HASNATDYNLINK=false fi case $HASNATDYNLINK,$ARCH,`uname -r`,$CAMLVERSION in true,Darwin,9.*,3.11.*) # ocaml 3.11.0 dynlink on MacOS 10.5 is buggy NATDYNLINKFLAG=os5fixme;; #Possibly a problem on 10.6.0/10.6.1/10.6.2 #May just be a 32 vs 64 problem for all 10.6.* true,Darwin,10.0.*,3.11.*) # Possibly a problem on 10.6.0 NATDYNLINKFLAG=os5fixme;; true,Darwin,10.1.*,3.11.*) # Possibly a problem on 10.6.1 NATDYNLINKFLAG=os5fixme;; true,Darwin,10.2.*,3.11.*) # Possibly a problem on 10.6.2 NATDYNLINKFLAG=os5fixme;; true,Darwin,10.*,3.11.*) if [ `getconf LONG_BIT` = "32" ]; then # Still a problem for x86_32 NATDYNLINKFLAG=os5fixme else # Not a problem for x86_64 NATDYNLINKFLAG=$HASNATDYNLINK fi;; *) NATDYNLINKFLAG=$HASNATDYNLINK;; esac # Camlp4 / Camlp5 configuration # Assume that camlp(4|5) binaries are at the same place as ocaml ones # (this should become configurable some day) CAMLP4BIN=${CAMLBIN} case $usecamlp5 in yes) CAMLP4=camlp5 CAMLP4MOD=gramlib if [ "$camlp5dir" != "" ]; then if [ -f "$camlp5dir/${CAMLP4MOD}.cma" ]; then CAMLP4LIB=$camlp5dir FULLCAMLP4LIB=$camlp5dir else echo "Cannot find camlp5 libraries in $camlp5dir (camlp5.cma not found)." echo "Configuration script failed!" exit 1 fi else # Beware of the final \r in Win32 camlp5dir="$(camlp5 -where | tr -d '\r')" if [ "$camlp5dir" != "" ]; then CAMLP4LIB=$camlp5dir FULLCAMLP4LIB=$camlp5dir elif [ -f "${CAMLLIB}/camlp5/${CAMLP4MOD}.cma" ]; then CAMLP4LIB=+camlp5 FULLCAMLP4LIB=${CAMLLIB}/camlp5 elif [ -f "${CAMLLIB}/site-lib/${CAMLP4MOD}.cma" ]; then CAMLP4LIB=+site-lib/camlp5 FULLCAMLP4LIB=${CAMLLIB}/site-lib/camlp5 else echo "No Camlp5 installation found. Looking for Camlp4 instead..." usecamlp5=no fi fi esac # If we're (still...) going to use Camlp5, let's check its version case $usecamlp5 in yes) camlp4oexec=`echo "$camlp4oexec" | tr 4 5` case `"$camlp4oexec" -v 2>&1` in *"version 4.0"*|*5.00*) echo "Camlp5 version < 5.01 not supported." echo "Configuration script failed!" exit 1;; esac esac # We might now try to use Camlp4, either by explicit choice or # by lack of proper Camlp5 installation case $usecamlp5 in no) CAMLP4=camlp4 CAMLP4MOD=camlp4lib CAMLP4LIB=+camlp4 FULLCAMLP4LIB=${CAMLLIB}/camlp4 if [ ! -f "${FULLCAMLP4LIB}/${CAMLP4MOD}.cma" ]; then echo "No Camlp4 installation found." echo "Configuration script failed!" exit 1 fi camlp4oexec=${camlp4oexec}rf if [ "`"$camlp4oexec" 2>&1`" != "" ]; then echo "Error: $camlp4oexec not found or not executable." echo "Configuration script failed!" exit 1 fi esac # do we have a native compiler: test of ocamlopt and its version if [ "$best_compiler" = "opt" ] ; then if test -e "$nativecamlc" || test -e "`which $nativecamlc`"; then CAMLOPTVERSION=`"$nativecamlc" -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' ` if [ ! -f "${FULLCAMLP4LIB}/${CAMLP4MOD}.cmxa" ]; then best_compiler=byte echo "Cannot find native-code $CAMLP4," echo "only the bytecode version of Coq will be available." else if [ "$CAMLOPTVERSION" != "$CAMLVERSION" ] ; then echo "Native and bytecode compilers do not have the same version!" fi echo "You have native-code compilation. Good!" fi else best_compiler=byte echo "You have only bytecode compilation." fi fi # OS dependent libraries OSDEPLIBS="-cclib -lunix" case $ARCH in sun4*) OS=`uname -r` case $OS in 5*) OS="Sun Solaris $OS" OSDEPLIBS="$OSDEPLIBS -cclib -lnsl -cclib -lsocket";; *) OS="Sun OS $OS" esac;; esac # lablgtk2 and CoqIDE IDEARCHFLAGS= IDEARCHFILE= IDEARCHDEF=X11 # -byte-only should imply -coqide byte, unless the user decides otherwise if [ "$best_compiler" = "byte" -a "$coqide_spec" = "no" ]; then coqide_spec=yes COQIDE=byte fi # Which coqide is asked ? which one is possible ? if [ "$coqide_spec" = "yes" -a "$COQIDE" = "no" ]; then echo "CoqIde disabled as requested." else case $lablgtkdir_spec in no) # Beware of the final \r in Win32 lablgtkdirtmp="$(ocamlfind query lablgtk2 2> /dev/null | tr -d '\r')" if [ "$lablgtkdirtmp" != "" ]; then if [ -f "$lablgtkdirtmp/glib.cmi" -a -f "$lablgtkdirtmp/glib.mli" ]; then lablgtkdirfoundmsg="LabelGtk2 found by ocamlfind" lablgtkdir=$lablgtkdirtmp LABLGTKLIB=$lablgtkdir # Pour le message utilisateur else echo "Headers missings in Lablgtk2 found by ocamlfind (glib.cmi/glib.mli not found)." fi fi if [ "$lablgtkdir" = "" -a -f "${CAMLLIB}/lablgtk2/glib.cmi" -a -f "${CAMLLIB}/lablgtk2/glib.mli" ]; then lablgtkdirfoundmsg="LablGtk2 found in ocaml lib directory" lablgtkdir=${CAMLLIB}/lablgtk2 LABLGTKLIB=+lablgtk2 # Pour le message utilisateur fi;; yes) if [ ! -d "$lablgtkdir" ]; then echo "$lablgtkdir is not a valid directory." echo "Configuration script failed!" exit 1 elif [ -f "$lablgtkdir/glib.cmi" -a -f "$lablgtkdir/glib.mli" ]; then lablgtkdirfoundmsg="LablGtk2 directory found" LABLGTKLIB=$lablgtkdir # Pour le message utilisateur else echo "Headers missing in LablGtk2 library (glib.cmi/glib.mli not found)." echo "Configuration script failed!" exit 1 fi;; esac if [ "$lablgtkdir" = "" ]; then echo "LablGtk2 not found: CoqIde will not be available." COQIDE=no elif [ -z "`grep -w convert_with_fallback "$lablgtkdir/glib.mli"`" ]; then echo "$lablgtkdirfoundmsg but too old: CoqIde will not be available." COQIDE=no; elif [ "$coqide_spec" = "yes" -a "$COQIDE" = "byte" ]; then echo "$lablgtkdirfoundmsg, bytecode CoqIde will be used as requested." COQIDE=byte elif [ ! -f "${CAMLLIB}/threads/threads.cmxa" ]; then echo "$lablgtkdirfoundmsg, no native threads: bytecode CoqIde will be available." COQIDE=byte else echo "$lablgtkdirfoundmsg, native threads: native CoqIde will be available." COQIDE=opt if [ "$nomacintegration_spec" = "no" ] && lablgtkosxdir=$(ocamlfind query lablgtkosx 2> /dev/null); then IDEARCHFLAGS=lablgtkosx.cmxa IDEARCHDEF=QUARTZ elif [ "$ARCH" = "win32" ]; then IDEARCHFLAGS= IDEARCHFILE=ide/ide_win32_stubs.o IDEARCHDEF=WIN32 fi fi fi case $COQIDE in byte|opt) LABLGTKINCLUDES="-I $LABLGTKLIB";; no) LABLGTKINCLUDES="";; esac [ x$lablgtkosxdir = x ] || LABLGTKINCLUDES="$LABLGTKINCLUDES -I $lablgtkosxdir" # strip command case $ARCH in Darwin) if [ "$HASNATDYNLINK" = "true" ] then STRIPCOMMAND="true" else STRIPCOMMAND="strip" fi;; *) if [ "$coq_profile_flag" = "-p" ] || [ "$coq_debug_flag" = "-g" ] then STRIPCOMMAND="true" else STRIPCOMMAND="strip" fi esac ### Test if documentation can be compiled (latex, hevea) if test "$with_doc" = "all" then for cmd in "latex" "hevea" ; do if test ! -x "`which $cmd`" then echo "$cmd was not found; documentation will not be available" with_doc=no break fi done fi ########################################### # bindir, libdir, mandir, docdir, etc. # OCaml only understand Windows filenames (C:\...) case $ARCH in win32) COQSRC=`mk_win_path "$COQSRC"` CAMLBIN=`mk_win_path "$CAMLBIN"` CAMLP4BIN=`mk_win_path "$CAMLP4BIN"` esac case $src_spec in no) COQTOP=${COQSRC} esac case $ARCH$CYGWIN in win32) W32PREF='C:\coq\' bindir_def="${W32PREF}bin" libdir_def="${W32PREF}lib" configdir_def="${W32PREF}config" datadir_def="${W32PREF}share" mandir_def="${W32PREF}man" docdir_def="${W32PREF}doc" emacslib_def="${W32PREF}emacs" coqdocdir_def="${W32PREF}latex";; *) bindir_def=/usr/local/bin libdir_def=/usr/local/lib/coq configdir_def=/etc/xdg/coq datadir_def=/usr/local/share/coq mandir_def=/usr/local/share/man docdir_def=/usr/local/share/doc/coq emacslib_def=/usr/local/share/emacs/site-lisp coqdocdir_def=/usr/local/share/texmf/tex/latex/misc;; esac emacs_def=emacs case $bindir_spec/$prefix_spec/$local in yes/*/*) BINDIR=$bindir ;; */yes/*) BINDIR=$prefix/bin ;; */*/true) BINDIR=$COQTOP/bin ;; *) printf "Where should I install the Coq binaries [%s]? " "$bindir_def" read BINDIR case $BINDIR in "") BINDIR=$bindir_def;; *) true;; esac;; esac case $libdir_spec/$prefix_spec/$local in yes/*/*) LIBDIR=$libdir;; */yes/*) libdir_spec=yes case $ARCH in win32) LIBDIR=$prefix ;; *) LIBDIR=$prefix/lib/coq ;; esac ;; */*/true) LIBDIR=$COQTOP ;; *) printf "Where should I install the Coq library [%s]? " "$libdir_def" read LIBDIR libdir_spec=yes case $LIBDIR in "") LIBDIR=$libdir_def;; *) true;; esac;; esac case $configdir_spec/$prefix_spec/$local in yes/*/*) CONFIGDIR=$configdir;; */yes/*) configdir_spec=yes case $ARCH in win32) CONFIGDIR=$prefix/config;; *) CONFIGDIR=$prefix/etc/xdg/coq;; esac;; */*/true) CONFIGDIR=$COQTOP/ide configdir_spec=yes;; *) printf "Where should I install the Coqide configuration files [%s]? " "$configdir_def" read CONFIGDIR case $CONFIGDIR in "") CONFIGDIR=$configdir_def;; *) configdir_spec=yes;; esac;; esac case $datadir_spec/$prefix_spec/$local in yes/*/*) DATADIR=$datadir;; */yes/*) DATADIR=$prefix/share/coq;; */*/true) DATADIR=$COQTOP/ide datadir_spec=yes;; *) printf "Where should I install the Coqide data files [%s]? " "$datadir_def" read DATADIR case $DATADIR in "") DATADIR=$datadir_def;; *) datadir_spec=yes;; esac;; esac case $mandir_spec/$prefix_spec/$local in yes/*/*) MANDIR=$mandir;; */yes/*) MANDIR=$prefix/share/man ;; */*/true) MANDIR=$COQTOP/man ;; *) printf "Where should I install the Coq man pages [%s]? " "$mandir_def" read MANDIR case $MANDIR in "") MANDIR=$mandir_def;; *) true;; esac;; esac case $docdir_spec/$prefix_spec/$local in yes/*/*) DOCDIR=$docdir;; */yes/*) DOCDIR=$prefix/share/doc/coq;; */*/true) DOCDIR=$COQTOP/doc;; *) printf "Where should I install the Coq documentation [%s]? " "$docdir_def" read DOCDIR case $DOCDIR in "") DOCDIR=$docdir_def;; *) true;; esac;; esac case $emacslib_spec/$prefix_spec/$local in yes/*/*) EMACSLIB=$emacslib;; */yes/*) case $ARCH in win32) EMACSLIB=$prefix/emacs ;; *) EMACSLIB=$prefix/share/emacs/site-lisp ;; esac ;; */*/true) EMACSLIB=$COQTOP/tools/emacs ;; *) printf "Where should I install the Coq Emacs mode [%s]? " "$emacslib_def" read EMACSLIB case $EMACSLIB in "") EMACSLIB=$emacslib_def;; *) true;; esac;; esac case $coqdocdir_spec/$prefix_spec/$local in yes/*/*) COQDOCDIR=$coqdocdir;; */yes/*) case $ARCH in win32) COQDOCDIR=$prefix/latex ;; *) COQDOCDIR=$prefix/share/emacs/site-lisp ;; esac ;; */*/true) COQDOCDIR=$COQTOP/tools/coqdoc ;; *) printf "Where should I install Coqdoc TeX/LaTeX files [%s]? " "$coqdocdir_def" read COQDOCDIR case $COQDOCDIR in "") COQDOCDIR=$coqdocdir_def;; *) true;; esac;; esac # Determine if we enable -custom by default (Windows and MacOS) CUSTOM_OS=no if [ "$ARCH" = "win32" ] || [ "$ARCH" = "Darwin" ]; then CUSTOM_OS=yes fi BUILDLDPATH="# you might want to set CAML_LD_LIBRARY_PATH by hand!" case $coqrunbyteflags_spec/$local/$custom_spec/$CUSTOM_OS in yes/*/*/*) COQRUNBYTEFLAGS="$coqrunbyteflags";; */*/yes/*|*/*/*/yes) COQRUNBYTEFLAGS="-custom";; */true/*/*) COQRUNBYTEFLAGS="-dllib -lcoqrun -dllpath '$COQTOP'/kernel/byterun";; *) COQRUNBYTEFLAGS="-dllib -lcoqrun -dllpath '$LIBDIR'" BUILDLDPATH="export CAML_LD_LIBRARY_PATH='$COQTOP'/kernel/byterun:$CAML_LD_LIBRARY_PATH";; esac case $coqtoolsbyteflags_spec/$custom_spec/$CUSTOM_OS in yes/*/*) COQTOOLSBYTEFLAGS="$coqtoolsbyteflags";; */yes/*|*/*/yes) COQTOOLSBYTEFLAGS="-custom";; *) COQTOOLSBYTEFLAGS="";; esac # case $emacs_spec in # no) printf "Which Emacs command should I use to compile coq.el [%s]? " "$emacs_def" # read EMACS # case $EMACS in # "") EMACS="$emacs_def";; # *) true;; # esac;; # yes) EMACS="$emacs";; # esac ########################################### # Summary of the configuration echo "" echo " Coq top directory : $COQTOP" echo " Architecture : $ARCH" if test ! -z "$OS" ; then echo " Operating system : $OS" fi echo " Coq VM bytecode link flags : $COQRUNBYTEFLAGS" echo " Coq tools bytecode link flags : $COQTOOLSBYTEFLAGS" echo " OS dependent libraries : $OSDEPLIBS" echo " Objective-Caml/Camlp4 version : $CAMLVERSION" echo " Objective-Caml/Camlp4 binaries in : $CAMLBIN" echo " Objective-Caml library in : $CAMLLIB" echo " Camlp4 library in : $CAMLP4LIB" if test "$best_compiler" = opt ; then echo " Native dynamic link support : $HASNATDYNLINK" fi if test "$COQIDE" != "no"; then echo " Lablgtk2 library in : $LABLGTKLIB" fi if test "$IDEARCHDEF" = "QUARTZ"; then echo " Mac OS integration is on" fi if test "$with_doc" = "all"; then echo " Documentation : All" else echo " Documentation : None" fi echo " CoqIde : $COQIDE" echo " Web browser : $BROWSER" echo " Coq web site : $WWWCOQ" echo "" echo " Paths for true installation:" echo " binaries will be copied in $BINDIR" echo " library will be copied in $LIBDIR" echo " config files will be copied in $CONFIGDIR" echo " data files will be copied in $DATADIR" echo " man pages will be copied in $MANDIR" echo " documentation will be copied in $DOCDIR" echo " emacs mode will be copied in $EMACSLIB" echo "" ################################################## # Building the $COQTOP/dev/ocamldebug-coq file ################################################## OCAMLDEBUGCOQ=$COQSRC/dev/ocamldebug-coq if test "$coq_debug_flag" = "-g" ; then rm -f $OCAMLDEBUGCOQ sed -e "s|COQTOPDIRECTORY|$COQTOP|" \ -e "s|COQLIBDIRECTORY|$LIBDIR|" \ -e "s|CAMLBINDIRECTORY|$CAMLBIN|" \ -e "s|CAMLP4LIBDIRECTORY|$FULLCAMLP4LIB|"\ $OCAMLDEBUGCOQ.template > $OCAMLDEBUGCOQ chmod a-w,a+x $OCAMLDEBUGCOQ fi #################################################### # Fixing lablgtk types (before/after 2.6.0) #################################################### if [ ! "$COQIDE" = "no" ]; then if grep "class view " "$lablgtkdir/gText.mli" | grep -q "\[>" ; then if grep -q "?accepts_tab:bool" "$lablgtkdir/gText.mli" ; then cp -f ide/undo_lablgtk_ge212.mli ide/undo.mli else cp -f ide/undo_lablgtk_ge26.mli ide/undo.mli fi else cp -f ide/undo_lablgtk_lt26.mli ide/undo.mli fi fi ############################################## # Creation of configuration files ############################################## mlconfig_file="$COQSRC/config/coq_config.ml" config_file="$COQSRC/config/Makefile" config_template="$COQSRC/config/Makefile.template" ### Warning !! ### After this line, be careful when using variables, ### since some of them (e.g. $COQSRC) will be escaped escape_string () { "$ocamlexec" "tools/escape_string.ml" "$1" } # Escaped version of browser command BROWSER=`escape_string "$BROWSER"` # Under Windows, we now escape the backslashes that will ends in # ocaml strings (coq_config.ml) or in Makefile variables. case $ARCH in win32) COQTOP=`escape_string "$COQTOP"` BINDIR=`escape_string "$BINDIR"` COQSRC=`escape_string "$COQSRC"` LIBDIR=`escape_string "$LIBDIR"` CONFIGDIR=`escape_string "$CONFIGDIR"` DATADIR=`escape_string "$DATADIR"` CAMLBIN=`escape_string "$CAMLBIN"` CAMLLIB=`escape_string "$CAMLLIB"` MANDIR=`escape_string "$MANDIR"` DOCDIR=`escape_string "$DOCDIR"` EMACSLIB=`escape_string "$EMACSLIB"` COQDOCDIR=`escape_string "$COQDOCDIR"` CAMLP4BIN=`escape_string "$CAMLP4BIN"` CAMLP4LIB=`escape_string "$CAMLP4LIB"` LABLGTKINCLUDES=`escape_string "$LABLGTKINCLUDES"` COQRUNBYTEFLAGS=`escape_string "$COQRUNBYTEFLAGS"` COQTOOLSBYTEFLAGS=`escape_string "$COQTOOLSBYTEFLAGS"` BUILDLDPATH=`escape_string "$BUILDLDPATH"` ocamlexec=`escape_string "$ocamlexec"` bytecamlc=`escape_string "$bytecamlc"` nativecamlc=`escape_string "$nativecamlc"` ocamlmklibexec=`escape_string "$ocamlmklibexec"` ocamldepexec=`escape_string "$ocamldepexec"` ocamldocexec=`escape_string "$ocamldocexec"` ocamllexexec=`escape_string "$ocamllexexec"` ocamlyaccexec=`escape_string "$ocamlyaccexec"` camlp4oexec=`escape_string "$camlp4oexec"` ;; esac case $libdir_spec in yes) LIBDIR_OPTION="Some \"$LIBDIR\"";; *) LIBDIR_OPTION="None";; esac case $configdir_spec in yes) CONFIGDIR_OPTION="Some \"$CONFIGDIR\"";; *) CONFIGDIR_OPTION="None";; esac case $datadir_spec in yes) DATADIR_OPTION="Some \"$DATADIR\"";; *) DATADIR_OPTION="None";; esac ##################################################### # Building the $COQTOP/config/coq_config.ml file ##################################################### rm -f "$mlconfig_file" cat << END_OF_COQ_CONFIG > $mlconfig_file (* DO NOT EDIT THIS FILE: automatically generated by ../configure *) let local = $local let coqrunbyteflags = "$COQRUNBYTEFLAGS" let coqlib = $LIBDIR_OPTION let configdir = $CONFIGDIR_OPTION let datadir = $DATADIR_OPTION let docdir = "$DOCDIR" let ocaml = "$ocamlexec" let ocamlc = "$bytecamlc" let ocamlopt = "$nativecamlc" let ocamlmklib = "$ocamlmklibexec" let ocamldep = "$ocamldepexec" let ocamldoc = "$ocamldocexec" let ocamlyacc = "$ocamlyaccexec" let ocamllex = "$ocamllexexec" let camlbin = "$CAMLBIN" let camllib = "$CAMLLIB" let camlp4 = "$CAMLP4" let camlp4o = "$camlp4oexec" let camlp4bin = "$CAMLP4BIN" let camlp4lib = "$CAMLP4LIB" let camlp4compat = "$CAMLP4COMPAT" let coqideincl = "$LABLGTKINCLUDES" let cflags = "$cflags" let best = "$best_compiler" let arch = "$ARCH" let has_coqide = "$COQIDE" let gtk_platform = \`$IDEARCHDEF let has_natdynlink = $HASNATDYNLINK let natdynlinkflag = "$NATDYNLINKFLAG" let osdeplibs = "$OSDEPLIBS" let version = "$VERSION" let caml_version = "$CAMLVERSION" let date = "$DATE" let compile_date = "$COMPILEDATE" let vo_magic_number = $VOMAGIC let state_magic_number = $STATEMAGIC let exec_extension = "$EXE" let with_geoproof = ref $with_geoproof let browser = "$BROWSER" let wwwcoq = "$WWWCOQ" let wwwrefman = wwwcoq ^ "distrib/" ^ version ^ "/refman/" let wwwstdlib = wwwcoq ^ "distrib/" ^ version ^ "/stdlib/" let localwwwrefman = "file:/" ^ docdir ^ "html/refman" END_OF_COQ_CONFIG # to be sure printf is found on windows when spaces occur in PATH variable PRINTF=`which printf` # Subdirectories of theories/ added in coq_config.ml subdirs () { (cd $1; find * \( -name .svn -prune \) -o \( -type d -exec $PRINTF "\"%s\";\n" {} \; \) >> "$mlconfig_file") } echo "let theories_dirs = [" >> "$mlconfig_file" subdirs theories echo "]" >> "$mlconfig_file" echo "let plugins_dirs = [" >> "$mlconfig_file" subdirs plugins echo "]" >> "$mlconfig_file" chmod a-w "$mlconfig_file" ############################################### # Building the $COQTOP/config/Makefile file ############################################### rm -f "$config_file" cat << END_OF_MAKEFILE > $config_file ###### config/Makefile : Configuration file for Coq ############## # # # This file is generated by the script "configure" # # DO NOT EDIT IT !! DO NOT EDIT IT !! DO NOT EDIT IT !! # # If something is wrong below, then rerun the script "configure" # # with the good options (see the file INSTALL). # # # ################################################################## #Variable used to detect whether ./configure has run successfully. COQ_CONFIGURED=yes # Local use (no installation) LOCAL=$local # Bytecode link flags for VM ("-custom" or "-dllib -lcoqrun") COQRUNBYTEFLAGS=$COQRUNBYTEFLAGS COQTOOLSBYTEFLAGS=$COQTOOLSBYTEFLAGS $BUILDLDPATH # Paths for true installation # BINDIR=path where coqtop, coqc, coqmktop, coq-tex, coqdep, gallina and # do_Makefile will reside # LIBDIR=path where the Coq library will reside # MANDIR=path where to install manual pages # EMACSDIR=path where to put Coq's Emacs mode (coq.el) BINDIR="$BINDIR" COQLIBINSTALL="$LIBDIR" CONFIGDIR="$CONFIGDIR" DATADIR="$DATADIR" MANDIR="$MANDIR" DOCDIR="$DOCDIR" EMACSLIB="$EMACSLIB" EMACS=$EMACS # Path to Coq distribution COQSRC="$COQSRC" VERSION=$VERSION # Ocaml version number CAMLVERSION=$CAMLTAG # Ocaml libraries CAMLLIB="$CAMLLIB" # Ocaml .h directory CAMLHLIB="$CAMLLIB" # Camlp4 : flavor, binaries, libraries ... # NB : CAMLP4BIN can be empty if camlp4 is in the PATH # NB : avoid using CAMLP4LIB (conflict under Windows) CAMLP4BIN="$CAMLP4BIN" CAMLP4=$CAMLP4 CAMLP4O=$camlp4oexec CAMLP4COMPAT=$CAMLP4COMPAT MYCAMLP4LIB="$CAMLP4LIB" # LablGTK COQIDEINCLUDES=$LABLGTKINCLUDES # Objective-Caml compile command OCAML="$ocamlexec" OCAMLC="$bytecamlc" OCAMLMKLIB="$ocamlmklibexec" OCAMLOPT="$nativecamlc" OCAMLDEP="$ocamldepexec" OCAMLDOC="$ocamldocexec" OCAMLLEX="$ocamllexexec" OCAMLYACC="$ocamlyaccexec" # Caml link command and Caml make top command CAMLLINK="$bytecamlc" CAMLOPTLINK="$nativecamlc" CAMLMKTOP="$ocamlmktopexec" # Caml flags CAMLFLAGS=-rectypes $coq_annotate_flag # Compilation debug flags CAMLDEBUG=$coq_debug_flag CAMLDEBUGOPT=$coq_debug_flag_opt # User compilation flag USERFLAGS= # Flags for GCC CFLAGS=$cflags # Compilation profile flag CAMLTIMEPROF=$coq_profile_flag # The best compiler: native (=opt) or bytecode (=byte) if no native compiler BEST=$best_compiler # Your architecture # Can be obtain by UNIX command arch ARCH=$ARCH HASNATDYNLINK=$NATDYNLINKFLAG # Supplementary libs for some systems, currently: # . Sun Solaris: -cclib -lunix -cclib -lnsl -cclib -lsocket # . others : -cclib -lunix OSDEPLIBS=$OSDEPLIBS # executable files extension, currently: # Unix systems: # Win32 systems : .exe EXE=$EXE DLLEXT=$DLLEXT # the command MKDIR (try to replace it with mkdirhier if you have problems) MKDIR=mkdir -p # where to put the coqdoc.sty style file COQDOCDIR="$COQDOCDIR" #the command STRIP # Unix systems and profiling: true # Unix systems and no profiling: strip STRIP=$STRIPCOMMAND # CoqIde (no/byte/opt) HASCOQIDE=$COQIDE IDEOPTFLAGS=$IDEARCHFLAGS IDEOPTDEPS=$IDEARCHFILE IDEOPTINT=$IDEARCHDEF # Defining REVISION CHECKEDOUT=$checkedout # Option to control compilation and installation of the documentation WITHDOC=$with_doc # make or sed are bogus and believe lines not terminating by a return # are inexistent END_OF_MAKEFILE chmod a-w "$config_file" ################################################## # The end #################################################### echo "If anything in the above is wrong, please restart './configure'." echo echo "*Warning* To compile the system for a new architecture" echo " don't forget to do a 'make archclean' before './configure'." coq-8.4pl4/myocamlbuild.ml0000644000175000017500000004322412326224777014653 0ustar stephsteph(** * Plugin for building Coq via Ocamlbuild *) open Ocamlbuild_plugin open Ocamlbuild_pack open Printf open Scanf (** WARNING !! this is preliminary stuff. It should allows you to build coq and its libraries if everything goes right. Support for all the build rules and configuration options is progressively added. Tested only on linux + ocaml 3.11 + local + natdynlink for now. Usage: ./configure -local -opt ./build (which launches ocamlbuild coq.otarget) Then you can (hopefully) launch bin/coqtop, bin/coqide and so on. Apart from the links in bin, every created files are in _build. A "./build clean" should give you back a clean source tree *) (** F.A.Q about ocamlbuild: * P / Px ? Same, except that the second can be use to signal the main target of a rule, in order to get a nicer log (otherwise the full command is used as target name) *) (** Generic file reader, which produces a list of strings, one per line *) let read_file f = let ic = open_in f and l = ref [] in (try while true do l := (input_line ic)::!l done with End_of_file -> ()); close_in ic; List.rev !l (** Configuration *) (** First, we access coq_config.ml indirectly : we symlink it to myocamlbuild_config.ml, which is linked with this myocamlbuild.ml *) module Coq_config = struct include Myocamlbuild_config end let _ = begin Options.ocamlc := A Coq_config.ocamlc; Options.ocamlopt := A Coq_config.ocamlopt; Options.ocamlmklib := A Coq_config.ocamlmklib; Options.ocamldep := A Coq_config.ocamldep; Options.ocamldoc := A Coq_config.ocamldoc; Options.ocamlyacc := A Coq_config.ocamlyacc; Options.ocamllex := A Coq_config.ocamllex; end let w32 = (Coq_config.arch = "win32") let w32pref = "i586-mingw32msvc" let w32ocamlc = w32pref^"-ocamlc" let w32ocamlopt = w32pref^"-ocamlopt" let w32ocamlmklib = w32pref^"-ocamlmklib" let w32res = w32pref^"-windres" let w32lib = "/usr/"^w32pref^"/lib/" let w32bin = "/usr/"^w32pref^"/bin/" let w32ico = "ide/coq_icon.o" let _ = if w32 then begin Options.ocamlopt := A w32ocamlopt; Options.ocamlmklib := A w32ocamlmklib; end let use_camlp5 = (Coq_config.camlp4 = "camlp5") let camlp4lib = if w32 then w32lib^"ocaml/camlp5" else Coq_config.camlp4lib let camlp4args = if use_camlp5 then [A "pa_extend.cmo";A "q_MLast.cmo";A "pa_macro.cmo"] else [] let ocaml = A Coq_config.ocaml let camlp4o = S ((A Coq_config.camlp4o) :: camlp4args) let camlp4incl = S[A"-I"; A camlp4lib] let camlp4compat = Sh Coq_config.camlp4compat let opt = (Coq_config.best = "opt") let ide = Coq_config.has_coqide let hasdynlink = Coq_config.has_natdynlink let os5fix = (Coq_config.natdynlinkflag = "os5fixme") let flag_dynlink = if hasdynlink then A"-DHasDynlink" else N let dep_dynlink = if hasdynlink then N else Sh"-natdynlink no" let lablgtkincl = Sh Coq_config.coqideincl let local = Coq_config.local let cflags = S[A"-ccopt";A Coq_config.cflags] (** Do we want to inspect .ml generated from .ml4 ? *) let readable_genml = false let readable_flag = if readable_genml then A"pr_o.cmo" else N let _build = Options.build_dir (** Abbreviations about files *) let core_libs = ["lib/lib"; "kernel/kernel"; "library/library"; "pretyping/pretyping"; "interp/interp"; "proofs/proofs"; "parsing/parsing"; "tactics/tactics"; "toplevel/toplevel"; "parsing/highparsing"; "tactics/hightactics"] let core_cma = List.map (fun s -> s^".cma") core_libs let core_cmxa = List.map (fun s -> s^".cmxa") core_libs let core_mllib = List.map (fun s -> s^".mllib") core_libs let tolink = "scripts/tolink.ml" let c_headers_base = ["coq_fix_code.h";"coq_instruct.h"; "coq_memory.h"; "int64_emul.h"; "coq_gc.h"; "coq_interp.h"; "coq_values.h"; "int64_native.h"; "coq_jumptbl.h"] let c_headers = List.map ((^) "kernel/byterun/") c_headers_base let coqinstrs = "kernel/byterun/coq_instruct.h" let coqjumps = "kernel/byterun/coq_jumptbl.h" let copcodes = "kernel/copcodes.ml" let libcoqrun = "kernel/byterun/libcoqrun.a" let initialcoq = "states/initial.coq" let init_vo = ["theories/Init/Prelude.vo";"theories/Init/Logic_Type.vo"] let makeinitial = "states/MakeInitial.v" let nmake = "theories/Numbers/Natural/BigN/NMake_gen.v" let nmakegen = "theories/Numbers/Natural/BigN/NMake_gen.ml" let adapt_name (pref,oldsuf,newsuf) f = pref ^ (Filename.chop_suffix f oldsuf) ^ newsuf let get_names (oldsuf,newsuf) s = let pref = Filename.dirname s ^ "/" in List.map (adapt_name (pref,oldsuf,newsuf)) (string_list_of_file s) let get_vo_itargets f = let vo_itargets = get_names (".otarget",".itarget") f in List.flatten (List.map (get_names (".vo",".v")) vo_itargets) let theoriesv = get_vo_itargets "theories/theories.itarget" let pluginsv = get_vo_itargets "plugins/pluginsvo.itarget" let pluginsmllib = get_names (".cma",".mllib") "plugins/pluginsbyte.itarget" (** for correct execution of coqdep_boot, source files should have been imported in _build (and NMake_gen.v should have been created). *) let coqdepdeps = theoriesv @ pluginsv @ pluginsmllib let coqtop = "toplevel/coqtop" let coqide = "ide/coqide" let coqdepboot = "tools/coqdep_boot" let coqmktop = "scripts/coqmktop" (** The list of binaries to build: (name of link in bin/, name in _build, install both or only best) *) type links = Both | Best | BestInPlace | Ide let all_binaries = (if w32 then [ "mkwinapp", "tools/mkwinapp", Best ] else []) @ [ "coqtop", coqtop, Both; "coqide", "ide/coqide_main", Ide; "coqmktop", coqmktop, Both; "coqc", "scripts/coqc", Both; "coqchk", "checker/main", Both; "coqdep_boot", coqdepboot, Best; "coqdep", "tools/coqdep", Best; "coqdoc", "tools/coqdoc/main", Best; "coqwc", "tools/coqwc", Best; "coq_makefile", "tools/coq_makefile", Best; "coq-tex", "tools/coq_tex", Best; "gallina", "tools/gallina", Best; "csdpcert", "plugins/micromega/csdpcert", BestInPlace; "fake_ide", "tools/fake_ide", Best; ] let best_oext = if opt then ".native" else ".byte" let best_ext = if opt then ".opt" else ".byte" let best_iext = if ide = "opt" then ".opt" else ".byte" let coqtopbest = coqtop^best_oext (* For inner needs, we rather use the bytecode versions of coqdep and coqmktop: slightly slower but compile quickly, and ok with w32 cross-compilation *) let coqdep_boot = coqdepboot^".byte" let coqmktop_boot = coqmktop^".byte" let binariesopt_deps = let addext b = b ^ ".native" in let rec deps = function | [] -> [] | (_,b,Ide)::l -> if ide="opt" then addext b :: deps l else deps l | (_,b,_)::l -> if opt then addext b :: deps l else deps l in deps all_binaries let binariesbyte_deps = let addext b = b ^ ".byte" in let rec deps = function | [] -> [] | (_,b,Ide)::l -> if ide<>"no" then addext b :: deps l else deps l | (_,b,Both)::l -> addext b :: deps l | (_,b,_)::l -> if not opt then addext b :: deps l else deps l in deps all_binaries let ln_sf toward f = Command.execute ~quiet:true (Cmd (S [A"ln";A"-sf";P toward;P f])) let rec make_bin_links = function | [] -> () | (b,ob,kind)::l -> make_bin_links l; let obd = "../"^ !_build^"/"^ob and bd = "bin/"^b in match kind with | Ide when ide <> "no" -> ln_sf (obd^".byte") (bd^".byte"); if ide = "opt" then ln_sf (obd^".native") (bd^".opt"); ln_sf (b^best_iext) bd | Ide (* when ide = "no" *) -> () | Both -> ln_sf (obd^".byte") (bd^".byte"); if opt then ln_sf (obd^".native") (bd^".opt"); ln_sf (b^best_ext) bd | Best -> ln_sf (obd^best_oext) bd | BestInPlace -> ln_sf (b^best_oext) (!_build^"/"^ob) let incl f = Ocaml_utils.ocaml_include_flags f let cmd cl = (fun _ _ -> (Cmd (S cl))) let initial_actions () = begin (** We "pre-create" a few subdirs in _build *) Shell.mkdir_p (!_build^"/dev"); Shell.mkdir_p (!_build^"/bin"); Shell.mkdir_p (!_build^"/plugins/micromega"); make_bin_links all_binaries; end let extra_rules () = begin (** Virtual target for building all binaries *) rule "binariesopt" ~stamp:"binariesopt" ~deps:binariesopt_deps (fun _ _ -> Nop); rule "binariesbyte" ~stamp:"binariesbyte" ~deps:binariesbyte_deps (fun _ _ -> Nop); rule "binaries" ~stamp:"binaries" ~deps:["binariesbyte";"binariesopt"] (fun _ _ -> Nop); (** We create a special coq_config which mentions _build *) rule "coq_config.ml" ~prod:"coq_config.ml" ~dep:"config/coq_config.ml" (fun _ _ -> if w32 then cp "config/coq_config.ml" "coq_config.ml" else let lines = read_file "config/coq_config.ml" in let lines = List.map (fun s -> s^"\n") lines in let line0 = "\n(* Adapted variables for ocamlbuild *)\n" in (* TODO : line2 isn't completely accurate with respect to ./configure: the case of -local -coqrunbyteflags foo isn't supported *) let line1 = "let coqrunbyteflags = \"-dllib -lcoqrun\"\n" in Echo (lines @ (if local then [line0;line1] else []), "coq_config.ml")); (** Camlp4 extensions *) rule ".ml4.ml" ~dep:"%.ml4" ~prod:"%.ml" (fun env _ -> let ml4 = env "%.ml4" and ml = env "%.ml" in Cmd (S[camlp4o;T(tags_of_pathname ml4 ++ "p4mod");readable_flag; T(tags_of_pathname ml4 ++ "p4option"); camlp4compat; A"-o"; Px ml; A"-impl"; P ml4])); flag_and_dep ["p4mod"; "use_grammar"] (P "parsing/grammar.cma"); flag_and_dep ["p4mod"; "use_constr"] (P "parsing/q_constr.cmo"); flag_and_dep ["p4mod"; "use_compat5"] (P "tools/compat5.cmo"); flag_and_dep ["p4mod"; "use_compat5b"] (P "tools/compat5b.cmo"); if w32 then begin flag ["p4mod"] (A "-DWIN32"); dep ["ocaml"; "link"; "ide"] ["ide/ide_win32_stubs.o"]; end; if not use_camlp5 then begin let mlp_cmo s = let src=s^".mlp" and dst=s^".cmo" in rule (src^".cmo") ~dep:src ~prod:dst ~insert:`top (fun env _ -> Cmd (S [!Options.ocamlc; A"-c"; A"-pp"; Quote (S [camlp4o;A"-impl"]); camlp4incl; A"-impl"; P src])) in mlp_cmo "tools/compat5"; mlp_cmo "tools/compat5b"; end; ocaml_lib ~extern:true ~dir:camlp4lib ~tag_name:"use_camlpX" ~byte:true ~native:true (if use_camlp5 then "gramlib" else "camlp4lib"); (** Special case of toplevel/mltop.ml4: - mltop.ml will be the old mltop.optml and be used to obtain mltop.cmx - we add a special mltop.ml4 --> mltop.cmo rule, before all the others *) flag ["is_mltop"; "p4option"] flag_dynlink; (*TODO: this is rather ugly for a simple file, we should try to benefit more from predefined rules *) let mltop = "toplevel/mltop" in let ml4 = mltop^".ml4" and mlo = mltop^".cmo" and ml = mltop^".ml" and mld = mltop^".ml.depends" in rule "mltop_byte" ~deps:[ml4;mld] ~prod:mlo ~insert:`top (fun env build -> Ocaml_compiler.prepare_compile build ml; Cmd (S [!Options.ocamlc; A"-c"; A"-pp"; Quote (S [camlp4o; T(tags_of_pathname ml4 ++ "p4mod"); A"-DByte";A"-DHasDynlink";camlp4compat;A"-impl"]); A"-rectypes"; A"-impl"; P ml4])); (** All caml files are compiled with -rectypes and +camlp4/5 and ide files need +lablgtk2 *) flag ["compile"; "ocaml"] (S [A"-rectypes"; camlp4incl]); flag ["link"; "ocaml"] (S [A"-rectypes"; camlp4incl]); flag ["ocaml"; "ide"; "compile"] lablgtkincl; flag ["ocaml"; "ide"; "link"] lablgtkincl; flag ["ocaml"; "ide"; "link"; "byte"] (S [A"lablgtk.cma"; A"gtkThread.cmo"]); flag ["ocaml"; "ide"; "link"; "native"] (S [A"lablgtk.cmxa"; A"gtkThread.cmx"]); (** C code for the VM *) dep ["compile"; "c"] c_headers; flag ["compile"; "c"] cflags; dep ["ocaml"; "use_libcoqrun"; "compile"] [libcoqrun]; dep ["ocaml"; "use_libcoqrun"; "link"; "native"] [libcoqrun]; flag ["ocaml"; "use_libcoqrun"; "link"; "byte"] (Sh Coq_config.coqrunbyteflags); (* we need to use a different ocamlc. For now we copy the rule *) if w32 then rule ".c.o" ~deps:("%.c"::c_headers) ~prod:"%.o" ~insert:`top (fun env _ -> let c = env "%.c" in let o = env "%.o" in Seq [Cmd (S [P w32ocamlc;cflags;A"-c";Px c]); mv (Filename.basename o) o]); (** VM: Generation of coq_jumbtbl.h and copcodes.ml from coq_instruct.h *) rule "coqinstrs" ~dep:coqinstrs ~prods:[coqjumps;copcodes] (fun _ _ -> let jmps = ref [] and ops = ref [] and i = ref 0 in let add_instr instr comma = if instr = "" then failwith "Empty" else begin jmps:=sprintf "&&coq_lbl_%s%s \n" instr comma :: !jmps; ops:=sprintf "let op%s = %d\n" instr !i :: !ops; incr i end in (** we recognize comma-separated uppercase instruction names *) let parse_line s = let b = Scanning.from_string s in try while true do bscanf b " %[A-Z0-9_]%[,]" add_instr done with _ -> () in List.iter parse_line (read_file coqinstrs); Seq [Echo (List.rev !jmps, coqjumps); Echo (List.rev !ops, copcodes)]); (** Generation of tolink.ml *) rule tolink ~deps:core_mllib ~prod:tolink (fun _ _ -> let cat s = String.concat " " (string_list_of_file s) in let core_mods = String.concat " " (List.map cat core_mllib) in let core_cmas = String.concat " " core_cma in Echo (["let copts = \"-cclib -lcoqrun\"\n"; "let core_libs = \"coq_config.cmo "^core_cmas^"\"\n"; "let core_objs = \"Coq_config "^core_mods^"\"\n"], tolink)); (** For windows, building coff object file from a .rc (for the icon) *) if w32 then rule ".rc.o" ~deps:["%.rc";"ide/coq.ico"] ~prod:"%.o" (fun env _ -> let rc = env "%.rc" and o = env "%.o" in Cmd (S [P w32res;A "--input-format";A "rc";A "--input";P rc; A "--output-format";A "coff";A "--output"; Px o])); (** Embed the Coq icon inside the windows version of Coqide *) if w32 then dep ["link"; "ocaml"; "program"; "ide"] [w32ico]; if w32 then flag ["link"; "ocaml"; "program"; "ide"] (P w32ico); (** Ealier we tried to make Coqide a console-free win32 app, but that was troublesome (unavailable stdout/stderr, issues with the stop button,...). If somebody really want to try again, the extra args to add are : [A "-ccopt"; A "-link -Wl,-subsystem,windows"] Other solution: use the mkwinapp tool. *) (** The mingw32-ocaml cross-compiler currently uses Filename.dir_sep="/". Let's tweak that... *) if w32 then begin ocaml_lib "tools/win32hack"; List.iter (fun (_,s,_) -> tag_file (s^".native") ["use_win32hack"]) all_binaries end; (** Coqtop *) let () = let fo = coqtop^".native" and fb = coqtop^".byte" in let depsall = (if w32 then [w32ico] else [])@[coqmktop_boot;libcoqrun] in let depso = "coq_config.cmx" :: core_cmxa in let depsb = "coq_config.cmo" :: core_cma in let w32flag = if not w32 then N else S ([A"-camlbin";A w32bin;A "-ccopt";P w32ico]) in if opt then rule fo ~prod:fo ~deps:(depsall@depso) ~insert:`top (cmd [P coqmktop_boot;w32flag;A"-boot";A"-opt";incl fo;camlp4incl;A"-o";Px fo]); rule fb ~prod:fb ~deps:(depsall@depsb) ~insert:`top (cmd [P coqmktop_boot;w32flag;A"-boot";A"-top";incl fb;camlp4incl;A"-o";Px fb]); in (** Coq files dependencies *) rule "coqdepready" ~stamp:"coqdepready" ~deps:coqdepdeps (fun _ _ -> Nop); rule ".v.d" ~prod:"%.v.depends" ~deps:["%.v";coqdep_boot;"coqdepready"] (fun env _ -> let v = env "%.v" and vd = env "%.v.depends" in (** NB: this relies on all .v files being already in _build. *) Cmd (S [P coqdep_boot;dep_dynlink;A"-slash";P v;Sh">";Px vd])); (** Coq files compilation *) let coq_build_dep f build = (** NB: this relies on coqdep producing a single Makefile line for one .v file, with some specific shape "f.vo ...: f.v deps.vo ..." *) let src = f^".v" in let depends = f^".v.depends" in let rec get_deps keep = function | [] -> [] | d::deps when d = src -> get_deps keep deps | d::deps when keep -> [d] :: get_deps keep deps | d::deps -> get_deps (String.contains d ':') deps in let d = get_deps false (string_list_of_file depends) in List.iter Outcome.ignore_good (build d) in let coq_v_rule d init = let bootflag = if init then A"-nois" else N in let gendep = if init then coqtopbest else initialcoq in rule (d^".v.vo") ~prods:[d^"%.vo";d^"%.glob"] ~deps:[gendep;d^"%.v";d^"%.v.depends"] (fun env build -> let f = env (d^"%") in coq_build_dep f build; Cmd (S [P coqtopbest;A"-boot";bootflag;A"-compile";Px f])) in coq_v_rule "theories/Init/" true; coq_v_rule "" false; (** Initial state *) rule "initial.coq" ~prod:initialcoq ~deps:(makeinitial::init_vo) (cmd [P coqtopbest;A"-boot";A"-batch";A"-nois";A"-notop";A"-silent"; A"-l";P makeinitial; A"-outputstate";Px initialcoq]); (** Generation of _plugin_mod.ml files *) rule "_mod.ml" ~prod:"%_plugin_mod.ml" ~dep:"%_plugin.mllib" (fun env _ -> let line s = "let _ = Mltop.add_known_module \""^s^"\"\n" in let mods = string_list_of_file (env "%_plugin.mllib") @ [Filename.basename (env "%_plugin")] in Echo (List.map line mods, env "%_plugin_mod.ml")); (** Rule for native dynlinkable plugins *) rule ".cmxa.cmxs" ~prod:"%.cmxs" ~dep:"%.cmxa" (fun env _ -> let cmxs = Px (env "%.cmxs") and cmxa = P (env "%.cmxa") in if os5fix then Cmd (S [A"../dev/ocamlopt_shared_os5fix.sh"; !Options.ocamlopt; cmxs]) else Cmd (S [!Options.ocamlopt;A"-linkall";A"-shared";A"-o";cmxs;cmxa])); (** Generation of NMake.v from NMake_gen.ml *) rule "NMake" ~prod:nmake ~dep:nmakegen (cmd [ocaml;P nmakegen;Sh ">";Px nmake]); end (** Registration of our rules (after the standard ones) *) let _ = dispatch begin function | After_rules -> initial_actions (); extra_rules () | _ -> () end (** TODO / Remarques: * Apres un premier build, le second prend du temps, meme cached: 1 min 25 pour les 2662 targets en cache. Etonnement, refaire coqtop.byte ne prend que ~4s, au lieu des ~40s pour coqtop.opt. A comprendre ... * Parallelisation: vraiment pas top *) coq-8.4pl4/coq-win32.itarget0000644000175000017500000000004712326224777014737 0ustar stephstephbinariesopt plugins/pluginsdyn.otarget coq-8.4pl4/coq.itarget0000644000175000017500000000033712326224777014001 0ustar stephsteph# NB: for the moment we start with bytecode compilation # for early error detection in .ml binariesbyte plugins/pluginsbyte.otarget binariesopt plugins/pluginsopt.otarget theories/theories.otarget plugins/pluginsvo.otarget coq-8.4pl4/INSTALL0000644000175000017500000003074212326224777012672 0ustar stephsteph INSTALLATION PROCEDURES FOR THE COQ V8.4 SYSTEM ----------------------------------------------- WHAT DO YOU NEED ? ================== Coq is designed to work on computers equipped with a POSIX (Unix or a clone) operating system. It also works under Microsoft Windows (see INSTALL.win); for a precompiled MacOS X package, see INSTALL.macosx. Coq is known to be actively used under GNU/Linux (i386, amd64 and ppc) and FreeBSD. Automated tests are run under many, many different architectures under GNU/Linux. Naturally, Coq will run faster on an architecture where OCaml can compile to native code, rather than only bytecode. At time of writing, that is IA32, PowerPC, AMD64, Alpha, Sparc, Mips, IA64, HPPA and StrongArm. See http://caml.inria.fr/ocaml/portability.en.html for details. Your OS may already contain Coq under the form of a precompiled package or ready-to-compile port. In this case, and if the supplied version suits you, follow the usual procedure for your OS to install it. E.g.: - Debian GNU/Linux (or Debian GNU/k*BSD or ...): aptitude install coq - Gentoo GNU/Linux: emerge sci-mathematics/coq - Mandriva GNU/Linux: urpmi coq Should you need or prefer to compile Coq V8.4 yourself, you need: - Objective Caml version 3.11.2 or later (available at http://caml.inria.fr/) - Camlp5 (version <= 4.08, or 5.* transitional) - GNU Make version 3.81 or later ( available at http://www.gnu.org/software/make/, but also a standard or optional add-on part to most Unices and Unix clones, sometimes under the name "gmake". If a new enough version is not included in your system, nor easily available as an add-on, this should get you a working make: #Download it (wget is an example, use your favourite FTP or HTTP client) wget http://ftp.gnu.org/pub/gnu/make/make-3.81.tar.bz2 bzip2 -cd make-3.81.tar.bz2 | tar x #If you don't have bzip2, you can download the gzipped version instead. cd make-3.81 ./configure --prefix=${HOME} make install Then, make sure that ${HOME}/bin is first in your $PATH. ) - a C compiler - for Coqide, the Lablgtk development files, and the GTK libraries, see INSTALL.ide for more details By FTP, Coq comes as a single compressed tar-file. You have probably already decompressed it if you are reading this document. QUICK INSTALLATION PROCEDURE. ============================= 1. ./configure 2. make world 3. make install (you may need superuser rights) 4. make clean INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). ================================================= 1- Check that you have the Objective Caml compiler version 3.11.2 (or later) installed on your computer and that "ocamlmktop" and "ocamlc" (or its native code version "ocamlc.opt") lie in a directory which is present in your $PATH environment variable. To get Coq in native-code, (it runs 4 to 10 times faster than bytecode, but it takes more time to get compiled and the binary is bigger), you will also need the "ocamlopt" (or its native code version "ocamlopt.opt") command. 2- Check that you have Camlp4 installed on your computer and that the command "camlp4" lies in a directory which is present in your $PATH environment variable path. (You need Camlp4 in both bytecode and native versions if your platform supports it). Note: in the latest ocaml distributions, camlp4 comes with ocaml so you do not have to check this point anymore. 3- The uncompression and un-tarring of the distribution file gave birth to a directory named "coq-8.xx". You can rename this directory and put it wherever you want. Just keep in mind that you will need some spare space during the compilation (reckon on about 50 Mb of disk space for the whole system in native-code compilation). Once installed, the binaries take about 14 Mb, and the library about 9 Mb. 4- First you need to configure the system. It is done automatically with the command: ./configure The "configure" script will ask you for directories where to put the Coq binaries, standard library, man pages, etc. It will propose you some default values. For a list of options accepted by the "configure" script, run "./configure -help". The main options accepted are: -prefix Binaries, library, man pages and Emacs mode will be respectively installed in /bin, /lib/coq, /man and /lib/emacs/site-lisp -bindir (default: /usr/local/bin) Directory where the binaries will be installed -libdir (default: /usr/local/lib/coq) Directory where the Coq standard library will be installed -mandir (default: /usr/local/man) Directory where the Coq manual pages will be installed -emacslib (default: /usr/local/lib/emacs/site-lisp) Directory where the Coq Emacs mode will be installed -arch (default is the result of the command "arch") An arbitrary architecture name for your machine (useful when compiling Coq on two different architectures for which the result of "arch" is the same, e.g. Sun OS and Solaris) -local Compile Coq to run in its source directory. The installation (step 6) is not necessary in that case. -opt Use the ocamlc.opt compiler instead of ocamlc (and ocamlopt.opt compiler instead of ocamlopt). Makes compilation faster (recommended). -browser Use to open an URL in a browser. %s must appear in , and will be replaced by the URL. 5- Still in the root directory, do make world to compile Coq in Objective Caml bytecode (and native-code if supported). This will compile the entire system. This phase can take more or less time, depending on your architecture and is fairly verbose. 6- You can now install the Coq system. Executables, libraries, manual pages and emacs mode are copied in some standard places of your system, defined at configuration time (step 3). Just do umask 022 make install Of course, you may need superuser rights to do that. To use the Coq emacs mode you also need to put the following lines in you .emacs file: (setq auto-mode-alist (cons '("\\.v$" . coq-mode) auto-mode-alist)) (autoload 'coq-mode "coq" "Major mode for editing Coq vernacular." t) 7- You can now clean all the sources. (You can even erase them.) make clean INSTALLATION PROCEDURE FOR ADVANCED USERS. ========================================== If you wish to write tactics (and that really means that you belong to advanced users!) you *must* keep the Coq sources, without cleaning them. Therefore, to avoid a duplication of binaries and library, it is not necessary to do the installation step (6- above). You just have to tell it at configuration step (4- above) with the option -local : ./configure -local Then compile the sources as described in step 5 above. The resulting binaries will reside in the subdirectory bin/. If you want to compile the sources for debugging (i.e. with the option -g of the Caml compiler) then add the -debug option at configuration step : ./configure -debug and then compile the sources (step 5). Then you must make a Coq toplevel including your own tactics, which must be compiled with -g, with coqmktop. See the chapter 16 of the Coq Reference Manual for details about how to use coqmktop and the Objective Caml debugger with Coq. THE AVAILABLE COMMANDS. ======================= There are two Coq commands: coqtop The Coq toplevel coqc The Coq compiler There are actually two binaries for the interactive system, coqtop.byte and coqtop.opt (respectively bytecode and native code versions of Coq). coqtop is a link to the fastest version, i.e. coqtop.opt if any, and coqtop.byte otherwise. coqc also invokes the fastest version of Coq. Options -opt and -byte to coqtop and coqc selects a particular binary. * `coqtop' launches Coq in the interactive mode. The default state (see the "-inputstate" option) is `initial.coq', which contains some basic logical definitions, the associated parsing and printing rules, and the following tactic modules: Equality, Tauto, Inv, EAuto and Refine. * `coqc' allows compilation of Coq files directly from the command line. To compile a file foo.v, do: coqc foo.v It will produce a file foo.vo, that you can now load through the Coq command "Require". A detailed description of these commands and of their options is given in the Reference Manual (which you can get by FTP, in the doc/ directory, or read online on http://coq.inria.fr/doc/) and in the corresponding manual pages. There is also a tutorial and a FAQ; see http://coq.inria.fr/doc1-eng.html COMMON PROBLEMS. ================ * On some sites, when running `./configure', `pwd' returned a path which is not valid from another machine (it may look like "/tmp_mnt/foo/...") and, as a consequence, you won't be able to run coqtop or coqc. The solution is to give the correct value, with ./configure -src * The `make install' procedure uses mkdirhier, a program that may not be present on certain systems. To fix that, try to replace mkdirhier with mkdir -p * See also section on dynamically loaded libraries. COMPILING FOR DIFFERENT ARCHITECTURES. ====================================== This section explains how to compile Coq for several architecture, sharing the same sources. The important fact is that some files are architecture dependent (.cmx, .o and executable files for instance) but others are not (.cmo and .vo). Consequently, you can : o save some time during compilation by not cleaning the architecture independent files; o save some space during installation by sharing the Coq standard library (which is fully architecture independent). So, in order to compile Coq for a new architecture, proceed as follows: * Omit step 7 above and clean only the architecture dependent files: it is done automatically with the command make archclean * Configure the system for the new architecture: ./configure You can specify the same directory for the standard library but you MUST specify a different directory for the binaries (of course). * Compile and install the system as described in steps 5 and 6 above. MOVING BINARIES OR LIBRARY. =========================== If you move the binaries or the library, Coq will be "lost". Running "coqtop" would then return an error message of the kind: Error during initialization : Error: Can't find file initial.coq on loadpath If you really have (or want) to move the binaries or the library, then you have to indicate their new places to Coq, using the options -bindir (for the binaries directory) and -libdir (for the standard library directory) : coqtop -bindir -libdir See also next section. DYNAMICALLY LOADED LIBRARIES FOR BYTECODE EXECUTABLES. ====================================================== Some bytecode executables of Coq use the OCaml runtime, which dynamically loads a shared library (.so or .dll). When it is not installed properly, you can get an error message of this kind: Fatal error: cannot load shared library dllcoqrun Reason: dllcoqrun.so: cannot open shared object file: No such file or directory In this case, you need either: - to set the CAML_LD_LIBRARY_PATH environment variable to point to the directory where dllcoqrun.so is; this is suitable when you want to run the command a limited number of times in a controlled environment (e.g. during compilation of binary packages); - install dllcoqrun.so in a location listed in the file ld.conf that is in the directory of the standard library of OCaml; - recompile your bytecode executables after reconfiguring the location of of the shared library: ./configure -coqrunbyteflags "-dllib -lcoqrun -dllpath " ... where is the directory where the dllcoqrun.so is installed; - (not recommended) compile bytecode executables with a custom OCaml runtime by using: ./configure -custom ... be aware that stripping executables generated this way, or performing other executable-specific operations, will make them useless. coq-8.4pl4/Makefile.build0000644000175000017500000007772512326224777014413 0ustar stephsteph####################################################################### # v # The Coq Proof Assistant / The Coq Development Team # # $@ ## then the target file will be created even if cmd has failed. ## Hence relaunching make will go further, as make thinks the target has been ## done ok. To avoid this, we use the following macro: TOTARGET = > "$@" || (RV=$$?; rm -f "$@"; exit $${RV}) ########################################################################### # Compilation option for .c files ########################################################################### CINCLUDES= -I $(CAMLHLIB) # libcoqrun.a, dllcoqrun.so # NB: We used to do a ranlib after ocamlmklib, but it seems that # ocamlmklib is already doing it $(LIBCOQRUN): kernel/byterun/coq_jumptbl.h $(BYTERUN) cd $(dir $(LIBCOQRUN)) && \ $(OCAMLMKLIB) -oc $(COQRUN) $(foreach u,$(BYTERUN),$(notdir $(u))) #coq_jumptbl.h is required only if you have GCC 2.0 or later kernel/byterun/coq_jumptbl.h : kernel/byterun/coq_instruct.h sed -n -e '/^ /s/ \([A-Z]\)/ \&\&coq_lbl_\1/gp' \ -e '/^}/q' $< $(TOTARGET) kernel/copcodes.ml: kernel/byterun/coq_instruct.h sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' $< | \ awk -f kernel/make-opcodes $(TOTARGET) ########################################################################### # Main targets (coqmktop, coqtop.opt, coqtop.byte) ########################################################################### ## In Win32, cygwin provides an emulation of ln -s, but this emulation ## won't work outside of cygwin shell (i.e. typically in a Sys.command). ## So we just forget about it, and do a simple copy. ifeq ($(ARCH),win32) LN:=cp -f else LN:=ln -sf endif .PHONY: coqbinaries coq coqlib coqlight states coqbinaries:: ${COQBINARIES} ${CSDPCERT} ${FAKEIDE} coq: coqlib tools coqbinaries coqlib:: theories plugins coqlight: theories-light tools coqbinaries states:: states/initial.coq $(COQTOPOPT): $(BESTCOQMKTOP) $(LINKCMX) $(LIBCOQRUN) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(BESTCOQMKTOP) -boot -opt $(BAREOPTFLAGS) -o $@ $(STRIP) $@ $(COQTOPBYTE): $(BESTCOQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(BESTCOQMKTOP) -boot -top $(BAREBYTEFLAGS) -o $@ $(COQTOPEXE): $(ORDER_ONLY_SEP) $(BESTCOQTOP) cd bin && $(LN) coqtop.$(BEST)$(EXE) coqtop$(EXE) LOCALCHKLIBS:=$(addprefix -I , $(CHKSRCDIRS) ) CHKLIBS:=$(LOCALCHKLIBS) -I $(MYCAMLP4LIB) CHKBYTEFLAGS:=$(CHKLIBS) $(CAMLDEBUG) $(USERFLAGS) CHKOPTFLAGS:=$(CHKLIBS) $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) $(CHICKENOPT): checker/check.cmxa checker/main.ml $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) $(CHKOPTFLAGS) -o $@ $(SYSCMXA) $^ $(STRIP) $@ $(CHICKENBYTE): checker/check.cma checker/main.ml $(SHOW)'OCAMLC -o $@' $(HIDE)$(OCAMLC) $(CHKBYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ $(SYSCMA) $^ $(CHICKEN): $(ORDER_ONLY_SEP) $(BESTCHICKEN) cd bin && $(LN) coqchk.$(BEST)$(EXE) coqchk$(EXE) # coqmktop $(COQMKTOPBYTE): $(COQMKTOPCMO) $(SHOW)'OCAMLC -o $@' $(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ $(SYSCMA) $^ $(OSDEPLIBS) $(COQMKTOPOPT): $(COQMKTOPCMO:.cmo=.cmx) $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ $(SYSCMXA) $^ $(OSDEPLIBS) $(STRIP) $@ $(COQMKTOP): $(ORDER_ONLY_SEP) $(BESTCOQMKTOP) cd bin && $(LN) coqmktop.$(BEST)$(EXE) coqmktop$(EXE) scripts/tolink.ml: Makefile.build Makefile.common $(SHOW)"ECHO... >" $@ $(HIDE)echo "let copts = \"-cclib -lcoqrun\"" > $@ $(HIDE)echo "let core_libs = \""$(LINKCMO)"\"" >> $@ $(HIDE)echo "let core_objs = \""$(OBJSMOD)"\"" >> $@ # coqc $(COQCBYTE): $(COQCCMO) | $(COQTOPBYTE) $(SHOW)'OCAMLC -o $@' $(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ $(SYSCMA) $^ $(OSDEPLIBS) $(COQCOPT): $(COQCCMO:.cmo=.cmx) | $(COQTOPOPT) $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ $(SYSCMXA) $^ $(OSDEPLIBS) $(STRIP) $@ $(COQC): $(ORDER_ONLY_SEP) $(BESTCOQC) cd bin && $(LN) coqc.$(BEST)$(EXE) coqc$(EXE) # target for libraries %.cma: | %.mllib.d $(SHOW)'OCAMLC -a -o $@' $(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $^ %.cmxa: | %.mllib.d $(SHOW)'OCAMLOPT -a -o $@' $(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $^ # For the checker, different flags may be used checker/check.cma: | checker/check.mllib.d $(SHOW)'OCAMLC -a -o $@' $(HIDE)$(OCAMLC) $(CHKBYTEFLAGS) -a -o $@ $^ checker/check.cmxa: | checker/check.mllib.d $(SHOW)'OCAMLOPT -a -o $@' $(HIDE)$(OCAMLOPT) $(CHKOPTFLAGS) -a -o $@ $^ ########################################################################### # Csdp to micromega special targets ########################################################################### plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMO:.cmo=$(BESTOBJ)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,nums unix) ########################################################################### # CoqIde special targets ########################################################################### .PHONY: coqide coqide-binaries coqide-no coqide-byte coqide-opt coqide-files # target to build CoqIde coqide:: coqide-files coqide-binaries states COQIDEFLAGS=-thread $(COQIDEINCLUDES) .SUFFIXES:.vo IDEFILES=ide/coq.png ide/coqide-gtk2rc ide/mac_default_accel_map coqide-binaries: coqide-$(HASCOQIDE) coqide-no: coqide-byte: $(COQIDEBYTE) $(COQIDE) coqide-opt: $(COQIDEBYTE) $(COQIDEOPT) $(COQIDE) coqide-files: $(IDEFILES) $(COQIDEOPT): $(LINKIDEOPT) | $(COQTOPOPT) $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ unix.cmxa threads.cmxa \ lablgtk.cmxa $(IDEOPTFLAGS) gtkThread.cmx str.cmxa $(LINKIDEOPT) $(STRIP) $@ $(COQIDEBYTE): $(LINKIDE) | $(COQTOPBYTE) $(SHOW)'OCAMLC -o $@' $(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ unix.cma threads.cma lablgtk.cma gtkThread.cmo\ str.cma $(COQRUNBYTEFLAGS) $(LINKIDE) $(COQIDE): cd bin && $(LN) coqide.$(HASCOQIDE)$(EXE) coqide$(EXE) # install targets .PHONY: install-coqide install-ide-no install-ide-byte install-ide-opt .PHONY: install-ide-files install-ide-info install-im install-coqide:: install-ide-$(HASCOQIDE) install-ide-files install-ide-info install-ide-no: install-ide-byte: $(MKDIR) $(FULLBINDIR) $(INSTALLBIN) $(COQIDEBYTE) $(FULLBINDIR) $(INSTALLSH) $(FULLCOQLIB) $(IDECMA) \ $(foreach lib,$(IDECMA:.cma=_MLLIB_DEPENDENCIES),$(addsuffix .cmi,$($(lib)))) cd $(FULLBINDIR) && $(LN) coqide.byte$(EXE) coqide$(EXE) install-ide-opt: $(MKDIR) $(FULLBINDIR) $(INSTALLBIN) $(COQIDEOPT) $(FULLBINDIR) $(INSTALLSH) $(FULLCOQLIB) $(IDECMA) $(IDECMA:.cma=.cmxa) $(IDECMA:.cma=.a) \ $(foreach lib,$(IDECMA:.cma=_MLLIB_DEPENDENCIES),$(addsuffix .cmi,$($(lib)))) cd $(FULLBINDIR) && $(LN) coqide.opt$(EXE) coqide$(EXE) install-ide-files: $(MKDIR) $(FULLDATADIR) $(INSTALLLIB) ide/coq.png $(FULLDATADIR) $(MKDIR) $(FULLCONFIGDIR) $(INSTALLLIB) ide/coqide-gtk2rc $(FULLCONFIGDIR) if [ $(IDEOPTINT) = QUARTZ ] ; then $(INSTALLLIB) ide/mac_default_accel_map $(FULLCONFIGDIR)/coqide.keys ; fi install-ide-info: $(MKDIR) $(FULLDOCDIR) $(INSTALLLIB) ide/FAQ $(FULLDOCDIR)/FAQ-CoqIde ########################################################################### # tests ########################################################################### .PHONY: validate check test-suite $(ALLSTDLIB).v VALIDOPTS=-silent -o -m validate:: $(BESTCHICKEN) $(ALLVO) $(SHOW)'COQCHK ' $(HIDE)$(BESTCHICKEN) -boot $(VALIDOPTS) $(ALLMODS) $(ALLSTDLIB).v: $(SHOW)'MAKE $(notdir $@)' $(HIDE)echo "Require $(ALLMODS)." > $@ MAKE_TSOPTS=-C test-suite -s BEST=$(BEST) VERBOSE=$(VERBOSE) check:: validate test-suite test-suite: world $(ALLSTDLIB).v $(MAKE) $(MAKE_TSOPTS) clean $(MAKE) $(MAKE_TSOPTS) all $(HIDE)if grep -F 'Error!' test-suite/summary.log ; then false; fi ################################################################## # partial targets: 1) core ML parts ################################################################## .PHONY: lib kernel byterun library proofs tactics interp parsing pretyping .PHONY: highparsing toplevel hightactics lib: lib/lib.cma kernel: kernel/kernel.cma byterun: $(BYTERUN) library: library/library.cma proofs: proofs/proofs.cma tactics: tactics/tactics.cma interp: interp/interp.cma parsing: parsing/parsing.cma pretyping: pretyping/pretyping.cma highparsing: parsing/highparsing.cma toplevel: toplevel/toplevel.cma hightactics: tactics/hightactics.cma ########################################################################### # 2) theories and plugins files ########################################################################### .PHONY: init theories theories-light .PHONY: logic arith bool narith zarith qarith lists strings sets .PHONY: fsets relations wellfounded reals setoids sorting numbers noreal init: $(INITVO) theories: $(THEORIESVO) theories-light: $(THEORIESLIGHTVO) logic: $(LOGICVO) arith: $(ARITHVO) bool: $(BOOLVO) narith: $(NARITHVO) zarith: $(ZARITHVO) qarith: $(QARITHVO) lists: $(LISTSVO) strings: $(STRINGSVO) sets: $(SETSVO) fsets: $(FSETSVO) relations: $(RELATIONSVO) wellfounded: $(WELLFOUNDEDVO) reals: $(REALSVO) setoids: $(SETOIDSVO) sorting: $(SORTINGVO) numbers: $(NUMBERSVO) unicode: $(UNICODEVO) classes: $(CLASSESVO) program: $(PROGRAMVO) structures: $(STRUCTURESVO) vectors: $(VECTORSVO) noreal: logic arith bool zarith qarith lists sets fsets relations \ wellfounded setoids sorting ########################################################################### # 3) plugins ########################################################################### .PHONY: plugins omega micromega ring setoid_ring nsatz xml extraction .PHONY: field fourier funind cc subtac rtauto pluginsopt plugins: $(PLUGINSVO) omega: $(OMEGAVO) $(OMEGACMA) $(ROMEGAVO) $(ROMEGACMA) micromega: $(MICROMEGAVO) $(MICROMEGACMA) $(CSDPCERT) ring: $(RINGVO) $(RINGCMA) setoid_ring: $(NEWRINGVO) $(NEWRINGCMA) nsatz: $(NSATZVO) $(NSATZCMA) xml: $(XMLVO) $(XMLCMA) extraction: $(EXTRACTIONCMA) field: $(FIELDVO) $(FIELDCMA) fourier: $(FOURIERVO) $(FOURIERCMA) funind: $(FUNINDCMA) $(FUNINDVO) cc: $(CCVO) $(CCCMA) subtac: $(SUBTACCMA) rtauto: $(RTAUTOVO) $(RTAUTOCMA) pluginsopt: $(PLUGINSOPT) ########################################################################### # rules to make theories, plugins and states ########################################################################### states/initial.coq: states/MakeInitial.v $(INITVO) $(VO_TOOLS_STRICT) | states/MakeInitial.v.d $(VO_TOOLS_ORDER_ONLY) $(SHOW)'BUILD $@' $(HIDE)$(BOOTCOQTOP) -batch -notop -silent -nois -load-vernac-source states/MakeInitial.v -outputstate states/initial.coq theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_STRICT) | theories/Init/%.v.d $(VO_TOOLS_ORDER_ONLY) $(SHOW)'COQC -nois $<' $(HIDE)rm -f theories/Init/$*.glob $(HIDE)$(BOOTCOQC) theories/Init/$* -nois theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_gen.ml $(OCAML) $< $(TOTARGET) ########################################################################### # tools ########################################################################### .PHONY: printers tools printers: $(DEBUGPRINTERS) tools:: $(TOOLS) $(DEBUGPRINTERS) $(COQDEPBOOT) # coqdep_boot : a basic version of coqdep, with almost no dependencies. # Here it is important to mention .ml files instead of .cmo in order # to avoid using implicit rules and hence .ml.d files that would need # coqdep_boot. COQDEPBOOTSRC:= \ tools/coqdep_lexer.mli tools/coqdep_lexer.ml \ tools/coqdep_common.mli tools/coqdep_common.ml \ tools/coqdep_boot.ml $(COQDEPBOOT): $(COQDEPBOOTSRC) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -I tools, unix) # the full coqdep $(COQDEP): $(COQDEPCMO:.cmo=$(BESTOBJ)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD)) $(GALLINA): $(addsuffix $(BESTOBJ), tools/gallina_lexer tools/gallina) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,) $(COQMAKEFILE): $(addsuffix $(BESTOBJ),config/coq_config ide/minilib ide/project_file tools/coq_makefile) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,str unix) $(COQTEX): tools/coq_tex$(BESTOBJ) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,str) $(COQWC): tools/coqwc$(BESTOBJ) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,) $(COQDOC): $(COQDOCCMO:.cmo=$(BESTOBJ)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,str unix) # fake_ide : for debugging or test-suite purpose, a fake ide simulating # a connection to coqtop -ideslave $(FAKEIDE): lib/xml_lexer$(BESTOBJ) lib/xml_parser$(BESTOBJ) lib/xml_utils$(BESTOBJ) toplevel/ide_intf$(BESTOBJ) tools/fake_ide$(BESTOBJ) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,unix) # Special rule for the compatibility-with-camlp5 extension for camlp4 ifeq ($(CAMLP4),camlp4) tools/compat5.cmo: tools/compat5.mlp $(OCAMLC) -c -I $(MYCAMLP4LIB) -pp '$(CAMLP4O) -impl' -impl $< tools/compat5b.cmo: tools/compat5b.mlp $(OCAMLC) -c -I $(MYCAMLP4LIB) -pp '$(CAMLP4O) -impl' -impl $< else tools/compat5.cmo: tools/compat5.ml $(OCAMLC) -c $< tools/compat5b.cmo: tools/compat5b.ml $(OCAMLC) -c $< endif ########################################################################### # Installation ########################################################################### #These variables are intended to be set by the caller to make #COQINSTALLPREFIX= #OLDROOT= # Can be changed for a local installation (to make packages). # You must NOT put a "/" at the end (Cygnus for win32 does not like "//"). ifdef COQINSTALLPREFIX FULLBINDIR=$(BINDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) FULLCOQLIB=$(COQLIBINSTALL:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) FULLCONFIGDIR=$(CONFIGDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) FULLDATADIR=$(DATADIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) FULLMANDIR=$(MANDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) FULLEMACSLIB=$(EMACSLIB:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) FULLCOQDOCDIR=$(COQDOCDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) FULLDOCDIR=$(DOCDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) else FULLBINDIR=$(BINDIR) FULLCOQLIB=$(COQLIBINSTALL) FULLCONFIGDIR=$(CONFIGDIR) FULLDATADIR=$(DATADIR) FULLMANDIR=$(MANDIR) FULLEMACSLIB=$(EMACSLIB) FULLCOQDOCDIR=$(COQDOCDIR) FULLDOCDIR=$(DOCDIR) endif .PHONY: install-coq install-coqlight install-binaries install-byte install-opt .PHONY: install-tools install-library install-library-light .PHONY: install-coq-info install-coq-manpages install-emacs install-latex install-coq: install-binaries install-library install-coq-info install-coqlight: install-binaries install-library-light install-binaries:: install-$(BEST) install-tools install-byte:: $(MKDIR) $(FULLBINDIR) $(INSTALLBIN) $(COQMKTOP) $(COQC) $(COQTOPBYTE) $(CHICKEN) $(FULLBINDIR) cd $(FULLBINDIR); $(LN) coqtop.byte$(EXE) coqtop$(EXE); $(LN) coqchk.byte$(EXE) coqchk$(EXE) install-opt:: $(MKDIR) $(FULLBINDIR) $(INSTALLBIN) $(COQMKTOP) $(COQC) $(COQTOPBYTE) $(COQTOPOPT) $(CHICKEN) $(CHICKENOPT) $(FULLBINDIR) cd $(FULLBINDIR); $(LN) coqtop.opt$(EXE) coqtop$(EXE); $(LN) coqchk.opt$(EXE) coqchk$(EXE) install-tools:: $(MKDIR) $(FULLBINDIR) # recopie des fichiers de style pour coqide $(MKDIR) $(FULLCOQLIB)/tools/coqdoc touch $(FULLCOQLIB)/tools/coqdoc/coqdoc.sty $(FULLCOQLIB)/tools/coqdoc/coqdoc.css # to have the mode according to umask (bug #1715) $(INSTALLLIB) tools/coqdoc/coqdoc.css tools/coqdoc/coqdoc.sty $(FULLCOQLIB)/tools/coqdoc $(INSTALLBIN) $(TOOLS) $(FULLBINDIR) # The list of .cmi to install, including the ones obtained # from .mli without .ml, and the ones obtained from .ml without .mli INSTALLCMI = $(sort \ $(CONFIG:.cmo=.cmi) \ $(filter-out checker/% ide/% tools/%, $(MLIFILES:.mli=.cmi)) \ $(foreach lib,$(CORECMA) $(PLUGINSCMA), $(addsuffix .cmi,$($(lib:.cma=_MLLIB_DEPENDENCIES))))) install-library: $(MKDIR) $(FULLCOQLIB) $(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS) $(MKDIR) $(FULLCOQLIB)/states $(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states $(MKDIR) $(FULLCOQLIB)/user-contrib ifneq ($(COQRUNBYTEFLAGS),"-custom") $(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB) endif $(INSTALLSH) $(FULLCOQLIB) $(CONFIG) $(LINKCMO) $(GRAMMARCMA) $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMI) ifeq ($(BEST),opt) $(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB) $(INSTALLSH) $(FULLCOQLIB) $(CONFIG:.cmo=.cmx) $(CONFIG:.cmo=.o) $(LINKCMO:.cma=.cmxa) $(LINKCMO:.cma=.a) $(PLUGINSOPT) endif # csdpcert is not meant to be directly called by the user; we install # it with libraries -$(MKDIR) $(FULLCOQLIB)/plugins/micromega $(INSTALLBIN) $(CSDPCERT) $(FULLCOQLIB)/plugins/micromega rm -f $(FULLCOQLIB)/revision -$(INSTALLLIB) revision $(FULLCOQLIB) install-library-light: $(MKDIR) $(FULLCOQLIB) $(INSTALLSH) $(FULLCOQLIB) $(LIBFILESLIGHT) $(INITPLUGINS) $(MKDIR) $(FULLCOQLIB)/states $(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states rm -f $(FULLCOQLIB)/revision -$(INSTALLLIB) revision $(FULLCOQLIB) ifeq ($(BEST),opt) $(INSTALLSH) $(FULLCOQLIB) $(INITPLUGINSOPT) endif install-coq-info: install-coq-manpages install-emacs install-latex install-coq-manpages: $(MKDIR) $(FULLMANDIR)/man1 $(INSTALLLIB) $(MANPAGES) $(FULLMANDIR)/man1 install-emacs: $(MKDIR) $(FULLEMACSLIB) $(INSTALLLIB) tools/coq-db.el tools/coq-font-lock.el tools/coq-syntax.el tools/coq.el tools/coq-inferior.el $(FULLEMACSLIB) # command to update TeX' kpathsea database #UPDATETEX = $(MKTEXLSR) /usr/share/texmf /var/spool/texmf $(BASETEXDIR) > /dev/null install-latex: $(MKDIR) $(FULLCOQDOCDIR) $(INSTALLLIB) tools/coqdoc/coqdoc.sty $(FULLCOQDOCDIR) # -$(UPDATETEX) ########################################################################### # Documentation of the source code (using ocamldoc) ########################################################################### .PHONY: source-doc mli-doc ml-doc source-doc: mli-doc $(OCAMLDOCDIR)/coq.pdf $(OCAMLDOCDIR)/coq.tex:: $(DOCMLIS:.mli=.cmi) $(OCAMLDOC) -latex -rectypes -I $(MYCAMLP4LIB) $(MLINCLUDES)\ $(DOCMLIS) -t "Coq mlis documentation" \ -intro $(OCAMLDOCDIR)/docintro -o $@ mli-doc:: $(DOCMLIS:.mli=.cmi) $(OCAMLDOC) -html -rectypes -I $(MYCAMLP4LIB) $(MLINCLUDES)\ $(DOCMLIS) -d $(OCAMLDOCDIR)/html -colorize-code \ -t "Coq mlis documentation" -intro $(OCAMLDOCDIR)/docintro \ -css-style style.css %_dep.png: %.dot $(DOT) -Tpng $< -o $@ %_types.dot: %.mli $(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -dot-types -o $@ $< OCAMLDOC_MLLIBD = $(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ \ $(foreach lib,$(|:.mllib.d=_MLLIB_DEPENDENCIES),$(addsuffix .ml,$($(lib)))) %.dot: | %.mllib.d $(OCAMLDOC_MLLIBD) ml-doc: $(OCAMLDOC) -html -rectypes $(LOCALINCLUDES) -d $(SOURCEDOCDIR) $(MLSTATICFILES) parsing/parsing.dot : | parsing/parsing.mllib.d parsing/highparsing.mllib.d $(OCAMLDOC_MLLIBD) tactics/tactics.dot: | tactics/tactics.mllib.d tactics/hightactics.mllib.d $(OCAMLDOC_MLLIBD) %.dot: %.mli $(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $< $(OCAMLDOCDIR)/%.pdf: $(OCAMLDOCDIR)/%.tex (cd $(OCAMLDOCDIR) ; pdflatex $*.tex && pdflatex $*.tex) ########################################################################### ### Special rules ########################################################################### dev/printers.cma: | dev/printers.mllib.d $(SHOW)'Testing $@' $(HIDE)$(OCAMLC) $(BYTEFLAGS) $(SYSCMA) $^ -o test-printer @rm -f test-printer $(SHOW)'OCAMLC -a $@' $(HIDE)$(OCAMLC) $(BYTEFLAGS) $^ -linkall -a -o $@ parsing/grammar.cma: | parsing/grammar.mllib.d $(SHOW)'Testing $@' @touch test.ml4 $(HIDE)$(OCAMLC) $(BYTEFLAGS) -pp '$(CAMLP4O) -I $(CAMLLIB) $^ -impl' -impl test.ml4 -o test-grammar @rm -f test-grammar test.* $(SHOW)'OCAMLC -a $@' $(HIDE)$(OCAMLC) $(BYTEFLAGS) $^ -linkall -a -o $@ # toplevel/mltop.ml4 (ifdef Byte) ## NB: mltop.ml correspond to the byte version (and hence need no special rules) ## while the opt version is in mltop.optml. Since mltop.optml uses mltop.ml.d ## as dependency file, be sure to import the same modules in the different sections ## of the ml4 toplevel/mltop.cmx: toplevel/mltop.optml | toplevel/mltop.ml.d toplevel/mltop.ml4.d $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(OPTFLAGS) -c -impl $< -o $@ toplevel/mltop.ml: toplevel/mltop.ml4 config/Makefile # no camlp4deps here $(SHOW)'CAMLP4O $<' $(HIDE)$(CAMLP4O) $(PR_O) $(CAMLP4USE) -DByte -DHasDynlink -impl $< -o $@ toplevel/mltop.optml: toplevel/mltop.ml4 config/Makefile # no camlp4deps here $(SHOW)'CAMLP4O $<' $(HIDE)$(CAMLP4O) $(PR_O) $(CAMLP4USE) $(NATDYNLINKDEF) -impl $< -o $@ ide/coqide_main.ml: ide/coqide_main.ml4 $(SHOW)'CAMLP4O $<' $(HIDE)$(CAMLP4O) $(CAMLP4USE) -impl $< -o $@ ide/coqide_main_opt.ml: ide/coqide_main.ml4 config/Makefile # no camlp4deps here $(SHOW)'CAMLP4O $<' $(HIDE)$(CAMLP4O) $(CAMLP4USE) -D$(IDEOPTINT) -impl $< -o $@ # pretty printing of the revision number when compiling a checked out # source tree .PHONY: revision revision: $(SHOW)'CHECK revision' $(HIDE)rm -f revision.new ifeq ($(CHECKEDOUT),svn) $(HIDE)set -e; \ if test -x "`which svn`"; then \ export LC_ALL=C;\ svn info . | sed -ne '/URL/s/.*\/\([^\/]\{1,\}\)/\1/p' > revision.new; \ svn info . | sed -ne '/Revision/s/Revision: \([0-9]\{1,\}\)/\1/p'>> revision.new; \ fi endif ifeq ($(CHECKEDOUT),gnuarch) $(HIDE)set -e; \ if test -x "`which tla`"; then \ LANG=C; export LANG; \ tla tree-version > revision.new ; \ tla tree-revision | sed -ne 's|.*--||p' >> revision.new ; \ fi endif ifeq ($(CHECKEDOUT),git) $(HIDE)set -e; \ if test -x "`which git`"; then \ LANG=C; export LANG; \ GIT_BRANCH=$$(git branch -a | sed -ne '/^\* /s/^\* \(.*\)/\1/p'); \ GIT_HOST=$$(hostname); \ GIT_PATH=$$(pwd); \ (echo "$${GIT_HOST}:$${GIT_PATH},$${GIT_BRANCH}") > revision.new; \ (echo "$$(git log -1 --pretty='format:%H')") >> revision.new; \ fi endif $(HIDE)set -e; \ if test -e revision.new; then \ if test -e revision; then \ if test "`cat revision`" = "`cat revision.new`" ; then \ rm -f revision.new; \ else \ mv -f revision.new revision; \ fi; \ else \ mv -f revision.new revision; \ fi \ fi ########################################################################### # Default rules ########################################################################### ## Three flavor of flags: checker/* ide/* and normal files COND_BYTEFLAGS= \ $(if $(filter checker/%,$<), $(CHKBYTEFLAGS), \ $(if $(filter ide/%,$<),$(COQIDEFLAGS),) $(BYTEFLAGS)) COND_OPTFLAGS= \ $(if $(filter checker/%,$<), $(CHKOPTFLAGS), \ $(if $(filter ide/%,$<),$(COQIDEFLAGS),) $(OPTFLAGS)) %.o: %.c $(SHOW)'OCAMLC $<' $(HIDE)cd $(dir $<) && $(OCAMLC) -ccopt "$(CFLAGS)" -c $(notdir $<) %.cmi: %.mli | %.mli.d $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< %.cmo: %.ml | %.ml.d $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< ## NB: for the moment ocamlopt erases and recreates .cmi if there's no .mli around. ## This can lead to nasty things with make -j. To avoid that: ## 1) We make .cmx always depend on .cmi ## 2) This .cmi will be created from the .mli, or trigger the compilation of the ## .cmo if there's no .mli (see rule below about MLWITHOUTMLI) ## 3) We tell ocamlopt to use the .cmi as the interface source file. With this ## hack, everything goes as if there is a .mli, and the .cmi is preserved ## and the .cmx is checked with respect to this .cmi HACKMLI = $(if $(wildcard $ $@' $(HIDE)sed -e "s/\([^ ]\{1,\}\)/let _=Mltop.add_known_module\"\1\" /g" $< > $@ $(HIDE)echo "let _=Mltop.add_known_module\"$(notdir $*)\"" >> $@ # NB: compatibility modules for camlp4: # - tools/compat5.cmo changes GEXTEND into EXTEND. Safe, always loaded # - tools/compat5b.cmo changes EXTEND into EXTEND Gram. Interact badly with # syntax such that VERNAC EXTEND, we only load it for a few files via camlp4deps %.ml: %.ml4 | %.ml4.d tools/compat5.cmo tools/compat5b.cmo $(SHOW)'CAMLP4O $<' $(HIDE)\ DEPS=$(CAMLP4DEPS); \ if ls $${DEPS} > /dev/null 2>&1; then \ $(CAMLP4O) $(PR_O) -I $(CAMLLIB) tools/compat5.cmo $${DEPS} $(CAMLP4USE) $(CAMLP4COMPAT) -impl $< -o $@; \ else echo $< : Dependency $${DEPS} not ready yet; false; fi %.vo %.glob: %.v states/initial.coq $(INITPLUGINSBEST) $(VO_TOOLS_STRICT) | %.v.d $(VO_TOOLS_ORDER_ONLY) $(SHOW)'COQC $<' $(HIDE)rm -f $*.glob $(HIDE)$(BOOTCOQC) $* ifdef VALIDATE $(SHOW)'COQCHK $(call vo_to_mod,$@)' $(HIDE)$(BESTCHICKEN) -boot -silent -norec $(call vo_to_mod,$@) \ || ( RV=$$?; rm -f "$@"; exit $${RV} ) endif ########################################################################### # Dependencies ########################################################################### # .ml4.d contains the dependencies to generate the .ml from the .ml4 # NOT to generate object code. %.ml4.d: $(D_DEPEND_BEFORE_SRC) %.ml4 $(SHOW)'CAMLP4DEPS $<' $(HIDE)echo "$*.ml: $(if $(NO_RECOMPILE_ML4),$(ORDER_ONLY_SEP)) $(CAMLP4DEPS)" $(TOTARGET) # We now use coqdep_boot to wrap around ocamldep -modules, since it is aware # of .ml4 files OCAMLDEP_NG = $(COQDEPBOOT) -mldep $(OCAMLDEP) checker/%.ml.d: $(D_DEPEND_BEFORE_SRC) checker/%.ml $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES) $(SHOW)'OCAMLDEP $<' $(HIDE)$(OCAMLDEP_NG) -slash $(LOCALCHKLIBS) "$<" $(TOTARGET) checker/%.mli.d: $(D_DEPEND_BEFORE_SRC) checker/%.mli $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES) $(SHOW)'OCAMLDEP $<' $(HIDE)$(OCAMLDEP_NG) -slash $(LOCALCHKLIBS) "$<" $(TOTARGET) %.ml.d: $(D_DEPEND_BEFORE_SRC) %.ml $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES) $(SHOW)'OCAMLDEP $<' $(HIDE)$(OCAMLDEP_NG) $(DEPFLAGS) "$<" $(TOTARGET) %.mli.d: $(D_DEPEND_BEFORE_SRC) %.mli $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES) $(SHOW)'OCAMLDEP $<' $(HIDE)$(OCAMLDEP_NG) $(DEPFLAGS) "$<" $(TOTARGET) checker/%.mllib.d: $(D_DEPEND_BEFORE_SRC) checker/%.mllib $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES) $(SHOW)'COQDEP $<' $(HIDE)$(COQDEPBOOT) -slash -I checker -c "$<" $(TOTARGET) %.mllib.d: $(D_DEPEND_BEFORE_SRC) %.mllib $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES) $(SHOW)'COQDEP $<' $(HIDE)$(COQDEPBOOT) -slash -I kernel -I tools/coqdoc -c "$<" $(TOTARGET) %.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENVFILES) $(SHOW)'COQDEP $<' $(HIDE)$(COQDEPBOOT) $(DEPNATDYN) -slash "$<" $(TOTARGET) %_stubs.c.d: $(D_DEPEND_BEFORE_SRC) %_stubs.c $(D_DEPEND_AFTER_SRC) $(SHOW)'CCDEP $<' $(HIDE)echo "$@ $(@:.c.d=.o): $(@:.c.d=.c)" > $@ %.c.d: $(D_DEPEND_BEFORE_SRC) %.c $(D_DEPEND_AFTER_SRC) $(GENHFILES) $(SHOW)'CCDEP $<' $(HIDE)$(OCAMLC) -ccopt "-MM -MQ $@ -MQ $(<:.c=.o) -isystem $(CAMLHLIB)" $< $(TOTARGET) ########################################################################### # this sets up developper supporting stuff ########################################################################### .PHONY: devel devel: $(DEBUGPRINTERS) ########################################################################### # For emacs: # Local Variables: # mode: makefile # End: coq-8.4pl4/man/0000755000175000017500000000000012365131026012371 5ustar stephstephcoq-8.4pl4/man/coqc.10000644000175000017500000000167312326224777013424 0ustar stephsteph.TH COQ 1 "April 25, 2001" .SH NAME coqc \- The Coq Proof Assistant compiler .SH SYNOPSIS .B coqc [ .B general \ Coq \ options ] .I file .SH DESCRIPTION .B coqc is the batch compiler for the Coq Proof Assistant. The options are basically the same as coqtop(1). .IR file.v \& is the vernacular file to compile. .IR file \& must be formed only with the characters `a` to `Z`, `0`-`9` or `_` and must begin with a letter. The compiler produces an object file .IR file.vo \&. For interactive use of Coq, see .BR coqtop(1). .SH OPTIONS .B coqc is a script that simply runs .B coqtop with option .B \-compile it accepts the same options as .B coqtop. .TP .BI \-image \ bin use .I bin as underlying .B coqtop instead of the default one. .TP .BI \-verbose print the compiled file on the standard output. .SH SEE ALSO .BR coqtop (1), .BR coq_makefile (1), .BR coqdep (1). .br .I The Coq Reference Manual. .I The Coq web site: http://coq.inria.fr coq-8.4pl4/man/coqtop.opt.10000644000175000017500000000061012326224777014573 0ustar stephsteph.TH COQ 1 "April 25, 2001" .SH NAME coqtop.opt \- The native-code Coq toplevel .SH SYNOPSIS .B coqopt.opt [ .B options ] [ .I file ] .SH DESCRIPTION .B coqopt.opt is the native-code version of Coq. It should not be called directly, but only by .B coqtop and .B coqc .SH SEE ALSO .BR coqtop (1), .BR coqc (1). .br .I The Coq Reference Manual. .I The Coq web site: http://coq.inria.fr coq-8.4pl4/man/coq-tex.10000644000175000017500000000600312326224777014047 0ustar stephsteph.TH COQ-TEX 1 "29 March 1995" .SH NAME coq-tex \- Process Coq phrases embedded in LaTeX files .SH SYNOPSIS .B coq-tex [ .BI \-o \ output-file ] [ .BI \-n \ line-width ] [ .BI \-image \ coq-image ] [ .B \-w ] [ .B \-v ] [ .B \-sl ] [ .B \-hrule ] [ .B \-small ] .I input-file ... .SH DESCRIPTION The .B coq-tex filter extracts Coq phrases embedded in LaTeX files, evaluates them, and insert the outcome of the evaluation after each phrase. Three LaTeX environments are provided to include Coq code in the input files: .TP .B coq_example The phrases between \\begin{coq_example} and \\end{coq_example} are evaluated and copied into the output file. Each phrase is followed by the response of the toplevel loop. .TP .B coq_example* The phrases between \\begin{coq_example*} and \\end{coq_example*} are evaluated and copied into the output file. The responses of the toplevel loop are discarded. .TP .B coq_eval The phrases between \\begin{coq_eval} and \\end{coq_eval} are silently evaluated. They are not copied into the output file, and the responses of the toplevel loop are discarded. .PP The resulting LaTeX code is stored in the file .IR file \&.v.tex if the input file has a name of the form .IR file \&.tex, otherwise the name of the output file is the name of the input file with `.v.tex' appended. The files produced by .B coq-tex can be directly processed by LaTeX. Both the Coq phrases and the toplevel output are typeset in typewriter font. .SH OPTIONS .TP .BI \-o \ output-file Specify the name of a file where the LaTeX output is to be stored. A dash `\-' causes the LaTeX output to be printed on standard output. .TP .BI \-n \ line-width Set the line width. The default is 72 characters. The responses of the toplevel loop are folded if they are longer than the line width. No folding is performed on the Coq input text. .TP .BI \-image \ coq-image Cause the file .IR coq-image to be executed to evaluate the Coq phrases. By default, this is the command .IR coqtop without specifying any path which is used to evaluate the Coq phrases. .TP .B \-w Cause lines to be folded on a space character whenever possible, avoiding word cuts in the output. By default, folding occurs at the line width, regardless of word cuts. .TP .B \-v Verbose mode. Prints the Coq answers on the standard output. Useful to detect errors in Coq phrases. .TP .B \-sl Slanted mode. The Coq answers are written in a slanted font. .TP .B \-hrule Horizontal lines mode. The Coq parts are written between two horizontal lines. .TP .B \-small Small font mode. The Coq parts are written in a smaller font. .SH CAVEATS The \\begin... and \\end... phrases must sit on a line by themselves, with no characters before the backslash or after the closing brace. Each Coq phrase must be terminated by `.' at the end of a line. Blank space is accepted between `.' and the newline, but any other character will cause coq-tex to ignore the end of the phrase, resulting in an incorrect shuffling of the responses into the phrases. (The responses ``lag behind''.) .SH SEE ALSO .B coqtop (1). coq-8.4pl4/man/coqtop.byte.10000644000175000017500000000060512326224777014740 0ustar stephsteph.TH COQ 1 "April 25, 2001" .SH NAME coqtop.byte \- The bytecode Coq toplevel .SH SYNOPSIS .B coqtop.byte [ .B options ] [ .I file ] .SH DESCRIPTION .B coqopt.byte is the bytecode version of Coq. It should not be called directly, but only by .B coqtop and .B coqc .SH SEE ALSO .BR coqtop (1), .BR coqc (1). .br .I The Coq Reference Manual. .I The Coq web site: http://coq.inria.fr coq-8.4pl4/man/coqide.10000644000175000017500000000501412326224777013734 0ustar stephsteph.TH COQIDE 1 "July 16, 2004" .SH NAME coqide \- The Coq Proof Assistant graphical interface .SH SYNOPSIS .B coqide [ .B options ] .SH DESCRIPTION .B coqide is a gtk graphical interface for the Coq proof assistant. For command-line-oriented use of Coq, see .BR coqtop (1) ; for batch-oriented use of Coq, see .BR coqc (1). .SH OPTIONS .TP .B \-h Show the complete list of options accepted by .BR coqide . .TP .BI \-I\ dir ,\ \-include\ dir Add directory dir in the include path. .TP .BI \-R\ dir\ coqdir Recursively map physical .I dir to logical .IR coqdir . .TP .B \-src Add source directories in the include path. .TP .BI \-is\ f ,\ \-inputstate\ f Read state from .IR f .coq. .TP .B \-nois Start with an empty state. .TP .BI \-outputstate\ f Write state in file .IR f .coq. .TP .BI \-load\-ml\-object\ f Load ML object file .IR f . .TP .BI \-load\-ml\-source\ f Load ML file .IR f . .TP .BI \-l\ f ,\ \-load\-vernac\-source\ f Load Coq file .IR f .v (Load .IR f .). .TP .BI \-lv\ f ,\ \-load\-vernac\-source\-verbose\ f Load Coq file .IR f .v (Load Verbose .IR f .). .TP .BI \-load\-vernac\-object\ f Load Coq object file .IR f .vo. .TP .BI \-require\ f Load Coq object file .IR f .vo and import it (Require .IR f .). .TP .BI \-compile\ f Compile Coq file .IR f .v (implies .BR \-batch ). .TP .BI \-compile\-verbose\ f Verbosely compile Coq file .IR f .v (implies .BR -batch ). .TP .B \-opt Run the native-code version of Coq or Coq_SearchIsos. .TP .B \-byte Run the bytecode version of Coq or Coq_SearchIsos. .TP .B \-where Print Coq's standard library location and exit. .TP .B -v Print Coq version and exit. .TP .B \-q Skip loading of rcfile. .TP .BI \-init\-file\ f Set the rcfile to .IR f . .TP .B \-batch Batch mode (exits just after arguments parsing). .TP .B \-boot Boot mode (implies .B \-q and .BR \-batch ). .TP .B \-emacs Tells Coq it is executed under Emacs. .TP .BI \-dump\-glob\ f Dump globalizations in file .I f (to be used by .BR coqdoc (1)). .TP .B \-impredicative\-set Set sort Set impredicative. .TP .B \-dont\-load\-proofs Don't load opaque proofs in memory. .TP .B \-xml Export XML files either to the hierarchy rooted in the directory .B COQ_XML_LIBRARY_ROOT (if set) or to stdout (if unset). .SH SEE ALSO .BR coqc (1), .BR coqtop (1), .BR coq-tex (1), .BR coqdep (1). .br .I The Coq Reference Manual, .I The Coq web site: http://coq.inria.fr, .I /usr/share/doc/coqide/FAQ. .SH AUTHOR This manual page was written by Samuel Mimram , for the Debian project (but may be used by others). coq-8.4pl4/man/coq_makefile.10000644000175000017500000000072212326224777015110 0ustar stephsteph.TH COQ 1 "April 25, 2001" .SH NAME coq_makefile \- The Coq Proof Assistant makefile generator .SH SYNOPSIS .B coq_makefile [ .B arguments ] .SH DESCRIPTION .B coq_makefile is a makefile generator for Coq proof developments. .SH OPTIONS .TP .BI \-h Will give you a description of the whole list of options of coq_makefile. .SH SEE ALSO .BR coqtop (1), .BR coqtc (1), .BR coqdep (1). .br .I The Coq Reference Manual. .I The Coq web site: http://coq.inria.fr coq-8.4pl4/man/coqtop.10000644000175000017500000000537512326224777014007 0ustar stephsteph.TH COQ 1 "October 11, 2006" .SH NAME coqtop \- The Coq Proof Assistant toplevel system .SH SYNOPSIS .B coqtop [ .B options ] .SH DESCRIPTION .B coqtop is the toplevel system of Coq, for interactive use. It reads phrases on the standard input, and prints results on the standard output. For batch-oriented use of Coq, see .BR coqc(1). .SH OPTIONS .TP .B \-h, \-\-help Help. Will give you the complete list of options accepted by coqtop. .TP .BI \-I \ dir, \ \-\-include \ dir add directory .I dir in the include path .TP .BI \-R \ dir\ coqdir recursively map physical .I dir to logical .I coqdir .TP .BI \-top \ coqdir set the toplevel name to be .I coqdir instead of Top .TP .BI \-inputstate \ filename, \ \-is \ filename read state from file .I filename.coq .TP .B \-nois start with an empty initial state .TP .BI \-outputstate filename write state in file .I filename.coq .TP .BI \-load\-ml\-object \ filename load ML object file .I filenname .TP .BI \-load\-ml\-source \ filename load ML file .I filename .TP .BI \-load\-vernac\-source \ filename, \ \-l \ filename load Coq file .I filename.v (Load filename.) .TP .BI \-load\-vernac\-source\-verbose \ filename, \ \-lv \ filename load verbosely Coq file .I filename.v (Load Verbose filename.) .TP .BI \-load\-vernac\-object \ filename load Coq object file .I filename.vo .TP .BI \-require \ filename load Coq object file .I filename.vo and import it (Require Import filename.) .TP .BI \-compile \ filename compile Coq file .I filename.v (implies .B \-batch ) .TP .BI \-compile\-verbose \ filename verbosely compile Coq file .I filename.v (implies .B \-batch ) .TP .B \-opt run the native\-code version of Coq .TP .B \-byte run the bytecode version of Coq .TP .B \-where print Coq's standard library location and exit .TP .B \-v print Coq version and exit .TP .B \-q skip loading of rcfile .TP .BI \-init\-file \ filename set the rcfile to .I filename .TP .B \-batch batch mode (exits just after arguments parsing) .TP .B \-boot boot mode (implies .B \-q and .B \-batch ) .TP .B \-emacs tells Coq it is executed under Emacs .TP .BI \-dump\-glob \ filename dump globalizations in file f (to be used by .B coqdoc(1) ) .TP .BI \-with\-geoproof \ (yes|no) to (de)activate special functions for Geoproof within Coqide (default is .I yes ) .TP .B \-impredicative\-set set sort Set impredicative .TP .B \-dont\-load\-proofs don't load opaque proofs in memory .TP .B \-xml export XML files either to the hierarchy rooted in the directory $COQ_XML_LIBRARY_ROOT (if set) or to stdout (if unset) .TP .B \-quality improve the legibility of the proof terms produced by some tactics .SH SEE ALSO .BR coqc (1), .BR coq-tex (1), .BR coqdep (1). .br .I The Coq Reference Manual. .I The Coq web site: http://coq.inria.fr coq-8.4pl4/man/coqchk.10000644000175000017500000000352012326224777013740 0ustar stephsteph.TH COQ 1 "July 7, 201" .SH NAME coqchk \- The Coq Proof Checker compiled libraries verifier .SH SYNOPSIS .B coqchk [ .B options ] .I modules .SH DESCRIPTION .B coqchk is the standalone checker of compiled libraries (.vo files produced by coqc) for the Coq Proof Assistant. See the Reference Manual for more information. It returns with exit code 0 if all the requested tasks succeeded. A non-zero return code means that something went wrong: some library was not found, corrupted content, type-checking failure, etc. .IR modules \& is a list of modules to be checked. Modules can be referred to by a short or qualified name. .SH OPTIONS .TP .BI \-I \ dir, \ \-\-include \ dir add directory .I dir in the include path .TP .BI \-R \ dir\ coqdir recursively map physical .I dir to logical .I coqdir .TP .BI \-silent makes coqchk less verbose. .TP .BI \-admit \ module tag the specified module and all its dependencies as trusted, and will not be rechecked, unless explicitly requested by other options. .TP .BI \-norec \ module specifies that the given module shall be verified without requesting to check its dependencies. .TP .BI \-m,\ \-\-memory displays a summary of the memory used by the checker. .TP .BI \-o,\ \-\-output\-context displays a summary of the logical content that have been verified: assumptions and usage of impredicativity. .TP .BI \-impredicative\-set allows the checker to accept libraries that have been compiled with this flag. .TP .BI \-v print coqchk version and exit. .TP .BI \-coqlib \ dir overrides the default location of the standard library. .TP .BI \-where print coqchk standard library location and exit. .TP .BI \-h,\ \-\-help print list of options .SH SEE ALSO .BR coqtop (1), .BR coqc (1), .BR coq_makefile (1), .BR coqdep (1). .br .I The Coq Reference Manual. .I The Coq web site: http://coq.inria.fr coq-8.4pl4/man/coqmktop.10000644000175000017500000000207312326224777014327 0ustar stephsteph.TH COQ 1 "April 25, 2001" .SH NAME coqmktop \- The Coq Proof Assistant user-tactics linker .SH SYNOPSIS .B coqmktop [ .I options ] .I files .SH DESCRIPTION .B coqmktop builds a new Coq toplevel extended with user-tactics. .IR files \& are the Objective Caml object or library files (i.e. with suffix .cmo, .cmx, .cma or .cmxa) to link with the Coq system. The linker produces an executable Coq toplevel which can be called directly or through coqc(1), using the \-image option. .SH OPTIONS .TP .BI \-h Help. List the available options. .TP .BI \-srcdir \ dir Specify where the Coq source files are .TP .BI \-o \ exec\-file Specify the name of the resulting toplevel .TP .B \-opt Compile in native code .TP .B \-full Link high level tactics .TP .B \-top Build Coq on a ocaml toplevel (incompatible with .BR \-opt ) .TP .BI \-R \ dir Specify recursively directories for Ocaml .TP .B \-v8 Link with V8 grammar .SH SEE ALSO .BR coqtop (1), .BR ocamlmktop (1). .BR ocamlc (1). .BR ocamlopt (1). .br .I The Coq Reference Manual. .I The Coq web site: http://coq.inria.fr coq-8.4pl4/man/gallina.10000644000175000017500000000223612326224777014102 0ustar stephsteph.TH COQ 1 "29 March 1995" "Coq tools" .SH NAME gallina \- extracts specification from Coq vernacular files .SH SYNOPSIS .B gallina [ .BI \- ] [ .BI \-stdout ] [ .BI \-nocomments ] .I file ... .SH DESCRIPTION .B gallina takes Coq files as arguments and builds the corresponding specification files. The Coq file .IR foo.v \& gives bearth to the specification file .IR foo.g. \& The suffix '.g' stands for Gallina. For that purpose, gallina removes all commands that follow a "Theorem", "Lemma", "Fact", "Remark" or "Goal" statement until it reaches a command "Abort.", "Save.", "Qed.", "Defined." or "Proof <...>.". It also removes every "Hint", "Syntax", "Immediate" or "Transparent" command. Files without the .v suffix are ignored. .SH OPTIONS .TP .BI \-stdout Prints the result on standard output. .TP .BI \- Coq source is taken on standard input. The result is printed on standard output. .TP .BI \-nocomments Comments are removed in the *.g file. .SH NOTES Nested comments are correctly handled. In particular, every command "Save." or "Abort." in a comment is not taken into account. .SH BUGS Please report any bug to .B coq@pauillac.inria.fr coq-8.4pl4/man/coq-interface.10000644000175000017500000000114012326224777015204 0ustar stephsteph.TH COQ 1 "April 25, 2001" .SH NAME coq\-interface \- Customized Coq toplevel to make user interfaces .SH SYNOPSIS .B coq-interface [ .B options ] .SH DESCRIPTION .B coq-interface is a Coq customized toplevel system for Coq containing some modules useful for the graphical interface. This program is not for the casual user. .SH OPTIONS .TP .B \-h Help. Will give you the complete list of options accepted by coq-interface (the same as coqtop). .SH SEE ALSO .BR coqc (1), .BR coqdep (1), .BR coqtop (1), .BR coq\-parser (1). .br .I The Coq Reference Manual. .I The Coq web site: http://coq.inria.fr coq-8.4pl4/man/coqdoc.10000644000175000017500000001072412326224777013744 0ustar stephsteph.TH coqdoc 1 "April, 2006" .SH NAME coqdoc \- A documentation tool for the Coq proof assistant .SH SYNOPSIS .B coqdoc [ .B options ] .B files .SH DESCRIPTION .B coqdoc is a documentation tool for the Coq proof assistant. It creates LaTeX or HTML documents from a set of Coq files. See the Coq reference manual for documentation (url below). .SH OPTIONS .SS Overall options .TP .BI \-h Help. Will give you the complete list of options accepted by coqdoc. .TP .B \-\-html Select a HTML output. .TP .B \-\-latex Select a LATEX output. .TP .B \-\-dvi Select a DVI output. .TP .B \-\-ps Select a PostScript output. .TP .B \-\-texmacs Select a TeXmacs output. .TP .B \-\-stdout Redirect the output to stdout .TP .BI \-o \ file, \-\-output \ file Redirect the output into the file .I file. .TP .BI \-d \ dir, \ \-\-directory \ dir Output files into directory .I dir instead of current directory (option \-d does not change the filename specified with option \-o, if any). .TP .B \-s, \ \-\-short Do not insert titles for the files. The default behavior is to insert a title like ``Library Foo'' for each file. .TP .BI \-t \ string, \ \-\-title \ string Set the document title. .TP .B \-\-body\-only Suppress the header and trailer of the final document. Thus, you can insert the resulting document into a larger one. .TP .BI \-p \ string, \ \-\-preamble \ string Insert some material in the LATEX preamble, right before \\begin{document} (meaningless with \-html). .TP .BI \-\-vernac\-file \ file, \ \-\-tex\-file \ file Considers the file `file' respectively as a .v (or .g) file or a .tex file. .TP .BI \-\-files\-from \ file Read file names to process in file `file' as if they were given on the command line. Useful for program sources split in several directories. .TP .B \-q, \ \-\-quiet Be quiet. Do not print anything except errors. .TP .B \-h, \ \-\-help Give a short summary of the options and exit. .TP .B \-v, \ \-\-version Print the version and exit. .SS Index options Default behavior is to build an index, for the HTML output only, into index.html. .TP .B \-\-no\-index Do not output the index. .TP .B \-\-multi\-index Generate one page for each category and each letter in the index, together with a top page index.html. .SS Table of contents option .TP .B \-toc, \ \-\-table\-of\-contents Insert a table of contents. For a LATEX output, it inserts a \\tableofcontents at the beginning of the document. For a HTML output, it builds a table of contents into toc.html. .SS Hyperlinks options .TP .B \-\-glob\-from \ file Make references using Coq globalizations from file file. (Such globalizations are obtained with Coq option \-dump\-glob). .TP .B \-\-no\-externals Do not insert links to the Coq standard library. .TP .BI \-\-external \ url \ libroot Set base URL for the external library whose root prefix is libroot. .TP .BI \-\-coqlib \ url Set base URL for the Coq standard library (default is http://coq.inria.fr/library/). .TP .BI \-\-coqlib_path \ dir Set the base path where the Coq files are installed, especially style files coqdoc.sty and coqdoc.css. .TP .BI \-R \ dir \ coqdir Map physical directory dir to Coq logical directory coqdir (similarly to Coq option \-R). .B Note: option \-R only has effect on the files following it on the command line, so you will probably need to put this option first. .SS Contents options .TP .B \-g, \ \-\-gallina Do not print proofs. .TP .B \-l, \ \-\-light Light mode. Suppress proofs (as with \-g) and the following commands: * [Recursive] Tactic Definition * Hint / Hints * Require * Transparent / Opaque * Implicit Argument / Implicits * Section / Variable / Hypothesis / End The behavior of options \-g and \-l can be locally overridden using the (* begin show *) ... (* end show *) environment (see above). .SS Language options Default behavior is to assume ASCII 7 bits input files. .TP .B \-latin1, \ \-\-latin1 Select ISO-8859-1 input files. It is equivalent to \-\-inputenc latin1 \-\-charset iso\-8859\-1. .TP .B \-utf8, \ \-\-utf8 Select UTF-8 (Unicode) input files. It is equivalent to \-\-inputenc utf8 \-\-charset utf\-8. LATEX UTF-8 support can be found at http://www.ctan.org/tex\-archive/macros/latex/contrib/supported/unicode/. .TP .BI \-\-inputenc \ string Give a LATEX input encoding, as an option to LATEX package inputenc. .TP .BI \-\-charset \ string Specify the HTML character set, to be inserted in the HTML header. .SH SEE ALSO .I The Coq Reference Manual from http://coq.inria.fr/ coq-8.4pl4/man/coq-parser.10000644000175000017500000000072312326224777014546 0ustar stephsteph.TH COQ 1 "April 25, 2001" .SH NAME coq\-parser \- Coq parser .SH SYNOPSIS .B coq\-parser [ .B options ] .SH DESCRIPTION .B parser is a program reading Coq proof developments and outputing them in the structured format given in the INRIA technical report RT154. This program is not for the casual user. .SH SEE ALSO .BR coq\-interface (1), .BR coqc (1), .BR coqtop (1), .BR coqdep (1). .br .I The Coq Reference Manual. .I The Coq web site: http://coq.inria.fr coq-8.4pl4/man/coqwc.10000644000175000017500000000112012326224777013576 0ustar stephsteph.TH COQ 1 "16 March 2004" "Coq tools" .SH NAME coqwc \- print the number of specification, proof and comment lines in Coq files .SH SYNOPSIS .B coqwc [ .BI \-p ] [ .BI \-s ] [ .BI \-r ] [ .BI \-e ] .I files ... .SH DESCRIPTION .B coqwc computes the number of specification lines, proof lines and comment lines in Coq files. .SH OPTIONS .TP .BI \-p Print the percentage of comments .TP .BI \-s Print only the number of specification lines .TP .BI \-r Print only the number of proof lines .TP .BI \-e Do not skip headers .SH BUGS Please report any bug to .B coq\-bugs@pauillac.inria.fr coq-8.4pl4/man/coqdep.10000644000175000017500000000700512326224777013745 0ustar stephsteph.TH COQ 1 "28 March 1995" "Coq tools" .SH NAME coqdep \- Compute inter-module dependencies for Coq and Caml programs .SH SYNOPSIS .B coqdep [ .BI \-w ] [ .BI \-I \ directory ] [ .BI \-coqlib \ directory ] [ .BI \-c ] [ .BI \-i ] [ .BI \-D ] [ .BI \-slash ] .I filename ... .I directory ... .SH DESCRIPTION .B coqdep compute inter-module dependencies for Coq and Caml programs, and prints the dependencies on the standard output in a format readable by make. When a directory is given as argument, it is recursively looked at. Dependencies of Coq modules are computed by looking at .IR Require \& commands (Require, Require Export, Require Import), .IR Declare \& .IR ML \& .IR Module \& commands and .IR Load \& commands. Dependencies relative to modules from the Coq library are not printed. Dependencies of Caml modules are computed by looking at .IR open \& directives and the dot notation .IR module.value \&. .SH OPTIONS .TP .BI \-c Prints the dependencies of Caml modules. (On Caml modules, the behaviour is exactly the same as ocamldep). .TP .BI \-w Prints a warning if a Coq command .IR Declare \& .IR ML \& .IR Module \& is incorrect. (For instance, you wrote `Declare ML Module "A".', but the module A contains #open "B"). The correct command is printed (see option \-D). The warning is printed on standard error. .TP .BI \-D This commands looks for every command .IR Declare \& .IR ML \& .IR Module \& of each Coq file given as argument and complete (if needed) the list of Caml modules. The new command is printed on the standard output. No dependency is computed with this option. .TP .BI \-slash Prints paths using a slash instead of the OS specific separator. This option is useful when developping under Cygwin. .TP .BI \-I \ directory The files .v .ml .mli of the directory .IR directory \& are taken into account during the calculus of dependencies, but their own dependencies are not printed. .TP .BI \-coqlib \ directory Indicates where is the Coq library. The default value has been determined at installation time, and therefore this option should not be used under normal circumstances. .SH SEE ALSO .BR ocamlc (1), .BR coqc (1), .BR make (1). .br .SH NOTES Lexers (for Coq and Caml) correctly handle nested comments and strings. The treatment of symbolic links is primitive. If two files have the same name, in two different directories, a warning is printed on standard error. There is no way to limit the scope of the recursive search for directories. .SH EXAMPLES .LP Consider the files (in the same directory): A.ml B.ml C.ml D.ml X.v Y.v and Z.v where .TP .BI \+ D.ml contains the commands `open A', `open B' and `type t = C.t' ; .TP .BI \+ Y.v contains the command `Require X' ; .TP .BI \+ Z.v contains the commands `Require X' and `Declare ML Module "D"'. .LP To get the dependencies of the Coq files: .IP .B example% coqdep \-I . *.v .RS .sp .5 .nf .B Z.vo: Z.v ./X.vo ./D.cmo .B Y.vo: Y.v ./X.vo .B X.vo: X.v .fi .RE .br .ne 7 .LP With a warning: .IP .B example% coqdep \-w \-I . *.v .RS .sp .5 .nf .B Z.vo: Z.v ./X.vo ./D.cmo .B Y.vo: Y.v ./X.vo .B X.vo: X.v ### Warning : In file Z.v, the ML modules declaration should be ### Declare ML Module "A" "B" "C" "D". .fi .RE .br .ne 7 .LP To get only the Caml dependencies: .IP .B example% coqdep \-c \-I . *.ml .RS .sp .5 .nf .B D.cmo: D.ml ./A.cmo ./B.cmo ./C.cmo .B D.cmx: D.ml ./A.cmx ./B.cmx ./C.cmx .B C.cmo: C.ml .B C.cmx: C.ml .B B.cmo: B.ml .B B.cmx: B.ml .B A.cmo: A.ml .B A.cmx: A.ml .fi .RE .br .ne 7 .SH BUGS Please report any bug to .B coq\-bugs@pauillac.inria.fr coq-8.4pl4/Makefile.doc0000644000175000017500000003165112326224777014045 0ustar stephsteph# Makefile for the Coq documentation # COQSRC needs to be set to a coq source repository # To compile documentation, you need the following tools: # Dvi: latex (latex2e), bibtex, makeindex # Pdf: pdflatex # Html: hevea (http://hevea.inria.fr) >= 1.05 ###################################################################### ### General rules ###################################################################### .PHONY: doc doc-html doc-pdf doc-ps refman refman-quick tutorial .PHONY: stdlib full-stdlib faq rectutorial refman-html-dir INDEXURLS:=doc/refman/html/index_urls.txt doc: refman faq tutorial rectutorial stdlib $(INDEXURLS) doc-html:\ doc/tutorial/Tutorial.v.html doc/refman/html/index.html \ doc/faq/html/index.html doc/stdlib/html/index.html doc/RecTutorial/RecTutorial.html doc-pdf:\ doc/tutorial/Tutorial.v.pdf doc/refman/Reference-Manual.pdf \ doc/faq/FAQ.v.pdf doc/stdlib/Library.pdf doc/RecTutorial/RecTutorial.pdf doc-ps:\ doc/tutorial/Tutorial.v.ps doc/refman/Reference-Manual.ps \ doc/faq/FAQ.v.ps doc/stdlib/Library.ps doc/RecTutorial/RecTutorial.ps refman: \ doc/refman/html/index.html doc/refman/Reference-Manual.ps doc/refman/Reference-Manual.pdf tutorial: \ doc/tutorial/Tutorial.v.html doc/tutorial/Tutorial.v.ps doc/tutorial/Tutorial.v.pdf stdlib: \ doc/stdlib/html/index.html doc/stdlib/Library.ps doc/stdlib/Library.pdf full-stdlib: \ doc/stdlib/html/index.html doc/stdlib/FullLibrary.ps doc/stdlib/FullLibrary.pdf faq: doc/faq/html/index.html doc/faq/FAQ.v.ps doc/faq/FAQ.v.pdf rectutorial: doc/RecTutorial/RecTutorial.html \ doc/RecTutorial/RecTutorial.ps doc/RecTutorial/RecTutorial.pdf ###################################################################### ### Implicit rules ###################################################################### ifdef QUICK %.v.tex: %.tex $(COQTEX) $(COQTEXOPTS) $< else %.v.tex: %.tex $(COQTEX) $(COQTOPEXE) $(PLUGINSVO) $(THEORIESVO) $(COQTEX) $(COQTEXOPTS) $< endif %.ps: %.dvi (cd `dirname $<`; dvips -q -o `basename $@` `basename $<`) ###################################################################### # Macros for filtering outputs ###################################################################### HIDEBIBTEXINFO=| grep -v "^A level-1 auxiliary file" SHOWMAKEINDEXERROR=egrep '^!! Input index error|^\*\* Input style error|^ --' # Empty subsection levels in faq are on purpose HEVEAFAQFILTER=2>&1 | grep -v "^Warning: List with no item" ###################################################################### # Common ###################################################################### ### Version doc/common/version.tex: config/Makefile printf '\\newcommand{\\coqversion}{$(VERSION)}' > doc/common/version.tex ###################################################################### # Reference Manual ###################################################################### ### Reference Manual (printable format) # The second LATEX compilation is necessary otherwise the pages of the index # are not correct (don't know why...) - BB doc/refman/Reference-Manual.dvi: $(REFMANFILES) doc/refman/Reference-Manual.tex @(cd doc/refman;\ $(LATEX) -interaction=batchmode Reference-Manual;\ $(BIBTEX) -terse Reference-Manual $(HIDEBIBTEXINFO);\ $(LATEX) -interaction=batchmode Reference-Manual > /dev/null;\ $(MAKEINDEX) -q Reference-Manual;\ $(SHOWMAKEINDEXERROR) Reference-Manual.ilg;\ $(MAKEINDEX) -q Reference-Manual.tacidx -o Reference-Manual.tacind;\ $(SHOWMAKEINDEXERROR) Reference-Manual.ilg;\ $(MAKEINDEX) -q Reference-Manual.comidx -o Reference-Manual.comind;\ $(SHOWMAKEINDEXERROR) Reference-Manual.ilg;\ $(MAKEINDEX) -q Reference-Manual.erridx -o Reference-Manual.errind;\ $(SHOWMAKEINDEXERROR) Reference-Manual.ilg;\ $(LATEX) -interaction=batchmode Reference-Manual > /dev/null;\ $(LATEX) -interaction=batchmode Reference-Manual > /dev/null;\ ../tools/show_latex_messages -no-overfull Reference-Manual.log) doc/refman/Reference-Manual.pdf: doc/refman/Reference-Manual.dvi (cd doc/refman;\ $(PDFLATEX) -interaction=batchmode Reference-Manual.tex;\ ../tools/show_latex_messages -no-overfull Reference-Manual.log) ### Reference Manual (browsable format) doc/refman/Reference-Manual.html: doc/refman/styles.hva doc/refman/headers.hva doc/refman/Reference-Manual.dvi # to ensure bbl file (cd doc/refman; BIBINPUTS=.: $(HEVEA) $(HEVEAOPTS) ./styles.hva ./Reference-Manual.tex) doc/refman/cover.html: doc/common/styles/html/$(HTMLSTYLE)/cover.html $(INSTALLLIB) $< doc/refman doc/refman/styles.hva: doc/common/styles/html/$(HTMLSTYLE)/styles.hva $(INSTALLLIB) $< doc/refman INDEXES:= doc/refman/html/command-index.html doc/refman/html/tactic-index.html ALLINDEXES:= doc/refman/html/index.html $(INDEXES) $(ALLINDEXES): refman-html-dir refman-html-dir: doc/refman/Reference-Manual.html $(REFMANPNGFILES) \ doc/refman/cover.html doc/refman/styles.hva doc/refman/index.html - rm -rf doc/refman/html $(MKDIR) doc/refman/html $(INSTALLLIB) $(REFMANPNGFILES) doc/refman/html (cd doc/refman/html; hacha -nolinks -tocbis -o toc.html ../styles.hva ../Reference-Manual.html) $(INSTALLLIB) doc/refman/cover.html doc/refman/html/index.html -$(INSTALLLIB) doc/common/styles/html/$(HTMLSTYLE)/*.css doc/refman/html refman-quick: (cd doc/refman;\ $(PDFLATEX) -interaction=batchmode Reference-Manual.tex;\ ../tools/show_latex_messages -no-overfull Reference-Manual.log && \ $(HEVEA) $(HEVEAOPTS) ./Reference-Manual.tex) ###################################################################### # Index file for CoqIDE ###################################################################### $(INDEXURLS): $(INDEXES) cat $< | grep li-indexenv | grep HREF | sed -e 's@.*\(.*\).*, .*@\1,\2@' > $@ ###################################################################### # Tutorial ###################################################################### doc/tutorial/Tutorial.v.dvi: $(DOCCOMMON) doc/tutorial/Tutorial.v.tex (cd doc/tutorial;\ $(LATEX) -interaction=batchmode Tutorial.v;\ ../tools/show_latex_messages Tutorial.v.log) doc/tutorial/Tutorial.v.pdf: $(DOCCOMMON) doc/tutorial/Tutorial.v.tex (cd doc/tutorial;\ $(PDFLATEX) -interaction=batchmode Tutorial.v.tex;\ ../tools/show_latex_messages Tutorial.v.log) doc/tutorial/Tutorial.v.html: $(DOCCOMMON) doc/tutorial/Tutorial.v.tex (cd doc/tutorial; $(HEVEA) $(HEVEAOPTS) Tutorial.v) ###################################################################### # FAQ ###################################################################### doc/faq/FAQ.v.dvi: doc/common/version.tex doc/common/title.tex doc/faq/FAQ.v.tex (cd doc/faq;\ $(LATEX) -interaction=batchmode FAQ.v;\ $(BIBTEX) -terse FAQ.v;\ $(LATEX) -interaction=batchmode FAQ.v > /dev/null;\ $(LATEX) -interaction=batchmode FAQ.v > /dev/null;\ ../tools/show_latex_messages FAQ.v.log) doc/faq/FAQ.v.pdf: doc/common/version.tex doc/common/title.tex doc/faq/FAQ.v.dvi doc/faq/axioms.png (cd doc/faq;\ $(PDFLATEX) -interaction=batchmode FAQ.v.tex;\ ../tools/show_latex_messages FAQ.v.log) doc/faq/FAQ.v.html: doc/faq/FAQ.v.dvi # to ensure FAQ.v.bbl (cd doc/faq; ($(HEVEA) $(HEVEAOPTS) FAQ.v.tex $(HEVEAFAQFILTER))) doc/faq/html/index.html: doc/faq/FAQ.v.html - rm -rf doc/faq/html $(MKDIR) doc/faq/html $(INSTALLLIB) doc/faq/interval_discr.v doc/faq/axioms.png doc/faq/html $(INSTALLLIB) doc/faq/FAQ.v.html doc/faq/html/index.html ###################################################################### # Standard library ###################################################################### ### Standard library (browsable html format) ifdef QUICK doc/stdlib/html/genindex.html: else doc/stdlib/html/genindex.html: | $(COQDOC) $(THEORIESVO) endif - rm -rf doc/stdlib/html $(MKDIR) doc/stdlib/html $(COQDOC) -q -d doc/stdlib/html --with-header doc/common/styles/html/$(HTMLSTYLE)/header.html --with-footer doc/common/styles/html/$(HTMLSTYLE)/footer.html --multi-index --html -g \ -R theories Coq $(THEORIESVO:.vo=.v) mv doc/stdlib/html/index.html doc/stdlib/html/genindex.html doc/stdlib/index-list.html: doc/stdlib/index-list.html.template doc/stdlib/make-library-index ./doc/stdlib/make-library-index doc/stdlib/index-list.html doc/stdlib/hidden-files doc/stdlib/html/index.html: doc/stdlib/html/genindex.html doc/stdlib/index-list.html cat doc/common/styles/html/$(HTMLSTYLE)/header.html doc/stdlib/index-list.html > $@ cat doc/common/styles/html/$(HTMLSTYLE)/footer.html >> $@ ### Standard library (light version, full version is definitely too big) ifdef QUICK doc/stdlib/Library.coqdoc.tex: else doc/stdlib/Library.coqdoc.tex: | $(COQDOC) $(THEORIESLIGHTVO) endif $(COQDOC) -q -boot --gallina --body-only --latex --stdout \ -R theories Coq $(THEORIESLIGHTVO:.vo=.v) >> $@ doc/stdlib/Library.dvi: $(DOCCOMMON) doc/stdlib/Library.coqdoc.tex doc/stdlib/Library.tex (cd doc/stdlib;\ $(LATEX) -interaction=batchmode Library;\ $(LATEX) -interaction=batchmode Library > /dev/null;\ ../tools/show_latex_messages -no-overfull Library.log) doc/stdlib/Library.pdf: $(DOCCOMMON) doc/stdlib/Library.coqdoc.tex doc/stdlib/Library.dvi (cd doc/stdlib;\ $(PDFLATEX) -interaction=batchmode Library;\ ../tools/show_latex_messages -no-overfull Library.log) ### Standard library (full version if you're crazy enouth to try) doc/stdlib/FullLibrary.tex: doc/stdlib/Library.tex sed -e 's/Library.coqdoc/FullLibrary.coqdoc/g;s/\\begin{document}/\\newcommand{\\textlambda}{\\ensuremath{\\lambda}}\\newcommand{\\textPi}{\\ensuremath{\\Pi}}\\begin{document}/' $< > $@ ifdef QUICK doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ -R theories Coq $(THEORIESVO:.vo=.v) > $@ sed -i.tmp -e 's///g' $@ && rm $@.tmp else doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) $(THEORIESVO) $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ -R theories Coq $(THEORIESVO:.vo=.v) > $@ sed -i.tmp -e 's///g' $@ && rm $@.tmp endif doc/stdlib/FullLibrary.dvi: $(DOCCOMMON) doc/stdlib/FullLibrary.coqdoc.tex doc/stdlib/FullLibrary.tex (cd doc/stdlib;\ $(LATEX) -interaction=batchmode FullLibrary;\ $(LATEX) -interaction=batchmode FullLibrary > /dev/null;\ ../tools/show_latex_messages -no-overfull FullLibrary.log) doc/stdlib/FullLibrary.pdf: $(DOCCOMMON) doc/stdlib/FullLibrary.coqdoc.tex doc/stdlib/FullLibrary.dvi (cd doc/stdlib;\ $(PDFLATEX) -interaction=batchmode FullLibrary;\ ../tools/show_latex_messages -no-overfull FullLibrary.log) ###################################################################### # Tutorial on inductive types ###################################################################### doc/RecTutorial/RecTutorial.dvi: doc/common/version.tex doc/common/title.tex doc/RecTutorial/RecTutorial.tex (cd doc/RecTutorial;\ $(LATEX) -interaction=batchmode RecTutorial;\ $(BIBTEX) -terse RecTutorial;\ $(LATEX) -interaction=batchmode RecTutorial > /dev/null;\ $(LATEX) -interaction=batchmode RecTutorial > /dev/null;\ ../tools/show_latex_messages RecTutorial.log) doc/RecTutorial/RecTutorial.pdf: doc/common/version.tex doc/common/title.tex doc/RecTutorial/RecTutorial.dvi (cd doc/RecTutorial;\ $(PDFLATEX) -interaction=batchmode RecTutorial.tex;\ ../tools/show_latex_messages RecTutorial.log) doc/RecTutorial/RecTutorial.html: doc/RecTutorial/RecTutorial.tex (cd doc/RecTutorial; $(HEVEA) $(HEVEAOPTS) RecTutorial) ###################################################################### # Install all documentation files ###################################################################### .PHONY: install-doc install-doc-meta install-doc-html install-doc-printable install-doc-index-urls install-doc: install-doc-meta install-doc-html install-doc-printable install-doc-index-urls install-doc-meta: $(MKDIR) $(FULLDOCDIR) $(INSTALLLIB) doc/LICENSE $(FULLDOCDIR)/LICENSE.doc install-doc-html: $(MKDIR) $(addprefix $(FULLDOCDIR)/html/, refman stdlib faq) $(INSTALLLIB) doc/refman/html/* $(FULLDOCDIR)/html/refman $(INSTALLLIB) doc/stdlib/html/* $(FULLDOCDIR)/html/stdlib $(INSTALLLIB) doc/RecTutorial/RecTutorial.html $(FULLDOCDIR)/html/RecTutorial.html $(INSTALLLIB) doc/faq/html/* $(FULLDOCDIR)/html/faq $(INSTALLLIB) doc/tutorial/Tutorial.v.html $(FULLDOCDIR)/html/Tutorial.html install-doc-printable: $(MKDIR) $(FULLDOCDIR)/ps $(FULLDOCDIR)/pdf $(INSTALLLIB) doc/refman/Reference-Manual.pdf \ doc/stdlib/Library.pdf $(FULLDOCDIR)/pdf $(INSTALLLIB) doc/refman/Reference-Manual.ps \ doc/stdlib/Library.ps $(FULLDOCDIR)/ps $(INSTALLLIB) doc/tutorial/Tutorial.v.pdf $(FULLDOCDIR)/pdf/Tutorial.pdf $(INSTALLLIB) doc/RecTutorial/RecTutorial.pdf $(FULLDOCDIR)/pdf/RecTutorial.pdf $(INSTALLLIB) doc/faq/FAQ.v.pdf $(FULLDOCDIR)/pdf/FAQ.pdf $(INSTALLLIB) doc/tutorial/Tutorial.v.ps $(FULLDOCDIR)/ps/Tutorial.ps $(INSTALLLIB) doc/RecTutorial/RecTutorial.ps $(FULLDOCDIR)/ps/RecTutorial.ps $(INSTALLLIB) doc/faq/FAQ.v.ps $(FULLDOCDIR)/ps/FAQ.ps install-doc-index-urls: $(MKDIR) $(FULLDOCDIR)/ps $(FULLDOCDIR)/pdf $(INSTALLLIB) $(INDEXURLS) \ $(FULLDOCDIR)/html/refman # For emacs: # Local Variables: # mode: makefile # End: coq-8.4pl4/Makefile.common0000644000175000017500000003014012326224777014560 0ustar stephsteph####################################################################### # v # The Coq Proof Assistant / The Coq Development Team # # id_ord i1 i2 | Axiom k1 , Axiom k2 -> cst_ord k1 k2 | Opaque k1 , Opaque k2 -> cst_ord k1 k2 | Variable _ , Axiom _ -> -1 | Axiom _ , Variable _ -> 1 | Opaque _ , _ -> -1 | _, Opaque _ -> 1 end module ContextObjectSet = Set.Make (OrderedContextObject) module ContextObjectMap = Map.Make (OrderedContextObject) (** For a constant c in a module sealed by an interface (M:T and not M<:T), [Global.lookup_constant] may return a [constant_body] without body. We fix this by looking in the implementation of the module *) let modcache = ref (MPmap.empty : structure_body MPmap.t) let rec search_mod_label lab = function | [] -> raise Not_found | (l,SFBmodule mb) :: _ when l = lab -> mb | _ :: fields -> search_mod_label lab fields let rec search_cst_label lab = function | [] -> raise Not_found | (l,SFBconst cb) :: _ when l = lab -> cb | _ :: fields -> search_cst_label lab fields let rec lookup_module_in_impl mp = try Global.lookup_module mp with Not_found -> (* The module we search might not be exported by its englobing module(s). We access the upper layer, and then do a manual search *) match mp with | MPfile _ | MPbound _ -> raise Not_found (* should have been found by [lookup_module] *) | MPdot (mp',lab') -> let fields = memoize_fields_of_mp mp' in search_mod_label lab' fields and memoize_fields_of_mp mp = try MPmap.find mp !modcache with Not_found -> let l = fields_of_mp mp in modcache := MPmap.add mp l !modcache; l and fields_of_mp mp = let mb = lookup_module_in_impl mp in let fields,inner_mp,subs = fields_of_mb empty_subst mb [] in let subs = if inner_mp = mp then subs else add_mp inner_mp mp mb.mod_delta subs in Modops.subst_signature subs fields and fields_of_mb subs mb args = let seb = match mb.mod_expr with | None -> mb.mod_type (* cf. Declare Module *) | Some seb -> seb in fields_of_seb subs mb.mod_mp seb args (* TODO: using [empty_delta_resolver] below in [fields_of_seb] is probably slightly incorrect. But: a) I don't see currently what should be used instead b) this shouldn't be critical for Print Assumption. At worse some constants will have a canonical name which is non-canonical, leading to failures in [Global.lookup_constant], but our own [lookup_constant] should work. *) and fields_of_seb subs mp0 seb args = match seb with | SEBstruct l -> assert (args = []); l, mp0, subs | SEBident mp -> let mb = lookup_module_in_impl (subst_mp subs mp) in fields_of_mb subs mb args | SEBapply (seb1,seb2,_) -> (match seb2 with | SEBident mp2 -> fields_of_seb subs mp0 seb1 (mp2::args) | _ -> assert false) (* only legal application is to module names *) | SEBfunctor (mbid,mtb,seb) -> (match args with | [] -> assert false (* we should only encounter applied functors *) | mpa :: args -> let subs = add_mbid mbid mpa empty_delta_resolver subs in fields_of_seb subs mp0 seb args) | SEBwith _ -> assert false (* should not appear in a mod_expr or mod_type field *) let lookup_constant_in_impl cst fallback = try let mp,dp,lab = repr_kn (canonical_con cst) in let fields = memoize_fields_of_mp mp in (* A module found this way is necessarily closed, in particular our constant cannot be in an opened section : *) search_cst_label lab fields with Not_found -> (* Either: - The module part of the constant isn't registered yet : we're still in it, so the [constant_body] found earlier (if any) was a true axiom. - The label has not been found in the structure. This is an error *) match fallback with | Some cb -> cb | None -> anomaly ("Print Assumption: unknown constant "^string_of_con cst) let lookup_constant cst = try let cb = Global.lookup_constant cst in if constant_has_body cb then cb else lookup_constant_in_impl cst (Some cb) with Not_found -> lookup_constant_in_impl cst None let assumptions ?(add_opaque=false) st (* t *) = modcache := MPmap.empty; let (idts,knst) = st in (* Infix definition for chaining function that accumulate on a and a ContextObjectSet, ContextObjectMap. *) let ( ** ) f1 f2 s m = let (s',m') = f1 s m in f2 s' m' in (* This function eases memoization, by checking if an object is already stored before trying and applying a function. If the object is there, the function is not fired (we are in a particular case where memoized object don't need a treatment at all). If the object isn't there, it is stored and the function is fired*) let try_and_go o f s m = if ContextObjectSet.mem o s then (s,m) else f (ContextObjectSet.add o s) m in let identity2 s m = (s,m) in (* Goes recursively into the term to see if it depends on assumptions. The 3 important cases are : - Const _ where we need to first unfold the constant and return the needed assumptions of its body in the environment, - Rel _ which means the term is a variable which has been bound earlier by a Lambda or a Prod (returns [] ), - Var _ which means that the term refers to a section variable or a "Let" definition, in the former it is an assumption of [t], in the latter is must be unfolded like a Const. The other cases are straightforward recursion. Calls to the environment are memoized, thus avoiding to explore the DAG of the environment as if it was a tree (can cause exponential behavior and prevent the algorithm from terminating in reasonable time). [s] is a set of [context_object], representing the object already visited.*) let rec do_constr t s acc = let rec iter t = match kind_of_term t with | Var id -> do_memoize_id id | Meta _ | Evar _ -> assert false | Cast (e1,_,e2) | Prod (_,e1,e2) | Lambda (_,e1,e2) -> (iter e1)**(iter e2) | LetIn (_,e1,e2,e3) -> (iter e1)**(iter e2)**(iter e3) | App (e1, e_array) -> (iter e1)**(iter_array e_array) | Case (_,e1,e2,e_array) -> (iter e1)**(iter e2)**(iter_array e_array) | Fix (_,(_, e1_array, e2_array)) | CoFix (_,(_,e1_array, e2_array)) -> (iter_array e1_array) ** (iter_array e2_array) | Const kn -> do_memoize_kn kn | _ -> identity2 (* closed atomic types + rel *) and iter_array a = Array.fold_right (fun e f -> (iter e)**f) a identity2 in iter t s acc and add_id id s acc = (* a Var can be either a variable, or a "Let" definition.*) match Global.lookup_named id with | (_,None,t) -> (s,ContextObjectMap.add (Variable id) t acc) | (_,Some bdy,_) -> do_constr bdy s acc and do_memoize_id id = try_and_go (Variable id) (add_id id) and add_kn kn s acc = let cb = lookup_constant kn in let do_type cst = let ctype = match cb.Declarations.const_type with | PolymorphicArity (ctx,a) -> mkArity (ctx, Type a.poly_level) | NonPolymorphicType t -> t in (s,ContextObjectMap.add cst ctype acc) in let (s,acc) = if add_opaque && Declarations.constant_has_body cb && (Declarations.is_opaque cb || not (Cpred.mem kn knst)) then do_type (Opaque kn) else (s,acc) in match Declarations.body_of_constant cb with | None -> do_type (Axiom kn) | Some body -> do_constr (Declarations.force body) s acc and do_memoize_kn kn = try_and_go (Axiom kn) (add_kn kn) in fun t -> snd (do_constr t (ContextObjectSet.empty) (ContextObjectMap.empty)) coq-8.4pl4/library/library.ml0000644000175000017500000005556212326224777015312 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* p = phys_dir) !load_paths with | [_,dir,_] -> dir | [] -> Nameops.default_root_prefix | l -> anomaly ("Two logical paths are associated to "^phys_dir) let is_in_load_paths phys_dir = let dir = System.canonical_path_name phys_dir in let lp = get_load_paths () in let check_p = fun p -> (String.compare dir p) == 0 in List.exists check_p lp let remove_load_path dir = load_paths := List.filter (fun (p,d,_) -> p <> dir) !load_paths let add_load_path isroot (phys_path,coq_path) = let phys_path = System.canonical_path_name phys_path in match List.filter (fun (p,d,_) -> p = phys_path) !load_paths with | [_,dir,_] -> if coq_path <> dir (* If this is not the default -I . to coqtop *) && not (phys_path = System.canonical_path_name Filename.current_dir_name && coq_path = Nameops.default_root_prefix) then begin (* Assume the user is concerned by library naming *) if dir <> Nameops.default_root_prefix then Flags.if_warn msg_warning (str phys_path ++ strbrk " was previously bound to " ++ pr_dirpath dir ++ strbrk "; it is remapped to " ++ pr_dirpath coq_path); remove_load_path phys_path; load_paths := (phys_path,coq_path,isroot) :: !load_paths; end | [] -> load_paths := (phys_path,coq_path,isroot) :: !load_paths; | _ -> anomaly ("Two logical paths are associated to "^phys_path) let extend_path_with_dirpath p dir = List.fold_left Filename.concat p (List.map string_of_id (List.rev (repr_dirpath dir))) let root_paths_matching_dir_path dir = let rec aux = function | [] -> [] | (p,d,true) :: l when is_dirpath_prefix_of d dir -> let suffix = drop_dirpath_prefix d dir in extend_path_with_dirpath p suffix :: aux l | _ :: l -> aux l in aux !load_paths (* Root p is bound to A.B.C.D and we require file C.D.E.F *) (* We may mean A.B.C.D.E.F, or A.B.C.D.C.D.E.F *) (* Root p is bound to A.B.C.C and we require file C.C.E.F *) (* We may mean A.B.C.C.E.F, or A.B.C.C.C.E.F, or A.B.C.C.C.C.E.F *) let intersections d1 d2 = let rec aux d1 = if d1 = empty_dirpath then [d2] else let rest = aux (snd (chop_dirpath 1 d1)) in if is_dirpath_prefix_of d1 d2 then drop_dirpath_prefix d1 d2 :: rest else rest in aux d1 let loadpaths_matching_dir_path dir = let rec aux = function | [] -> [] | (p,d,true) :: l -> let inters = intersections d dir in List.map (fun tl -> (extend_path_with_dirpath p tl,append_dirpath d tl)) inters @ aux l | (p,d,_) :: l -> (extend_path_with_dirpath p dir,append_dirpath d dir) :: aux l in aux !load_paths let get_full_load_paths () = List.map (fun (a,b,c) -> (a,b)) !load_paths (************************************************************************) (*s Modules on disk contain the following informations (after the magic number, and before the digest). *) type compilation_unit_name = dir_path type library_disk = { md_name : compilation_unit_name; md_compiled : LightenLibrary.lightened_compiled_library; md_objects : Declaremods.library_objects; md_deps : (compilation_unit_name * Digest.t) list; md_imports : compilation_unit_name list } (*s Modules loaded in memory contain the following informations. They are kept in the global table [libraries_table]. *) type library_t = { library_name : compilation_unit_name; library_compiled : compiled_library; library_objects : Declaremods.library_objects; library_deps : (compilation_unit_name * Digest.t) list; library_imports : compilation_unit_name list; library_digest : Digest.t } module LibraryOrdered = struct type t = dir_path let compare d1 d2 = Pervasives.compare (List.rev (repr_dirpath d1)) (List.rev (repr_dirpath d2)) end module LibraryMap = Map.Make(LibraryOrdered) module LibraryFilenameMap = Map.Make(LibraryOrdered) (* This is a map from names to loaded libraries *) let libraries_table = ref LibraryMap.empty (* This is the map of loaded libraries filename *) (* (not synchronized so as not to be caught in the states on disk) *) let libraries_filename_table = ref LibraryFilenameMap.empty (* These are the _ordered_ sets of loaded, imported and exported libraries *) let libraries_loaded_list = ref [] let libraries_imports_list = ref [] let libraries_exports_list = ref [] let freeze () = !libraries_table, !libraries_loaded_list, !libraries_imports_list, !libraries_exports_list let unfreeze (mt,mo,mi,me) = libraries_table := mt; libraries_loaded_list := mo; libraries_imports_list := mi; libraries_exports_list := me let init () = libraries_table := LibraryMap.empty; libraries_loaded_list := []; libraries_imports_list := []; libraries_exports_list := [] let _ = Summary.declare_summary "MODULES" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = init } (* various requests to the tables *) let find_library dir = LibraryMap.find dir !libraries_table let try_find_library dir = try find_library dir with Not_found -> error ("Unknown library " ^ (string_of_dirpath dir)) let register_library_filename dir f = (* Not synchronized: overwrite the previous binding if one existed *) (* from a previous play of the session *) libraries_filename_table := LibraryFilenameMap.add dir f !libraries_filename_table let library_full_filename dir = try LibraryFilenameMap.find dir !libraries_filename_table with Not_found -> "" let overwrite_library_filenames f = let f = if Filename.is_relative f then Filename.concat (Sys.getcwd ()) f else f in LibraryMap.iter (fun dir _ -> register_library_filename dir f) !libraries_table let library_is_loaded dir = try let _ = find_library dir in true with Not_found -> false let library_is_opened dir = List.exists (fun m -> m.library_name = dir) !libraries_imports_list let loaded_libraries () = List.map (fun m -> m.library_name) !libraries_loaded_list let opened_libraries () = List.map (fun m -> m.library_name) !libraries_imports_list (* If a library is loaded several time, then the first occurrence must be performed first, thus the libraries_loaded_list ... *) let register_loaded_library m = let rec aux = function | [] -> [m] | m'::_ as l when m'.library_name = m.library_name -> l | m'::l' -> m' :: aux l' in libraries_loaded_list := aux !libraries_loaded_list; libraries_table := LibraryMap.add m.library_name m !libraries_table (* ... while if a library is imported/exported several time, then only the last occurrence is really needed - though the imported list may differ from the exported list (consider the sequence Export A; Export B; Import A which results in A;B for exports but in B;A for imports) *) let rec remember_last_of_each l m = match l with | [] -> [m] | m'::l' when m'.library_name = m.library_name -> remember_last_of_each l' m | m'::l' -> m' :: remember_last_of_each l' m let register_open_library export m = libraries_imports_list := remember_last_of_each !libraries_imports_list m; if export then libraries_exports_list := remember_last_of_each !libraries_exports_list m (************************************************************************) (*s Opening libraries *) (* [open_library export explicit m] opens library [m] if not already opened _or_ if explicitly asked to be (re)opened *) let eq_lib_name m1 m2 = m1.library_name = m2.library_name let open_library export explicit_libs m = if (* Only libraries indirectly to open are not reopen *) (* Libraries explicitly mentionned by the user are always reopen *) List.exists (eq_lib_name m) explicit_libs or not (library_is_opened m.library_name) then begin register_open_library export m; Declaremods.really_import_module (MPfile m.library_name) end else if export then libraries_exports_list := remember_last_of_each !libraries_exports_list m (* open_libraries recursively open a list of libraries but opens only once a library that is re-exported many times *) let open_libraries export modl = let to_open_list = List.fold_left (fun l m -> let subimport = List.fold_left (fun l m -> remember_last_of_each l (try_find_library m)) l m.library_imports in remember_last_of_each subimport m) [] modl in List.iter (open_library export modl) to_open_list (**********************************************************************) (* import and export - synchronous operations*) let open_import i (_,(dir,export)) = if i=1 then (* even if the library is already imported, we re-import it *) (* if not (library_is_opened dir) then *) open_libraries export [try_find_library dir] let cache_import obj = open_import 1 obj let subst_import (_,o) = o let classify_import (_,export as obj) = if export then Substitute obj else Dispose let in_import : dir_path * bool -> obj = declare_object {(default_object "IMPORT LIBRARY") with cache_function = cache_import; open_function = open_import; subst_function = subst_import; classify_function = classify_import } (************************************************************************) (*s Low-level interning/externing of libraries to files *) (*s Loading from disk to cache (preparation phase) *) let (raw_extern_library, raw_intern_library) = System.raw_extern_intern Coq_config.vo_magic_number ".vo" (************************************************************************) (*s Locate absolute or partially qualified library names in the path *) exception LibUnmappedDir exception LibNotFound type library_location = LibLoaded | LibInPath let locate_absolute_library dir = (* Search in loadpath *) let pref, base = split_dirpath dir in let loadpath = root_paths_matching_dir_path pref in if loadpath = [] then raise LibUnmappedDir; try let name = (string_of_id base)^".vo" in let _, file = System.where_in_path ~warn:false loadpath name in (dir, file) with Not_found -> (* Last chance, removed from the file system but still in memory *) if library_is_loaded dir then (dir, library_full_filename dir) else raise LibNotFound let locate_qualified_library warn qid = try (* Search library in loadpath *) let dir, base = repr_qualid qid in let loadpath = loadpaths_matching_dir_path dir in if loadpath = [] then raise LibUnmappedDir; let name = string_of_id base ^ ".vo" in let lpath, file = System.where_in_path ~warn (List.map fst loadpath) name in let dir = add_dirpath_suffix (List.assoc lpath loadpath) base in (* Look if loaded *) if library_is_loaded dir then (LibLoaded, dir, library_full_filename dir) (* Otherwise, look for it in the file system *) else (LibInPath, dir, file) with Not_found -> raise LibNotFound let explain_locate_library_error qid = function | LibUnmappedDir -> let prefix, _ = repr_qualid qid in errorlabstrm "load_absolute_library_from" (str "Cannot load " ++ pr_qualid qid ++ str ":" ++ spc () ++ str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++ fnl ()) | LibNotFound -> errorlabstrm "load_absolute_library_from" (str"Cannot find library " ++ pr_qualid qid ++ str" in loadpath") | e -> raise e let try_locate_absolute_library dir = try locate_absolute_library dir with e when Errors.noncritical e -> explain_locate_library_error (qualid_of_dirpath dir) e let try_locate_qualified_library (loc,qid) = try let (_,dir,f) = locate_qualified_library (Flags.is_verbose()) qid in dir,f with e when Errors.noncritical e -> explain_locate_library_error qid e (************************************************************************) (* Internalise libraries *) let mk_library md table digest = let md_compiled = LightenLibrary.load ~load_proof:!Flags.load_proofs table md.md_compiled in { library_name = md.md_name; library_compiled = md_compiled; library_objects = md.md_objects; library_deps = md.md_deps; library_imports = md.md_imports; library_digest = digest } let fetch_opaque_table (f,pos,digest) = try let ch = System.with_magic_number_check raw_intern_library f in seek_in ch pos; if System.marshal_in f ch <> digest then failwith "File changed!"; let table = (System.marshal_in f ch : LightenLibrary.table) in close_in ch; table with e when Errors.noncritical e -> error ("The file "^f^" is inaccessible or has changed,\n" ^ "cannot load some opaque constant bodies in it.\n") let intern_from_file f = let ch = System.with_magic_number_check raw_intern_library f in let lmd = System.marshal_in f ch in let pos = pos_in ch in let digest = System.marshal_in f ch in let table = lazy (fetch_opaque_table (f,pos,digest)) in register_library_filename lmd.md_name f; let library = mk_library lmd table digest in close_in ch; library let rec intern_library needed (dir, f) = (* Look if in the current logical environment *) try find_library dir, needed with Not_found -> (* Look if already listed and consequently its dependencies too *) try List.assoc dir needed, needed with Not_found -> (* [dir] is an absolute name which matches [f] which must be in loadpath *) let m = intern_from_file f in if dir <> m.library_name then errorlabstrm "load_physical_library" (str ("The file " ^ f ^ " contains library") ++ spc () ++ pr_dirpath m.library_name ++ spc () ++ str "and not library" ++ spc() ++ pr_dirpath dir); m, intern_library_deps needed dir m and intern_library_deps needed dir m = (dir,m)::List.fold_left (intern_mandatory_library dir) needed m.library_deps and intern_mandatory_library caller needed (dir,d) = let m,needed = intern_library needed (try_locate_absolute_library dir) in if d <> m.library_digest then errorlabstrm "" (strbrk ("Compiled library "^(string_of_dirpath caller)^ ".vo makes inconsistent assumptions over library " ^(string_of_dirpath dir))); needed let rec_intern_library needed mref = let _,needed = intern_library needed mref in needed let check_library_short_name f dir = function | Some id when id <> snd (split_dirpath dir) -> errorlabstrm "check_library_short_name" (str ("The file " ^ f ^ " contains library") ++ spc () ++ pr_dirpath dir ++ spc () ++ str "and not library" ++ spc () ++ pr_id id) | _ -> () let rec_intern_by_filename_only id f = let m = try intern_from_file f with Sys_error s -> error s in (* Only the base name is expected to match *) check_library_short_name f m.library_name id; (* We check no other file containing same library is loaded *) if library_is_loaded m.library_name then begin Flags.if_warn msg_warning (pr_dirpath m.library_name ++ str " is already loaded from file " ++ str (library_full_filename m.library_name)); m.library_name, [] end else let needed = intern_library_deps [] m.library_name m in m.library_name, needed let rec_intern_library_from_file idopt f = (* A name is specified, we have to check it contains library id *) let paths = get_load_paths () in let _, f = System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".vo") in rec_intern_by_filename_only idopt f (**********************************************************************) (*s [require_library] loads and possibly opens a library. This is a synchronized operation. It is performed as follows: preparation phase: (functions require_library* ) the library and its dependencies are read from to disk (using intern_* ) [they are read from disk to ensure that at section/module discharging time, the physical library referred to outside the section/module is the one that was used at type-checking time in the section/module] execution phase: (through add_leaf and cache_require) the library is loaded in the environment and Nametab, the objects are registered etc, using functions from Declaremods (via load_library, which recursively loads its dependencies) *) type library_reference = dir_path list * bool option let register_library m = Declaremods.register_library m.library_name m.library_compiled m.library_objects m.library_digest; register_loaded_library m (* Follow the semantics of Anticipate object: - called at module or module type closing when a Require occurs in the module or module type - not called from a library (i.e. a module identified with a file) *) let load_require _ (_,(needed,modl,_)) = List.iter register_library needed let open_require i (_,(_,modl,export)) = Option.iter (fun exp -> open_libraries exp (List.map find_library modl)) export (* [needed] is the ordered list of libraries not already loaded *) let cache_require o = load_require 1 o; open_require 1 o let discharge_require (_,o) = Some o (* open_function is never called from here because an Anticipate object *) type require_obj = library_t list * dir_path list * bool option let in_require : require_obj -> obj = declare_object {(default_object "REQUIRE") with cache_function = cache_require; load_function = load_require; open_function = (fun _ _ -> assert false); discharge_function = discharge_require; classify_function = (fun o -> Anticipate o) } (* Require libraries, import them if [export <> None], mark them for export if [export = Some true] *) let xml_require = ref (fun d -> ()) let set_xml_require f = xml_require := f let require_library_from_dirpath modrefl export = let needed = List.fold_left rec_intern_library [] modrefl in let needed = List.rev_map snd needed in let modrefl = List.map fst modrefl in if Lib.is_module_or_modtype () then begin add_anonymous_leaf (in_require (needed,modrefl,None)); Option.iter (fun exp -> List.iter (fun dir -> add_anonymous_leaf (in_import(dir,exp))) modrefl) export end else add_anonymous_leaf (in_require (needed,modrefl,export)); if !Flags.xml_export then List.iter !xml_require modrefl; add_frozen_state () let require_library qidl export = let modrefl = List.map try_locate_qualified_library qidl in require_library_from_dirpath modrefl export let require_library_from_file idopt file export = let modref,needed = rec_intern_library_from_file idopt file in let needed = List.rev_map snd needed in if Lib.is_module_or_modtype () then begin add_anonymous_leaf (in_require (needed,[modref],None)); Option.iter (fun exp -> add_anonymous_leaf (in_import (modref,exp))) export end else add_anonymous_leaf (in_require (needed,[modref],export)); if !Flags.xml_export then !xml_require modref; add_frozen_state () (* the function called by Vernacentries.vernac_import *) let import_module export (loc,qid) = try match Nametab.locate_module qid with | MPfile dir -> if Lib.is_module_or_modtype () || not export then add_anonymous_leaf (in_import (dir, export)) else add_anonymous_leaf (in_import (dir, export)) | mp -> Declaremods.import_module export mp with Not_found -> user_err_loc (loc,"import_library", str ((string_of_qualid qid)^" is not a module")) (************************************************************************) (*s Initializing the compilation of a library. *) let check_coq_overwriting p id = let l = repr_dirpath p in if not !Flags.boot && l <> [] && string_of_id (list_last l) = "Coq" then errorlabstrm "" (strbrk ("Cannot build module "^string_of_dirpath p^"."^string_of_id id^ ": it starts with prefix \"Coq\" which is reserved for the Coq library.")) let start_library f = let paths = get_load_paths () in let _,longf = System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".v") in let ldir0 = find_logical_path (Filename.dirname longf) in let id = id_of_string (Filename.basename f) in check_coq_overwriting ldir0 id; let ldir = add_dirpath_suffix ldir0 id in Declaremods.start_library ldir; ldir,longf (************************************************************************) (*s [save_library dir] ends library [dir] and save it to the disk. *) let current_deps () = List.map (fun m -> (m.library_name, m.library_digest)) !libraries_loaded_list let current_reexports () = List.map (fun m -> m.library_name) !libraries_exports_list let error_recursively_dependent_library dir = errorlabstrm "" (strbrk "Unable to use logical name " ++ pr_dirpath dir ++ strbrk " to save current library because" ++ strbrk " it already depends on a library of this name.") (* Security weakness: file might have been changed on disk between writing the content and computing the checksum... *) let save_library_to dir f = let cenv, seg = Declaremods.end_library dir in let cenv, table = LightenLibrary.save cenv in let md = { md_name = dir; md_compiled = cenv; md_objects = seg; md_deps = current_deps (); md_imports = current_reexports () } in if List.mem_assoc dir md.md_deps then error_recursively_dependent_library dir; let (f',ch) = raw_extern_library f in try System.marshal_out ch md; flush ch; (* The loading of the opaque definitions table is optional whereas the digest is loaded all the time. As a consequence, the digest must be serialized before the table (if we want to keep the current simple layout of .vo files). This also entails that the digest does not take opaque terms into account anymore. *) let di = Digest.file f' in System.marshal_out ch di; System.marshal_out ch table; close_out ch with reraise -> msg_warn ("Removed file "^f'); close_out ch; Sys.remove f'; raise reraise (************************************************************************) (*s Display the memory use of a library. *) open Printf let mem s = let m = try_find_library s in h 0 (str (sprintf "%dk (cenv = %dk / seg = %dk)" (size_kb m) (size_kb m.library_compiled) (size_kb m.library_objects))) coq-8.4pl4/library/library.mli0000644000175000017500000000647212326224777015457 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool option -> unit val require_library_from_dirpath : (dir_path * string) list -> bool option -> unit val require_library_from_file : identifier option -> System.physical_path -> bool option -> unit (** {6 ... } *) (** Open a module (or a library); if the boolean is true then it's also an export otherwise just a simple import *) val import_module : bool -> qualid located -> unit (** {6 Start the compilation of a library } *) val start_library : string -> dir_path * string (** {6 End the compilation of a library and save it to a ".vo" file } *) val save_library_to : dir_path -> string -> unit (** {6 Interrogate the status of libraries } *) (** - Tell if a library is loaded or opened *) val library_is_loaded : dir_path -> bool val library_is_opened : dir_path -> bool (** - Tell which libraries are loaded or imported *) val loaded_libraries : unit -> dir_path list val opened_libraries : unit -> dir_path list (** - Return the full filename of a loaded library. *) val library_full_filename : dir_path -> string (** - Overwrite the filename of all libraries (used when restoring a state) *) val overwrite_library_filenames : string -> unit (** {6 Hook for the xml exportation of libraries } *) val set_xml_require : (dir_path -> unit) -> unit (** {6 ... } *) (** Global load paths: a load path is a physical path in the file system; to each load path is associated a Coq [dir_path] (the "logical" path of the physical path) *) val get_load_paths : unit -> System.physical_path list val get_full_load_paths : unit -> (System.physical_path * dir_path) list val add_load_path : bool -> System.physical_path * dir_path -> unit val remove_load_path : System.physical_path -> unit val find_logical_path : System.physical_path -> dir_path val is_in_load_paths : System.physical_path -> bool (** {6 Locate a library in the load paths } *) exception LibUnmappedDir exception LibNotFound type library_location = LibLoaded | LibInPath val locate_qualified_library : bool -> qualid -> library_location * dir_path * System.physical_path val try_locate_qualified_library : qualid located -> dir_path * string (** {6 Statistics: display the memory use of a library. } *) val mem : dir_path -> Pp.std_ppcmds coq-8.4pl4/library/decls.mli0000644000175000017500000000322612326224777015077 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* variable_data -> unit val variable_path : variable -> dir_path val variable_secpath : variable -> qualid val variable_kind : variable -> logical_kind val variable_opacity : variable -> bool val variable_constraints : variable -> Univ.constraints val variable_exists : variable -> bool (** Registration and access to the table of constants *) val add_constant_kind : constant -> logical_kind -> unit val constant_kind : constant -> logical_kind (* Prepare global named context for proof session: remove proofs of opaque section definitions and remove vm-compiled code *) val initialize_named_context_for_proof : unit -> Environ.named_context_val (** Miscellaneous functions *) val last_section_hyps : dir_path -> identifier list coq-8.4pl4/library/decl_kinds.ml0000644000175000017500000000636412326224777015741 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* IsDefinition d | Proof s -> IsProof s let string_of_theorem_kind = function | Theorem -> "Theorem" | Lemma -> "Lemma" | Fact -> "Fact" | Remark -> "Remark" | Property -> "Property" | Proposition -> "Proposition" | Corollary -> "Corollary" let string_of_definition_kind def = match def with | Local, Coercion -> "Coercion Local" | Global, Coercion -> "Coercion" | Local, Definition -> "Let" | Global, Definition -> "Definition" | Local, SubClass -> "Local SubClass" | Global, SubClass -> "SubClass" | Global, CanonicalStructure -> "Canonical Structure" | Global, Example -> "Example" | Local, (CanonicalStructure|Example) -> anomaly "Unsupported local definition kind" | Local, Instance -> "Instance" | Global, Instance -> "Global Instance" | _, (StructureComponent|Scheme|CoFixpoint|Fixpoint|IdentityCoercion|Method) -> anomaly "Internal definition kind" (* Strength *) let strength_of_global = function | VarRef _ -> Local | IndRef _ | ConstructRef _ | ConstRef _ -> Global let string_of_strength = function | Local -> "Local" | Global -> "Global" (* Recursive power *) (* spiwack: this definition might be of use in the kernel, for now I do not push them deeper than needed, though. *) type recursivity_kind = | Finite (* = inductive *) | CoFinite (* = coinductive *) | BiFinite (* = non-recursive, like in "Record" definitions *) (* helper, converts to "finiteness flag" booleans *) let recursivity_flag_of_kind = function | Finite | BiFinite -> true | CoFinite -> false coq-8.4pl4/library/goptions.mli0000644000175000017500000001373212326224777015652 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool -> std_ppcmds val synchronous : bool end) -> sig val active : string -> bool val elements : unit -> string list end (** The functor [MakeRefTable] declares a new table of objects of type [A.t] practically denoted by [reference]; the encoding function [encode : reference -> A.t] is typically a globalization function, possibly with some restriction checks; the function [member_message] say what to print when invoking the "Test Toto Titi foo." command; at the end [title] is the table name printed when invoking the "Print Toto Titi." command; [active] is roughly the internal version of the vernacular "Test ...": it tells if a given object is in the table. *) module MakeRefTable : functor (A : sig type t val encode : reference -> t val subst : substitution -> t -> t val printer : t -> std_ppcmds val key : option_name val title : string val member_message : t -> bool -> std_ppcmds val synchronous : bool end) -> sig val active : A.t -> bool val elements : unit -> A.t list end (** {6 Options. } *) (** These types and function are for declaring a new option of name [key] and access functions [read] and [write]; the parameter [name] is the option name used when printing the option value (command "Print Toto Titi." *) type 'a option_sig = { optsync : bool; (** whether the option is synchronous w.r.t to the section/module system. *) optdepr : bool; (** whether the option is DEPRECATED *) optname : string; (** a short string describing the option *) optkey : option_name; (** the low-level name of this option *) optread : unit -> 'a; optwrite : 'a -> unit } (** When an option is declared synchronous ([optsync] is [true]), the output is a synchronous write function. Otherwise it is [optwrite] *) type 'a write_function = 'a -> unit val declare_int_option : int option option_sig -> int option write_function val declare_bool_option : bool option_sig -> bool write_function val declare_string_option: string option_sig -> string write_function (** {6 Special functions supposed to be used only in vernacentries.ml } *) module OptionMap : Map.S with type key = option_name val get_string_table : option_name -> < add : string -> unit; remove : string -> unit; mem : string -> unit; print : unit > val get_ref_table : option_name -> < add : reference -> unit; remove : reference -> unit; mem : reference -> unit; print : unit > (** The first argument is a locality flag. [Some true] = "Local", [Some false]="Global". *) val set_int_option_value_gen : bool option -> option_name -> int option -> unit val set_bool_option_value_gen : bool option -> option_name -> bool -> unit val set_string_option_value_gen : bool option -> option_name -> string -> unit val unset_option_value_gen : bool option -> option_name -> unit val set_int_option_value : option_name -> int option -> unit val set_bool_option_value : option_name -> bool -> unit val set_string_option_value : option_name -> string -> unit val print_option_value : option_name -> unit val get_tables : unit -> Goptionstyp.option_state OptionMap.t val print_tables : unit -> unit val error_undeclared_key : option_name -> 'a coq-8.4pl4/library/summary.mli0000644000175000017500000000234712326224777015505 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a; unfreeze_function : 'a -> unit; init_function : unit -> unit } val declare_summary : string -> 'a summary_declaration -> unit type frozen val freeze_summaries : unit -> frozen val unfreeze_summaries : frozen -> unit val init_summaries : unit -> unit (** Beware: if some code is dynamically loaded via dynlink after the initialization of Coq, the init functions of any summary declared by this code may not be run. It is hence the responsability of plugins to initialize themselves properly. *) coq-8.4pl4/library/libobject.mli0000644000175000017500000001017012326224777015736 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit; load_function : int -> object_name * 'a -> unit; open_function : int -> object_name * 'a -> unit; classify_function : 'a -> 'a substitutivity; subst_function : substitution * 'a -> 'a; discharge_function : object_name * 'a -> 'a option; rebuild_function : 'a -> 'a } (** The default object is a "Keep" object with empty methods. Object creators are advised to use the construction [{(default_object "MY_OBJECT") with cache_function = ... }] and specify only these functions which are not empty/meaningless *) val default_object : string -> 'a object_declaration (** the identity substitution function *) val ident_subst_function : substitution * 'a -> 'a (** {6 ... } *) (** Given an object declaration, the function [declare_object_full] will hand back two functions, the "injection" and "projection" functions for dynamically typed library-objects. *) type obj val declare_object_full : 'a object_declaration -> ('a -> obj) * (obj -> 'a) val declare_object : 'a object_declaration -> ('a -> obj) val object_tag : obj -> string val cache_object : object_name * obj -> unit val load_object : int -> object_name * obj -> unit val open_object : int -> object_name * obj -> unit val subst_object : substitution * obj -> obj val classify_object : obj -> obj substitutivity val discharge_object : object_name * obj -> obj option val rebuild_object : obj -> obj val relax : bool -> unit coq-8.4pl4/library/assumptions.mli0000644000175000017500000000237212326224777016373 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* transparent_state -> constr -> Term.types ContextObjectMap.t coq-8.4pl4/library/impargs.ml0000644000175000017500000006075712326224777015312 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* begin implicit_args := oflags; raise reraise end let set_maximality imps b = (* Force maximal insertion on ending implicits (compatibility) *) b || List.for_all ((<>) None) imps (*s Computation of implicit arguments *) (* We remember various information about why an argument is inferable as implicit - [DepRigid] means that the implicit argument can be found by unification along a rigid path (we do not print the arguments of this kind if there is enough arguments to infer them) - [DepFlex] means that the implicit argument can be found by unification along a collapsable path only (e.g. as x in (P x) where P is another argument) (we do (defensively) print the arguments of this kind) - [DepFlexAndRigid] means that the least argument from which the implicit argument can be inferred is following a collapsable path but there is a greater argument from where the implicit argument is inferable following a rigid path (useful to know how to print a partial application) - [Manual] means the argument has been explicitely set as implicit. We also consider arguments inferable from the conclusion but it is operational only if [conclusion_matters] is true. *) type argument_position = | Conclusion | Hyp of int type implicit_explanation = | DepRigid of argument_position | DepFlex of argument_position | DepFlexAndRigid of (*flex*) argument_position * (*rig*) argument_position | Manual let argument_less = function | Hyp n, Hyp n' -> n true | Conclusion, _ -> false let update pos rig (na,st) = let e = if rig then match st with | None -> DepRigid pos | Some (DepRigid n as x) -> if argument_less (pos,n) then DepRigid pos else x | Some (DepFlexAndRigid (fpos,rpos) as x) -> if argument_less (pos,fpos) or pos=fpos then DepRigid pos else if argument_less (pos,rpos) then DepFlexAndRigid (fpos,pos) else x | Some (DepFlex fpos) -> if argument_less (pos,fpos) or pos=fpos then DepRigid pos else DepFlexAndRigid (fpos,pos) | Some Manual -> assert false else match st with | None -> DepFlex pos | Some (DepRigid rpos as x) -> if argument_less (pos,rpos) then DepFlexAndRigid (pos,rpos) else x | Some (DepFlexAndRigid (fpos,rpos) as x) -> if argument_less (pos,fpos) then DepFlexAndRigid (pos,rpos) else x | Some (DepFlex fpos as x) -> if argument_less (pos,fpos) then DepFlex pos else x | Some Manual -> assert false in na, Some e (* modified is_rigid_reference with a truncated env *) let is_flexible_reference env bound depth f = match kind_of_term f with | Rel n when n >= bound+depth -> (* inductive type *) false | Rel n when n >= depth -> (* previous argument *) true | Rel n -> (* since local definitions have been expanded *) false | Const kn -> let cb = Environ.lookup_constant kn env in (match cb.const_body with Def _ -> true | _ -> false) | Var id -> let (_,value,_) = Environ.lookup_named id env in value <> None | Ind _ | Construct _ -> false | _ -> true let push_lift d (e,n) = (push_rel d e,n+1) let is_reversible_pattern bound depth f l = isRel f & let n = destRel f in (n < bound+depth) & (n >= depth) & array_for_all (fun c -> isRel c & destRel c < depth) l & array_distinct l (* Precondition: rels in env are for inductive types only *) let add_free_rels_until strict strongly_strict revpat bound env m pos acc = let rec frec rig (env,depth as ed) c = let hd = if strict then whd_betadeltaiota env c else c in let c = if strongly_strict then hd else c in match kind_of_term hd with | Rel n when (n < bound+depth) & (n >= depth) -> let i = bound + depth - n - 1 in acc.(i) <- update pos rig acc.(i) | App (f,l) when revpat & is_reversible_pattern bound depth f l -> let i = bound + depth - destRel f - 1 in acc.(i) <- update pos rig acc.(i) | App (f,_) when rig & is_flexible_reference env bound depth f -> if strict then () else iter_constr_with_full_binders push_lift (frec false) ed c | Case _ when rig -> if strict then () else iter_constr_with_full_binders push_lift (frec false) ed c | Evar _ -> () | _ -> iter_constr_with_full_binders push_lift (frec rig) ed c in frec true (env,1) m; acc let rec is_rigid_head t = match kind_of_term t with | Rel _ | Evar _ -> false | Ind _ | Const _ | Var _ | Sort _ -> true | Case (_,_,f,_) -> is_rigid_head f | App (f,args) -> (match kind_of_term f with | Fix ((fi,i),_) -> is_rigid_head (args.(fi.(i))) | _ -> is_rigid_head f) | Lambda _ | LetIn _ | Construct _ | CoFix _ | Fix _ | Prod _ | Meta _ | Cast _ -> assert false (* calcule la liste des arguments implicites *) let find_displayed_name_in all avoid na (_,b as envnames_b) = let flag = RenamingElsewhereFor envnames_b in if all then compute_and_force_displayed_name_in flag avoid na b else compute_displayed_name_in flag avoid na b let compute_implicits_gen strict strongly_strict revpat contextual all env t = let rigid = ref true in let rec aux env avoid n names t = let t = whd_betadeltaiota env t in match kind_of_term t with | Prod (na,a,b) -> let na',avoid' = find_displayed_name_in all avoid na (names,b) in add_free_rels_until strict strongly_strict revpat n env a (Hyp (n+1)) (aux (push_rel (na',None,a) env) avoid' (n+1) (na'::names) b) | _ -> rigid := is_rigid_head t; let names = List.rev names in let v = Array.map (fun na -> na,None) (Array.of_list names) in if contextual then add_free_rels_until strict strongly_strict revpat n env t Conclusion v else v in match kind_of_term (whd_betadeltaiota env t) with | Prod (na,a,b) -> let na',avoid = find_displayed_name_in all [] na ([],b) in let v = aux (push_rel (na',None,a) env) avoid 1 [na'] b in !rigid, Array.to_list v | _ -> true, [] let compute_implicits_flags env f all t = compute_implicits_gen (f.strict or f.strongly_strict) f.strongly_strict f.reversible_pattern f.contextual all env t let compute_auto_implicits env flags enriching t = if enriching then compute_implicits_flags env flags true t else compute_implicits_gen false false false true true env t let compute_implicits_names env t = let _, impls = compute_implicits_gen false false false false true env t in List.map fst impls (* Extra information about implicit arguments *) type maximal_insertion = bool (* true = maximal contextual insertion *) type force_inference = bool (* true = always infer, never turn into evar/subgoal *) type implicit_status = (* None = Not implicit *) (identifier * implicit_explanation * (maximal_insertion * force_inference)) option type implicit_side_condition = DefaultImpArgs | LessArgsThan of int type implicits_list = implicit_side_condition * implicit_status list let is_status_implicit = function | None -> false | _ -> true let name_of_implicit = function | None -> anomaly "Not an implicit argument" | Some (id,_,_) -> id let maximal_insertion_of = function | Some (_,_,(b,_)) -> b | None -> anomaly "Not an implicit argument" let force_inference_of = function | Some (_, _, (_, b)) -> b | None -> anomaly "Not an implicit argument" (* [in_ctx] means we know the expected type, [n] is the index of the argument *) let is_inferable_implicit in_ctx n = function | None -> false | Some (_,DepRigid (Hyp p),_) -> in_ctx or n >= p | Some (_,DepFlex (Hyp p),_) -> false | Some (_,DepFlexAndRigid (_,Hyp q),_) -> in_ctx or n >= q | Some (_,DepRigid Conclusion,_) -> in_ctx | Some (_,DepFlex Conclusion,_) -> false | Some (_,DepFlexAndRigid (_,Conclusion),_) -> in_ctx | Some (_,Manual,_) -> true let positions_of_implicits (_,impls) = let rec aux n = function [] -> [] | Some _ :: l -> n :: aux (n+1) l | None :: l -> aux (n+1) l in aux 1 impls (* Manage user-given implicit arguments *) let rec prepare_implicits f = function | [] -> [] | (Anonymous, Some _)::_ -> anomaly "Unnamed implicit" | (Name id, Some imp)::imps -> let imps' = prepare_implicits f imps in Some (id,imp,(set_maximality imps' f.maximal,true)) :: imps' | _::imps -> None :: prepare_implicits f imps let set_implicit id imp insmax = (id,(match imp with None -> Manual | Some imp -> imp),insmax) let rec assoc_by_pos k = function (ExplByPos (k', x), b) :: tl when k = k' -> (x,b), tl | hd :: tl -> let (x, tl) = assoc_by_pos k tl in x, hd :: tl | [] -> raise Not_found let check_correct_manual_implicits autoimps l = List.iter (function | ExplByName id,(b,fi,forced) -> if not forced then error ("Wrong or non-dependent implicit argument name: "^(string_of_id id)^".") | ExplByPos (i,_id),_t -> if i<1 or i>List.length autoimps then error ("Bad implicit argument number: "^(string_of_int i)^".") else errorlabstrm "" (str "Cannot set implicit argument number " ++ int i ++ str ": it has no name.")) l let set_manual_implicits env flags enriching autoimps l = let try_forced k l = try let (id, (b, fi, fo)), l' = assoc_by_pos k l in if fo then let id = match id with Some id -> id | None -> id_of_string ("arg_" ^ string_of_int k) in l', Some (id,Manual,(b,fi)) else l, None with Not_found -> l, None in if not (list_distinct l) then error ("Some parameters are referred more than once."); (* Compare with automatic implicits to recover printing data and names *) let rec merge k l = function | (Name id,imp)::imps -> let l',imp,m = try let (b, fi, fo) = List.assoc (ExplByName id) l in List.remove_assoc (ExplByName id) l, (Some Manual), (Some (b, fi)) with Not_found -> try let (id, (b, fi, fo)), l' = assoc_by_pos k l in l', (Some Manual), (Some (b,fi)) with Not_found -> l,imp, if enriching && imp <> None then Some (flags.maximal,true) else None in let imps' = merge (k+1) l' imps in let m = Option.map (fun (b,f) -> set_maximality imps' b, f) m in Option.map (set_implicit id imp) m :: imps' | (Anonymous,imp)::imps -> let l', forced = try_forced k l in forced :: merge (k+1) l' imps | [] when l = [] -> [] | [] -> check_correct_manual_implicits autoimps l; [] in merge 1 l autoimps let compute_semi_auto_implicits env f manual t = match manual with | [] -> if not f.auto then [DefaultImpArgs, []] else let _,l = compute_implicits_flags env f false t in [DefaultImpArgs, prepare_implicits f l] | _ -> let _,autoimpls = compute_auto_implicits env f f.auto t in [DefaultImpArgs, set_manual_implicits env f f.auto autoimpls manual] let compute_implicits env t = compute_semi_auto_implicits env !implicit_args [] t (*s Constants. *) let compute_constant_implicits flags manual cst = let env = Global.env () in compute_semi_auto_implicits env flags manual (Typeops.type_of_constant env cst) (*s Inductives and constructors. Their implicit arguments are stored in an array, indexed by the inductive number, of pairs $(i,v)$ where $i$ are the implicit arguments of the inductive and $v$ the array of implicit arguments of the constructors. *) let compute_mib_implicits flags manual kn = let env = Global.env () in let mib = lookup_mind kn env in let ar = Array.to_list (Array.map (* No need to lift, arities contain no de Bruijn *) (fun mip -> (Name mip.mind_typename, None, type_of_inductive env (mib,mip))) mib.mind_packets) in let env_ar = push_rel_context ar env in let imps_one_inductive i mip = let ind = (kn,i) in let ar = type_of_inductive env (mib,mip) in ((IndRef ind,compute_semi_auto_implicits env flags manual ar), Array.mapi (fun j c -> (ConstructRef (ind,j+1),compute_semi_auto_implicits env_ar flags manual c)) mip.mind_nf_lc) in Array.mapi imps_one_inductive mib.mind_packets let compute_all_mib_implicits flags manual kn = let imps = compute_mib_implicits flags manual kn in List.flatten (array_map_to_list (fun (ind,cstrs) -> ind::Array.to_list cstrs) imps) (*s Variables. *) let compute_var_implicits flags manual id = let env = Global.env () in let (_,_,ty) = lookup_named id env in compute_semi_auto_implicits env flags manual ty (* Implicits of a global reference. *) let compute_global_implicits flags manual = function | VarRef id -> compute_var_implicits flags manual id | ConstRef kn -> compute_constant_implicits flags manual kn | IndRef (kn,i) -> let ((_,imps),_) = (compute_mib_implicits flags manual kn).(i) in imps | ConstructRef ((kn,i),j) -> let (_,cimps) = (compute_mib_implicits flags manual kn).(i) in snd cimps.(j-1) (* Merge a manual explicitation with an implicit_status list *) let merge_impls (cond,oldimpls) (_,newimpls) = let oldimpls,usersuffiximpls = list_chop (List.length newimpls) oldimpls in cond, (List.map2 (fun orig ni -> match orig with | Some (_, Manual, _) -> orig | _ -> ni) oldimpls newimpls)@usersuffiximpls (* Caching implicits *) type implicit_interactive_request = | ImplAuto | ImplManual of int type implicit_discharge_request = | ImplLocal | ImplConstant of constant * implicits_flags | ImplMutualInductive of mutual_inductive * implicits_flags | ImplInteractive of global_reference * implicits_flags * implicit_interactive_request let implicits_table = ref Refmap.empty let implicits_of_global ref = try let l = Refmap.find ref !implicits_table in try let rename_l = Arguments_renaming.arguments_names ref in let rename imp name = match imp, name with | Some (_, x,y), Name id -> Some (id, x,y) | _ -> imp in List.map2 (fun (t, il) rl -> t, List.map2 rename il rl) l rename_l with Not_found -> l | Invalid_argument _ -> anomaly "renamings list and implicits list have different lenghts" with Not_found -> [DefaultImpArgs,[]] let cache_implicits_decl (ref,imps) = implicits_table := Refmap.add ref imps !implicits_table let load_implicits _ (_,(_,l)) = List.iter cache_implicits_decl l let cache_implicits o = load_implicits 1 o let subst_implicits_decl subst (r,imps as o) = let r' = fst (subst_global subst r) in if r==r' then o else (r',imps) let subst_implicits (subst,(req,l)) = (ImplLocal,list_smartmap (subst_implicits_decl subst) l) let impls_of_context ctx = List.rev_map (fun (id,impl,_,_) -> if impl = Lib.Implicit then Some (id, Manual, (true,true)) else None) (List.filter (fun (_,_,b,_) -> b = None) ctx) let section_segment_of_reference = function | ConstRef con -> section_segment_of_constant con | IndRef (kn,_) | ConstructRef ((kn,_),_) -> section_segment_of_mutual_inductive kn | _ -> [] let adjust_side_condition p = function | LessArgsThan n -> LessArgsThan (n+p) | DefaultImpArgs -> DefaultImpArgs let add_section_impls vars extra_impls (cond,impls) = let p = List.length vars - List.length extra_impls in adjust_side_condition p cond, extra_impls @ impls let discharge_implicits (_,(req,l)) = match req with | ImplLocal -> None | ImplInteractive (ref,flags,exp) -> (try let vars = section_segment_of_reference ref in let ref' = if isVarRef ref then ref else pop_global_reference ref in let extra_impls = impls_of_context vars in let l' = [ref', List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in Some (ImplInteractive (ref',flags,exp),l') with Not_found -> (* ref not defined in this section *) Some (req,l)) | ImplConstant (con,flags) -> (try let con' = pop_con con in let vars = section_segment_of_constant con in let extra_impls = impls_of_context vars in let l' = [ConstRef con',List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in Some (ImplConstant (con',flags),l') with Not_found -> (* con not defined in this section *) Some (req,l)) | ImplMutualInductive (kn,flags) -> (try let l' = List.map (fun (gr, l) -> let vars = section_segment_of_reference gr in let extra_impls = impls_of_context vars in ((if isVarRef gr then gr else pop_global_reference gr), List.map (add_section_impls vars extra_impls) l)) l in Some (ImplMutualInductive (pop_kn kn,flags),l') with Not_found -> (* ref not defined in this section *) Some (req,l)) let rebuild_implicits (req,l) = match req with | ImplLocal -> assert false | ImplConstant (con,flags) -> let oldimpls = snd (List.hd l) in let newimpls = compute_constant_implicits flags [] con in req, [ConstRef con, List.map2 merge_impls oldimpls newimpls] | ImplMutualInductive (kn,flags) -> let newimpls = compute_all_mib_implicits flags [] kn in let rec aux olds news = match olds, news with | (_, oldimpls) :: old, (gr, newimpls) :: tl -> (gr, List.map2 merge_impls oldimpls newimpls) :: aux old tl | [], [] -> [] | _, _ -> assert false in req, aux l newimpls | ImplInteractive (ref,flags,o) -> (if isVarRef ref && is_in_section ref then ImplLocal else req), match o with | ImplAuto -> let oldimpls = snd (List.hd l) in let newimpls = compute_global_implicits flags [] ref in [ref,List.map2 merge_impls oldimpls newimpls] | ImplManual userimplsize -> let oldimpls = snd (List.hd l) in if flags.auto then let newimpls = List.hd (compute_global_implicits flags [] ref) in let p = List.length (snd newimpls) - userimplsize in let newimpls = on_snd (list_firstn p) newimpls in [ref,List.map (fun o -> merge_impls o newimpls) oldimpls] else [ref,oldimpls] let classify_implicits (req,_ as obj) = if req = ImplLocal then Dispose else Substitute obj type implicits_obj = implicit_discharge_request * (global_reference * implicits_list list) list let inImplicits : implicits_obj -> obj = declare_object {(default_object "IMPLICITS") with cache_function = cache_implicits; load_function = load_implicits; subst_function = subst_implicits; classify_function = classify_implicits; discharge_function = discharge_implicits; rebuild_function = rebuild_implicits } let is_local local ref = local || isVarRef ref && is_in_section ref let declare_implicits_gen req flags ref = let imps = compute_global_implicits flags [] ref in add_anonymous_leaf (inImplicits (req,[ref,imps])) let declare_implicits local ref = let flags = { !implicit_args with auto = true } in let req = if is_local local ref then ImplLocal else ImplInteractive(ref,flags,ImplAuto) in declare_implicits_gen req flags ref let declare_var_implicits id = let flags = !implicit_args in declare_implicits_gen ImplLocal flags (VarRef id) let declare_constant_implicits con = let flags = !implicit_args in declare_implicits_gen (ImplConstant (con,flags)) flags (ConstRef con) let declare_mib_implicits kn = let flags = !implicit_args in let imps = array_map_to_list (fun (ind,cstrs) -> ind::(Array.to_list cstrs)) (compute_mib_implicits flags [] kn) in add_anonymous_leaf (inImplicits (ImplMutualInductive (kn,flags),List.flatten imps)) (* Declare manual implicits *) type manual_explicitation = Topconstr.explicitation * (bool * bool * bool) type manual_implicits = manual_explicitation list let compute_implicits_with_manual env typ enriching l = let _,autoimpls = compute_auto_implicits env !implicit_args enriching typ in set_manual_implicits env !implicit_args enriching autoimpls l let check_inclusion l = (* Check strict inclusion *) let rec aux = function | n1::(n2::_ as nl) -> if n1 <= n2 then error "Sequences of implicit arguments must be of different lengths"; aux nl | _ -> () in aux (List.map (fun (imps,_) -> List.length imps) l) let check_rigidity isrigid = if not isrigid then errorlabstrm "" (strbrk "Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.") let declare_manual_implicits local ref ?enriching l = let flags = !implicit_args in let env = Global.env () in let t = Global.type_of_global ref in let enriching = Option.default flags.auto enriching in let isrigid,autoimpls = compute_auto_implicits env flags enriching t in let l' = match l with | [] -> assert false | [l] -> [DefaultImpArgs, set_manual_implicits env flags enriching autoimpls l] | _ -> check_rigidity isrigid; let l = List.map (fun imps -> (imps,List.length imps)) l in let l = Sort.list (fun (_,n1) (_,n2) -> n1 > n2) l in check_inclusion l; let nargs = List.length autoimpls in List.map (fun (imps,n) -> (LessArgsThan (nargs-n), set_manual_implicits env flags enriching autoimpls imps)) l in let req = if is_local local ref then ImplLocal else ImplInteractive(ref,flags,ImplManual (List.length autoimpls)) in add_anonymous_leaf (inImplicits (req,[ref,l'])) let maybe_declare_manual_implicits local ref ?enriching l = if l = [] then () else declare_manual_implicits local ref ?enriching [l] let extract_impargs_data impls = let rec aux p = function | (DefaultImpArgs, imps)::_ -> [None,imps] | (LessArgsThan n, imps)::l -> (Some (p,n),imps) :: aux (n+1) l | [] -> [] in aux 0 impls let lift_implicits n = List.map (fun x -> match fst x with ExplByPos (k, id) -> ExplByPos (k + n, id), snd x | _ -> x) let make_implicits_list l = [DefaultImpArgs, l] let rec drop_first_implicits p l = if p = 0 then l else match l with | _,[] as x -> x | DefaultImpArgs,imp::impls -> drop_first_implicits (p-1) (DefaultImpArgs,impls) | LessArgsThan n,imp::impls -> let n = if is_status_implicit imp then n-1 else n in drop_first_implicits (p-1) (LessArgsThan n,impls) let rec select_impargs_size n = function | [] -> [] (* Tolerance for (DefaultImpArgs,[]) *) | [_, impls] | (DefaultImpArgs, impls)::_ -> impls | (LessArgsThan p, impls)::l -> if n <= p then impls else select_impargs_size n l let rec select_stronger_impargs = function | [] -> [] (* Tolerance for (DefaultImpArgs,[]) *) | (_,impls)::_ -> impls (*s Registration as global tables *) let init () = implicits_table := Refmap.empty let freeze () = !implicits_table let unfreeze t = implicits_table := t let _ = Summary.declare_summary "implicits" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = init } coq-8.4pl4/library/nameops.ml0000644000175000017500000001001312326224777015266 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* str "_" | Name id -> pr_id id (* Utilities *) let code_of_0 = Char.code '0' let code_of_9 = Char.code '9' let cut_ident skip_quote s = let s = string_of_id s in let slen = String.length s in (* [n'] is the position of the first non nullary digit *) let rec numpart n n' = if n = 0 then (* ident made of _ and digits only [and ' if skip_quote]: don't cut it *) slen else let c = Char.code (String.get s (n-1)) in if c = code_of_0 && n <> slen then numpart (n-1) n' else if code_of_0 <= c && c <= code_of_9 then numpart (n-1) (n-1) else if skip_quote & (c = Char.code '\'' || c = Char.code '_') then numpart (n-1) (n-1) else n' in numpart slen slen let repr_ident s = let numstart = cut_ident false s in let s = string_of_id s in let slen = String.length s in if numstart = slen then (s, None) else (String.sub s 0 numstart, Some (int_of_string (String.sub s numstart (slen - numstart)))) let make_ident sa = function | Some n -> let c = Char.code (String.get sa (String.length sa -1)) in let s = if c < code_of_0 or c > code_of_9 then sa ^ (string_of_int n) else sa ^ "_" ^ (string_of_int n) in id_of_string s | None -> id_of_string (String.copy sa) let root_of_id id = let suffixstart = cut_ident true id in id_of_string (String.sub (string_of_id id) 0 suffixstart) (* Rem: semantics is a bit different, if an ident starts with toto00 then after successive renamings it comes to toto09, then it goes on with toto10 *) let lift_subscript id = let id = string_of_id id in let len = String.length id in let rec add carrypos = let c = id.[carrypos] in if is_digit c then if c = '9' then begin assert (carrypos>0); add (carrypos-1) end else begin let newid = String.copy id in String.fill newid (carrypos+1) (len-1-carrypos) '0'; newid.[carrypos] <- Char.chr (Char.code c + 1); newid end else begin let newid = id^"0" in if carrypos < len-1 then begin String.fill newid (carrypos+1) (len-1-carrypos) '0'; newid.[carrypos+1] <- '1' end; newid end in id_of_string (add (len-1)) let has_subscript id = let id = string_of_id id in is_digit (id.[String.length id - 1]) let forget_subscript id = let numstart = cut_ident false id in let newid = String.make (numstart+1) '0' in String.blit (string_of_id id) 0 newid 0 numstart; (id_of_string newid) let add_suffix id s = id_of_string (string_of_id id ^ s) let add_prefix s id = id_of_string (s ^ string_of_id id) let atompart_of_id id = fst (repr_ident id) (* Names *) let out_name = function | Name id -> id | Anonymous -> failwith "out_name: expects a defined name" let name_fold f na a = match na with | Name id -> f id a | Anonymous -> a let name_iter f na = name_fold (fun x () -> f x) na () let name_cons na l = match na with | Anonymous -> l | Name id -> id::l let name_app f = function | Name id -> Name (f id) | Anonymous -> Anonymous let name_fold_map f e = function | Name id -> let (e,id) = f e id in (e,Name id) | Anonymous -> e,Anonymous let pr_lab l = str (string_of_label l) let default_library = Names.initial_dir (* = ["Top"] *) (*s Roots of the space of absolute names *) let coq_root = id_of_string "Coq" let default_root_prefix = make_dirpath [] (* Metavariables *) let pr_meta = Pp.int let string_of_meta = string_of_int coq-8.4pl4/library/summary.ml0000644000175000017500000000352612326224777015334 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a; unfreeze_function : 'a -> unit; init_function : unit -> unit } let summaries = (Hashtbl.create 17 : (string, Dyn.t summary_declaration) Hashtbl.t) let internal_declare_summary sumname sdecl = let (infun,outfun) = Dyn.create sumname in let dyn_freeze () = infun (sdecl.freeze_function()) and dyn_unfreeze sum = sdecl.unfreeze_function (outfun sum) and dyn_init = sdecl.init_function in let ddecl = { freeze_function = dyn_freeze; unfreeze_function = dyn_unfreeze; init_function = dyn_init } in if Hashtbl.mem summaries sumname then anomalylabstrm "Summary.declare_summary" (str "Cannot declare a summary twice: " ++ str sumname); Hashtbl.add summaries sumname ddecl let declare_summary sumname decl = internal_declare_summary (sumname^"-SUMMARY") decl type frozen = Dyn.t Stringmap.t let freeze_summaries () = let m = ref Stringmap.empty in Hashtbl.iter (fun id decl -> m := Stringmap.add id (decl.freeze_function()) !m) summaries; !m let unfreeze_summaries fs = Hashtbl.iter (fun id decl -> try decl.unfreeze_function (Stringmap.find id fs) with Not_found -> decl.init_function()) summaries let init_summaries () = Hashtbl.iter (fun _ decl -> decl.init_function()) summaries coq-8.4pl4/library/nametab.mli0000644000175000017500000001436312326224777015420 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* full_user_name -> object_reference -> unit] Registers the [object_reference] to be referred to by the [full_user_name] (and its suffixes according to [visibility]). [full_user_name] can either be a [full_path] or a [dir_path]. } {- [exists : full_user_name -> bool] Is the [full_user_name] already atributed as an absolute user name of some object? } {- [locate : qualid -> object_reference] Finds the object referred to by [qualid] or raises [Not_found] } {- [full_name : qualid -> full_user_name] Finds the full user name referred to by [qualid] or raises [Not_found] } {- [shortest_qualid_of : object_reference -> user_name] The [user_name] can be for example the shortest non ambiguous [qualid] or the [full_user_name] or [identifier]. Such a function can also have a local context argument.}} *) exception GlobalizationError of qualid exception GlobalizationConstantError of qualid (** Raises a globalization error *) val error_global_not_found_loc : loc -> qualid -> 'a val error_global_not_found : qualid -> 'a val error_global_constant_not_found_loc : loc -> qualid -> 'a (** {6 Register visibility of things } *) (** The visibility can be registered either - for all suffixes not shorter then a given int -- when the object is loaded inside a module -- or - for a precise suffix, when the module containing (the module containing ...) the object is opened (imported) *) type visibility = Until of int | Exactly of int val push : visibility -> full_path -> global_reference -> unit val push_modtype : visibility -> full_path -> module_path -> unit val push_dir : visibility -> dir_path -> global_dir_reference -> unit val push_syndef : visibility -> full_path -> syndef_name -> unit type ltac_constant = kernel_name val push_tactic : visibility -> full_path -> ltac_constant -> unit (** {6 The following functions perform globalization of qualified names } *) (** These functions globalize a (partially) qualified name or fail with [Not_found] *) val locate : qualid -> global_reference val locate_extended : qualid -> extended_global_reference val locate_constant : qualid -> constant val locate_syndef : qualid -> syndef_name val locate_modtype : qualid -> module_path val locate_dir : qualid -> global_dir_reference val locate_module : qualid -> module_path val locate_section : qualid -> dir_path val locate_tactic : qualid -> ltac_constant (** These functions globalize user-level references into global references, like [locate] and co, but raise a nice error message in case of failure *) val global : reference -> global_reference val global_inductive : reference -> inductive (** These functions locate all global references with a given suffix; if [qualid] is valid as such, it comes first in the list *) val locate_all : qualid -> global_reference list val locate_extended_all : qualid -> extended_global_reference list (** Mapping a full path to a global reference *) val global_of_path : full_path -> global_reference val extended_global_of_path : full_path -> extended_global_reference (** {6 These functions tell if the given absolute name is already taken } *) val exists_cci : full_path -> bool val exists_modtype : full_path -> bool val exists_dir : dir_path -> bool val exists_section : dir_path -> bool (** deprecated synonym of [exists_dir] *) val exists_module : dir_path -> bool (** deprecated synonym of [exists_dir] *) (** {6 These functions locate qualids into full user names } *) val full_name_cci : qualid -> full_path val full_name_modtype : qualid -> full_path val full_name_module : qualid -> dir_path (** {6 Reverse lookup } Finding user names corresponding to the given internal name *) (** Returns the full path bound to a global reference or syntactic definition, and the (full) dirpath associated to a module path *) val path_of_syndef : syndef_name -> full_path val path_of_global : global_reference -> full_path val dirpath_of_module : module_path -> dir_path val path_of_tactic : ltac_constant -> full_path (** Returns in particular the dirpath or the basename of the full path associated to global reference *) val dirpath_of_global : global_reference -> dir_path val basename_of_global : global_reference -> identifier (** Printing of global references using names as short as possible *) val pr_global_env : Idset.t -> global_reference -> std_ppcmds (** The [shortest_qualid] functions given an object with [user_name] Coq.A.B.x, try to find the shortest among x, B.x, A.B.x and Coq.A.B.x that denotes the same object. *) val shortest_qualid_of_global : Idset.t -> global_reference -> qualid val shortest_qualid_of_syndef : Idset.t -> syndef_name -> qualid val shortest_qualid_of_modtype : module_path -> qualid val shortest_qualid_of_module : module_path -> qualid val shortest_qualid_of_tactic : ltac_constant -> qualid (** Deprecated synonyms *) val extended_locate : qualid -> extended_global_reference (*= locate_extended *) val absolute_reference : full_path -> global_reference (** = global_of_path *) coq-8.4pl4/library/libobject.ml0000644000175000017500000001443412326224777015574 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit; load_function : int -> object_name * 'a -> unit; open_function : int -> object_name * 'a -> unit; classify_function : 'a -> 'a substitutivity; subst_function : substitution * 'a -> 'a; discharge_function : object_name * 'a -> 'a option; rebuild_function : 'a -> 'a } let yell s = anomaly s let default_object s = { object_name = s; cache_function = (fun _ -> ()); load_function = (fun _ _ -> ()); open_function = (fun _ _ -> ()); subst_function = (fun _ -> yell ("The object "^s^" does not know how to substitute!")); classify_function = (fun obj -> Keep obj); discharge_function = (fun _ -> None); rebuild_function = (fun x -> x)} (* The suggested object declaration is the following: declare_object { (default_object "MY OBJECT") with cache_function = fun (sp,a) -> Mytbl.add sp a} and the listed functions are only those which definitions actually differ from the default. This helps introducing new functions in objects. *) let ident_subst_function (_,a) = a type obj = Dyn.t (* persistent dynamic objects *) type dynamic_object_declaration = { dyn_cache_function : object_name * obj -> unit; dyn_load_function : int -> object_name * obj -> unit; dyn_open_function : int -> object_name * obj -> unit; dyn_subst_function : substitution * obj -> obj; dyn_classify_function : obj -> obj substitutivity; dyn_discharge_function : object_name * obj -> obj option; dyn_rebuild_function : obj -> obj } let object_tag lobj = Dyn.tag lobj let cache_tab = (Hashtbl.create 17 : (string,dynamic_object_declaration) Hashtbl.t) let declare_object_full odecl = let na = odecl.object_name in let (infun,outfun) = Dyn.create na in let cacher (oname,lobj) = if Dyn.tag lobj = na then odecl.cache_function (oname,outfun lobj) else anomaly "somehow we got the wrong dynamic object in the cachefun" and loader i (oname,lobj) = if Dyn.tag lobj = na then odecl.load_function i (oname,outfun lobj) else anomaly "somehow we got the wrong dynamic object in the loadfun" and opener i (oname,lobj) = if Dyn.tag lobj = na then odecl.open_function i (oname,outfun lobj) else anomaly "somehow we got the wrong dynamic object in the openfun" and substituter (sub,lobj) = if Dyn.tag lobj = na then infun (odecl.subst_function (sub,outfun lobj)) else anomaly "somehow we got the wrong dynamic object in the substfun" and classifier lobj = if Dyn.tag lobj = na then match odecl.classify_function (outfun lobj) with | Dispose -> Dispose | Substitute obj -> Substitute (infun obj) | Keep obj -> Keep (infun obj) | Anticipate (obj) -> Anticipate (infun obj) else anomaly "somehow we got the wrong dynamic object in the classifyfun" and discharge (oname,lobj) = if Dyn.tag lobj = na then Option.map infun (odecl.discharge_function (oname,outfun lobj)) else anomaly "somehow we got the wrong dynamic object in the dischargefun" and rebuild lobj = if Dyn.tag lobj = na then infun (odecl.rebuild_function (outfun lobj)) else anomaly "somehow we got the wrong dynamic object in the rebuildfun" in Hashtbl.add cache_tab na { dyn_cache_function = cacher; dyn_load_function = loader; dyn_open_function = opener; dyn_subst_function = substituter; dyn_classify_function = classifier; dyn_discharge_function = discharge; dyn_rebuild_function = rebuild }; (infun,outfun) let declare_object odecl = fst (declare_object_full odecl) let missing_tab = (Hashtbl.create 17 : (string, unit) Hashtbl.t) (* this function describes how the cache, load, open, and export functions are triggered. In relaxed mode, this function just return a meaningless value instead of raising an exception when they fail. *) let apply_dyn_fun deflt f lobj = let tag = object_tag lobj in try let dodecl = try Hashtbl.find cache_tab tag with Not_found -> failwith "local to_apply_dyn_fun" in f dodecl with Failure "local to_apply_dyn_fun" -> if not (!relax_flag || Hashtbl.mem missing_tab tag) then begin Pp.msg_warning (Pp.str ("Cannot find library functions for an object with tag " ^ tag ^ " (a plugin may be missing)")); Hashtbl.add missing_tab tag () end; deflt let cache_object ((_,lobj) as node) = apply_dyn_fun () (fun d -> d.dyn_cache_function node) lobj let load_object i ((_,lobj) as node) = apply_dyn_fun () (fun d -> d.dyn_load_function i node) lobj let open_object i ((_,lobj) as node) = apply_dyn_fun () (fun d -> d.dyn_open_function i node) lobj let subst_object ((_,lobj) as node) = apply_dyn_fun lobj (fun d -> d.dyn_subst_function node) lobj let classify_object lobj = apply_dyn_fun Dispose (fun d -> d.dyn_classify_function lobj) lobj let discharge_object ((_,lobj) as node) = apply_dyn_fun None (fun d -> d.dyn_discharge_function node) lobj let rebuild_object lobj = apply_dyn_fun lobj (fun d -> d.dyn_rebuild_function lobj) lobj coq-8.4pl4/library/libnames.mli0000644000175000017500000001450312326224777015577 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool val isConstRef : global_reference -> bool val isIndRef : global_reference -> bool val isConstructRef : global_reference -> bool val eq_gr : global_reference -> global_reference -> bool val canonical_gr : global_reference -> global_reference val destVarRef : global_reference -> variable val destConstRef : global_reference -> constant val destIndRef : global_reference -> inductive val destConstructRef : global_reference -> constructor val subst_constructor : substitution -> constructor -> constructor * constr val subst_global : substitution -> global_reference -> global_reference * constr (** Turn a global reference into a construction *) val constr_of_global : global_reference -> constr (** Turn a construction denoting a global reference into a global reference; raise [Not_found] if not a global reference *) val global_of_constr : constr -> global_reference (** Obsolete synonyms for constr_of_global and global_of_constr *) val constr_of_reference : global_reference -> constr val reference_of_constr : constr -> global_reference module RefOrdered : sig type t = global_reference val compare : global_reference -> global_reference -> int end module RefOrdered_env : sig type t = global_reference val compare : global_reference -> global_reference -> int end module Refset : Set.S with type elt = global_reference module Refmap : Map.S with type key = global_reference (** {6 Extended global references } *) type syndef_name = kernel_name type extended_global_reference = | TrueGlobal of global_reference | SynDef of syndef_name module ExtRefOrdered : sig type t = extended_global_reference val compare : t -> t -> int end (** {6 Dirpaths } *) val pr_dirpath : dir_path -> Pp.std_ppcmds val dirpath_of_string : string -> dir_path val string_of_dirpath : dir_path -> string (** Pop the suffix of a [dir_path] *) val pop_dirpath : dir_path -> dir_path (** Pop the suffix n times *) val pop_dirpath_n : int -> dir_path -> dir_path (** Give the immediate prefix and basename of a [dir_path] *) val split_dirpath : dir_path -> dir_path * identifier val add_dirpath_suffix : dir_path -> module_ident -> dir_path val add_dirpath_prefix : module_ident -> dir_path -> dir_path val chop_dirpath : int -> dir_path -> dir_path * dir_path val append_dirpath : dir_path -> dir_path -> dir_path val drop_dirpath_prefix : dir_path -> dir_path -> dir_path val is_dirpath_prefix_of : dir_path -> dir_path -> bool module Dirset : Set.S with type elt = dir_path module Dirmap : Map.S with type key = dir_path (** {6 Full paths are {e absolute} paths of declarations } *) type full_path (** Constructors of [full_path] *) val make_path : dir_path -> identifier -> full_path (** Destructors of [full_path] *) val repr_path : full_path -> dir_path * identifier val dirpath : full_path -> dir_path val basename : full_path -> identifier (** Parsing and printing of section path as ["coq_root.module.id"] *) val path_of_string : string -> full_path val string_of_path : full_path -> string val pr_path : full_path -> std_ppcmds module Spmap : Map.S with type key = full_path val restrict_path : int -> full_path -> full_path (** {6 Temporary function to brutally form kernel names from section paths } *) val encode_mind : dir_path -> identifier -> mutual_inductive val decode_mind : mutual_inductive -> dir_path * identifier val encode_con : dir_path -> identifier -> constant val decode_con : constant -> dir_path * identifier (** {6 ... } *) (** A [qualid] is a partially qualified ident; it includes fully qualified names (= absolute names) and all intermediate partial qualifications of absolute names, including single identifiers. The [qualid] are used to access the name table. *) type qualid val make_qualid : dir_path -> identifier -> qualid val repr_qualid : qualid -> dir_path * identifier val pr_qualid : qualid -> std_ppcmds val string_of_qualid : qualid -> string val qualid_of_string : string -> qualid (** Turns an absolute name, a dirpath, or an identifier into a qualified name denoting the same name *) val qualid_of_path : full_path -> qualid val qualid_of_dirpath : dir_path -> qualid val qualid_of_ident : identifier -> qualid (** Both names are passed to objects: a "semantic" [kernel_name], which can be substituted and a "syntactic" [full_path] which can be printed *) type object_name = full_path * kernel_name type object_prefix = dir_path * (module_path * dir_path) val make_oname : object_prefix -> identifier -> object_name (** to this type are mapped [dir_path]'s in the nametab *) type global_dir_reference = | DirOpenModule of object_prefix | DirOpenModtype of object_prefix | DirOpenSection of object_prefix | DirModule of object_prefix | DirClosedSection of dir_path (** this won't last long I hope! *) (** {6 ... } *) (** A [reference] is the user-level notion of name. It denotes either a global name (referred either by a qualified name or by a single name) or a variable *) type reference = | Qualid of qualid located | Ident of identifier located val qualid_of_reference : reference -> qualid located val string_of_reference : reference -> string val pr_reference : reference -> std_ppcmds val loc_of_reference : reference -> loc (** {6 Popping one level of section in global names } *) val pop_con : constant -> constant val pop_kn : mutual_inductive-> mutual_inductive val pop_global_reference : global_reference -> global_reference (** Deprecated synonyms *) val make_short_qualid : identifier -> qualid (** = qualid_of_ident *) val qualid_of_sp : full_path -> qualid (** = qualid_of_path *) coq-8.4pl4/library/goptions.ml0000644000175000017500000003017012326224777015474 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit method remove : 'a -> unit method mem : 'a -> unit method print : unit end module MakeTable = functor (A : sig type t type key val table : (string * key table_of_A) list ref val encode : key -> t val subst : substitution -> t -> t val printer : t -> std_ppcmds val key : option_name val title : string val member_message : t -> bool -> std_ppcmds val synchronous : bool end) -> struct type option_mark = | GOadd | GOrmv let nick = nickname A.key let _ = if List.mem_assoc nick !A.table then error "Sorry, this table name is already used." module MySet = Set.Make (struct type t = A.t let compare = compare end) let t = ref (MySet.empty : MySet.t) let _ = if A.synchronous then let freeze () = !t in let unfreeze c = t := c in let init () = t := MySet.empty in Summary.declare_summary nick { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = init } let (add_option,remove_option) = if A.synchronous then let cache_options (_,(f,p)) = match f with | GOadd -> t := MySet.add p !t | GOrmv -> t := MySet.remove p !t in let load_options i o = if i=1 then cache_options o in let subst_options (subst,(f,p as obj)) = let p' = A.subst subst p in if p' == p then obj else (f,p') in let inGo : option_mark * A.t -> obj = Libobject.declare_object {(Libobject.default_object nick) with Libobject.load_function = load_options; Libobject.open_function = load_options; Libobject.cache_function = cache_options; Libobject.subst_function = subst_options; Libobject.classify_function = (fun x -> Substitute x)} in ((fun c -> Lib.add_anonymous_leaf (inGo (GOadd, c))), (fun c -> Lib.add_anonymous_leaf (inGo (GOrmv, c)))) else ((fun c -> t := MySet.add c !t), (fun c -> t := MySet.remove c !t)) let print_table table_name printer table = msg (str table_name ++ (hov 0 (if MySet.is_empty table then str "None" ++ fnl () else MySet.fold (fun a b -> printer a ++ spc () ++ b) table (mt ()) ++ fnl ()))) class table_of_A () = object method add x = add_option (A.encode x) method remove x = remove_option (A.encode x) method mem x = let y = A.encode x in let answer = MySet.mem y !t in msg (A.member_message y answer ++ fnl ()) method print = print_table A.title A.printer !t end let _ = A.table := (nick,new table_of_A ())::!A.table let active c = MySet.mem c !t let elements () = MySet.elements !t end let string_table = ref [] let get_string_table k = List.assoc (nickname k) !string_table module type StringConvertArg = sig val key : option_name val title : string val member_message : string -> bool -> std_ppcmds val synchronous : bool end module StringConvert = functor (A : StringConvertArg) -> struct type t = string type key = string let table = string_table let encode x = x let subst _ x = x let printer = str let key = A.key let title = A.title let member_message = A.member_message let synchronous = A.synchronous end module MakeStringTable = functor (A : StringConvertArg) -> MakeTable (StringConvert(A)) let ref_table = ref [] let get_ref_table k = List.assoc (nickname k) !ref_table module type RefConvertArg = sig type t val encode : reference -> t val subst : substitution -> t -> t val printer : t -> std_ppcmds val key : option_name val title : string val member_message : t -> bool -> std_ppcmds val synchronous : bool end module RefConvert = functor (A : RefConvertArg) -> struct type t = A.t type key = reference let table = ref_table let encode = A.encode let subst = A.subst let printer = A.printer let key = A.key let title = A.title let member_message = A.member_message let synchronous = A.synchronous end module MakeRefTable = functor (A : RefConvertArg) -> MakeTable (RefConvert(A)) (****************************************************************************) (* 2- Flags. *) type 'a option_sig = { optsync : bool; optdepr : bool; optname : string; optkey : option_name; optread : unit -> 'a; optwrite : 'a -> unit } type option_type = bool * (unit -> option_value) -> (option_value -> unit) module OptionMap = Map.Make (struct type t = option_name let compare = compare end) let value_tab = ref OptionMap.empty (* This raises Not_found if option of key [key] is unknown *) let get_option key = OptionMap.find key !value_tab let check_key key = try let _ = get_option key in error "Sorry, this option name is already used." with Not_found -> if List.mem_assoc (nickname key) !string_table or List.mem_assoc (nickname key) !ref_table then error "Sorry, this option name is already used." open Summary open Libobject open Lib let declare_option cast uncast { optsync=sync; optdepr=depr; optname=name; optkey=key; optread=read; optwrite=write } = check_key key; let default = read() in (* spiwack: I use two spaces in the nicknames of "local" and "global" objects. That way I shouldn't collide with [nickname key] for any [key]. As [key]-s are lists of strings *without* spaces. *) let (write,lwrite,gwrite) = if sync then let ldecl_obj = (* "Local": doesn't survive section or modules. *) declare_object {(default_object ("L "^nickname key)) with cache_function = (fun (_,v) -> write v); classify_function = (fun _ -> Dispose)} in let decl_obj = (* default locality: survives sections but not modules. *) declare_object {(default_object (nickname key)) with cache_function = (fun (_,v) -> write v); classify_function = (fun _ -> Dispose); discharge_function = (fun (_,v) -> Some v)} in let gdecl_obj = (* "Global": survives section and modules. *) declare_object {(default_object ("G "^nickname key)) with cache_function = (fun (_,v) -> write v); classify_function = (fun v -> Substitute v); subst_function = (fun (_,v) -> v); discharge_function = (fun (_,v) -> Some v); load_function = (fun _ (_,v) -> write v)} in let _ = declare_summary (nickname key) { freeze_function = read; unfreeze_function = write; init_function = (fun () -> write default) } in begin fun v -> add_anonymous_leaf (decl_obj v) end , begin fun v -> add_anonymous_leaf (ldecl_obj v) end , begin fun v -> add_anonymous_leaf (gdecl_obj v) end else write,write,write in let cread () = cast (read ()) in let cwrite v = write (uncast v) in let clwrite v = lwrite (uncast v) in let cgwrite v = gwrite (uncast v) in value_tab := OptionMap.add key (name, depr, (sync,cread,cwrite,clwrite,cgwrite)) !value_tab; write type 'a write_function = 'a -> unit let declare_int_option = declare_option (fun v -> IntValue v) (function IntValue v -> v | _ -> anomaly "async_option") let declare_bool_option = declare_option (fun v -> BoolValue v) (function BoolValue v -> v | _ -> anomaly "async_option") let declare_string_option = declare_option (fun v -> StringValue v) (function StringValue v -> v | _ -> anomaly "async_option") (* 3- User accessible commands *) (* Setting values of options *) let set_option_value locality check_and_cast key v = let (name, depr, (_,read,write,lwrite,gwrite)) = try get_option key with Not_found -> error ("There is no option "^(nickname key)^".") in let write = match locality with | None -> write | Some true -> lwrite | Some false -> gwrite in write (check_and_cast v (read ())) let bad_type_error () = error "Bad type of value for this option." let check_int_value v = function | IntValue _ -> IntValue v | _ -> bad_type_error () let check_bool_value v = function | BoolValue _ -> BoolValue v | _ -> bad_type_error () let check_string_value v = function | StringValue _ -> StringValue v | _ -> bad_type_error () let check_unset_value v = function | BoolValue _ -> BoolValue false | IntValue _ -> IntValue None | _ -> bad_type_error () (* Nota: For compatibility reasons, some errors are treated as warning. This allows a script to refer to an option that doesn't exist anymore *) let set_int_option_value_gen locality = set_option_value locality check_int_value let set_bool_option_value_gen locality key v = try set_option_value locality check_bool_value key v with UserError (_,s) -> Flags.if_warn msg_warning s let set_string_option_value_gen locality = set_option_value locality check_string_value let unset_option_value_gen locality key = try set_option_value locality check_unset_value key () with UserError (_,s) -> Flags.if_warn msg_warning s let set_int_option_value = set_int_option_value_gen None let set_bool_option_value = set_bool_option_value_gen None let set_string_option_value = set_string_option_value_gen None (* Printing options/tables *) let msg_option_value (name,v) = match v with | BoolValue true -> str "true" | BoolValue false -> str "false" | IntValue (Some n) -> int n | IntValue None -> str "undefined" | StringValue s -> str s (* | IdentValue r -> pr_global_env Idset.empty r *) let print_option_value key = let (name, depr, (_,read,_,_,_)) = get_option key in let s = read () in match s with | BoolValue b -> msg (str ("The "^name^" mode is "^(if b then "on" else "off")) ++ fnl ()) | _ -> msg (str ("Current value of "^name^" is ") ++ msg_option_value (name,s) ++ fnl ()) let get_tables () = let tables = !value_tab in let fold key (name, depr, (sync,read,_,_,_)) accu = let state = { opt_sync = sync; opt_name = name; opt_depr = depr; opt_value = read (); } in OptionMap.add key state accu in OptionMap.fold fold tables OptionMap.empty let print_tables () = let print_option key name value depr = let msg = str (" "^(nickname key)^": ") ++ msg_option_value (name, value) in if depr then msg ++ str " [DEPRECATED]" ++ fnl () else msg ++ fnl () in msg (str "Synchronous options:" ++ fnl () ++ OptionMap.fold (fun key (name, depr, (sync,read,_,_,_)) p -> if sync then p ++ print_option key name (read ()) depr else p) !value_tab (mt ()) ++ str "Asynchronous options:" ++ fnl () ++ OptionMap.fold (fun key (name, depr, (sync,read,_,_,_)) p -> if sync then p else p ++ print_option key name (read ()) depr) !value_tab (mt ()) ++ str "Tables:" ++ fnl () ++ List.fold_right (fun (nickkey,_) p -> p ++ str (" "^nickkey) ++ fnl ()) !string_table (mt ()) ++ List.fold_right (fun (nickkey,_) p -> p ++ str (" "^nickkey) ++ fnl ()) !ref_table (mt ()) ++ fnl () ) coq-8.4pl4/library/heads.mli0000644000175000017500000000210712326224777015066 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit (** [is_rigid] tells if some term is known to ultimately reduce to a term with a rigid head symbol *) val is_rigid : env -> constr -> bool coq-8.4pl4/library/decl_kinds.mli0000644000175000017500000000441412326224777016104 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* logical_kind val string_of_theorem_kind : theorem_kind -> string val string_of_definition_kind : locality * definition_object_kind -> string (** About locality *) val strength_of_global : global_reference -> locality val string_of_strength : locality -> string (** About recursive power of type declarations *) type recursivity_kind = | Finite (** = inductive *) | CoFinite (** = coinductive *) | BiFinite (** = non-recursive, like in "Record" definitions *) (** helper, converts to "finiteness flag" booleans *) val recursivity_flag_of_kind : recursivity_kind -> bool coq-8.4pl4/library/lib.ml0000644000175000017500000005333512326224777014410 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* f i (make_oname prefix id, obj)) let load_objects = iter_objects load_object let open_objects = iter_objects open_object let subst_objects subst seg = let subst_one = fun (id,obj as node) -> let obj' = subst_object (subst,obj) in if obj' == obj then node else (id, obj') in list_smartmap subst_one seg (*let load_and_subst_objects i prefix subst seg = List.rev (List.fold_left (fun seg (id,obj as node) -> let obj' = subst_object (make_oname prefix id, subst, obj) in let node = if obj == obj' then node else (id, obj') in load_object i (make_oname prefix id, obj'); node :: seg) [] seg) *) let classify_segment seg = let rec clean ((substl,keepl,anticipl) as acc) = function | (_,CompilingLibrary _) :: _ | [] -> acc | ((sp,kn),Leaf o) :: stk -> let id = Names.id_of_label (Names.label kn) in (match classify_object o with | Dispose -> clean acc stk | Keep o' -> clean (substl, (id,o')::keepl, anticipl) stk | Substitute o' -> clean ((id,o')::substl, keepl, anticipl) stk | Anticipate o' -> clean (substl, keepl, o'::anticipl) stk) | (_,ClosedSection _) :: stk -> clean acc stk (* LEM; TODO: Understand what this does and see if what I do is the correct thing for ClosedMod(ule|type) *) | (_,ClosedModule _) :: stk -> clean acc stk | (_,OpenedSection _) :: _ -> error "there are still opened sections" | (_,OpenedModule (ty,_,_,_)) :: _ -> error ("there are still opened " ^ module_kind ty ^"s") | (_,FrozenState _) :: stk -> clean acc stk in clean ([],[],[]) (List.rev seg) let segment_of_objects prefix = List.map (fun (id,obj) -> (make_oname prefix id, Leaf obj)) (* We keep trace of operations in the stack [lib_stk]. [path_prefix] is the current path of sections, where sections are stored in ``correct'' order, the oldest coming first in the list. It may seems costly, but in practice there is not so many openings and closings of sections, but on the contrary there are many constructions of section paths based on the library path. *) let initial_prefix = default_library,(Names.initial_path,Names.empty_dirpath) let lib_stk = ref ([] : library_segment) let comp_name = ref None let library_dp () = match !comp_name with Some m -> m | None -> default_library (* [path_prefix] is a pair of absolute dirpath and a pair of current module path and relative section path *) let path_prefix = ref initial_prefix let sections_depth () = List.length (Names.repr_dirpath (snd (snd !path_prefix))) let sections_are_opened () = match Names.repr_dirpath (snd (snd !path_prefix)) with [] -> false | _ -> true let cwd () = fst !path_prefix let cwd_except_section () = Libnames.pop_dirpath_n (sections_depth ()) (cwd ()) let current_dirpath sec = Libnames.drop_dirpath_prefix (library_dp ()) (if sec then cwd () else cwd_except_section ()) let make_path id = Libnames.make_path (cwd ()) id let make_path_except_section id = Libnames.make_path (cwd_except_section ()) id let path_of_include () = let dir = Names.repr_dirpath (cwd ()) in let new_dir = List.tl dir in let id = List.hd dir in Libnames.make_path (Names.make_dirpath new_dir) id let current_prefix () = snd !path_prefix let make_kn id = let mp,dir = current_prefix () in Names.make_kn mp dir (Names.label_of_id id) let make_con id = let mp,dir = current_prefix () in Names.make_con mp dir (Names.label_of_id id) let make_oname id = make_path id, make_kn id let recalc_path_prefix () = let rec recalc = function | (sp, OpenedSection (dir,_)) :: _ -> dir | (sp, OpenedModule (_,_,dir,_)) :: _ -> dir | (sp, CompilingLibrary dir) :: _ -> dir | _::l -> recalc l | [] -> initial_prefix in path_prefix := recalc !lib_stk let pop_path_prefix () = let dir,(mp,sec) = !path_prefix in path_prefix := fst (split_dirpath dir), (mp, fst (split_dirpath sec)) let find_entry_p p = let rec find = function | [] -> raise Not_found | ent::l -> if p ent then ent else find l in find !lib_stk let find_split_p p = let rec find = function | [] -> raise Not_found | ent::l -> if p ent then ent,l else find l in find !lib_stk let split_lib_gen test = let rec collect after equal = function | hd::before when test hd -> collect after (hd::equal) before | before -> after,equal,before in let rec findeq after = function | hd :: before -> if test hd then Some (collect after [hd] before) else (match hd with | (sp,ClosedModule seg) | (sp,ClosedSection seg) -> (match findeq after seg with | None -> findeq (hd::after) before | Some (sub_after,sub_equal,sub_before) -> Some (sub_after, sub_equal, (List.append sub_before before))) | _ -> findeq (hd::after) before) | [] -> None in match findeq [] !lib_stk with | None -> error "no such entry" | Some r -> r let split_lib sp = split_lib_gen (fun x -> fst x = sp) let split_lib_at_opening sp = let is_sp = function | x,(OpenedSection _|OpenedModule _|CompilingLibrary _) -> x = sp | _ -> false in let a,s,b = split_lib_gen is_sp in assert (List.tl s = []); (a,List.hd s,b) (* Adding operations. *) let add_entry sp node = lib_stk := (sp,node) :: !lib_stk let anonymous_id = let n = ref 0 in fun () -> incr n; Names.id_of_string ("_" ^ (string_of_int !n)) let add_anonymous_entry node = let id = anonymous_id () in let name = make_oname id in add_entry name node; name let add_leaf id obj = if fst (current_prefix ()) = Names.initial_path then error ("No session module started (use -top dir)"); let oname = make_oname id in cache_object (oname,obj); add_entry oname (Leaf obj); oname let add_discharged_leaf id obj = let oname = make_oname id in let newobj = rebuild_object obj in cache_object (oname,newobj); add_entry oname (Leaf newobj) let add_leaves id objs = let oname = make_oname id in let add_obj obj = add_entry oname (Leaf obj); load_object 1 (oname,obj) in List.iter add_obj objs; oname let add_anonymous_leaf obj = let id = anonymous_id () in let oname = make_oname id in cache_object (oname,obj); add_entry oname (Leaf obj) let add_frozen_state () = let _ = add_anonymous_entry (FrozenState (freeze_summaries())) in () (* Modules. *) let is_opening_node = function | _,(OpenedSection _ | OpenedModule _) -> true | _ -> false let is_opening_node_or_lib = function | _,(CompilingLibrary _ | OpenedSection _ | OpenedModule _) -> true | _ -> false let current_mod_id () = try match find_entry_p is_opening_node_or_lib with | oname,OpenedModule (_,_,_,fs) -> basename (fst oname) | oname,CompilingLibrary _ -> basename (fst oname) | _ -> error "you are not in a module" with Not_found -> error "no opened modules" let start_mod is_type export id mp fs = let dir = add_dirpath_suffix (fst !path_prefix) id in let prefix = dir,(mp,Names.empty_dirpath) in let sp = make_path id in let oname = sp, make_kn id in let exists = if is_type then Nametab.exists_cci sp else Nametab.exists_module dir in if exists then errorlabstrm "open_module" (pr_id id ++ str " already exists"); add_entry oname (OpenedModule (is_type,export,prefix,fs)); path_prefix := prefix; prefix (* add_frozen_state () must be called in declaremods *) let start_module = start_mod false let start_modtype = start_mod true None let error_still_opened string oname = let id = basename (fst oname) in errorlabstrm "" (str ("The "^string^" ") ++ pr_id id ++ str " is still opened.") let end_mod is_type = let oname,fs = try match find_entry_p is_opening_node with | oname,OpenedModule (ty,_,_,fs) -> if ty = is_type then oname,fs else error_still_opened (module_kind ty) oname | oname,OpenedSection _ -> error_still_opened "section" oname | _ -> assert false with Not_found -> error "No opened modules." in let (after,mark,before) = split_lib_at_opening oname in lib_stk := before; add_entry oname (ClosedModule (List.rev (mark::after))); let prefix = !path_prefix in recalc_path_prefix (); (* add_frozen_state must be called after processing the module, because we cannot recache interactive modules *) (oname, prefix, fs, after) let end_module () = end_mod false let end_modtype () = end_mod true let contents_after = function | None -> !lib_stk | Some sp -> let (after,_,_) = split_lib sp in after (* Modules. *) (* TODO: use check_for_module ? *) let start_compilation s mp = if !comp_name <> None then error "compilation unit is already started"; if snd (snd (!path_prefix)) <> Names.empty_dirpath then error "some sections are already opened"; let prefix = s, (mp, Names.empty_dirpath) in let _ = add_anonymous_entry (CompilingLibrary prefix) in comp_name := Some s; path_prefix := prefix let end_compilation dir = let _ = try match snd (find_entry_p is_opening_node) with | OpenedSection _ -> error "There are some open sections." | OpenedModule (ty,_,_,_) -> error ("There are some open "^module_kind ty^"s.") | _ -> assert false with Not_found -> () in let is_opening_lib = function _,CompilingLibrary _ -> true | _ -> false in let oname = try match find_entry_p is_opening_lib with | (oname, CompilingLibrary prefix) -> oname | _ -> assert false with Not_found -> anomaly "No module declared" in let _ = match !comp_name with | None -> anomaly "There should be a module name..." | Some m -> if m <> dir then anomaly ("The current open module has name "^ (Names.string_of_dirpath m) ^ " and not " ^ (Names.string_of_dirpath m)); in let (after,mark,before) = split_lib_at_opening oname in comp_name := None; !path_prefix,after (* Returns true if we are inside an opened module or module type *) let is_module_gen which = let test = function | _, OpenedModule (ty,_,_,_) -> which ty | _ -> false in try let _ = find_entry_p test in true with Not_found -> false let is_module_or_modtype () = is_module_gen (fun _ -> true) let is_modtype () = is_module_gen (fun b -> b) let is_module () = is_module_gen (fun b -> not b) (* Returns the opening node of a given name *) let find_opening_node id = try let oname,entry = find_entry_p is_opening_node in let id' = basename (fst oname) in if id <> id' then error ("Last block to end has name "^(Names.string_of_id id')^"."); entry with Not_found -> error "There is nothing to end." (* Discharge tables *) (* At each level of section, we remember - the list of variables in this section - the list of variables on which each constant depends in this section - the list of variables on which each inductive depends in this section - the list of substitution to do at section closing *) type binding_kind = Explicit | Implicit type variable_info = Names.identifier * binding_kind * Term.constr option * Term.types type variable_context = variable_info list type abstr_list = variable_context Names.Cmap.t * variable_context Names.Mindmap.t let sectab = ref ([] : ((Names.identifier * binding_kind) list * Cooking.work_list * abstr_list) list) let add_section () = sectab := ([],(Names.Cmap.empty,Names.Mindmap.empty),(Names.Cmap.empty,Names.Mindmap.empty)) :: !sectab let add_section_variable id impl = match !sectab with | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) | (vars,repl,abs)::sl -> sectab := ((id,impl)::vars,repl,abs)::sl let extract_hyps (secs,ohyps) = let rec aux = function | ((id,impl)::idl,(id',b,t)::hyps) when id=id' -> (id',impl,b,t) :: aux (idl,hyps) | (id::idl,hyps) -> aux (idl,hyps) | [], _ -> [] in aux (secs,ohyps) let instance_from_variable_context sign = let rec inst_rec = function | (id,b,None,_) :: sign -> id :: inst_rec sign | _ :: sign -> inst_rec sign | [] -> [] in Array.of_list (inst_rec sign) let named_of_variable_context = List.map (fun (id,_,b,t) -> (id,b,t)) let add_section_replacement f g hyps = match !sectab with | [] -> () | (vars,exps,abs)::sl -> let sechyps = extract_hyps (vars,hyps) in let args = instance_from_variable_context (List.rev sechyps) in sectab := (vars,f args exps,g sechyps abs)::sl let add_section_kn kn = let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in add_section_replacement f f let add_section_constant kn = let f x (l1,l2) = (Names.Cmap.add kn x l1,l2) in add_section_replacement f f let replacement_context () = pi2 (List.hd !sectab) let section_segment_of_constant con = Names.Cmap.find con (fst (pi3 (List.hd !sectab))) let section_segment_of_mutual_inductive kn = Names.Mindmap.find kn (snd (pi3 (List.hd !sectab))) let rec list_mem_assoc x = function | [] -> raise Not_found | (a,_)::l -> compare a x = 0 or list_mem_assoc x l let section_instance = function | VarRef id -> if list_mem_assoc id (pi1 (List.hd !sectab)) then [||] else raise Not_found | ConstRef con -> Names.Cmap.find con (fst (pi2 (List.hd !sectab))) | IndRef (kn,_) | ConstructRef ((kn,_),_) -> Names.Mindmap.find kn (snd (pi2 (List.hd !sectab))) let is_in_section ref = try ignore (section_instance ref); true with Not_found -> false let init_sectab () = sectab := [] let freeze_sectab () = !sectab let unfreeze_sectab s = sectab := s let _ = Summary.declare_summary "section-context" { Summary.freeze_function = freeze_sectab; Summary.unfreeze_function = unfreeze_sectab; Summary.init_function = init_sectab } (*************) (* Sections. *) (* XML output hooks *) let xml_open_section = ref (fun id -> ()) let xml_close_section = ref (fun id -> ()) let set_xml_open_section f = xml_open_section := f let set_xml_close_section f = xml_close_section := f let open_section id = let olddir,(mp,oldsec) = !path_prefix in let dir = add_dirpath_suffix olddir id in let prefix = dir, (mp, add_dirpath_suffix oldsec id) in let name = make_path id, make_kn id (* this makes little sense however *) in if Nametab.exists_section dir then errorlabstrm "open_section" (pr_id id ++ str " already exists."); let fs = freeze_summaries() in add_entry name (OpenedSection (prefix, fs)); (*Pushed for the lifetime of the section: removed by unfrozing the summary*) Nametab.push_dir (Nametab.Until 1) dir (DirOpenSection prefix); path_prefix := prefix; if !Flags.xml_export then !xml_open_section id; add_section () (* Restore lib_stk and summaries as before the section opening, and add a ClosedSection object. *) let discharge_item ((sp,_ as oname),e) = match e with | Leaf lobj -> Option.map (fun o -> (basename sp,o)) (discharge_object (oname,lobj)) | FrozenState _ -> None | ClosedSection _ | ClosedModule _ -> None | OpenedSection _ | OpenedModule _ | CompilingLibrary _ -> anomaly "discharge_item" let close_section () = let oname,fs = try match find_entry_p is_opening_node with | oname,OpenedSection (_,fs) -> oname,fs | _ -> assert false with Not_found -> error "No opened section." in let (secdecls,mark,before) = split_lib_at_opening oname in lib_stk := before; let full_olddir = fst !path_prefix in pop_path_prefix (); add_entry oname (ClosedSection (List.rev (mark::secdecls))); if !Flags.xml_export then !xml_close_section (basename (fst oname)); let newdecls = List.map discharge_item secdecls in Summary.unfreeze_summaries fs; List.iter (Option.iter (fun (id,o) -> add_discharged_leaf id o)) newdecls; Cooking.clear_cooking_sharing (); Nametab.push_dir (Nametab.Until 1) full_olddir (DirClosedSection full_olddir) (*****************) (* Backtracking. *) let (inLabel : int -> obj), (outLabel : obj -> int) = declare_object_full {(default_object "DOT") with classify_function = (fun _ -> Dispose)} let recache_decl = function | (sp, Leaf o) -> cache_object (sp,o) | (_,OpenedSection _) -> add_section () | _ -> () let recache_context ctx = List.iter recache_decl ctx let is_frozen_state = function (_,FrozenState _) -> true | _ -> false let set_lib_stk new_lib_stk = lib_stk := new_lib_stk; recalc_path_prefix (); let spf = match find_entry_p is_frozen_state with | (sp, FrozenState f) -> unfreeze_summaries f; sp | _ -> assert false in let (after,_,_) = split_lib spf in try recache_context after with | Not_found -> error "Tried to set environment to an incoherent state." let reset_to_gen test = let (_,_,before) = split_lib_gen test in set_lib_stk before let reset_to sp = reset_to_gen (fun x -> fst x = sp) let first_command_label = 1 let mark_end_of_command, current_command_label, reset_command_label = let n = ref (first_command_label-1) in (fun () -> match !lib_stk with (_,Leaf o)::_ when object_tag o = "DOT" -> () | _ -> incr n;add_anonymous_leaf (inLabel !n)), (fun () -> !n), (fun x -> n:=x;add_anonymous_leaf (inLabel x)) let is_label_n n x = match x with | (sp,Leaf o) when object_tag o = "DOT" && n = outLabel o -> true | _ -> false (** Reset the label registered by [mark_end_of_command()] with number n, which should be strictly in the past. *) let reset_label n = if n >= current_command_label () then error "Cannot backtrack to the current label or a future one"; reset_to_gen (is_label_n n); (* forget state numbers after n only if reset succeeded *) reset_command_label n (** Search the last label registered before defining [id] *) let label_before_name (loc,id) = let found = ref false in let search = function | (_,Leaf o) when !found && object_tag o = "DOT" -> true | (sp,_) -> (if id = snd (repr_path (fst sp)) then found := true); false in match find_entry_p search with | (_,Leaf o) -> outLabel o | _ -> raise Not_found (* State and initialization. *) type frozen = Names.dir_path option * library_segment let freeze () = (!comp_name, !lib_stk) let unfreeze (mn,stk) = comp_name := mn; lib_stk := stk; recalc_path_prefix () let init () = lib_stk := []; add_frozen_state (); comp_name := None; path_prefix := initial_prefix; init_summaries() (* Misc *) let mp_of_global ref = match ref with | VarRef id -> fst (current_prefix ()) | ConstRef cst -> Names.con_modpath cst | IndRef ind -> Names.ind_modpath ind | ConstructRef constr -> Names.constr_modpath constr let rec dp_of_mp modp = match modp with | Names.MPfile dp -> dp | Names.MPbound _ -> library_dp () | Names.MPdot (mp,_) -> dp_of_mp mp let rec split_mp mp = match mp with | Names.MPfile dp -> dp, Names.empty_dirpath | Names.MPdot (prfx, lbl) -> let mprec, dprec = split_mp prfx in mprec, Names.make_dirpath (Names.id_of_string (Names.string_of_label lbl) :: (Names.repr_dirpath dprec)) | Names.MPbound mbid -> let (_, id, dp) = Names.repr_mbid mbid in library_dp(), Names.make_dirpath [id] let split_modpath mp = let rec aux = function | Names.MPfile dp -> dp, [] | Names.MPbound mbid -> library_dp (), [Names.id_of_mbid mbid] | Names.MPdot (mp,l) -> let (mp', lab) = aux mp in (mp', Names.id_of_label l :: lab) in let (mp, l) = aux mp in mp, l let library_part ref = match ref with | VarRef id -> library_dp () | _ -> dp_of_mp (mp_of_global ref) let remove_section_part ref = let sp = Nametab.path_of_global ref in let dir,_ = repr_path sp in match ref with | VarRef id -> anomaly "remove_section_part not supported on local variables" | _ -> if is_dirpath_prefix_of dir (cwd ()) then (* Not yet (fully) discharged *) pop_dirpath_n (sections_depth ()) (cwd ()) else (* Theorem/Lemma outside its outer section of definition *) dir (************************) (* Discharging names *) let pop_kn kn = let (mp,dir,l) = Names.repr_mind kn in Names.make_mind mp (pop_dirpath dir) l let pop_con con = let (mp,dir,l) = Names.repr_con con in Names.make_con mp (pop_dirpath dir) l let con_defined_in_sec kn = let _,dir,_ = Names.repr_con kn in dir <> Names.empty_dirpath && fst (split_dirpath dir) = snd (current_prefix ()) let defined_in_sec kn = let _,dir,_ = Names.repr_mind kn in dir <> Names.empty_dirpath && fst (split_dirpath dir) = snd (current_prefix ()) let discharge_global = function | ConstRef kn when con_defined_in_sec kn -> ConstRef (pop_con kn) | IndRef (kn,i) when defined_in_sec kn -> IndRef (pop_kn kn,i) | ConstructRef ((kn,i),j) when defined_in_sec kn -> ConstructRef ((pop_kn kn,i),j) | r -> r let discharge_kn kn = if defined_in_sec kn then pop_kn kn else kn let discharge_con cst = if con_defined_in_sec cst then pop_con cst else cst let discharge_inductive (kn,i) = (discharge_kn kn,i) coq-8.4pl4/library/library.mllib0000644000175000017500000000021612326224777015763 0ustar stephstephNameops Libnames Libobject Summary Nametab Global Lib Declaremods Library States Decl_kinds Dischargedhypsmap Goptions Decls Heads Assumptionscoq-8.4pl4/library/decls.ml0000644000175000017500000000507412326224777014731 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* !vartab); Summary.unfreeze_function = (fun ft -> vartab := ft); Summary.init_function = (fun () -> vartab := Idmap.empty) } let add_variable_data id o = vartab := Idmap.add id o !vartab let variable_path id = let (p,_,_,_) = Idmap.find id !vartab in p let variable_opacity id = let (_,opaq,_,_) = Idmap.find id !vartab in opaq let variable_kind id = let (_,_,_,k) = Idmap.find id !vartab in k let variable_constraints id = let (_,_,cst,_) = Idmap.find id !vartab in cst let variable_secpath id = let dir = drop_dirpath_prefix (Lib.library_dp()) (variable_path id) in make_qualid dir id let variable_exists id = Idmap.mem id !vartab (** Datas associated to global parameters and constants *) let csttab = ref (Cmap.empty : logical_kind Cmap.t) let _ = Summary.declare_summary "CONSTANT" { Summary.freeze_function = (fun () -> !csttab); Summary.unfreeze_function = (fun ft -> csttab := ft); Summary.init_function = (fun () -> csttab := Cmap.empty) } let add_constant_kind kn k = csttab := Cmap.add kn k !csttab let constant_kind kn = Cmap.find kn !csttab (** Miscellaneous functions. *) let initialize_named_context_for_proof () = let sign = Global.named_context () in List.fold_right (fun (id,c,t as d) signv -> let d = if variable_opacity id then (id,None,t) else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val let last_section_hyps dir = fold_named_context (fun (id,_,_) sec_ids -> try if dir=variable_path id then id::sec_ids else sec_ids with Not_found -> sec_ids) (Environ.named_context (Global.env())) ~init:[] coq-8.4pl4/library/dischargedhypsmap.ml0000644000175000017500000000245012326224777017331 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* [] (*s Registration as global tables and rollback. *) let init () = discharged_hyps_map := Spmap.empty let freeze () = !discharged_hyps_map let unfreeze dhm = discharged_hyps_map := dhm let _ = Summary.declare_summary "discharged_hypothesis" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = init } coq-8.4pl4/library/dischargedhypsmap.mli0000644000175000017500000000157112326224777017505 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* discharged_hyps -> unit val get_discharged_hyps : full_path -> discharged_hyps coq-8.4pl4/library/nametab.ml0000644000175000017500000003712112326224777015244 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string val repr : t -> identifier * module_ident list end (* A ['a t] is a map from [user_name] to ['a], with possible lookup by partially qualified names of type [qualid]. The mapping of partially qualified names to ['a] is determined by the [visibility] parameter of [push]. The [shortest_qualid] function given a user_name Coq.A.B.x, tries to find the shortest among x, B.x, A.B.x and Coq.A.B.x that denotes the same object. *) module type NAMETREE = sig type 'a t type user_name val empty : 'a t val push : visibility -> user_name -> 'a -> 'a t -> 'a t val locate : qualid -> 'a t -> 'a val find : user_name -> 'a t -> 'a val exists : user_name -> 'a t -> bool val user_name : qualid -> 'a t -> user_name val shortest_qualid : Idset.t -> user_name -> 'a t -> qualid val find_prefixes : qualid -> 'a t -> 'a list end module Make(U:UserName) : NAMETREE with type user_name = U.t = struct type user_name = U.t type 'a path_status = Nothing | Relative of user_name * 'a | Absolute of user_name * 'a (* Dictionaries of short names *) type 'a nametree = ('a path_status * 'a nametree ModIdmap.t) type 'a t = 'a nametree Idmap.t let empty = Idmap.empty (* [push_until] is used to register [Until vis] visibility and [push_exactly] to [Exactly vis] and [push_tree] chooses the right one*) let rec push_until uname o level (current,dirmap) = function | modid :: path -> let mc = try ModIdmap.find modid dirmap with Not_found -> (Nothing, ModIdmap.empty) in let this = if level <= 0 then match current with | Absolute (n,_) -> (* This is an absolute name, we must keep it otherwise it may become unaccessible forever *) Flags.if_warn msg_warning (str ("Trying to mask the absolute name \"" ^ U.to_string n ^ "\"!")); current | Nothing | Relative _ -> Relative (uname,o) else current in let ptab' = push_until uname o (level-1) mc path in (this, ModIdmap.add modid ptab' dirmap) | [] -> match current with | Absolute (uname',o') -> if o'=o then begin assert (uname=uname'); current, dirmap (* we are putting the same thing for the second time :) *) end else (* This is an absolute name, we must keep it otherwise it may become unaccessible forever *) (* But ours is also absolute! This is an error! *) error ("Cannot mask the absolute name \"" ^ U.to_string uname' ^ "\"!") | Nothing | Relative _ -> Absolute (uname,o), dirmap let rec push_exactly uname o level (current,dirmap) = function | modid :: path -> let mc = try ModIdmap.find modid dirmap with Not_found -> (Nothing, ModIdmap.empty) in if level = 0 then let this = match current with | Absolute (n,_) -> (* This is an absolute name, we must keep it otherwise it may become unaccessible forever *) Flags.if_warn msg_warning (str ("Trying to mask the absolute name \"" ^ U.to_string n ^ "\"!")); current | Nothing | Relative _ -> Relative (uname,o) in (this, dirmap) else (* not right level *) let ptab' = push_exactly uname o (level-1) mc path in (current, ModIdmap.add modid ptab' dirmap) | [] -> anomaly "Prefix longer than path! Impossible!" let push visibility uname o tab = let id,dir = U.repr uname in let ptab = try Idmap.find id tab with Not_found -> (Nothing, ModIdmap.empty) in let ptab' = match visibility with | Until i -> push_until uname o (i-1) ptab dir | Exactly i -> push_exactly uname o (i-1) ptab dir in Idmap.add id ptab' tab let rec search (current,modidtab) = function | modid :: path -> search (ModIdmap.find modid modidtab) path | [] -> current let find_node qid tab = let (dir,id) = repr_qualid qid in search (Idmap.find id tab) (repr_dirpath dir) let locate qid tab = let o = match find_node qid tab with | Absolute (uname,o) | Relative (uname,o) -> o | Nothing -> raise Not_found in o let user_name qid tab = let uname = match find_node qid tab with | Absolute (uname,o) | Relative (uname,o) -> uname | Nothing -> raise Not_found in uname let find uname tab = let id,l = U.repr uname in match search (Idmap.find id tab) l with Absolute (_,o) -> o | _ -> raise Not_found let exists uname tab = try let _ = find uname tab in true with Not_found -> false let shortest_qualid ctx uname tab = let id,dir = U.repr uname in let hidden = Idset.mem id ctx in let rec find_uname pos dir (path,tab) = match path with | Absolute (u,_) | Relative (u,_) when u=uname && not(pos=[] && hidden) -> List.rev pos | _ -> match dir with [] -> raise Not_found | id::dir -> find_uname (id::pos) dir (ModIdmap.find id tab) in let ptab = Idmap.find id tab in let found_dir = find_uname [] dir ptab in make_qualid (make_dirpath found_dir) id let push_node node l = match node with | Absolute (_,o) | Relative (_,o) when not (List.mem o l) -> o::l | _ -> l let rec flatten_idmap tab l = ModIdmap.fold (fun _ (current,idtab) l -> flatten_idmap idtab (push_node current l)) tab l let rec search_prefixes (current,modidtab) = function | modid :: path -> search_prefixes (ModIdmap.find modid modidtab) path | [] -> List.rev (flatten_idmap modidtab (push_node current [])) let find_prefixes qid tab = try let (dir,id) = repr_qualid qid in search_prefixes (Idmap.find id tab) (repr_dirpath dir) with Not_found -> [] end (* Global name tables *************************************************) module SpTab = Make (struct type t = full_path let to_string = string_of_path let repr sp = let dir,id = repr_path sp in id, (repr_dirpath dir) end) type ccitab = extended_global_reference SpTab.t let the_ccitab = ref (SpTab.empty : ccitab) type kntab = kernel_name SpTab.t let the_tactictab = ref (SpTab.empty : kntab) type mptab = module_path SpTab.t let the_modtypetab = ref (SpTab.empty : mptab) module DirTab = Make(struct type t = dir_path let to_string = string_of_dirpath let repr dir = match repr_dirpath dir with | [] -> anomaly "Empty dirpath" | id::l -> (id,l) end) (* If we have a (closed) module M having a submodule N, than N does not have the entry in [the_dirtab]. *) type dirtab = global_dir_reference DirTab.t let the_dirtab = ref (DirTab.empty : dirtab) (* Reversed name tables ***************************************************) (* This table translates extended_global_references back to section paths *) module Globrevtab = Map.Make(ExtRefOrdered) type globrevtab = full_path Globrevtab.t let the_globrevtab = ref (Globrevtab.empty : globrevtab) type mprevtab = dir_path MPmap.t let the_modrevtab = ref (MPmap.empty : mprevtab) type mptrevtab = full_path MPmap.t let the_modtyperevtab = ref (MPmap.empty : mptrevtab) type knrevtab = full_path KNmap.t let the_tacticrevtab = ref (KNmap.empty : knrevtab) (* Push functions *********************************************************) (* This is for permanent constructions (never discharged -- but with possibly limited visibility, i.e. Theorem, Lemma, Definition, Axiom, Parameter but also Remark and Fact) *) let push_xref visibility sp xref = match visibility with | Until _ -> the_ccitab := SpTab.push visibility sp xref !the_ccitab; the_globrevtab := Globrevtab.add xref sp !the_globrevtab | _ -> begin if SpTab.exists sp !the_ccitab then match SpTab.find sp !the_ccitab with | TrueGlobal( ConstRef _) | TrueGlobal( IndRef _) | TrueGlobal( ConstructRef _) as xref -> the_ccitab := SpTab.push visibility sp xref !the_ccitab; | _ -> the_ccitab := SpTab.push visibility sp xref !the_ccitab; else the_ccitab := SpTab.push visibility sp xref !the_ccitab; end let push_cci visibility sp ref = push_xref visibility sp (TrueGlobal ref) (* This is for Syntactic Definitions *) let push_syndef visibility sp kn = push_xref visibility sp (SynDef kn) let push = push_cci let push_modtype vis sp kn = the_modtypetab := SpTab.push vis sp kn !the_modtypetab; the_modtyperevtab := MPmap.add kn sp !the_modtyperevtab (* This is for tactic definition names *) let push_tactic vis sp kn = the_tactictab := SpTab.push vis sp kn !the_tactictab; the_tacticrevtab := KNmap.add kn sp !the_tacticrevtab (* This is to remember absolute Section/Module names and to avoid redundancy *) let push_dir vis dir dir_ref = the_dirtab := DirTab.push vis dir dir_ref !the_dirtab; match dir_ref with DirModule (_,(mp,_)) -> the_modrevtab := MPmap.add mp dir !the_modrevtab | _ -> () (* Locate functions *******************************************************) (* This should be used when syntactic definitions are allowed *) let locate_extended qid = SpTab.locate qid !the_ccitab (* This should be used when no syntactic definitions is expected *) let locate qid = match locate_extended qid with | TrueGlobal ref -> ref | SynDef _ -> raise Not_found let full_name_cci qid = SpTab.user_name qid !the_ccitab let locate_syndef qid = match locate_extended qid with | TrueGlobal _ -> raise Not_found | SynDef kn -> kn let locate_modtype qid = SpTab.locate qid !the_modtypetab let full_name_modtype qid = SpTab.user_name qid !the_modtypetab let locate_tactic qid = SpTab.locate qid !the_tactictab let locate_dir qid = DirTab.locate qid !the_dirtab let locate_module qid = match locate_dir qid with | DirModule (_,(mp,_)) -> mp | _ -> raise Not_found let full_name_module qid = match locate_dir qid with | DirModule (dir,_) -> dir | _ -> raise Not_found let locate_section qid = match locate_dir qid with | DirOpenSection (dir, _) | DirClosedSection dir -> dir | _ -> raise Not_found let locate_all qid = List.fold_right (fun a l -> match a with TrueGlobal a -> a::l | _ -> l) (SpTab.find_prefixes qid !the_ccitab) [] let locate_extended_all qid = SpTab.find_prefixes qid !the_ccitab (* Derived functions *) let locate_constant qid = match locate_extended qid with | TrueGlobal (ConstRef kn) -> kn | _ -> raise Not_found let global_of_path sp = match SpTab.find sp !the_ccitab with | TrueGlobal ref -> ref | _ -> raise Not_found let extended_global_of_path sp = SpTab.find sp !the_ccitab let global r = let (loc,qid) = qualid_of_reference r in try match locate_extended qid with | TrueGlobal ref -> ref | SynDef _ -> user_err_loc (loc,"global", str "Unexpected reference to a notation: " ++ pr_qualid qid) with Not_found -> error_global_not_found_loc loc qid (* Exists functions ********************************************************) let exists_cci sp = SpTab.exists sp !the_ccitab let exists_dir dir = DirTab.exists dir !the_dirtab let exists_section = exists_dir let exists_module = exists_dir let exists_modtype sp = SpTab.exists sp !the_modtypetab (* Reverse locate functions ***********************************************) let path_of_global ref = match ref with | VarRef id -> make_path empty_dirpath id | _ -> Globrevtab.find (TrueGlobal ref) !the_globrevtab let dirpath_of_global ref = fst (repr_path (path_of_global ref)) let basename_of_global ref = snd (repr_path (path_of_global ref)) let path_of_syndef kn = Globrevtab.find (SynDef kn) !the_globrevtab let dirpath_of_module mp = MPmap.find mp !the_modrevtab let path_of_tactic kn = KNmap.find kn !the_tacticrevtab (* Shortest qualid functions **********************************************) let shortest_qualid_of_global ctx ref = match ref with | VarRef id -> make_qualid empty_dirpath id | _ -> let sp = Globrevtab.find (TrueGlobal ref) !the_globrevtab in SpTab.shortest_qualid ctx sp !the_ccitab let shortest_qualid_of_syndef ctx kn = let sp = path_of_syndef kn in SpTab.shortest_qualid ctx sp !the_ccitab let shortest_qualid_of_module mp = let dir = MPmap.find mp !the_modrevtab in DirTab.shortest_qualid Idset.empty dir !the_dirtab let shortest_qualid_of_modtype kn = let sp = MPmap.find kn !the_modtyperevtab in SpTab.shortest_qualid Idset.empty sp !the_modtypetab let shortest_qualid_of_tactic kn = let sp = KNmap.find kn !the_tacticrevtab in SpTab.shortest_qualid Idset.empty sp !the_tactictab let pr_global_env env ref = (* Il est important de laisser le let-in, car les streams s'évaluent paresseusement : il faut forcer l'évaluation pour capturer l'éventuelle levée d'une exception (le cas échoit dans le debugger) *) let s = string_of_qualid (shortest_qualid_of_global env ref) in (str s) let global_inductive r = match global r with | IndRef ind -> ind | ref -> user_err_loc (loc_of_reference r,"global_inductive", pr_reference r ++ spc () ++ str "is not an inductive type") (********************************************************************) (********************************************************************) (* Registration of tables as a global table and rollback *) type frozen = ccitab * dirtab * kntab * kntab * globrevtab * mprevtab * knrevtab * knrevtab let init () = the_ccitab := SpTab.empty; the_dirtab := DirTab.empty; the_modtypetab := SpTab.empty; the_tactictab := SpTab.empty; the_globrevtab := Globrevtab.empty; the_modrevtab := MPmap.empty; the_modtyperevtab := MPmap.empty; the_tacticrevtab := KNmap.empty let freeze () = !the_ccitab, !the_dirtab, !the_modtypetab, !the_tactictab, !the_globrevtab, !the_modrevtab, !the_modtyperevtab, !the_tacticrevtab let unfreeze (ccit,dirt,mtyt,tact,globr,modr,mtyr,tacr) = the_ccitab := ccit; the_dirtab := dirt; the_modtypetab := mtyt; the_tactictab := tact; the_globrevtab := globr; the_modrevtab := modr; the_modtyperevtab := mtyr; the_tacticrevtab := tacr let _ = Summary.declare_summary "names" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = init } (* Deprecated synonyms *) let extended_locate = locate_extended let absolute_reference = global_of_path coq-8.4pl4/library/declare.ml0000644000175000017500000002560312326224777015236 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ()) let xml_declare_constant = ref (fun (sp:internal_flag * constant)-> ()) let xml_declare_inductive = ref (fun (sp:internal_flag * object_name) -> ()) let if_xml f x = if !Flags.xml_export then f x else () let set_xml_declare_variable f = xml_declare_variable := if_xml f let set_xml_declare_constant f = xml_declare_constant := if_xml f let set_xml_declare_inductive f = xml_declare_inductive := if_xml f let cache_hook = ref ignore let add_cache_hook f = cache_hook := f (** Declaration of section variables and local definitions *) type section_variable_entry = | SectionLocalDef of constr * types option * bool (* opacity *) | SectionLocalAssum of types * bool (* Implicit status *) type variable_declaration = dir_path * section_variable_entry * logical_kind let cache_variable ((sp,_),o) = match o with | Inl cst -> Global.add_constraints cst | Inr (id,(p,d,mk)) -> (* Constr raisonne sur les noms courts *) if variable_exists id then alreadydeclared (pr_id id ++ str " already exists"); let impl,opaq,cst = match d with (* Fails if not well-typed *) | SectionLocalAssum (ty, impl) -> let cst = Global.push_named_assum (id,ty) in let impl = if impl then Lib.Implicit else Lib.Explicit in impl, true, cst | SectionLocalDef (c,t,opaq) -> let cst = Global.push_named_def (id,c,t) in Lib.Explicit, opaq, cst in Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id); add_section_variable id impl; Dischargedhypsmap.set_discharged_hyps sp []; add_variable_data id (p,opaq,cst,mk) let discharge_variable (_,o) = match o with | Inr (id,_) -> Some (Inl (variable_constraints id)) | Inl _ -> Some o type variable_obj = (Univ.constraints, identifier * variable_declaration) union let inVariable : variable_obj -> obj = declare_object { (default_object "VARIABLE") with cache_function = cache_variable; discharge_function = discharge_variable; classify_function = (fun _ -> Dispose) } (* for initial declaration *) let declare_variable id obj = let oname = add_leaf id (inVariable (Inr (id,obj))) in declare_var_implicits id; Notation.declare_ref_arguments_scope (VarRef id); Heads.declare_head (EvalVarRef id); !xml_declare_variable oname; oname (** Declaration of constants and parameters *) type constant_declaration = constant_entry * logical_kind (* At load-time, the segment starting from the module name to the discharge *) (* section (if Remark or Fact) is needed to access a construction *) let load_constant i ((sp,kn),(_,_,kind)) = if Nametab.exists_cci sp then alreadydeclared (pr_id (basename sp) ++ str " already exists"); let con = Global.constant_of_delta_kn kn in Nametab.push (Nametab.Until i) sp (ConstRef con); add_constant_kind con kind (* Opening means making the name without its module qualification available *) let open_constant i ((sp,kn),_) = let con = Global.constant_of_delta_kn kn in Nametab.push (Nametab.Exactly i) sp (ConstRef con) let exists_name id = variable_exists id or Global.exists_objlabel (label_of_id id) let check_exists sp = let id = basename sp in if exists_name id then alreadydeclared (pr_id id ++ str " already exists") let cache_constant ((sp,kn),(cdt,dhyps,kind)) = let id = basename sp in let _,dir,_ = repr_kn kn in check_exists sp; let kn' = Global.add_constant dir id cdt in assert (kn' = constant_of_kn kn); Nametab.push (Nametab.Until 1) sp (ConstRef (constant_of_kn kn)); add_section_constant kn' (Global.lookup_constant kn').const_hyps; Dischargedhypsmap.set_discharged_hyps sp dhyps; add_constant_kind (constant_of_kn kn) kind; !cache_hook sp let discharged_hyps kn sechyps = let (_,dir,_) = repr_kn kn in let args = Array.to_list (instance_from_variable_context sechyps) in List.rev (List.map (Libnames.make_path dir) args) let discharge_constant ((sp,kn),(cdt,dhyps,kind)) = let con = constant_of_kn kn in let cb = Global.lookup_constant con in let repl = replacement_context () in let sechyps = section_segment_of_constant con in let recipe = { d_from=cb; d_modlist=repl; d_abstract=named_of_variable_context sechyps } in Some (GlobalRecipe recipe,(discharged_hyps kn sechyps)@dhyps,kind) (* Hack to reduce the size of .vo: we keep only what load/open needs *) let dummy_constant_entry = ConstantEntry (ParameterEntry (None,mkProp,None)) let dummy_constant (ce,_,mk) = dummy_constant_entry,[],mk let classify_constant cst = Substitute (dummy_constant cst) type constant_obj = global_declaration * Dischargedhypsmap.discharged_hyps * logical_kind let inConstant : constant_obj -> obj = declare_object { (default_object "CONSTANT") with cache_function = cache_constant; load_function = load_constant; open_function = open_constant; classify_function = classify_constant; subst_function = ident_subst_function; discharge_function = discharge_constant } let declare_constant_common id dhyps (cd,kind) = let (sp,kn) = add_leaf id (inConstant (cd,dhyps,kind)) in let c = Global.constant_of_delta_kn kn in declare_constant_implicits c; Heads.declare_head (EvalConstRef c); Notation.declare_ref_arguments_scope (ConstRef c); c let declare_constant ?(internal = UserVerbose) id (cd,kind) = let kn = declare_constant_common id [] (ConstantEntry cd,kind) in !xml_declare_constant (internal,kn); kn (** Declaration of inductive blocks *) let declare_inductive_argument_scopes kn mie = list_iter_i (fun i {mind_entry_consnames=lc} -> Notation.declare_ref_arguments_scope (IndRef (kn,i)); for j=1 to List.length lc do Notation.declare_ref_arguments_scope (ConstructRef ((kn,i),j)); done) mie.mind_entry_inds let inductive_names sp kn mie = let (dp,_) = repr_path sp in let kn = Global.mind_of_delta_kn kn in let names, _ = List.fold_left (fun (names, n) ind -> let ind_p = (kn,n) in let names, _ = List.fold_left (fun (names, p) l -> let sp = Libnames.make_path dp l in ((sp, ConstructRef (ind_p,p)) :: names, p+1)) (names, 1) ind.mind_entry_consnames in let sp = Libnames.make_path dp ind.mind_entry_typename in ((sp, IndRef ind_p) :: names, n+1)) ([], 0) mie.mind_entry_inds in names let load_inductive i ((sp,kn),(_,mie)) = let names = inductive_names sp kn mie in List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until i) sp ref ) names let open_inductive i ((sp,kn),(_,mie)) = let names = inductive_names sp kn mie in List.iter (fun (sp, ref) -> Nametab.push (Nametab.Exactly i) sp ref) names let cache_inductive ((sp,kn),(dhyps,mie)) = let names = inductive_names sp kn mie in List.iter check_exists (List.map fst names); let id = basename sp in let _,dir,_ = repr_kn kn in let kn' = Global.add_mind dir id mie in assert (kn'= mind_of_kn kn); add_section_kn kn' (Global.lookup_mind kn').mind_hyps; Dischargedhypsmap.set_discharged_hyps sp dhyps; List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names; List.iter (fun (sp,_) -> !cache_hook sp) (inductive_names sp kn mie) let discharge_inductive ((sp,kn),(dhyps,mie)) = let mind = Global.mind_of_delta_kn kn in let mie = Global.lookup_mind mind in let repl = replacement_context () in let sechyps = section_segment_of_mutual_inductive mind in Some (discharged_hyps kn sechyps, Discharge.process_inductive (named_of_variable_context sechyps) repl mie) let dummy_one_inductive_entry mie = { mind_entry_typename = mie.mind_entry_typename; mind_entry_arity = mkProp; mind_entry_consnames = mie.mind_entry_consnames; mind_entry_lc = [] } (* Hack to reduce the size of .vo: we keep only what load/open needs *) let dummy_inductive_entry (_,m) = ([],{ mind_entry_params = []; mind_entry_record = false; mind_entry_finite = true; mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds }) type inductive_obj = Dischargedhypsmap.discharged_hyps * mutual_inductive_entry let inInductive : inductive_obj -> obj = declare_object {(default_object "INDUCTIVE") with cache_function = cache_inductive; load_function = load_inductive; open_function = open_inductive; classify_function = (fun a -> Substitute (dummy_inductive_entry a)); subst_function = ident_subst_function; discharge_function = discharge_inductive } (* for initial declaration *) let declare_mind isrecord mie = let id = match mie.mind_entry_inds with | ind::_ -> ind.mind_entry_typename | [] -> anomaly "cannot declare an empty list of inductives" in let (sp,kn as oname) = add_leaf id (inInductive ([],mie)) in let mind = Global.mind_of_delta_kn kn in declare_mib_implicits mind; declare_inductive_argument_scopes mind mie; !xml_declare_inductive (isrecord,oname); oname (* Declaration messages *) let pr_rank i = str (ordinal (i+1)) let fixpoint_message indexes l = Flags.if_verbose msgnl (match l with | [] -> anomaly "no recursive definition" | [id] -> pr_id id ++ str " is recursively defined" ++ (match indexes with | Some [|i|] -> str " (decreasing on "++pr_rank i++str " argument)" | _ -> mt ()) | l -> hov 0 (prlist_with_sep pr_comma pr_id l ++ spc () ++ str "are recursively defined" ++ match indexes with | Some a -> spc () ++ str "(decreasing respectively on " ++ prlist_with_sep pr_comma pr_rank (Array.to_list a) ++ str " arguments)" | None -> mt ())) let cofixpoint_message l = Flags.if_verbose msgnl (match l with | [] -> anomaly "No corecursive definition." | [id] -> pr_id id ++ str " is corecursively defined" | l -> hov 0 (prlist_with_sep pr_comma pr_id l ++ spc () ++ str "are corecursively defined")) let recursive_message isfix i l = (if isfix then fixpoint_message i else cofixpoint_message) l let definition_message id = Flags.if_verbose msgnl (pr_id id ++ str " is defined") let assumption_message id = Flags.if_verbose msgnl (pr_id id ++ str " is assumed") coq-8.4pl4/library/declaremods.ml0000644000175000017500000010453512326224777016123 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* add_scope_subst sc1 sc2) scl let subst_scope sc = try Stringmap.find sc !scope_subst with Not_found -> sc let reset_scope_subst () = scope_subst := Stringmap.empty (** Which inline annotations should we honor, either None or the ones whose level is less or equal to the given integer *) type inline = | NoInline | DefaultInline | InlineAt of int let default_inline () = Some (Flags.get_inline_level ()) let inl2intopt = function | NoInline -> None | InlineAt i -> Some i | DefaultInline -> default_inline () type funct_app_annot = { ann_inline : inline; ann_scope_subst : scope_subst } let inline_annot a = inl2intopt a.ann_inline type 'a annotated = ('a * funct_app_annot) (* modules and components *) (* OBSOLETE This type is a functional closure of substitutive lib_objects. The first part is a partial substitution (which will be later applied to lib_objects when completed). The second one is a list of bound identifiers which is nonempty only if the objects are owned by a fuctor The third one is the "self" ident of the signature (or structure), which should be substituted in lib_objects with the real name of the module. The fourth one is the segment itself which can contain references to identifiers in the domain of the substitution or in other two parts. These references are invalid in the current scope and therefore must be substitued with valid names before use. *) type substitutive_objects = mod_bound_id list * module_path * lib_objects (* For each module, we store the following things: In modtab_substobjs: substitutive_objects when we will do Module M:=N, the objects of N will be reloaded with M after substitution In modtab_objects: "substituted objects" @ "keep objects" substituted objects - roughly the objects above after the substitution - we need to keep them to call open_object when the module is opened (imported) keep objects - The list of non-substitutive objects - as above, for each of them we will call open_object when the module is opened (Some) Invariants: * If the module is a functor, the two latter lists are empty. * Module objects in substitutive_objects part have empty substituted objects. * Modules which where created with Module M:=mexpr or with Module M:SIG. ... End M. have the keep list empty. *) let modtab_substobjs = ref (MPmap.empty : substitutive_objects MPmap.t) let modtab_objects = ref (MPmap.empty : (object_prefix * lib_objects) MPmap.t) (* currently started interactive module (if any) - its arguments (if it is a functor) and declared output type *) let openmod_info = ref ((MPfile(initial_dir),[],None,[]) : module_path * mod_bound_id list * (module_struct_entry * int option) option * module_type_body list) (* The library_cache here is needed to avoid recalculations of substituted modules object during "reloading" of libraries *) let library_cache = ref Dirmap.empty let _ = Summary.declare_summary "MODULE-INFO" { Summary.freeze_function = (fun () -> !modtab_substobjs, !modtab_objects, !openmod_info, !library_cache); Summary.unfreeze_function = (fun (sobjs,objs,info,libcache) -> modtab_substobjs := sobjs; modtab_objects := objs; openmod_info := info; library_cache := libcache); Summary.init_function = (fun () -> modtab_substobjs := MPmap.empty; modtab_objects := MPmap.empty; openmod_info := ((MPfile(initial_dir), [],None,[])); library_cache := Dirmap.empty) } (* auxiliary functions to transform full_path and kernel_name given by Lib into module_path and dir_path needed for modules *) let mp_of_kn kn = let mp,sec,l = repr_kn kn in if sec=empty_dirpath then MPdot (mp,l) else anomaly ("Non-empty section in module name!" ^ string_of_kn kn) let dir_of_sp sp = let dir,id = repr_path sp in add_dirpath_suffix dir id (* Subtyping checks *) let check_sub mtb sub_mtb_l = (* The constraints are checked and forgot immediately : *) ignore (List.fold_right (fun sub_mtb env -> Environ.add_constraints (Subtyping.check_subtypes env mtb sub_mtb) env) sub_mtb_l (Global.env())) (* This function checks if the type calculated for the module [mp] is a subtype of all signatures in [sub_mtb_l]. Uses only the global environment. *) let check_subtypes mp sub_mtb_l = let mb = try Global.lookup_module mp with Not_found -> assert false in let mtb = Modops.module_type_of_module None mb in check_sub mtb sub_mtb_l (* Same for module type [mp] *) let check_subtypes_mt mp sub_mtb_l = let mtb = try Global.lookup_modtype mp with Not_found -> assert false in check_sub mtb sub_mtb_l (* Create a functor type entry *) let funct_entry args m = List.fold_right (fun (arg_id,(arg_t,_)) mte -> MSEfunctor (arg_id,arg_t,mte)) args m (* Prepare the module type list for check of subtypes *) let build_subtypes interp_modtype mp args mtys = List.map (fun (m,ann) -> let inl = inline_annot ann in let mte = interp_modtype (Global.env()) m in let mtb = Mod_typing.translate_module_type (Global.env()) mp inl mte in let funct_mtb = List.fold_right (fun (arg_id,(arg_t,arg_inl)) mte -> let arg_t = Mod_typing.translate_module_type (Global.env()) (MPbound arg_id) arg_inl arg_t in SEBfunctor(arg_id,arg_t,mte)) args mtb.typ_expr in { mtb with typ_expr = funct_mtb }) mtys (* These functions register the visibility of the module and iterates through its components. They are called by plenty module functions *) let compute_visibility exists what i dir dirinfo = if exists then if try Nametab.locate_dir (qualid_of_dirpath dir) = dirinfo with Not_found -> false then Nametab.Exactly i else errorlabstrm (what^"_module") (pr_dirpath dir ++ str " should already exist!") else if Nametab.exists_dir dir then errorlabstrm (what^"_module") (pr_dirpath dir ++ str " already exists") else Nametab.Until i (* let do_load_and_subst_module i dir mp substobjs keep = let prefix = (dir,(mp,empty_dirpath)) in let dirinfo = DirModule (dir,(mp,empty_dirpath)) in let vis = compute_visibility false "load_and_subst" i dir dirinfo in let objects = compute_subst_objects mp substobjs resolver in Nametab.push_dir vis dir dirinfo; modtab_substobjs := MPmap.add mp substobjs !modtab_substobjs; match objects with | Some (subst,seg) -> let seg = load_and_subst_objects (i+1) prefix subst seg in modtab_objects := MPmap.add mp (prefix,seg) !modtab_objects; load_objects (i+1) prefix keep; Some (seg@keep) | None -> None *) let do_module exists what iter_objects i dir mp substobjs keep= let prefix = (dir,(mp,empty_dirpath)) in let dirinfo = DirModule (dir,(mp,empty_dirpath)) in let vis = compute_visibility exists what i dir dirinfo in Nametab.push_dir vis dir dirinfo; modtab_substobjs := MPmap.add mp substobjs !modtab_substobjs; match substobjs with ([],mp1,objs) -> modtab_objects := MPmap.add mp (prefix,objs@keep) !modtab_objects; iter_objects (i+1) prefix (objs@keep) | (mbids,_,_) -> () let conv_names_do_module exists what iter_objects i (sp,kn) substobjs = let dir,mp = dir_of_sp sp, mp_of_kn kn in do_module exists what iter_objects i dir mp substobjs [] (* Interactive modules and module types cannot be recached! cache_mod* functions can be called only once (and "end_mod*" set the flag to false then) *) let cache_module ((sp,kn),substobjs) = let dir,mp = dir_of_sp sp, mp_of_kn kn in do_module false "cache" load_objects 1 dir mp substobjs [] (* When this function is called the module itself is already in the environment. This function loads its objects only *) let load_module i (oname,substobjs) = conv_names_do_module false "load" load_objects i oname substobjs let open_module i (oname,substobjs) = conv_names_do_module true "open" open_objects i oname substobjs let subst_module (subst,(mbids,mp,objs)) = (mbids,subst_mp subst mp, subst_objects subst objs) let classify_module substobjs = Substitute substobjs let (in_module : substitutive_objects -> obj), (out_module : obj -> substitutive_objects) = declare_object_full {(default_object "MODULE") with cache_function = cache_module; load_function = load_module; open_function = open_module; subst_function = subst_module; classify_function = classify_module } let cache_keep _ = anomaly "This module should not be cached!" let load_keep i ((sp,kn),seg) = let mp = mp_of_kn kn in let prefix = dir_of_sp sp, (mp,empty_dirpath) in begin try let prefix',objects = MPmap.find mp !modtab_objects in if prefix' <> prefix then anomaly "Two different modules with the same path!"; modtab_objects := MPmap.add mp (prefix,objects@seg) !modtab_objects; with Not_found -> anomaly "Keep objects before substitutive" end; load_objects i prefix seg let open_keep i ((sp,kn),seg) = let dirpath,mp = dir_of_sp sp, mp_of_kn kn in open_objects i (dirpath,(mp,empty_dirpath)) seg let in_modkeep : lib_objects -> obj = declare_object {(default_object "MODULE KEEP OBJECTS") with cache_function = cache_keep; load_function = load_keep; open_function = open_keep } (* we remember objects for a module type. In case of a declaration: Module M:SIG:=... The module M gets its objects from SIG *) let modtypetab = ref (MPmap.empty : substitutive_objects MPmap.t) (* currently started interactive module type. We remember its arguments if it is a functor type *) let openmodtype_info = ref ([],[] : mod_bound_id list * module_type_body list) let _ = Summary.declare_summary "MODTYPE-INFO" { Summary.freeze_function = (fun () -> !modtypetab,!openmodtype_info); Summary.unfreeze_function = (fun ft -> modtypetab := fst ft; openmodtype_info := snd ft); Summary.init_function = (fun () -> modtypetab := MPmap.empty; openmodtype_info := [],[]) } let cache_modtype ((sp,kn),(entry,modtypeobjs,sub_mty_l)) = let mp = mp_of_kn kn in (* We enrich the global environment *) let _ = match entry with | None -> anomaly "You must not recache interactive module types!" | Some (mte,inl) -> if mp <> Global.add_modtype (basename sp) mte inl then anomaly "Kernel and Library names do not match" in (* Using declare_modtype should lead here, where we check that any given subtyping is indeed accurate *) check_subtypes_mt mp sub_mty_l; if Nametab.exists_modtype sp then errorlabstrm "cache_modtype" (pr_path sp ++ str " already exists") ; Nametab.push_modtype (Nametab.Until 1) sp mp; modtypetab := MPmap.add mp modtypeobjs !modtypetab let load_modtype i ((sp,kn),(entry,modtypeobjs,_)) = assert (entry = None); if Nametab.exists_modtype sp then errorlabstrm "cache_modtype" (pr_path sp ++ str " already exists") ; Nametab.push_modtype (Nametab.Until i) sp (mp_of_kn kn); modtypetab := MPmap.add (mp_of_kn kn) modtypeobjs !modtypetab let open_modtype i ((sp,kn),(entry,_,_)) = assert (entry = None); if try Nametab.locate_modtype (qualid_of_path sp) <> (mp_of_kn kn) with Not_found -> true then errorlabstrm ("open_modtype") (pr_path sp ++ str " should already exist!"); Nametab.push_modtype (Nametab.Exactly i) sp (mp_of_kn kn) let subst_modtype (subst,(entry,(mbids,mp,objs),_)) = assert (entry = None); (entry,(mbids,subst_mp subst mp,subst_objects subst objs),[]) let classify_modtype (_,substobjs,_) = Substitute (None,substobjs,[]) type modtype_obj = (module_struct_entry * Entries.inline) option (* will be None in vo *) * substitutive_objects * module_type_body list let in_modtype : modtype_obj -> obj = declare_object {(default_object "MODULE TYPE") with cache_function = cache_modtype; open_function = open_modtype; load_function = load_modtype; subst_function = subst_modtype; classify_function = classify_modtype } let rec replace_module_object idl (mbids,mp,lib_stack) (mbids2,mp2,objs) mp1 = if mbids<>[] then anomaly "Unexpected functor objects"; let rec replace_idl = function | _,[] -> [] | id::idl,(id',obj)::tail when id = id' -> if object_tag obj <> "MODULE" then anomaly "MODULE expected!"; let substobjs = if idl = [] then let mp' = MPdot(mp, label_of_id id) in mbids, mp', subst_objects (map_mp mp1 mp' empty_delta_resolver) objs else replace_module_object idl (out_module obj) (mbids2,mp2,objs) mp in (id, in_module substobjs)::tail | idl,lobj::tail -> lobj::replace_idl (idl,tail) in (mbids, mp, replace_idl (idl,lib_stack)) let discr_resolver mb = match mb.mod_type with | SEBstruct _ -> Some mb.mod_delta | _ -> None (* when mp is a functor *) (* Small function to avoid module typing during substobjs retrivial *) let rec get_objs_modtype_application env = function | MSEident mp -> MPmap.find mp !modtypetab,Environ.lookup_modtype mp env,[] | MSEapply (fexpr, MSEident mp) -> let objs,mtb,mp_l= get_objs_modtype_application env fexpr in objs,mtb,mp::mp_l | MSEapply (_,mexpr) -> Modops.error_application_to_not_path mexpr | _ -> error "Application of a non-functor." let rec compute_subst env mbids sign mp_l inl = match mbids,mp_l with | _,[] -> mbids,empty_subst | [],r -> error "Application of a functor with too few arguments." | mbid::mbids,mp::mp_l -> let farg_id, farg_b, fbody_b = Modops.destr_functor env sign in let mb = Environ.lookup_module mp env in let mbid_left,subst = compute_subst env mbids fbody_b mp_l inl in let resolver = match discr_resolver mb with | None -> empty_delta_resolver | Some mp_delta -> Modops.inline_delta_resolver env inl mp farg_id farg_b mp_delta in mbid_left,join (map_mbid mbid mp resolver) subst let rec get_modtype_substobjs env mp_from inline = function MSEident ln -> MPmap.find ln !modtypetab | MSEfunctor (mbid,_,mte) -> let (mbids, mp, objs) = get_modtype_substobjs env mp_from inline mte in (mbid::mbids, mp, objs) | MSEwith (mty, With_Definition _) -> get_modtype_substobjs env mp_from inline mty | MSEwith (mty, With_Module (idl,mp1)) -> let substobjs = get_modtype_substobjs env mp_from inline mty in let modobjs = MPmap.find mp1 !modtab_substobjs in replace_module_object idl substobjs modobjs mp1 | MSEapply (fexpr, MSEident mp) as me -> let (mbids, mp1, objs),mtb_mp1,mp_l = get_objs_modtype_application env me in let mbids_left,subst = compute_subst env mbids mtb_mp1.typ_expr (List.rev mp_l) inline in (mbids_left, mp1,subst_objects subst objs) | MSEapply (_,mexpr) -> Modops.error_application_to_not_path mexpr (* push names of bound modules (and their components) to Nametab *) (* add objects associated to them *) let process_module_bindings argids args = let process_arg id (mbid,(mty,ann)) = let dir = make_dirpath [id] in let mp = MPbound mbid in let (mbids,mp_from,objs) = get_modtype_substobjs (Global.env()) mp (inline_annot ann) mty in let substobjs = (mbids,mp,subst_objects (map_mp mp_from mp empty_delta_resolver) objs)in do_module false "start" load_objects 1 dir mp substobjs [] in List.iter2 process_arg argids args (* Same with module_type_body *) let rec seb2mse = function | SEBident mp -> MSEident mp | SEBapply (s,s',_) -> MSEapply(seb2mse s, seb2mse s') | SEBwith (s,With_module_body (l,mp)) -> MSEwith(seb2mse s,With_Module(l,mp)) | SEBwith (s,With_definition_body(l,cb)) -> (match cb.const_body with | Def c -> MSEwith(seb2mse s,With_Definition(l,Declarations.force c)) | _ -> assert false) | _ -> failwith "seb2mse: received a non-atomic seb" let process_module_seb_binding mbid seb = process_module_bindings [id_of_mbid mbid] [mbid, (seb2mse seb, { ann_inline = DefaultInline; ann_scope_subst = [] })] let intern_args interp_modtype (idl,(arg,ann)) = let inl = inline_annot ann in let lib_dir = Lib.library_dp() in let mbids = List.map (fun (_,id) -> make_mbid lib_dir id) idl in let mty = interp_modtype (Global.env()) arg in let dirs = List.map (fun (_,id) -> make_dirpath [id]) idl in let (mbi,mp_from,objs) = get_modtype_substobjs (Global.env()) (MPbound (List.hd mbids)) inl mty in List.map2 (fun dir mbid -> let resolver = Global.add_module_parameter mbid mty inl in let mp = MPbound mbid in let substobjs = (mbi,mp,subst_objects (map_mp mp_from mp resolver) objs) in do_module false "interp" load_objects 1 dir mp substobjs []; (mbid,(mty,inl))) dirs mbids let start_module_ interp_modtype export id args res fs = let mp = Global.start_module id in let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in let res_entry_o, sub_body_l = match res with | Enforce (res,ann) -> let inl = inline_annot ann in let mte = interp_modtype (Global.env()) res in let _ = Mod_typing.translate_struct_type_entry (Global.env()) inl mte in Some (mte,inl), [] | Check resl -> None, build_subtypes interp_modtype mp arg_entries resl in let mbids = List.map fst arg_entries in openmod_info:=(mp,mbids,res_entry_o,sub_body_l); let prefix = Lib.start_module export id mp fs in Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModule prefix); Lib.add_frozen_state (); mp let end_module () = let oldoname,oldprefix,fs,lib_stack = Lib.end_module () in let mp,mbids, res_o, sub_l = !openmod_info in let substitute, keep, special = Lib.classify_segment lib_stack in let mp_from,substobjs, keep, special = try match res_o with | None -> (* the module is not sealed *) None,( mbids, mp, substitute), keep, special | Some (MSEident ln as mty, inline) -> let (mbids1,mp1,objs) = get_modtype_substobjs (Global.env()) mp inline mty in Some mp1,(mbids@mbids1,mp1,objs), [], [] | Some (MSEwith _ as mty, inline) -> let (mbids1,mp1,objs) = get_modtype_substobjs (Global.env()) mp inline mty in Some mp1,(mbids@mbids1,mp1,objs), [], [] | Some (MSEfunctor _, _) -> anomaly "Funsig cannot be here..." | Some (MSEapply _ as mty, inline) -> let (mbids1,mp1,objs) = get_modtype_substobjs (Global.env()) mp inline mty in Some mp1,(mbids@mbids1,mp1,objs), [], [] with Not_found -> anomaly "Module objects not found..." in (* must be called after get_modtype_substobjs, because of possible dependencies on functor arguments *) let id = basename (fst oldoname) in let mp,resolver = Global.end_module fs id res_o in check_subtypes mp sub_l; (* we substitute objects if the module is sealed by a signature (ie. mp_from != None *) let substobjs = match mp_from,substobjs with None,_ -> substobjs | Some mp_from,(mbids,_,objs) -> (mbids,mp,subst_objects (map_mp mp_from mp resolver) objs) in let node = in_module substobjs in let objects = if keep = [] || mbids <> [] then special@[node] (* no keep objects or we are defining a functor *) else special@[node;in_modkeep keep] (* otherwise *) in let newoname = Lib.add_leaves id objects in if (fst newoname) <> (fst oldoname) then anomaly "Names generated on start_ and end_module do not match"; if mp_of_kn (snd newoname) <> mp then anomaly "Kernel and Library names do not match"; Lib.add_frozen_state () (* to prevent recaching *); mp let module_objects mp = let prefix,objects = MPmap.find mp !modtab_objects in segment_of_objects prefix objects (************************************************************************) (* libraries *) type library_name = dir_path (* The first two will form substitutive_objects, the last one is keep *) type library_objects = module_path * lib_objects * lib_objects let register_library dir cenv objs digest = let mp = MPfile dir in let substobjs, keep = try ignore(Global.lookup_module mp); (* if it's in the environment, the cached objects should be correct *) Dirmap.find dir !library_cache with Not_found -> if mp <> Global.import cenv digest then anomaly "Unexpected disk module name"; let mp,substitute,keep = objs in let substobjs = [], mp, substitute in let modobjs = substobjs, keep in library_cache := Dirmap.add dir modobjs !library_cache; modobjs in do_module false "register_library" load_objects 1 dir mp substobjs keep let start_library dir = let mp = Global.start_library dir in openmod_info:=mp,[],None,[]; Lib.start_compilation dir mp; Lib.add_frozen_state () let end_library_hook = ref ignore let set_end_library_hook f = end_library_hook := f let end_library dir = !end_library_hook(); let prefix, lib_stack = Lib.end_compilation dir in let mp,cenv = Global.export dir in let substitute, keep, _ = Lib.classify_segment lib_stack in cenv,(mp,substitute,keep) (* implementation of Export M and Import M *) let really_import_module mp = let prefix,objects = MPmap.find mp !modtab_objects in open_objects 1 prefix objects let cache_import (_,(_,mp)) = (* for non-substitutive exports: let mp = Nametab.locate_module (qualid_of_dirpath dir) in *) really_import_module mp let classify_import (export,_ as obj) = if export then Substitute obj else Dispose let subst_import (subst,(export,mp as obj)) = let mp' = subst_mp subst mp in if mp'==mp then obj else (export,mp') let in_import = declare_object {(default_object "IMPORT MODULE") with cache_function = cache_import; open_function = (fun i o -> if i=1 then cache_import o); subst_function = subst_import; classify_function = classify_import } let import_module export mp = Lib.add_anonymous_leaf (in_import (export,mp)) (************************************************************************) (* module types *) let start_modtype_ interp_modtype id args mtys fs = let mp = Global.start_modtype id in let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in let sub_mty_l = build_subtypes interp_modtype mp arg_entries mtys in let mbids = List.map fst arg_entries in openmodtype_info := mbids, sub_mty_l; let prefix = Lib.start_modtype id mp fs in Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModtype prefix); Lib.add_frozen_state (); mp let end_modtype () = let oldoname,prefix,fs,lib_stack = Lib.end_modtype () in let id = basename (fst oldoname) in let substitute, _, special = Lib.classify_segment lib_stack in let mbids, sub_mty_l = !openmodtype_info in let mp = Global.end_modtype fs id in let modtypeobjs = mbids, mp, substitute in check_subtypes_mt mp sub_mty_l; let oname = Lib.add_leaves id (special@[in_modtype (None, modtypeobjs,[])]) in if fst oname <> fst oldoname then anomaly "Section paths generated on start_ and end_modtype do not match"; if (mp_of_kn (snd oname)) <> mp then anomaly "Kernel and Library names do not match"; Lib.add_frozen_state ()(* to prevent recaching *); mp let declare_modtype_ interp_modtype id args mtys (mty,ann) fs = let inl = inline_annot ann in let mmp = Global.start_modtype id in let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in let entry = funct_entry arg_entries (interp_modtype (Global.env()) mty) in (* NB: check of subtyping will be done in cache_modtype *) let sub_mty_l = build_subtypes interp_modtype mmp arg_entries mtys in let (mbids,mp_from,objs) = get_modtype_substobjs (Global.env()) mmp inl entry in (* Undo the simulated interactive building of the module type *) (* and declare the module type as a whole *) register_scope_subst ann.ann_scope_subst; let substobjs = (mbids,mmp, subst_objects (map_mp mp_from mmp empty_delta_resolver) objs) in reset_scope_subst (); Summary.unfreeze_summaries fs; ignore (add_leaf id (in_modtype (Some (entry,inl), substobjs, sub_mty_l))); mmp (* Small function to avoid module typing during substobjs retrivial *) let rec get_objs_module_application env = function | MSEident mp -> MPmap.find mp !modtab_substobjs,Environ.lookup_module mp env,[] | MSEapply (fexpr, MSEident mp) -> let objs,mtb,mp_l= get_objs_module_application env fexpr in objs,mtb,mp::mp_l | MSEapply (_,mexpr) -> Modops.error_application_to_not_path mexpr | _ -> error "Application of a non-functor." let rec get_module_substobjs env mp_from inl = function | MSEident mp -> MPmap.find mp !modtab_substobjs | MSEfunctor (mbid,mty,mexpr) -> let (mbids, mp, objs) = get_module_substobjs env mp_from inl mexpr in (mbid::mbids, mp, objs) | MSEapply (fexpr, MSEident mp) as me -> let (mbids, mp1, objs),mb_mp1,mp_l = get_objs_module_application env me in let mbids_left,subst = compute_subst env mbids mb_mp1.mod_type (List.rev mp_l) inl in (mbids_left, mp1,subst_objects subst objs) | MSEapply (_,mexpr) -> Modops.error_application_to_not_path mexpr | MSEwith (mty, With_Definition _) -> get_module_substobjs env mp_from inl mty | MSEwith (mty, With_Module (idl,mp)) -> assert false let declare_module_ interp_modtype interp_modexpr id args res mexpr_o fs = let mmp = Global.start_module id in let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in let funct f m = funct_entry arg_entries (f (Global.env ()) m) in let env = Global.env() in let mty_entry_o, subs, inl_res = match res with | Enforce (mty,ann) -> Some (funct interp_modtype mty), [], inline_annot ann | Check mtys -> None, build_subtypes interp_modtype mmp arg_entries mtys, default_inline () in (*let subs = List.map (Mod_typing.translate_module_type env mmp) mty_sub_l in *) let mexpr_entry_o, inl_expr, scl = match mexpr_o with | None -> None, default_inline (), [] | Some (mexpr,ann) -> Some (funct interp_modexpr mexpr), inline_annot ann, ann.ann_scope_subst in let entry = {mod_entry_type = mty_entry_o; mod_entry_expr = mexpr_entry_o } in let substobjs = match entry with | {mod_entry_type = Some mte} -> get_modtype_substobjs env mmp inl_res mte | {mod_entry_expr = Some mexpr} -> get_module_substobjs env mmp inl_expr mexpr | _ -> anomaly "declare_module: No type, no body ..." in let (mbids,mp_from,objs) = substobjs in (* Undo the simulated interactive building of the module *) (* and declare the module as a whole *) Summary.unfreeze_summaries fs; let mp = mp_of_kn (Lib.make_kn id) in let inl = if inl_expr = None then None else inl_res in (*PLTODO *) let mp_env,resolver = Global.add_module id entry inl in if mp_env <> mp then anomaly "Kernel and Library names do not match"; check_subtypes mp subs; register_scope_subst scl; let substobjs = (mbids,mp_env, subst_objects(map_mp mp_from mp_env resolver) objs) in reset_scope_subst (); ignore (add_leaf id (in_module substobjs)); mmp (* Include *) let rec subst_inc_expr subst me = match me with | MSEident mp -> MSEident (subst_mp subst mp) | MSEwith (me,With_Module(idl,mp)) -> MSEwith (subst_inc_expr subst me, With_Module(idl,subst_mp subst mp)) | MSEwith (me,With_Definition(idl,const))-> let const1 = Mod_subst.from_val const in let force = Mod_subst.force subst_mps in MSEwith (subst_inc_expr subst me, With_Definition(idl,force (subst_substituted subst const1))) | MSEapply (me1,me2) -> MSEapply (subst_inc_expr subst me1, subst_inc_expr subst me2) | MSEfunctor(mbid,me1,me2) -> MSEfunctor (mbid, subst_inc_expr subst me1, subst_inc_expr subst me2) let lift_oname (sp,kn) = let mp,_,_ = Names.repr_kn kn in let dir,_ = Libnames.repr_path sp in (dir,mp) let cache_include (oname,(me,(mbis,mp1,objs))) = let dir,mp1 = lift_oname oname in let prefix = (dir,(mp1,empty_dirpath)) in load_objects 1 prefix objs; open_objects 1 prefix objs let load_include i (oname,(me,(mbis,mp1,objs))) = let dir,mp1 = lift_oname oname in let prefix = (dir,(mp1,empty_dirpath)) in load_objects i prefix objs let open_include i (oname,(me,(mbis,mp1,objs))) = let dir,mp1 = lift_oname oname in let prefix = (dir,(mp1,empty_dirpath)) in open_objects i prefix objs let subst_include (subst,(me,substobj)) = let (mbids,mp,objs) = substobj in let substobjs = (mbids,subst_mp subst mp,subst_objects subst objs) in (subst_inc_expr subst me,substobjs) let classify_include (me,substobjs) = Substitute (me,substobjs) type include_obj = module_struct_entry * substitutive_objects let (in_include : include_obj -> obj), (out_include : obj -> include_obj) = declare_object_full {(default_object "INCLUDE") with cache_function = cache_include; load_function = load_include; open_function = open_include; subst_function = subst_include; classify_function = classify_include } let rec include_subst env mb mbids sign inline = match mbids with | [] -> empty_subst | mbid::mbids -> let farg_id, farg_b, fbody_b = Modops.destr_functor env sign in let subst = include_subst env mb mbids fbody_b inline in let mp_delta = Modops.inline_delta_resolver env inline mb.mod_mp farg_id farg_b mb.mod_delta in join (map_mbid mbid mb.mod_mp mp_delta) subst exception NothingToDo let get_includeself_substobjs env objs me is_mod inline = try let mb_mp = match me with | MSEident mp -> if is_mod then Environ.lookup_module mp env else Modops.module_body_of_type mp (Environ.lookup_modtype mp env) | MSEapply(fexpr, MSEident p) as mexpr -> let _,mb_mp,mp_l = if is_mod then get_objs_module_application env mexpr else let o,mtb_mp,mp_l = get_objs_modtype_application env mexpr in o,Modops.module_body_of_type mtb_mp.typ_mp mtb_mp,mp_l in List.fold_left (fun mb _ -> match mb.mod_type with | SEBfunctor(_,_,str) -> {mb with mod_type = str} | _ -> error "Application of a functor with too much arguments.") mb_mp mp_l | _ -> raise NothingToDo in let (mbids,mp_self,objects) = objs in let mb = Global.pack_module() in let subst = include_subst env mb mbids mb_mp.mod_type inline in ([],mp_self,subst_objects subst objects) with NothingToDo -> objs let declare_one_include_inner annot (me,is_mod) = let env = Global.env() in let mp1,_ = current_prefix () in let inl = inline_annot annot in let (mbids,mp,objs)= if is_mod then get_module_substobjs env mp1 inl me else get_modtype_substobjs env mp1 inl me in let (mbids,mp,objs) = if mbids <> [] then get_includeself_substobjs env (mbids,mp,objs) me is_mod inl else (mbids,mp,objs) in let id = current_mod_id() in let resolver = Global.add_include me is_mod inl in register_scope_subst annot.ann_scope_subst; let substobjs = (mbids,mp1, subst_objects (map_mp mp mp1 resolver) objs) in reset_scope_subst (); ignore (add_leaf id (in_include (me, substobjs))) let declare_one_include interp_struct (me_ast,annot) = declare_one_include_inner annot (interp_struct (Global.env()) me_ast) let declare_include_ interp_struct me_asts = List.iter (declare_one_include interp_struct) me_asts (** Versions of earlier functions taking care of the freeze/unfreeze of summaries *) let protect_summaries f = let fs = Summary.freeze_summaries () in try f fs with reraise -> (* Something wrong: undo the whole process *) Summary.unfreeze_summaries fs; raise reraise let declare_include interp_struct me_asts = protect_summaries (fun _ -> declare_include_ interp_struct me_asts) let declare_modtype interp_mt interp_mix id args mtys mty_l = let declare_mt fs = match mty_l with | [] -> assert false | [mty] -> declare_modtype_ interp_mt id args mtys mty fs | mty_l -> ignore (start_modtype_ interp_mt id args mtys fs); declare_include_ interp_mix mty_l; end_modtype () in protect_summaries declare_mt let start_modtype interp_modtype id args mtys = protect_summaries (start_modtype_ interp_modtype id args mtys) let declare_module interp_mt interp_me interp_mix id args mtys me_l = let declare_me fs = match me_l with | [] -> declare_module_ interp_mt interp_me id args mtys None fs | [me] -> declare_module_ interp_mt interp_me id args mtys (Some me) fs | me_l -> ignore (start_module_ interp_mt None id args mtys fs); declare_include_ interp_mix me_l; end_module () in protect_summaries declare_me let start_module interp_modtype export id args res = protect_summaries (start_module_ interp_modtype export id args res) (*s Iterators. *) let iter_all_segments f = let _ = MPmap.iter (fun _ (prefix,objects) -> let rec apply_obj (id,obj) = match object_tag obj with | "INCLUDE" -> let (_,(_,_,objs)) = out_include obj in List.iter apply_obj objs | _ -> f (make_oname prefix id) obj in List.iter apply_obj objects) !modtab_objects in let rec apply_node = function | sp, Leaf o -> f sp o | _ -> () in List.iter apply_node (Lib.contents_after None) let debug_print_modtab _ = let pr_seg = function | [] -> str "[]" | l -> str ("[." ^ string_of_int (List.length l) ^ ".]") in let pr_modinfo mp (prefix,objects) s = s ++ str (string_of_mp mp) ++ (spc ()) ++ (pr_seg (segment_of_objects prefix objects)) in let modules = MPmap.fold pr_modinfo !modtab_objects (mt ()) in hov 0 modules coq-8.4pl4/library/declaremods.mli0000644000175000017500000001140512326224777016265 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string (** Which inline annotations should we honor, either None or the ones whose level is less or equal to the given integer *) type inline = | NoInline | DefaultInline | InlineAt of int (** The type of annotations for functor applications *) type funct_app_annot = { ann_inline : inline; ann_scope_subst : scope_subst } type 'a annotated = ('a * funct_app_annot) (** {6 Modules } *) (** [declare_module interp_modtype interp_modexpr id fargs typ expr] declares module [id], with type constructed by [interp_modtype] from functor arguments [fargs] and [typ] and with module body constructed by [interp_modtype] from functor arguments [fargs] and by [interp_modexpr] from [expr]. At least one of [typ], [expr] must be non-empty. The [bool] in [typ] tells if the module must be abstracted [true] with respect to the module type or merely matched without any restriction [false]. *) val declare_module : (env -> 'modast -> module_struct_entry) -> (env -> 'modast -> module_struct_entry) -> (env -> 'modast -> module_struct_entry * bool) -> identifier -> (identifier located list * ('modast annotated)) list -> ('modast annotated) module_signature -> ('modast annotated) list -> module_path val start_module : (env -> 'modast -> module_struct_entry) -> bool option -> identifier -> (identifier located list * ('modast annotated)) list -> ('modast annotated) module_signature -> module_path val end_module : unit -> module_path (** {6 Module types } *) val declare_modtype : (env -> 'modast -> module_struct_entry) -> (env -> 'modast -> module_struct_entry * bool) -> identifier -> (identifier located list * ('modast annotated)) list -> ('modast annotated) list -> ('modast annotated) list -> module_path val start_modtype : (env -> 'modast -> module_struct_entry) -> identifier -> (identifier located list * ('modast annotated)) list -> ('modast annotated) list -> module_path val end_modtype : unit -> module_path (** {6 ... } *) (** Objects of a module. They come in two lists: the substitutive ones and the other *) val module_objects : module_path -> library_segment (** {6 Libraries i.e. modules on disk } *) type library_name = dir_path type library_objects val register_library : library_name -> Safe_typing.compiled_library -> library_objects -> Digest.t -> unit val start_library : library_name -> unit val end_library : library_name -> Safe_typing.compiled_library * library_objects (** set a function to be executed at end_library *) val set_end_library_hook : (unit -> unit) -> unit (** [really_import_module mp] opens the module [mp] (in a Caml sense). It modifies Nametab and performs the [open_object] function for every object of the module. *) val really_import_module : module_path -> unit (** [import_module export mp] is a synchronous version of [really_import_module]. If [export] is [true], the module is also opened every time the module containing it is. *) val import_module : bool -> module_path -> unit (** Include *) val declare_include : (env -> 'struct_expr -> module_struct_entry * bool) -> ('struct_expr annotated) list -> unit (** {6 ... } *) (** [iter_all_segments] iterate over all segments, the modules' segments first and then the current segment. Modules are presented in an arbitrary order. The given function is applied to all leaves (together with their section path). *) val iter_all_segments : (object_name -> obj -> unit) -> unit val debug_print_modtab : unit -> Pp.std_ppcmds (*i val debug_print_modtypetab : unit -> Pp.std_ppcmds i*) (** For translator *) val process_module_bindings : module_ident list -> (mod_bound_id * (module_struct_entry annotated)) list -> unit (** For Printer *) val process_module_seb_binding : mod_bound_id -> Declarations.struct_expr_body -> unit coq-8.4pl4/library/impargs.mli0000644000175000017500000001315712326224777015453 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val make_strict_implicit_args : bool -> unit val make_strongly_strict_implicit_args : bool -> unit val make_reversible_pattern_implicit_args : bool -> unit val make_contextual_implicit_args : bool -> unit val make_maximal_implicit_args : bool -> unit val is_implicit_args : unit -> bool val is_strict_implicit_args : unit -> bool val is_strongly_strict_implicit_args : unit -> bool val is_reversible_pattern_implicit_args : unit -> bool val is_contextual_implicit_args : unit -> bool val is_maximal_implicit_args : unit -> bool type implicits_flags val with_implicits : implicits_flags -> ('a -> 'b) -> 'a -> 'b (** {6 ... } *) (** An [implicits_list] is a list of positions telling which arguments of a reference can be automatically infered *) type argument_position = | Conclusion | Hyp of int (** We remember various information about why an argument is inferable as implicit *) type implicit_explanation = | DepRigid of argument_position (** means that the implicit argument can be found by unification along a rigid path (we do not print the arguments of this kind if there is enough arguments to infer them) *) | DepFlex of argument_position (** means that the implicit argument can be found by unification along a collapsable path only (e.g. as x in (P x) where P is another argument) (we do (defensively) print the arguments of this kind) *) | DepFlexAndRigid of (*flex*) argument_position * (*rig*) argument_position (** means that the least argument from which the implicit argument can be inferred is following a collapsable path but there is a greater argument from where the implicit argument is inferable following a rigid path (useful to know how to print a partial application) *) | Manual (** means the argument has been explicitely set as implicit. *) (** We also consider arguments inferable from the conclusion but it is operational only if [conclusion_matters] is true. *) type maximal_insertion = bool (** true = maximal contextual insertion *) type force_inference = bool (** true = always infer, never turn into evar/subgoal *) type implicit_status = (identifier * implicit_explanation * (maximal_insertion * force_inference)) option (** [None] = Not implicit *) type implicit_side_condition type implicits_list = implicit_side_condition * implicit_status list val is_status_implicit : implicit_status -> bool val is_inferable_implicit : bool -> int -> implicit_status -> bool val name_of_implicit : implicit_status -> identifier val maximal_insertion_of : implicit_status -> bool val force_inference_of : implicit_status -> bool val positions_of_implicits : implicits_list -> int list (** A [manual_explicitation] is a tuple of a positional or named explicitation with maximal insertion, force inference and force usage flags. Forcing usage makes the argument implicit even if the automatic inference considers it not inferable. *) type manual_explicitation = Topconstr.explicitation * (maximal_insertion * force_inference * bool) type manual_implicits = manual_explicitation list val compute_implicits_with_manual : env -> types -> bool -> manual_implicits -> implicit_status list val compute_implicits_names : env -> types -> name list (** {6 Computation of implicits (done using the global environment). } *) val declare_var_implicits : variable -> unit val declare_constant_implicits : constant -> unit val declare_mib_implicits : mutual_inductive -> unit val declare_implicits : bool -> global_reference -> unit (** [declare_manual_implicits local ref enriching l] Manual declaration of which arguments are expected implicit. If not set, we decide if it should enrich by automatically inferd implicits depending on the current state. Unsets implicits if [l] is empty. *) val declare_manual_implicits : bool -> global_reference -> ?enriching:bool -> manual_implicits list -> unit (** If the list is empty, do nothing, otherwise declare the implicits. *) val maybe_declare_manual_implicits : bool -> global_reference -> ?enriching:bool -> manual_implicits -> unit val implicits_of_global : global_reference -> implicits_list list val extract_impargs_data : implicits_list list -> ((int * int) option * implicit_status list) list val lift_implicits : int -> manual_implicits -> manual_implicits val make_implicits_list : implicit_status list -> implicits_list list val drop_first_implicits : int -> implicits_list -> implicits_list val select_impargs_size : int -> implicits_list list -> implicit_status list val select_stronger_impargs : implicits_list list -> implicit_status list type implicit_interactive_request type implicit_discharge_request = | ImplLocal | ImplConstant of constant * implicits_flags | ImplMutualInductive of mutual_inductive * implicits_flags | ImplInteractive of global_reference * implicits_flags * implicit_interactive_request coq-8.4pl4/library/doc.tex0000644000175000017500000000100012326224777014555 0ustar stephsteph \newpage \section*{The Coq library} \ocwsection \label{library} This chapter describes the \Coq\ library, which is made of two parts: \begin{itemize} \item a general mechanism to keep a trace of all operations and of the state of the system, with backtrack capabilities; \item a global environment for the CCI, with functions to export and import compiled modules. \end{itemize} The modules of the library are organized as follows. \bigskip \begin{center}\epsfig{file=library.dep.ps}\end{center} coq-8.4pl4/library/lib.mli0000644000175000017500000001747012326224777014561 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Libnames.object_prefix -> lib_objects -> unit val load_objects : int -> Libnames.object_prefix -> lib_objects -> unit val subst_objects : Mod_subst.substitution -> lib_objects -> lib_objects (*val load_and_subst_objects : int -> Libnames.object_prefix -> Mod_subst.substitution -> lib_objects -> lib_objects*) (** [classify_segment seg] verifies that there are no OpenedThings, clears ClosedSections and FrozenStates and divides Leafs according to their answers to the [classify_object] function in three groups: [Substitute], [Keep], [Anticipate] respectively. The order of each returned list is the same as in the input list. *) val classify_segment : library_segment -> lib_objects * lib_objects * Libobject.obj list (** [segment_of_objects prefix objs] forms a list of Leafs *) val segment_of_objects : Libnames.object_prefix -> lib_objects -> library_segment (** {6 ... } *) (** Adding operations (which call the [cache] method, and getting the current list of operations (most recent ones coming first). *) val add_leaf : Names.identifier -> Libobject.obj -> Libnames.object_name val add_anonymous_leaf : Libobject.obj -> unit (** this operation adds all objects with the same name and calls [load_object] for each of them *) val add_leaves : Names.identifier -> Libobject.obj list -> Libnames.object_name val add_frozen_state : unit -> unit (** {6 ... } *) (** The function [contents_after] returns the current library segment, starting from a given section path. If not given, the entire segment is returned. *) val contents_after : Libnames.object_name option -> library_segment (** {6 Functions relative to current path } *) (** User-side names *) val cwd : unit -> Names.dir_path val cwd_except_section : unit -> Names.dir_path val current_dirpath : bool -> Names.dir_path (* false = except sections *) val make_path : Names.identifier -> Libnames.full_path val make_path_except_section : Names.identifier -> Libnames.full_path val path_of_include : unit -> Libnames.full_path (** Kernel-side names *) val current_prefix : unit -> Names.module_path * Names.dir_path val make_kn : Names.identifier -> Names.kernel_name val make_con : Names.identifier -> Names.constant (** Are we inside an opened section *) val sections_are_opened : unit -> bool val sections_depth : unit -> int (** Are we inside an opened module type *) val is_module_or_modtype : unit -> bool val is_modtype : unit -> bool val is_module : unit -> bool val current_mod_id : unit -> Names.module_ident (** Returns the opening node of a given name *) val find_opening_node : Names.identifier -> node (** {6 Modules and module types } *) val start_module : export -> Names.module_ident -> Names.module_path -> Summary.frozen -> Libnames.object_prefix val start_modtype : Names.module_ident -> Names.module_path -> Summary.frozen -> Libnames.object_prefix val end_module : unit -> Libnames.object_name * Libnames.object_prefix * Summary.frozen * library_segment val end_modtype : unit -> Libnames.object_name * Libnames.object_prefix * Summary.frozen * library_segment (** [Lib.add_frozen_state] must be called after each of the above functions *) (** {6 Compilation units } *) val start_compilation : Names.dir_path -> Names.module_path -> unit val end_compilation : Names.dir_path -> Libnames.object_prefix * library_segment (** The function [library_dp] returns the [dir_path] of the current compiling library (or [default_library]) *) val library_dp : unit -> Names.dir_path (** Extract the library part of a name even if in a section *) val dp_of_mp : Names.module_path -> Names.dir_path val split_mp : Names.module_path -> Names.dir_path * Names.dir_path val split_modpath : Names.module_path -> Names.dir_path * Names.identifier list val library_part : Libnames.global_reference -> Names.dir_path val remove_section_part : Libnames.global_reference -> Names.dir_path (** {6 Sections } *) val open_section : Names.identifier -> unit val close_section : unit -> unit (** {6 Backtracking } *) (** NB: The next commands are low-level ones, do not use them directly otherwise the command history stack in [Backtrack] will be out-of-sync. Also note that [reset_initial] is now [reset_label first_command_label] *) (** Adds a "dummy" entry in lib_stk with a unique new label number. *) val mark_end_of_command : unit -> unit (** Returns the current label number *) val current_command_label : unit -> int (** The first label number *) val first_command_label : int (** [reset_label n] resets [lib_stk] to the label n registered by [mark_end_of_command()]. It forgets anything registered after this label. The label should be strictly in the past. *) val reset_label : int -> unit (** search the label registered immediately before adding some definition *) val label_before_name : Names.identifier Util.located -> int (** {6 We can get and set the state of the operations (used in [States]). } *) type frozen val freeze : unit -> frozen val unfreeze : frozen -> unit val init : unit -> unit (** XML output hooks *) val set_xml_open_section : (Names.identifier -> unit) -> unit val set_xml_close_section : (Names.identifier -> unit) -> unit type binding_kind = Explicit | Implicit (** {6 Section management for discharge } *) type variable_info = Names.identifier * binding_kind * Term.constr option * Term.types type variable_context = variable_info list val instance_from_variable_context : variable_context -> Names.identifier array val named_of_variable_context : variable_context -> Sign.named_context val section_segment_of_constant : Names.constant -> variable_context val section_segment_of_mutual_inductive: Names.mutual_inductive -> variable_context val section_instance : Libnames.global_reference -> Names.identifier array val is_in_section : Libnames.global_reference -> bool val add_section_variable : Names.identifier -> binding_kind -> unit val add_section_constant : Names.constant -> Sign.named_context -> unit val add_section_kn : Names.mutual_inductive -> Sign.named_context -> unit val replacement_context : unit -> (Names.identifier array Names.Cmap.t * Names.identifier array Names.Mindmap.t) (** {6 Discharge: decrease the section level if in the current section } *) val discharge_kn : Names.mutual_inductive -> Names.mutual_inductive val discharge_con : Names.constant -> Names.constant val discharge_global : Libnames.global_reference -> Libnames.global_reference val discharge_inductive : Names.inductive -> Names.inductive coq-8.4pl4/library/states.mli0000644000175000017500000000254212326224777015310 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit val extern_state : string -> unit type state val freeze : unit -> state val unfreeze : state -> unit (** {6 Rollback } *) (** [with_heavy_rollback f x] applies [f] to [x] and restores the state of the whole system as it was before the evaluation if an exception is raised. *) val with_heavy_rollback : ('a -> 'b) -> (exn -> exn) -> 'a -> 'b (** [with_state_protection f x] applies [f] to [x] and restores the state of the whole system as it was before the evaluation of f *) val with_state_protection : ('a -> 'b) -> 'a -> 'b coq-8.4pl4/library/states.ml0000644000175000017500000000265312326224777015142 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* if !Flags.load_proofs <> Flags.Force then Util.error "Write State only works with option -force-load-proofs"; raw_extern s (freeze())), (fun s -> unfreeze (with_magic_number_check (raw_intern (Library.get_load_paths ())) s); Library.overwrite_library_filenames s) (* Rollback. *) let with_heavy_rollback f h x = let st = freeze () in try f x with reraise -> let e = h reraise in (unfreeze st; raise e) let with_state_protection f x = let st = freeze () in try let a = f x in unfreeze st; a with reraise -> (unfreeze st; raise reraise) coq-8.4pl4/library/global.ml0000644000175000017500000001201212326224777015065 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* !global_env); unfreeze_function = (fun fr -> global_env := fr); init_function = (fun () -> global_env := empty_environment) } (* Then we export the functions of [Typing] on that environment. *) let universes () = universes (env()) let named_context () = named_context (env()) let named_context_val () = named_context_val (env()) let push_named_assum a = let (cst,env) = push_named_assum a !global_env in global_env := env; cst let push_named_def d = let (cst,env) = push_named_def d !global_env in global_env := env; cst let add_thing add dir id thing = let kn, newenv = add dir (label_of_id id) thing !global_env in global_env := newenv; kn let add_constant = add_thing add_constant let add_mind = add_thing add_mind let add_modtype x y inl = add_thing (fun _ x y -> add_modtype x y inl) () x y let add_module id me inl = let l = label_of_id id in let mp,resolve,new_env = add_module l me inl !global_env in global_env := new_env; mp,resolve let add_constraints c = global_env := add_constraints c !global_env let set_engagement c = global_env := set_engagement c !global_env let add_include me is_module inl = let resolve,newenv = add_include me is_module inl !global_env in global_env := newenv; resolve let start_module id = let l = label_of_id id in let mp,newenv = start_module l !global_env in global_env := newenv; mp let end_module fs id mtyo = let l = label_of_id id in let mp,resolve,newenv = end_module l mtyo !global_env in Summary.unfreeze_summaries fs; global_env := newenv; mp,resolve let add_module_parameter mbid mte inl = let resolve,newenv = add_module_parameter mbid mte inl !global_env in global_env := newenv; resolve let start_modtype id = let l = label_of_id id in let mp,newenv = start_modtype l !global_env in global_env := newenv; mp let end_modtype fs id = let l = label_of_id id in let kn,newenv = end_modtype l !global_env in Summary.unfreeze_summaries fs; global_env := newenv; kn let pack_module () = pack_module !global_env let lookup_named id = lookup_named id (env()) let lookup_constant kn = lookup_constant kn (env()) let lookup_inductive ind = Inductive.lookup_mind_specif (env()) ind let lookup_mind kn = lookup_mind kn (env()) let lookup_module mp = lookup_module mp (env()) let lookup_modtype kn = lookup_modtype kn (env()) let constant_of_delta_kn kn = let resolver,resolver_param = (delta_of_senv !global_env) in (* TODO : are resolver and resolver_param orthogonal ? the effect of resolver is lost if resolver_param isn't trivial at that spot. *) Mod_subst.constant_of_delta resolver_param (Mod_subst.constant_of_delta_kn resolver kn) let mind_of_delta_kn kn = let resolver,resolver_param = (delta_of_senv !global_env) in (* TODO idem *) Mod_subst.mind_of_delta resolver_param (Mod_subst.mind_of_delta_kn resolver kn) let exists_objlabel id = exists_objlabel id !global_env let start_library dir = let mp,newenv = start_library dir !global_env in global_env := newenv; mp let export s = export !global_env s let import cenv digest = let mp,newenv = import cenv digest !global_env in global_env := newenv; mp (*s Function to get an environment from the constants part of the global environment and a given context. *) let env_of_context hyps = reset_with_named_context hyps (env()) open Libnames let type_of_reference env = function | VarRef id -> Environ.named_type id env | ConstRef c -> Typeops.type_of_constant env c | IndRef ind -> let specif = Inductive.lookup_mind_specif env ind in Inductive.type_of_inductive env specif | ConstructRef cstr -> let specif = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in Inductive.type_of_constructor cstr specif let type_of_global t = type_of_reference (env ()) t (* spiwack: register/unregister functions for retroknowledge *) let register field value by_clause = let entry = kind_of_term value in let senv = Safe_typing.register !global_env field entry by_clause in global_env := senv coq-8.4pl4/library/declare.mli0000644000175000017500000000603212326224777015402 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* variable_declaration -> object_name (** Declaration of global constructions i.e. Definition/Theorem/Axiom/Parameter/... *) type constant_declaration = constant_entry * logical_kind (** [declare_constant id cd] declares a global declaration (constant/parameter) with name [id] in the current section; it returns the full path of the declaration internal specify if the constant has been created by the kernel or by the user, and in the former case, if its errors should be silent *) type internal_flag = | KernelVerbose | KernelSilent | UserVerbose val declare_constant : ?internal:internal_flag -> identifier -> constant_declaration -> constant (** [declare_mind me] declares a block of inductive types with their constructors in the current section; it returns the path of the whole block (boolean must be true iff it is a record) *) val declare_mind : internal_flag -> mutual_inductive_entry -> object_name (** Hooks for XML output *) val set_xml_declare_variable : (object_name -> unit) -> unit val set_xml_declare_constant : (internal_flag * constant -> unit) -> unit val set_xml_declare_inductive : (internal_flag * object_name -> unit) -> unit (** Hook for the cache function of constants and inductives *) val add_cache_hook : (full_path -> unit) -> unit (** Declaration messages *) val definition_message : identifier -> unit val assumption_message : identifier -> unit val fixpoint_message : int array option -> identifier list -> unit val cofixpoint_message : identifier list -> unit val recursive_message : bool (** true = fixpoint *) -> int array option -> identifier list -> unit val exists_name : identifier -> bool coq-8.4pl4/library/global.mli0000644000175000017500000000743712326224777015255 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* safe_environment val env : unit -> Environ.env val env_is_empty : unit -> bool val universes : unit -> universes val named_context_val : unit -> Environ.named_context_val val named_context : unit -> Sign.named_context val env_is_empty : unit -> bool (** {6 Extending env with variables and local definitions } *) val push_named_assum : (identifier * types) -> Univ.constraints val push_named_def : (identifier * constr * types option) -> Univ.constraints (** {6 ... } *) (** Adding constants, inductives, modules and module types. All these functions verify that given names match those generated by kernel *) val add_constant : dir_path -> identifier -> global_declaration -> constant val add_mind : dir_path -> identifier -> mutual_inductive_entry -> mutual_inductive val add_module : identifier -> module_entry -> inline -> module_path * delta_resolver val add_modtype : identifier -> module_struct_entry -> inline -> module_path val add_include : module_struct_entry -> bool -> inline -> delta_resolver val add_constraints : constraints -> unit val set_engagement : engagement -> unit (** {6 Interactive modules and module types } Both [start_*] functions take the [dir_path] argument to create a [mod_self_id]. This should be the name of the compilation unit. *) (** [start_*] functions return the [module_path] valid for components of the started module / module type *) val start_module : identifier -> module_path val end_module : Summary.frozen ->identifier -> (module_struct_entry * inline) option -> module_path * delta_resolver val add_module_parameter : mod_bound_id -> module_struct_entry -> inline -> delta_resolver val start_modtype : identifier -> module_path val end_modtype : Summary.frozen -> identifier -> module_path val pack_module : unit -> module_body (** Queries *) val lookup_named : variable -> named_declaration val lookup_constant : constant -> constant_body val lookup_inductive : inductive -> mutual_inductive_body * one_inductive_body val lookup_mind : mutual_inductive -> mutual_inductive_body val lookup_module : module_path -> module_body val lookup_modtype : module_path -> module_type_body val constant_of_delta_kn : kernel_name -> constant val mind_of_delta_kn : kernel_name -> mutual_inductive val exists_objlabel : label -> bool (** Compiled modules *) val start_library : dir_path -> module_path val export : dir_path -> module_path * compiled_library val import : compiled_library -> Digest.t -> module_path (** {6 ... } *) (** Function to get an environment from the constants part of the global * environment and a given context. *) val type_of_global : Libnames.global_reference -> types val env_of_context : Environ.named_context_val -> Environ.env (** spiwack: register/unregister function for retroknowledge *) val register : Retroknowledge.field -> constr -> constr -> unit coq-8.4pl4/library/goptionstyp.mli0000644000175000017500000000165412326224777016407 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | _ -> false let isConstRef = function ConstRef _ -> true | _ -> false let isIndRef = function IndRef _ -> true | _ -> false let isConstructRef = function ConstructRef _ -> true | _ -> false let eq_gr gr1 gr2 = match gr1,gr2 with | ConstRef con1, ConstRef con2 -> eq_constant con1 con2 | IndRef kn1,IndRef kn2 -> eq_ind kn1 kn2 | ConstructRef kn1,ConstructRef kn2 -> eq_constructor kn1 kn2 | _,_ -> gr1=gr2 let destVarRef = function VarRef ind -> ind | _ -> failwith "destVarRef" let destConstRef = function ConstRef ind -> ind | _ -> failwith "destConstRef" let destIndRef = function IndRef ind -> ind | _ -> failwith "destIndRef" let destConstructRef = function ConstructRef ind -> ind | _ -> failwith "destConstructRef" let subst_constructor subst ((kn,i),j as ref) = let kn' = subst_ind subst kn in if kn==kn' then ref, mkConstruct ref else ((kn',i),j), mkConstruct ((kn',i),j) let subst_global subst ref = match ref with | VarRef var -> ref, mkVar var | ConstRef kn -> let kn',t = subst_con subst kn in if kn==kn' then ref, mkConst kn else ConstRef kn', t | IndRef (kn,i) -> let kn' = subst_ind subst kn in if kn==kn' then ref, mkInd (kn,i) else IndRef(kn',i), mkInd (kn',i) | ConstructRef ((kn,i),j as c) -> let c',t = subst_constructor subst c in if c'==c then ref,t else ConstructRef c', t let canonical_gr = function | ConstRef con -> ConstRef(constant_of_kn(canonical_con con)) | IndRef (kn,i) -> IndRef(mind_of_kn(canonical_mind kn),i) | ConstructRef ((kn,i),j )-> ConstructRef((mind_of_kn(canonical_mind kn),i),j) | VarRef id -> VarRef id let global_of_constr c = match kind_of_term c with | Const sp -> ConstRef sp | Ind ind_sp -> IndRef ind_sp | Construct cstr_cp -> ConstructRef cstr_cp | Var id -> VarRef id | _ -> raise Not_found let constr_of_global = function | VarRef id -> mkVar id | ConstRef sp -> mkConst sp | ConstructRef sp -> mkConstruct sp | IndRef sp -> mkInd sp let constr_of_reference = constr_of_global let reference_of_constr = global_of_constr let global_ord_gen fc fmi x y = let ind_ord (indx,ix) (indy,iy) = let c = Pervasives.compare ix iy in if c = 0 then kn_ord (fmi indx) (fmi indy) else c in match x, y with | ConstRef cx, ConstRef cy -> kn_ord (fc cx) (fc cy) | IndRef indx, IndRef indy -> ind_ord indx indy | ConstructRef (indx,jx), ConstructRef (indy,jy) -> let c = Pervasives.compare jx jy in if c = 0 then ind_ord indx indy else c | _, _ -> Pervasives.compare x y let global_ord_can = global_ord_gen canonical_con canonical_mind let global_ord_user = global_ord_gen user_con user_mind (* By default, [global_reference] are ordered on their canonical part *) module RefOrdered = struct type t = global_reference let compare = global_ord_can end module RefOrdered_env = struct type t = global_reference let compare = global_ord_user end module Refset = Set.Make(RefOrdered) module Refmap = Map.Make(RefOrdered) (* Extended global references *) type syndef_name = kernel_name type extended_global_reference = | TrueGlobal of global_reference | SynDef of syndef_name (* We order [extended_global_reference] via their user part (cf. pretty printer) *) module ExtRefOrdered = struct type t = extended_global_reference let compare x y = match x, y with | TrueGlobal rx, TrueGlobal ry -> global_ord_user rx ry | SynDef knx, SynDef kny -> kn_ord knx kny | _, _ -> Pervasives.compare x y end (**********************************************) let pr_dirpath sl = (str (string_of_dirpath sl)) (*s Operations on dirpaths *) (* Pop the last n module idents *) let pop_dirpath_n n dir = make_dirpath (list_skipn n (repr_dirpath dir)) let pop_dirpath p = match repr_dirpath p with | [] -> anomaly "dirpath_prefix: empty dirpath" | _::l -> make_dirpath l let is_dirpath_prefix_of d1 d2 = list_prefix_of (List.rev (repr_dirpath d1)) (List.rev (repr_dirpath d2)) let chop_dirpath n d = let d1,d2 = list_chop n (List.rev (repr_dirpath d)) in make_dirpath (List.rev d1), make_dirpath (List.rev d2) let drop_dirpath_prefix d1 d2 = let d = Util.list_drop_prefix (List.rev (repr_dirpath d1)) (List.rev (repr_dirpath d2)) in make_dirpath (List.rev d) let append_dirpath d1 d2 = make_dirpath (repr_dirpath d2 @ repr_dirpath d1) (* To know how qualified a name should be to be understood in the current env*) let add_dirpath_prefix id d = make_dirpath (repr_dirpath d @ [id]) let split_dirpath d = let l = repr_dirpath d in (make_dirpath (List.tl l), List.hd l) let add_dirpath_suffix p id = make_dirpath (id :: repr_dirpath p) (* parsing *) let parse_dir s = let len = String.length s in let rec decoupe_dirs dirs n = if n = len && n > 0 then error (s ^ " is an invalid path."); if n >= len then dirs else let pos = try String.index_from s n '.' with Not_found -> len in if pos = n then error (s ^ " is an invalid path."); let dir = String.sub s n (pos-n) in decoupe_dirs ((id_of_string dir)::dirs) (pos+1) in decoupe_dirs [] 0 let dirpath_of_string s = make_dirpath (if s = "" then [] else parse_dir s) let string_of_dirpath = Names.string_of_dirpath module Dirset = Set.Make(struct type t = dir_path let compare = compare end) module Dirmap = Map.Make(struct type t = dir_path let compare = compare end) (*s Section paths are absolute names *) type full_path = { dirpath : dir_path ; basename : identifier } let make_path pa id = { dirpath = pa; basename = id } let repr_path { dirpath = pa; basename = id } = (pa,id) (* parsing and printing of section paths *) let string_of_path sp = let (sl,id) = repr_path sp in if repr_dirpath sl = [] then string_of_id id else (string_of_dirpath sl) ^ "." ^ (string_of_id id) let sp_ord sp1 sp2 = let (p1,id1) = repr_path sp1 and (p2,id2) = repr_path sp2 in let p_bit = compare p1 p2 in if p_bit = 0 then id_ord id1 id2 else p_bit module SpOrdered = struct type t = full_path let compare = sp_ord end module Spmap = Map.Make(SpOrdered) let dirpath sp = let (p,_) = repr_path sp in p let basename sp = let (_,id) = repr_path sp in id let path_of_string s = try let dir, id = split_dirpath (dirpath_of_string s) in make_path dir id with | Invalid_argument _ -> invalid_arg "path_of_string" let pr_path sp = str (string_of_path sp) let restrict_path n sp = let dir, s = repr_path sp in let dir' = list_firstn n (repr_dirpath dir) in make_path (make_dirpath dir') s let encode_mind dir id = make_mind (MPfile dir) empty_dirpath (label_of_id id) let encode_con dir id = make_con (MPfile dir) empty_dirpath (label_of_id id) let decode_mind kn = let rec dir_of_mp = function | MPfile dir -> repr_dirpath dir | MPbound mbid -> let _,_,dp = repr_mbid mbid in let id = id_of_mbid mbid in id::(repr_dirpath dp) | MPdot(mp,l) -> (id_of_label l)::(dir_of_mp mp) in let mp,sec_dir,l = repr_mind kn in if (repr_dirpath sec_dir) = [] then (make_dirpath (dir_of_mp mp)),id_of_label l else anomaly "Section part should be empty!" let decode_con kn = let mp,sec_dir,l = repr_con kn in match mp,(repr_dirpath sec_dir) with MPfile dir,[] -> (dir,id_of_label l) | _ , [] -> anomaly "MPfile expected!" | _ -> anomaly "Section part should be empty!" (*s qualified names *) type qualid = full_path let make_qualid = make_path let repr_qualid = repr_path let string_of_qualid = string_of_path let pr_qualid = pr_path let qualid_of_string = path_of_string let qualid_of_path sp = sp let qualid_of_ident id = make_qualid empty_dirpath id let qualid_of_dirpath dir = let (l,a) = split_dirpath dir in make_qualid l a type object_name = full_path * kernel_name type object_prefix = dir_path * (module_path * dir_path) let make_oname (dirpath,(mp,dir)) id = make_path dirpath id, make_kn mp dir (label_of_id id) (* to this type are mapped dir_path's in the nametab *) type global_dir_reference = | DirOpenModule of object_prefix | DirOpenModtype of object_prefix | DirOpenSection of object_prefix | DirModule of object_prefix | DirClosedSection of dir_path (* this won't last long I hope! *) (* | ModRef mp -> let mp' = subst_modpath subst mp in if mp==mp' then ref else ModRef mp' | ModTypeRef kn -> let kn' = subst_kernel_name subst kn in if kn==kn' then ref else ModTypeRef kn' *) type reference = | Qualid of qualid located | Ident of identifier located let qualid_of_reference = function | Qualid (loc,qid) -> loc, qid | Ident (loc,id) -> loc, qualid_of_ident id let string_of_reference = function | Qualid (loc,qid) -> string_of_qualid qid | Ident (loc,id) -> string_of_id id let pr_reference = function | Qualid (_,qid) -> pr_qualid qid | Ident (_,id) -> pr_id id let loc_of_reference = function | Qualid (loc,qid) -> loc | Ident (loc,id) -> loc (* popping one level of section in global names *) let pop_con con = let (mp,dir,l) = repr_con con in Names.make_con mp (pop_dirpath dir) l let pop_kn kn = let (mp,dir,l) = repr_mind kn in Names.make_mind mp (pop_dirpath dir) l let pop_global_reference = function | ConstRef con -> ConstRef (pop_con con) | IndRef (kn,i) -> IndRef (pop_kn kn,i) | ConstructRef ((kn,i),j) -> ConstructRef ((pop_kn kn,i),j) | VarRef id -> anomaly "VarRef not poppable" (* Deprecated synonyms *) let make_short_qualid = qualid_of_ident let qualid_of_sp = qualid_of_path coq-8.4pl4/library/heads.ml0000644000175000017500000001442112326224777014717 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* phi(x))] where [g] is [fun f => g O] does not launch the evaluation of [phi(0)] and the head of [h] is declared unknown). *) type rigid_head_kind = | RigidParameter of constant (* a Const without body *) | RigidVar of variable (* a Var without body *) | RigidType (* an inductive, a product or a sort *) type head_approximation = | RigidHead of rigid_head_kind | ConstructorHead | FlexibleHead of int * int * int * bool (* [true] if a surrounding case *) | NotImmediatelyComputableHead (** Registration as global tables and rollback. *) module Evalreford = struct type t = evaluable_global_reference let compare x y = let make_name = function | EvalConstRef con -> EvalConstRef(constant_of_kn(canonical_con con)) | k -> k in Pervasives.compare (make_name x) (make_name y) end module Evalrefmap = Map.Make (Evalreford) let head_map = ref Evalrefmap.empty let init () = head_map := Evalrefmap.empty let freeze () = !head_map let unfreeze hm = head_map := hm let _ = Summary.declare_summary "Head_decl" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = init } let variable_head id = Evalrefmap.find (EvalVarRef id) !head_map let constant_head cst = Evalrefmap.find (EvalConstRef cst) !head_map let kind_of_head env t = let rec aux k l t b = match kind_of_term (Reduction.whd_betaiotazeta t) with | Rel n when n > k -> NotImmediatelyComputableHead | Rel n -> FlexibleHead (k,k+1-n,List.length l,b) | Var id -> (try on_subterm k l b (variable_head id) with Not_found -> (* a goal variable *) match pi2 (lookup_named id env) with | Some c -> aux k l c b | None -> NotImmediatelyComputableHead) | Const cst -> (try on_subterm k l b (constant_head cst) with Not_found -> assert false) | Construct _ | CoFix _ -> if b then NotImmediatelyComputableHead else ConstructorHead | Sort _ | Ind _ | Prod _ -> RigidHead RigidType | Cast (c,_,_) -> aux k l c b | Lambda (_,_,c) when l = [] -> assert (not b); aux (k+1) [] c b | Lambda (_,_,c) -> aux k (List.tl l) (subst1 (List.hd l) c) b | LetIn _ -> assert false | Meta _ | Evar _ -> NotImmediatelyComputableHead | App (c,al) -> aux k (Array.to_list al @ l) c b | Case (_,_,c,_) -> aux k [] c true | Fix ((i,j),_) -> let n = i.(j) in try aux k [] (List.nth l n) true with Failure _ -> FlexibleHead (k + n + 1, k + n + 1, 0, true) and on_subterm k l with_case = function | FlexibleHead (n,i,q,with_subcase) -> let m = List.length l in let k',rest,a = if n > m then (* eta-expansion *) let a = if i <= m then (* we pick the head in the existing arguments *) lift (n-m) (List.nth l (i-1)) else (* we pick the head in the added arguments *) mkRel (n-i+1) in k+n-m,[],a else (* enough arguments to [cst] *) k,list_skipn n l,List.nth l (i-1) in let l' = list_tabulate (fun _ -> mkMeta 0) q @ rest in aux k' l' a (with_subcase or with_case) | ConstructorHead when with_case -> NotImmediatelyComputableHead | x -> x in aux 0 [] t false let compute_head = function | EvalConstRef cst -> (match constant_opt_value (Global.env()) cst with | None -> RigidHead (RigidParameter cst) | Some c -> kind_of_head (Global.env()) c) | EvalVarRef id -> (match pi2 (Global.lookup_named id) with | Some c when not (Decls.variable_opacity id) -> kind_of_head (Global.env()) c | _ -> RigidHead (RigidVar id)) let is_rigid env t = match kind_of_head env t with | RigidHead _ | ConstructorHead -> true | _ -> false (** Registration of heads as an object *) let load_head _ (_,(ref,(k:head_approximation))) = head_map := Evalrefmap.add ref k !head_map let cache_head o = load_head 1 o let subst_head_approximation subst = function | RigidHead (RigidParameter cst) as k -> let cst,c = subst_con subst cst in if isConst c && eq_constant (destConst c) cst then (* A change of the prefix of the constant *) k else (* A substitution of the constant by a functor argument *) kind_of_head (Global.env()) c | x -> x let subst_head (subst,(ref,k)) = (subst_evaluable_reference subst ref, subst_head_approximation subst k) let discharge_head (_,(ref,k)) = match ref with | EvalConstRef cst -> Some (EvalConstRef (pop_con cst), k) | EvalVarRef id -> None let rebuild_head (ref,k) = (ref, compute_head ref) type head_obj = evaluable_global_reference * head_approximation let inHead : head_obj -> obj = declare_object {(default_object "HEAD") with cache_function = cache_head; load_function = load_head; subst_function = subst_head; classify_function = (fun x -> Substitute x); discharge_function = discharge_head; rebuild_function = rebuild_head } let declare_head c = let hd = compute_head c in add_anonymous_leaf (inHead (c,hd)) (** Printing *) let pr_head = function | RigidHead (RigidParameter cst) -> str "rigid constant " ++ pr_con cst | RigidHead (RigidType) -> str "rigid type" | RigidHead (RigidVar id) -> str "rigid variable " ++ pr_id id | ConstructorHead -> str "constructor" | FlexibleHead (k,n,p,b) -> int n ++ str "th of " ++ int k ++ str " binders applied to " ++ int p ++ str " arguments" ++ (if b then str " (with case)" else mt()) | NotImmediatelyComputableHead -> str "unknown" coq-8.4pl4/library/nameops.mli0000644000175000017500000000360212326224777015445 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Pp.std_ppcmds val pr_name : name -> Pp.std_ppcmds val make_ident : string -> int option -> identifier val repr_ident : identifier -> string * int option val atompart_of_id : identifier -> string (** remove trailing digits *) val root_of_id : identifier -> identifier (** remove trailing digits, ' and _ *) val add_suffix : identifier -> string -> identifier val add_prefix : string -> identifier -> identifier val has_subscript : identifier -> bool val lift_subscript : identifier -> identifier val forget_subscript : identifier -> identifier val out_name : name -> identifier val name_fold : (identifier -> 'a -> 'a) -> name -> 'a -> 'a val name_iter : (identifier -> unit) -> name -> unit val name_cons : name -> identifier list -> identifier list val name_app : (identifier -> identifier) -> name -> name val name_fold_map : ('a -> identifier -> 'a * identifier) -> 'a -> name -> 'a * name val pr_lab : label -> Pp.std_ppcmds (** some preset paths *) val default_library : dir_path (** This is the root of the standard library of Coq *) val coq_root : module_ident (** This is the default root prefix for developments which doesn't mention a root *) val default_root_prefix : dir_path (** Metavariables *) val pr_meta : Term.metavariable -> Pp.std_ppcmds val string_of_meta : Term.metavariable -> string coq-8.4pl4/kernel/0000755000175000017500000000000012365131026013076 5ustar stephstephcoq-8.4pl4/kernel/make-opcodes0000644000175000017500000000014612326224777015406 0ustar stephsteph$1=="enum" {n=0; next; } {for (i = 1; i <= NF; i++) {printf("let op%s = %d\n", $i, n++);}} coq-8.4pl4/kernel/esubst.ml0000644000175000017500000001311312326224777014751 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* n *) (* i.e under n binders *) let el_id = ELID (* compose a relocation of magnitude n *) let rec el_shft_rec n = function | ELSHFT(el,k) -> el_shft_rec (k+n) el | el -> ELSHFT(el,n) let el_shft n el = if n = 0 then el else el_shft_rec n el (* cross n binders *) let rec el_liftn_rec n = function | ELID -> ELID | ELLFT(k,el) -> el_liftn_rec (n+k) el | el -> ELLFT(n, el) let el_liftn n el = if n = 0 then el else el_liftn_rec n el let el_lift el = el_liftn_rec 1 el (* relocation of de Bruijn n in an explicit lift *) let rec reloc_rel n = function | ELID -> n | ELLFT(k,el) -> if n <= k then n else (reloc_rel (n-k) el) + k | ELSHFT(el,k) -> (reloc_rel (n+k) el) let rec is_lift_id = function | ELID -> true | ELSHFT(e,n) -> n=0 & is_lift_id e | ELLFT (_,e) -> is_lift_id e (*********************) (* Substitutions *) (*********************) (* (bounded) explicit substitutions of type 'a *) type 'a subs = | ESID of int (* ESID(n) = %n END bounded identity *) | CONS of 'a array * 'a subs (* CONS([|t1..tn|],S) = (S.t1...tn) parallel substitution beware of the order *) | SHIFT of int * 'a subs (* SHIFT(n,S) = (^n o S) terms in S are relocated *) (* with n vars *) | LIFT of int * 'a subs (* LIFT(n,S) = (%n S) stands for ((^n o S).n...1) *) (* operations of subs: collapses constructors when possible. * Needn't be recursive if we always use these functions *) let subs_id i = ESID i let subs_cons(x,s) = if Array.length x = 0 then s else CONS(x,s) let subs_liftn n = function | ESID p -> ESID (p+n) (* bounded identity lifted extends by p *) | LIFT (p,lenv) -> LIFT (p+n, lenv) | lenv -> LIFT (n,lenv) let subs_lift a = subs_liftn 1 a let subs_liftn n a = if n = 0 then a else subs_liftn n a let subs_shft = function | (0, s) -> s | (n, SHIFT (k,s1)) -> SHIFT (k+n, s1) | (n, s) -> SHIFT (n,s) let subs_shft (n,a) = if n = 0 then a else subs_shft(n,a) let subs_shift_cons = function (0, s, t) -> CONS(t,s) | (k, SHIFT(n,s1), t) -> CONS(t,SHIFT(k+n, s1)) | (k, s, t) -> CONS(t,SHIFT(k, s));; (* Tests whether a substitution is equal to the identity *) let rec is_subs_id = function ESID _ -> true | LIFT(_,s) -> is_subs_id s | SHIFT(0,s) -> is_subs_id s | CONS(x,s) -> Array.length x = 0 && is_subs_id s | _ -> false (* Expands de Bruijn k in the explicit substitution subs * lams accumulates de shifts to perform when retrieving the i-th value * the rules used are the following: * * [id]k --> k * [S.t]1 --> t * [S.t]k --> [S](k-1) if k > 1 * [^n o S] k --> [^n]([S]k) * [(%n S)] k --> k if k <= n * [(%n S)] k --> [^n]([S](k-n)) * * the result is (Inr (k+lams,p)) when the variable is just relocated * where p is None if the variable points inside subs and Some(k) if the * variable points k bindings beyond subs. *) let rec exp_rel lams k subs = match subs with | CONS (def,_) when k <= Array.length def -> Inl(lams,def.(Array.length def - k)) | CONS (v,l) -> exp_rel lams (k - Array.length v) l | LIFT (n,_) when k<=n -> Inr(lams+k,None) | LIFT (n,l) -> exp_rel (n+lams) (k-n) l | SHIFT (n,s) -> exp_rel (n+lams) k s | ESID n when k<=n -> Inr(lams+k,None) | ESID n -> Inr(lams+k,Some (k-n)) let expand_rel k subs = exp_rel 0 k subs let rec comp mk_cl s1 s2 = match (s1, s2) with | _, ESID _ -> s1 | ESID _, _ -> s2 | SHIFT(k,s), _ -> subs_shft(k, comp mk_cl s s2) | _, CONS(x,s') -> CONS(Array.map (fun t -> mk_cl(s1,t)) x, comp mk_cl s1 s') | CONS(x,s), SHIFT(k,s') -> let lg = Array.length x in if k == lg then comp mk_cl s s' else if k > lg then comp mk_cl s (SHIFT(k-lg, s')) else comp mk_cl (CONS(Array.sub x 0 (lg-k), s)) s' | CONS(x,s), LIFT(k,s') -> let lg = Array.length x in if k == lg then CONS(x, comp mk_cl s s') else if k > lg then CONS(x, comp mk_cl s (LIFT(k-lg, s'))) else CONS(Array.sub x (lg-k) k, comp mk_cl (CONS(Array.sub x 0 (lg-k),s)) s') | LIFT(k,s), SHIFT(k',s') -> if k if k Environ.env val empty_environment : safe_environment val is_empty : safe_environment -> bool (** Adding and removing local declarations (Local or Variables) *) val push_named_assum : identifier * types -> safe_environment -> Univ.constraints * safe_environment val push_named_def : identifier * constr * types option -> safe_environment -> Univ.constraints * safe_environment (** Adding global axioms or definitions *) type global_declaration = | ConstantEntry of constant_entry | GlobalRecipe of Cooking.recipe val add_constant : dir_path -> label -> global_declaration -> safe_environment -> constant * safe_environment (** Adding an inductive type *) val add_mind : dir_path -> label -> mutual_inductive_entry -> safe_environment -> mutual_inductive * safe_environment (** Adding a module *) val add_module : label -> module_entry -> inline -> safe_environment -> module_path * delta_resolver * safe_environment (** Adding a module type *) val add_modtype : label -> module_struct_entry -> inline -> safe_environment -> module_path * safe_environment (** Adding universe constraints *) val add_constraints : Univ.constraints -> safe_environment -> safe_environment (** Settin the strongly constructive or classical logical engagement *) val set_engagement : engagement -> safe_environment -> safe_environment (** {6 Interactive module functions } *) val start_module : label -> safe_environment -> module_path * safe_environment val end_module : label -> (module_struct_entry * inline) option -> safe_environment -> module_path * delta_resolver * safe_environment val add_module_parameter : mod_bound_id -> module_struct_entry -> inline -> safe_environment -> delta_resolver * safe_environment val start_modtype : label -> safe_environment -> module_path * safe_environment val end_modtype : label -> safe_environment -> module_path * safe_environment val add_include : module_struct_entry -> bool -> inline -> safe_environment -> delta_resolver * safe_environment val pack_module : safe_environment -> module_body val current_modpath : safe_environment -> module_path val delta_of_senv : safe_environment -> delta_resolver*delta_resolver (** Loading and saving compilation units *) (** exporting and importing modules *) type compiled_library val start_library : dir_path -> safe_environment -> module_path * safe_environment val export : safe_environment -> dir_path -> module_path * compiled_library val import : compiled_library -> Digest.t -> safe_environment -> module_path * safe_environment (** Remove the body of opaque constants *) module LightenLibrary : sig type table type lightened_compiled_library val save : compiled_library -> lightened_compiled_library * table val load : load_proof:Flags.load_proofs -> table Lazy.t -> lightened_compiled_library -> compiled_library end (** {6 Typing judgments } *) type judgment val j_val : judgment -> constr val j_type : judgment -> constr (** Safe typing of a term returning a typing judgment and universe constraints to be added to the environment for the judgment to hold. It is guaranteed that the constraints are satisfiable *) val safe_infer : safe_environment -> constr -> judgment * Univ.constraints val typing : safe_environment -> constr -> judgment (** {7 Query } *) val exists_objlabel : label -> safe_environment -> bool (*spiwack: safe retroknowledge functionalities *) open Retroknowledge val retroknowledge : (retroknowledge-> 'a) -> safe_environment -> 'a val register : safe_environment -> field -> Retroknowledge.entry -> constr -> safe_environment coq-8.4pl4/kernel/modops.ml0000644000175000017500000005027212326224777014754 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (arg_id,arg_t,body_t) | _ -> error_not_a_functor mtb let is_functor = function | SEBfunctor (arg_id,arg_t,body_t) -> true | _ -> false let module_body_of_type mp mtb = { mod_mp = mp; mod_type = mtb.typ_expr; mod_type_alg = mtb.typ_expr_alg; mod_expr = None; mod_constraints = mtb.typ_constraints; mod_delta = mtb.typ_delta; mod_retroknowledge = []} let check_modpath_equiv env mp1 mp2 = if mp1=mp2 then () else let mb1=lookup_module mp1 env in let mb2=lookup_module mp2 env in if (mp_of_delta mb1.mod_delta mp1)=(mp_of_delta mb2.mod_delta mp2) then () else error_not_equal_modpaths mp1 mp2 let rec subst_with_body sub = function | With_module_body(id,mp) -> With_module_body(id,subst_mp sub mp) | With_definition_body(id,cb) -> With_definition_body( id,subst_const_body sub cb) and subst_modtype sub do_delta mtb= let mp = subst_mp sub mtb.typ_mp in let sub = add_mp mtb.typ_mp mp empty_delta_resolver sub in let typ_expr' = subst_struct_expr sub do_delta mtb.typ_expr in let typ_alg' = Option.smartmap (subst_struct_expr sub (fun x y-> x)) mtb.typ_expr_alg in let mtb_delta = do_delta mtb.typ_delta sub in if typ_expr'==mtb.typ_expr && typ_alg'==mtb.typ_expr_alg && mp==mtb.typ_mp then mtb else {mtb with typ_mp = mp; typ_expr = typ_expr'; typ_expr_alg = typ_alg'; typ_delta = mtb_delta} and subst_structure sub do_delta sign = let subst_body = function SFBconst cb -> SFBconst (subst_const_body sub cb) | SFBmind mib -> SFBmind (subst_mind sub mib) | SFBmodule mb -> SFBmodule (subst_module sub do_delta mb) | SFBmodtype mtb -> SFBmodtype (subst_modtype sub do_delta mtb) in List.map (fun (l,b) -> (l,subst_body b)) sign and subst_module sub do_delta mb = let mp = subst_mp sub mb.mod_mp in let sub = if is_functor mb.mod_type && not(mp=mb.mod_mp) then add_mp mb.mod_mp mp empty_delta_resolver sub else sub in let id_delta = (fun x y-> x) in let mtb',me' = let mtb = subst_struct_expr sub do_delta mb.mod_type in match mb.mod_expr with None -> mtb,None | Some me -> if me==mb.mod_type then mtb,Some mtb else mtb,Option.smartmap (subst_struct_expr sub id_delta) mb.mod_expr in let typ_alg' = Option.smartmap (subst_struct_expr sub id_delta) mb.mod_type_alg in let mb_delta = do_delta mb.mod_delta sub in if mtb'==mb.mod_type && mb.mod_expr == me' && mb_delta == mb.mod_delta && mp == mb.mod_mp then mb else { mb with mod_mp = mp; mod_expr = me'; mod_type_alg = typ_alg'; mod_type=mtb'; mod_delta = mb_delta} and subst_struct_expr sub do_delta = function | SEBident mp -> SEBident (subst_mp sub mp) | SEBfunctor (mbid, mtb, meb') -> SEBfunctor(mbid,subst_modtype sub do_delta mtb ,subst_struct_expr sub do_delta meb') | SEBstruct (str)-> SEBstruct( subst_structure sub do_delta str) | SEBapply (meb1,meb2,cst)-> SEBapply(subst_struct_expr sub do_delta meb1, subst_struct_expr sub do_delta meb2, cst) | SEBwith (meb,wdb)-> SEBwith(subst_struct_expr sub do_delta meb, subst_with_body sub wdb) let subst_signature subst = subst_structure subst (fun resolver subst-> subst_codom_delta_resolver subst resolver) let subst_struct_expr subst = subst_struct_expr subst (fun resolver subst-> subst_codom_delta_resolver subst resolver) (* spiwack: here comes the function which takes care of importing the retroknowledge declared in the library *) (* lclrk : retroknowledge_action list, rkaction : retroknowledge action *) let add_retroknowledge mp = let perform rkaction env = match rkaction with | Retroknowledge.RKRegister (f, e) -> Environ.register env f (match e with | Const kn -> kind_of_term (mkConst kn) | Ind ind -> kind_of_term (mkInd ind) | _ -> anomaly "Modops.add_retroknowledge: had to import an unsupported kind of term") in fun lclrk env -> (* The order of the declaration matters, for instance (and it's at the time this comment is being written, the only relevent instance) the int31 type registration absolutely needs int31 bits to be registered. Since the local_retroknowledge is stored in reverse order (each new registration is added at the top of the list) we need a fold_right for things to go right (the pun is not intented). So we lose tail recursivity, but the world will have exploded before any module imports 10 000 retroknowledge registration.*) List.fold_right perform lclrk env let rec add_signature mp sign resolver env = let add_one env (l,elem) = let kn = make_kn mp empty_dirpath l in match elem with | SFBconst cb -> Environ.add_constant (constant_of_delta_kn resolver kn) cb env | SFBmind mib -> Environ.add_mind (mind_of_delta_kn resolver kn) mib env | SFBmodule mb -> add_module mb env (* adds components as well *) | SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env in List.fold_left add_one env sign and add_module mb env = let mp = mb.mod_mp in let env = Environ.shallow_add_module mp mb env in match mb.mod_type with | SEBstruct (sign) -> add_retroknowledge mp mb.mod_retroknowledge (add_signature mp sign mb.mod_delta env) | SEBfunctor _ -> env | _ -> anomaly "Modops:the evaluation of the structure failed " let strengthen_const mp_from l cb resolver = match cb.const_body with | Def _ -> cb | _ -> let kn = make_kn mp_from empty_dirpath l in let con = constant_of_delta_kn resolver kn in { cb with const_body = Def (Declarations.from_val (mkConst con)); const_body_code = Cemitcodes.from_val (Cbytegen.compile_alias con) } let rec strengthen_mod mp_from mp_to mb = if mp_in_delta mb.mod_mp mb.mod_delta then mb else match mb.mod_type with | SEBstruct (sign) -> let resolve_out,sign_out = strengthen_sig mp_from sign mp_to mb.mod_delta in { mb with mod_expr = Some (SEBident mp_to); mod_type = SEBstruct(sign_out); mod_type_alg = mb.mod_type_alg; mod_constraints = mb.mod_constraints; mod_delta = add_mp_delta_resolver mp_from mp_to (add_delta_resolver mb.mod_delta resolve_out); mod_retroknowledge = mb.mod_retroknowledge} | SEBfunctor _ -> mb | _ -> anomaly "Modops:the evaluation of the structure failed " and strengthen_sig mp_from sign mp_to resolver = match sign with | [] -> empty_delta_resolver,[] | (l,SFBconst cb) :: rest -> let item' = l,SFBconst (strengthen_const mp_from l cb resolver) in let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in resolve_out,item'::rest' | (_,SFBmind _ as item):: rest -> let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in resolve_out,item::rest' | (l,SFBmodule mb) :: rest -> let mp_from' = MPdot (mp_from,l) in let mp_to' = MPdot(mp_to,l) in let mb_out = strengthen_mod mp_from' mp_to' mb in let item' = l,SFBmodule (mb_out) in let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in add_delta_resolver resolve_out mb.mod_delta, item':: rest' | (l,SFBmodtype mty as item) :: rest -> let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in resolve_out,item::rest' let strengthen mtb mp = if mp_in_delta mtb.typ_mp mtb.typ_delta then (* in this case mtb has already been strengthened*) mtb else match mtb.typ_expr with | SEBstruct (sign) -> let resolve_out,sign_out = strengthen_sig mtb.typ_mp sign mp mtb.typ_delta in {mtb with typ_expr = SEBstruct(sign_out); typ_delta = add_delta_resolver mtb.typ_delta (add_mp_delta_resolver mtb.typ_mp mp resolve_out)} | SEBfunctor _ -> mtb | _ -> anomaly "Modops:the evaluation of the structure failed " let module_type_of_module mp mb = match mp with Some mp -> strengthen { typ_mp = mp; typ_expr = mb.mod_type; typ_expr_alg = None; typ_constraints = mb.mod_constraints; typ_delta = mb.mod_delta} mp | None -> {typ_mp = mb.mod_mp; typ_expr = mb.mod_type; typ_expr_alg = None; typ_constraints = mb.mod_constraints; typ_delta = mb.mod_delta} let inline_delta_resolver env inl mp mbid mtb delta = let constants = inline_of_delta inl mtb.typ_delta in let rec make_inline delta = function | [] -> delta | (lev,kn)::r -> let kn = replace_mp_in_kn (MPbound mbid) mp kn in let con = constant_of_delta_kn delta kn in try let constant = lookup_constant con env in let l = make_inline delta r in match constant.const_body with | Undef _ | OpaqueDef _ -> l | Def body -> let constr = Declarations.force body in add_inline_delta_resolver kn (lev, Some constr) l with Not_found -> error_no_such_label_sub (con_label con) (string_of_mp (con_modpath con)) in make_inline delta constants let rec strengthen_and_subst_mod mb subst mp_from mp_to resolver = match mb.mod_type with SEBstruct(str) -> let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in if mb_is_an_alias then subst_module subst (fun resolver subst-> subst_dom_delta_resolver subst resolver) mb else let resolver,new_sig = strengthen_and_subst_struct str subst mp_from mp_from mp_to false false mb.mod_delta in {mb with mod_mp = mp_to; mod_expr = Some (SEBident mp_from); mod_type = SEBstruct(new_sig); mod_delta = add_mp_delta_resolver mp_to mp_from resolver} | SEBfunctor(arg_id,arg_b,body) -> let subst = add_mp mb.mod_mp mp_to empty_delta_resolver subst in subst_module subst (fun resolver subst-> subst_dom_codom_delta_resolver subst resolver) mb | _ -> anomaly "Modops:the evaluation of the structure failed " and strengthen_and_subst_struct str subst mp_alias mp_from mp_to alias incl resolver = match str with | [] -> empty_delta_resolver,[] | (l,SFBconst cb) :: rest -> let item' = if alias then (* case alias no strengthening needed*) l,SFBconst (subst_const_body subst cb) else l,SFBconst (strengthen_const mp_from l (subst_const_body subst cb) resolver) in let resolve_out,rest' = strengthen_and_subst_struct rest subst mp_alias mp_from mp_to alias incl resolver in if incl then (* If we are performing an inclusion we need to add the fact that the constant mp_to.l is \Delta-equivalent to resolver(mp_from.l) *) let kn_from = make_kn mp_from empty_dirpath l in let kn_to = make_kn mp_to empty_dirpath l in let old_name = kn_of_delta resolver kn_from in (add_kn_delta_resolver kn_to old_name resolve_out), item'::rest' else (*In this case the fact that the constant mp_to.l is \Delta-equivalent to resolver(mp_from.l) is already known because resolve_out contains mp_to maps to resolver(mp_from)*) resolve_out,item'::rest' | (l,SFBmind mib) :: rest -> (*Same as constant*) let item' = l,SFBmind (subst_mind subst mib) in let resolve_out,rest' = strengthen_and_subst_struct rest subst mp_alias mp_from mp_to alias incl resolver in if incl then let kn_from = make_kn mp_from empty_dirpath l in let kn_to = make_kn mp_to empty_dirpath l in let old_name = kn_of_delta resolver kn_from in (add_kn_delta_resolver kn_to old_name resolve_out), item'::rest' else resolve_out,item'::rest' | (l,SFBmodule mb) :: rest -> let mp_from' = MPdot (mp_from,l) in let mp_to' = MPdot(mp_to,l) in let mb_out = if alias then subst_module subst (fun resolver subst -> subst_dom_delta_resolver subst resolver) mb else strengthen_and_subst_mod mb subst mp_from' mp_to' resolver in let item' = l,SFBmodule (mb_out) in let resolve_out,rest' = strengthen_and_subst_struct rest subst mp_alias mp_from mp_to alias incl resolver in (* if mb is a functor we should not derive new equivalences on names, hence we add the fact that the functor can only be equivalent to itself. If we adopt an applicative semantic for functor this should be changed.*) if is_functor mb_out.mod_type then (add_mp_delta_resolver mp_to' mp_to' resolve_out),item':: rest' else add_delta_resolver resolve_out mb_out.mod_delta, item':: rest' | (l,SFBmodtype mty) :: rest -> let mp_from' = MPdot (mp_from,l) in let mp_to' = MPdot(mp_to,l) in let subst' = add_mp mp_from' mp_to' empty_delta_resolver subst in let mty = subst_modtype subst' (fun resolver subst -> subst_dom_codom_delta_resolver subst' resolver) mty in let resolve_out,rest' = strengthen_and_subst_struct rest subst mp_alias mp_from mp_to alias incl resolver in (add_mp_delta_resolver mp_to' mp_to' resolve_out),(l,SFBmodtype mty)::rest' (* Let P be a module path when we write "Module M:=P." or "Module M. Include P. End M." we need to perform two operations to compute the body of M. The first one is applying the substitution {P <- M} on the type of P and the second one is strenghtening. *) let strengthen_and_subst_mb mb mp include_b = match mb.mod_type with SEBstruct str -> let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in (*if mb.mod_mp is an alias then the strengthening is useless (i.e. it is already done)*) let mp_alias = mp_of_delta mb.mod_delta mb.mod_mp in let subst_resolver = map_mp mb.mod_mp mp empty_delta_resolver in let new_resolver = add_mp_delta_resolver mp mp_alias (subst_dom_delta_resolver subst_resolver mb.mod_delta) in let subst = map_mp mb.mod_mp mp new_resolver in let resolver_out,new_sig = strengthen_and_subst_struct str subst mp_alias mb.mod_mp mp mb_is_an_alias include_b mb.mod_delta in {mb with mod_mp = mp; mod_type = SEBstruct(new_sig); mod_expr = Some (SEBident mb.mod_mp); mod_delta = if include_b then resolver_out else add_delta_resolver new_resolver resolver_out} | SEBfunctor(arg_id,argb,body) -> let subst = map_mp mb.mod_mp mp empty_delta_resolver in subst_module subst (fun resolver subst -> subst_dom_codom_delta_resolver subst resolver) mb | _ -> anomaly "Modops:the evaluation of the structure failed " let subst_modtype_and_resolver mtb mp = let subst = (map_mp mtb.typ_mp mp empty_delta_resolver) in let new_delta = subst_dom_codom_delta_resolver subst mtb.typ_delta in let full_subst = (map_mp mtb.typ_mp mp new_delta) in subst_modtype full_subst (fun resolver subst -> subst_dom_codom_delta_resolver subst resolver) mtb let rec is_bounded_expr l = function | SEBident mp -> List.mem mp l | SEBapply (fexpr,mexpr,_) -> is_bounded_expr l mexpr || is_bounded_expr l fexpr | _ -> false let rec clean_struct l = function | (lab,SFBmodule mb) as field -> let clean_typ = clean_expr l mb.mod_type in let clean_impl = begin try if (is_bounded_expr l (Option.get mb.mod_expr)) then Some clean_typ else Some (clean_expr l (Option.get mb.mod_expr)) with Option.IsNone -> None end in if clean_typ==mb.mod_type && clean_impl==mb.mod_expr then field else (lab,SFBmodule {mb with mod_type=clean_typ; mod_expr=clean_impl}) | field -> field and clean_expr l = function | SEBfunctor (mbid,sigt,str) as s-> let str_clean = clean_expr l str in let sig_clean = clean_expr l sigt.typ_expr in if str_clean == str && sig_clean = sigt.typ_expr then s else SEBfunctor (mbid,{sigt with typ_expr=sig_clean},str_clean) | SEBstruct str as s-> let str_clean = Util.list_smartmap (clean_struct l) str in if str_clean == str then s else SEBstruct(str_clean) | str -> str let rec collect_mbid l = function | SEBfunctor (mbid,sigt,str) as s-> let str_clean = collect_mbid ((MPbound mbid)::l) str in if str_clean == str then s else SEBfunctor (mbid,sigt,str_clean) | SEBstruct str as s-> let str_clean = Util.list_smartmap (clean_struct l) str in if str_clean == str then s else SEBstruct(str_clean) | _ -> anomaly "Modops:the evaluation of the structure failed " let clean_bounded_mod_expr = function | SEBfunctor _ as str -> let str_clean = collect_mbid [] str in if str_clean == str then str else str_clean | str -> str coq-8.4pl4/kernel/modops.mli0000644000175000017500000000772412326224777015131 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* module_type_body -> module_body val module_type_of_module : module_path option -> module_body -> module_type_body val destr_functor : env -> struct_expr_body -> mod_bound_id * module_type_body * struct_expr_body val subst_struct_expr : substitution -> struct_expr_body -> struct_expr_body val subst_signature : substitution -> structure_body -> structure_body val add_signature : module_path -> structure_body -> delta_resolver -> env -> env (** adds a module and its components, but not the constraints *) val add_module : module_body -> env -> env val check_modpath_equiv : env -> module_path -> module_path -> unit val strengthen : module_type_body -> module_path -> module_type_body val inline_delta_resolver : env -> inline -> module_path -> mod_bound_id -> module_type_body -> delta_resolver -> delta_resolver val strengthen_and_subst_mb : module_body -> module_path -> bool -> module_body val subst_modtype_and_resolver : module_type_body -> module_path -> module_type_body val clean_bounded_mod_expr : struct_expr_body -> struct_expr_body (** Errors *) type signature_mismatch_error = | InductiveFieldExpected of mutual_inductive_body | DefinitionFieldExpected | ModuleFieldExpected | ModuleTypeFieldExpected | NotConvertibleInductiveField of identifier | NotConvertibleConstructorField of identifier | NotConvertibleBodyField | NotConvertibleTypeField of env * types * types | NotSameConstructorNamesField | NotSameInductiveNameInBlockField | FiniteInductiveFieldExpected of bool | InductiveNumbersFieldExpected of int | InductiveParamsNumberField of int | RecordFieldExpected of bool | RecordProjectionsExpected of name list | NotEqualInductiveAliases | NoTypeConstraintExpected type module_typing_error = | SignatureMismatch of label * structure_field_body * signature_mismatch_error | LabelAlreadyDeclared of label | ApplicationToNotPath of module_struct_entry | NotAFunctor of struct_expr_body | IncompatibleModuleTypes of module_type_body * module_type_body | NotEqualModulePaths of module_path * module_path | NoSuchLabel of label | IncompatibleLabels of label * label | SignatureExpected of struct_expr_body | NoModuleToEnd | NoModuleTypeToEnd | NotAModule of string | NotAModuleType of string | NotAConstant of label | IncorrectWithConstraint of label | GenerativeModuleExpected of label | NonEmptyLocalContect of label option | LabelMissing of label * string exception ModuleTypingError of module_typing_error val error_existing_label : label -> 'a val error_application_to_not_path : module_struct_entry -> 'a val error_incompatible_modtypes : module_type_body -> module_type_body -> 'a val error_signature_mismatch : label -> structure_field_body -> signature_mismatch_error -> 'a val error_incompatible_labels : label -> label -> 'a val error_no_such_label : label -> 'a val error_signature_expected : struct_expr_body -> 'a val error_no_module_to_end : unit -> 'a val error_no_modtype_to_end : unit -> 'a val error_not_a_module : string -> 'a val error_not_a_constant : label -> 'a val error_incorrect_with_constraint : label -> 'a val error_generative_module_expected : label -> 'a val error_non_empty_local_context : label option -> 'a val error_no_such_label_sub : label->string->'a coq-8.4pl4/kernel/inductive.mli0000644000175000017500000001054312326224777015613 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* types -> inductive * constr list val find_inductive : env -> types -> inductive * constr list val find_coinductive : env -> types -> inductive * constr list type mind_specif = mutual_inductive_body * one_inductive_body (** {6 ... } *) (** Fetching information in the environment about an inductive type. Raises [Not_found] if the inductive type is not found. *) val lookup_mind_specif : env -> inductive -> mind_specif (** {6 Functions to build standard types related to inductive } *) val ind_subst : mutual_inductive -> mutual_inductive_body -> constr list val type_of_inductive : env -> mind_specif -> types val elim_sorts : mind_specif -> sorts_family list (** Return type as quoted by the user *) val type_of_constructor : constructor -> mind_specif -> types (** Return constructor types in normal form *) val arities_of_constructors : inductive -> mind_specif -> types array (** Return constructor types in user form *) val type_of_constructors : inductive -> mind_specif -> types array (** Transforms inductive specification into types (in nf) *) val arities_of_specif : mutual_inductive -> mind_specif -> types array val inductive_params : mind_specif -> int (** [type_case_branches env (I,args) (p:A) c] computes useful types about the following Cases expression:

    Cases (c :: (I args)) of b1..bn end It computes the type of every branch (pattern variables are introduced by products), the type for the whole expression, and the universe constraints generated. *) val type_case_branches : env -> inductive * constr list -> unsafe_judgment -> constr -> types array * types * constraints val build_branches_type : inductive -> mutual_inductive_body * one_inductive_body -> constr list -> constr -> types array (** Return the arity of an inductive type *) val mind_arity : one_inductive_body -> rel_context * sorts_family val inductive_sort_family : one_inductive_body -> sorts_family (** Check a [case_info] actually correspond to a Case expression on the given inductive type. *) val check_case_info : env -> inductive -> case_info -> unit (** {6 Guard conditions for fix and cofix-points. } *) val check_fix : env -> fixpoint -> unit val check_cofix : env -> cofixpoint -> unit (** {6 Support for sort-polymorphic inductive types } *) (** The "polyprop" optional argument below allows to control the "Prop-polymorphism". By default, it is allowed. But when "polyprop=false", the following exception is raised when a polymorphic singleton inductive type becomes Prop due to parameter instantiation. This is used by the Ocaml extraction, which cannot handle (yet?) Prop-polymorphism. *) exception SingletonInductiveBecomesProp of identifier val type_of_inductive_knowing_parameters : ?polyprop:bool -> env -> one_inductive_body -> types array -> types val max_inductive_sort : sorts array -> universe val instantiate_universes : env -> rel_context -> polymorphic_arity -> types array -> rel_context * sorts (** {6 Debug} *) type size = Large | Strict type subterm_spec = Subterm of (size * wf_paths) | Dead_code | Not_subterm type guard_env = { env : env; (** dB of last fixpoint *) rel_min : int; (** dB of variables denoting subterms *) genv : subterm_spec Lazy.t list; } type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t val subterm_specif : guard_env -> stack_element list -> constr -> subterm_spec coq-8.4pl4/kernel/retroknowledge.mli0000644000175000017500000001341112326224777016651 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* entry -> Cbytecodes.comp_env -> constr array -> int -> Cbytecodes.bytecodes-> Cbytecodes.bytecodes (*Given an identifier id (usually Construct _) and its argument array, returns a function that tries an ad-hoc optimisated compilation (in the case of the 31-bit integers it means compiling them directly into an integer) raises Not_found if id should be compiled as usual, and expectingly CBytecodes.NotClosed if the term is not a closed constructor pattern (a constant for the compiler) *) val get_vm_constant_static_info : retroknowledge -> entry -> constr array -> Cbytecodes.structured_constant (*Given an identifier id (usually Construct _ ) its argument array and a continuation, returns the compiled version of id+args+cont when id has a specific treatment (in the case of 31-bit integers, that would be the dynamic compilation into integers) or raises Not_found if id should be compiled as usual *) val get_vm_constant_dynamic_info : retroknowledge -> entry -> Cbytecodes.comp_env -> Cbytecodes.block array -> int -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes (** Given a type identifier, this function is used before compiling a match over this type. In the case of 31-bit integers for instance, it is used to add the instruction sequence which would perform a dynamic decompilation in case the argument of the match is not in coq representation *) val get_vm_before_match_info : retroknowledge -> entry -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes (** Given a type identifier, this function is used by pretyping/vnorm.ml to recover the elements of that type from their compiled form if it's non standard (it is used (and can be used) only when the compiled form is not a block *) val get_vm_decompile_constant_info : retroknowledge -> entry -> int -> Term.constr (** the following functions are solely used in Pre_env and Environ to implement the functions register and unregister (and mem) of Environ *) val add_field : retroknowledge -> field -> entry -> retroknowledge val mem : retroknowledge -> field -> bool val remove : retroknowledge -> field -> retroknowledge val find : retroknowledge -> field -> entry (** the following function manipulate the reactive information of values they are only used by the functions of Pre_env, and Environ to implement the functions register and unregister of Environ *) val add_vm_compiling_info : retroknowledge-> entry -> (bool -> Cbytecodes.comp_env -> constr array -> int -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes) -> retroknowledge val add_vm_constant_static_info : retroknowledge-> entry -> (bool->constr array-> Cbytecodes.structured_constant) -> retroknowledge val add_vm_constant_dynamic_info : retroknowledge-> entry -> (bool -> Cbytecodes.comp_env -> Cbytecodes.block array -> int -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes) -> retroknowledge val add_vm_before_match_info : retroknowledge -> entry -> (bool->Cbytecodes.bytecodes->Cbytecodes.bytecodes) -> retroknowledge val add_vm_decompile_constant_info : retroknowledge -> entry -> (int -> constr) -> retroknowledge val clear_info : retroknowledge-> entry -> retroknowledge coq-8.4pl4/kernel/kernel.mllib0000644000175000017500000000042712326224777015417 0ustar stephstephNames Univ Esubst Term Mod_subst Sign Cbytecodes Copcodes Cemitcodes Declarations Retroknowledge Pre_env Cbytegen Environ Conv_oracle Closure Reduction Type_errors Entries Modops Inductive Typeops Indtypes Cooking Term_typing Subtyping Mod_typing Safe_typing Vm Csymtable Vconv coq-8.4pl4/kernel/cbytecodes.ml0000644000175000017500000002267012326224777015600 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* fprintf ppf "L%i:" lbl | Kacc n -> fprintf ppf "\tacc %i" n | Kenvacc n -> fprintf ppf "\tenvacc %i" n | Koffsetclosure n -> fprintf ppf "\toffsetclosure %i" n | Kpush -> fprintf ppf "\tpush" | Kpop n -> fprintf ppf "\tpop %i" n | Kpush_retaddr lbl -> fprintf ppf "\tpush_retaddr L%i" lbl | Kapply n -> fprintf ppf "\tapply %i" n | Kappterm(n, m) -> fprintf ppf "\tappterm %i, %i" n m | Kreturn n -> fprintf ppf "\treturn %i" n | Kjump -> fprintf ppf "\tjump" | Krestart -> fprintf ppf "\trestart" | Kgrab n -> fprintf ppf "\tgrab %i" n | Kgrabrec n -> fprintf ppf "\tgrabrec %i" n | Kclosure(lbl, n) -> fprintf ppf "\tclosure L%i, %i" lbl n | Kclosurerec(fv,init,lblt,lblb) -> fprintf ppf "\tclosurerec"; fprintf ppf "%i , %i, " fv init; print_string "types = "; Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblt; print_string " bodies = "; Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb; | Kclosurecofix (fv,init,lblt,lblb) -> fprintf ppf "\tclosurecofix"; fprintf ppf " %i , %i, " fv init; print_string "types = "; Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblt; print_string " bodies = "; Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb; | Kgetglobal id -> fprintf ppf "\tgetglobal %s" (Names.string_of_con id) | Kconst cst -> fprintf ppf "\tconst" | Kmakeblock(n, m) -> fprintf ppf "\tmakeblock %i, %i" n m | Kmakeprod -> fprintf ppf "\tmakeprod" | Kmakeswitchblock(lblt,lbls,_,sz) -> fprintf ppf "\tmakeswitchblock %i, %i, %i" lblt lbls sz | Kswitch(lblc,lblb) -> fprintf ppf "\tswitch"; Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblc; Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb; | Kpushfields n -> fprintf ppf "\tpushfields %i" n | Ksetfield n -> fprintf ppf "\tsetfield %i" n | Kfield n -> fprintf ppf "\tgetfield %i" n | Kstop -> fprintf ppf "\tstop" | Ksequence (c1,c2) -> fprintf ppf "%a@ %a" instruction_list c1 instruction_list c2 (* spiwack *) | Kbranch lbl -> fprintf ppf "\tbranch %i" lbl | Kaddint31 -> fprintf ppf "\taddint31" | Kaddcint31 -> fprintf ppf "\taddcint31" | Kaddcarrycint31 -> fprintf ppf "\taddcarrycint31" | Ksubint31 -> fprintf ppf "\tsubint31" | Ksubcint31 -> fprintf ppf "\tsubcint31" | Ksubcarrycint31 -> fprintf ppf "\tsubcarrycint31" | Kmulint31 -> fprintf ppf "\tmulint31" | Kmulcint31 -> fprintf ppf "\tmulcint31" | Kdiv21int31 -> fprintf ppf "\tdiv21int31" | Kdivint31 -> fprintf ppf "\tdivint31" | Kcompareint31 -> fprintf ppf "\tcompareint31" | Khead0int31 -> fprintf ppf "\thead0int31" | Ktail0int31 -> fprintf ppf "\ttail0int31" | Kaddmuldivint31 -> fprintf ppf "\taddmuldivint31" | Kisconst lbl -> fprintf ppf "\tisconst %i" lbl | Kareconst(n,lbl) -> fprintf ppf "\tareconst %i %i" n lbl | Kcompint31 -> fprintf ppf "\tcompint31" | Kdecompint31 -> fprintf ppf "\tdecompint" (* /spiwack *) and instruction_list ppf = function [] -> () | Klabel lbl :: il -> fprintf ppf "L%i:%a" lbl instruction_list il | instr :: il -> fprintf ppf "%a@ %a" instruction instr instruction_list il (*spiwack: moved this type in this file because I needed it for retroknowledge which can't depend from cbytegen *) type block = | Bconstr of constr | Bstrconst of structured_constant | Bmakeblock of int * block array | Bconstruct_app of int * int * int * block array (* tag , nparams, arity *) | Bspecial of (comp_env -> block array -> int -> bytecodes -> bytecodes) * block array (* spiwack: compilation given by a function *) (* compilation function (see get_vm_constant_dynamic_info in retroknowledge.mli for more info) , argument array *) let draw_instr c = fprintf std_formatter "@[%a@]" instruction_list c coq-8.4pl4/kernel/closure.mli0000644000175000017500000001441112326224777015273 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a (** {6 ... } *) (** Delta implies all consts (both global (= by [kernel_name]) and local (= by [Rel] or [Var])), all evars, and letin's. Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of a LetIn expression is Letin reduction *) val all_opaque : transparent_state val all_transparent : transparent_state val is_transparent_variable : transparent_state -> variable -> bool val is_transparent_constant : transparent_state -> constant -> bool (** Sets of reduction kinds. *) module type RedFlagsSig = sig type reds type red_kind (** The different kinds of reduction *) val fBETA : red_kind val fDELTA : red_kind val fIOTA : red_kind val fZETA : red_kind val fCONST : constant -> red_kind val fVAR : identifier -> red_kind (** No reduction at all *) val no_red : reds (** Adds a reduction kind to a set *) val red_add : reds -> red_kind -> reds (** Removes a reduction kind to a set *) val red_sub : reds -> red_kind -> reds (** Adds a reduction kind to a set *) val red_add_transparent : reds -> transparent_state -> reds (** Build a reduction set from scratch = iter [red_add] on [no_red] *) val mkflags : red_kind list -> reds (** Tests if a reduction kind is set *) val red_set : reds -> red_kind -> bool end module RedFlags : RedFlagsSig open RedFlags val beta : reds val betaiota : reds val betadeltaiota : reds val betaiotazeta : reds val betadeltaiotanolet : reds val unfold_side_red : reds val unfold_red : evaluable_global_reference -> reds (***********************************************************************) type table_key = id_key type 'a infos val ref_value_cache: 'a infos -> table_key -> 'a option val info_flags: 'a infos -> reds val create: ('a infos -> constr -> 'a) -> reds -> env -> (existential -> constr option) -> 'a infos val evar_value : 'a infos -> existential -> constr option (*********************************************************************** s Lazy reduction. *) (** [fconstr] is the type of frozen constr *) type fconstr (** [fconstr] can be accessed by using the function [fterm_of] and by matching on type [fterm] *) type fterm = | FRel of int | FAtom of constr (** Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key | FInd of inductive | FConstruct of constructor | FApp of fconstr * fconstr array | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCases of case_info * fconstr * fconstr * fconstr array | FLambda of int * (name * constr) list * constr * fconstr subs | FProd of name * fconstr * fconstr | FLetIn of name * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED (*********************************************************************** s A [stack] is a context of arguments, arguments are pushed by [append_stack] one array at a time but popped with [decomp_stack] one by one *) type stack_member = | Zapp of fconstr array | Zcase of case_info * fconstr * fconstr array | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr and stack = stack_member list val empty_stack : stack val append_stack : fconstr array -> stack -> stack val decomp_stack : stack -> (fconstr * stack) option val array_of_stack : stack -> fconstr array val stack_assign : stack -> int -> fconstr -> stack val stack_args_size : stack -> int val stack_tail : int -> stack -> stack val stack_nth : stack -> int -> fconstr val zip_term : (fconstr -> constr) -> constr -> stack -> constr val eta_expand_stack : stack -> stack (** To lazy reduce a constr, create a [clos_infos] with [create_clos_infos], inject the term to reduce with [inject]; then use a reduction function *) val inject : constr -> fconstr (** mk_atom: prevents a term from being evaluated *) val mk_atom : constr -> fconstr val fterm_of : fconstr -> fterm val term_of_fconstr : fconstr -> constr val destFLambda : (fconstr subs -> constr -> fconstr) -> fconstr -> name * fconstr * fconstr (** Global and local constant cache *) type clos_infos val create_clos_infos : ?evars:(existential->constr option) -> reds -> env -> clos_infos (** Reduction function *) (** [norm_val] is for strong normalization *) val norm_val : clos_infos -> fconstr -> constr (** [whd_val] is for weak head normalization *) val whd_val : clos_infos -> fconstr -> constr (** [whd_stack] performs weak head normalization in a given stack. It stops whenever a reduction is blocked. *) val whd_stack : clos_infos -> fconstr -> stack -> fconstr * stack (** Conversion auxiliary functions to do step by step normalisation *) (** [unfold_reference] unfolds references in a [fconstr] *) val unfold_reference : clos_infos -> table_key -> fconstr option val eq_table_key : table_key -> table_key -> bool (*********************************************************************** i This is for lazy debug *) val lift_fconstr : int -> fconstr -> fconstr val lift_fconstr_vect : int -> fconstr array -> fconstr array val mk_clos : fconstr subs -> constr -> fconstr val mk_clos_vect : fconstr subs -> constr array -> fconstr array val mk_clos_deep : (fconstr subs -> constr -> fconstr) -> fconstr subs -> constr -> fconstr val kni: clos_infos -> fconstr -> stack -> fconstr * stack val knr: clos_infos -> fconstr -> stack -> fconstr * stack val kl : clos_infos -> fconstr -> constr val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr val optimise_closure : fconstr subs -> constr -> fconstr subs * constr (** End of cbn debug section i*) coq-8.4pl4/kernel/cooking.mli0000644000175000017500000000205112326224777015245 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* recipe -> constant_def * constant_type * constraints * Sign.section_context (** {6 Utility functions used in module [Discharge]. } *) val expmod_constr : work_list -> constr -> constr val clear_cooking_sharing : unit -> unit coq-8.4pl4/kernel/conv_oracle.mli0000644000175000017500000000274412326224777016117 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a tableKey -> 'a tableKey -> bool (** Priority for the expansion of constant in the conversion test. * Higher levels means that the expansion is less prioritary. * (And Expand stands for -oo, and Opaque +oo.) * The default value (transparent constants) is [Level 0]. *) type level = Expand | Level of int | Opaque val transparent : level val get_strategy : 'a tableKey -> level (** Sets the level of a constant. * Level of RelKey constant cannot be set. *) val set_strategy : 'a tableKey -> level -> unit val get_transp_state : unit -> transparent_state (**************************** Summary operations *) type oracle val init : unit -> unit val freeze : unit -> oracle val unfreeze : oracle -> unit coq-8.4pl4/kernel/term.mli0000644000175000017500000005360512326224777014576 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* sorts_family (** {6 Useful types } *) (** {6 Existential variables } *) type existential_key = int (** {6 Existential variables } *) type metavariable = int (** {6 Case annotation } *) type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle (** infer printing form from number of constructor *) type case_printing = { ind_nargs : int; (** length of the arity of the inductive type *) style : case_style } (** the integer is the number of real args, needed for reduction *) type case_info = { ci_ind : inductive; ci_npar : int; ci_cstr_ndecls : int array; (** number of real args of each constructor *) ci_pp_info : case_printing (** not interpreted by the kernel *) } (** {6 The type of constructions } *) type constr (** [eq_constr a b] is true if [a] equals [b] modulo alpha, casts, and application grouping *) val eq_constr : constr -> constr -> bool (** [types] is the same as [constr] but is intended to be used for documentation to indicate that such or such function specifically works with {e types} (i.e. terms of type a sort). (Rem:plurial form since [type] is a reserved ML keyword) *) type types = constr (** {5 Functions for dealing with constr terms. } The following functions are intended to simplify and to uniform the manipulation of terms. Some of these functions may be overlapped with previous ones. *) (** {6 Term constructors. } *) (** Constructs a DeBrujin index (DB indices begin at 1) *) val mkRel : int -> constr (** Constructs a Variable *) val mkVar : identifier -> constr (** Constructs an patvar named "?n" *) val mkMeta : metavariable -> constr (** Constructs an existential variable *) type existential = existential_key * constr array val mkEvar : existential -> constr (** Construct a sort *) val mkSort : sorts -> types val mkProp : types val mkSet : types val mkType : Univ.universe -> types (** This defines the strategy to use for verifiying a Cast *) type cast_kind = VMcast | DEFAULTcast | REVERTcast (** Constructs the term [t1::t2], i.e. the term t{_ 1} casted with the type t{_ 2} (that means t2 is declared as the type of t1). *) val mkCast : constr * cast_kind * constr -> constr (** Constructs the product [(x:t1)t2] *) val mkProd : name * types * types -> types val mkNamedProd : identifier -> types -> types -> types (** non-dependent product [t1 -> t2], an alias for [forall (_:t1), t2]. Beware [t_2] is NOT lifted. Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 0) (mkRel 1))] *) val mkArrow : types -> types -> constr (** Constructs the abstraction \[x:t{_ 1}\]t{_ 2} *) val mkLambda : name * types * constr -> constr val mkNamedLambda : identifier -> types -> constr -> constr (** Constructs the product [let x = t1 : t2 in t3] *) val mkLetIn : name * constr * types * constr -> constr val mkNamedLetIn : identifier -> constr -> types -> constr -> constr (** [mkApp (f,[| t_1; ...; t_n |]] constructs the application {% $(f~t_1~\dots~t_n)$ %}. *) val mkApp : constr * constr array -> constr (** Constructs a constant The array of terms correspond to the variables introduced in the section *) val mkConst : constant -> constr (** Inductive types *) (** Constructs the ith (co)inductive type of the block named kn The array of terms correspond to the variables introduced in the section *) val mkInd : inductive -> constr (** Constructs the jth constructor of the ith (co)inductive type of the block named kn. The array of terms correspond to the variables introduced in the section *) val mkConstruct : constructor -> constr (** Constructs a destructor of inductive type. [mkCase ci p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] presented as describe in [ci]. [p] stucture is [fun args x -> "return clause"] [ac]{^ ith} element is ith constructor case presented as {e lambda construct_args (without params). case_term } *) val mkCase : case_info * constr * constr * constr array -> constr (** If [recindxs = [|i1,...in|]] [funnames = [|f1,.....fn|]] [typarray = [|t1,...tn|]] [bodies = [|b1,.....bn|]] then [mkFix ((recindxs,i), funnames, typarray, bodies) ] constructs the {% $ %}i{% $ %}th function of the block (counting from 0) [Fixpoint f1 [ctx1] = b1 with f2 [ctx2] = b2 ... with fn [ctxn] = bn.] where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. *) type rec_declaration = name array * types array * constr array type fixpoint = (int array * int) * rec_declaration val mkFix : fixpoint -> constr (** If [funnames = [|f1,.....fn|]] [typarray = [|t1,...tn|]] [bodies = [b1,.....bn]] then [mkCoFix (i, (funnames, typarray, bodies))] constructs the ith function of the block [CoFixpoint f1 = b1 with f2 = b2 ... with fn = bn.] *) type cofixpoint = int * rec_declaration val mkCoFix : cofixpoint -> constr (** {6 Concrete type for making pattern-matching. } *) (** [constr array] is an instance matching definitional [named_context] in the same order (i.e. last argument first) *) type 'constr pexistential = existential_key * 'constr array type ('constr, 'types) prec_declaration = name array * 'types array * 'constr array type ('constr, 'types) pfixpoint = (int array * int) * ('constr, 'types) prec_declaration type ('constr, 'types) pcofixpoint = int * ('constr, 'types) prec_declaration type ('constr, 'types) kind_of_term = | Rel of int | Var of identifier | Meta of metavariable | Evar of 'constr pexistential | Sort of sorts | Cast of 'constr * cast_kind * 'types | Prod of name * 'types * 'types | Lambda of name * 'types * 'constr | LetIn of name * 'constr * 'types * 'constr | App of 'constr * 'constr array | Const of constant | Ind of inductive | Construct of constructor | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint (** User view of [constr]. For [App], it is ensured there is at least one argument and the function is not itself an applicative term *) val kind_of_term : constr -> (constr, types) kind_of_term (** Experimental, used in Presburger contrib *) type ('constr, 'types) kind_of_type = | SortType of sorts | CastType of 'types * 'types | ProdType of name * 'types * 'types | LetInType of name * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array val kind_of_type : types -> (constr, types) kind_of_type (** {6 Simple term case analysis. } *) val isRel : constr -> bool val isRelN : int -> constr -> bool val isVar : constr -> bool val isVarId : identifier -> constr -> bool val isInd : constr -> bool val isEvar : constr -> bool val isMeta : constr -> bool val isMetaOf : metavariable -> constr -> bool val isEvar_or_Meta : constr -> bool val isSort : constr -> bool val isCast : constr -> bool val isApp : constr -> bool val isLambda : constr -> bool val isLetIn : constr -> bool val isProd : constr -> bool val isConst : constr -> bool val isConstruct : constr -> bool val isFix : constr -> bool val isCoFix : constr -> bool val isCase : constr -> bool val is_Prop : constr -> bool val is_Set : constr -> bool val isprop : constr -> bool val is_Type : constr -> bool val iskind : constr -> bool val is_small : sorts -> bool (** {6 Term destructors } *) (** Destructor operations are partial functions and @raise Invalid_argument "dest*" if the term has not the expected form. *) (** Destructs a DeBrujin index *) val destRel : constr -> int (** Destructs an existential variable *) val destMeta : constr -> metavariable (** Destructs a variable *) val destVar : constr -> identifier (** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *) val destSort : constr -> sorts (** Destructs a casted term *) val destCast : constr -> constr * cast_kind * constr (** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *) val destProd : types -> name * types * types (** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *) val destLambda : constr -> name * types * constr (** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *) val destLetIn : constr -> name * constr * types * constr (** Destructs an application *) val destApp : constr -> constr * constr array (** Obsolete synonym of destApp *) val destApplication : constr -> constr * constr array (** Decompose any term as an applicative term; the list of args can be empty *) val decompose_app : constr -> constr * constr list (** Destructs a constant *) val destConst : constr -> constant (** Destructs an existential variable *) val destEvar : constr -> existential (** Destructs a (co)inductive type *) val destInd : constr -> inductive (** Destructs a constructor *) val destConstruct : constr -> constructor (** Destructs a [match c as x in I args return P with ... | Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args return P in t1], or [if c then t1 else t2]) @return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])] where [info] is pretty-printing information *) val destCase : constr -> case_info * constr * constr * constr array (** Destructs the {% $ %}i{% $ %}th function of the block [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1} with f{_ 2} ctx{_ 2} = b{_ 2} ... with f{_ n} ctx{_ n} = b{_ n}], where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. *) val destFix : constr -> fixpoint val destCoFix : constr -> cofixpoint (** {6 Local } *) (** A {e declaration} has the form [(name,body,type)]. It is either an {e assumption} if [body=None] or a {e definition} if [body=Some actualbody]. It is referred by {e name} if [na] is an identifier or by {e relative index} if [na] is not an identifier (in the latter case, [na] is of type [name] but just for printing purpose) *) type named_declaration = identifier * constr option * types type rel_declaration = name * constr option * types val map_named_declaration : (constr -> constr) -> named_declaration -> named_declaration val map_rel_declaration : (constr -> constr) -> rel_declaration -> rel_declaration val fold_named_declaration : (constr -> 'a -> 'a) -> named_declaration -> 'a -> 'a val fold_rel_declaration : (constr -> 'a -> 'a) -> rel_declaration -> 'a -> 'a val exists_named_declaration : (constr -> bool) -> named_declaration -> bool val exists_rel_declaration : (constr -> bool) -> rel_declaration -> bool val for_all_named_declaration : (constr -> bool) -> named_declaration -> bool val for_all_rel_declaration : (constr -> bool) -> rel_declaration -> bool val eq_named_declaration : named_declaration -> named_declaration -> bool val eq_rel_declaration : rel_declaration -> rel_declaration -> bool (** {6 Contexts of declarations referred to by de Bruijn indices } *) (** In [rel_context], more recent declaration is on top *) type rel_context = rel_declaration list val empty_rel_context : rel_context val add_rel_decl : rel_declaration -> rel_context -> rel_context val lookup_rel : int -> rel_context -> rel_declaration val rel_context_length : rel_context -> int val rel_context_nhyps : rel_context -> int (** Constructs either [(x:t)c] or [[x=b:t]c] *) val mkProd_or_LetIn : rel_declaration -> types -> types val mkProd_wo_LetIn : rel_declaration -> types -> types val mkNamedProd_or_LetIn : named_declaration -> types -> types val mkNamedProd_wo_LetIn : named_declaration -> types -> types (** Constructs either [[x:t]c] or [[x=b:t]c] *) val mkLambda_or_LetIn : rel_declaration -> constr -> constr val mkNamedLambda_or_LetIn : named_declaration -> constr -> constr (** {6 Other term constructors. } *) (** [applist (f,args)] and its variants work as [mkApp] *) val applist : constr * constr list -> constr val applistc : constr -> constr list -> constr val appvect : constr * constr array -> constr val appvectc : constr -> constr array -> constr (** [prodn n l b] = [forall (x_1:T_1)...(x_n:T_n), b] where [l] is [(x_n,T_n)...(x_1,T_1)...]. *) val prodn : int -> (name * constr) list -> constr -> constr (** [compose_prod l b] @return [forall (x_1:T_1)...(x_n:T_n), b] where [l] is [(x_n,T_n)...(x_1,T_1)]. Inverse of [decompose_prod]. *) val compose_prod : (name * constr) list -> constr -> constr (** [lamn n l b] @return [fun (x_1:T_1)...(x_n:T_n) => b] where [l] is [(x_n,T_n)...(x_1,T_1)...]. *) val lamn : int -> (name * constr) list -> constr -> constr (** [compose_lam l b] @return [fun (x_1:T_1)...(x_n:T_n) => b] where [l] is [(x_n,T_n)...(x_1,T_1)]. Inverse of [it_destLam] *) val compose_lam : (name * constr) list -> constr -> constr (** [to_lambda n l] @return [fun (x_1:T_1)...(x_n:T_n) => T] where [l] is [forall (x_1:T_1)...(x_n:T_n), T] *) val to_lambda : int -> constr -> constr (** [to_prod n l] @return [forall (x_1:T_1)...(x_n:T_n), T] where [l] is [fun (x_1:T_1)...(x_n:T_n) => T] *) val to_prod : int -> constr -> constr (** pseudo-reduction rule *) (** [prod_appvect] [forall (x1:B1;...;xn:Bn), B] [a1...an] @return [B[a1...an]] *) val prod_appvect : constr -> constr array -> constr val prod_applist : constr -> constr list -> constr val it_mkLambda_or_LetIn : constr -> rel_context -> constr val it_mkProd_or_LetIn : types -> rel_context -> types (** {6 Other term destructors. } *) (** Transforms a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a product. *) val decompose_prod : constr -> (name*constr) list * constr (** Transforms a lambda term {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a lambda. *) val decompose_lam : constr -> (name*constr) list * constr (** Given a positive integer n, transforms a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} into the pair {% $ %}([(xn,Tn);...;(x1,T1)],T){% $ %}. *) val decompose_prod_n : int -> constr -> (name * constr) list * constr (** Given a positive integer {% $ %}n{% $ %}, transforms a lambda term {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %} *) val decompose_lam_n : int -> constr -> (name * constr) list * constr (** Extract the premisses and the conclusion of a term of the form "(xi:Ti) ... (xj:=cj:Tj) ..., T" where T is not a product nor a let *) val decompose_prod_assum : types -> rel_context * types (** Idem with lambda's *) val decompose_lam_assum : constr -> rel_context * constr (** Idem but extract the first [n] premisses *) val decompose_prod_n_assum : int -> types -> rel_context * types val decompose_lam_n_assum : int -> constr -> rel_context * constr (** [nb_lam] {% $ %}[x_1:T_1]...[x_n:T_n]c{% $ %} where {% $ %}c{% $ %} is not an abstraction gives {% $ %}n{% $ %} (casts are ignored) *) val nb_lam : constr -> int (** Similar to [nb_lam], but gives the number of products instead *) val nb_prod : constr -> int (** Returns the premisses/parameters of a type/term (let-in included) *) val prod_assum : types -> rel_context val lam_assum : constr -> rel_context (** Returns the first n-th premisses/parameters of a type/term (let included)*) val prod_n_assum : int -> types -> rel_context val lam_n_assum : int -> constr -> rel_context (** Remove the premisses/parameters of a type/term *) val strip_prod : types -> types val strip_lam : constr -> constr (** Remove the first n-th premisses/parameters of a type/term *) val strip_prod_n : int -> types -> types val strip_lam_n : int -> constr -> constr (** Remove the premisses/parameters of a type/term (including let-in) *) val strip_prod_assum : types -> types val strip_lam_assum : constr -> constr (** flattens application lists *) val collapse_appl : constr -> constr (** Removes recursively the casts around a term i.e. [strip_outer_cast (Cast (Cast ... (Cast c, t) ... ))] is [c]. *) val strip_outer_cast : constr -> constr (** Apply a function letting Casted types in place *) val under_casts : (constr -> constr) -> constr -> constr (** Apply a function under components of Cast if any *) val under_outer_cast : (constr -> constr) -> constr -> constr (** {6 ... } *) (** An "arity" is a term of the form [[x1:T1]...[xn:Tn]s] with [s] a sort. Such a term can canonically be seen as the pair of a context of types and of a sort *) type arity = rel_context * sorts (** Build an "arity" from its canonical form *) val mkArity : arity -> types (** Destructs an "arity" into its canonical form *) val destArity : types -> arity (** Tells if a term has the form of an arity *) val isArity : types -> bool (** {6 Occur checks } *) (** [closedn n M] is true iff [M] is a (deBruijn) closed term under n binders *) val closedn : int -> constr -> bool (** [closed0 M] is true iff [M] is a (deBruijn) closed term *) val closed0 : constr -> bool (** [noccurn n M] returns true iff [Rel n] does NOT occur in term [M] *) val noccurn : int -> constr -> bool (** [noccur_between n m M] returns true iff [Rel p] does NOT occur in term [M] for n <= p < n+m *) val noccur_between : int -> int -> constr -> bool (** Checking function for terms containing existential- or meta-variables. The function [noccur_with_meta] does not consider meta-variables applied to some terms (intended to be its local context) (for existential variables, it is necessarily the case) *) val noccur_with_meta : int -> int -> constr -> bool (** {6 Relocation and substitution } *) (** [exliftn el c] lifts [c] with lifting [el] *) val exliftn : Esubst.lift -> constr -> constr (** [liftn n k c] lifts by [n] indexes above or equal to [k] in [c] *) val liftn : int -> int -> constr -> constr (** [lift n c] lifts by [n] the positive indexes in [c] *) val lift : int -> constr -> constr (** [substnl [a1;...;an] k c] substitutes in parallel [a1],...,[an] for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates accordingly indexes in [a1],...,[an] *) val substnl : constr list -> int -> constr -> constr val substl : constr list -> constr -> constr val subst1 : constr -> constr -> constr val substnl_decl : constr list -> int -> rel_declaration -> rel_declaration val substl_decl : constr list -> rel_declaration -> rel_declaration val subst1_decl : constr -> rel_declaration -> rel_declaration val subst1_named_decl : constr -> named_declaration -> named_declaration val substl_named_decl : constr list -> named_declaration -> named_declaration val replace_vars : (identifier * constr) list -> constr -> constr val subst_var : identifier -> constr -> constr (** [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t] if two names are identical, the one of least indice is kept *) val subst_vars : identifier list -> constr -> constr (** [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t] if two names are identical, the one of least indice is kept *) val substn_vars : int -> identifier list -> constr -> constr (** {6 Functionals working on the immediate subterm of a construction } *) (** [fold_constr f acc c] folds [f] on the immediate subterms of [c] starting from [acc] and proceeding from left to right according to the usual representation of the constructions; it is not recursive *) val fold_constr : ('a -> constr -> 'a) -> 'a -> constr -> 'a (** [map_constr f c] maps [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is not specified *) val map_constr : (constr -> constr) -> constr -> constr (** [map_constr_with_binders g f n c] maps [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive and the order with which subterms are processed is not specified *) val map_constr_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr (** [iter_constr f c] iters [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is not specified *) val iter_constr : (constr -> unit) -> constr -> unit (** [iter_constr_with_binders g f n c] iters [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive and the order with which subterms are processed is not specified *) val iter_constr_with_binders : ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit (** [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare the immediate subterms of [c1] of [c2] if needed; Cast's, binders name and Cases annotations are not taken into account *) val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool val constr_ord : constr -> constr -> int val hash_constr : constr -> int (*********************************************************************) val hcons_sorts : sorts -> sorts val hcons_constr : constr -> constr val hcons_types : types -> types (**************************************) type values coq-8.4pl4/kernel/safe_typing.ml0000644000175000017500000006722212326224777015766 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* set_engagement eng env | _ -> env type library_info = dir_path * Digest.t type safe_environment = { old : safe_environment; env : env; modinfo : module_info; modlabels : Labset.t; objlabels : Labset.t; revstruct : structure_body; univ : Univ.constraints; engagement : engagement option; imports : library_info list; loads : (module_path * module_body) list; local_retroknowledge : Retroknowledge.action list} let exists_modlabel l senv = Labset.mem l senv.modlabels let exists_objlabel l senv = Labset.mem l senv.objlabels let check_modlabel l senv = if exists_modlabel l senv then error_existing_label l let check_objlabel l senv = if exists_objlabel l senv then error_existing_label l let check_objlabels ls senv = Labset.iter (fun l -> check_objlabel l senv) ls let labels_of_mib mib = let add,get = let labels = ref Labset.empty in (fun id -> labels := Labset.add (label_of_id id) !labels), (fun () -> !labels) in let visit_mip mip = add mip.mind_typename; Array.iter add mip.mind_consnames in Array.iter visit_mip mib.mind_packets; get () (* a small hack to avoid variants and an unused case in all functions *) let rec empty_environment = { old = empty_environment; env = empty_env; modinfo = { modpath = initial_path; label = mk_label "_"; variant = NONE; resolver = empty_delta_resolver; resolver_of_param = empty_delta_resolver}; modlabels = Labset.empty; objlabels = Labset.empty; revstruct = []; univ = Univ.empty_constraint; engagement = None; imports = []; loads = []; local_retroknowledge = [] } let env_of_safe_env senv = senv.env let env_of_senv = env_of_safe_env let add_constraints cst senv = { senv with env = Environ.add_constraints cst senv.env; univ = Univ.union_constraints cst senv.univ } let constraints_of_sfb = function | SFBconst cb -> cb.const_constraints | SFBmind mib -> mib.mind_constraints | SFBmodtype mtb -> mtb.typ_constraints | SFBmodule mb -> mb.mod_constraints (* A generic function for adding a new field in a same environment. It also performs the corresponding [add_constraints]. *) type generic_name = | C of constant | I of mutual_inductive | MT of module_path | M let add_field ((l,sfb) as field) gn senv = let mlabs,olabs = match sfb with | SFBmind mib -> let l = labels_of_mib mib in check_objlabels l senv; (Labset.empty,l) | SFBconst _ -> check_objlabel l senv; (Labset.empty, Labset.singleton l) | SFBmodule _ | SFBmodtype _ -> check_modlabel l senv; (Labset.singleton l, Labset.empty) in let senv = add_constraints (constraints_of_sfb sfb) senv in let env' = match sfb, gn with | SFBconst cb, C con -> Environ.add_constant con cb senv.env | SFBmind mib, I mind -> Environ.add_mind mind mib senv.env | SFBmodtype mtb, MT mp -> Environ.add_modtype mp mtb senv.env | SFBmodule mb, M -> Modops.add_module mb senv.env | _ -> assert false in { senv with env = env'; modlabels = Labset.union mlabs senv.modlabels; objlabels = Labset.union olabs senv.objlabels; revstruct = field :: senv.revstruct } (* Applying a certain function to the resolver of a safe environment *) let update_resolver f senv = let mi = senv.modinfo in { senv with modinfo = { mi with resolver = f mi.resolver }} (* universal lifting, used for the "get" operations mostly *) let retroknowledge f senv = Environ.retroknowledge f (env_of_senv senv) let register senv field value by_clause = (* todo : value closed, by_clause safe, by_clause of the proper type*) (* spiwack : updates the safe_env with the information that the register action has to be performed (again) when the environement is imported *) {senv with env = Environ.register senv.env field value; local_retroknowledge = Retroknowledge.RKRegister (field,value)::senv.local_retroknowledge } (* spiwack : currently unused *) let unregister senv field = (*spiwack: todo: do things properly or delete *) {senv with env = Environ.unregister senv.env field} (* /spiwack *) (* Insertion of section variables. They are now typed before being added to the environment. *) (* Same as push_named, but check that the variable is not already there. Should *not* be done in Environ because tactics add temporary hypothesis many many times, and the check performed here would cost too much. *) let safe_push_named (id,_,_ as d) env = let _ = try let _ = lookup_named id env in error ("Identifier "^string_of_id id^" already defined.") with Not_found -> () in Environ.push_named d env let push_named_def (id,b,topt) senv = let (c,typ,cst) = translate_local_def senv.env (b,topt) in let senv' = add_constraints cst senv in let env'' = safe_push_named (id,Some c,typ) senv'.env in (cst, {senv' with env=env''}) let push_named_assum (id,t) senv = let (t,cst) = translate_local_assum senv.env t in let senv' = add_constraints cst senv in let env'' = safe_push_named (id,None,t) senv'.env in (cst, {senv' with env=env''}) (* Insertion of constants and parameters in environment. *) type global_declaration = | ConstantEntry of constant_entry | GlobalRecipe of Cooking.recipe let add_constant dir l decl senv = let kn = make_con senv.modinfo.modpath dir l in let cb = match decl with | ConstantEntry ce -> translate_constant senv.env kn ce | GlobalRecipe r -> let cb = translate_recipe senv.env kn r in if dir = empty_dirpath then hcons_const_body cb else cb in let senv' = add_field (l,SFBconst cb) (C kn) senv in let senv'' = match cb.const_body with | Undef (Some lev) -> update_resolver (add_inline_delta_resolver (user_con kn) (lev,None)) senv' | _ -> senv' in kn, senv'' (* Insertion of inductive types. *) let add_mind dir l mie senv = if mie.mind_entry_inds = [] then anomaly "empty inductive types declaration"; (* this test is repeated by translate_mind *) let id = (List.nth mie.mind_entry_inds 0).mind_entry_typename in if l <> label_of_id id then anomaly ("the label of inductive packet and its first inductive"^ " type do not match"); let kn = make_mind senv.modinfo.modpath dir l in let mib = translate_mind senv.env kn mie in let mib = if mib.mind_hyps <> [] then mib else hcons_mind mib in let senv' = add_field (l,SFBmind mib) (I kn) senv in kn, senv' (* Insertion of module types *) let add_modtype l mte inl senv = let mp = MPdot(senv.modinfo.modpath, l) in let mtb = translate_module_type senv.env mp inl mte in let senv' = add_field (l,SFBmodtype mtb) (MT mp) senv in mp, senv' (* full_add_module adds module with universes and constraints *) let full_add_module mb senv = let senv = add_constraints mb.mod_constraints senv in { senv with env = Modops.add_module mb senv.env } (* Insertion of modules *) let add_module l me inl senv = let mp = MPdot(senv.modinfo.modpath, l) in let mb = translate_module senv.env mp inl me in let senv' = add_field (l,SFBmodule mb) M senv in let senv'' = match mb.mod_type with | SEBstruct _ -> update_resolver (add_delta_resolver mb.mod_delta) senv' | _ -> senv' in mp,mb.mod_delta,senv'' (* Interactive modules *) let start_module l senv = check_modlabel l senv; let mp = MPdot(senv.modinfo.modpath, l) in let modinfo = { modpath = mp; label = l; variant = STRUCT []; resolver = empty_delta_resolver; resolver_of_param = empty_delta_resolver} in mp, { old = senv; env = senv.env; modinfo = modinfo; modlabels = Labset.empty; objlabels = Labset.empty; revstruct = []; univ = Univ.empty_constraint; engagement = None; imports = senv.imports; loads = []; (* spiwack : not sure, but I hope it's correct *) local_retroknowledge = [] } let end_module l restype senv = let oldsenv = senv.old in let modinfo = senv.modinfo in let mp = senv.modinfo.modpath in let restype = Option.map (fun (res,inl) -> translate_module_type senv.env mp inl res) restype in let params,is_functor = match modinfo.variant with | NONE | LIBRARY _ | SIG _ -> error_no_module_to_end () | STRUCT params -> params, (List.length params > 0) in if l <> modinfo.label then error_incompatible_labels l modinfo.label; if not (empty_context senv.env) then error_non_empty_local_context None; let functorize_struct tb = List.fold_left (fun mtb (arg_id,arg_b) -> SEBfunctor(arg_id,arg_b,mtb)) tb params in let auto_tb = SEBstruct (List.rev senv.revstruct) in let mexpr,mod_typ,mod_typ_alg,resolver,cst = match restype with | None -> let mexpr = functorize_struct auto_tb in mexpr,mexpr,None,modinfo.resolver,empty_constraint | Some mtb -> let auto_mtb = { typ_mp = senv.modinfo.modpath; typ_expr = auto_tb; typ_expr_alg = None; typ_constraints = empty_constraint; typ_delta = empty_delta_resolver} in let cst = check_subtypes senv.env auto_mtb mtb in let mod_typ = functorize_struct mtb.typ_expr in let mexpr = functorize_struct auto_tb in let typ_alg = Option.map functorize_struct mtb.typ_expr_alg in mexpr,mod_typ,typ_alg,mtb.typ_delta,cst in let cst = union_constraints cst senv.univ in let mb = { mod_mp = mp; mod_expr = Some mexpr; mod_type = mod_typ; mod_type_alg = mod_typ_alg; mod_constraints = cst; mod_delta = resolver; mod_retroknowledge = senv.local_retroknowledge } in let newenv = oldsenv.env in let newenv = set_engagement_opt senv.engagement newenv in let senv'= {senv with env = newenv; univ = cst} in let senv' = List.fold_left (fun env (_,mb) -> full_add_module mb env) senv' (List.rev senv'.loads) in let newenv = Environ.add_constraints cst senv'.env in let newenv = Modops.add_module mb newenv in let modinfo = match mb.mod_type with SEBstruct _ -> { oldsenv.modinfo with resolver = add_delta_resolver resolver oldsenv.modinfo.resolver} | _ -> oldsenv.modinfo in mp,resolver,{ old = oldsenv.old; env = newenv; modinfo = modinfo; modlabels = Labset.add l oldsenv.modlabels; objlabels = oldsenv.objlabels; revstruct = (l,SFBmodule mb)::oldsenv.revstruct; univ = Univ.union_constraints senv'.univ oldsenv.univ; (* engagement is propagated to the upper level *) engagement = senv'.engagement; imports = senv'.imports; loads = senv'.loads@oldsenv.loads; local_retroknowledge = senv'.local_retroknowledge@oldsenv.local_retroknowledge } (* Include for module and module type*) let add_include me is_module inl senv = let sign,cst,resolver = if is_module then let sign,_,resolver,cst = translate_struct_include_module_entry senv.env senv.modinfo.modpath inl me in sign,cst,resolver else let mtb = translate_module_type senv.env senv.modinfo.modpath inl me in mtb.typ_expr,mtb.typ_constraints,mtb.typ_delta in let senv = add_constraints cst senv in let mp_sup = senv.modinfo.modpath in (* Include Self support *) let rec compute_sign sign mb resolver senv = match sign with | SEBfunctor(mbid,mtb,str) -> let cst_sub = check_subtypes senv.env mb mtb in let senv = add_constraints cst_sub senv in let mpsup_delta = inline_delta_resolver senv.env inl mp_sup mbid mtb mb.typ_delta in let subst = map_mbid mbid mp_sup mpsup_delta in let resolver = subst_codom_delta_resolver subst resolver in (compute_sign (subst_struct_expr subst str) mb resolver senv) | str -> resolver,str,senv in let resolver,sign,senv = compute_sign sign {typ_mp = mp_sup; typ_expr = SEBstruct (List.rev senv.revstruct); typ_expr_alg = None; typ_constraints = empty_constraint; typ_delta = senv.modinfo.resolver} resolver senv in let str = match sign with | SEBstruct(str_l) -> str_l | _ -> error ("You cannot Include a higher-order structure.") in let senv = update_resolver (add_delta_resolver resolver) senv in let add senv ((l,elem) as field) = let new_name = match elem with | SFBconst _ -> let kn = make_kn mp_sup empty_dirpath l in C (constant_of_delta_kn resolver kn) | SFBmind _ -> let kn = make_kn mp_sup empty_dirpath l in I (mind_of_delta_kn resolver kn) | SFBmodule _ -> M | SFBmodtype _ -> MT (MPdot(senv.modinfo.modpath, l)) in add_field field new_name senv in resolver,(List.fold_left add senv str) (* Adding parameters to modules or module types *) let add_module_parameter mbid mte inl senv = if senv.revstruct <> [] or senv.loads <> [] then anomaly "Cannot add a module parameter to a non empty module"; let mtb = translate_module_type senv.env (MPbound mbid) inl mte in let senv = full_add_module (module_body_of_type (MPbound mbid) mtb) senv in let new_variant = match senv.modinfo.variant with | STRUCT params -> STRUCT ((mbid,mtb) :: params) | SIG params -> SIG ((mbid,mtb) :: params) | _ -> anomaly "Module parameters can only be added to modules or signatures" in let resolver_of_param = match mtb.typ_expr with SEBstruct _ -> mtb.typ_delta | _ -> empty_delta_resolver in mtb.typ_delta, { old = senv.old; env = senv.env; modinfo = { senv.modinfo with variant = new_variant; resolver_of_param = add_delta_resolver resolver_of_param senv.modinfo.resolver_of_param}; modlabels = senv.modlabels; objlabels = senv.objlabels; revstruct = []; univ = senv.univ; engagement = senv.engagement; imports = senv.imports; loads = []; local_retroknowledge = senv.local_retroknowledge } (* Interactive module types *) let start_modtype l senv = check_modlabel l senv; let mp = MPdot(senv.modinfo.modpath, l) in let modinfo = { modpath = mp; label = l; variant = SIG []; resolver = empty_delta_resolver; resolver_of_param = empty_delta_resolver} in mp, { old = senv; env = senv.env; modinfo = modinfo; modlabels = Labset.empty; objlabels = Labset.empty; revstruct = []; univ = Univ.empty_constraint; engagement = None; imports = senv.imports; loads = [] ; (* spiwack: not 100% sure, but I think it should be like that *) local_retroknowledge = []} let end_modtype l senv = let oldsenv = senv.old in let modinfo = senv.modinfo in let params = match modinfo.variant with | LIBRARY _ | NONE | STRUCT _ -> error_no_modtype_to_end () | SIG params -> params in if l <> modinfo.label then error_incompatible_labels l modinfo.label; if not (empty_context senv.env) then error_non_empty_local_context None; let auto_tb = SEBstruct (List.rev senv.revstruct) in let mtb_expr = List.fold_left (fun mtb (arg_id,arg_b) -> SEBfunctor(arg_id,arg_b,mtb)) auto_tb params in let mp = MPdot (oldsenv.modinfo.modpath, l) in let newenv = oldsenv.env in let newenv = Environ.add_constraints senv.univ newenv in let newenv = set_engagement_opt senv.engagement newenv in let senv = {senv with env=newenv} in let senv = List.fold_left (fun env (mp,mb) -> full_add_module mb env) senv (List.rev senv.loads) in let mtb = {typ_mp = mp; typ_expr = mtb_expr; typ_expr_alg = None; typ_constraints = senv.univ; typ_delta = senv.modinfo.resolver} in let newenv = Environ.add_modtype mp mtb senv.env in mp, { old = oldsenv.old; env = newenv; modinfo = oldsenv.modinfo; modlabels = Labset.add l oldsenv.modlabels; objlabels = oldsenv.objlabels; revstruct = (l,SFBmodtype mtb)::oldsenv.revstruct; univ = Univ.union_constraints senv.univ oldsenv.univ; engagement = senv.engagement; imports = senv.imports; loads = senv.loads@oldsenv.loads; (* spiwack : if there is a bug with retroknowledge in nested modules it's likely to come from here *) local_retroknowledge = senv.local_retroknowledge@oldsenv.local_retroknowledge} let current_modpath senv = senv.modinfo.modpath let delta_of_senv senv = senv.modinfo.resolver,senv.modinfo.resolver_of_param (* Check that the engagement expected by a library matches the initial one *) let check_engagement env c = match Environ.engagement env, c with | Some ImpredicativeSet, Some ImpredicativeSet -> () | _, None -> () | _, Some ImpredicativeSet -> error "Needs option -impredicative-set." let set_engagement c senv = {senv with env = Environ.set_engagement c senv.env; engagement = Some c } (* Libraries = Compiled modules *) type compiled_library = dir_path * module_body * library_info list * engagement option (* We check that only initial state Require's were performed before [start_library] was called *) let is_empty senv = senv.revstruct = [] && senv.modinfo.modpath = initial_path && senv.modinfo.variant = NONE let start_library dir senv = if not (is_empty senv) then anomaly "Safe_typing.start_library: environment should be empty"; let dir_path,l = match (repr_dirpath dir) with [] -> anomaly "Empty dirpath in Safe_typing.start_library" | hd::tl -> make_dirpath tl, label_of_id hd in let mp = MPfile dir in let modinfo = {modpath = mp; label = l; variant = LIBRARY dir; resolver = empty_delta_resolver; resolver_of_param = empty_delta_resolver} in mp, { old = senv; env = senv.env; modinfo = modinfo; modlabels = Labset.empty; objlabels = Labset.empty; revstruct = []; univ = Univ.empty_constraint; engagement = None; imports = senv.imports; loads = []; local_retroknowledge = [] } let pack_module senv = {mod_mp=senv.modinfo.modpath; mod_expr=None; mod_type= SEBstruct (List.rev senv.revstruct); mod_type_alg=None; mod_constraints=empty_constraint; mod_delta=senv.modinfo.resolver; mod_retroknowledge=[]; } let export senv dir = let modinfo = senv.modinfo in begin match modinfo.variant with | LIBRARY dp -> if dir <> dp then anomaly "We are not exporting the right library!" | _ -> anomaly "We are not exporting the library" end; (*if senv.modinfo.params <> [] || senv.modinfo.restype <> None then (* error_export_simple *) (); *) let str = SEBstruct (List.rev senv.revstruct) in let mp = senv.modinfo.modpath in let mb = { mod_mp = mp; mod_expr = Some str; mod_type = str; mod_type_alg = None; mod_constraints = senv.univ; mod_delta = senv.modinfo.resolver; mod_retroknowledge = senv.local_retroknowledge} in mp, (dir,mb,senv.imports,engagement senv.env) let check_imports senv needed = let imports = senv.imports in let check (id,stamp) = try let actual_stamp = List.assoc id imports in if stamp <> actual_stamp then error ("Inconsistent assumptions over module "^(string_of_dirpath id)^".") with Not_found -> error ("Reference to unknown module "^(string_of_dirpath id)^".") in List.iter check needed (* we have an inefficiency: Since loaded files are added to the environment every time a module is closed, their components are calculated many times. Thic could be avoided in several ways: 1 - for each file create a dummy environment containing only this file's components, merge this environment with the global environment, and store for the future (instead of just its type) 2 - create "persistent modules" environment table in Environ add put loaded by side-effect once and for all (like it is done in OCaml). Would this be correct with respect to undo's and stuff ? *) let import (dp,mb,depends,engmt) digest senv = check_imports senv depends; check_engagement senv.env engmt; let mp = MPfile dp in let env = senv.env in let env = Environ.add_constraints mb.mod_constraints env in let env = Modops.add_module mb env in mp, { senv with env = env; modinfo = {senv.modinfo with resolver = add_delta_resolver mb.mod_delta senv.modinfo.resolver}; imports = (dp,digest)::senv.imports; loads = (mp,mb)::senv.loads } (* Store the body of modules' opaque constants inside a table. This module is used during the serialization and deserialization of vo files. By adding an indirection to the opaque constant definitions, we gain the ability not to load them. As these constant definitions are usually big terms, we save a deserialization time as well as some memory space. *) module LightenLibrary : sig type table type lightened_compiled_library val save : compiled_library -> lightened_compiled_library * table val load : load_proof:Flags.load_proofs -> table Lazy.t -> lightened_compiled_library -> compiled_library end = struct (* The table is implemented as an array of [constr_substituted]. Keys are hence integers. To avoid changing the [compiled_library] type, we brutally encode integers into [lazy_constr]. This isn't pretty, but shouldn't be dangerous since the produced structure [lightened_compiled_library] is abstract and only meant for writing to .vo via Marshal (which doesn't care about types). *) type table = constr_substituted array let key_as_lazy_constr (i:int) = (Obj.magic i : lazy_constr) let key_of_lazy_constr (c:lazy_constr) = (Obj.magic c : int) (* To avoid any future misuse of the lightened library that could interpret encoded keys as real [constr_substituted], we hide these kind of values behind an abstract datatype. *) type lightened_compiled_library = compiled_library (* Map a [compiled_library] to another one by just updating the opaque term [t] to [on_opaque_const_body t]. *) let traverse_library on_opaque_const_body = let rec traverse_module mb = match mb.mod_expr with None -> { mb with mod_expr = None; mod_type = traverse_modexpr mb.mod_type; } | Some impl when impl == mb.mod_type-> let mtb = traverse_modexpr mb.mod_type in { mb with mod_expr = Some mtb; mod_type = mtb; } | Some impl -> { mb with mod_expr = Option.map traverse_modexpr mb.mod_expr; mod_type = traverse_modexpr mb.mod_type; } and traverse_struct struc = let traverse_body (l,body) = (l,match body with | SFBconst cb when is_opaque cb -> SFBconst {cb with const_body = on_opaque_const_body cb.const_body} | (SFBconst _ | SFBmind _ ) as x -> x | SFBmodule m -> SFBmodule (traverse_module m) | SFBmodtype m -> SFBmodtype ({m with typ_expr = traverse_modexpr m.typ_expr})) in List.map traverse_body struc and traverse_modexpr = function | SEBfunctor (mbid,mty,mexpr) -> SEBfunctor (mbid, ({mty with typ_expr = traverse_modexpr mty.typ_expr}), traverse_modexpr mexpr) | SEBident mp as x -> x | SEBstruct (struc) -> SEBstruct (traverse_struct struc) | SEBapply (mexpr,marg,u) -> SEBapply (traverse_modexpr mexpr,traverse_modexpr marg,u) | SEBwith (seb,wdcl) -> SEBwith (traverse_modexpr seb,wdcl) in fun (dp,mb,depends,s) -> (dp,traverse_module mb,depends,s) (* To disburden a library from opaque definitions, we simply traverse it and add an indirection between the module body and its reference to a [const_body]. *) let save library = let ((insert : constant_def -> constant_def), (get_table : unit -> table)) = (* We use an integer as a key inside the table. *) let counter = ref (-1) in (* During the traversal, the table is implemented by a list to get constant time insertion. *) let opaque_definitions = ref [] in ((* Insert inside the table. *) (fun def -> let opaque_definition = match def with | OpaqueDef lc -> force_lazy_constr lc | _ -> assert false in incr counter; opaque_definitions := opaque_definition :: !opaque_definitions; OpaqueDef (key_as_lazy_constr !counter)), (* Get the final table representation. *) (fun () -> Array.of_list (List.rev !opaque_definitions))) in let lightened_library = traverse_library insert library in (lightened_library, get_table ()) (* Loading is also a traversing that decodes the embedded keys that are inside the [lightened_library]. If the [load_proof] flag is set, we lookup inside the table to graft the [constr_substituted]. Otherwise, we set the [const_body] field to [None]. *) let load ~load_proof (table : table Lazy.t) lightened_library = let decode_key = function | Undef _ | Def _ -> assert false | OpaqueDef k -> let k = key_of_lazy_constr k in let access key = try (Lazy.force table).(key) with e when Errors.noncritical e -> error "Error while retrieving an opaque body" in match load_proof with | Flags.Force -> let lc = Lazy.lazy_from_val (access k) in OpaqueDef (make_lazy_constr lc) | Flags.Lazy -> let lc = lazy (access k) in OpaqueDef (make_lazy_constr lc) | Flags.Dont -> Undef None in traverse_library decode_key lightened_library end type judgment = unsafe_judgment let j_val j = j.uj_val let j_type j = j.uj_type let safe_infer senv = infer (env_of_senv senv) let typing senv = Typeops.typing (env_of_senv senv) coq-8.4pl4/kernel/csymtable.mli0000644000175000017500000000130412326224777015577 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> values val set_opaque_const : constant -> unit val set_transparent_const : constant -> unit coq-8.4pl4/kernel/byterun/0000755000175000017500000000000012365131026014566 5ustar stephstephcoq-8.4pl4/kernel/byterun/coq_values.h0000644000175000017500000000231512326224777017116 0ustar stephsteph/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ #ifndef _COQ_VALUES_ #define _COQ_VALUES_ #include #include #define Default_tag 0 #define Accu_tag 0 #define ATOM_ID_TAG 0 #define ATOM_IDDEF_TAG 1 #define ATOM_INDUCTIVE_TAG 2 #define ATOM_FIX_TAG 3 #define ATOM_SWITCH_TAG 4 #define ATOM_COFIX_TAG 5 #define ATOM_COFIXEVALUATED_TAG 6 /* Les blocs accumulate */ #define Is_accu(v) (Is_block(v) && (Tag_val(v) == Accu_tag)) #define IS_EVALUATED_COFIX(v) (Is_accu(v) && Is_block(Field(v,1)) && (Tag_val(Field(v,1)) == ATOM_COFIXEVALUATED_TAG)) #endif /* _COQ_VALUES_ */ coq-8.4pl4/kernel/byterun/coq_memory.h0000644000175000017500000000407212326224777017131 0ustar stephsteph/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ #ifndef _COQ_MEMORY_ #define _COQ_MEMORY_ #include #include #include #include #include #define Coq_stack_size (4096 * sizeof(value)) #define Coq_stack_threshold (256 * sizeof(value)) #define Coq_global_data_Size (4096 * sizeof(value)) #define Coq_max_stack_size (256 * 1024) #define TRANSP 0 #define BOXED 1 /* stack */ extern value * coq_stack_low; extern value * coq_stack_high; extern value * coq_stack_threshold; /* global_data */ extern value coq_global_data; extern value coq_global_boxed; extern int coq_all_transp; extern value coq_atom_tbl; extern int drawinstr; /* interp state */ extern value * coq_sp; /* Some predefined pointer code */ extern code_t accumulate; /* functions over global environment */ value coq_static_alloc(value size); /* ML */ value init_coq_vm(value unit); /* ML */ value re_init_coq_vm(value unit); /* ML */ void realloc_coq_stack(asize_t required_space); value get_coq_global_data(value unit); /* ML */ value realloc_coq_global_data(value size); /* ML */ value get_coq_global_boxed(value unit); value realloc_coq_global_boxed(value size); /* ML */ value get_coq_atom_tbl(value unit); /* ML */ value realloc_coq_atom_tbl(value size); /* ML */ value coq_set_transp_value(value transp); /* ML */ value get_coq_transp_value(value unit); /* ML */ #endif /* _COQ_MEMORY_ */ value coq_set_drawinstr(value unit); coq-8.4pl4/kernel/byterun/int64_emul.h0000644000175000017500000001351512326224777016747 0ustar stephsteph/***********************************************************************/ /* */ /* Objective Caml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* Software emulation of 64-bit integer arithmetic, for C compilers that do not support it. */ #ifndef CAML_INT64_EMUL_H #define CAML_INT64_EMUL_H #include #ifdef ARCH_BIG_ENDIAN #define I64_literal(hi,lo) { hi, lo } #else #define I64_literal(hi,lo) { lo, hi } #endif /* Unsigned comparison */ static int I64_ucompare(uint64 x, uint64 y) { if (x.h > y.h) return 1; if (x.h < y.h) return -1; if (x.l > y.l) return 1; if (x.l < y.l) return -1; return 0; } #define I64_ult(x, y) (I64_ucompare(x, y) < 0) /* Signed comparison */ static int I64_compare(int64 x, int64 y) { if ((int32)x.h > (int32)y.h) return 1; if ((int32)x.h < (int32)y.h) return -1; if (x.l > y.l) return 1; if (x.l < y.l) return -1; return 0; } /* Negation */ static int64 I64_neg(int64 x) { int64 res; res.l = -x.l; res.h = ~x.h; if (res.l == 0) res.h++; return res; } /* Addition */ static int64 I64_add(int64 x, int64 y) { int64 res; res.l = x.l + y.l; res.h = x.h + y.h; if (res.l < x.l) res.h++; return res; } /* Subtraction */ static int64 I64_sub(int64 x, int64 y) { int64 res; res.l = x.l - y.l; res.h = x.h - y.h; if (x.l < y.l) res.h--; return res; } /* Multiplication */ static int64 I64_mul(int64 x, int64 y) { int64 res; uint32 prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF); uint32 prod10 = (x.l >> 16) * (y.l & 0xFFFF); uint32 prod01 = (x.l & 0xFFFF) * (y.l >> 16); uint32 prod11 = (x.l >> 16) * (y.l >> 16); res.l = prod00; res.h = prod11 + (prod01 >> 16) + (prod10 >> 16); prod01 = prod01 << 16; res.l += prod01; if (res.l < prod01) res.h++; prod10 = prod10 << 16; res.l += prod10; if (res.l < prod10) res.h++; res.h += x.l * y.h + x.h * y.l; return res; } #define I64_is_zero(x) (((x).l | (x).h) == 0) #define I64_is_negative(x) ((int32) (x).h < 0) /* Bitwise operations */ static int64 I64_and(int64 x, int64 y) { int64 res; res.l = x.l & y.l; res.h = x.h & y.h; return res; } static int64 I64_or(int64 x, int64 y) { int64 res; res.l = x.l | y.l; res.h = x.h | y.h; return res; } static int64 I64_xor(int64 x, int64 y) { int64 res; res.l = x.l ^ y.l; res.h = x.h ^ y.h; return res; } /* Shifts */ static int64 I64_lsl(int64 x, int s) { int64 res; s = s & 63; if (s == 0) return x; if (s < 32) { res.l = x.l << s; res.h = (x.h << s) | (x.l >> (32 - s)); } else { res.l = 0; res.h = x.l << (s - 32); } return res; } static int64 I64_lsr(int64 x, int s) { int64 res; s = s & 63; if (s == 0) return x; if (s < 32) { res.l = (x.l >> s) | (x.h << (32 - s)); res.h = x.h >> s; } else { res.l = x.h >> (s - 32); res.h = 0; } return res; } static int64 I64_asr(int64 x, int s) { int64 res; s = s & 63; if (s == 0) return x; if (s < 32) { res.l = (x.l >> s) | (x.h << (32 - s)); res.h = (int32) x.h >> s; } else { res.l = (int32) x.h >> (s - 32); res.h = (int32) x.h >> 31; } return res; } /* Division and modulus */ #define I64_SHL1(x) x.h = (x.h << 1) | (x.l >> 31); x.l <<= 1 #define I64_SHR1(x) x.l = (x.l >> 1) | (x.h << 31); x.h >>= 1 static void I64_udivmod(uint64 modulus, uint64 divisor, uint64 * quo, uint64 * mod) { int64 quotient, mask; int cmp; quotient.h = 0; quotient.l = 0; mask.h = 0; mask.l = 1; while ((int32) divisor.h >= 0) { cmp = I64_ucompare(divisor, modulus); I64_SHL1(divisor); I64_SHL1(mask); if (cmp >= 0) break; } while (mask.l | mask.h) { if (I64_ucompare(modulus, divisor) >= 0) { quotient.h |= mask.h; quotient.l |= mask.l; modulus = I64_sub(modulus, divisor); } I64_SHR1(mask); I64_SHR1(divisor); } *quo = quotient; *mod = modulus; } static int64 I64_div(int64 x, int64 y) { int64 q, r; int32 sign; sign = x.h ^ y.h; if ((int32) x.h < 0) x = I64_neg(x); if ((int32) y.h < 0) y = I64_neg(y); I64_udivmod(x, y, &q, &r); if (sign < 0) q = I64_neg(q); return q; } static int64 I64_mod(int64 x, int64 y) { int64 q, r; int32 sign; sign = x.h; if ((int32) x.h < 0) x = I64_neg(x); if ((int32) y.h < 0) y = I64_neg(y); I64_udivmod(x, y, &q, &r); if (sign < 0) r = I64_neg(r); return r; } /* Coercions */ static int64 I64_of_int32(int32 x) { int64 res; res.l = x; res.h = x >> 31; return res; } #define I64_to_int32(x) ((int32) (x).l) /* Note: we assume sizeof(intnat) = 4 here, which is true otherwise autoconfiguration would have selected native 64-bit integers */ #define I64_of_intnat I64_of_int32 #define I64_to_intnat I64_to_int32 static double I64_to_double(int64 x) { double res; int32 sign = x.h; if (sign < 0) x = I64_neg(x); res = ldexp((double) x.h, 32) + x.l; if (sign < 0) res = -res; return res; } static int64 I64_of_double(double f) { int64 res; double frac, integ; int neg; neg = (f < 0); f = fabs(f); frac = modf(ldexp(f, -32), &integ); res.h = (uint32) integ; res.l = (uint32) ldexp(frac, 32); if (neg) res = I64_neg(res); return res; } #endif /* CAML_INT64_EMUL_H */ coq-8.4pl4/kernel/byterun/coq_instruct.h0000644000175000017500000000424512326224777017476 0ustar stephsteph/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ #ifndef _COQ_INSTRUCT_ #define _COQ_INSTRUCT_ /* Nota: this list of instructions is parsed to produce derived files */ /* coq_jumptbl.h and copcodes.ml. Instructions should be uppercase */ /* and alone on lines starting by two spaces. */ enum instructions { ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, ACC, PUSH, PUSHACC0, PUSHACC1, PUSHACC2, PUSHACC3, PUSHACC4, PUSHACC5, PUSHACC6, PUSHACC7, PUSHACC, POP, ENVACC1, ENVACC2, ENVACC3, ENVACC4, ENVACC, PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC4, PUSHENVACC, PUSH_RETADDR, APPLY, APPLY1, APPLY2, APPLY3, APPTERM, APPTERM1, APPTERM2, APPTERM3, RETURN, RESTART, GRAB, GRABREC, CLOSURE, CLOSUREREC, CLOSURECOFIX, OFFSETCLOSUREM2, OFFSETCLOSURE0, OFFSETCLOSURE2, OFFSETCLOSURE, PUSHOFFSETCLOSUREM2, PUSHOFFSETCLOSURE0, PUSHOFFSETCLOSURE2, PUSHOFFSETCLOSURE, GETGLOBAL, PUSHGETGLOBAL, MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, MAKEBLOCK4, SWITCH, PUSHFIELDS, GETFIELD0, GETFIELD1, GETFIELD, SETFIELD0, SETFIELD1, SETFIELD, CONST0, CONST1, CONST2, CONST3, CONSTINT, PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT, ACCUMULATE, ACCUMULATECOND, MAKESWITCHBLOCK, MAKEACCU, MAKEPROD, /* spiwack: */ BRANCH, ADDINT31, ADDCINT31, ADDCARRYCINT31, SUBINT31, SUBCINT31, SUBCARRYCINT31, MULCINT31, MULINT31, DIV21INT31, DIVINT31, ADDMULDIVINT31, COMPAREINT31, HEAD0INT31, TAIL0INT31, ISCONST, ARECONST, COMPINT31, DECOMPINT31, /* /spiwack */ STOP }; #endif /* _COQ_INSTRUCT_ */ coq-8.4pl4/kernel/byterun/coq_gc.h0000644000175000017500000000411512326224777016210 0ustar stephsteph/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ #ifndef _COQ_CAML_GC_ #define _COQ_CAML_GC_ #include #include typedef void (*scanning_action) (value, value *); CAMLextern char *young_ptr; CAMLextern char *young_limit; CAMLextern void (*scan_roots_hook) (scanning_action); CAMLextern void minor_collection (void); #define Caml_white (0 << 8) #define Caml_black (3 << 8) #define Make_header(wosize, tag, color) \ (((header_t) (((header_t) (wosize) << 10) \ + (color) \ + (tag_t) (tag))) \ ) #define Alloc_small(result, wosize, tag) do{ \ young_ptr -= Bhsize_wosize (wosize); \ if (young_ptr < young_limit){ \ young_ptr += Bhsize_wosize (wosize); \ Setup_for_gc; \ minor_collection (); \ Restore_after_gc; \ young_ptr -= Bhsize_wosize (wosize); \ } \ Hd_hp (young_ptr) = Make_header ((wosize), (tag), Caml_black); \ (result) = Val_hp (young_ptr); \ }while(0) #endif /*_COQ_CAML_GC_ */ coq-8.4pl4/kernel/byterun/coq_fix_code.c0000644000175000017500000001417112326224777017375 0ustar stephsteph/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ /* Arnaud Spiwack: expanded the virtual machine with operators used for fast computation of bounded (31bits) integers */ #include #include #include #include #include #include #include #include "coq_instruct.h" #include "coq_fix_code.h" #ifdef THREADED_CODE char ** coq_instr_table; char * coq_instr_base; int arity[STOP+1]; void init_arity () { /* instruction with zero operand */ arity[ACC0]=arity[ACC1]=arity[ACC2]=arity[ACC3]=arity[ACC4]=arity[ACC5]= arity[ACC6]=arity[ACC7]=arity[PUSH]=arity[PUSHACC0]=arity[PUSHACC1]= arity[PUSHACC2]=arity[PUSHACC3]=arity[PUSHACC4]=arity[PUSHACC5]= arity[PUSHACC6]=arity[PUSHACC7]=arity[ENVACC1]=arity[ENVACC2]= arity[ENVACC3]=arity[ENVACC4]=arity[PUSHENVACC1]=arity[PUSHENVACC2]= arity[PUSHENVACC3]=arity[PUSHENVACC4]=arity[APPLY1]=arity[APPLY2]= arity[APPLY3]=arity[RESTART]=arity[OFFSETCLOSUREM2]= arity[OFFSETCLOSURE0]=arity[OFFSETCLOSURE2]=arity[PUSHOFFSETCLOSUREM2]= arity[PUSHOFFSETCLOSURE0]=arity[PUSHOFFSETCLOSURE2]= arity[GETFIELD0]=arity[GETFIELD1]=arity[SETFIELD0]=arity[SETFIELD1]= arity[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]= arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]= arity[ACCUMULATE]=arity[STOP]=arity[MAKEPROD]= arity[ADDINT31]=arity[ADDCINT31]=arity[ADDCARRYCINT31]= arity[SUBINT31]=arity[SUBCINT31]=arity[SUBCARRYCINT31]= arity[MULCINT31]=arity[MULINT31]=arity[COMPAREINT31]= arity[DIV21INT31]=arity[DIVINT31]=arity[ADDMULDIVINT31]= arity[HEAD0INT31]=arity[TAIL0INT31]= arity[COMPINT31]=arity[DECOMPINT31]=0; /* instruction with one operand */ arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]= arity[PUSH_RETADDR]=arity[APPLY]=arity[APPTERM1]=arity[APPTERM2]= arity[APPTERM3]=arity[RETURN]=arity[GRAB]=arity[OFFSETCLOSURE]= arity[PUSHOFFSETCLOSURE]=arity[GETGLOBAL]=arity[PUSHGETGLOBAL]= arity[MAKEBLOCK1]=arity[MAKEBLOCK2]=arity[MAKEBLOCK3]=arity[MAKEBLOCK4]= arity[MAKEACCU]=arity[CONSTINT]=arity[PUSHCONSTINT]=arity[GRABREC]= arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]=arity[ACCUMULATECOND]= arity[BRANCH]=arity[ISCONST]= 1; /* instruction with two operands */ arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]= arity[ARECONST]=2; /* instruction with four operands */ arity[MAKESWITCHBLOCK]=4; /* instruction with arbitrary operands */ arity[CLOSUREREC]=arity[CLOSURECOFIX]=arity[SWITCH]=0; } #endif /* THREADED_CODE */ void * coq_stat_alloc (asize_t sz) { void * result = malloc (sz); if (result == NULL) raise_out_of_memory (); return result; } value coq_makeaccu (value i) { code_t q; code_t res = coq_stat_alloc(8); q = res; *q++ = VALINSTR(MAKEACCU); *q = (opcode_t)Int_val(i); return (value)res; } value coq_accucond (value i) { code_t q; code_t res = coq_stat_alloc(8); q = res; *q++ = VALINSTR(ACCUMULATECOND); *q = (opcode_t)Int_val(i); return (value)res; } value coq_pushpop (value i) { code_t res; int n; n = Int_val(i); if (n == 0) { res = coq_stat_alloc(4); *res = VALINSTR(STOP); return (value)res; } else { code_t q; res = coq_stat_alloc(12); q = res; *q++ = VALINSTR(POP); *q++ = (opcode_t)n; *q = VALINSTR(STOP); return (value)res; } } value coq_is_accumulate_code(value code){ code_t q; int res; q = (code_t)code; res = Is_instruction(q,ACCUMULATECOND) || Is_instruction(q,ACCUMULATE); return Val_bool(res); } #ifdef ARCH_BIG_ENDIAN #define Reverse_32(dst,src) { \ char * _p, * _q; \ char _a, _b; \ _p = (char *) (src); \ _q = (char *) (dst); \ _a = _p[0]; \ _b = _p[1]; \ _q[0] = _p[3]; \ _q[1] = _p[2]; \ _q[3] = _a; \ _q[2] = _b; \ } #define COPY32(dst,src) Reverse_32(dst,src) #else #define COPY32(dst,src) (*dst=*src) #endif /* ARCH_BIG_ENDIAN */ value coq_tcode_of_code (value code, value size) { code_t p, q, res; asize_t len = (asize_t) Long_val(size); res = coq_stat_alloc(len); q = res; len /= sizeof(opcode_t); for (p = (code_t)code; p < (code_t)code + len; /*nothing*/) { opcode_t instr; COPY32(&instr,p); p++; if (instr < 0 || instr > STOP){ instr = STOP; }; *q++ = VALINSTR(instr); if (instr == SWITCH) { uint32 i, sizes, const_size, block_size; COPY32(q,p); p++; sizes=*q++; const_size = sizes & 0xFFFF; block_size = sizes >> 16; sizes = const_size + block_size; for(i=0; i (y)) - ((x) < (y))) #define I64_ult(x,y) ((uint64)(x) < (uint64)(y)) #define I64_neg(x) (-(x)) #define I64_add(x,y) ((x) + (y)) #define I64_sub(x,y) ((x) - (y)) #define I64_mul(x,y) ((x) * (y)) #define I64_is_zero(x) ((x) == 0) #define I64_is_negative(x) ((x) < 0) #define I64_div(x,y) ((x) / (y)) #define I64_mod(x,y) ((x) % (y)) #define I64_udivmod(x,y,quo,rem) \ (*(rem) = (uint64)(x) % (uint64)(y), \ *(quo) = (uint64)(x) / (uint64)(y)) #define I64_and(x,y) ((x) & (y)) #define I64_or(x,y) ((x) | (y)) #define I64_xor(x,y) ((x) ^ (y)) #define I64_lsl(x,y) ((x) << (y)) #define I64_asr(x,y) ((x) >> (y)) #define I64_lsr(x,y) ((uint64)(x) >> (y)) #define I64_to_intnat(x) ((intnat) (x)) #define I64_of_intnat(x) ((intnat) (x)) #define I64_to_int32(x) ((int32) (x)) #define I64_of_int32(x) ((int64) (x)) #define I64_to_double(x) ((double)(x)) #define I64_of_double(x) ((int64)(x)) #endif /* CAML_INT64_NATIVE_H */ coq-8.4pl4/kernel/byterun/coq_interp.c0000644000175000017500000010561112326224777017116 0ustar stephsteph/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ /* The bytecode interpreter */ /* Spiwack: expanded the virtual machine with operators used for fast computation of bounded (31bits) integers */ #include #include #include "coq_gc.h" #include "coq_instruct.h" #include "coq_fix_code.h" #include "coq_memory.h" #include "coq_values.h" /*spiwack : imports support functions for 64-bit integers */ #include #ifdef ARCH_INT64_TYPE #include "int64_native.h" #else #include "int64_emul.h" #endif /* spiwack: I append here a few macros for value/number manipulation */ #define uint32_of_value(val) (((uint32)val >> 1)) #define value_of_uint32(i) ((value)(((uint32)(i) << 1) | 1)) #define UI64_of_uint32(lo) ((uint64)(I64_literal(0,(uint32)(lo)))) #define UI64_of_value(val) (UI64_of_uint32(uint32_of_value(val))) /* /spiwack */ /* Registers for the abstract machine: pc the code pointer sp the stack pointer (grows downward) accu the accumulator env heap-allocated environment trapsp pointer to the current trap frame extra_args number of extra arguments provided by the caller sp is a local copy of the global variable extern_sp. */ /* Instruction decoding */ #ifdef THREADED_CODE # define Instruct(name) coq_lbl_##name: # if defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) # define coq_Jumptbl_base ((char *) &&coq_lbl_ACC0) # else # define coq_Jumptbl_base ((char *) 0) # define coq_jumptbl_base ((char *) 0) # endif # ifdef DEBUG # define Next goto next_instr # else # define Next goto *(void *)(coq_jumptbl_base + *pc++) # endif #else # define Instruct(name) case name: # define Next break #endif /* #define _COQ_DEBUG_ */ #ifdef _COQ_DEBUG_ # define print_instr(s) /*if (drawinstr)*/ printf("%s\n",s) # define print_int(i) /*if (drawinstr)*/ printf("%d\n",i) # else # define print_instr(s) # define print_int(i) #endif /* GC interface */ #define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = coq_env; coq_sp = sp; } #define Restore_after_gc { accu = sp[0]; coq_env = sp[1]; sp += 2; } /* Register optimization. Some compilers underestimate the use of the local variables representing the abstract machine registers, and don't put them in hardware registers, which slows down the interpreter considerably. For GCC, Xavier Leroy have hand-assigned hardware registers for several architectures. */ #if defined(__GNUC__) && !defined(DEBUG) #ifdef __mips__ #define PC_REG asm("$16") #define SP_REG asm("$17") #define ACCU_REG asm("$18") #endif #ifdef __sparc__ #define PC_REG asm("%l0") #define SP_REG asm("%l1") #define ACCU_REG asm("%l2") #endif #ifdef __alpha__ #ifdef __CRAY__ #define PC_REG asm("r9") #define SP_REG asm("r10") #define ACCU_REG asm("r11") #define JUMPTBL_BASE_REG asm("r12") #else #define PC_REG asm("$9") #define SP_REG asm("$10") #define ACCU_REG asm("$11") #define JUMPTBL_BASE_REG asm("$12") #endif #endif #ifdef __i386__ #define PC_REG asm("%esi") #define SP_REG asm("%edi") #define ACCU_REG #endif #if defined(PPC) || defined(_POWER) || defined(_IBMR2) #define PC_REG asm("26") #define SP_REG asm("27") #define ACCU_REG asm("28") #endif #ifdef __hppa__ #define PC_REG asm("%r18") #define SP_REG asm("%r17") #define ACCU_REG asm("%r16") #endif #ifdef __mc68000__ #define PC_REG asm("a5") #define SP_REG asm("a4") #define ACCU_REG asm("d7") #endif #if defined(__arm__) && !defined(__thumb2__) #define PC_REG asm("r9") #define SP_REG asm("r8") #define ACCU_REG asm("r7") #endif #ifdef __ia64__ #define PC_REG asm("36") #define SP_REG asm("37") #define ACCU_REG asm("38") #define JUMPTBL_BASE_REG asm("39") #endif #endif /* For signal handling, we hijack some code from the caml runtime */ extern intnat caml_signals_are_pending; extern intnat caml_pending_signals[]; extern void caml_process_pending_signals(void); /* The interpreter itself */ value coq_interprete (code_t coq_pc, value coq_accu, value coq_env, long coq_extra_args) { /*Declaration des variables */ #ifdef PC_REG register code_t pc PC_REG; register value * sp SP_REG; register value accu ACCU_REG; #else register code_t pc; register value * sp; register value accu; #endif #if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) #ifdef JUMPTBL_BASE_REG register char * coq_jumptbl_base JUMPTBL_BASE_REG; #else register char * coq_jumptbl_base; #endif #endif #ifdef THREADED_CODE static void * coq_jumptable[] = { # include "coq_jumptbl.h" }; #else opcode_t curr_instr; #endif print_instr("Enter Interpreter"); if (coq_pc == NULL) { /* Interpreter is initializing */ print_instr("Interpreter is initializing"); #ifdef THREADED_CODE coq_instr_table = (char **) coq_jumptable; coq_instr_base = coq_Jumptbl_base; #endif return Val_unit; } #if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) coq_jumptbl_base = coq_Jumptbl_base; #endif /* Initialisation */ sp = coq_sp; pc = coq_pc; accu = coq_accu; #ifdef THREADED_CODE goto *(void *)(coq_jumptbl_base + *pc++); /* Jump to the first instruction */ #else while(1) { curr_instr = *pc++; switch(curr_instr) { #endif /* Basic stack operations */ Instruct(ACC0){ print_instr("ACC0"); accu = sp[0]; Next; } Instruct(ACC1){ print_instr("ACC1"); accu = sp[1]; Next; } Instruct(ACC2){ print_instr("ACC2"); accu = sp[2]; Next; } Instruct(ACC3){ print_instr("ACC3"); accu = sp[3]; Next; } Instruct(ACC4){ print_instr("ACC4"); accu = sp[4]; Next; } Instruct(ACC5){ print_instr("ACC5"); accu = sp[5]; Next; } Instruct(ACC6){ print_instr("ACC6"); accu = sp[6]; Next; } Instruct(ACC7){ print_instr("ACC7"); accu = sp[7]; Next; } Instruct(PUSH){ print_instr("PUSH"); *--sp = accu; Next; } Instruct(PUSHACC0) { print_instr("PUSHACC0"); *--sp = accu; Next; } Instruct(PUSHACC1){ print_instr("PUSHACC1"); *--sp = accu; accu = sp[1]; Next; } Instruct(PUSHACC2){ print_instr("PUSHACC2"); *--sp = accu; accu = sp[2]; Next; } Instruct(PUSHACC3){ print_instr("PUSHACC3"); *--sp = accu; accu = sp[3]; Next; } Instruct(PUSHACC4){ print_instr("PUSHACC4"); *--sp = accu; accu = sp[4]; Next; } Instruct(PUSHACC5){ print_instr("PUSHACC5"); *--sp = accu; accu = sp[5]; Next; } Instruct(PUSHACC6){ print_instr("PUSHACC5"); *--sp = accu; accu = sp[6]; Next; } Instruct(PUSHACC7){ print_instr("PUSHACC7"); *--sp = accu; accu = sp[7]; Next; } Instruct(PUSHACC){ print_instr("PUSHACC"); *--sp = accu; } /* Fallthrough */ Instruct(ACC){ print_instr("ACC"); accu = sp[*pc++]; Next; } Instruct(POP){ print_instr("POP"); sp += *pc++; Next; } /* Access in heap-allocated environment */ Instruct(ENVACC1){ print_instr("ENVACC1"); accu = Field(coq_env, 1); Next; } Instruct(ENVACC2){ print_instr("ENVACC2"); accu = Field(coq_env, 2); Next; } Instruct(ENVACC3){ print_instr("ENVACC3"); accu = Field(coq_env, 3); Next; } Instruct(ENVACC4){ print_instr("ENVACC4"); accu = Field(coq_env, 4); Next; } Instruct(PUSHENVACC1){ print_instr("PUSHENVACC1"); *--sp = accu; accu = Field(coq_env, 1); Next; } Instruct(PUSHENVACC2){ print_instr("PUSHENVACC2"); *--sp = accu; accu = Field(coq_env, 2); Next; } Instruct(PUSHENVACC3){ print_instr("PUSHENVACC3"); *--sp = accu; accu = Field(coq_env, 3); Next; } Instruct(PUSHENVACC4){ print_instr("PUSHENVACC4"); *--sp = accu; accu = Field(coq_env, 4); Next; } Instruct(PUSHENVACC){ print_instr("PUSHENVACC"); *--sp = accu; } /* Fallthrough */ Instruct(ENVACC){ print_instr("ENVACC"); accu = Field(coq_env, *pc++); Next; } /* Function application */ Instruct(PUSH_RETADDR) { print_instr("PUSH_RETADDR"); sp -= 3; sp[0] = (value) (pc + *pc); sp[1] = coq_env; sp[2] = Val_long(coq_extra_args); coq_extra_args = 0; pc++; Next; } Instruct(APPLY) { print_instr("APPLY"); coq_extra_args = *pc - 1; pc = Code_val(accu); coq_env = accu; goto check_stacks; } Instruct(APPLY1) { value arg1 = sp[0]; print_instr("APPLY1"); sp -= 3; sp[0] = arg1; sp[1] = (value)pc; sp[2] = coq_env; sp[3] = Val_long(coq_extra_args); pc = Code_val(accu); coq_env = accu; coq_extra_args = 0; goto check_stacks; } Instruct(APPLY2) { value arg1 = sp[0]; value arg2 = sp[1]; print_instr("APPLY2"); sp -= 3; sp[0] = arg1; sp[1] = arg2; sp[2] = (value)pc; sp[3] = coq_env; sp[4] = Val_long(coq_extra_args); pc = Code_val(accu); coq_env = accu; coq_extra_args = 1; goto check_stacks; } Instruct(APPLY3) { value arg1 = sp[0]; value arg2 = sp[1]; value arg3 = sp[2]; print_instr("APPLY3"); sp -= 3; sp[0] = arg1; sp[1] = arg2; sp[2] = arg3; sp[3] = (value)pc; sp[4] = coq_env; sp[5] = Val_long(coq_extra_args); pc = Code_val(accu); coq_env = accu; coq_extra_args = 2; goto check_stacks; } /* Stack checks */ check_stacks: print_instr("check_stacks"); if (sp < coq_stack_threshold) { coq_sp = sp; realloc_coq_stack(Coq_stack_threshold); sp = coq_sp; } /* We also check for signals */ if (caml_signals_are_pending) { /* If there's a Ctrl-C, we reset the vm */ if (caml_pending_signals[SIGINT]) { coq_sp = coq_stack_high; } caml_process_pending_signals(); } Next; Instruct(APPTERM) { int nargs = *pc++; int slotsize = *pc; value * newsp; int i; print_instr("APPTERM"); /* Slide the nargs bottom words of the current frame to the top of the frame, and discard the remainder of the frame */ newsp = sp + slotsize - nargs; for (i = nargs - 1; i >= 0; i--) newsp[i] = sp[i]; sp = newsp; pc = Code_val(accu); coq_env = accu; coq_extra_args += nargs - 1; goto check_stacks; } Instruct(APPTERM1) { value arg1 = sp[0]; print_instr("APPTERM1"); sp = sp + *pc - 1; sp[0] = arg1; pc = Code_val(accu); coq_env = accu; goto check_stacks; } Instruct(APPTERM2) { value arg1 = sp[0]; value arg2 = sp[1]; print_instr("APPTERM2"); sp = sp + *pc - 2; sp[0] = arg1; sp[1] = arg2; pc = Code_val(accu); coq_env = accu; coq_extra_args += 1; goto check_stacks; } Instruct(APPTERM3) { value arg1 = sp[0]; value arg2 = sp[1]; value arg3 = sp[2]; print_instr("APPTERM3"); sp = sp + *pc - 3; sp[0] = arg1; sp[1] = arg2; sp[2] = arg3; pc = Code_val(accu); coq_env = accu; coq_extra_args += 2; goto check_stacks; } Instruct(RETURN) { print_instr("RETURN"); print_int(*pc); sp += *pc++; if (coq_extra_args > 0) { coq_extra_args--; pc = Code_val(accu); coq_env = accu; } else { pc = (code_t)(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); sp += 3; } Next; } Instruct(RESTART) { int num_args = Wosize_val(coq_env) - 2; int i; print_instr("RESTART"); sp -= num_args; for (i = 0; i < num_args; i++) sp[i] = Field(coq_env, i + 2); coq_env = Field(coq_env, 1); coq_extra_args += num_args; Next; } Instruct(GRAB) { int required = *pc++; print_instr("GRAB"); /* printf("GRAB %d\n",required); */ if (coq_extra_args >= required) { coq_extra_args -= required; } else { mlsize_t num_args, i; num_args = 1 + coq_extra_args; /* arg1 + extra args */ Alloc_small(accu, num_args + 2, Closure_tag); Field(accu, 1) = coq_env; for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */ sp += num_args; pc = (code_t)(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); sp += 3; } Next; } Instruct(GRABREC) { int rec_pos = *pc++; /* commence a zero */ print_instr("GRABREC"); if (rec_pos <= coq_extra_args && !Is_accu(sp[rec_pos])) { pc++;/* On saute le Restart */ } else { if (coq_extra_args < rec_pos) { mlsize_t num_args, i; num_args = 1 + coq_extra_args; /* arg1 + extra args */ Alloc_small(accu, num_args + 2, Closure_tag); Field(accu, 1) = coq_env; for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; Code_val(accu) = pc - 3; sp += num_args; pc = (code_t)(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); sp += 3; } else { /* L'argument recursif est un accumulateur */ mlsize_t num_args, i; /* Construction du PF partiellement appliqué */ Alloc_small(accu, rec_pos + 2, Closure_tag); Field(accu, 1) = coq_env; for (i = 0; i < rec_pos; i++) Field(accu, i + 2) = sp[i]; Code_val(accu) = pc; sp += rec_pos; *--sp = accu; /* Construction de l'atom */ Alloc_small(accu, 2, ATOM_FIX_TAG); Field(accu,1) = sp[0]; Field(accu,0) = sp[1]; sp++; sp[0] = accu; /* Construction de l'accumulateur */ num_args = coq_extra_args - rec_pos; Alloc_small(accu, 2+num_args, Accu_tag); Code_val(accu) = accumulate; Field(accu,1) = sp[0]; sp++; for (i = 0; i < num_args;i++)Field(accu, i + 2) = sp[i]; sp += num_args; pc = (code_t)(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); sp += 3; } } Next; } Instruct(CLOSURE) { int nvars = *pc++; int i; print_instr("CLOSURE"); print_int(nvars); if (nvars > 0) *--sp = accu; Alloc_small(accu, 1 + nvars, Closure_tag); Code_val(accu) = pc + *pc; pc++; for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i]; sp += nvars; Next; } Instruct(CLOSUREREC) { int nfuncs = *pc++; int nvars = *pc++; int start = *pc++; int i; value * p; print_instr("CLOSUREREC"); if (nvars > 0) *--sp = accu; /* construction du vecteur de type */ Alloc_small(accu, nfuncs, 0); for(i = 0; i < nfuncs; i++) { Field(accu,i) = (value)(pc+pc[i]); } pc += nfuncs; *--sp=accu; Alloc_small(accu, nfuncs * 2 + nvars, Closure_tag); Field(accu, nfuncs * 2 + nvars - 1) = *sp++; /* On remplie la partie pour les variables libres */ p = &Field(accu, nfuncs * 2 - 1); for (i = 0; i < nvars; i++) { *p++ = *sp++; } p = &Field(accu, 0); *p = (value) (pc + pc[0]); p++; for (i = 1; i < nfuncs; i++) { *p = Make_header(i * 2, Infix_tag, Caml_white); p++; /* color irrelevant. */ *p = (value) (pc + pc[i]); p++; } pc += nfuncs; accu = accu + 2 * start * sizeof(value); Next; } Instruct(CLOSURECOFIX){ int nfunc = *pc++; int nvars = *pc++; int start = *pc++; int i, j , size; value * p; print_instr("CLOSURECOFIX"); if (nvars > 0) *--sp = accu; /* construction du vecteur de type */ Alloc_small(accu, nfunc, 0); for(i = 0; i < nfunc; i++) { Field(accu,i) = (value)(pc+pc[i]); } pc += nfunc; *--sp=accu; /* Creation des blocks accumulate */ for(i=0; i < nfunc; i++) { Alloc_small(accu, 2, Accu_tag); Code_val(accu) = accumulate; Field(accu,1) = Val_int(1); *--sp=accu; } /* creation des fonction cofix */ p = sp; size = nfunc + nvars + 2; for (i=0; i < nfunc; i++) { Alloc_small(accu, size, Closure_tag); Code_val(accu) = pc+pc[i]; for (j = 0; j < nfunc; j++) Field(accu, j+1) = p[j]; Field(accu, size - 1) = p[nfunc]; for (j = nfunc+1; j <= nfunc+nvars; j++) Field(accu, j) = p[j]; *--sp = accu; /* creation du block contenant le cofix */ Alloc_small(accu,1, ATOM_COFIX_TAG); Field(accu, 0) = sp[0]; *sp = accu; /* mise a jour du block accumulate */ caml_modify(&Field(p[i], 1),*sp); sp++; } pc += nfunc; accu = p[start]; sp = p + nfunc + 1 + nvars; print_instr("ici4"); Next; } Instruct(PUSHOFFSETCLOSURE) { print_instr("PUSHOFFSETCLOSURE"); *--sp = accu; } /* fallthrough */ Instruct(OFFSETCLOSURE) { print_instr("OFFSETCLOSURE"); accu = coq_env + *pc++ * sizeof(value); Next; } Instruct(PUSHOFFSETCLOSUREM2) { print_instr("PUSHOFFSETCLOSUREM2"); *--sp = accu; } /* fallthrough */ Instruct(OFFSETCLOSUREM2) { print_instr("OFFSETCLOSUREM2"); accu = coq_env - 2 * sizeof(value); Next; } Instruct(PUSHOFFSETCLOSURE0) { print_instr("PUSHOFFSETCLOSURE0"); *--sp = accu; }/* fallthrough */ Instruct(OFFSETCLOSURE0) { print_instr("OFFSETCLOSURE0"); accu = coq_env; Next; } Instruct(PUSHOFFSETCLOSURE2){ print_instr("PUSHOFFSETCLOSURE2"); *--sp = accu; /* fallthrough */ } Instruct(OFFSETCLOSURE2) { print_instr("OFFSETCLOSURE2"); accu = coq_env + 2 * sizeof(value); Next; } /* Access to global variables */ Instruct(PUSHGETGLOBAL) { print_instr("PUSH"); *--sp = accu; } /* Fallthrough */ Instruct(GETGLOBAL){ print_instr("GETGLOBAL"); accu = Field(coq_global_data, *pc); pc++; Next; } /* Allocation of blocks */ Instruct(MAKEBLOCK) { mlsize_t wosize = *pc++; tag_t tag = *pc++; mlsize_t i; value block; print_instr("MAKEBLOCK"); Alloc_small(block, wosize, tag); Field(block, 0) = accu; for (i = 1; i < wosize; i++) Field(block, i) = *sp++; accu = block; Next; } Instruct(MAKEBLOCK1) { tag_t tag = *pc++; value block; print_instr("MAKEBLOCK1"); Alloc_small(block, 1, tag); Field(block, 0) = accu; accu = block; Next; } Instruct(MAKEBLOCK2) { tag_t tag = *pc++; value block; print_instr("MAKEBLOCK2"); Alloc_small(block, 2, tag); Field(block, 0) = accu; Field(block, 1) = sp[0]; sp += 1; accu = block; Next; } Instruct(MAKEBLOCK3) { tag_t tag = *pc++; value block; print_instr("MAKEBLOCK3"); Alloc_small(block, 3, tag); Field(block, 0) = accu; Field(block, 1) = sp[0]; Field(block, 2) = sp[1]; sp += 2; accu = block; Next; } Instruct(MAKEBLOCK4) { tag_t tag = *pc++; value block; print_instr("MAKEBLOCK4"); Alloc_small(block, 4, tag); Field(block, 0) = accu; Field(block, 1) = sp[0]; Field(block, 2) = sp[1]; Field(block, 3) = sp[2]; sp += 3; accu = block; Next; } /* Access to components of blocks */ Instruct(SWITCH) { uint32 sizes = *pc++; print_instr("SWITCH"); print_int(sizes & 0xFFFF); if (Is_block(accu)) { long index = Tag_val(accu); print_instr("block"); print_int(index); pc += pc[(sizes & 0xFFFF) + index]; } else { long index = Long_val(accu); print_instr("constant"); print_int(index); pc += pc[index]; } Next; } Instruct(PUSHFIELDS){ int i; int size = *pc++; print_instr("PUSHFIELDS"); sp -= size; for(i=0;i p = 2v*w */ p = I64_mul (UI64_of_value (accu), UI64_of_uint32 ((*sp++)^1)); if ( I64_is_zero(p) ) { accu = (value)1; } else { /* the output type is supposed to have a constant constructor and a non-constant constructor (in that order), the tag of the non-constant constructor is then 1 */ Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ /*unsigned shift*/ Field(accu, 0) = (value)(I64_lsr(p,31)|1) ; /*higher part*/ Field(accu, 1) = (value)(I64_to_int32(p)|1); /*lower part*/ } Next; } Instruct (DIV21INT31) { print_instr("DIV21INT31"); /* spiwack: takes three int31 (the two first ones represent an int62) and performs the euclidian division of the int62 by the int31 */ uint64 bigint; bigint = UI64_of_value(accu); bigint = I64_or(I64_lsl(bigint, 31),UI64_of_value(*sp++)); uint64 divisor; divisor = UI64_of_value(*sp++); Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ if (I64_is_zero (divisor)) { Field(accu, 0) = 1; /* 2*0+1 */ Field(accu, 1) = 1; /* 2*0+1 */ } else { uint64 quo, mod; I64_udivmod(bigint, divisor, &quo, &mod); Field(accu, 0) = value_of_uint32(I64_to_int32(quo)); Field(accu, 1) = value_of_uint32(I64_to_int32(mod)); } Next; } Instruct (DIVINT31) { print_instr("DIVINT31"); /* spiwack: a priori no need of the NON_STANDARD_DIV_MOD flag since it probably only concerns negative number. needs to be checked at this point */ uint32 divisor; divisor = uint32_of_value(*sp++); if (divisor == 0) { Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ Field(accu, 0) = 1; /* 2*0+1 */ Field(accu, 1) = 1; /* 2*0+1 */ } else { uint32 modulus; modulus = uint32_of_value(accu); Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ Field(accu, 0) = value_of_uint32(modulus/divisor); Field(accu, 1) = value_of_uint32(modulus%divisor); } Next; } Instruct (ADDMULDIVINT31) { print_instr("ADDMULDIVINT31"); /* higher level shift (does shifts and cycles and such) */ uint32 shiftby; shiftby = uint32_of_value(accu); if (shiftby > 31) { if (shiftby < 62) { *sp++; accu = (value)((((*sp++)^1) << (shiftby - 31)) | 1); } else { accu = (value)(1); } } else{ /* *sp = 2*x+1 --> accu = 2^(shiftby+1)*x */ accu = (value)(((*sp++)^1) << shiftby); /* accu = 2^(shiftby+1)*x --> 2^(shifby+1)*x+2*y/2^(31-shiftby)+1 */ accu = (value)((accu | (((uint32)(*sp++)) >> (31-shiftby)))|1); } Next; } Instruct (COMPAREINT31) { /* returns Eq if equal, Lt if accu is less than *sp, Gt otherwise */ /* assumes Inudctive _ : _ := Eq | Lt | Gt */ print_instr("COMPAREINT31"); if ((uint32)accu == (uint32)*sp) { accu = 1; /* 2*0+1 */ sp++; } else{if ((uint32)accu < (uint32)(*sp++)) { accu = 3; /* 2*1+1 */ } else{ accu = 5; /* 2*2+1 */ }} Next; } Instruct (HEAD0INT31) { int r = 0; uint32 x; print_instr("HEAD0INT31"); x = (uint32) accu; if (!(x & 0xFFFF0000)) { x <<= 16; r += 16; } if (!(x & 0xFF000000)) { x <<= 8; r += 8; } if (!(x & 0xF0000000)) { x <<= 4; r += 4; } if (!(x & 0xC0000000)) { x <<= 2; r += 2; } if (!(x & 0x80000000)) { x <<=1; r += 1; } if (!(x & 0x80000000)) { r += 1; } accu = value_of_uint32(r); Next; } Instruct (TAIL0INT31) { int r = 0; uint32 x; print_instr("TAIL0INT31"); x = (((uint32) accu >> 1) | 0x80000000); if (!(x & 0xFFFF)) { x >>= 16; r += 16; } if (!(x & 0x00FF)) { x >>= 8; r += 8; } if (!(x & 0x000F)) { x >>= 4; r += 4; } if (!(x & 0x0003)) { x >>= 2; r += 2; } if (!(x & 0x0001)) { x >>=1; r += 1; } if (!(x & 0x0001)) { r += 1; } accu = value_of_uint32(r); Next; } Instruct (ISCONST) { /* Branches if the accu does not contain a constant (i.e., a non-block value) */ print_instr("ISCONST"); if ((accu & 1) == 0) /* last bit is 0 -> it is a block */ pc += *pc; else pc++; Next; } Instruct (ARECONST) { /* Branches if the n first values on the stack are not all constansts */ print_instr("ARECONST"); int i, n, ok; ok = 1; n = *pc++; for(i=0; i < n; i++) { if ((sp[i] & 1) == 0) { ok = 0; break; } } if(ok) pc++; else pc += *pc; Next; } Instruct (COMPINT31) { /* makes an 31-bit integer out of the accumulator and the 30 first values of the stack and put it in the accumulator (the accumulator then the topmost get to be the heavier bits) */ print_instr("COMPINT31"); int i; /*accu=accu or accu = (value)((unsigned long)1-accu) if bool is used for the bits */ for(i=0; i < 30; i++) { accu = (value) ((((uint32)accu-1) << 1) | *sp++); /* -1 removes the tag bit, << 1 multiplies the value by 2, | *sp++ pops the last value and add it (no carry involved) not that it reintroduces a tag bit */ /* alternative, if bool is used for the bits : accu = (value) ((((unsigned long)accu) << 1) & !*sp++); */ } Next; } Instruct (DECOMPINT31) { /* builds a block out of a 31-bit integer (from the accumulator), used before cases */ int i; value block; print_instr("DECOMPINT31"); Alloc_small(block, 31, 1); // Alloc_small(*, size, tag) for(i = 30; i >= 0; i--) { Field(block, i) = (value)(accu & 3); /* two last bits of the accumulator */ //Field(block, i) = 3; accu = (value) ((uint32)accu >> 1) | 1; /* last bit must be a one */ }; accu = block; Next; } /* /spiwack */ /* Debugging and machine control */ Instruct(STOP){ print_instr("STOP"); coq_sp = sp; return accu; } #ifndef THREADED_CODE default: /*fprintf(stderr, "%d\n", *pc);*/ failwith("Coq VM: Fatal error: bad opcode"); } } #endif } value coq_push_ra(value tcode) { print_instr("push_ra"); coq_sp -= 3; coq_sp[0] = (value) tcode; coq_sp[1] = Val_unit; coq_sp[2] = Val_long(0); return Val_unit; } value coq_push_val(value v) { print_instr("push_val"); *--coq_sp = v; return Val_unit; } value coq_push_arguments(value args) { int nargs,i; nargs = Wosize_val(args) - 2; coq_sp -= nargs; print_instr("push_args");print_int(nargs); for(i = 0; i < nargs; i++) coq_sp[i] = Field(args, i+2); return Val_unit; } value coq_push_vstack(value stk) { int len,i; len = Wosize_val(stk); coq_sp -= len; print_instr("push_vstack");print_int(len); for(i = 0; i < len; i++) coq_sp[i] = Field(stk,i); return Val_unit; } value coq_interprete_ml(value tcode, value a, value e, value ea) { print_instr("coq_interprete"); return coq_interprete((code_t)tcode, a, e, Long_val(ea)); print_instr("end coq_interprete"); } value coq_eval_tcode (value tcode, value e) { return coq_interprete_ml(tcode, Val_unit, e, 0); } coq-8.4pl4/kernel/byterun/coq_memory.c0000644000175000017500000001556712326224777017137 0ustar stephsteph/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ #include #include #include "coq_gc.h" #include "coq_instruct.h" #include "coq_fix_code.h" #include "coq_memory.h" #include "coq_interp.h" /* stack */ value * coq_stack_low; value * coq_stack_high; value * coq_stack_threshold; asize_t coq_max_stack_size = Coq_max_stack_size; /* global_data */ value coq_global_data; value coq_global_boxed; int coq_all_transp; value coq_atom_tbl; int drawinstr; /* interp state */ long coq_saved_sp_offset; value * coq_sp; /* Some predefined pointer code */ code_t accumulate; /* functions over global environment */ void coq_stat_free (void * blk) { free (blk); } value coq_static_alloc(value size) /* ML */ { return (value) coq_stat_alloc((asize_t) Long_val(size)); } value accumulate_code(value unit) /* ML */ { return (value) accumulate; } static void (*coq_prev_scan_roots_hook) (scanning_action); static void coq_scan_roots(scanning_action action) { register value * i; /* Scan the global variables */ (*action)(coq_global_data, &coq_global_data); (*action)(coq_global_boxed, &coq_global_boxed); (*action)(coq_atom_tbl, &coq_atom_tbl); /* Scan the stack */ for (i = coq_sp; i < coq_stack_high; i++) { (*action) (*i, i); }; /* Hook */ if (coq_prev_scan_roots_hook != NULL) (*coq_prev_scan_roots_hook)(action); } void init_coq_stack() { coq_stack_low = (value *) coq_stat_alloc(Coq_stack_size); coq_stack_high = coq_stack_low + Coq_stack_size / sizeof (value); coq_stack_threshold = coq_stack_low + Coq_stack_threshold / sizeof(value); coq_max_stack_size = Coq_max_stack_size; } void init_coq_global_data(long requested_size) { int i; coq_global_data = alloc_shr(requested_size, 0); for (i = 0; i < requested_size; i++) Field (coq_global_data, i) = Val_unit; } void init_coq_global_boxed(long requested_size) { int i; coq_global_boxed = alloc_shr(requested_size, 0); for (i = 0; i < requested_size; i++) Field (coq_global_boxed, i) = Val_true; } void init_coq_atom_tbl(long requested_size){ int i; coq_atom_tbl = alloc_shr(requested_size, 0); for (i = 0; i < requested_size; i++) Field (coq_atom_tbl, i) = Val_unit; } void init_coq_interpreter() { coq_sp = coq_stack_high; coq_interprete(NULL, Val_unit, Val_unit, 0); } static int coq_vm_initialized = 0; value init_coq_vm(value unit) /* ML */ { int i; if (coq_vm_initialized == 1) { fprintf(stderr,"already open \n");fflush(stderr);} else { drawinstr=0; #ifdef THREADED_CODE init_arity(); #endif /* THREADED_CODE */ /* Allocate the table of global and the stack */ init_coq_stack(); init_coq_global_data(Coq_global_data_Size); init_coq_global_boxed(40); init_coq_atom_tbl(40); /* Initialing the interpreter */ coq_all_transp = 0; init_coq_interpreter(); /* Some predefined pointer code */ accumulate = (code_t) coq_stat_alloc(sizeof(opcode_t)); *accumulate = VALINSTR(ACCUMULATE); /* Initialize GC */ if (coq_prev_scan_roots_hook == NULL) coq_prev_scan_roots_hook = scan_roots_hook; scan_roots_hook = coq_scan_roots; coq_vm_initialized = 1; } return Val_unit;; } void realloc_coq_stack(asize_t required_space) { asize_t size; value * new_low, * new_high, * new_sp; value * p; size = coq_stack_high - coq_stack_low; do { size *= 2; } while (size < coq_stack_high - coq_sp + required_space); new_low = (value *) coq_stat_alloc(size * sizeof(value)); new_high = new_low + size; #define shift(ptr) \ ((char *) new_high - ((char *) coq_stack_high - (char *) (ptr))) new_sp = (value *) shift(coq_sp); memmove((char *) new_sp, (char *) coq_sp, (coq_stack_high - coq_sp) * sizeof(value)); coq_stat_free(coq_stack_low); coq_stack_low = new_low; coq_stack_high = new_high; coq_stack_threshold = coq_stack_low + Coq_stack_threshold / sizeof(value); coq_sp = new_sp; #undef shift } value get_coq_global_data(value unit) /* ML */ { return coq_global_data; } value get_coq_atom_tbl(value unit) /* ML */ { return coq_atom_tbl; } value get_coq_global_boxed(value unit) /* ML */ { return coq_global_boxed; } value realloc_coq_global_data(value size) /* ML */ { mlsize_t requested_size, actual_size, i; value new_global_data; requested_size = Long_val(size); actual_size = Wosize_val(coq_global_data); if (requested_size >= actual_size) { requested_size = (requested_size + 0x100) & 0xFFFFFF00; new_global_data = alloc_shr(requested_size, 0); for (i = 0; i < actual_size; i++) initialize(&Field(new_global_data, i), Field(coq_global_data, i)); for (i = actual_size; i < requested_size; i++){ Field (new_global_data, i) = Val_long (0); } coq_global_data = new_global_data; } return Val_unit; } value realloc_coq_global_boxed(value size) /* ML */ { mlsize_t requested_size, actual_size, i; value new_global_boxed; requested_size = Long_val(size); actual_size = Wosize_val(coq_global_boxed); if (requested_size >= actual_size) { requested_size = (requested_size + 0x100) & 0xFFFFFF00; new_global_boxed = alloc_shr(requested_size, 0); for (i = 0; i < actual_size; i++) initialize(&Field(new_global_boxed, i), Field(coq_global_boxed, i)); for (i = actual_size; i < requested_size; i++) Field (new_global_boxed, i) = Val_long (0); coq_global_boxed = new_global_boxed; } return Val_unit; } value realloc_coq_atom_tbl(value size) /* ML */ { mlsize_t requested_size, actual_size, i; value new_atom_tbl; requested_size = Long_val(size); actual_size = Wosize_val(coq_atom_tbl); if (requested_size >= actual_size) { requested_size = (requested_size + 0x100) & 0xFFFFFF00; new_atom_tbl = alloc_shr(requested_size, 0); for (i = 0; i < actual_size; i++) initialize(&Field(new_atom_tbl, i), Field(coq_atom_tbl, i)); for (i = actual_size; i < requested_size; i++) Field (new_atom_tbl, i) = Val_long (0); coq_atom_tbl = new_atom_tbl; } return Val_unit; } value coq_set_transp_value(value transp) { coq_all_transp = (transp == Val_true); return Val_unit; } value get_coq_transp_value(value unit) { return Val_bool(coq_all_transp); } value coq_set_drawinstr(value unit) { drawinstr = 1; return Val_unit; } coq-8.4pl4/kernel/byterun/coq_fix_code.h0000644000175000017500000000241312326224777017376 0ustar stephsteph/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ #ifndef _COQ_FIX_CODE_ #define _COQ_FIX_CODE_ #include void * coq_stat_alloc (asize_t sz); #ifdef THREADED_CODE extern char ** coq_instr_table; extern char * coq_instr_base; void init_arity(); #define VALINSTR(instr) ((opcode_t)(coq_instr_table[instr] - coq_instr_base)) #else #define VALINSTR(instr) instr #endif /* THREADED_CODE */ #define Is_instruction(pc,instr) (*pc == VALINSTR(instr)) value coq_tcode_of_code(value code, value len); value coq_makeaccu (value i); value coq_pushpop (value i); value coq_accucond (value i); value coq_is_accumulate_code(value code); #endif /* _COQ_FIX_CODE_ */ coq-8.4pl4/kernel/byterun/coq_values.c0000644000175000017500000000407512326224777017116 0ustar stephsteph/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ #include #include "coq_fix_code.h" #include "coq_instruct.h" #include "coq_memory.h" #include "coq_values.h" #include /* KIND OF VALUES */ #define Setup_for_gc #define Restore_after_gc value coq_kind_of_closure(value v) { opcode_t * c; int res; int is_app = 0; c = Code_val(v); if (Is_instruction(c, GRAB)) return Val_int(0); if (Is_instruction(c, RESTART)) {is_app = 1; c++;} if (Is_instruction(c, GRABREC)) return Val_int(1+is_app); if (Is_instruction(c, MAKEACCU)) return Val_int(3); return Val_int(0); } /* DESTRUCT ACCU */ value coq_closure_arity(value clos) { opcode_t * c = Code_val(clos); if (Is_instruction(c,RESTART)) { c++; if (Is_instruction(c,GRAB)) return Val_int(3 + c[1] - Wosize_val(clos)); else { if (Wosize_val(clos) != 2) failwith("Coq Values : coq_closure_arity"); return Val_int(1); } } if (Is_instruction(c,GRAB)) return Val_int(1 + c[1]); return Val_int(1); } /* Fonction sur les fix */ value coq_offset(value v) { if (Tag_val(v) == Closure_tag) return Val_int(0); else return Val_long(-Wsize_bsize(Infix_offset_val(v))); } value coq_offset_closure(value v, value offset){ return (value)&Field(v, Int_val(offset)); } value coq_offset_tcode(value code,value offset){ return((value)((code_t)code + Int_val(offset))); } value coq_int_tcode(value code, value offset) { return Val_int(*((code_t) code + Int_val(offset))); } coq-8.4pl4/kernel/byterun/libcoqrun.clib0000644000175000017500000000006612326224777017436 0ustar stephstephcoq_fix_code.o coq_memory.o coq_values.o coq_interp.o coq-8.4pl4/kernel/byterun/coq_interp.h0000644000175000017500000000176712326224777017132 0ustar stephsteph/***********************************************************************/ /* */ /* Coq Compiler */ /* */ /* Benjamin Gregoire, projets Logical and Cristal */ /* INRIA Rocquencourt */ /* */ /* */ /***********************************************************************/ value coq_push_ra(value tcode); value coq_push_val(value v); value coq_push_arguments(value args); value coq_push_vstack(value stk); value coq_interprete_ml(value tcode, value a, value e, value ea); value coq_interprete (code_t coq_pc, value coq_accu, value coq_env, long coq_extra_args); value coq_eval_tcode (value tcode, value e); coq-8.4pl4/kernel/entries.ml0000644000175000017500000000531012326224777015115 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* make_polymorphic_if_constant_for_ind env j, cst1 | Some t -> let (tj,cst2) = infer_type env t in let (_,cst3) = judge_of_cast env j DEFAULTcast tj in assert (eq_constr t tj.utj_val); let cstrs = union_constraints (union_constraints cst1 cst2) cst3 in NonPolymorphicType t, cstrs let local_constrain_type env j cst1 = function | None -> j.uj_type, cst1 | Some t -> let (tj,cst2) = infer_type env t in let (_,cst3) = judge_of_cast env j DEFAULTcast tj in assert (eq_constr t tj.utj_val); t, union_constraints (union_constraints cst1 cst2) cst3 let translate_local_def env (b,topt) = let (j,cst) = infer env b in let (typ,cst) = local_constrain_type env j cst topt in (j.uj_val,typ,cst) let translate_local_assum env t = let (j,cst) = infer env t in let t = Typeops.assumption_of_judgment env j in (t,cst) (* (* Same as push_named, but check that the variable is not already there. Should *not* be done in Environ because tactics add temporary hypothesis many many times, and the check performed here would cost too much. *) let safe_push_named (id,_,_ as d) env = let _ = try let _ = lookup_named id env in error ("Identifier "^string_of_id id^" already defined.") with Not_found -> () in push_named d env let push_named_def = push_rel_or_named_def safe_push_named let push_rel_def = push_rel_or_named_def push_rel let push_rel_or_named_assum push (id,t) env = let (j,cst) = safe_infer env t in let t = Typeops.assumption_of_judgment env j in let env' = add_constraints cst env in let env'' = push (id,None,t) env' in (cst,env'') let push_named_assum = push_rel_or_named_assum push_named let push_rel_assum d env = snd (push_rel_or_named_assum push_rel d env) let push_rels_with_univ vars env = List.fold_left (fun env nvar -> push_rel_assum nvar env) env vars *) (* Insertion of constants and parameters in environment. *) let infer_declaration env dcl = match dcl with | DefinitionEntry c -> let (j,cst) = infer env c.const_entry_body in let j = {uj_val = hcons_constr j.uj_val; uj_type = hcons_constr j.uj_type} in let (typ,cst) = constrain_type env j cst c.const_entry_type in let def = if c.const_entry_opaque then OpaqueDef (Declarations.opaque_from_val j.uj_val) else Def (Declarations.from_val j.uj_val) in def, typ, cst, c.const_entry_secctx | ParameterEntry (ctx,t,nl) -> let (j,cst) = infer env t in let t = hcons_constr (Typeops.assumption_of_judgment env j) in Undef nl, NonPolymorphicType t, cst, ctx let global_vars_set_constant_type env = function | NonPolymorphicType t -> global_vars_set env t | PolymorphicArity (ctx,_) -> Sign.fold_rel_context (fold_rel_declaration (fun t c -> Idset.union (global_vars_set env t) c)) ctx ~init:Idset.empty let build_constant_declaration env kn (def,typ,cst,ctx) = let hyps = let inferred = let ids_typ = global_vars_set_constant_type env typ in let ids_def = match def with | Undef _ -> Idset.empty | Def cs -> global_vars_set env (Declarations.force cs) | OpaqueDef lc -> global_vars_set env (Declarations.force_opaque lc) in keep_hyps env (Idset.union ids_typ ids_def) in let declared = match ctx with | None -> inferred | Some declared -> declared in let mk_set l = List.fold_right Idset.add (List.map pi1 l) Idset.empty in let inferred_set, declared_set = mk_set inferred, mk_set declared in if not (Idset.subset inferred_set declared_set) then error ("The following section variable are used but not declared:\n"^ (String.concat ", " (List.map string_of_id (Idset.elements (Idset.diff inferred_set declared_set))))); declared in let tps = Cemitcodes.from_val (compile_constant_body env def) in { const_hyps = hyps; const_body = def; const_type = typ; const_body_code = tps; const_constraints = cst } (*s Global and local constant declaration. *) let translate_constant env kn ce = build_constant_declaration env kn (infer_declaration env ce) let translate_recipe env kn r = build_constant_declaration env kn (let def,typ,cst,hyps = Cooking.cook_constant env r in def,typ,cst,Some hyps) (* Insertion of inductive types. *) let translate_mind env kn mie = check_inductive env kn mie coq-8.4pl4/kernel/environ.mli0000644000175000017500000001730712326224777015306 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Pre_env.env val env_of_pre_env : Pre_env.env -> env type named_context_val val eq_named_context_val : named_context_val -> named_context_val -> bool val empty_env : env val universes : env -> Univ.universes val rel_context : env -> rel_context val named_context : env -> named_context val named_context_val : env -> named_context_val val engagement : env -> engagement option (** is the local context empty *) val empty_context : env -> bool (** {5 Context of de Bruijn variables ([rel_context]) } *) val nb_rel : env -> int val push_rel : rel_declaration -> env -> env val push_rel_context : rel_context -> env -> env val push_rec_types : rec_declaration -> env -> env (** Looks up in the context of local vars referred by indice ([rel_context]) raises [Not_found] if the index points out of the context *) val lookup_rel : int -> env -> rel_declaration val evaluable_rel : int -> env -> bool (** {6 Recurrence on [rel_context] } *) val fold_rel_context : (env -> rel_declaration -> 'a -> 'a) -> env -> init:'a -> 'a (** {5 Context of variables (section variables and goal assumptions) } *) val named_context_of_val : named_context_val -> named_context val named_vals_of_val : named_context_val -> Pre_env.named_vals val val_of_named_context : named_context -> named_context_val val empty_named_context_val : named_context_val (** [map_named_val f ctxt] apply [f] to the body and the type of each declarations. *** /!\ *** [f t] should be convertible with t *) val map_named_val : (constr -> constr) -> named_context_val -> named_context_val val push_named : named_declaration -> env -> env val push_named_context_val : named_declaration -> named_context_val -> named_context_val (** Looks up in the context of local vars referred by names ([named_context]) raises [Not_found] if the identifier is not found *) val lookup_named : variable -> env -> named_declaration val lookup_named_val : variable -> named_context_val -> named_declaration val evaluable_named : variable -> env -> bool val named_type : variable -> env -> types val named_body : variable -> env -> constr option (** {6 Recurrence on [named_context]: older declarations processed first } *) val fold_named_context : (env -> named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a (** Recurrence on [named_context] starting from younger decl *) val fold_named_context_reverse : ('a -> named_declaration -> 'a) -> init:'a -> env -> 'a (** This forgets named and rel contexts *) val reset_context : env -> env (** This forgets rel context and sets a new named context *) val reset_with_named_context : named_context_val -> env -> env (** {5 Global constants } {6 Add entries to global environment } *) val add_constant : constant -> constant_body -> env -> env (** Looks up in the context of global constant names raises [Not_found] if the required path is not found *) val lookup_constant : constant -> env -> constant_body val evaluable_constant : constant -> env -> bool (** {6 ... } *) (** [constant_value env c] raises [NotEvaluableConst Opaque] if [c] is opaque and [NotEvaluableConst NoBody] if it has no body and [Not_found] if it does not exist in [env] *) type const_evaluation_result = NoBody | Opaque exception NotEvaluableConst of const_evaluation_result val constant_value : env -> constant -> constr val constant_type : env -> constant -> constant_type val constant_opt_value : env -> constant -> constr option (** {5 Inductive types } *) val add_mind : mutual_inductive -> mutual_inductive_body -> env -> env (** Looks up in the context of global inductive names raises [Not_found] if the required path is not found *) val lookup_mind : mutual_inductive -> env -> mutual_inductive_body (** {5 Modules } *) val add_modtype : module_path -> module_type_body -> env -> env (** [shallow_add_module] does not add module components *) val shallow_add_module : module_path -> module_body -> env -> env val lookup_module : module_path -> env -> module_body val lookup_modtype : module_path -> env -> module_type_body (** {5 Universe constraints } *) val add_constraints : Univ.constraints -> env -> env val set_engagement : engagement -> env -> env (** {6 Sets of referred section variables } [global_vars_set env c] returns the list of [id]'s occurring either directly as [Var id] in [c] or indirectly as a section variable dependent in a global reference occurring in [c] *) val global_vars_set : env -> constr -> Idset.t (** the constr must be a global reference *) val vars_of_global : env -> constr -> identifier list val keep_hyps : env -> Idset.t -> section_context (** {5 Unsafe judgments. } We introduce here the pre-type of judgments, which is actually only a datatype to store a term with its type and the type of its type. *) type unsafe_judgment = { uj_val : constr; uj_type : types } val make_judge : constr -> types -> unsafe_judgment val j_val : unsafe_judgment -> constr val j_type : unsafe_judgment -> types type unsafe_type_judgment = { utj_val : constr; utj_type : sorts } (** {6 Compilation of global declaration } *) val compile_constant_body : env -> constant_def -> Cemitcodes.body_code exception Hyp_not_found (** [apply_to_hyp sign id f] split [sign] into [tail::(id,_,_)::head] and return [tail::(f head (id,_,_) (rev tail))::head]. the value associated to id should not change *) val apply_to_hyp : named_context_val -> variable -> (named_context -> named_declaration -> named_context -> named_declaration) -> named_context_val (** [apply_to_hyp_and_dependent_on sign id f g] split [sign] into [tail::(id,_,_)::head] and return [(g tail)::(f (id,_,_))::head]. *) val apply_to_hyp_and_dependent_on : named_context_val -> variable -> (named_declaration -> named_context_val -> named_declaration) -> (named_declaration -> named_context_val -> named_declaration) -> named_context_val val insert_after_hyp : named_context_val -> variable -> named_declaration -> (named_context -> unit) -> named_context_val val remove_hyps : identifier list -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val open Retroknowledge (** functions manipulating the retroknowledge @author spiwack *) val retroknowledge : (retroknowledge->'a) -> env -> 'a val registered : env -> field -> bool val unregister : env -> field -> env val register : env -> field -> Retroknowledge.entry -> env coq-8.4pl4/kernel/cemitcodes.ml0000644000175000017500000002711112326224777015566 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* = String.length !out_buffer then begin let len = String.length !out_buffer in let new_buffer = String.create (2 * len) in String.blit !out_buffer 0 new_buffer 0 len; out_buffer := new_buffer end; String.unsafe_set !out_buffer p (Char.unsafe_chr b1); String.unsafe_set !out_buffer (p+1) (Char.unsafe_chr b2); String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3); String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4); out_position := p + 4 *) let out_word b1 b2 b3 b4 = let p = !out_position in if p >= String.length !out_buffer then begin let len = String.length !out_buffer in let new_len = if len <= Sys.max_string_length / 2 then 2 * len else if len = Sys.max_string_length then raise (Invalid_argument "String.create") (* Pas la bonne execption .... *) else Sys.max_string_length in let new_buffer = String.create new_len in String.blit !out_buffer 0 new_buffer 0 len; out_buffer := new_buffer end; String.unsafe_set !out_buffer p (Char.unsafe_chr b1); String.unsafe_set !out_buffer (p+1) (Char.unsafe_chr b2); String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3); String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4); out_position := p + 4 let out opcode = out_word opcode 0 0 0 let out_int n = out_word n (n asr 8) (n asr 16) (n asr 24) (* Handling of local labels and backpatching *) type label_definition = Label_defined of int | Label_undefined of (int * int) list let label_table = ref ([| |] : label_definition array) (* le ieme element de la table = Label_defined n signifie que l'on a deja rencontrer le label i et qu'il est a l'offset n. = Label_undefined l signifie que l'on a pas encore rencontrer ce label, le premier entier indique ou est l'entier a patcher dans la string, le deuxieme son origine *) let extend_label_table needed = let new_size = ref(Array.length !label_table) in while needed >= !new_size do new_size := 2 * !new_size done; let new_table = Array.create !new_size (Label_undefined []) in Array.blit !label_table 0 new_table 0 (Array.length !label_table); label_table := new_table let backpatch (pos, orig) = let displ = (!out_position - orig) asr 2 in !out_buffer.[pos] <- Char.unsafe_chr displ; !out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8); !out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16); !out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24) let define_label lbl = if lbl >= Array.length !label_table then extend_label_table lbl; match (!label_table).(lbl) with Label_defined _ -> raise(Failure "CEmitcode.define_label") | Label_undefined patchlist -> List.iter backpatch patchlist; (!label_table).(lbl) <- Label_defined !out_position let out_label_with_orig orig lbl = if lbl >= Array.length !label_table then extend_label_table lbl; match (!label_table).(lbl) with Label_defined def -> out_int((def - orig) asr 2) | Label_undefined patchlist -> (* spiwack: patchlist is supposed to be non-empty all the time thus I commented that out. If there is no problem I suggest removing it for next release (cur: 8.1) *) (*if patchlist = [] then *) (!label_table).(lbl) <- Label_undefined((!out_position, orig) :: patchlist); out_int 0 let out_label l = out_label_with_orig !out_position l (* Relocation information *) let reloc_info = ref ([] : (reloc_info * int) list) let enter info = reloc_info := (info, !out_position) :: !reloc_info let slot_for_const c = enter (Reloc_const c); out_int 0 and slot_for_annot a = enter (Reloc_annot a); out_int 0 and slot_for_getglobal id = enter (Reloc_getglobal id); out_int 0 (* Emission of one instruction *) let emit_instr = function | Klabel lbl -> define_label lbl | Kacc n -> if n < 8 then out(opACC0 + n) else (out opACC; out_int n) | Kenvacc n -> if n >= 1 && n <= 4 then out(opENVACC1 + n - 1) else (out opENVACC; out_int n) | Koffsetclosure ofs -> if ofs = -2 || ofs = 0 || ofs = 2 then out (opOFFSETCLOSURE0 + ofs / 2) else (out opOFFSETCLOSURE; out_int ofs) | Kpush -> out opPUSH | Kpop n -> out opPOP; out_int n | Kpush_retaddr lbl -> out opPUSH_RETADDR; out_label lbl | Kapply n -> if n < 4 then out(opAPPLY1 + n - 1) else (out opAPPLY; out_int n) | Kappterm(n, sz) -> if n < 4 then (out(opAPPTERM1 + n - 1); out_int sz) else (out opAPPTERM; out_int n; out_int sz) | Kreturn n -> out opRETURN; out_int n | Kjump -> out opRETURN; out_int 0 | Krestart -> out opRESTART | Kgrab n -> out opGRAB; out_int n | Kgrabrec(rec_arg) -> out opGRABREC; out_int rec_arg | Kclosure(lbl, n) -> out opCLOSURE; out_int n; out_label lbl | Kclosurerec(nfv,init,lbl_types,lbl_bodies) -> out opCLOSUREREC;out_int (Array.length lbl_bodies); out_int nfv; out_int init; let org = !out_position in Array.iter (out_label_with_orig org) lbl_types; let org = !out_position in Array.iter (out_label_with_orig org) lbl_bodies | Kclosurecofix(nfv,init,lbl_types,lbl_bodies) -> out opCLOSURECOFIX;out_int (Array.length lbl_bodies); out_int nfv; out_int init; let org = !out_position in Array.iter (out_label_with_orig org) lbl_types; let org = !out_position in Array.iter (out_label_with_orig org) lbl_bodies | Kgetglobal q -> out opGETGLOBAL; slot_for_getglobal q | Kconst((Const_b0 i)) -> if i >= 0 && i <= 3 then out (opCONST0 + i) else (out opCONSTINT; out_int i) | Kconst c -> out opGETGLOBAL; slot_for_const c | Kmakeblock(n, t) -> if n = 0 then raise (Invalid_argument "emit_instr : block size = 0") else if n < 4 then (out(opMAKEBLOCK1 + n - 1); out_int t) else (out opMAKEBLOCK; out_int n; out_int t) | Kmakeprod -> out opMAKEPROD | Kmakeswitchblock(typlbl,swlbl,annot,sz) -> out opMAKESWITCHBLOCK; out_label typlbl; out_label swlbl; slot_for_annot annot;out_int sz | Kswitch (tbl_const, tbl_block) -> out opSWITCH; out_int (Array.length tbl_const + (Array.length tbl_block lsl 16)); let org = !out_position in Array.iter (out_label_with_orig org) tbl_const; Array.iter (out_label_with_orig org) tbl_block | Kpushfields n -> out opPUSHFIELDS;out_int n | Kfield n -> if n <= 1 then out (opGETFIELD0+n) else (out opGETFIELD;out_int n) | Ksetfield n -> if n <= 1 then out (opSETFIELD0+n) else (out opSETFIELD;out_int n) | Ksequence _ -> raise (Invalid_argument "Cemitcodes.emit_instr") (* spiwack *) | Kbranch lbl -> out opBRANCH; out_label lbl | Kaddint31 -> out opADDINT31 | Kaddcint31 -> out opADDCINT31 | Kaddcarrycint31 -> out opADDCARRYCINT31 | Ksubint31 -> out opSUBINT31 | Ksubcint31 -> out opSUBCINT31 | Ksubcarrycint31 -> out opSUBCARRYCINT31 | Kmulint31 -> out opMULINT31 | Kmulcint31 -> out opMULCINT31 | Kdiv21int31 -> out opDIV21INT31 | Kdivint31 -> out opDIVINT31 | Kaddmuldivint31 -> out opADDMULDIVINT31 | Kcompareint31 -> out opCOMPAREINT31 | Khead0int31 -> out opHEAD0INT31 | Ktail0int31 -> out opTAIL0INT31 | Kisconst lbl -> out opISCONST; out_label lbl | Kareconst(n,lbl) -> out opARECONST; out_int n; out_label lbl | Kcompint31 -> out opCOMPINT31 | Kdecompint31 -> out opDECOMPINT31 (*/spiwack *) | Kstop -> out opSTOP (* Emission of a list of instructions. Include some peephole optimization. *) let rec emit = function | [] -> () (* Peephole optimizations *) | Kpush :: Kacc n :: c -> if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n); emit c | Kpush :: Kenvacc n :: c -> if n >= 1 && n <= 4 then out(opPUSHENVACC1 + n - 1) else (out opPUSHENVACC; out_int n); emit c | Kpush :: Koffsetclosure ofs :: c -> if ofs = -2 || ofs = 0 || ofs = 2 then out(opPUSHOFFSETCLOSURE0 + ofs / 2) else (out opPUSHOFFSETCLOSURE; out_int ofs); emit c | Kpush :: Kgetglobal id :: c -> out opPUSHGETGLOBAL; slot_for_getglobal id; emit c | Kpush :: Kconst (Const_b0 i) :: c -> if i >= 0 && i <= 3 then out (opPUSHCONST0 + i) else (out opPUSHCONSTINT; out_int i); emit c | Kpush :: Kconst const :: c -> out opPUSHGETGLOBAL; slot_for_const const; emit c | Kpop n :: Kjump :: c -> out opRETURN; out_int n; emit c | Ksequence(c1,c2)::c -> emit c1; emit c2;emit c (* Default case *) | instr :: c -> emit_instr instr; emit c (* Initialization *) let init () = out_position := 0; label_table := Array.create 16 (Label_undefined []); reloc_info := [] type emitcodes = string let copy = String.copy let length = String.length type to_patch = emitcodes * (patch list) * fv (* Substitution *) let rec subst_strcst s sc = match sc with | Const_sorts _ | Const_b0 _ -> sc | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args) | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_ind s kn, i)) let subst_patch s (ri,pos) = match ri with | Reloc_annot a -> let (kn,i) = a.ci.ci_ind in let ci = {a.ci with ci_ind = (subst_ind s kn,i)} in (Reloc_annot {a with ci = ci},pos) | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos) | Reloc_getglobal kn -> (Reloc_getglobal (fst (subst_con s kn)), pos) let subst_to_patch s (code,pl,fv) = code,List.rev_map (subst_patch s) pl,fv type body_code = | BCdefined of to_patch | BCallias of constant | BCconstant let subst_body_code s = function | BCdefined tp -> BCdefined (subst_to_patch s tp) | BCallias kn -> BCallias (fst (subst_con s kn)) | BCconstant -> BCconstant type to_patch_substituted = body_code substituted let from_val = from_val let force = force subst_body_code let subst_to_patch_subst = subst_substituted let repr_body_code = repr_substituted let to_memory (init_code, fun_code, fv) = init(); emit init_code; emit fun_code; let code = String.create !out_position in String.unsafe_blit !out_buffer 0 code 0 !out_position; let reloc = List.rev !reloc_info in Array.iter (fun lbl -> (match lbl with Label_defined _ -> assert true | Label_undefined patchlist -> assert (patchlist = []))) !label_table; (code, reloc, fv) coq-8.4pl4/kernel/esubst.mli0000644000175000017500000000546112326224777015131 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a subs val subs_cons: 'a array * 'a subs -> 'a subs val subs_shft: int * 'a subs -> 'a subs val subs_lift: 'a subs -> 'a subs val subs_liftn: int -> 'a subs -> 'a subs (** [subs_shift_cons(k,s,[|t1..tn|])] builds (^k s).t1..tn *) val subs_shift_cons: int * 'a subs * 'a array -> 'a subs (** [expand_rel k subs] expands de Bruijn [k] in the explicit substitution [subs]. The result is either (Inl(lams,v)) when the variable is substituted by value [v] under lams binders (i.e. v *has* to be shifted by lams), or (Inr (k',p)) when the variable k is just relocated as k'; p is None if the variable points inside subs and Some(k) if the variable points k bindings beyond subs (cf argument of ESID). *) val expand_rel: int -> 'a subs -> (int * 'a, int * int option) Util.union (** Tests whether a substitution behaves like the identity *) val is_subs_id: 'a subs -> bool (** Composition of substitutions: [comp mk_clos s1 s2] computes a substitution equivalent to applying s2 then s1. Argument mk_clos is used when a closure has to be created, i.e. when s1 is applied on an element of s2. *) val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs (** {6 Compact representation } *) (** Compact representation of explicit relocations - [ELSHFT(l,n)] == lift of [n], then apply [lift l]. - [ELLFT(n,l)] == apply [l] to de Bruijn > [n] i.e under n binders. *) type lift = private | ELID | ELSHFT of lift * int | ELLFT of int * lift val el_id : lift val el_shft : int -> lift -> lift val el_liftn : int -> lift -> lift val el_lift : lift -> lift val reloc_rel : int -> lift -> int val is_lift_id : lift -> bool coq-8.4pl4/kernel/cooking.ml0000644000175000017500000001064012326224777015077 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* anomaly "dirpath_prefix: empty dirpath" | _::l -> make_dirpath l let pop_mind kn = let (mp,dir,l) = Names.repr_mind kn in Names.make_mind mp (pop_dirpath dir) l let pop_con con = let (mp,dir,l) = Names.repr_con con in Names.make_con mp (pop_dirpath dir) l type my_global_reference = | ConstRef of constant | IndRef of inductive | ConstructRef of constructor let cache = (Hashtbl.create 13 : (my_global_reference, constr) Hashtbl.t) let clear_cooking_sharing () = Hashtbl.clear cache let share r (cstl,knl) = try Hashtbl.find cache r with Not_found -> let f,l = match r with | IndRef (kn,i) -> mkInd (pop_mind kn,i), Mindmap.find kn knl | ConstructRef ((kn,i),j) -> mkConstruct ((pop_mind kn,i),j), Mindmap.find kn knl | ConstRef cst -> mkConst (pop_con cst), Cmap.find cst cstl in let c = mkApp (f, Array.map mkVar l) in Hashtbl.add cache r c; (* has raised Not_found if not in work_list *) c let update_case_info ci modlist = try let ind, n = match kind_of_term (share (IndRef ci.ci_ind) modlist) with | App (f,l) -> (destInd f, Array.length l) | Ind ind -> ind, 0 | _ -> assert false in { ci with ci_ind = ind; ci_npar = ci.ci_npar + n } with Not_found -> ci let empty_modlist = (Cmap.empty, Mindmap.empty) let expmod_constr modlist c = let rec substrec c = match kind_of_term c with | Case (ci,p,t,br) -> map_constr substrec (mkCase (update_case_info ci modlist,p,t,br)) | Ind ind -> (try share (IndRef ind) modlist with | Not_found -> map_constr substrec c) | Construct cstr -> (try share (ConstructRef cstr) modlist with | Not_found -> map_constr substrec c) | Const cst -> (try share (ConstRef cst) modlist with | Not_found -> map_constr substrec c) | _ -> map_constr substrec c in if modlist = empty_modlist then c else substrec c let abstract_constant_type = List.fold_left (fun c d -> mkNamedProd_wo_LetIn d c) let abstract_constant_body = List.fold_left (fun c d -> mkNamedLambda_or_LetIn d c) type recipe = { d_from : constant_body; d_abstract : named_context; d_modlist : work_list } let on_body f = function | Undef inl -> Undef inl | Def cs -> Def (Declarations.from_val (f (Declarations.force cs))) | OpaqueDef lc -> OpaqueDef (Declarations.opaque_from_val (f (Declarations.force_opaque lc))) let constr_of_def = function | Undef _ -> assert false | Def cs -> Declarations.force cs | OpaqueDef lc -> Declarations.force_opaque lc let cook_constant env r = let cb = r.d_from in let hyps = Sign.map_named_context (expmod_constr r.d_modlist) r.d_abstract in let body = on_body (fun c -> abstract_constant_body (expmod_constr r.d_modlist c) hyps) cb.const_body in let const_hyps = Sign.fold_named_context (fun (h,_,_) hyps -> List.filter (fun (id,_,_) -> id <> h) hyps) hyps ~init:cb.const_hyps in let typ = match cb.const_type with | NonPolymorphicType t -> let typ = abstract_constant_type (expmod_constr r.d_modlist t) hyps in NonPolymorphicType typ | PolymorphicArity (ctx,s) -> let t = mkArity (ctx,Type s.poly_level) in let typ = abstract_constant_type (expmod_constr r.d_modlist t) hyps in let j = make_judge (constr_of_def body) typ in Typeops.make_polymorphic_if_constant_for_ind env j in (body, typ, cb.const_constraints, const_hyps) coq-8.4pl4/kernel/type_errors.ml0000644000175000017500000000765312326224777016035 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* NonInformativeToInformative | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *) | _ -> WrongArity coq-8.4pl4/kernel/term.ml0000644000175000017500000014000512326224777014414 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* InProp | Prop Pos -> InSet | Type _ -> InType (********************************************************************) (* Constructions as implemented *) (********************************************************************) (* [constr array] is an instance matching definitional [named_context] in the same order (i.e. last argument first) *) type 'constr pexistential = existential_key * 'constr array type ('constr, 'types) prec_declaration = name array * 'types array * 'constr array type ('constr, 'types) pfixpoint = (int array * int) * ('constr, 'types) prec_declaration type ('constr, 'types) pcofixpoint = int * ('constr, 'types) prec_declaration (* [Var] is used for named variables and [Rel] for variables as de Bruijn indices. *) type ('constr, 'types) kind_of_term = | Rel of int | Var of identifier | Meta of metavariable | Evar of 'constr pexistential | Sort of sorts | Cast of 'constr * cast_kind * 'types | Prod of name * 'types * 'types | Lambda of name * 'types * 'constr | LetIn of name * 'constr * 'types * 'constr | App of 'constr * 'constr array | Const of constant | Ind of inductive | Construct of constructor | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint (* constr is the fixpoint of the previous type. Requires option -rectypes of the Caml compiler to be set *) type constr = (constr,constr) kind_of_term type existential = existential_key * constr array type rec_declaration = name array * constr array * constr array type fixpoint = (int array * int) * rec_declaration type cofixpoint = int * rec_declaration (*********************) (* Term constructors *) (*********************) (* Constructs a DeBrujin index with number n *) let rels = [|Rel 1;Rel 2;Rel 3;Rel 4;Rel 5;Rel 6;Rel 7; Rel 8; Rel 9;Rel 10;Rel 11;Rel 12;Rel 13;Rel 14;Rel 15; Rel 16|] let mkRel n = if 0 mkProp (* Easy sharing *) | Prop Pos -> mkSet | s -> Sort s (* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *) (* (that means t2 is declared as the type of t1) *) let mkCast (t1,k2,t2) = match t1 with | Cast (c,k1, _) when k1 = VMcast & k1 = k2 -> Cast (c,k1,t2) | _ -> Cast (t1,k2,t2) (* Constructs the product (x:t1)t2 *) let mkProd (x,t1,t2) = Prod (x,t1,t2) (* Constructs the abstraction [x:t1]t2 *) let mkLambda (x,t1,t2) = Lambda (x,t1,t2) (* Constructs [x=c_1:t]c_2 *) let mkLetIn (x,c1,t,c2) = LetIn (x,c1,t,c2) (* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *) (* We ensure applicative terms have at least one argument and the function is not itself an applicative term *) let mkApp (f, a) = if Array.length a = 0 then f else match f with | App (g, cl) -> App (g, Array.append cl a) | _ -> App (f, a) (* Constructs a constant *) let mkConst c = Const c (* Constructs an existential variable *) let mkEvar e = Evar e (* Constructs the ith (co)inductive type of the block named kn *) let mkInd m = Ind m (* Constructs the jth constructor of the ith (co)inductive type of the block named kn. The array of terms correspond to the variables introduced in the section *) let mkConstruct c = Construct c (* Constructs the term

    Case c of c1 | c2 .. | cn end *) let mkCase (ci, p, c, ac) = Case (ci, p, c, ac) (* If recindxs = [|i1,...in|] funnames = [|f1,...fn|] typarray = [|t1,...tn|] bodies = [|b1,...bn|] then mkFix ((recindxs,i),(funnames,typarray,bodies)) constructs the ith function of the block Fixpoint f1 [ctx1] : t1 := b1 with f2 [ctx2] : t2 := b2 ... with fn [ctxn] : tn := bn. where the lenght of the jth context is ij. *) let mkFix fix = Fix fix (* If funnames = [|f1,...fn|] typarray = [|t1,...tn|] bodies = [|b1,...bn|] then mkCoFix (i,(funnames,typsarray,bodies)) constructs the ith function of the block CoFixpoint f1 : t1 := b1 with f2 : t2 := b2 ... with fn : tn := bn. *) let mkCoFix cofix= CoFix cofix (* Constructs an existential variable named "?n" *) let mkMeta n = Meta n (* Constructs a Variable named id *) let mkVar id = Var id (************************************************************************) (* kind_of_term = constructions as seen by the user *) (************************************************************************) (* User view of [constr]. For [App], it is ensured there is at least one argument and the function is not itself an applicative term *) let kind_of_term c = c (* Experimental, used in Presburger contrib *) type ('constr, 'types) kind_of_type = | SortType of sorts | CastType of 'types * 'types | ProdType of name * 'types * 'types | LetInType of name * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array let kind_of_type = function | Sort s -> SortType s | Cast (c,_,t) -> CastType (c, t) | Prod (na,t,c) -> ProdType (na, t, c) | LetIn (na,b,t,c) -> LetInType (na, b, t, c) | App (c,l) -> AtomicType (c, l) | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Case _ | Fix _ | CoFix _ | Ind _ as c) -> AtomicType (c,[||]) | (Lambda _ | Construct _) -> failwith "Not a type" (**********************************************************************) (* Non primitive term destructors *) (**********************************************************************) (* Destructor operations : partial functions Raise invalid_arg "dest*" if the const has not the expected form *) (* Destructs a DeBrujin index *) let destRel c = match kind_of_term c with | Rel n -> n | _ -> invalid_arg "destRel" (* Destructs an existential variable *) let destMeta c = match kind_of_term c with | Meta n -> n | _ -> invalid_arg "destMeta" let isMeta c = match kind_of_term c with Meta _ -> true | _ -> false let isMetaOf mv c = match kind_of_term c with Meta mv' -> mv = mv' | _ -> false (* Destructs a variable *) let destVar c = match kind_of_term c with | Var id -> id | _ -> invalid_arg "destVar" (* Destructs a type *) let isSort c = match kind_of_term c with | Sort s -> true | _ -> false let destSort c = match kind_of_term c with | Sort s -> s | _ -> invalid_arg "destSort" let rec isprop c = match kind_of_term c with | Sort (Prop _) -> true | Cast (c,_,_) -> isprop c | _ -> false let rec is_Prop c = match kind_of_term c with | Sort (Prop Null) -> true | Cast (c,_,_) -> is_Prop c | _ -> false let rec is_Set c = match kind_of_term c with | Sort (Prop Pos) -> true | Cast (c,_,_) -> is_Set c | _ -> false let rec is_Type c = match kind_of_term c with | Sort (Type _) -> true | Cast (c,_,_) -> is_Type c | _ -> false let is_small = function | Prop _ -> true | _ -> false let iskind c = isprop c or is_Type c (* Tests if an evar *) let isEvar c = match kind_of_term c with Evar _ -> true | _ -> false let isEvar_or_Meta c = match kind_of_term c with | Evar _ | Meta _ -> true | _ -> false (* Destructs a casted term *) let destCast c = match kind_of_term c with | Cast (t1,k,t2) -> (t1,k,t2) | _ -> invalid_arg "destCast" let isCast c = match kind_of_term c with Cast _ -> true | _ -> false (* Tests if a de Bruijn index *) let isRel c = match kind_of_term c with Rel _ -> true | _ -> false let isRelN n c = match kind_of_term c with Rel n' -> n = n' | _ -> false (* Tests if a variable *) let isVar c = match kind_of_term c with Var _ -> true | _ -> false let isVarId id c = match kind_of_term c with Var id' -> id = id' | _ -> false (* Tests if an inductive *) let isInd c = match kind_of_term c with Ind _ -> true | _ -> false (* Destructs the product (x:t1)t2 *) let destProd c = match kind_of_term c with | Prod (x,t1,t2) -> (x,t1,t2) | _ -> invalid_arg "destProd" let isProd c = match kind_of_term c with | Prod _ -> true | _ -> false (* Destructs the abstraction [x:t1]t2 *) let destLambda c = match kind_of_term c with | Lambda (x,t1,t2) -> (x,t1,t2) | _ -> invalid_arg "destLambda" let isLambda c = match kind_of_term c with | Lambda _ -> true | _ -> false (* Destructs the let [x:=b:t1]t2 *) let destLetIn c = match kind_of_term c with | LetIn (x,b,t1,t2) -> (x,b,t1,t2) | _ -> invalid_arg "destLetIn" let isLetIn c = match kind_of_term c with LetIn _ -> true | _ -> false (* Destructs an application *) let destApp c = match kind_of_term c with | App (f,a) -> (f, a) | _ -> invalid_arg "destApplication" let destApplication = destApp let isApp c = match kind_of_term c with App _ -> true | _ -> false (* Destructs a constant *) let destConst c = match kind_of_term c with | Const kn -> kn | _ -> invalid_arg "destConst" let isConst c = match kind_of_term c with Const _ -> true | _ -> false (* Destructs an existential variable *) let destEvar c = match kind_of_term c with | Evar (kn, a as r) -> r | _ -> invalid_arg "destEvar" (* Destructs a (co)inductive type named kn *) let destInd c = match kind_of_term c with | Ind (kn, a as r) -> r | _ -> invalid_arg "destInd" (* Destructs a constructor *) let destConstruct c = match kind_of_term c with | Construct (kn, a as r) -> r | _ -> invalid_arg "dest" let isConstruct c = match kind_of_term c with Construct _ -> true | _ -> false (* Destructs a term

    Case c of lc1 | lc2 .. | lcn end *) let destCase c = match kind_of_term c with | Case (ci,p,c,v) -> (ci,p,c,v) | _ -> anomaly "destCase" let isCase c = match kind_of_term c with Case _ -> true | _ -> false let destFix c = match kind_of_term c with | Fix fix -> fix | _ -> invalid_arg "destFix" let isFix c = match kind_of_term c with Fix _ -> true | _ -> false let destCoFix c = match kind_of_term c with | CoFix cofix -> cofix | _ -> invalid_arg "destCoFix" let isCoFix c = match kind_of_term c with CoFix _ -> true | _ -> false (******************************************************************) (* Cast management *) (******************************************************************) let rec strip_outer_cast c = match kind_of_term c with | Cast (c,_,_) -> strip_outer_cast c | _ -> c (* Fonction spéciale qui laisse les cast clés sous les Fix ou les Case *) let under_outer_cast f c = match kind_of_term c with | Cast (b,k,t) -> mkCast (f b, k, f t) | _ -> f c let rec under_casts f c = match kind_of_term c with | Cast (c,k,t) -> mkCast (under_casts f c, k, t) | _ -> f c (******************************************************************) (* Flattening and unflattening of embedded applications and casts *) (******************************************************************) (* flattens application lists throwing casts in-between *) let rec collapse_appl c = match kind_of_term c with | App (f,cl) -> let rec collapse_rec f cl2 = match kind_of_term (strip_outer_cast f) with | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) | _ -> mkApp (f,cl2) in collapse_rec f cl | _ -> c let decompose_app c = match kind_of_term c with | App (f,cl) -> (f, Array.to_list cl) | _ -> (c,[]) (****************************************************************************) (* Functions to recur through subterms *) (****************************************************************************) (* [fold_constr f acc c] folds [f] on the immediate subterms of [c] starting from [acc] and proceeding from left to right according to the usual representation of the constructions; it is not recursive *) let fold_constr f acc c = match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> acc | Cast (c,_,t) -> f (f acc c) t | Prod (_,t,c) -> f (f acc t) c | Lambda (_,t,c) -> f (f acc t) c | LetIn (_,b,t,c) -> f (f (f acc b) t) c | App (c,l) -> Array.fold_left f (f acc c) l | Evar (_,l) -> Array.fold_left f acc l | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl | Fix (_,(lna,tl,bl)) -> let fd = array_map3 (fun na t b -> (na,t,b)) lna tl bl in Array.fold_left (fun acc (na,t,b) -> f (f acc t) b) acc fd | CoFix (_,(lna,tl,bl)) -> let fd = array_map3 (fun na t b -> (na,t,b)) lna tl bl in Array.fold_left (fun acc (na,t,b) -> f (f acc t) b) acc fd (* [iter_constr f c] iters [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is not specified *) let iter_constr f c = match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () | Cast (c,_,t) -> f c; f t | Prod (_,t,c) -> f t; f c | Lambda (_,t,c) -> f t; f c | LetIn (_,b,t,c) -> f b; f t; f c | App (c,l) -> f c; Array.iter f l | Evar (_,l) -> Array.iter f l | Case (_,p,c,bl) -> f p; f c; Array.iter f bl | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl (* [iter_constr_with_binders g f n c] iters [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive and the order with which subterms are processed is not specified *) let iter_constr_with_binders g f n c = match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () | Cast (c,_,t) -> f n c; f n t | Prod (_,t,c) -> f n t; f (g n) c | Lambda (_,t,c) -> f n t; f (g n) c | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c | App (c,l) -> f n c; Array.iter (f n) l | Evar (_,l) -> Array.iter (f n) l | Case (_,p,c,bl) -> f n p; f n c; Array.iter (f n) bl | Fix (_,(_,tl,bl)) -> Array.iter (f n) tl; Array.iter (f (iterate g (Array.length tl) n)) bl | CoFix (_,(_,tl,bl)) -> Array.iter (f n) tl; Array.iter (f (iterate g (Array.length tl) n)) bl (* [map_constr f c] maps [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is not specified *) let map_constr f c = match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> c | Cast (c,k,t) -> mkCast (f c, k, f t) | Prod (na,t,c) -> mkProd (na, f t, f c) | Lambda (na,t,c) -> mkLambda (na, f t, f c) | LetIn (na,b,t,c) -> mkLetIn (na, f b, f t, f c) | App (c,l) -> mkApp (f c, Array.map f l) | Evar (e,l) -> mkEvar (e, Array.map f l) | Case (ci,p,c,bl) -> mkCase (ci, f p, f c, Array.map f bl) | Fix (ln,(lna,tl,bl)) -> mkFix (ln,(lna,Array.map f tl,Array.map f bl)) | CoFix(ln,(lna,tl,bl)) -> mkCoFix (ln,(lna,Array.map f tl,Array.map f bl)) (* [map_constr_with_binders g f n c] maps [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive and the order with which subterms are processed is not specified *) let map_constr_with_binders g f l c = match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> c | Cast (c,k,t) -> mkCast (f l c, k, f l t) | Prod (na,t,c) -> mkProd (na, f l t, f (g l) c) | Lambda (na,t,c) -> mkLambda (na, f l t, f (g l) c) | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g l) c) | App (c,al) -> mkApp (f l c, Array.map (f l) al) | Evar (e,al) -> mkEvar (e, Array.map (f l) al) | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl) | Fix (ln,(lna,tl,bl)) -> let l' = iterate g (Array.length tl) l in mkFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) | CoFix(ln,(lna,tl,bl)) -> let l' = iterate g (Array.length tl) l in mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) (* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare the immediate subterms of [c1] of [c2] if needed; Cast's, application associativity, binders name and Cases annotations are not taken into account *) let compare_constr f t1 t2 = match kind_of_term t1, kind_of_term t2 with | Rel n1, Rel n2 -> n1 = n2 | Meta m1, Meta m2 -> m1 = m2 | Var id1, Var id2 -> id1 = id2 | Sort s1, Sort s2 -> s1 = s2 | Cast (c1,_,_), _ -> f c1 t2 | _, Cast (c2,_,_) -> f t1 c2 | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 & f c1 c2 | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 & f c1 c2 | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 & f t1 t2 & f c1 c2 | App (c1,l1), _ when isCast c1 -> f (mkApp (pi1 (destCast c1),l1)) t2 | _, App (c2,l2) when isCast c2 -> f t1 (mkApp (pi1 (destCast c2),l2)) | App (c1,l1), App (c2,l2) -> Array.length l1 = Array.length l2 && f c1 c2 && array_for_all2 f l1 l2 | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2 | Const c1, Const c2 -> eq_constant c1 c2 | Ind c1, Ind c2 -> eq_ind c1 c2 | Construct c1, Construct c2 -> eq_constructor c1 c2 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> f p1 p2 & f c1 c2 & array_for_all2 f bl1 bl2 | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2 | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2 | _ -> false (*******************************) (* alpha conversion functions *) (*******************************) (* alpha conversion : ignore print names and casts *) let rec eq_constr m n = (m==n) or compare_constr eq_constr m n let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *) let constr_ord_int f t1 t2 = let (=?) f g i1 i2 j1 j2= let c=f i1 i2 in if c=0 then g j1 j2 else c in let (==?) fg h i1 i2 j1 j2 k1 k2= let c=fg i1 i2 j1 j2 in if c=0 then h k1 k2 else c in match kind_of_term t1, kind_of_term t2 with | Rel n1, Rel n2 -> n1 - n2 | Meta m1, Meta m2 -> m1 - m2 | Var id1, Var id2 -> id_ord id1 id2 | Sort s1, Sort s2 -> Pervasives.compare s1 s2 | Cast (c1,_,_), _ -> f c1 t2 | _, Cast (c2,_,_) -> f t1 c2 | Prod (_,t1,c1), Prod (_,t2,c2) | Lambda (_,t1,c1), Lambda (_,t2,c2) -> (f =? f) t1 t2 c1 c2 | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> ((f =? f) ==? f) b1 b2 t1 t2 c1 c2 | App (c1,l1), _ when isCast c1 -> f (mkApp (pi1 (destCast c1),l1)) t2 | _, App (c2,l2) when isCast c2 -> f t1 (mkApp (pi1 (destCast c2),l2)) | App (c1,l1), App (c2,l2) -> (f =? (array_compare f)) c1 c2 l1 l2 | Evar (e1,l1), Evar (e2,l2) -> ((-) =? (array_compare f)) e1 e2 l1 l2 | Const c1, Const c2 -> kn_ord (canonical_con c1) (canonical_con c2) | Ind (spx, ix), Ind (spy, iy) -> let c = ix - iy in if c = 0 then kn_ord (canonical_mind spx) (canonical_mind spy) else c | Construct ((spx, ix), jx), Construct ((spy, iy), jy) -> let c = jx - jy in if c = 0 then (let c = ix - iy in if c = 0 then kn_ord (canonical_mind spx) (canonical_mind spy) else c) else c | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> ((f =? f) ==? (array_compare f)) p1 p2 c1 c2 bl1 bl2 | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> ((Pervasives.compare =? (array_compare f)) ==? (array_compare f)) ln1 ln2 tl1 tl2 bl1 bl2 | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> ((Pervasives.compare =? (array_compare f)) ==? (array_compare f)) ln1 ln2 tl1 tl2 bl1 bl2 | t1, t2 -> Pervasives.compare t1 t2 let rec constr_ord m n= constr_ord_int constr_ord m n (***************************************************************************) (* Type of assumptions *) (***************************************************************************) type types = constr type strategy = types option type named_declaration = identifier * constr option * types type rel_declaration = name * constr option * types let map_named_declaration f (id, v, ty) = (id, Option.map f v, f ty) let map_rel_declaration = map_named_declaration let fold_named_declaration f (_, v, ty) a = f ty (Option.fold_right f v a) let fold_rel_declaration = fold_named_declaration let exists_named_declaration f (_, v, ty) = Option.cata f false v || f ty let exists_rel_declaration f (_, v, ty) = Option.cata f false v || f ty let for_all_named_declaration f (_, v, ty) = Option.cata f true v && f ty let for_all_rel_declaration f (_, v, ty) = Option.cata f true v && f ty let eq_named_declaration (i1, c1, t1) (i2, c2, t2) = id_ord i1 i2 = 0 && Option.Misc.compare eq_constr c1 c2 && eq_constr t1 t2 let eq_rel_declaration (n1, c1, t1) (n2, c2, t2) = n1 = n2 && Option.Misc.compare eq_constr c1 c2 && eq_constr t1 t2 (***************************************************************************) (* Type of local contexts (telescopes) *) (***************************************************************************) (*s Signatures of ordered optionally named variables, intended to be accessed by de Bruijn indices (to represent bound variables) *) type rel_context = rel_declaration list let empty_rel_context = [] let add_rel_decl d ctxt = d::ctxt let rec lookup_rel n sign = match n, sign with | 1, decl :: _ -> decl | n, _ :: sign -> lookup_rel (n-1) sign | _, [] -> raise Not_found let rel_context_length = List.length let rel_context_nhyps hyps = let rec nhyps acc = function | [] -> acc | (_,None,_)::hyps -> nhyps (1+acc) hyps | (_,Some _,_)::hyps -> nhyps acc hyps in nhyps 0 hyps (****************************************************************************) (* Functions for dealing with constr terms *) (****************************************************************************) (*********************) (* Occurring *) (*********************) exception LocalOccur (* (closedn n M) raises FreeVar if a variable of height greater than n occurs in M, returns () otherwise *) let closedn n c = let rec closed_rec n c = match kind_of_term c with | Rel m -> if m>n then raise LocalOccur | _ -> iter_constr_with_binders succ closed_rec n c in try closed_rec n c; true with LocalOccur -> false (* [closed0 M] is true iff [M] is a (deBruijn) closed term *) let closed0 = closedn 0 (* (noccurn n M) returns true iff (Rel n) does NOT occur in term M *) let noccurn n term = let rec occur_rec n c = match kind_of_term c with | Rel m -> if m = n then raise LocalOccur | _ -> iter_constr_with_binders succ occur_rec n c in try occur_rec n term; true with LocalOccur -> false (* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M for n <= p < n+m *) let noccur_between n m term = let rec occur_rec n c = match kind_of_term c with | Rel(p) -> if n<=p && p iter_constr_with_binders succ occur_rec n c in try occur_rec n term; true with LocalOccur -> false (* Checking function for terms containing existential variables. The function [noccur_with_meta] considers the fact that each existential variable (as well as each isevar) in the term appears applied to its local context, which may contain the CoFix variables. These occurrences of CoFix variables are not considered *) let noccur_with_meta n m term = let rec occur_rec n c = match kind_of_term c with | Rel p -> if n<=p & p (match kind_of_term f with | Cast (c,_,_) when isMeta c -> () | Meta _ -> () | _ -> iter_constr_with_binders succ occur_rec n c) | Evar (_, _) -> () | _ -> iter_constr_with_binders succ occur_rec n c in try (occur_rec n term; true) with LocalOccur -> false (*********************) (* Lifting *) (*********************) (* The generic lifting function *) let rec exliftn el c = match kind_of_term c with | Rel i -> mkRel(reloc_rel i el) | _ -> map_constr_with_binders el_lift exliftn el c (* Lifting the binding depth across k bindings *) let liftn n k = match el_liftn (pred k) (el_shft n el_id) with | ELID -> (fun c -> c) | el -> exliftn el let lift n = liftn n 1 (*********************) (* Substituting *) (*********************) (* (subst1 M c) substitutes M for Rel(1) in c we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel M1,...,Mn for respectively Rel(1),...,Rel(n) in c *) (* 1st : general case *) type info = Closed | Open | Unknown type 'a substituend = { mutable sinfo: info; sit: 'a } let rec lift_substituend depth s = match s.sinfo with | Closed -> s.sit | Open -> lift depth s.sit | Unknown -> s.sinfo <- if closed0 s.sit then Closed else Open; lift_substituend depth s let make_substituend c = { sinfo=Unknown; sit=c } let substn_many lamv n c = let lv = Array.length lamv in if lv = 0 then c else let rec substrec depth c = match kind_of_term c with | Rel k -> if k<=depth then c else if k-depth <= lv then lift_substituend depth lamv.(k-depth-1) else mkRel (k-lv) | _ -> map_constr_with_binders succ substrec depth c in substrec n c (* let substkey = Profile.declare_profile "substn_many";; let substn_many lamv n c = Profile.profile3 substkey substn_many lamv n c;; *) let substnl laml n = substn_many (Array.map make_substituend (Array.of_list laml)) n let substl laml = substnl laml 0 let subst1 lam = substl [lam] let substnl_decl laml k = map_rel_declaration (substnl laml k) let substl_decl laml = substnl_decl laml 0 let subst1_decl lam = substl_decl [lam] let substnl_named laml k = map_named_declaration (substnl laml k) let substl_named_decl = substl_decl let subst1_named_decl = subst1_decl (* (thin_val sigma) removes identity substitutions from sigma *) let rec thin_val = function | [] -> [] | (((id,{ sit = v }) as s)::tl) when isVar v -> if id = destVar v then thin_val tl else s::(thin_val tl) | h::tl -> h::(thin_val tl) (* (replace_vars sigma M) applies substitution sigma to term M *) let replace_vars var_alist = let var_alist = List.map (fun (str,c) -> (str,make_substituend c)) var_alist in let var_alist = thin_val var_alist in let rec substrec n c = match kind_of_term c with | Var x -> (try lift_substituend n (List.assoc x var_alist) with Not_found -> c) | _ -> map_constr_with_binders succ substrec n c in if var_alist = [] then (function x -> x) else substrec 0 (* let repvarkey = Profile.declare_profile "replace_vars";; let replace_vars vl c = Profile.profile2 repvarkey replace_vars vl c ;; *) (* (subst_var str t) substitute (VAR str) by (Rel 1) in t *) let subst_var str = replace_vars [(str, mkRel 1)] (* (subst_vars [id1;...;idn] t) substitute (VAR idj) by (Rel j) in t *) let substn_vars p vars = let _,subst = List.fold_left (fun (n,l) var -> ((n+1),(var,mkRel n)::l)) (p,[]) vars in replace_vars (List.rev subst) let subst_vars = substn_vars 1 (***************************) (* Other term constructors *) (***************************) let mkNamedProd id typ c = mkProd (Name id, typ, subst_var id c) let mkNamedLambda id typ c = mkLambda (Name id, typ, subst_var id c) let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, subst_var id c2) (* Constructs either [(x:t)c] or [[x=b:t]c] *) let mkProd_or_LetIn (na,body,t) c = match body with | None -> mkProd (na, t, c) | Some b -> mkLetIn (na, b, t, c) let mkNamedProd_or_LetIn (id,body,t) c = match body with | None -> mkNamedProd id t c | Some b -> mkNamedLetIn id b t c (* Constructs either [(x:t)c] or [c] where [x] is replaced by [b] *) let mkProd_wo_LetIn (na,body,t) c = match body with | None -> mkProd (na, t, c) | Some b -> subst1 b c let mkNamedProd_wo_LetIn (id,body,t) c = match body with | None -> mkNamedProd id t c | Some b -> subst1 b (subst_var id c) (* non-dependent product t1 -> t2 *) let mkArrow t1 t2 = mkProd (Anonymous, t1, t2) (* Constructs either [[x:t]c] or [[x=b:t]c] *) let mkLambda_or_LetIn (na,body,t) c = match body with | None -> mkLambda (na, t, c) | Some b -> mkLetIn (na, b, t, c) let mkNamedLambda_or_LetIn (id,body,t) c = match body with | None -> mkNamedLambda id t c | Some b -> mkNamedLetIn id b t c (* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *) let prodn n env b = let rec prodrec = function | (0, env, b) -> b | (n, ((v,t)::l), b) -> prodrec (n-1, l, mkProd (v,t,b)) | _ -> assert false in prodrec (n,env,b) (* compose_prod [xn:Tn;..;x1:T1] b = (x1:T1)..(xn:Tn)b *) let compose_prod l b = prodn (List.length l) l b (* lamn n [xn:Tn;..;x1:T1;Gamma] b = [x1:T1]..[xn:Tn]b *) let lamn n env b = let rec lamrec = function | (0, env, b) -> b | (n, ((v,t)::l), b) -> lamrec (n-1, l, mkLambda (v,t,b)) | _ -> assert false in lamrec (n,env,b) (* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *) let compose_lam l b = lamn (List.length l) l b let applist (f,l) = mkApp (f, Array.of_list l) let applistc f l = mkApp (f, Array.of_list l) let appvect = mkApp let appvectc f l = mkApp (f,l) (* to_lambda n (x1:T1)...(xn:Tn)T = * [x1:T1]...[xn:Tn]T *) let rec to_lambda n prod = if n = 0 then prod else match kind_of_term prod with | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd) | Cast (c,_,_) -> to_lambda n c | _ -> errorlabstrm "to_lambda" (mt ()) let rec to_prod n lam = if n=0 then lam else match kind_of_term lam with | Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd) | Cast (c,_,_) -> to_prod n c | _ -> errorlabstrm "to_prod" (mt ()) (* pseudo-reduction rule: * [prod_app s (Prod(_,B)) N --> B[N] * with an strip_outer_cast on the first argument to produce a product *) let prod_app t n = match kind_of_term (strip_outer_cast t) with | Prod (_,_,b) -> subst1 n b | _ -> errorlabstrm "prod_app" (str"Needed a product, but didn't find one" ++ fnl ()) (* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) let prod_appvect t nL = Array.fold_left prod_app t nL (* prod_applist T [ a1 ; ... ; an ] -> (T a1 ... an) *) let prod_applist t nL = List.fold_left prod_app t nL let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c) (*********************************) (* Other term destructors *) (*********************************) (* Transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a product *) let decompose_prod = let rec prodec_rec l c = match kind_of_term c with | Prod (x,t,c) -> prodec_rec ((x,t)::l) c | Cast (c,_,_) -> prodec_rec l c | _ -> l,c in prodec_rec [] (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) let decompose_lam = let rec lamdec_rec l c = match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c | Cast (c,_,_) -> lamdec_rec l c | _ -> l,c in lamdec_rec [] (* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T) *) let decompose_prod_n n = if n < 0 then error "decompose_prod_n: integer parameter must be positive"; let rec prodec_rec l n c = if n=0 then l,c else match kind_of_term c with | Prod (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c | _ -> error "decompose_prod_n: not enough products" in prodec_rec [] n (* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T) *) let decompose_lam_n n = if n < 0 then error "decompose_lam_n: integer parameter must be positive"; let rec lamdec_rec l n c = if n=0 then l,c else match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c | Cast (c,_,_) -> lamdec_rec l n c | _ -> error "decompose_lam_n: not enough abstractions" in lamdec_rec [] n (* Transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a product *) let decompose_prod_assum = let rec prodec_rec l c = match kind_of_term c with | Prod (x,t,c) -> prodec_rec (add_rel_decl (x,None,t) l) c | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) c | Cast (c,_,_) -> prodec_rec l c | _ -> l,c in prodec_rec empty_rel_context (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) let decompose_lam_assum = let rec lamdec_rec l c = match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec (add_rel_decl (x,None,t) l) c | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) c | Cast (c,_,_) -> lamdec_rec l c | _ -> l,c in lamdec_rec empty_rel_context (* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T) *) let decompose_prod_n_assum n = if n < 0 then error "decompose_prod_n_assum: integer parameter must be positive"; let rec prodec_rec l n c = if n=0 then l,c else match kind_of_term c with | Prod (x,t,c) -> prodec_rec (add_rel_decl (x,None,t) l) (n-1) c | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c | c -> error "decompose_prod_n_assum: not enough assumptions" in prodec_rec empty_rel_context n (* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T) Lets in between are not expanded but turn into local definitions, but n is the actual number of destructurated lambdas. *) let decompose_lam_n_assum n = if n < 0 then error "decompose_lam_n_assum: integer parameter must be positive"; let rec lamdec_rec l n c = if n=0 then l,c else match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec (add_rel_decl (x,None,t) l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) n c | Cast (c,_,_) -> lamdec_rec l n c | c -> error "decompose_lam_n_assum: not enough abstractions" in lamdec_rec empty_rel_context n (* (nb_lam [na1:T1]...[nan:Tan]c) where c is not an abstraction * gives n (casts are ignored) *) let nb_lam = let rec nbrec n c = match kind_of_term c with | Lambda (_,_,c) -> nbrec (n+1) c | Cast (c,_,_) -> nbrec n c | _ -> n in nbrec 0 (* similar to nb_lam, but gives the number of products instead *) let nb_prod = let rec nbrec n c = match kind_of_term c with | Prod (_,_,c) -> nbrec (n+1) c | Cast (c,_,_) -> nbrec n c | _ -> n in nbrec 0 let prod_assum t = fst (decompose_prod_assum t) let prod_n_assum n t = fst (decompose_prod_n_assum n t) let strip_prod_assum t = snd (decompose_prod_assum t) let strip_prod t = snd (decompose_prod t) let strip_prod_n n t = snd (decompose_prod_n n t) let lam_assum t = fst (decompose_lam_assum t) let lam_n_assum n t = fst (decompose_lam_n_assum n t) let strip_lam_assum t = snd (decompose_lam_assum t) let strip_lam t = snd (decompose_lam t) let strip_lam_n n t = snd (decompose_lam_n n t) (***************************) (* Arities *) (***************************) (* An "arity" is a term of the form [[x1:T1]...[xn:Tn]s] with [s] a sort. Such a term can canonically be seen as the pair of a context of types and of a sort *) type arity = rel_context * sorts let destArity = let rec prodec_rec l c = match kind_of_term c with | Prod (x,t,c) -> prodec_rec ((x,None,t)::l) c | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c | Cast (c,_,_) -> prodec_rec l c | Sort s -> l,s | _ -> anomaly "destArity: not an arity" in prodec_rec [] let mkArity (sign,s) = it_mkProd_or_LetIn (mkSort s) sign let rec isArity c = match kind_of_term c with | Prod (_,_,c) -> isArity c | LetIn (_,b,_,c) -> isArity (subst1 b c) | Cast (c,_,_) -> isArity c | Sort _ -> true | _ -> false (*******************) (* hash-consing *) (*******************) (* Hash-consing of [constr] does not use the module [Hashcons] because [Hashcons] is not efficient on deep tree-like data structures. Indeed, [Hashcons] is based the (very efficient) generic hash function [Hashtbl.hash], which computes the hash key through a depth bounded traversal of the data structure to be hashed. As a consequence, for a deep [constr] like the natural number 1000 (S (S (... (S O)))), the same hash is assigned to all the sub [constr]s greater than the maximal depth handled by [Hashtbl.hash]. This entails a huge number of collisions in the hash table and leads to cubic hash-consing in this worst-case. In order to compute a hash key that is independent of the data structure depth while being constant-time, an incremental hashing function must be devised. A standard implementation creates a cache of the hashing function by decorating each node of the hash-consed data structure with its hash key. In that case, the hash function can deduce the hash key of a toplevel data structure by a local computation based on the cache held on its substructures. Unfortunately, this simple implementation introduces a space overhead that is damageable for the hash-consing of small [constr]s (the most common case). One can think of an heterogeneous distribution of caches on smartly chosen nodes, but this is forbidden by the use of generic equality in Coq source code. (Indeed, this forces each [constr] to have a unique canonical representation.) Given that hash-consing proceeds inductively, we can nonetheless computes the hash key incrementally during hash-consing by changing a little the signature of the hash-consing function: it now returns both the hash-consed term and its hash key. This simple solution is implemented in the following code: it does not introduce a space overhead in [constr], that's why the efficiency is unchanged for small [constr]s. Besides, it does handle deep [constr]s without introducing an unreasonable number of collisions in the hash table. Some benchmarks make us think that this implementation of hash-consing is linear in the size of the hash-consed data structure for our daily use of Coq. *) let array_eqeq t1 t2 = t1 == t2 || (Array.length t1 = Array.length t2 && let rec aux i = (i = Array.length t1) || (t1.(i) == t2.(i) && aux (i + 1)) in aux 0) let equals_constr t1 t2 = match t1, t2 with | Rel n1, Rel n2 -> n1 == n2 | Meta m1, Meta m2 -> m1 == m2 | Var id1, Var id2 -> id1 == id2 | Sort s1, Sort s2 -> s1 == s2 | Cast (c1,k1,t1), Cast (c2,k2,t2) -> c1 == c2 & k1 == k2 & t1 == t2 | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2 | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2 | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) -> n1 == n2 & b1 == b2 & t1 == t2 & c1 == c2 | App (c1,l1), App (c2,l2) -> c1 == c2 & array_eqeq l1 l2 | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_eqeq l1 l2 | Const c1, Const c2 -> c1 == c2 | Ind (sp1,i1), Ind (sp2,i2) -> sp1 == sp2 & i1 = i2 | Construct ((sp1,i1),j1), Construct ((sp2,i2),j2) -> sp1 == sp2 & i1 = i2 & j1 = j2 | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) -> ci1 == ci2 & p1 == p2 & c1 == c2 & array_eqeq bl1 bl2 | Fix (ln1,(lna1,tl1,bl1)), Fix (ln2,(lna2,tl2,bl2)) -> ln1 = ln2 & array_eqeq lna1 lna2 & array_eqeq tl1 tl2 & array_eqeq bl1 bl2 | CoFix(ln1,(lna1,tl1,bl1)), CoFix(ln2,(lna2,tl2,bl2)) -> ln1 = ln2 & array_eqeq lna1 lna2 & array_eqeq tl1 tl2 & array_eqeq bl1 bl2 | _ -> false (** Note that the following Make has the side effect of creating once and for all the table we'll use for hash-consing all constr *) module H = Hashtbl_alt.Make(struct type t = constr let equals = equals_constr end) open Hashtbl_alt.Combine (* [hcons_term hash_consing_functions constr] computes an hash-consed representation for [constr] using [hash_consing_functions] on leaves. *) let hcons_term (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = (* Note : we hash-cons constr arrays *in place* *) let rec hash_term_array t = let accu = ref 0 in for i = 0 to Array.length t - 1 do let x, h = sh_rec t.(i) in accu := combine !accu h; t.(i) <- x done; !accu and hash_term t = match t with | Var i -> (Var (sh_id i), combinesmall 1 (Hashtbl.hash i)) | Sort s -> (Sort (sh_sort s), combinesmall 2 (Hashtbl.hash s)) | Cast (c, k, t) -> let c, hc = sh_rec c in let t, ht = sh_rec t in (Cast (c, k, t), combinesmall 3 (combine3 hc (Hashtbl.hash k) ht)) | Prod (na,t,c) -> let t, ht = sh_rec t and c, hc = sh_rec c in (Prod (sh_na na, t, c), combinesmall 4 (combine3 (Hashtbl.hash na) ht hc)) | Lambda (na,t,c) -> let t, ht = sh_rec t and c, hc = sh_rec c in (Lambda (sh_na na, t, c), combinesmall 5 (combine3 (Hashtbl.hash na) ht hc)) | LetIn (na,b,t,c) -> let b, hb = sh_rec b in let t, ht = sh_rec t in let c, hc = sh_rec c in (LetIn (sh_na na, b, t, c), combinesmall 6 (combine4 (Hashtbl.hash na) hb ht hc)) | App (c,l) -> let c, hc = sh_rec c in let hl = hash_term_array l in (App (c, l), combinesmall 7 (combine hl hc)) | Evar (e,l) -> let hl = hash_term_array l in (* since the array have been hashed in place : *) (t, combinesmall 8 (combine (Hashtbl.hash e) hl)) | Const c -> (Const (sh_con c), combinesmall 9 (Hashtbl.hash c)) | Ind ((kn,i) as ind) -> (Ind (sh_ind ind), combinesmall 9 (combine (Hashtbl.hash kn) i)) | Construct (((kn,i),j) as c)-> (Construct (sh_construct c), combinesmall 10 (combine3 (Hashtbl.hash kn) i j)) | Case (ci,p,c,bl) -> let p, hp = sh_rec p and c, hc = sh_rec c in let hbl = hash_term_array bl in let hbl = combine (combine hc hp) hbl in (Case (sh_ci ci, p, c, bl), combinesmall 11 hbl) | Fix (ln,(lna,tl,bl)) -> let hbl = hash_term_array bl in let htl = hash_term_array tl in Array.iteri (fun i x -> lna.(i) <- sh_na x) lna; (* since the three arrays have been hashed in place : *) (t, combinesmall 13 (combine (Hashtbl.hash lna) (combine hbl htl))) | CoFix(ln,(lna,tl,bl)) -> let hbl = hash_term_array bl in let htl = hash_term_array tl in Array.iteri (fun i x -> lna.(i) <- sh_na x) lna; (* since the three arrays have been hashed in place : *) (t, combinesmall 14 (combine (Hashtbl.hash lna) (combine hbl htl))) | Meta n -> (t, combinesmall 15 n) | Rel n -> (t, combinesmall 16 n) and sh_rec t = let (y, h) = hash_term t in (* [h] must be positive. *) let h = h land 0x3FFFFFFF in (H.may_add_and_get h y, h) in (* Make sure our statically allocated Rels (1 to 16) are considered as canonical, and hence hash-consed to themselves *) ignore (hash_term_array rels); fun t -> fst (sh_rec t) (* Exported hashing fonction on constr, used mainly in plugins. Appears to have slight differences from [snd (hash_term t)] above ? *) let rec hash_constr t = match kind_of_term t with | Var i -> combinesmall 1 (Hashtbl.hash i) | Sort s -> combinesmall 2 (Hashtbl.hash s) | Cast (c, _, _) -> hash_constr c | Prod (_, t, c) -> combinesmall 4 (combine (hash_constr t) (hash_constr c)) | Lambda (_, t, c) -> combinesmall 5 (combine (hash_constr t) (hash_constr c)) | LetIn (_, b, t, c) -> combinesmall 6 (combine3 (hash_constr b) (hash_constr t) (hash_constr c)) | App (c,l) when isCast c -> hash_constr (mkApp (pi1 (destCast c),l)) | App (c,l) -> combinesmall 7 (combine (hash_term_array l) (hash_constr c)) | Evar (e,l) -> combinesmall 8 (combine (Hashtbl.hash e) (hash_term_array l)) | Const c -> combinesmall 9 (Hashtbl.hash c) (* TODO: proper hash function for constants *) | Ind (kn,i) -> combinesmall 9 (combine (Hashtbl.hash kn) i) | Construct ((kn,i),j) -> combinesmall 10 (combine3 (Hashtbl.hash kn) i j) | Case (_ , p, c, bl) -> combinesmall 11 (combine3 (hash_constr c) (hash_constr p) (hash_term_array bl)) | Fix (ln ,(_, tl, bl)) -> combinesmall 13 (combine (hash_term_array bl) (hash_term_array tl)) | CoFix(ln, (_, tl, bl)) -> combinesmall 14 (combine (hash_term_array bl) (hash_term_array tl)) | Meta n -> combinesmall 15 n | Rel n -> combinesmall 16 n and hash_term_array t = Array.fold_left (fun acc t -> combine (hash_constr t) acc) 0 t module Hsorts = Hashcons.Make( struct type t = sorts type u = universe -> universe let hash_sub huniv = function Prop c -> Prop c | Type u -> Type (huniv u) let equal s1 s2 = match (s1,s2) with (Prop c1, Prop c2) -> c1=c2 | (Type u1, Type u2) -> u1 == u2 |_ -> false let hash = Hashtbl.hash end) module Hcaseinfo = Hashcons.Make( struct type t = case_info type u = inductive -> inductive let hash_sub hind ci = { ci with ci_ind = hind ci.ci_ind } let equal ci ci' = ci.ci_ind == ci'.ci_ind && ci.ci_npar = ci'.ci_npar && ci.ci_cstr_ndecls = ci'.ci_cstr_ndecls && (* we use (=) on purpose *) ci.ci_pp_info = ci'.ci_pp_info (* we use (=) on purpose *) let hash = Hashtbl.hash end) let hcons_sorts = Hashcons.simple_hcons Hsorts.f hcons_univ let hcons_caseinfo = Hashcons.simple_hcons Hcaseinfo.f hcons_ind let hcons_constr = hcons_term (hcons_sorts, hcons_caseinfo, hcons_construct, hcons_ind, hcons_con, hcons_name, hcons_ident) let hcons_types = hcons_constr (*******) (* Type of abstract machine values *) type values coq-8.4pl4/kernel/vconv.ml0000644000175000017500000001731012326224777014602 0ustar stephstephopen Names open Declarations open Term open Environ open Conv_oracle open Reduction open Closure open Vm open Csymtable open Univ let val_of_constr env c = val_of_constr (pre_env env) c (* Test la structure des piles *) let compare_zipper z1 z2 = match z1, z2 with | Zapp args1, Zapp args2 -> nargs args1 = nargs args2 | Zfix(f1,args1), Zfix(f2,args2) -> nargs args1 = nargs args2 | Zswitch _, Zswitch _ -> true | _ , _ -> false let rec compare_stack stk1 stk2 = match stk1, stk2 with | [], [] -> true | z1::stk1, z2::stk2 -> if compare_zipper z1 z2 then compare_stack stk1 stk2 else false | _, _ -> false (* Conversion *) let conv_vect fconv vect1 vect2 cu = let n = Array.length vect1 in if n = Array.length vect2 then let rcu = ref cu in for i = 0 to n - 1 do rcu := fconv vect1.(i) vect2.(i) !rcu done; !rcu else raise NotConvertible let infos = ref (create_clos_infos betaiotazeta Environ.empty_env) let rec conv_val pb k v1 v2 cu = if v1 == v2 then cu else conv_whd pb k (whd_val v1) (whd_val v2) cu and conv_whd pb k whd1 whd2 cu = match whd1, whd2 with | Vsort s1, Vsort s2 -> sort_cmp pb s1 s2 cu | Vprod p1, Vprod p2 -> let cu = conv_val CONV k (dom p1) (dom p2) cu in conv_fun pb k (codom p1) (codom p2) cu | Vfun f1, Vfun f2 -> conv_fun CONV k f1 f2 cu | Vfix (f1,None), Vfix (f2,None) -> conv_fix k f1 f2 cu | Vfix (f1,Some args1), Vfix(f2,Some args2) -> if nargs args1 <> nargs args2 then raise NotConvertible else conv_arguments k args1 args2 (conv_fix k f1 f2 cu) | Vcofix (cf1,_,None), Vcofix (cf2,_,None) -> conv_cofix k cf1 cf2 cu | Vcofix (cf1,_,Some args1), Vcofix (cf2,_,Some args2) -> if nargs args1 <> nargs args2 then raise NotConvertible else conv_arguments k args1 args2 (conv_cofix k cf1 cf2 cu) | Vconstr_const i1, Vconstr_const i2 -> if i1 = i2 then cu else raise NotConvertible | Vconstr_block b1, Vconstr_block b2 -> let sz = bsize b1 in if btag b1 = btag b2 && sz = bsize b2 then let rcu = ref cu in for i = 0 to sz - 1 do rcu := conv_val CONV k (bfield b1 i) (bfield b2 i) !rcu done; !rcu else raise NotConvertible | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> conv_atom pb k a1 stk1 a2 stk2 cu | Vfun _, _ | _, Vfun _ -> conv_val CONV (k+1) (eta_whd k whd1) (eta_whd k whd2) cu | _, Vatom_stk(Aiddef(_,v),stk) -> conv_whd pb k whd1 (force_whd v stk) cu | Vatom_stk(Aiddef(_,v),stk), _ -> conv_whd pb k (force_whd v stk) whd2 cu | _, _ -> raise NotConvertible and conv_atom pb k a1 stk1 a2 stk2 cu = match a1, a2 with | Aind (kn1,i1), Aind(kn2,i2) -> if eq_ind (kn1,i1) (kn2,i2) && compare_stack stk1 stk2 then conv_stack k stk1 stk2 cu else raise NotConvertible | Aid ik1, Aid ik2 -> if ik1 = ik2 && compare_stack stk1 stk2 then conv_stack k stk1 stk2 cu else raise NotConvertible | Aiddef(ik1,v1), Aiddef(ik2,v2) -> begin try if eq_table_key ik1 ik2 && compare_stack stk1 stk2 then conv_stack k stk1 stk2 cu else raise NotConvertible with NotConvertible -> if oracle_order false ik1 ik2 then conv_whd pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu else conv_whd pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu end | Aiddef(ik1,v1), _ -> conv_whd pb k (force_whd v1 stk1) (Vatom_stk(a2,stk2)) cu | _, Aiddef(ik2,v2) -> conv_whd pb k (Vatom_stk(a1,stk1)) (force_whd v2 stk2) cu | _, _ -> raise NotConvertible and conv_stack k stk1 stk2 cu = match stk1, stk2 with | [], [] -> cu | Zapp args1 :: stk1, Zapp args2 :: stk2 -> conv_stack k stk1 stk2 (conv_arguments k args1 args2 cu) | Zfix(f1,args1) :: stk1, Zfix(f2,args2) :: stk2 -> conv_stack k stk1 stk2 (conv_arguments k args1 args2 (conv_fix k f1 f2 cu)) | Zswitch sw1 :: stk1, Zswitch sw2 :: stk2 -> if check_switch sw1 sw2 then let vt1,vt2 = type_of_switch sw1, type_of_switch sw2 in let rcu = ref (conv_val CONV k vt1 vt2 cu) in let b1, b2 = branch_of_switch k sw1, branch_of_switch k sw2 in for i = 0 to Array.length b1 - 1 do rcu := conv_val CONV (k + fst b1.(i)) (snd b1.(i)) (snd b2.(i)) !rcu done; conv_stack k stk1 stk2 !rcu else raise NotConvertible | _, _ -> raise NotConvertible and conv_fun pb k f1 f2 cu = if f1 == f2 then cu else let arity,b1,b2 = decompose_vfun2 k f1 f2 in conv_val pb (k+arity) b1 b2 cu and conv_fix k f1 f2 cu = if f1 == f2 then cu else if check_fix f1 f2 then let bf1, tf1 = reduce_fix k f1 in let bf2, tf2 = reduce_fix k f2 in let cu = conv_vect (conv_val CONV k) tf1 tf2 cu in conv_vect (conv_fun CONV (k + Array.length tf1)) bf1 bf2 cu else raise NotConvertible and conv_cofix k cf1 cf2 cu = if cf1 == cf2 then cu else if check_cofix cf1 cf2 then let bcf1, tcf1 = reduce_cofix k cf1 in let bcf2, tcf2 = reduce_cofix k cf2 in let cu = conv_vect (conv_val CONV k) tcf1 tcf2 cu in conv_vect (conv_val CONV (k + Array.length tcf1)) bcf1 bcf2 cu else raise NotConvertible and conv_arguments k args1 args2 cu = if args1 == args2 then cu else let n = nargs args1 in if n = nargs args2 then let rcu = ref cu in for i = 0 to n - 1 do rcu := conv_val CONV k (arg args1 i) (arg args2 i) !rcu done; !rcu else raise NotConvertible let rec conv_eq pb t1 t2 cu = if t1 == t2 then cu else match kind_of_term t1, kind_of_term t2 with | Rel n1, Rel n2 -> if n1 = n2 then cu else raise NotConvertible | Meta m1, Meta m2 -> if m1 = m2 then cu else raise NotConvertible | Var id1, Var id2 -> if id1 = id2 then cu else raise NotConvertible | Sort s1, Sort s2 -> sort_cmp pb s1 s2 cu | Cast (c1,_,_), _ -> conv_eq pb c1 t2 cu | _, Cast (c2,_,_) -> conv_eq pb t1 c2 cu | Prod (_,t1,c1), Prod (_,t2,c2) -> conv_eq pb c1 c2 (conv_eq CONV t1 t2 cu) | Lambda (_,t1,c1), Lambda (_,t2,c2) -> conv_eq CONV c1 c2 cu | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> conv_eq pb c1 c2 (conv_eq CONV b1 b2 cu) | App (c1,l1), App (c2,l2) -> conv_eq_vect l1 l2 (conv_eq CONV c1 c2 cu) | Evar (e1,l1), Evar (e2,l2) -> if e1 = e2 then conv_eq_vect l1 l2 cu else raise NotConvertible | Const c1, Const c2 -> if eq_constant c1 c2 then cu else raise NotConvertible | Ind c1, Ind c2 -> if eq_ind c1 c2 then cu else raise NotConvertible | Construct c1, Construct c2 -> if eq_constructor c1 c2 then cu else raise NotConvertible | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> let pcu = conv_eq CONV p1 p2 cu in let ccu = conv_eq CONV c1 c2 pcu in conv_eq_vect bl1 bl2 ccu | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu) else raise NotConvertible | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu) else raise NotConvertible | _ -> raise NotConvertible and conv_eq_vect vt1 vt2 cu = let len = Array.length vt1 in if len = Array.length vt2 then let rcu = ref cu in for i = 0 to len-1 do rcu := conv_eq CONV vt1.(i) vt2.(i) !rcu done; !rcu else raise NotConvertible let vconv pb env t1 t2 = let cu = try conv_eq pb t1 t2 empty_constraint with NotConvertible -> infos := create_clos_infos betaiotazeta env; let v1 = val_of_constr env t1 in let v2 = val_of_constr env t2 in let cu = conv_val pb (nb_rel env) v1 v2 empty_constraint in cu in cu let _ = Reduction.set_vm_conv vconv let use_vm = ref false let set_use_vm b = use_vm := b; if b then Reduction.set_default_conv (fun cv_pb ?(l2r=false) -> vconv cv_pb) else Reduction.set_default_conv (fun cv_pb ?(l2r=false) -> Reduction.conv_cmp cv_pb) let use_vm _ = !use_vm coq-8.4pl4/kernel/conv_oracle.ml0000644000175000017500000000455712326224777015752 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (try Idmap.find id !var_opacity with Not_found -> default) | ConstKey c -> (try Cmap.find c !cst_opacity with Not_found -> default) | RelKey _ -> Expand let set_strategy k l = match k with | VarKey id -> var_opacity := if l=default then Idmap.remove id !var_opacity else Idmap.add id l !var_opacity | ConstKey c -> cst_opacity := if l=default then Cmap.remove c !cst_opacity else Cmap.add c l !cst_opacity | RelKey _ -> Util.error "set_strategy: RelKey" let get_transp_state () = (Idmap.fold (fun id l ts -> if l=Opaque then Idpred.remove id ts else ts) !var_opacity Idpred.full, Cmap.fold (fun c l ts -> if l=Opaque then Cpred.remove c ts else ts) !cst_opacity Cpred.full) (* Unfold the first constant only if it is "more transparent" than the second one. In case of tie, expand the second one. *) let oracle_order l2r k1 k2 = match get_strategy k1, get_strategy k2 with | Expand, _ -> true | Level n1, Opaque -> true | Level n1, Level n2 -> n1 < n2 | _ -> l2r (* use recommended default *) (* summary operations *) let init() = (cst_opacity := Cmap.empty; var_opacity := Idmap.empty) let freeze () = (!var_opacity, !cst_opacity) let unfreeze (vo,co) = (cst_opacity := co; var_opacity := vo) coq-8.4pl4/kernel/sign.ml0000644000175000017500000000557212326224777014416 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* decl | _ :: sign -> lookup_named id sign | [] -> raise Not_found let named_context_length = List.length let named_context_equal = list_equal eq_named_declaration let vars_of_named_context = List.map (fun (id,_,_) -> id) let instance_from_named_context sign = let rec inst_rec = function | (id,None,_) :: sign -> mkVar id :: inst_rec sign | _ :: sign -> inst_rec sign | [] -> [] in Array.of_list (inst_rec sign) let fold_named_context f l ~init = List.fold_right f l init let fold_named_context_reverse f ~init l = List.fold_left f init l (*s Signatures of ordered section variables *) type section_context = named_context let fold_rel_context f l ~init:x = List.fold_right f l x let fold_rel_context_reverse f ~init:x l = List.fold_left f x l let map_context f l = let map_decl (n, body_o, typ as decl) = let body_o' = Option.smartmap f body_o in let typ' = f typ in if body_o' == body_o && typ' == typ then decl else (n, body_o', typ') in list_smartmap map_decl l let map_rel_context = map_context let map_named_context = map_context let iter_rel_context f = List.iter (fun (_,b,t) -> f t; Option.iter f b) let iter_named_context f = List.iter (fun (_,b,t) -> f t; Option.iter f b) (* Push named declarations on top of a rel context *) (* Bizarre. Should be avoided. *) let push_named_to_rel_context hyps ctxt = let rec push = function | (id,b,t) :: l -> let s, hyps = push l in let d = (Name id, Option.map (subst_vars s) b, subst_vars s t) in id::s, d::hyps | [] -> [],[] in let s, hyps = push hyps in let rec subst = function | d :: l -> let n, ctxt = subst l in (n+1), (map_rel_declaration (substn_vars n s) d)::ctxt | [] -> 1, hyps in snd (subst ctxt) coq-8.4pl4/kernel/pre_env.ml0000644000175000017500000000733712326224777015115 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* raise Not_found let env_of_rel n env = { env with env_rel_context = Util.list_skipn n env.env_rel_context; env_rel_val = Util.list_skipn n env.env_rel_val; env_nb_rel = env.env_nb_rel - n } (* Named context *) let push_named_context_val d (ctxt,vals) = let id,_,_ = d in let rval = ref VKnone in Sign.add_named_decl d ctxt, (id,rval)::vals exception ASSERT of rel_context let push_named d env = (* if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context); assert (env.env_rel_context = []); *) let id,body,_ = d in let rval = ref VKnone in { env with env_named_context = Sign.add_named_decl d env.env_named_context; env_named_vals = (id,rval):: env.env_named_vals } let lookup_named_val id env = snd(List.find (fun (id',_) -> id = id') env.env_named_vals) (* Warning all the names should be different *) let env_of_named id env = env (* Global constants *) let lookup_constant_key kn env = Cmap_env.find kn env.env_globals.env_constants let lookup_constant kn env = fst (Cmap_env.find kn env.env_globals.env_constants) (* Mutual Inductives *) let lookup_mind kn env = Mindmap_env.find kn env.env_globals.env_inductives coq-8.4pl4/kernel/cbytecodes.mli0000644000175000017500000001357512326224777015755 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t val reset_label_counter : unit -> unit end type instruction = | Klabel of Label.t | Kacc of int | Kenvacc of int | Koffsetclosure of int | Kpush | Kpop of int | Kpush_retaddr of Label.t | Kapply of int (** number of arguments *) | Kappterm of int * int (** number of arguments, slot size *) | Kreturn of int (** slot size *) | Kjump | Krestart | Kgrab of int (** number of arguments *) | Kgrabrec of int (** rec arg *) | Kclosure of Label.t * int (** label, number of free variables *) | Kclosurerec of int * int * Label.t array * Label.t array (** nb fv, init, lbl types, lbl bodies *) | Kclosurecofix of int * int * Label.t array * Label.t array (** nb fv, init, lbl types, lbl bodies *) | Kgetglobal of constant | Kconst of structured_constant | Kmakeblock of int * tag (** size, tag *) | Kmakeprod | Kmakeswitchblock of Label.t * Label.t * annot_switch * int | Kswitch of Label.t array * Label.t array (** consts,blocks *) | Kpushfields of int | Kfield of int | Ksetfield of int | Kstop | Ksequence of bytecodes * bytecodes (** spiwack: instructions concerning integers *) | Kbranch of Label.t (** jump to label, is it needed ? *) | Kaddint31 (** adds the int31 in the accu and the one ontop of the stack *) | Kaddcint31 (** makes the sum and keeps the carry *) | Kaddcarrycint31 (** sum +1, keeps the carry *) | Ksubint31 (** subtraction modulo *) | Ksubcint31 (** subtraction, keeps the carry *) | Ksubcarrycint31 (** subtraction -1, keeps the carry *) | Kmulint31 (** multiplication modulo *) | Kmulcint31 (** multiplication, result in two int31, for exact computation *) | Kdiv21int31 (** divides a double size integer (represented by an int31 in the accumulator and one on the top of the stack) by an int31. The result is a pair of the quotient and the rest. If the divisor is 0, it returns 0. *) | Kdivint31 (** euclidian division (returns a pair quotient,rest) *) | Kaddmuldivint31 (** generic operation for shifting and cycling. Takes 3 int31 i j and s, and returns x*2^s+y/(2^(31-s) *) | Kcompareint31 (** unsigned comparison of int31 cf COMPAREINT31 in kernel/byterun/coq_interp.c for more info *) | Khead0int31 (** Give the numbers of 0 in head of a in31*) | Ktail0int31 (** Give the numbers of 0 in tail of a in31 ie low bits *) | Kisconst of Label.t (** conditional jump *) | Kareconst of int*Label.t (** conditional jump *) | Kcompint31 (** dynamic compilation of int31 *) | Kdecompint31 (** dynamix decompilation of int31 /spiwack *) and bytecodes = instruction list type fv_elem = FVnamed of identifier | FVrel of int type fv = fv_elem array (** spiwack: this exception is expected to be raised by function expecting closed terms. *) exception NotClosed (*spiwack: both type have been moved from Cbytegen because I needed then for the retroknowledge *) type vm_env = { size : int; (** longueur de la liste [n] *) fv_rev : fv_elem list (** [fvn; ... ;fv1] *) } type comp_env = { nb_stack : int; (** nbre de variables sur la pile *) in_stack : int list; (** position dans la pile *) nb_rec : int; (** nbre de fonctions mutuellement *) (** recursives = nbr *) pos_rec : instruction list; (** instruction d'acces pour les variables *) (** de point fix ou de cofix *) offset : int; in_env : vm_env ref } val draw_instr : bytecodes -> unit (*spiwack: moved this here because I needed it for retroknowledge *) type block = | Bconstr of constr | Bstrconst of structured_constant | Bmakeblock of int * block array | Bconstruct_app of int * int * int * block array (** tag , nparams, arity *) | Bspecial of (comp_env -> block array -> int -> bytecodes -> bytecodes) * block array (** compilation function (see get_vm_constant_dynamic_info in retroknowledge.mli for more info) , argument array *) coq-8.4pl4/kernel/names.ml0000644000175000017500000003337112326224777014557 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* if f a b then raise Finded) m ; false with |Finded -> true let singleton k v = add k v empty end module Idpred = Predicate.Make(IdOrdered) (** {6 Various types based on identifiers } *) type name = Name of identifier | Anonymous type variable = identifier (** {6 Directory paths = section names paths } *) (** Dirpaths are lists of module identifiers. The actual representation is reversed to optimise sharing: Coq.A.B is ["B";"A";"Coq"] *) type module_ident = identifier type dir_path = module_ident list module ModIdmap = Idmap let make_dirpath x = x let repr_dirpath x = x let empty_dirpath = [] (** Printing of directory paths as ["coq_root.module.submodule"] *) let string_of_dirpath = function | [] -> "<>" | sl -> String.concat "." (List.map string_of_id (List.rev sl)) (** {6 Unique names for bound modules } *) let u_number = ref 0 type uniq_ident = int * identifier * dir_path let make_uid dir s = incr u_number;(!u_number,s,dir) let debug_string_of_uid (i,s,p) = "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">" let string_of_uid (i,s,p) = string_of_dirpath p ^"."^s module Umap = Map.Make(struct type t = uniq_ident let compare = Pervasives.compare end) type mod_bound_id = uniq_ident let make_mbid = make_uid let repr_mbid (n, id, dp) = (n, id, dp) let debug_string_of_mbid = debug_string_of_uid let string_of_mbid = string_of_uid let id_of_mbid (_,s,_) = s (** {6 Names of structure elements } *) type label = identifier let mk_label = id_of_string let string_of_label = string_of_id let pr_label l = str (string_of_label l) let id_of_label l = l let label_of_id id = id module Labset = Idset module Labmap = Idmap (** {6 The module part of the kernel name } *) type module_path = | MPfile of dir_path | MPbound of mod_bound_id | MPdot of module_path * label let rec check_bound_mp = function | MPbound _ -> true | MPdot(mp,_) ->check_bound_mp mp | _ -> false let rec string_of_mp = function | MPfile sl -> string_of_dirpath sl | MPbound uid -> string_of_uid uid | MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l (** we compare labels first if both are MPdots *) let rec mp_ord mp1 mp2 = match (mp1,mp2) with MPdot(mp1,l1), MPdot(mp2,l2) -> let c = Pervasives.compare l1 l2 in if c<>0 then c else mp_ord mp1 mp2 | _,_ -> Pervasives.compare mp1 mp2 module MPord = struct type t = module_path let compare = mp_ord end module MPset = Set.Make(MPord) module MPmap = Map.Make(MPord) let default_module_name = "If you see this, it's a bug" let initial_dir = make_dirpath [default_module_name] let initial_path = MPfile initial_dir (** {6 Kernel names } *) type kernel_name = module_path * dir_path * label let make_kn mp dir l = (mp,dir,l) let repr_kn kn = kn let modpath kn = let mp,_,_ = repr_kn kn in mp let label kn = let _,_,l = repr_kn kn in l let string_of_kn (mp,dir,l) = let str_dir = if dir = [] then "." else "#" ^ string_of_dirpath dir ^ "#" in string_of_mp mp ^ str_dir ^ string_of_label l let pr_kn kn = str (string_of_kn kn) let kn_ord kn1 kn2 = let mp1,dir1,l1 = kn1 in let mp2,dir2,l2 = kn2 in let c = Pervasives.compare l1 l2 in if c <> 0 then c else let c = Pervasives.compare dir1 dir2 in if c<>0 then c else MPord.compare mp1 mp2 module KNord = struct type t = kernel_name let compare = kn_ord end module KNmap = Map.Make(KNord) module KNpred = Predicate.Make(KNord) module KNset = Set.Make(KNord) (** {6 Constant names } *) (** a constant name is a kernel name couple (kn1,kn2) where kn1 corresponds to the name used at toplevel (i.e. what the user see) and kn2 corresponds to the canonical kernel name i.e. in the environment we have kn1 \rhd_{\delta}^* kn2 \rhd_{\delta} t *) type constant = kernel_name*kernel_name let constant_of_kn kn = (kn,kn) let constant_of_kn_equiv kn1 kn2 = (kn1,kn2) let make_con mp dir l = constant_of_kn (mp,dir,l) let make_con_equiv mp1 mp2 dir l = if mp1 == mp2 then make_con mp1 dir l else ((mp1,dir,l),(mp2,dir,l)) let canonical_con con = snd con let user_con con = fst con let repr_con con = fst con let eq_constant (_,kn1) (_,kn2) = kn1=kn2 let con_label con = label (fst con) let con_modpath con = modpath (fst con) let string_of_con con = string_of_kn (fst con) let pr_con con = str (string_of_con con) let debug_string_of_con con = "(" ^ string_of_kn (fst con) ^ "," ^ string_of_kn (snd con) ^ ")" let debug_pr_con con = str (debug_string_of_con con) let con_with_label ((mp1,dp1,l1),(mp2,dp2,l2) as con) lbl = if lbl = l1 && lbl = l2 then con else ((mp1,dp1,lbl),(mp2,dp2,lbl)) (** For the environment we distinguish constants by their user part*) module User_ord = struct type t = kernel_name*kernel_name let compare x y= kn_ord (fst x) (fst y) end (** For other uses (ex: non-logical things) it is enough to deal with the canonical part *) module Canonical_ord = struct type t = kernel_name*kernel_name let compare x y= kn_ord (snd x) (snd y) end module Cmap = Map.Make(Canonical_ord) module Cmap_env = Map.Make(User_ord) module Cpred = Predicate.Make(Canonical_ord) module Cset = Set.Make(Canonical_ord) module Cset_env = Set.Make(User_ord) (** {6 Names of mutual inductive types } *) (** The same thing is done for mutual inductive names it replaces also the old mind_equiv field of mutual inductive types *) (** Beware: first inductive has index 0 *) (** Beware: first constructor has index 1 *) type mutual_inductive = kernel_name*kernel_name type inductive = mutual_inductive * int type constructor = inductive * int let mind_modpath mind = modpath (fst mind) let ind_modpath ind = mind_modpath (fst ind) let constr_modpath c = ind_modpath (fst c) let mind_of_kn kn = (kn,kn) let mind_of_kn_equiv kn1 kn2 = (kn1,kn2) let make_mind mp dir l = mind_of_kn (mp,dir,l) let make_mind_equiv mp1 mp2 dir l = if mp1 == mp2 then make_mind mp1 dir l else ((mp1,dir,l),(mp2,dir,l)) let canonical_mind mind = snd mind let user_mind mind = fst mind let repr_mind mind = fst mind let mind_label mind= label (fst mind) let eq_mind (_,kn1) (_,kn2) = kn1=kn2 let string_of_mind mind = string_of_kn (fst mind) let pr_mind mind = str (string_of_mind mind) let debug_string_of_mind mind = "(" ^ string_of_kn (fst mind) ^ "," ^ string_of_kn (snd mind) ^ ")" let debug_pr_mind con = str (debug_string_of_mind con) let ith_mutual_inductive (kn,_) i = (kn,i) let ith_constructor_of_inductive ind i = (ind,i) let inductive_of_constructor (ind,i) = ind let index_of_constructor (ind,i) = i let eq_ind (kn1,i1) (kn2,i2) = i1=i2&&eq_mind kn1 kn2 let eq_constructor (kn1,i1) (kn2,i2) = i1=i2&&eq_ind kn1 kn2 module Mindmap = Map.Make(Canonical_ord) module Mindset = Set.Make(Canonical_ord) module Mindmap_env = Map.Make(User_ord) module InductiveOrdered = struct type t = inductive let compare (spx,ix) (spy,iy) = let c = ix - iy in if c = 0 then Canonical_ord.compare spx spy else c end module InductiveOrdered_env = struct type t = inductive let compare (spx,ix) (spy,iy) = let c = ix - iy in if c = 0 then User_ord.compare spx spy else c end module Indmap = Map.Make(InductiveOrdered) module Indmap_env = Map.Make(InductiveOrdered_env) module ConstructorOrdered = struct type t = constructor let compare (indx,ix) (indy,iy) = let c = ix - iy in if c = 0 then InductiveOrdered.compare indx indy else c end module ConstructorOrdered_env = struct type t = constructor let compare (indx,ix) (indy,iy) = let c = ix - iy in if c = 0 then InductiveOrdered_env.compare indx indy else c end module Constrmap = Map.Make(ConstructorOrdered) module Constrmap_env = Map.Make(ConstructorOrdered_env) (* Better to have it here that in closure, since used in grammar.cma *) type evaluable_global_reference = | EvalVarRef of identifier | EvalConstRef of constant let eq_egr e1 e2 = match e1,e2 with EvalConstRef con1, EvalConstRef con2 -> eq_constant con1 con2 | _,_ -> e1 = e2 (** {6 Hash-consing of name objects } *) module Hname = Hashcons.Make( struct type t = name type u = identifier -> identifier let hash_sub hident = function | Name id -> Name (hident id) | n -> n let equal n1 n2 = match (n1,n2) with | (Name id1, Name id2) -> id1 == id2 | (Anonymous,Anonymous) -> true | _ -> false let hash = Hashtbl.hash end) module Hdir = Hashcons.Make( struct type t = dir_path type u = identifier -> identifier let hash_sub hident d = list_smartmap hident d let rec equal d1 d2 = match (d1,d2) with | [],[] -> true | id1::d1,id2::d2 -> id1 == id2 & equal d1 d2 | _ -> false let hash = Hashtbl.hash end) module Huniqid = Hashcons.Make( struct type t = uniq_ident type u = (identifier -> identifier) * (dir_path -> dir_path) let hash_sub (hid,hdir) (n,s,dir) = (n,hid s,hdir dir) let equal (n1,s1,dir1) (n2,s2,dir2) = n1 = n2 && s1 == s2 && dir1 == dir2 let hash = Hashtbl.hash end) module Hmod = Hashcons.Make( struct type t = module_path type u = (dir_path -> dir_path) * (uniq_ident -> uniq_ident) * (string -> string) let rec hash_sub (hdir,huniqid,hstr as hfuns) = function | MPfile dir -> MPfile (hdir dir) | MPbound m -> MPbound (huniqid m) | MPdot (md,l) -> MPdot (hash_sub hfuns md, hstr l) let rec equal d1 d2 = match (d1,d2) with | MPfile dir1, MPfile dir2 -> dir1 == dir2 | MPbound m1, MPbound m2 -> m1 == m2 | MPdot (mod1,l1), MPdot (mod2,l2) -> l1 == l2 && equal mod1 mod2 | _ -> false let hash = Hashtbl.hash end) module Hkn = Hashcons.Make( struct type t = kernel_name type u = (module_path -> module_path) * (dir_path -> dir_path) * (string -> string) let hash_sub (hmod,hdir,hstr) (md,dir,l) = (hmod md, hdir dir, hstr l) let equal (mod1,dir1,l1) (mod2,dir2,l2) = mod1 == mod2 && dir1 == dir2 && l1 == l2 let hash = Hashtbl.hash end) (** For [constant] and [mutual_inductive], we discriminate only on the user part : having the same user part implies having the same canonical part (invariant of the system). *) module Hcn = Hashcons.Make( struct type t = kernel_name*kernel_name type u = kernel_name -> kernel_name let hash_sub hkn (user,can) = (hkn user, hkn can) let equal (user1,_) (user2,_) = user1 == user2 let hash (user,_) = Hashtbl.hash user end) module Hind = Hashcons.Make( struct type t = inductive type u = mutual_inductive -> mutual_inductive let hash_sub hmind (mind, i) = (hmind mind, i) let equal (mind1,i1) (mind2,i2) = mind1 == mind2 && i1 = i2 let hash = Hashtbl.hash end) module Hconstruct = Hashcons.Make( struct type t = constructor type u = inductive -> inductive let hash_sub hind (ind, j) = (hind ind, j) let equal (ind1,j1) (ind2,j2) = ind1 == ind2 && j1 = j2 let hash = Hashtbl.hash end) let hcons_string = Hashcons.simple_hcons Hashcons.Hstring.f () let hcons_ident = hcons_string let hcons_name = Hashcons.simple_hcons Hname.f hcons_ident let hcons_dirpath = Hashcons.simple_hcons Hdir.f hcons_ident let hcons_uid = Hashcons.simple_hcons Huniqid.f (hcons_ident,hcons_dirpath) let hcons_mp = Hashcons.simple_hcons Hmod.f (hcons_dirpath,hcons_uid,hcons_string) let hcons_kn = Hashcons.simple_hcons Hkn.f (hcons_mp,hcons_dirpath,hcons_string) let hcons_con = Hashcons.simple_hcons Hcn.f hcons_kn let hcons_mind = Hashcons.simple_hcons Hcn.f hcons_kn let hcons_ind = Hashcons.simple_hcons Hind.f hcons_mind let hcons_construct = Hashcons.simple_hcons Hconstruct.f hcons_ind (*******) type transparent_state = Idpred.t * Cpred.t let empty_transparent_state = (Idpred.empty, Cpred.empty) let full_transparent_state = (Idpred.full, Cpred.full) let var_full_transparent_state = (Idpred.full, Cpred.empty) let cst_full_transparent_state = (Idpred.empty, Cpred.full) type 'a tableKey = | ConstKey of constant | VarKey of identifier | RelKey of 'a type inv_rel_key = int (* index in the [rel_context] part of environment starting by the end, {\em inverse} of de Bruijn indice *) type id_key = inv_rel_key tableKey let eq_id_key ik1 ik2 = match ik1,ik2 with ConstKey (_,kn1), ConstKey (_,kn2) -> kn1=kn2 | a,b -> a=b let eq_con_chk (kn1,_) (kn2,_) = kn1=kn2 let eq_mind_chk (kn1,_) (kn2,_) = kn1=kn2 let eq_ind_chk (kn1,i1) (kn2,i2) = i1=i2&&eq_mind_chk kn1 kn2 coq-8.4pl4/kernel/mod_typing.mli0000644000175000017500000000327212326224777015773 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* module_path -> inline -> module_entry -> module_body val translate_module_type : env -> module_path -> inline -> module_struct_entry -> module_type_body val translate_struct_module_entry : env -> module_path -> inline -> module_struct_entry -> struct_expr_body (* Signature *) * struct_expr_body option (* Algebraic expr, in fact never None *) * delta_resolver * Univ.constraints val translate_struct_type_entry : env -> inline -> module_struct_entry -> struct_expr_body * struct_expr_body option * delta_resolver * Univ.constraints val translate_struct_include_module_entry : env -> module_path -> inline -> module_struct_entry -> struct_expr_body * struct_expr_body option (* Algebraic expr, always None *) * delta_resolver * Univ.constraints val add_modtype_constraints : env -> module_type_body -> env val add_module_constraints : env -> module_body -> env val add_struct_expr_constraints : env -> struct_expr_body -> env val struct_expr_constraints : struct_expr_body -> Univ.constraints val module_constraints : module_body -> Univ.constraints coq-8.4pl4/kernel/inductive.ml0000644000175000017500000010407412326224777015445 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* = Array.length mib.mind_packets then error "Inductive.lookup_mind_specif: invalid inductive index"; (mib, mib.mind_packets.(tyi)) let find_rectype env c = let (t, l) = decompose_app (whd_betadeltaiota env c) in match kind_of_term t with | Ind ind -> (ind, l) | _ -> raise Not_found let find_inductive env c = let (t, l) = decompose_app (whd_betadeltaiota env c) in match kind_of_term t with | Ind ind when (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l) | _ -> raise Not_found let find_coinductive env c = let (t, l) = decompose_app (whd_betadeltaiota env c) in match kind_of_term t with | Ind ind when not (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l) | _ -> raise Not_found let inductive_params (mib,_) = mib.mind_nparams (************************************************************************) (* Build the substitution that replaces Rels by the appropriate *) (* inductives *) let ind_subst mind mib = let ntypes = mib.mind_ntypes in let make_Ik k = mkInd (mind,ntypes-k-1) in list_tabulate make_Ik ntypes (* Instantiate inductives in constructor type *) let constructor_instantiate mind mib c = let s = ind_subst mind mib in substl s c let instantiate_params full t args sign = let fail () = anomaly "instantiate_params: type, ctxt and args mismatch" in let (rem_args, subs, ty) = Sign.fold_rel_context (fun (_,copt,_) (largs,subs,ty) -> match (copt, largs, kind_of_term ty) with | (None, a::args, Prod(_,_,t)) -> (args, a::subs, t) | (Some b,_,LetIn(_,_,_,t)) -> (largs, (substl subs b)::subs, t) | (_,[],_) -> if full then fail() else ([], subs, ty) | _ -> fail ()) sign ~init:(args,[],t) in if rem_args <> [] then fail(); substl subs ty let full_inductive_instantiate mib params sign = let dummy = prop_sort in let t = mkArity (sign,dummy) in fst (destArity (instantiate_params true t params mib.mind_params_ctxt)) let full_constructor_instantiate ((mind,_),(mib,_),params) = let inst_ind = constructor_instantiate mind mib in (fun t -> instantiate_params true (inst_ind t) params mib.mind_params_ctxt) (************************************************************************) (************************************************************************) (* Functions to build standard types related to inductive *) (* Computing the actual sort of an applied or partially applied inductive type: I_i: forall uniformparams:utyps, forall otherparams:otyps, Type(a) uniformargs : utyps otherargs : otyps I_1:forall ...,s_1;...I_n:forall ...,s_n |- sort(C_kj(uniformargs)) = s_kj s'_k = max(..s_kj..) merge(..s'_k..) = ..s''_k.. -------------------------------------------------------------------- Gamma |- I_i uniformargs otherargs : phi(s''_i) where - if p=0, phi() = Prop - if p=1, phi(s) = s - if p<>1, phi(s) = sup(Set,s) Remark: Set (predicative) is encoded as Type(0) *) let sort_as_univ = function | Type u -> u | Prop Null -> type0m_univ | Prop Pos -> type0_univ let cons_subst u su subst = try (u, sup su (List.assoc u subst)) :: List.remove_assoc u subst with Not_found -> (u, su) :: subst let actualize_decl_level env lev t = let sign,s = dest_arity env t in mkArity (sign,lev) let polymorphism_on_non_applied_parameters = false (* Bind expected levels of parameters to actual levels *) (* Propagate the new levels in the signature *) let rec make_subst env = function | (_,Some _,_ as t)::sign, exp, args -> let ctx,subst = make_subst env (sign, exp, args) in t::ctx, subst | d::sign, None::exp, args -> let args = match args with _::args -> args | [] -> [] in let ctx,subst = make_subst env (sign, exp, args) in d::ctx, subst | d::sign, Some u::exp, a::args -> (* We recover the level of the argument, but we don't change the *) (* level in the corresponding type in the arity; this level in the *) (* arity is a global level which, at typing time, will be enforce *) (* to be greater than the level of the argument; this is probably *) (* a useless extra constraint *) let s = sort_as_univ (snd (dest_arity env a)) in let ctx,subst = make_subst env (sign, exp, args) in d::ctx, cons_subst u s subst | (na,None,t as d)::sign, Some u::exp, [] -> (* No more argument here: we instantiate the type with a fresh level *) (* which is first propagated to the corresponding premise in the arity *) (* (actualize_decl_level), then to the conclusion of the arity (via *) (* the substitution) *) let ctx,subst = make_subst env (sign, exp, []) in if polymorphism_on_non_applied_parameters then let s = fresh_local_univ () in let t = actualize_decl_level env (Type s) t in (na,None,t)::ctx, cons_subst u s subst else d::ctx, subst | sign, [], _ -> (* Uniform parameters are exhausted *) sign,[] | [], _, _ -> assert false let instantiate_universes env ctx ar argsorts = let args = Array.to_list argsorts in let ctx,subst = make_subst env (ctx,ar.poly_param_levels,args) in let level = subst_large_constraints subst ar.poly_level in ctx, (* Singleton type not containing types are interpretable in Prop *) if is_type0m_univ level then prop_sort (* Non singleton type not containing types are interpretable in Set *) else if is_type0_univ level then set_sort (* This is a Type with constraints *) else Type level exception SingletonInductiveBecomesProp of identifier let type_of_inductive_knowing_parameters ?(polyprop=true) env mip paramtyps = match mip.mind_arity with | Monomorphic s -> s.mind_user_arity | Polymorphic ar -> let ctx = List.rev mip.mind_arity_ctxt in let ctx,s = instantiate_universes env ctx ar paramtyps in (* The Ocaml extraction cannot handle (yet?) "Prop-polymorphism", i.e. the situation where a non-Prop singleton inductive becomes Prop when applied to Prop params *) if not polyprop && not (is_type0m_univ ar.poly_level) && s = prop_sort then raise (SingletonInductiveBecomesProp mip.mind_typename); mkArity (List.rev ctx,s) (* Type of a (non applied) inductive type *) let type_of_inductive env (_,mip) = type_of_inductive_knowing_parameters env mip [||] (* The max of an array of universes *) let cumulate_constructor_univ u = function | Prop Null -> u | Prop Pos -> sup type0_univ u | Type u' -> sup u u' let max_inductive_sort = Array.fold_left cumulate_constructor_univ type0m_univ (************************************************************************) (* Type of a constructor *) let type_of_constructor cstr (mib,mip) = let ind = inductive_of_constructor cstr in let specif = mip.mind_user_lc in let i = index_of_constructor cstr in let nconstr = Array.length mip.mind_consnames in if i > nconstr then error "Not enough constructors in the type."; constructor_instantiate (fst ind) mib specif.(i-1) let arities_of_specif kn (mib,mip) = let specif = mip.mind_nf_lc in Array.map (constructor_instantiate kn mib) specif let arities_of_constructors ind specif = arities_of_specif (fst ind) specif let type_of_constructors ind (mib,mip) = let specif = mip.mind_user_lc in Array.map (constructor_instantiate (fst ind) mib) specif (************************************************************************) (* Type of case predicates *) let local_rels ctxt = let (rels,_) = Sign.fold_rel_context_reverse (fun (rels,n) (_,copt,_) -> match copt with None -> (mkRel n :: rels, n+1) | Some _ -> (rels, n+1)) ~init:([],1) ctxt in rels (* Get type of inductive, with parameters instantiated *) let inductive_sort_family mip = match mip.mind_arity with | Monomorphic s -> family_of_sort s.mind_sort | Polymorphic _ -> InType let mind_arity mip = mip.mind_arity_ctxt, inductive_sort_family mip let get_instantiated_arity (mib,mip) params = let sign, s = mind_arity mip in full_inductive_instantiate mib params sign, s let elim_sorts (_,mip) = mip.mind_kelim let extended_rel_list n hyps = let rec reln l p = function | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps | (_,Some _,_) :: hyps -> reln l (p+1) hyps | [] -> l in reln [] 1 hyps let build_dependent_inductive ind (_,mip) params = let realargs,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in applist (mkInd ind, List.map (lift mip.mind_nrealargs_ctxt) params @ extended_rel_list 0 realargs) (* This exception is local *) exception LocalArity of (sorts_family * sorts_family * arity_error) option let check_allowed_sort ksort specif = if not (List.exists ((=) ksort) (elim_sorts specif)) then let s = inductive_sort_family (snd specif) in raise (LocalArity (Some(ksort,s,error_elim_explain ksort s))) let is_correct_arity env c pj ind specif params = let arsign,_ = get_instantiated_arity specif params in let rec srec env pt ar u = let pt' = whd_betadeltaiota env pt in match kind_of_term pt', ar with | Prod (na1,a1,t), (_,None,a1')::ar' -> let univ = try conv env a1 a1' with NotConvertible -> raise (LocalArity None) in srec (push_rel (na1,None,a1) env) t ar' (union_constraints u univ) (* The last Prod domain is the type of the scrutinee *) | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) let env' = push_rel (na1,None,a1) env in let ksort = match kind_of_term (whd_betadeltaiota env' a2) with | Sort s -> family_of_sort s | _ -> raise (LocalArity None) in let dep_ind = build_dependent_inductive ind specif params in let univ = try conv env a1 dep_ind with NotConvertible -> raise (LocalArity None) in check_allowed_sort ksort specif; union_constraints u univ | _, (_,Some _,_ as d)::ar' -> srec (push_rel d env) (lift 1 pt') ar' u | _ -> raise (LocalArity None) in try srec env pj.uj_type (List.rev arsign) empty_constraint with LocalArity kinds -> error_elim_arity env ind (elim_sorts specif) c pj kinds (************************************************************************) (* Type of case branches *) (* [p] is the predicate, [i] is the constructor number (starting from 0), and [cty] is the type of the constructor (params not instantiated) *) let build_branches_type ind (_,mip as specif) params p = let build_one_branch i cty = let typi = full_constructor_instantiate (ind,specif,params) cty in let (args,ccl) = decompose_prod_assum typi in let nargs = rel_context_length args in let (_,allargs) = decompose_app ccl in let (lparams,vargs) = list_chop (inductive_params specif) allargs in let cargs = let cstr = ith_constructor_of_inductive ind (i+1) in let dep_cstr = applist (mkConstruct cstr,lparams@(local_rels args)) in vargs @ [dep_cstr] in let base = beta_appvect (lift nargs p) (Array.of_list cargs) in it_mkProd_or_LetIn base args in Array.mapi build_one_branch mip.mind_nf_lc (* [p] is the predicate, [c] is the match object, [realargs] is the list of real args of the inductive type *) let build_case_type n p c realargs = whd_betaiota (betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) let type_case_branches env (ind,largs) pj c = let specif = lookup_mind_specif env ind in let nparams = inductive_params specif in let (params,realargs) = list_chop nparams largs in let p = pj.uj_val in let univ = is_correct_arity env c pj ind specif params in let lc = build_branches_type ind specif params p in let ty = build_case_type (snd specif).mind_nrealargs_ctxt p c realargs in (lc, ty, univ) (************************************************************************) (* Checking the case annotation is relevent *) let check_case_info env indsp ci = let (mib,mip) = lookup_mind_specif env indsp in if not (eq_ind indsp ci.ci_ind) or (mib.mind_nparams <> ci.ci_npar) or (mip.mind_consnrealdecls <> ci.ci_cstr_ndecls) then raise (TypeError(env,WrongCaseInfo(indsp,ci))) (************************************************************************) (************************************************************************) (* Guard conditions for fix and cofix-points *) (* Check if t is a subterm of Rel n, and gives its specification, assuming lst already gives index of subterms with corresponding specifications of recursive arguments *) (* A powerful notion of subterm *) (* To each inductive definition corresponds an array describing the structure of recursive arguments for each constructor, we call it the recursive spec of the type (it has type recargs vect). For checking the guard, we start from the decreasing argument (Rel n) with its recursive spec. During checking the guardness condition, we collect patterns variables corresponding to subterms of n, each of them with its recursive spec. They are organised in a list lst of type (int * recargs) list which is sorted with respect to the first argument. *) (*************************************************************) (* Environment annotated with marks on recursive arguments *) (* tells whether it is a strict or loose subterm *) type size = Large | Strict (* merging information *) let size_glb s1 s2 = match s1,s2 with Strict, Strict -> Strict | _ -> Large (* possible specifications for a term: - Not_subterm: when the size of a term is not related to the recursive argument of the fixpoint - Subterm: when the term is a subterm of the recursive argument the wf_paths argument specifies which subterms are recursive - Dead_code: when the term has been built by elimination over an empty type *) type subterm_spec = Subterm of (size * wf_paths) | Dead_code | Not_subterm let spec_of_tree t = lazy (if Rtree.eq_rtree (=) (Lazy.force t) mk_norec then Not_subterm else Subterm(Strict,Lazy.force t)) let subterm_spec_glb = let glb2 s1 s2 = match s1, s2 with s1, Dead_code -> s1 | Dead_code, s2 -> s2 | Not_subterm, _ -> Not_subterm | _, Not_subterm -> Not_subterm | Subterm (a1,t1), Subterm (a2,t2) -> if Rtree.eq_rtree (=) t1 t2 then Subterm (size_glb a1 a2, t1) (* branches do not return objects with same spec *) else Not_subterm in Array.fold_left glb2 Dead_code type guard_env = { env : env; (* dB of last fixpoint *) rel_min : int; (* dB of variables denoting subterms *) genv : subterm_spec Lazy.t list; } let make_renv env recarg (kn,tyi) = let mib = Environ.lookup_mind kn env in let mind_recvec = Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in { env = env; rel_min = recarg+2; genv = [Lazy.lazy_from_val(Subterm(Large,mind_recvec.(tyi)))] } let push_var renv (x,ty,spec) = { env = push_rel (x,None,ty) renv.env; rel_min = renv.rel_min+1; genv = spec:: renv.genv } let assign_var_spec renv (i,spec) = { renv with genv = list_assign renv.genv (i-1) spec } let push_var_renv renv (x,ty) = push_var renv (x,ty,lazy Not_subterm) (* Fetch recursive information about a variable p *) let subterm_var p renv = try Lazy.force (List.nth renv.genv (p-1)) with Failure _ | Invalid_argument _ -> Not_subterm let push_ctxt_renv renv ctxt = let n = rel_context_length ctxt in { env = push_rel_context ctxt renv.env; rel_min = renv.rel_min+n; genv = iterate (fun ge -> lazy Not_subterm::ge) n renv.genv } let push_fix_renv renv (_,v,_ as recdef) = let n = Array.length v in { env = push_rec_types recdef renv.env; rel_min = renv.rel_min+n; genv = iterate (fun ge -> lazy Not_subterm::ge) n renv.genv } (* Definition and manipulation of the stack *) type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t let push_stack_closures renv l stack = List.fold_right (fun h b -> (SClosure (renv,h))::b) l stack let push_stack_args l stack = List.fold_right (fun h b -> (SArg h)::b) l stack (******************************) (* {6 Computing the recursive subterms of a term (propagation of size information through Cases).} *) let lookup_subterms env ind = let (_,mip) = lookup_mind_specif env ind in mip.mind_recargs let match_inductive ind ra = match ra with | (Mrec i | Imbr i) -> eq_ind ind i | Norec -> false (* In {match c as z in ci y_s return P with |C_i x_s => t end} [branches_specif renv c_spec ci] returns an array of x_s specs knowing c_spec. *) let branches_specif renv c_spec ci = let car = (* We fetch the regular tree associated to the inductive of the match. This is just to get the number of constructors (and constructor arities) that fit the match branches without forcing c_spec. Note that c_spec might be more precise than [v] below, because of nested inductive types. *) let (_,mip) = lookup_mind_specif renv.env ci.ci_ind in let v = dest_subterms mip.mind_recargs in Array.map List.length v in Array.mapi (fun i nca -> (* i+1-th cstructor has arity nca *) let lvra = lazy (match Lazy.force c_spec with Subterm (_,t) when match_inductive ci.ci_ind (dest_recarg t) -> let vra = Array.of_list (dest_subterms t).(i) in assert (nca = Array.length vra); Array.map (fun t -> Lazy.force (spec_of_tree (lazy t))) vra | Dead_code -> Array.create nca Dead_code | _ -> Array.create nca Not_subterm) in list_tabulate (fun j -> lazy (Lazy.force lvra).(j)) nca) car (* [subterm_specif renv t] computes the recursive structure of [t] and compare its size with the size of the initial recursive argument of the fixpoint we are checking. [renv] collects such information about variables. *) let rec subterm_specif renv stack t = (* maybe reduction is not always necessary! *) let f,l = decompose_app (whd_betadeltaiota renv.env t) in match kind_of_term f with | Rel k -> subterm_var k renv | Case (ci,_,c,lbr) -> let stack' = push_stack_closures renv l stack in let cases_spec = branches_specif renv (lazy_subterm_specif renv [] c) ci in let stl = Array.mapi (fun i br' -> let stack_br = push_stack_args (cases_spec.(i)) stack' in subterm_specif renv stack_br br') lbr in subterm_spec_glb stl | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> (* when proving that the fixpoint f(x)=e is less than n, it is enough to prove that e is less than n assuming f is less than n furthermore when f is applied to a term which is strictly less than n, one may assume that x itself is strictly less than n *) let (ctxt,clfix) = dest_prod renv.env typarray.(i) in let oind = let env' = push_rel_context ctxt renv.env in try Some(fst(find_inductive env' clfix)) with Not_found -> None in (match oind with None -> Not_subterm (* happens if fix is polymorphic *) | Some ind -> let nbfix = Array.length typarray in let recargs = lookup_subterms renv.env ind in (* pushing the fixpoints *) let renv' = push_fix_renv renv recdef in let renv' = (* Why Strict here ? To be general, it could also be Large... *) assign_var_spec renv' (nbfix-i, lazy (Subterm(Strict,recargs))) in let decrArg = recindxs.(i) in let theBody = bodies.(i) in let nbOfAbst = decrArg+1 in let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in (* pushing the fix parameters *) let stack' = push_stack_closures renv l stack in let renv'' = push_ctxt_renv renv' sign in let renv'' = if List.length stack' < nbOfAbst then renv'' else let decrArg = List.nth stack' decrArg in let arg_spec = stack_element_specif decrArg in assign_var_spec renv'' (1, arg_spec) in subterm_specif renv'' [] strippedBody) | Lambda (x,a,b) -> assert (l=[]); let spec,stack' = extract_stack renv a stack in subterm_specif (push_var renv (x,a,spec)) stack' b (* Metas and evars are considered OK *) | (Meta _|Evar _) -> Dead_code (* Other terms are not subterms *) | _ -> Not_subterm and lazy_subterm_specif renv stack t = lazy (subterm_specif renv stack t) and stack_element_specif = function |SClosure (h_renv,h) -> lazy_subterm_specif h_renv [] h |SArg x -> x and extract_stack renv a = function | [] -> Lazy.lazy_from_val Not_subterm , [] | h::t -> stack_element_specif h, t (* Check term c can be applied to one of the mutual fixpoints. *) let check_is_subterm x = match Lazy.force x with Subterm (Strict,_) | Dead_code -> true | _ -> false (************************************************************************) exception FixGuardError of env * guard_error let error_illegal_rec_call renv fx (arg_renv,arg) = let (_,le_vars,lt_vars) = List.fold_left (fun (i,le,lt) sbt -> match Lazy.force sbt with (Subterm(Strict,_) | Dead_code) -> (i+1, le, i::lt) | (Subterm(Large,_)) -> (i+1, i::le, lt) | _ -> (i+1, le ,lt)) (1,[],[]) renv.genv in raise (FixGuardError (renv.env, RecursionOnIllegalTerm(fx,(arg_renv.env, arg), le_vars,lt_vars))) let error_partial_apply renv fx = raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx)) (* Check if [def] is a guarded fixpoint body with decreasing arg. given [recpos], the decreasing arguments of each mutually defined fixpoint. *) let check_one_fix renv recpos def = let nfi = Array.length recpos in (* Checks if [t] only make valid recursive calls [stack] is the list of constructor's argument specification and arguments than will be applied after reduction. example u in t where we have (match .. with |.. => t end) u *) let rec check_rec_call renv stack t = (* if [t] does not make recursive calls, it is guarded: *) if noccur_with_meta renv.rel_min nfi t then () else let (f,l) = decompose_app (whd_betaiotazeta t) in match kind_of_term f with | Rel p -> (* Test if [p] is a fixpoint (recursive call) *) if renv.rel_min <= p & p < renv.rel_min+nfi then begin List.iter (check_rec_call renv []) l; (* the position of the invoked fixpoint: *) let glob = renv.rel_min+nfi-1-p in (* the decreasing arg of the rec call: *) let np = recpos.(glob) in let stack' = push_stack_closures renv l stack in if List.length stack' <= np then error_partial_apply renv glob else (* Check the decreasing arg is smaller *) let z = List.nth stack' np in if not (check_is_subterm (stack_element_specif z)) then begin match z with |SClosure (z,z') -> error_illegal_rec_call renv glob (z,z') |SArg _ -> error_partial_apply renv glob end end else begin match pi2 (lookup_rel p renv.env) with | None -> List.iter (check_rec_call renv []) l | Some c -> try List.iter (check_rec_call renv []) l with FixGuardError _ -> check_rec_call renv stack (applist(lift p c,l)) end | Case (ci,p,c_0,lrest) -> List.iter (check_rec_call renv []) (c_0::p::l); (* compute the recarg information for the arguments of each branch *) let case_spec = branches_specif renv (lazy_subterm_specif renv [] c_0) ci in let stack' = push_stack_closures renv l stack in Array.iteri (fun k br' -> let stack_br = push_stack_args case_spec.(k) stack' in check_rec_call renv stack_br br') lrest (* Enables to traverse Fixpoint definitions in a more intelligent way, ie, the rule : if - g = fix g (y1:T1)...(yp:Tp) {struct yp} := e & - f is guarded with respect to the set of pattern variables S in a1 ... am & - f is guarded with respect to the set of pattern variables S in T1 ... Tp & - ap is a sub-term of the formal argument of f & - f is guarded with respect to the set of pattern variables S+{yp} in e then f is guarded with respect to S in (g a1 ... am). Eduardo 7/9/98 *) | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> List.iter (check_rec_call renv []) l; Array.iter (check_rec_call renv []) typarray; let decrArg = recindxs.(i) in let renv' = push_fix_renv renv recdef in let stack' = push_stack_closures renv l stack in Array.iteri (fun j body -> if i=j && (List.length stack' > decrArg) then let recArg = List.nth stack' decrArg in let arg_sp = stack_element_specif recArg in check_nested_fix_body renv' (decrArg+1) arg_sp body else check_rec_call renv' [] body) bodies | Const kn -> if evaluable_constant kn renv.env then try List.iter (check_rec_call renv []) l with (FixGuardError _ ) -> let value = (applist(constant_value renv.env kn, l)) in check_rec_call renv stack value else List.iter (check_rec_call renv []) l | Lambda (x,a,b) -> assert (l = []); check_rec_call renv [] a ; let spec, stack' = extract_stack renv a stack in check_rec_call (push_var renv (x,a,spec)) stack' b | Prod (x,a,b) -> assert (l = [] && stack = []); check_rec_call renv [] a; check_rec_call (push_var_renv renv (x,a)) [] b | CoFix (i,(_,typarray,bodies as recdef)) -> List.iter (check_rec_call renv []) l; Array.iter (check_rec_call renv []) typarray; let renv' = push_fix_renv renv recdef in Array.iter (check_rec_call renv' []) bodies | (Ind _ | Construct _) -> List.iter (check_rec_call renv []) l | Var id -> begin match pi2 (lookup_named id renv.env) with | None -> List.iter (check_rec_call renv []) l | Some c -> try List.iter (check_rec_call renv []) l with (FixGuardError _) -> check_rec_call renv stack (applist(c,l)) end | Sort _ -> assert (l = []) (* l is not checked because it is considered as the meta's context *) | (Evar _ | Meta _) -> () | (App _ | LetIn _ | Cast _) -> assert false (* beta zeta reduction *) and check_nested_fix_body renv decr recArgsDecrArg body = if decr = 0 then check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) [] body else match kind_of_term body with | Lambda (x,a,b) -> check_rec_call renv [] a; let renv' = push_var_renv renv (x,a) in check_nested_fix_body renv' (decr-1) recArgsDecrArg b | _ -> anomaly "Not enough abstractions in fix body" in check_rec_call renv [] def let judgment_of_fixpoint (_, types, bodies) = array_map2 (fun typ body -> { uj_val = body ; uj_type = typ }) types bodies let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = let nbfix = Array.length bodies in if nbfix = 0 or Array.length nvect <> nbfix or Array.length types <> nbfix or Array.length names <> nbfix or bodynum < 0 or bodynum >= nbfix then anomaly "Ill-formed fix term"; let fixenv = push_rec_types recdef env in let vdefj = judgment_of_fixpoint recdef in let raise_err env i err = error_ill_formed_rec_body env err names i fixenv vdefj in (* Check the i-th definition with recarg k *) let find_ind i k def = (* check fi does not appear in the k+1 first abstractions, gives the type of the k+1-eme abstraction (must be an inductive) *) let rec check_occur env n def = match kind_of_term (whd_betadeltaiota env def) with | Lambda (x,a,b) -> if noccur_with_meta n nbfix a then let env' = push_rel (x, None, a) env in if n = k+1 then (* get the inductive type of the fixpoint *) let (mind, _) = try find_inductive env a with Not_found -> raise_err env i (RecursionNotOnInductiveType a) in (mind, (env', b)) else check_occur env' (n+1) b else anomaly "check_one_fix: Bad occurrence of recursive call" | _ -> raise_err env i NotEnoughAbstractionInFixBody in check_occur fixenv 1 def in (* Do it on every fixpoint *) let rv = array_map2_i find_ind nvect bodies in (Array.map fst rv, Array.map snd rv) let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) = let (minds, rdef) = inductive_of_mutfix env fix in for i = 0 to Array.length bodies - 1 do let (fenv,body) = rdef.(i) in let renv = make_renv fenv nvect.(i) minds.(i) in try check_one_fix renv nvect body with FixGuardError (fixenv,err) -> error_ill_formed_rec_body fixenv err names i (push_rec_types recdef env) (judgment_of_fixpoint recdef) done (* let cfkey = Profile.declare_profile "check_fix";; let check_fix env fix = Profile.profile3 cfkey check_fix env fix;; *) (************************************************************************) (* Co-fixpoints. *) exception CoFixGuardError of env * guard_error let anomaly_ill_typed () = anomaly "check_one_cofix: too many arguments applied to constructor" let rec codomain_is_coind env c = let b = whd_betadeltaiota env c in match kind_of_term b with | Prod (x,a,b) -> codomain_is_coind (push_rel (x, None, a) env) b | _ -> (try find_coinductive env b with Not_found -> raise (CoFixGuardError (env, CodomainNotInductiveType b))) let check_one_cofix env nbfix def deftype = let rec check_rec_call env alreadygrd n vlra t = if not (noccur_with_meta n nbfix t) then let c,args = decompose_app (whd_betadeltaiota env t) in match kind_of_term c with | Rel p when n <= p && p < n+nbfix -> (* recursive call: must be guarded and no nested recursive call allowed *) if not alreadygrd then raise (CoFixGuardError (env,UnguardedRecursiveCall t)) else if not(List.for_all (noccur_with_meta n nbfix) args) then raise (CoFixGuardError (env,NestedRecursiveOccurrences)) | Construct (_,i as cstr_kn) -> let lra = vlra.(i-1) in let mI = inductive_of_constructor cstr_kn in let (mib,mip) = lookup_mind_specif env mI in let realargs = list_skipn mib.mind_nparams args in let rec process_args_of_constr = function | (t::lr), (rar::lrar) -> if rar = mk_norec then if noccur_with_meta n nbfix t then process_args_of_constr (lr, lrar) else raise (CoFixGuardError (env,RecCallInNonRecArgOfConstructor t)) else let spec = dest_subterms rar in check_rec_call env true n spec t; process_args_of_constr (lr, lrar) | [],_ -> () | _ -> anomaly_ill_typed () in process_args_of_constr (realargs, lra) | Lambda (x,a,b) -> assert (args = []); if noccur_with_meta n nbfix a then let env' = push_rel (x, None, a) env in check_rec_call env' alreadygrd (n+1) vlra b else raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a)) | CoFix (j,(_,varit,vdefs as recdef)) -> if List.for_all (noccur_with_meta n nbfix) args then if array_for_all (noccur_with_meta n nbfix) varit then let nbfix = Array.length vdefs in let env' = push_rec_types recdef env in (Array.iter (check_rec_call env' alreadygrd (n+nbfix) vlra) vdefs; List.iter (check_rec_call env alreadygrd n vlra) args) else raise (CoFixGuardError (env,RecCallInTypeOfDef c)) else raise (CoFixGuardError (env,UnguardedRecursiveCall c)) | Case (_,p,tm,vrest) -> if (noccur_with_meta n nbfix p) then if (noccur_with_meta n nbfix tm) then if (List.for_all (noccur_with_meta n nbfix) args) then Array.iter (check_rec_call env alreadygrd n vlra) vrest else raise (CoFixGuardError (env,RecCallInCaseFun c)) else raise (CoFixGuardError (env,RecCallInCaseArg c)) else raise (CoFixGuardError (env,RecCallInCasePred c)) | Meta _ -> () | Evar _ -> List.iter (check_rec_call env alreadygrd n vlra) args | _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in let (mind, _) = codomain_is_coind env deftype in let vlra = lookup_subterms env mind in check_rec_call env false 1 (dest_subterms vlra) def (* The function which checks that the whole block of definitions satisfies the guarded condition *) let check_cofix env (bodynum,(names,types,bodies as recdef)) = let nbfix = Array.length bodies in for i = 0 to nbfix-1 do let fixenv = push_rec_types recdef env in try check_one_cofix fixenv nbfix bodies.(i) types.(i) with CoFixGuardError (errenv,err) -> error_ill_formed_rec_body errenv err names i fixenv (judgment_of_fixpoint recdef) done coq-8.4pl4/kernel/environ.ml0000644000175000017500000004145112326224777015132 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | _ -> false let nb_rel env = env.env_nb_rel let push_rel = push_rel let push_rel_context ctxt x = Sign.fold_rel_context push_rel ctxt ~init:x let push_rec_types (lna,typarray,_) env = let ctxt = array_map2_i (fun i na t -> (na, None, lift i t)) lna typarray in Array.fold_left (fun e assum -> push_rel assum e) env ctxt let fold_rel_context f env ~init = let rec fold_right env = match env.env_rel_context with | [] -> init | rd::rc -> let env = { env with env_rel_context = rc; env_rel_val = List.tl env.env_rel_val; env_nb_rel = env.env_nb_rel - 1 } in f env rd (fold_right env) in fold_right env (* Named context *) let named_context_of_val = fst let named_vals_of_val = snd (* [map_named_val f ctxt] apply [f] to the body and the type of each declarations. *** /!\ *** [f t] should be convertible with t *) let map_named_val f (ctxt,ctxtv) = let ctxt = List.map (fun (id,body,typ) -> (id, Option.map f body, f typ)) ctxt in (ctxt,ctxtv) let empty_named_context = empty_named_context let push_named = push_named let push_named_context_val = push_named_context_val let val_of_named_context ctxt = List.fold_right push_named_context_val ctxt empty_named_context_val let lookup_named id env = Sign.lookup_named id env.env_named_context let lookup_named_val id (ctxt,_) = Sign.lookup_named id ctxt let eq_named_context_val c1 c2 = c1 == c2 || named_context_equal (named_context_of_val c1) (named_context_of_val c2) (* A local const is evaluable if it is defined *) let named_type id env = let (_,_,t) = lookup_named id env in t let named_body id env = let (_,b,_) = lookup_named id env in b let evaluable_named id env = match named_body id env with | Some _ -> true | _ -> false let reset_with_named_context (ctxt,ctxtv) env = { env with env_named_context = ctxt; env_named_vals = ctxtv; env_rel_context = empty_rel_context; env_rel_val = []; env_nb_rel = 0 } let reset_context = reset_with_named_context empty_named_context_val let fold_named_context f env ~init = let rec fold_right env = match env.env_named_context with | [] -> init | d::ctxt -> let env = reset_with_named_context (ctxt,List.tl env.env_named_vals) env in f env d (fold_right env) in fold_right env let fold_named_context_reverse f ~init env = Sign.fold_named_context_reverse f ~init:init (named_context env) (* Global constants *) let lookup_constant = lookup_constant let add_constant kn cs env = let new_constants = Cmap_env.add kn (cs,ref None) env.env_globals.env_constants in let new_globals = { env.env_globals with env_constants = new_constants } in { env with env_globals = new_globals } (* constant_type gives the type of a constant *) let constant_type env kn = let cb = lookup_constant kn env in cb.const_type type const_evaluation_result = NoBody | Opaque exception NotEvaluableConst of const_evaluation_result let constant_value env kn = let cb = lookup_constant kn env in match cb.const_body with | Def l_body -> Declarations.force l_body | OpaqueDef _ -> raise (NotEvaluableConst Opaque) | Undef _ -> raise (NotEvaluableConst NoBody) let constant_opt_value env cst = try Some (constant_value env cst) with NotEvaluableConst _ -> None (* A global const is evaluable if it is defined and not opaque *) let evaluable_constant cst env = try let _ = constant_value env cst in true with NotEvaluableConst _ -> false (* Mutual Inductives *) let lookup_mind = lookup_mind let add_mind kn mib env = let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in let new_globals = { env.env_globals with env_inductives = new_inds } in { env with env_globals = new_globals } (* Universe constraints *) let add_constraints c env = if is_empty_constraint c then env else let s = env.env_stratification in { env with env_stratification = { s with env_universes = merge_constraints c s.env_universes } } let set_engagement c env = (* Unsafe *) { env with env_stratification = { env.env_stratification with env_engagement = Some c } } (* Lookup of section variables *) let lookup_constant_variables c env = let cmap = lookup_constant c env in Sign.vars_of_named_context cmap.const_hyps let lookup_inductive_variables (kn,i) env = let mis = lookup_mind kn env in Sign.vars_of_named_context mis.mind_hyps let lookup_constructor_variables (ind,_) env = lookup_inductive_variables ind env (* Returns the list of global variables in a term *) let vars_of_global env constr = match kind_of_term constr with Var id -> [id] | Const kn -> lookup_constant_variables kn env | Ind ind -> lookup_inductive_variables ind env | Construct cstr -> lookup_constructor_variables cstr env | _ -> raise Not_found let global_vars_set env constr = let rec filtrec acc c = let acc = match kind_of_term c with | Var _ | Const _ | Ind _ | Construct _ -> List.fold_right Idset.add (vars_of_global env c) acc | _ -> acc in fold_constr filtrec acc c in filtrec Idset.empty constr (* [keep_hyps env ids] keeps the part of the section context of [env] which contains the variables of the set [ids], and recursively the variables contained in the types of the needed variables. *) let keep_hyps env needed = let really_needed = Sign.fold_named_context_reverse (fun need (id,copt,t) -> if Idset.mem id need then let globc = match copt with | None -> Idset.empty | Some c -> global_vars_set env c in Idset.union (global_vars_set env t) (Idset.union globc need) else need) ~init:needed (named_context env) in Sign.fold_named_context (fun (id,_,_ as d) nsign -> if Idset.mem id really_needed then add_named_decl d nsign else nsign) (named_context env) ~init:empty_named_context (* Modules *) let add_modtype ln mtb env = let new_modtypes = MPmap.add ln mtb env.env_globals.env_modtypes in let new_globals = { env.env_globals with env_modtypes = new_modtypes } in { env with env_globals = new_globals } let shallow_add_module mp mb env = let new_mods = MPmap.add mp mb env.env_globals.env_modules in let new_globals = { env.env_globals with env_modules = new_mods } in { env with env_globals = new_globals } let lookup_module mp env = MPmap.find mp env.env_globals.env_modules let lookup_modtype mp env = MPmap.find mp env.env_globals.env_modtypes (*s Judgments. *) type unsafe_judgment = { uj_val : constr; uj_type : types } let make_judge v tj = { uj_val = v; uj_type = tj } let j_val j = j.uj_val let j_type j = j.uj_type type unsafe_type_judgment = { utj_val : constr; utj_type : sorts } (*s Compilation of global declaration *) let compile_constant_body = Cbytegen.compile_constant_body exception Hyp_not_found let rec apply_to_hyp (ctxt,vals) id f = let rec aux rtail ctxt vals = match ctxt, vals with | (idc,c,ct as d)::ctxt, v::vals -> if idc = id then (f ctxt d rtail)::ctxt, v::vals else let ctxt',vals' = aux (d::rtail) ctxt vals in d::ctxt', v::vals' | [],[] -> raise Hyp_not_found | _, _ -> assert false in aux [] ctxt vals let rec apply_to_hyp_and_dependent_on (ctxt,vals) id f g = let rec aux ctxt vals = match ctxt,vals with | (idc,c,ct as d)::ctxt, v::vals -> if idc = id then let sign = ctxt,vals in push_named_context_val (f d sign) sign else let (ctxt,vals as sign) = aux ctxt vals in push_named_context_val (g d sign) sign | [],[] -> raise Hyp_not_found | _,_ -> assert false in aux ctxt vals let insert_after_hyp (ctxt,vals) id d check = let rec aux ctxt vals = match ctxt, vals with | (idc,c,ct)::ctxt', v::vals' -> if idc = id then begin check ctxt; push_named_context_val d (ctxt,vals) end else let ctxt,vals = aux ctxt vals in d::ctxt, v::vals | [],[] -> raise Hyp_not_found | _, _ -> assert false in aux ctxt vals (* To be used in Logic.clear_hyps *) let remove_hyps ids check_context check_value (ctxt, vals) = List.fold_right2 (fun (id,_,_ as d) (id',v) (ctxt,vals) -> if List.mem id ids then (ctxt,vals) else let nd = check_context d in let nv = check_value v in (nd::ctxt,(id',nv)::vals)) ctxt vals ([],[]) (*spiwack: the following functions assemble the pieces of the retroknowledge note that the "consistent" register function is available in the module Safetyping, Environ only synchronizes the proactive and the reactive parts*) open Retroknowledge (* lifting of the "get" functions works also for "mem"*) let retroknowledge f env = f env.retroknowledge let registered env field = retroknowledge mem env field (* spiwack: this unregistration function is not in operation yet. It should not be used *) (* this unregistration function assumes that no "constr" can hold two different places in the retroknowledge. There is no reason why it shouldn't be true, but in case someone needs it, remember to add special branches to the unregister function *) let unregister env field = match field with | KInt31 (_,Int31Type) -> (*there is only one matching kind due to the fact that Environ.env is abstract, and that the only function which add elements to the retroknowledge is Environ.register which enforces this shape *) (match retroknowledge find env field with | Ind i31t -> let i31c = Construct (i31t, 1) in {env with retroknowledge = remove (retroknowledge clear_info env i31c) field} | _ -> assert false) |_ -> {env with retroknowledge = try remove (retroknowledge clear_info env (retroknowledge find env field)) field with Not_found -> retroknowledge remove env field} (* the Environ.register function syncrhonizes the proactive and reactive retroknowledge. *) let register = (* subfunction used for static decompilation of int31 (after a vm_compute, see pretyping/vnorm.ml for more information) *) let constr_of_int31 = let nth_digit_plus_one i n = (* calculates the nth (starting with 0) digit of i and adds 1 to it (nth_digit_plus_one 1 3 = 2) *) if (land) i ((lsl) 1 n) = 0 then 1 else 2 in fun ind -> fun digit_ind -> fun tag -> let array_of_int i = Array.init 31 (fun n -> mkConstruct (digit_ind, nth_digit_plus_one i (30-n))) in mkApp(mkConstruct(ind, 1), array_of_int tag) in (* subfunction which adds the information bound to the constructor of the int31 type to the reactive retroknowledge *) let add_int31c retroknowledge c = let rk = add_vm_constant_static_info retroknowledge c Cbytegen.compile_structured_int31 in add_vm_constant_dynamic_info rk c Cbytegen.dynamic_int31_compilation in (* subfunction which adds the compiling information of an int31 operation which has a specific vm instruction (associates it to the name of the coq definition in the reactive retroknowledge) *) let add_int31_op retroknowledge v n op kn = add_vm_compiling_info retroknowledge v (Cbytegen.op_compilation n op kn) in fun env field value -> (* subfunction which shortens the (very often use) registration of binary operators to the reactive retroknowledge. *) let add_int31_binop_from_const op = match value with | Const kn -> retroknowledge add_int31_op env value 2 op kn | _ -> anomaly "Environ.register: should be a constant" in let add_int31_unop_from_const op = match value with | Const kn -> retroknowledge add_int31_op env value 1 op kn | _ -> anomaly "Environ.register: should be a constant" in (* subfunction which completes the function constr_of_int31 above by performing the actual retroknowledge operations *) let add_int31_decompilation_from_type rk = (* invariant : the type of bits is registered, otherwise the function would raise Not_found. The invariant is enforced in safe_typing.ml *) match field with | KInt31 (grp, Int31Type) -> (match Retroknowledge.find rk (KInt31 (grp,Int31Bits)) with | Ind i31bit_type -> (match value with | Ind i31t -> Retroknowledge.add_vm_decompile_constant_info rk value (constr_of_int31 i31t i31bit_type) | _ -> anomaly "Environ.register: should be an inductive type") | _ -> anomaly "Environ.register: Int31Bits should be an inductive type") | _ -> anomaly "Environ.register: add_int31_decompilation_from_type called with an abnormal field" in {env with retroknowledge = let retroknowledge_with_reactive_info = match field with | KInt31 (_, Int31Type) -> let i31c = match value with | Ind i31t -> (Construct (i31t, 1)) | _ -> anomaly "Environ.register: should be an inductive type" in add_int31_decompilation_from_type (add_vm_before_match_info (retroknowledge add_int31c env i31c) value Cbytegen.int31_escape_before_match) | KInt31 (_, Int31Plus) -> add_int31_binop_from_const Cbytecodes.Kaddint31 | KInt31 (_, Int31PlusC) -> add_int31_binop_from_const Cbytecodes.Kaddcint31 | KInt31 (_, Int31PlusCarryC) -> add_int31_binop_from_const Cbytecodes.Kaddcarrycint31 | KInt31 (_, Int31Minus) -> add_int31_binop_from_const Cbytecodes.Ksubint31 | KInt31 (_, Int31MinusC) -> add_int31_binop_from_const Cbytecodes.Ksubcint31 | KInt31 (_, Int31MinusCarryC) -> add_int31_binop_from_const Cbytecodes.Ksubcarrycint31 | KInt31 (_, Int31Times) -> add_int31_binop_from_const Cbytecodes.Kmulint31 | KInt31 (_, Int31TimesC) -> add_int31_binop_from_const Cbytecodes.Kmulcint31 | KInt31 (_, Int31Div21) -> (* this is a ternary operation *) (match value with | Const kn -> retroknowledge add_int31_op env value 3 Cbytecodes.Kdiv21int31 kn | _ -> anomaly "Environ.register: should be a constant") | KInt31 (_, Int31Div) -> add_int31_binop_from_const Cbytecodes.Kdivint31 | KInt31 (_, Int31AddMulDiv) -> (* this is a ternary operation *) (match value with | Const kn -> retroknowledge add_int31_op env value 3 Cbytecodes.Kaddmuldivint31 kn | _ -> anomaly "Environ.register: should be a constant") | KInt31 (_, Int31Compare) -> add_int31_binop_from_const Cbytecodes.Kcompareint31 | KInt31 (_, Int31Head0) -> add_int31_unop_from_const Cbytecodes.Khead0int31 | KInt31 (_, Int31Tail0) -> add_int31_unop_from_const Cbytecodes.Ktail0int31 | _ -> env.retroknowledge in Retroknowledge.add_field retroknowledge_with_reactive_info field value } coq-8.4pl4/kernel/subtyping.ml0000644000175000017500000004006012326224777015471 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Labmap.add (label_of_id id) (IndConstr((ip,i+1), mib)) map) oib.mind_consnames map in Labmap.add (label_of_id oib.mind_typename) (IndType (ip, mib)) map in array_fold_right_i add_mip_nameobjects mib.mind_packets map (* creates (namedobject/namedmodule) map for the whole signature *) type labmap = { objs : namedobject Labmap.t; mods : namedmodule Labmap.t } let empty_labmap = { objs = Labmap.empty; mods = Labmap.empty } let get_obj mp map l = try Labmap.find l map.objs with Not_found -> error_no_such_label_sub l (string_of_mp mp) let get_mod mp map l = try Labmap.find l map.mods with Not_found -> error_no_such_label_sub l (string_of_mp mp) let make_labmap mp list = let add_one (l,e) map = match e with | SFBconst cb -> { map with objs = Labmap.add l (Constant cb) map.objs } | SFBmind mib -> { map with objs = add_mib_nameobjects mp l mib map.objs } | SFBmodule mb -> { map with mods = Labmap.add l (Module mb) map.mods } | SFBmodtype mtb -> { map with mods = Labmap.add l (Modtype mtb) map.mods } in List.fold_right add_one list empty_labmap let check_conv_error error why cst f env a1 a2 = try union_constraints cst (f env a1 a2) with NotConvertible -> error why (* for now we do not allow reorderings *) let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2= let kn1 = make_mind mp1 empty_dirpath l in let kn2 = make_mind mp2 empty_dirpath l in let error why = error_signature_mismatch l spec2 why in let check_conv why cst f = check_conv_error error why cst f in let mib1 = match info1 with | IndType ((_,0), mib) -> subst_mind subst1 mib | _ -> error (InductiveFieldExpected mib2) in let mib2 = subst_mind subst2 mib2 in let check_inductive_type cst name env t1 t2 = (* Due to sort-polymorphism in inductive types, the conclusions of t1 and t2, if in Type, are generated as the least upper bounds of the types of the constructors. By monotonicity of the infered l.u.b. wrt subtyping (i.e. if X:U |- T(X):s and |- M:U' and U'<=U then infer_type(T(M))<=s), each universe in the conclusion of t1 has an bounding universe in the conclusion of t2, so that we don't need to check the subtyping of the conclusions of t1 and t2. Even if we'd like to recheck it, the inference of constraints is not designed to deal with algebraic constraints of the form max-univ(u1..un) <= max-univ(u'1..u'n), so that it is not easy to recheck it (in short, we would need the actual graph of constraints as input while type checking is currently designed to output a set of constraints instead) *) (* So we cheat and replace the subtyping problem on algebraic constraints of the form max-univ(u1..un) <= max-univ(u'1..u'n) (that we know are necessary true) by trivial constraints that the constraint generator knows how to deal with *) let (ctx1,s1) = dest_arity env t1 in let (ctx2,s2) = dest_arity env t2 in let s1,s2 = match s1, s2 with | Type _, Type _ -> (* shortcut here *) prop_sort, prop_sort | (Prop _, Type _) | (Type _,Prop _) -> error (NotConvertibleInductiveField name) | _ -> (s1, s2) in check_conv (NotConvertibleInductiveField name) cst conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) in let check_packet cst p1 p2 = let check f why = if f p1 <> f p2 then error why in check (fun p -> p.mind_consnames) NotSameConstructorNamesField; check (fun p -> p.mind_typename) NotSameInductiveNameInBlockField; (* nf_lc later *) (* nf_arity later *) (* user_lc ignored *) (* user_arity ignored *) check (fun p -> p.mind_nrealargs) (NotConvertibleInductiveField p2.mind_typename); (* How can it fail since the type of inductive are checked below? [HH] *) (* kelim ignored *) (* listrec ignored *) (* finite done *) (* nparams done *) (* params_ctxt done because part of the inductive types *) (* Don't check the sort of the type if polymorphic *) let cst = check_inductive_type cst p2.mind_typename env (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2)) in cst in let check_cons_types i cst p1 p2 = array_fold_left3 (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst conv env t1 t2) cst p2.mind_consnames (arities_of_specif kn1 (mib1,p1)) (arities_of_specif kn1 (mib2,p2)) in let check f why = if f mib1 <> f mib2 then error (why (f mib2)) in check (fun mib -> mib.mind_finite) (fun x -> FiniteInductiveFieldExpected x); check (fun mib -> mib.mind_ntypes) (fun x -> InductiveNumbersFieldExpected x); assert (mib1.mind_hyps=[] && mib2.mind_hyps=[]); assert (Array.length mib1.mind_packets >= 1 && Array.length mib2.mind_packets >= 1); (* Check that the expected numbers of uniform parameters are the same *) (* No need to check the contexts of parameters: it is checked *) (* at the time of checking the inductive arities in check_packet. *) (* Notice that we don't expect the local definitions to match: only *) (* the inductive types and constructors types have to be convertible *) check (fun mib -> mib.mind_nparams) (fun x -> InductiveParamsNumberField x); begin match mind_of_delta reso2 kn2 with | kn2' when kn2=kn2' -> () | kn2' -> if not (eq_mind (mind_of_delta reso1 kn1) (subst_ind subst2 kn2')) then error NotEqualInductiveAliases end; (* we check that records and their field names are preserved. *) check (fun mib -> mib.mind_record) (fun x -> RecordFieldExpected x); if mib1.mind_record then begin let rec names_prod_letin t = match kind_of_term t with | Prod(n,_,t) -> n::(names_prod_letin t) | LetIn(n,_,_,t) -> n::(names_prod_letin t) | Cast(t,_,_) -> names_prod_letin t | _ -> [] in assert (Array.length mib1.mind_packets = 1); assert (Array.length mib2.mind_packets = 1); assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1); assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1); check (fun mib -> let nparamdecls = List.length mib.mind_params_ctxt in let names = names_prod_letin (mib.mind_packets.(0).mind_user_lc.(0)) in snd (list_chop nparamdecls names)) (fun x -> RecordProjectionsExpected x); end; (* we first check simple things *) let cst = array_fold_left2 check_packet cst mib1.mind_packets mib2.mind_packets in (* and constructor types in the end *) let cst = array_fold_left2_i check_cons_types cst mib1.mind_packets mib2.mind_packets in cst let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = let error why = error_signature_mismatch l spec2 why in let check_conv cst f = check_conv_error error cst f in let check_type cst env t1 t2 = let err = NotConvertibleTypeField (env, t1, t2) in (* If the type of a constant is generated, it may mention non-variable algebraic universes that the general conversion algorithm is not ready to handle. Anyway, generated types of constants are functions of the body of the constant. If the bodies are the same in environments that are subtypes one of the other, the types are subtypes too (i.e. if Gamma <= Gamma', Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T'). Hence they don't have to be checked again *) let t1,t2 = if isArity t2 then let (ctx2,s2) = destArity t2 in match s2 with | Type v when not (is_univ_variable v) -> (* The type in the interface is inferred and is made of algebraic universes *) begin try let (ctx1,s1) = dest_arity env t1 in match s1 with | Type u when not (is_univ_variable u) -> (* Both types are inferred, no need to recheck them. We cheat and collapse the types to Prop *) mkArity (ctx1,prop_sort), mkArity (ctx2,prop_sort) | Prop _ -> (* The type in the interface is inferred, it may be the case that the type in the implementation is smaller because the body is more reduced. We safely collapse the upper type to Prop *) mkArity (ctx1,prop_sort), mkArity (ctx2,prop_sort) | Type _ -> (* The type in the interface is inferred and the type in the implementation is not inferred or is inferred but from a more reduced body so that it is just a variable. Since constraints of the form "univ <= max(...)" are not expressible in the system of algebraic universes: we fail (the user has to use an explicit type in the interface *) error NoTypeConstraintExpected with NotArity -> error err end | _ -> t1,t2 else (t1,t2) in check_conv err cst conv_leq env t1 t2 in match info1 with | Constant cb1 -> assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ; let cb1 = subst_const_body subst1 cb1 in let cb2 = subst_const_body subst2 cb2 in (* Start by checking types*) let typ1 = Typeops.type_of_constant_type env cb1.const_type in let typ2 = Typeops.type_of_constant_type env cb2.const_type in let cst = check_type cst env typ1 typ2 in (* Now we check the bodies: - A transparent constant can only be implemented by a compatible transparent constant. - In the signature, an opaque is handled just as a parameter: anything of the right type can implement it, even if bodies differ. *) (match cb2.const_body with | Undef _ | OpaqueDef _ -> cst | Def lc2 -> (match cb1.const_body with | Undef _ | OpaqueDef _ -> error NotConvertibleBodyField | Def lc1 -> (* NB: cb1 might have been strengthened and appear as transparent. Anyway [check_conv] will handle that afterwards. *) let c1 = Declarations.force lc1 in let c2 = Declarations.force lc2 in check_conv NotConvertibleBodyField cst conv env c1 c2)) | IndType ((kn,i),mind1) -> ignore (Util.error ( "The kernel does not recognize yet that a parameter can be " ^ "instantiated by an inductive type. Hint: you can rename the " ^ "inductive type and give a definition to map the old name to the new " ^ "name.")); assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ; if constant_has_body cb2 then error DefinitionFieldExpected; let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in let typ2 = Typeops.type_of_constant_type env cb2.const_type in let error = NotConvertibleTypeField (env, arity1, typ2) in check_conv error cst conv_leq env arity1 typ2 | IndConstr (((kn,i),j) as cstr,mind1) -> ignore (Util.error ( "The kernel does not recognize yet that a parameter can be " ^ "instantiated by a constructor. Hint: you can rename the " ^ "constructor and give a definition to map the old name to the new " ^ "name.")); assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ; if constant_has_body cb2 then error DefinitionFieldExpected; let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in let ty2 = Typeops.type_of_constant_type env cb2.const_type in let error = NotConvertibleTypeField (env, ty1, ty2) in check_conv error cst conv env ty1 ty2 let rec check_modules cst env msb1 msb2 subst1 subst2 = let mty1 = module_type_of_module None msb1 in let mty2 = module_type_of_module None msb2 in let cst = check_modtypes cst env mty1 mty2 subst1 subst2 false in cst and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2= let map1 = make_labmap mp1 sig1 in let check_one_body cst (l,spec2) = match spec2 with | SFBconst cb2 -> check_constant cst env mp1 l (get_obj mp1 map1 l) cb2 spec2 subst1 subst2 | SFBmind mib2 -> check_inductive cst env mp1 l (get_obj mp1 map1 l) mp2 mib2 spec2 subst1 subst2 reso1 reso2 | SFBmodule msb2 -> begin match get_mod mp1 map1 l with | Module msb -> check_modules cst env msb msb2 subst1 subst2 | _ -> error_signature_mismatch l spec2 ModuleFieldExpected end | SFBmodtype mtb2 -> let mtb1 = match get_mod mp1 map1 l with | Modtype mtb -> mtb | _ -> error_signature_mismatch l spec2 ModuleTypeFieldExpected in let env = add_module (module_body_of_type mtb2.typ_mp mtb2) (add_module (module_body_of_type mtb1.typ_mp mtb1) env) in check_modtypes cst env mtb1 mtb2 subst1 subst2 true in List.fold_left check_one_body cst sig2 and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = if mtb1==mtb2 then cst else let mtb1',mtb2'=mtb1.typ_expr,mtb2.typ_expr in let rec check_structure cst env str1 str2 equiv subst1 subst2 = match str1,str2 with | SEBstruct (list1), SEBstruct (list2) -> if equiv then let subst2 = add_mp mtb2.typ_mp mtb1.typ_mp mtb1.typ_delta subst2 in Univ.union_constraints (check_signatures cst env mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2 mtb1.typ_delta mtb2.typ_delta) (check_signatures cst env mtb2.typ_mp list2 mtb1.typ_mp list1 subst2 subst1 mtb2.typ_delta mtb1.typ_delta) else check_signatures cst env mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2 mtb1.typ_delta mtb2.typ_delta | SEBfunctor (arg_id1,arg_t1,body_t1), SEBfunctor (arg_id2,arg_t2,body_t2) -> let subst1 = (join (map_mbid arg_id1 (MPbound arg_id2) arg_t2.typ_delta) subst1) in let cst = check_modtypes cst env arg_t2 arg_t1 subst2 subst1 equiv in (* contravariant *) let env = add_module (module_body_of_type (MPbound arg_id2) arg_t2) env in let env = match body_t1 with SEBstruct str -> add_module {mod_mp = mtb1.typ_mp; mod_expr = None; mod_type = subst_struct_expr subst1 body_t1; mod_type_alg= None; mod_constraints=mtb1.typ_constraints; mod_retroknowledge = []; mod_delta = mtb1.typ_delta} env | _ -> env in check_structure cst env body_t1 body_t2 equiv subst1 subst2 | _ , _ -> error_incompatible_modtypes mtb1 mtb2 in if mtb1'== mtb2' then cst else check_structure cst env mtb1' mtb2' equiv subst1 subst2 let check_subtypes env sup super = let env = add_module (module_body_of_type sup.typ_mp sup) env in check_modtypes empty_constraint env (strengthen sup sup.typ_mp) super empty_subst (map_mp super.typ_mp sup.typ_mp sup.typ_delta) false coq-8.4pl4/kernel/sign.mli0000644000175000017500000000464212326224777014564 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* named_context -> named_context val vars_of_named_context : named_context -> identifier list val lookup_named : identifier -> named_context -> named_declaration (** number of declarations *) val named_context_length : named_context -> int (** named context equality *) val named_context_equal : named_context -> named_context -> bool (** {6 Recurrence on [named_context]: older declarations processed first } *) val fold_named_context : (named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a (** newer declarations first *) val fold_named_context_reverse : ('a -> named_declaration -> 'a) -> init:'a -> named_context -> 'a (** {6 Section-related auxiliary functions } *) val instance_from_named_context : named_context -> constr array (** {6 ... } *) (** Signatures of ordered optionally named variables, intended to be accessed by de Bruijn indices *) val push_named_to_rel_context : named_context -> rel_context -> rel_context (** {6 Recurrence on [rel_context]: older declarations processed first } *) val fold_rel_context : (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a (** newer declarations first *) val fold_rel_context_reverse : ('a -> rel_declaration -> 'a) -> init:'a -> rel_context -> 'a (** {6 Map function of [rel_context] } *) val map_rel_context : (constr -> constr) -> rel_context -> rel_context (** {6 Map function of [named_context] } *) val map_named_context : (constr -> constr) -> named_context -> named_context (** {6 Map function of [rel_context] } *) val iter_rel_context : (constr -> unit) -> rel_context -> unit (** {6 Map function of [named_context] } *) val iter_named_context : (constr -> unit) -> named_context -> unit coq-8.4pl4/kernel/declarations.mli0000644000175000017500000001764612326224777016304 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr_substituted val force : constr_substituted -> constr (** Opaque proof terms are not loaded immediately, but are there in a lazy form. Forcing this lazy may trigger some unmarshal of the necessary structure. *) type lazy_constr val subst_lazy_constr : substitution -> lazy_constr -> lazy_constr val force_lazy_constr : lazy_constr -> constr_substituted val make_lazy_constr : constr_substituted Lazy.t -> lazy_constr val lazy_constr_is_val : lazy_constr -> bool val force_opaque : lazy_constr -> constr val opaque_from_val : constr -> lazy_constr (** Inlining level of parameters at functor applications. None means no inlining *) type inline = int option (** A constant can have no body (axiom/parameter), or a transparent body, or an opaque one *) type constant_def = | Undef of inline | Def of constr_substituted | OpaqueDef of lazy_constr type constant_body = { const_hyps : section_context; (** New: younger hyp at top *) const_body : constant_def; const_type : constant_type; const_body_code : to_patch_substituted; const_constraints : constraints } val subst_const_def : substitution -> constant_def -> constant_def val subst_const_body : substitution -> constant_body -> constant_body (** Is there a actual body in const_body or const_body_opaque ? *) val constant_has_body : constant_body -> bool (** Accessing const_body_opaque or const_body *) val body_of_constant : constant_body -> constr_substituted option val is_opaque : constant_body -> bool (** {6 Representation of mutual inductive types in the kernel } *) type recarg = | Norec | Mrec of inductive | Imbr of inductive val subst_recarg : substitution -> recarg -> recarg type wf_paths = recarg Rtree.t val mk_norec : wf_paths val mk_paths : recarg -> wf_paths list array -> wf_paths val dest_recarg : wf_paths -> recarg val dest_subterms : wf_paths -> wf_paths list array val recarg_length : wf_paths -> int -> int val subst_wf_paths : substitution -> wf_paths -> wf_paths (** {v Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1 ... with In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn v} *) type monomorphic_inductive_arity = { mind_user_arity : constr; mind_sort : sorts; } type inductive_arity = | Monomorphic of monomorphic_inductive_arity | Polymorphic of polymorphic_arity type one_inductive_body = { (** {8 Primitive datas } *) mind_typename : identifier; (** Name of the type: [Ii] *) mind_arity_ctxt : rel_context; (** Arity context of [Ii] with parameters: [forall params, Ui] *) mind_arity : inductive_arity; (** Arity sort and original user arity if monomorphic *) mind_consnames : identifier array; (** Names of the constructors: [cij] *) mind_user_lc : types array; (** Types of the constructors with parameters: [forall params, Tij], where the Ik are replaced by de Bruijn index in the context I1:forall params, U1 .. In:forall params, Un *) (** {8 Derived datas } *) mind_nrealargs : int; (** Number of expected real arguments of the type (no let, no params) *) mind_nrealargs_ctxt : int; (** Length of realargs context (with let, no params) *) mind_kelim : sorts_family list; (** List of allowed elimination sorts *) mind_nf_lc : types array; (** Head normalized constructor types so that their conclusion is atomic *) mind_consnrealdecls : int array; (** Length of the signature of the constructors (with let, w/o params) (not used in the kernel) *) mind_recargs : wf_paths; (** Signature of recursive arguments in the constructors *) (** {8 Datas for bytecode compilation } *) mind_nb_constant : int; (** number of constant constructor *) mind_nb_args : int; (** number of no constant constructor *) mind_reloc_tbl : Cbytecodes.reloc_table; } type mutual_inductive_body = { mind_packets : one_inductive_body array; (** The component of the mutual inductive block *) mind_record : bool; (** Whether the inductive type has been declared as a record *) mind_finite : bool; (** Whether the type is inductive or coinductive *) mind_ntypes : int; (** Number of types in the block *) mind_hyps : section_context; (** Section hypotheses on which the block depends *) mind_nparams : int; (** Number of expected parameters *) mind_nparams_rec : int; (** Number of recursively uniform (i.e. ordinary) parameters *) mind_params_ctxt : rel_context; (** The context of parameters (includes let-in declaration) *) mind_constraints : constraints; (** Universes constraints enforced by the inductive declaration *) } val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body (** {6 Modules: signature component specifications, module types, and module declarations } *) type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body | SFBmodtype of module_type_body (** NB: we may encounter now (at most) twice the same label in a [structure_body], once for a module ([SFBmodule] or [SFBmodtype]) and once for an object ([SFBconst] or [SFBmind]) *) and structure_body = (label * structure_field_body) list and struct_expr_body = | SEBident of module_path | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body | SEBapply of struct_expr_body * struct_expr_body * constraints | SEBstruct of structure_body | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = With_module_body of identifier list * module_path | With_definition_body of identifier list * constant_body and module_body = { (** absolute path of the module *) mod_mp : module_path; (** Implementation *) mod_expr : struct_expr_body option; (** Signature *) mod_type : struct_expr_body; (** algebraic structure expression is kept if it's relevant for extraction *) mod_type_alg : struct_expr_body option; (** set of all constraint in the module *) mod_constraints : constraints; (** quotiented set of equivalent constant and inductive name *) mod_delta : delta_resolver; mod_retroknowledge : Retroknowledge.action list} and module_type_body = { (** Path of the module type *) typ_mp : module_path; typ_expr : struct_expr_body; (** algebraic structure expression is kept if it's relevant for extraction *) typ_expr_alg : struct_expr_body option ; typ_constraints : constraints; (** quotiented set of equivalent constant and inductive name *) typ_delta :delta_resolver} (** Hash-consing *) (** Here, strictly speaking, we don't perform true hash-consing of the structure, but simply hash-cons all inner constr and other known elements *) val hcons_const_body : constant_body -> constant_body val hcons_mind : mutual_inductive_body -> mutual_inductive_body coq-8.4pl4/kernel/mod_subst.ml0000644000175000017500000004216112326224777015450 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* *) let string_of_hint = function | Inline (_,Some _) -> "inline(Some _)" | Inline _ -> "inline()" | Equiv kn -> string_of_kn kn let debug_string_of_delta resolve = let kn_to_string kn hint l = (string_of_kn kn ^ "=>" ^ string_of_hint hint) :: l in let mp_to_string mp mp' l = (string_of_mp mp ^ "=>" ^ string_of_mp mp') :: l in let l = Deltamap.fold mp_to_string kn_to_string resolve [] in String.concat ", " (List.rev l) let list_contents sub = let one_pair (mp,reso) = (string_of_mp mp,debug_string_of_delta reso) in let mp_one_pair mp0 p l = (string_of_mp mp0, one_pair p)::l in let mbi_one_pair mbi p l = (debug_string_of_mbid mbi, one_pair p)::l in Umap.fold mp_one_pair mbi_one_pair sub [] let debug_string_of_subst sub = let l = List.map (fun (s1,(s2,s3)) -> s1^"|->"^s2^"["^s3^"]") (list_contents sub) in "{" ^ String.concat "; " l ^ "}" let debug_pr_delta resolve = str (debug_string_of_delta resolve) let debug_pr_subst sub = let l = list_contents sub in let f (s1,(s2,s3)) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2 ++ spc () ++ str "[" ++ str s3 ++ str "]") in str "{" ++ hov 2 (prlist_with_sep pr_comma f l) ++ str "}" (* *) (** Extending a [delta_resolver] *) let add_inline_delta_resolver kn (lev,oc) = Deltamap.add_kn kn (Inline (lev,oc)) let add_kn_delta_resolver kn kn' = Deltamap.add_kn kn (Equiv kn') let add_mp_delta_resolver mp1 mp2 = Deltamap.add_mp mp1 mp2 (** Extending a [substitution *) let add_mbid mbid mp resolve s = Umap.add_mbi mbid (mp,resolve) s let add_mp mp1 mp2 resolve s = Umap.add_mp mp1 (mp2,resolve) s let map_mbid mbid mp resolve = add_mbid mbid mp resolve empty_subst let map_mp mp1 mp2 resolve = add_mp mp1 mp2 resolve empty_subst let mp_in_delta mp = Deltamap.mem_mp mp let kn_in_delta kn resolver = try match Deltamap.find_kn kn resolver with | Equiv _ -> true | Inline _ -> false with Not_found -> false let con_in_delta con resolver = kn_in_delta (user_con con) resolver let mind_in_delta mind resolver = kn_in_delta (user_mind mind) resolver let mp_of_delta resolve mp = try Deltamap.find_mp mp resolve with Not_found -> mp let rec find_prefix resolve mp = let rec sub_mp = function | MPdot(mp,l) as mp_sup -> (try Deltamap.find_mp mp_sup resolve with Not_found -> MPdot(sub_mp mp,l)) | p -> Deltamap.find_mp p resolve in try sub_mp mp with Not_found -> mp exception Change_equiv_to_inline of (int * constr) let solve_delta_kn resolve kn = try match Deltamap.find_kn kn resolve with | Equiv kn1 -> kn1 | Inline (lev, Some c) -> raise (Change_equiv_to_inline (lev,c)) | Inline (_, None) -> raise Not_found with Not_found -> let mp,dir,l = repr_kn kn in let new_mp = find_prefix resolve mp in if mp == new_mp then kn else make_kn new_mp dir l let kn_of_delta resolve kn = try solve_delta_kn resolve kn with e when Errors.noncritical e -> kn let constant_of_delta_kn resolve kn = constant_of_kn_equiv kn (kn_of_delta resolve kn) let gen_of_delta resolve x kn fix_can = try let new_kn = solve_delta_kn resolve kn in if kn == new_kn then x else fix_can new_kn with e when Errors.noncritical e -> x let constant_of_delta resolve con = let kn = user_con con in gen_of_delta resolve con kn (constant_of_kn_equiv kn) let constant_of_delta2 resolve con = let kn, kn' = canonical_con con, user_con con in gen_of_delta resolve con kn (constant_of_kn_equiv kn') let mind_of_delta_kn resolve kn = mind_of_kn_equiv kn (kn_of_delta resolve kn) let mind_of_delta resolve mind = let kn = user_mind mind in gen_of_delta resolve mind kn (mind_of_kn_equiv kn) let mind_of_delta2 resolve mind = let kn, kn' = canonical_mind mind, user_mind mind in gen_of_delta resolve mind kn (mind_of_kn_equiv kn') let inline_of_delta inline resolver = match inline with | None -> [] | Some inl_lev -> let extract kn hint l = match hint with | Inline (lev,_) -> if lev <= inl_lev then (lev,kn)::l else l | _ -> l in Deltamap.fold_kn extract resolver [] let find_inline_of_delta kn resolve = match Deltamap.find_kn kn resolve with | Inline (_,o) -> o | _ -> raise Not_found let constant_of_delta_with_inline resolve con = let kn1,kn2 = canonical_con con,user_con con in try find_inline_of_delta kn2 resolve with Not_found -> if kn1 == kn2 then None else try find_inline_of_delta kn1 resolve with Not_found -> None let subst_mp0 sub mp = (* 's like subst *) let rec aux mp = match mp with | MPfile sid -> Umap.find_mp mp sub | MPbound bid -> begin try Umap.find_mbi bid sub with Not_found -> Umap.find_mp mp sub end | MPdot (mp1,l) as mp2 -> begin try Umap.find_mp mp2 sub with Not_found -> let mp1',resolve = aux mp1 in MPdot (mp1',l),resolve end in try Some (aux mp) with Not_found -> None let subst_mp sub mp = match subst_mp0 sub mp with None -> mp | Some (mp',_) -> mp' let subst_kn_delta sub kn = let mp,dir,l = repr_kn kn in match subst_mp0 sub mp with Some (mp',resolve) -> solve_delta_kn resolve (make_kn mp' dir l) | None -> kn let subst_kn sub kn = let mp,dir,l = repr_kn kn in match subst_mp0 sub mp with Some (mp',_) -> (make_kn mp' dir l) | None -> kn exception No_subst type sideconstantsubst = | User | Canonical let gen_subst_mp f sub mp1 mp2 = let o1 = subst_mp0 sub mp1 in let o2 = if mp1 == mp2 then o1 else subst_mp0 sub mp2 in match o1, o2 with | None, None -> raise No_subst | Some (mp',resolve), None -> User, (f mp' mp2), resolve | None, Some (mp',resolve) -> Canonical, (f mp1 mp'), resolve | Some (mp1',_), Some (mp2',resolve2) -> Canonical, (f mp1' mp2'), resolve2 let subst_ind sub mind = let kn1,kn2 = user_mind mind, canonical_mind mind in let mp1,dir,l = repr_kn kn1 in let mp2,_,_ = repr_kn kn2 in let rebuild_mind mp1 mp2 = make_mind_equiv mp1 mp2 dir l in try let side,mind',resolve = gen_subst_mp rebuild_mind sub mp1 mp2 in match side with | User -> mind_of_delta resolve mind' | Canonical -> mind_of_delta2 resolve mind' with No_subst -> mind let subst_con0 sub con = let kn1,kn2 = user_con con,canonical_con con in let mp1,dir,l = repr_kn kn1 in let mp2,_,_ = repr_kn kn2 in let rebuild_con mp1 mp2 = make_con_equiv mp1 mp2 dir l in let dup con = con, mkConst con in let side,con',resolve = gen_subst_mp rebuild_con sub mp1 mp2 in match constant_of_delta_with_inline resolve con' with | Some t -> (* In case of inlining, discard the canonical part (cf #2608) *) constant_of_kn (user_con con'), t | None -> let con'' = match side with | User -> constant_of_delta resolve con' | Canonical -> constant_of_delta2 resolve con' in if con'' == con then raise No_subst else dup con'' let subst_con sub con = try subst_con0 sub con with No_subst -> con, mkConst con (* Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? Does the user mean "Unfold X.t" or does she mean "Unfold y" where X.t is later on instantiated with y? I choose the first interpretation (i.e. an evaluable reference is never expanded). *) let subst_evaluable_reference subst = function | EvalVarRef id -> EvalVarRef id | EvalConstRef kn -> EvalConstRef (fst (subst_con subst kn)) let rec map_kn f f' c = let func = map_kn f f' in match kind_of_term c with | Const kn -> (try snd (f' kn) with No_subst -> c) | Ind (kn,i) -> let kn' = f kn in if kn'==kn then c else mkInd (kn',i) | Construct ((kn,i),j) -> let kn' = f kn in if kn'==kn then c else mkConstruct ((kn',i),j) | Case (ci,p,ct,l) -> let ci_ind = let (kn,i) = ci.ci_ind in let kn' = f kn in if kn'==kn then ci.ci_ind else kn',i in let p' = func p in let ct' = func ct in let l' = array_smartmap func l in if (ci.ci_ind==ci_ind && p'==p && l'==l && ct'==ct)then c else mkCase ({ci with ci_ind = ci_ind}, p',ct', l') | Cast (ct,k,t) -> let ct' = func ct in let t'= func t in if (t'==t && ct'==ct) then c else mkCast (ct', k, t') | Prod (na,t,ct) -> let ct' = func ct in let t'= func t in if (t'==t && ct'==ct) then c else mkProd (na, t', ct') | Lambda (na,t,ct) -> let ct' = func ct in let t'= func t in if (t'==t && ct'==ct) then c else mkLambda (na, t', ct') | LetIn (na,b,t,ct) -> let ct' = func ct in let t'= func t in let b'= func b in if (t'==t && ct'==ct && b==b') then c else mkLetIn (na, b', t', ct') | App (ct,l) -> let ct' = func ct in let l' = array_smartmap func l in if (ct'== ct && l'==l) then c else mkApp (ct',l') | Evar (e,l) -> let l' = array_smartmap func l in if (l'==l) then c else mkEvar (e,l') | Fix (ln,(lna,tl,bl)) -> let tl' = array_smartmap func tl in let bl' = array_smartmap func bl in if (bl == bl'&& tl == tl') then c else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> let tl' = array_smartmap func tl in let bl' = array_smartmap func bl in if (bl == bl'&& tl == tl') then c else mkCoFix (ln,(lna,tl',bl')) | _ -> c let subst_mps sub c = if is_empty_subst sub then c else map_kn (subst_ind sub) (subst_con0 sub) c let rec replace_mp_in_mp mpfrom mpto mp = match mp with | _ when mp = mpfrom -> mpto | MPdot (mp1,l) -> let mp1' = replace_mp_in_mp mpfrom mpto mp1 in if mp1==mp1' then mp else MPdot (mp1',l) | _ -> mp let replace_mp_in_kn mpfrom mpto kn = let mp,dir,l = repr_kn kn in let mp'' = replace_mp_in_mp mpfrom mpto mp in if mp==mp'' then kn else make_kn mp'' dir l let rec mp_in_mp mp mp1 = match mp1 with | _ when mp1 = mp -> true | MPdot (mp2,l) -> mp_in_mp mp mp2 | _ -> false let subset_prefixed_by mp resolver = let mp_prefix mkey mequ rslv = if mp_in_mp mp mkey then Deltamap.add_mp mkey mequ rslv else rslv in let kn_prefix kn hint rslv = match hint with | Inline _ -> rslv | Equiv _ -> if mp_in_mp mp (modpath kn) then Deltamap.add_kn kn hint rslv else rslv in Deltamap.fold mp_prefix kn_prefix resolver empty_delta_resolver let subst_dom_delta_resolver subst resolver = let mp_apply_subst mkey mequ rslv = Deltamap.add_mp (subst_mp subst mkey) mequ rslv in let kn_apply_subst kkey hint rslv = Deltamap.add_kn (subst_kn subst kkey) hint rslv in Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver let subst_mp_delta sub mp mkey = match subst_mp0 sub mp with None -> empty_delta_resolver,mp | Some (mp',resolve) -> let mp1 = find_prefix resolve mp' in let resolve1 = subset_prefixed_by mp1 resolve in (subst_dom_delta_resolver (map_mp mp1 mkey empty_delta_resolver) resolve1),mp1 let gen_subst_delta_resolver dom subst resolver = let mp_apply_subst mkey mequ rslv = let mkey' = if dom then subst_mp subst mkey else mkey in let rslv',mequ' = subst_mp_delta subst mequ mkey in Deltamap.join rslv' (Deltamap.add_mp mkey' mequ' rslv) in let kn_apply_subst kkey hint rslv = let kkey' = if dom then subst_kn subst kkey else kkey in let hint' = match hint with | Equiv kequ -> (try Equiv (subst_kn_delta subst kequ) with Change_equiv_to_inline (lev,c) -> Inline (lev,Some c)) | Inline (lev,Some t) -> Inline (lev,Some (subst_mps subst t)) | Inline (_,None) -> hint in Deltamap.add_kn kkey' hint' rslv in Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver let subst_codom_delta_resolver = gen_subst_delta_resolver false let subst_dom_codom_delta_resolver = gen_subst_delta_resolver true let update_delta_resolver resolver1 resolver2 = let mp_apply_rslv mkey mequ rslv = if Deltamap.mem_mp mkey resolver2 then rslv else Deltamap.add_mp mkey (find_prefix resolver2 mequ) rslv in let kn_apply_rslv kkey hint rslv = if Deltamap.mem_kn kkey resolver2 then rslv else let hint' = match hint with | Equiv kequ -> (try Equiv (solve_delta_kn resolver2 kequ) with Change_equiv_to_inline (lev,c) -> Inline (lev, Some c)) | _ -> hint in Deltamap.add_kn kkey hint' rslv in Deltamap.fold mp_apply_rslv kn_apply_rslv resolver1 empty_delta_resolver let add_delta_resolver resolver1 resolver2 = if resolver1 == resolver2 then resolver2 else if resolver2 = empty_delta_resolver then resolver1 else Deltamap.join (update_delta_resolver resolver1 resolver2) resolver2 let substition_prefixed_by k mp subst = let mp_prefixmp kmp (mp_to,reso) sub = if mp_in_mp mp kmp && mp <> kmp then let new_key = replace_mp_in_mp mp k kmp in Umap.add_mp new_key (mp_to,reso) sub else sub in let mbi_prefixmp mbi _ sub = sub in Umap.fold mp_prefixmp mbi_prefixmp subst empty_subst let join subst1 subst2 = let apply_subst mpk add (mp,resolve) res = let mp',resolve' = match subst_mp0 subst2 mp with | None -> mp, None | Some (mp',resolve') -> mp', Some resolve' in let resolve'' = match resolve' with | Some res -> add_delta_resolver (subst_dom_codom_delta_resolver subst2 resolve) res | None -> subst_codom_delta_resolver subst2 resolve in let prefixed_subst = substition_prefixed_by mpk mp' subst2 in Umap.join prefixed_subst (add (mp',resolve'') res) in let mp_apply_subst mp = apply_subst mp (Umap.add_mp mp) in let mbi_apply_subst mbi = apply_subst (MPbound mbi) (Umap.add_mbi mbi) in let subst = Umap.fold mp_apply_subst mbi_apply_subst subst1 empty_subst in Umap.join subst2 subst let rec occur_in_path mbi = function | MPbound bid' -> mbi = bid' | MPdot (mp1,_) -> occur_in_path mbi mp1 | _ -> false let occur_mbid mbi sub = let check_one mbi' (mp,_) = if mbi = mbi' || occur_in_path mbi mp then raise Exit in try Umap.iter_mbi check_one sub; false with Exit -> true type 'a lazy_subst = | LSval of 'a | LSlazy of substitution list * 'a type 'a substituted = 'a lazy_subst ref let from_val a = ref (LSval a) let force fsubst r = match !r with | LSval a -> a | LSlazy(s,a) -> let subst = List.fold_left join empty_subst (List.rev s) in let a' = fsubst subst a in r := LSval a'; a' let subst_substituted s r = match !r with | LSval a -> ref (LSlazy([s],a)) | LSlazy(s',a) -> ref (LSlazy(s::s',a)) (* debug *) let repr_substituted r = match !r with | LSval a -> None, a | LSlazy(s,a) -> Some s, a coq-8.4pl4/kernel/subtyping.mli0000644000175000017500000000121212326224777015636 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* module_type_body -> module_type_body -> constraints coq-8.4pl4/kernel/indtypes.mli0000644000175000017500000000262512326224777015462 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body coq-8.4pl4/kernel/type_errors.mli0000644000175000017500000000704612326224777016202 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int -> 'a val error_unbound_var : env -> variable -> 'a val error_not_type : env -> unsafe_judgment -> 'a val error_assumption : env -> unsafe_judgment -> 'a val error_reference_variables : env -> constr -> 'a val error_elim_arity : env -> inductive -> sorts_family list -> constr -> unsafe_judgment -> (sorts_family * sorts_family * arity_error) option -> 'a val error_case_not_inductive : env -> unsafe_judgment -> 'a val error_number_branches : env -> unsafe_judgment -> int -> 'a val error_ill_formed_branch : env -> constr -> constructor -> constr -> constr -> 'a val error_generalization : env -> name * types -> unsafe_judgment -> 'a val error_actual_type : env -> unsafe_judgment -> types -> 'a val error_cant_apply_not_functional : env -> unsafe_judgment -> unsafe_judgment array -> 'a val error_cant_apply_bad_type : env -> int * constr * constr -> unsafe_judgment -> unsafe_judgment array -> 'a val error_ill_formed_rec_body : env -> guard_error -> name array -> int -> env -> unsafe_judgment array -> 'a val error_ill_typed_rec_body : env -> int -> name array -> unsafe_judgment array -> types array -> 'a val error_elim_explain : sorts_family -> sorts_family -> arity_error coq-8.4pl4/kernel/reduction.mli0000644000175000017500000000642012326224777015614 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr val whd_betadeltaiota : env -> constr -> constr val whd_betadeltaiota_nolet : env -> constr -> constr val whd_betaiota : constr -> constr val nf_betaiota : constr -> constr (*********************************************************************** s conversion functions *) exception NotConvertible exception NotConvertibleVect of int type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints type 'a trans_conversion_function = Names.transparent_state -> env -> 'a -> 'a -> Univ.constraints type conv_pb = CONV | CUMUL val sort_cmp : conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints val conv_sort : sorts conversion_function val conv_sort_leq : sorts conversion_function val trans_conv_cmp : ?l2r:bool -> conv_pb -> constr trans_conversion_function val trans_conv : ?l2r:bool -> ?evars:(existential->constr option) -> constr trans_conversion_function val trans_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> types trans_conversion_function val conv_cmp : ?l2r:bool -> conv_pb -> constr conversion_function val conv : ?l2r:bool -> ?evars:(existential->constr option) -> constr conversion_function val conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> types conversion_function val conv_leq_vecti : ?l2r:bool -> ?evars:(existential->constr option) -> types array conversion_function (** option for conversion *) val set_vm_conv : (conv_pb -> types conversion_function) -> unit val vm_conv : conv_pb -> types conversion_function val set_default_conv : (conv_pb -> ?l2r:bool -> types conversion_function) -> unit val default_conv : conv_pb -> ?l2r:bool -> types conversion_function val default_conv_leq : ?l2r:bool -> types conversion_function (************************************************************************) (** Builds an application node, reducing beta redexes it may produce. *) val beta_appvect : constr -> constr array -> constr (** Builds an application node, reducing the [n] first beta-zeta redexes. *) val betazeta_appvect : int -> constr -> constr array -> constr (** Pseudo-reduction rule Prod(x,A,B) a --> B[x\a] *) val hnf_prod_applist : env -> types -> constr list -> types (*********************************************************************** s Recognizing products and arities modulo reduction *) val dest_prod : env -> types -> rel_context * types val dest_prod_assum : env -> types -> rel_context * types exception NotArity val dest_arity : env -> types -> arity (* raises NotArity if not an arity *) val is_arity : env -> types -> bool coq-8.4pl4/kernel/vconv.mli0000644000175000017500000000147312326224777014756 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool val set_use_vm : bool -> unit val vconv : conv_pb -> types conversion_function val val_of_constr : env -> constr -> values coq-8.4pl4/kernel/mod_typing.ml0000644000175000017500000003566612326224777015636 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* mp | _ -> raise Not_path let rec mp_from_mexpr = function | MSEident mp -> mp | MSEapply (expr,_) -> mp_from_mexpr expr | MSEfunctor (_,_,expr) -> mp_from_mexpr expr | MSEwith (expr,_) -> mp_from_mexpr expr let is_modular = function | SFBmodule _ | SFBmodtype _ -> true | SFBconst _ | SFBmind _ -> false let rec list_split_assoc ((k,m) as km) rev_before = function | [] -> raise Not_found | (k',b)::after when k=k' && is_modular b = m -> rev_before,b,after | h::tail -> list_split_assoc km (h::rev_before) tail let discr_resolver env mtb = match mtb.typ_expr with SEBstruct _ -> mtb.typ_delta | _ -> (*case mp is a functor *) empty_delta_resolver let rec rebuild_mp mp l = match l with []-> mp | i::r -> rebuild_mp (MPdot(mp,i)) r let rec check_with env sign with_decl alg_sign mp equiv = let sign,wd,equiv,cst= match with_decl with | With_Definition (idl,c) -> let sign,cb,cst = check_with_def env sign (idl,c) mp equiv in sign,With_definition_body(idl,cb),equiv,cst | With_Module (idl,mp1) -> let sign,equiv,cst = check_with_mod env sign (idl,mp1) mp equiv in sign,With_module_body(idl,mp1),equiv,cst in if alg_sign = None then sign,None,equiv,cst else sign,Some (SEBwith(Option.get(alg_sign),wd)),equiv,cst and check_with_def env sign (idl,c) mp equiv = let sig_b = match sign with | SEBstruct(sig_b) -> sig_b | _ -> error_signature_expected sign in let id,idl = match idl with | [] -> assert false | id::idl -> id,idl in let l = label_of_id id in try let rev_before,spec,after = list_split_assoc (l,(idl<>[])) [] sig_b in let before = List.rev rev_before in let env' = Modops.add_signature mp before equiv env in if idl = [] then (* Toplevel definition *) let cb = match spec with | SFBconst cb -> cb | _ -> error_not_a_constant l in (* In the spirit of subtyping.check_constant, we accept any implementations of parameters and opaques terms, as long as they have the right type *) let def,cst = match cb.const_body with | Undef _ | OpaqueDef _ -> let (j,cst1) = Typeops.infer env' c in let typ = Typeops.type_of_constant_type env' cb.const_type in let cst2 = Reduction.conv_leq env' j.uj_type typ in let cst = union_constraints (union_constraints cb.const_constraints cst1) cst2 in let def = Def (Declarations.from_val j.uj_val) in def,cst | Def cs -> let cst1 = Reduction.conv env' c (Declarations.force cs) in let cst = union_constraints cb.const_constraints cst1 in let def = Def (Declarations.from_val c) in def,cst in let cb' = { cb with const_body = def; const_body_code = Cemitcodes.from_val (compile_constant_body env' def); const_constraints = cst } in SEBstruct(before@(l,SFBconst(cb'))::after),cb',cst else (* Definition inside a sub-module *) let old = match spec with | SFBmodule msb -> msb | _ -> error_not_a_module (string_of_label l) in begin match old.mod_expr with | None -> let sign,cb,cst = check_with_def env' old.mod_type (idl,c) (MPdot(mp,l)) old.mod_delta in let new_spec = SFBmodule({old with mod_type = sign; mod_type_alg = None}) in SEBstruct(before@(l,new_spec)::after),cb,cst | Some msb -> error_generative_module_expected l end with | Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_incorrect_with_constraint l and check_with_mod env sign (idl,mp1) mp equiv = let sig_b = match sign with | SEBstruct(sig_b) ->sig_b | _ -> error_signature_expected sign in let id,idl = match idl with | [] -> assert false | id::idl -> id,idl in let l = label_of_id id in try let rev_before,spec,after = list_split_assoc (l,true) [] sig_b in let before = List.rev rev_before in let env' = Modops.add_signature mp before equiv env in if idl = [] then (* Toplevel module definition *) let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module (string_of_label l) in let mb_mp1 = (lookup_module mp1 env) in let mtb_mp1 = module_type_of_module None mb_mp1 in let cst = match old.mod_expr with None -> begin try union_constraints (check_subtypes env' mtb_mp1 (module_type_of_module None old)) old.mod_constraints with Failure _ -> error_incorrect_with_constraint (label_of_id id) end | Some (SEBident(mp')) -> check_modpath_equiv env' mp1 mp'; old.mod_constraints | _ -> error_generative_module_expected l in let new_mb = strengthen_and_subst_mb mb_mp1 (MPdot(mp,l)) false in let new_spec = SFBmodule {new_mb with mod_mp = MPdot(mp,l); mod_expr = Some (SEBident mp1); mod_constraints = cst} in (* we propagate the new equality in the rest of the signature with the identity substitution accompagned by the new resolver*) let id_subst = map_mp (MPdot(mp,l)) (MPdot(mp,l)) new_mb.mod_delta in SEBstruct(before@(l,new_spec)::subst_signature id_subst after), add_delta_resolver equiv new_mb.mod_delta,cst else (* Module definition of a sub-module *) let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module (string_of_label l) in begin match old.mod_expr with None -> let sign,equiv',cst = check_with_mod env' old.mod_type (idl,mp1) (MPdot(mp,l)) old.mod_delta in let new_equiv = add_delta_resolver equiv equiv' in let new_spec = SFBmodule {old with mod_type = sign; mod_type_alg = None; mod_delta = equiv'} in let id_subst = map_mp (MPdot(mp,l)) (MPdot(mp,l)) equiv' in SEBstruct(before@(l,new_spec)::subst_signature id_subst after), new_equiv,cst | Some (SEBident(mp')) -> let mpnew = rebuild_mp mp' (List.map label_of_id idl) in check_modpath_equiv env' mpnew mp; SEBstruct(before@(l,spec)::after) ,equiv,empty_constraint | _ -> error_generative_module_expected l end with Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_incorrect_with_constraint l and translate_module env mp inl me = match me.mod_entry_expr, me.mod_entry_type with | None, None -> anomaly "Mod_typing.translate_module: empty type and expr in module entry" | None, Some mte -> let mtb = translate_module_type env mp inl mte in { mod_mp = mp; mod_expr = None; mod_type = mtb.typ_expr; mod_type_alg = mtb.typ_expr_alg; mod_delta = mtb.typ_delta; mod_constraints = mtb.typ_constraints; mod_retroknowledge = []} | Some mexpr, _ -> let sign,alg_implem,resolver,cst1 = translate_struct_module_entry env mp inl mexpr in let sign,alg1,resolver,cst2 = match me.mod_entry_type with | None -> sign,None,resolver,empty_constraint | Some mte -> let mtb = translate_module_type env mp inl mte in let cst = check_subtypes env {typ_mp = mp; typ_expr = sign; typ_expr_alg = None; typ_constraints = empty_constraint; typ_delta = resolver;} mtb in mtb.typ_expr,mtb.typ_expr_alg,mtb.typ_delta,cst in { mod_mp = mp; mod_type = sign; mod_expr = alg_implem; mod_type_alg = alg1; mod_constraints = Univ.union_constraints cst1 cst2; mod_delta = resolver; mod_retroknowledge = []} (* spiwack: not so sure about that. It may cause a bug when closing nested modules. If it does, I don't really know how to fix the bug.*) and translate_apply env inl ftrans mexpr mkalg = let sign,alg,resolver,cst1 = ftrans in let farg_id, farg_b, fbody_b = destr_functor env sign in let mp1 = try path_of_mexpr mexpr with Not_path -> error_application_to_not_path mexpr in let mtb = module_type_of_module None (lookup_module mp1 env) in let cst2 = check_subtypes env mtb farg_b in let mp_delta = discr_resolver env mtb in let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in let subst = map_mbid farg_id mp1 mp_delta in subst_struct_expr subst fbody_b, mkalg alg mp1 cst2, subst_codom_delta_resolver subst resolver, Univ.union_constraints cst1 cst2 and translate_functor env inl arg_id arg_e trans mkalg = let mtb = translate_module_type env (MPbound arg_id) inl arg_e in let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in let sign,alg,resolver,cst = trans env' in SEBfunctor (arg_id, mtb, sign), mkalg alg arg_id mtb, resolver, Univ.union_constraints cst mtb.typ_constraints and translate_struct_module_entry env mp inl = function | MSEident mp1 -> let mb = lookup_module mp1 env in let mb' = strengthen_and_subst_mb mb mp false in mb'.mod_type, Some (SEBident mp1), mb'.mod_delta,Univ.empty_constraint | MSEfunctor (arg_id, arg_e, body_expr) -> let trans env' = translate_struct_module_entry env' mp inl body_expr in let mkalg a id m = Option.map (fun a -> SEBfunctor (id,m,a)) a in translate_functor env inl arg_id arg_e trans mkalg | MSEapply (fexpr,mexpr) -> let trans = translate_struct_module_entry env mp inl fexpr in let mkalg a mp c = Option.map (fun a -> SEBapply(a,SEBident mp,c)) a in translate_apply env inl trans mexpr mkalg | MSEwith(mte, with_decl) -> let sign,alg,resolve,cst1 = translate_struct_module_entry env mp inl mte in let sign,alg,resolve,cst2 = check_with env sign with_decl alg mp resolve in sign,alg,resolve,Univ.union_constraints cst1 cst2 and translate_struct_type_entry env inl = function | MSEident mp1 -> let mtb = lookup_modtype mp1 env in mtb.typ_expr,Some (SEBident mp1),mtb.typ_delta,Univ.empty_constraint | MSEfunctor (arg_id, arg_e, body_expr) -> let trans env' = translate_struct_type_entry env' inl body_expr in translate_functor env inl arg_id arg_e trans (fun _ _ _ -> None) | MSEapply (fexpr,mexpr) -> let trans = translate_struct_type_entry env inl fexpr in translate_apply env inl trans mexpr (fun _ _ _ -> None) | MSEwith(mte, with_decl) -> let sign,alg,resolve,cst1 = translate_struct_type_entry env inl mte in let sign,alg,resolve,cst2 = check_with env sign with_decl alg (mp_from_mexpr mte) resolve in sign,alg,resolve,Univ.union_constraints cst1 cst2 and translate_module_type env mp inl mte = let mp_from = mp_from_mexpr mte in let sign,alg,resolve,cst = translate_struct_type_entry env inl mte in let mtb = subst_modtype_and_resolver {typ_mp = mp_from; typ_expr = sign; typ_expr_alg = None; typ_constraints = cst; typ_delta = resolve} mp in {mtb with typ_expr_alg = alg} let rec translate_struct_include_module_entry env mp inl = function | MSEident mp1 -> let mb = lookup_module mp1 env in let mb' = strengthen_and_subst_mb mb mp true in let mb_typ = clean_bounded_mod_expr mb'.mod_type in mb_typ,None,mb'.mod_delta,Univ.empty_constraint | MSEapply (fexpr,mexpr) -> let ftrans = translate_struct_include_module_entry env mp inl fexpr in translate_apply env inl ftrans mexpr (fun _ _ _ -> None) | _ -> error ("You cannot Include a high-order structure.") let rec add_struct_expr_constraints env = function | SEBident _ -> env | SEBfunctor (_,mtb,meb) -> add_struct_expr_constraints (add_modtype_constraints env mtb) meb | SEBstruct (structure_body) -> List.fold_left (fun env (_,item) -> add_struct_elem_constraints env item) env structure_body | SEBapply (meb1,meb2,cst) -> Environ.add_constraints cst (add_struct_expr_constraints (add_struct_expr_constraints env meb1) meb2) | SEBwith(meb,With_definition_body(_,cb))-> Environ.add_constraints cb.const_constraints (add_struct_expr_constraints env meb) | SEBwith(meb,With_module_body(_,_))-> add_struct_expr_constraints env meb and add_struct_elem_constraints env = function | SFBconst cb -> Environ.add_constraints cb.const_constraints env | SFBmind mib -> Environ.add_constraints mib.mind_constraints env | SFBmodule mb -> add_module_constraints env mb | SFBmodtype mtb -> add_modtype_constraints env mtb and add_module_constraints env mb = let env = match mb.mod_expr with | None -> env | Some meb -> add_struct_expr_constraints env meb in let env = add_struct_expr_constraints env mb.mod_type in Environ.add_constraints mb.mod_constraints env and add_modtype_constraints env mtb = Environ.add_constraints mtb.typ_constraints (add_struct_expr_constraints env mtb.typ_expr) let rec struct_expr_constraints cst = function | SEBident _ -> cst | SEBfunctor (_,mtb,meb) -> struct_expr_constraints (modtype_constraints cst mtb) meb | SEBstruct (structure_body) -> List.fold_left (fun cst (_,item) -> struct_elem_constraints cst item) cst structure_body | SEBapply (meb1,meb2,cst1) -> struct_expr_constraints (struct_expr_constraints (Univ.union_constraints cst1 cst) meb1) meb2 | SEBwith(meb,With_definition_body(_,cb))-> struct_expr_constraints (Univ.union_constraints cb.const_constraints cst) meb | SEBwith(meb,With_module_body(_,_))-> struct_expr_constraints cst meb and struct_elem_constraints cst = function | SFBconst cb -> cst | SFBmind mib -> cst | SFBmodule mb -> module_constraints cst mb | SFBmodtype mtb -> modtype_constraints cst mtb and module_constraints cst mb = let cst = match mb.mod_expr with | None -> cst | Some meb -> struct_expr_constraints cst meb in let cst = struct_expr_constraints cst mb.mod_type in Univ.union_constraints mb.mod_constraints cst and modtype_constraints cst mtb = struct_expr_constraints (Univ.union_constraints mtb.typ_constraints cst) mtb.typ_expr let struct_expr_constraints = struct_expr_constraints Univ.empty_constraint let module_constraints = module_constraints Univ.empty_constraint coq-8.4pl4/kernel/term_typing.mli0000644000175000017500000000244612326224777016165 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr * types option -> constr * types * Univ.constraints val translate_local_assum : env -> types -> types * Univ.constraints val infer_declaration : env -> constant_entry -> constant_def * constant_type * constraints * Sign.section_context option val build_constant_declaration : env -> 'a -> constant_def * constant_type * constraints * Sign.section_context option -> constant_body val translate_constant : env -> constant -> constant_entry -> constant_body val translate_mind : env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body val translate_recipe : env -> constant -> Cooking.recipe -> constant_body coq-8.4pl4/kernel/indtypes.ml0000644000175000017500000006137712326224777015322 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* idset | c::cl -> if Idset.mem c idset then raise (InductiveError (SameNamesConstructors c)) else check (Idset.add c idset) cl in check (* [mind_check_names mie] checks the names of an inductive types declaration, and raises the corresponding exceptions when two types or two constructors have the same name. *) let mind_check_names mie = let rec check indset cstset = function | [] -> () | ind::inds -> let id = ind.mind_entry_typename in let cl = ind.mind_entry_consnames in if Idset.mem id indset then raise (InductiveError (SameNamesTypes id)) else let cstset' = check_constructors_names cstset cl in check (Idset.add id indset) cstset' inds in check Idset.empty Idset.empty mie.mind_entry_inds (* The above verification is not necessary from the kernel point of vue since inductive and constructors are not referred to by their name, but only by the name of the inductive packet and an index. *) (************************************************************************) (************************************************************************) (* Typing the arities and constructor types *) let is_logic_type t = (t.utj_type = prop_sort) (* [infos] is a sequence of pair [islogic,issmall] for each type in the product of a constructor or arity *) let is_small infos = List.for_all (fun (logic,small) -> small) infos let is_logic_constr infos = List.for_all (fun (logic,small) -> logic) infos (* An inductive definition is a "unit" if it has only one constructor and that all arguments expected by this constructor are logical, this is the case for equality, conjunction of logical properties *) let is_unit constrsinfos = match constrsinfos with (* One info = One constructor *) | [constrinfos] -> is_logic_constr constrinfos | [] -> (* type without constructors *) true | _ -> false let rec infos_and_sort env t = let t = whd_betadeltaiota env t in match kind_of_term t with | Prod (name,c1,c2) -> let (varj,_) = infer_type env c1 in let env1 = Environ.push_rel (name,None,varj.utj_val) env in let logic = is_logic_type varj in let small = Term.is_small varj.utj_type in (logic,small) :: (infos_and_sort env1 c2) | _ when is_constructor_head t -> [] | _ -> (* don't fail if not positive, it is tested later *) [] let small_unit constrsinfos = let issmall = List.for_all is_small constrsinfos and isunit = is_unit constrsinfos in issmall, isunit (* Computing the levels of polymorphic inductive types For each inductive type of a block that is of level u_i, we have the constraints that u_i >= v_i where v_i is the type level of the types of the constructors of this inductive type. Each v_i depends of some of the u_i and of an extra (maybe non variable) universe, say w_i that summarize all the other constraints. Typically, for three inductive types, we could have u1,u2,u3,w1 <= u1 u1 w2 <= u2 u2,u3,w3 <= u3 From this system of inequations, we shall deduce w1,w2,w3 <= u1 w1,w2 <= u2 w1,w2,w3 <= u3 *) let extract_level (_,_,_,lc,lev) = (* Enforce that the level is not in Prop if more than two constructors *) if Array.length lc >= 2 then sup type0_univ lev else lev let inductive_levels arities inds = let levels = Array.map pi3 arities in let cstrs_levels = Array.map extract_level inds in (* Take the transitive closure of the system of constructors *) (* level constraints and remove the recursive dependencies *) solve_constraints_system levels cstrs_levels (* This (re)computes informations relevant to extraction and the sort of an arity or type constructor; we do not to recompute universes constraints *) let constraint_list_union = List.fold_left union_constraints empty_constraint let infer_constructor_packet env_ar_par params lc = (* type-check the constructors *) let jlc,cstl = List.split (List.map (infer_type env_ar_par) lc) in let cst = constraint_list_union cstl in let jlc = Array.of_list jlc in (* generalize the constructor over the parameters *) let lc'' = Array.map (fun j -> it_mkProd_or_LetIn j.utj_val params) jlc in (* compute the max of the sorts of the products of the constructor type *) let level = max_inductive_sort (Array.map (fun j -> j.utj_type) jlc) in (* compute *) let info = small_unit (List.map (infos_and_sort env_ar_par) lc) in (info,lc'',level,cst) (* Type-check an inductive definition. Does not check positivity conditions. *) let typecheck_inductive env mie = if mie.mind_entry_inds = [] then anomaly "empty inductive types declaration"; (* Check unicity of names *) mind_check_names mie; (* Params are typed-checked here *) let env_params, params, cst1 = infer_local_decls env mie.mind_entry_params in (* We first type arity of each inductive definition *) (* This allows to build the environment of arities and to share *) (* the set of constraints *) let cst, env_arities, rev_arity_list = List.fold_left (fun (cst,env_ar,l) ind -> (* Arities (without params) are typed-checked here *) let arity, cst2 = infer_type env_params ind.mind_entry_arity in (* We do not need to generate the universe of full_arity; if later, after the validation of the inductive definition, full_arity is used as argument or subject to cast, an upper universe will be generated *) let full_arity = it_mkProd_or_LetIn arity.utj_val params in let cst = union_constraints cst cst2 in let id = ind.mind_entry_typename in let env_ar' = push_rel (Name id, None, full_arity) (add_constraints cst2 env_ar) in let lev = (* Decide that if the conclusion is not explicitly Type *) (* then the inductive type is not polymorphic *) match kind_of_term ((strip_prod_assum arity.utj_val)) with | Sort (Type u) -> Some u | _ -> None in (cst,env_ar',(id,full_arity,lev)::l)) (cst1,env,[]) mie.mind_entry_inds in let arity_list = List.rev rev_arity_list in (* builds the typing context "Gamma, I1:A1, ... In:An, params" *) let env_ar_par = push_rel_context params (add_constraints cst1 env_arities) in (* Now, we type the constructors (without params) *) let inds,cst = List.fold_right2 (fun ind arity_data (inds,cst) -> let (info,lc',cstrs_univ,cst') = infer_constructor_packet env_ar_par params ind.mind_entry_lc in let consnames = ind.mind_entry_consnames in let ind' = (arity_data,consnames,info,lc',cstrs_univ) in (ind'::inds, union_constraints cst cst')) mie.mind_entry_inds arity_list ([],cst) in let inds = Array.of_list inds in let arities = Array.of_list arity_list in let param_ccls = List.fold_left (fun l (_,b,p) -> if b = None then (* Parameter contributes to polymorphism only if explicit Type *) let c = strip_prod_assum p in (* Add Type levels to the ordered list of parameters contributing to *) (* polymorphism unless there is aliasing (i.e. non distinct levels) *) match kind_of_term c with | Sort (Type u) -> if List.mem (Some u) l then None :: List.map (function Some v when u = v -> None | x -> x) l else Some u :: l | _ -> None :: l else l) [] params in (* Compute/check the sorts of the inductive types *) let ind_min_levels = inductive_levels arities inds in let inds, cst = array_fold_map2' (fun ((id,full_arity,ar_level),cn,info,lc,_) lev cst -> let sign, s = try dest_arity env full_arity with NotArity -> raise (InductiveError (NotAnArity (env, full_arity))) in let status,cst = match s with | Type u when ar_level <> None (* Explicitly polymorphic *) && no_upper_constraints u cst -> (* The polymorphic level is a function of the level of the *) (* conclusions of the parameters *) (* We enforce [u >= lev] in case [lev] has a strict upper *) (* constraints over [u] *) Inr (param_ccls, lev), enforce_geq u lev cst | Type u (* Not an explicit occurrence of Type *) -> Inl (info,full_arity,s), enforce_geq u lev cst | Prop Pos when engagement env <> Some ImpredicativeSet -> (* Predicative set: check that the content is indeed predicative *) if not (is_type0m_univ lev) & not (is_type0_univ lev) then raise (InductiveError LargeNonPropInductiveNotInType); Inl (info,full_arity,s), cst | Prop _ -> Inl (info,full_arity,s), cst in (id,cn,lc,(sign,status)),cst) inds ind_min_levels cst in (env_arities, params, inds, cst) (************************************************************************) (************************************************************************) (* Positivity *) type ill_formed_ind = | LocalNonPos of int | LocalNotEnoughArgs of int | LocalNotConstructor | LocalNonPar of int * int exception IllFormedInd of ill_formed_ind (* [mind_extract_params mie] extracts the params from an inductive types declaration, and checks that they are all present (and all the same) for all the given types. *) let mind_extract_params = decompose_prod_n_assum let explain_ind_err id ntyp env0 nbpar c nargs err = let (lpar,c') = mind_extract_params nbpar c in let env = push_rel_context lpar env0 in match err with | LocalNonPos kt -> raise (InductiveError (NonPos (env,c',mkRel (kt+nbpar)))) | LocalNotEnoughArgs kt -> raise (InductiveError (NotEnoughArgs (env,c',mkRel (kt+nbpar)))) | LocalNotConstructor -> raise (InductiveError (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nbpar,nargs))) | LocalNonPar (n,l) -> raise (InductiveError (NonPar (env,c',n,mkRel (nbpar-n+1), mkRel (l+nbpar)))) let failwith_non_pos n ntypes c = for k = n to n + ntypes - 1 do if not (noccurn k c) then raise (IllFormedInd (LocalNonPos (k-n+1))) done let failwith_non_pos_vect n ntypes v = Array.iter (failwith_non_pos n ntypes) v; anomaly "failwith_non_pos_vect: some k in [n;n+ntypes-1] should occur" let failwith_non_pos_list n ntypes l = List.iter (failwith_non_pos n ntypes) l; anomaly "failwith_non_pos_list: some k in [n;n+ntypes-1] should occur" (* Check the inductive type is called with the expected parameters *) let check_correct_par (env,n,ntypes,_) hyps l largs = let nparams = rel_context_nhyps hyps in let largs = Array.of_list largs in if Array.length largs < nparams then raise (IllFormedInd (LocalNotEnoughArgs l)); let (lpar,largs') = array_chop nparams largs in let nhyps = List.length hyps in let rec check k index = function | [] -> () | (_,Some _,_)::hyps -> check k (index+1) hyps | _::hyps -> match kind_of_term (whd_betadeltaiota env lpar.(k)) with | Rel w when w = index -> check (k-1) (index+1) hyps | _ -> raise (IllFormedInd (LocalNonPar (k+1,l))) in check (nparams-1) (n-nhyps) hyps; if not (array_for_all (noccur_between n ntypes) largs') then failwith_non_pos_vect n ntypes largs' (* Computes the maximum number of recursive parameters : the first parameters which are constant in recursive arguments n is the current depth, nmr is the maximum number of possible recursive parameters *) let compute_rec_par (env,n,_,_) hyps nmr largs = if nmr = 0 then 0 else (* start from 0, hyps will be in reverse order *) let (lpar,_) = list_chop nmr largs in let rec find k index = function ([],_) -> nmr | (_,[]) -> assert false (* |hyps|>=nmr *) | (lp,(_,Some _,_)::hyps) -> find k (index-1) (lp,hyps) | (p::lp,_::hyps) -> ( match kind_of_term (whd_betadeltaiota env p) with | Rel w when w = index -> find (k+1) (index-1) (lp,hyps) | _ -> k) in find 0 (n-1) (lpar,List.rev hyps) let lambda_implicit_lift n a = let implicit_sort = mkType (make_univ (make_dirpath [id_of_string "implicit"], 0)) in let lambda_implicit a = mkLambda (Anonymous, implicit_sort, a) in iterate lambda_implicit n (lift n a) (* This removes global parameters of the inductive types in lc (for nested inductive types only ) *) let abstract_mind_lc env ntyps npars lc = if npars = 0 then lc else let make_abs = list_tabulate (function i -> lambda_implicit_lift npars (mkRel (i+1))) ntyps in Array.map (substl make_abs) lc (* [env] is the typing environment [n] is the dB of the last inductive type [ntypes] is the number of inductive types in the definition (i.e. range of inductives is [n; n+ntypes-1]) [lra] is the list of recursive tree of each variable *) let ienv_push_var (env, n, ntypes, lra) (x,a,ra) = (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra) let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) = let auxntyp = 1 in let specif = lookup_mind_specif env mi in let env' = push_rel (Anonymous,None, hnf_prod_applist env (type_of_inductive env specif) lpar) env in let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in (* New index of the inductive types *) let newidx = n + auxntyp in (env', newidx, ntypes, ra_env') let rec ienv_decompose_prod (env,_,_,_ as ienv) n c = if n=0 then (ienv,c) else let c' = whd_betadeltaiota env c in match kind_of_term c' with Prod(na,a,b) -> let ienv' = ienv_push_var ienv (na,a,mk_norec) in ienv_decompose_prod ienv' (n-1) b | _ -> assert false let array_min nmr a = if nmr = 0 then 0 else Array.fold_left (fun k (nmri,_) -> min k nmri) nmr a (* The recursive function that checks positivity and builds the list of recursive arguments *) let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcnames indlc = let lparams = rel_context_length hyps in let nmr = rel_context_nhyps hyps in (* Checking the (strict) positivity of a constructor argument type [c] *) let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c = let x,largs = decompose_app (whd_betadeltaiota env c) in match kind_of_term x with | Prod (na,b,d) -> assert (largs = []); (match weaker_noccur_between env n ntypes b with None -> failwith_non_pos_list n ntypes [b] | Some b -> check_pos (ienv_push_var ienv (na, b, mk_norec)) nmr d) | Rel k -> (try let (ra,rarg) = List.nth ra_env (k-1) in let nmr1 = (match ra with Mrec _ -> compute_rec_par ienv hyps nmr largs | _ -> nmr) in if not (List.for_all (noccur_between n ntypes) largs) then failwith_non_pos_list n ntypes largs else (nmr1,rarg) with Failure _ | Invalid_argument _ -> (nmr,mk_norec)) | Ind ind_kn -> (* If the inductive type being defined appears in a parameter, then we have a nested indtype *) if List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec) else check_positive_nested ienv nmr (ind_kn, largs) | err -> if noccur_between n ntypes x && List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec) else failwith_non_pos_list n ntypes (x::largs) (* accesses to the environment are not factorised, but is it worth? *) and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr (mi, largs) = let (mib,mip) = lookup_mind_specif env mi in let auxnpar = mib.mind_nparams_rec in let nonrecpar = mib.mind_nparams - auxnpar in let (lpar,auxlargs) = try list_chop auxnpar largs with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in (* If the inductive appears in the args (non params) then the definition is not positive. *) if not (List.for_all (noccur_between n ntypes) auxlargs) then failwith_non_pos_list n ntypes auxlargs; (* We do not deal with imbricated mutual inductive types *) let auxntyp = mib.mind_ntypes in if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n)); (* The nested inductive type with parameters removed *) let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in (* Extends the environment with a variable corresponding to the inductive def *) let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in (* Parameters expressed in env' *) let lpar' = List.map (lift auxntyp) lpar in let irecargs_nmr = (* fails if the inductive type occurs non positively *) (* with recursive parameters substituted *) Array.map (function c -> let c' = hnf_prod_applist env' c lpar' in (* skip non-recursive parameters *) let (ienv',c') = ienv_decompose_prod ienv' nonrecpar c' in check_constructors ienv' false nmr c') auxlcvect in let irecargs = Array.map snd irecargs_nmr and nmr' = array_min nmr irecargs_nmr in (nmr',(Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0)) (* check the inductive types occur positively in the products of C, if check_head=true, also check the head corresponds to a constructor of the ith type *) and check_constructors ienv check_head nmr c = let rec check_constr_rec (env,n,ntypes,ra_env as ienv) nmr lrec c = let x,largs = decompose_app (whd_betadeltaiota env c) in match kind_of_term x with | Prod (na,b,d) -> assert (largs = []); let nmr',recarg = check_pos ienv nmr b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in check_constr_rec ienv' nmr' (recarg::lrec) d | hd -> if check_head then if hd = Rel (n+ntypes-i-1) then check_correct_par ienv hyps (ntypes-i) largs else raise (IllFormedInd LocalNotConstructor) else if not (List.for_all (noccur_between n ntypes) largs) then failwith_non_pos_list n ntypes largs; (nmr,List.rev lrec) in check_constr_rec ienv nmr [] c in let irecargs_nmr = array_map2 (fun id c -> let _,rawc = mind_extract_params lparams c in try check_constructors ienv true nmr rawc with IllFormedInd err -> explain_ind_err id (ntypes-i) env lparams c nargs err) (Array.of_list lcnames) indlc in let irecargs = Array.map snd irecargs_nmr and nmr' = array_min nmr irecargs_nmr in (nmr', mk_paths (Mrec ind) irecargs) let check_positivity kn env_ar params inds = let ntypes = Array.length inds in let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in let lra_ind = List.rev (Array.to_list rc) in let lparams = rel_context_length params in let nmr = rel_context_nhyps params in let check_one i (_,lcnames,lc,(sign,_)) = let ra_env = list_tabulate (fun _ -> (Norec,mk_norec)) lparams @ lra_ind in let ienv = (env_ar, 1+lparams, ntypes, ra_env) in let nargs = rel_context_nhyps sign - nmr in check_positivity_one ienv params (kn,i) nargs lcnames lc in let irecargs_nmr = Array.mapi check_one inds in let irecargs = Array.map snd irecargs_nmr and nmr' = array_min nmr irecargs_nmr in (nmr',Rtree.mk_rec irecargs) (************************************************************************) (************************************************************************) (* Build the inductive packet *) (* Allowed eliminations *) let all_sorts = [InProp;InSet;InType] let small_sorts = [InProp;InSet] let logical_sorts = [InProp] let allowed_sorts issmall isunit s = match family_of_sort s with (* Type: all elimination allowed *) | InType -> all_sorts (* Small Set is predicative: all elimination allowed *) | InSet when issmall -> all_sorts (* Large Set is necessarily impredicative: forbids large elimination *) | InSet -> small_sorts (* Unitary/empty Prop: elimination to all sorts are realizable *) (* unless the type is large. If it is large, forbids large elimination *) (* which otherwise allows to simulate the inconsistent system Type:Type *) | InProp when isunit -> if issmall then all_sorts else small_sorts (* Other propositions: elimination only to Prop *) | InProp -> logical_sorts let fold_inductive_blocks f = Array.fold_left (fun acc (_,_,lc,(arsign,_)) -> f (Array.fold_left f acc lc) (it_mkProd_or_LetIn (* dummy *) mkSet arsign)) let used_section_variables env inds = let ids = fold_inductive_blocks (fun l c -> Idset.union (Environ.global_vars_set env c) l) Idset.empty inds in keep_hyps env ids let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = let ntypes = Array.length inds in (* Compute the set of used section variables *) let hyps = used_section_variables env inds in let nparamargs = rel_context_nhyps params in let nparamdecls = rel_context_length params in (* Check one inductive *) let build_one_packet (id,cnames,lc,(ar_sign,ar_kind)) recarg = (* Type of constructors in normal form *) let splayed_lc = Array.map (dest_prod_assum env_ar) lc in let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b d) splayed_lc in let consnrealargs = Array.map (fun (d,_) -> rel_context_length d - rel_context_length params) splayed_lc in (* Elimination sorts *) let arkind,kelim = match ar_kind with | Inr (param_levels,lev) -> Polymorphic { poly_param_levels = param_levels; poly_level = lev; }, all_sorts | Inl ((issmall,isunit),ar,s) -> let kelim = allowed_sorts issmall isunit s in Monomorphic { mind_user_arity = ar; mind_sort = s; }, kelim in (* Assigning VM tags to constructors *) let nconst, nblock = ref 0, ref 0 in let transf num = let arity = List.length (dest_subterms recarg).(num) in if arity = 0 then let p = (!nconst, 0) in incr nconst; p else let p = (!nblock + 1, arity) in incr nblock; p (* les tag des constructeur constant commence a 0, les tag des constructeur non constant a 1 (0 => accumulator) *) in let rtbl = Array.init (List.length cnames) transf in (* Build the inductive packet *) { mind_typename = id; mind_arity = arkind; mind_arity_ctxt = ar_sign; mind_nrealargs = rel_context_nhyps ar_sign - nparamargs; mind_nrealargs_ctxt = rel_context_length ar_sign - nparamdecls; mind_kelim = kelim; mind_consnames = Array.of_list cnames; mind_consnrealdecls = consnrealargs; mind_user_lc = lc; mind_nf_lc = nf_lc; mind_recargs = recarg; mind_nb_constant = !nconst; mind_nb_args = !nblock; mind_reloc_tbl = rtbl; } in let packets = array_map2 build_one_packet inds recargs in (* Build the mutual inductive *) { mind_record = isrecord; mind_ntypes = ntypes; mind_finite = isfinite; mind_hyps = hyps; mind_nparams = nparamargs; mind_nparams_rec = nmr; mind_params_ctxt = params; mind_packets = packets; mind_constraints = cst } (************************************************************************) (************************************************************************) let check_inductive env kn mie = (* First type-check the inductive definition *) let (env_ar, params, inds, cst) = typecheck_inductive env mie in (* Then check positivity conditions *) let (nmr,recargs) = check_positivity kn env_ar params inds in (* Build the inductive packets *) build_inductive env env_ar params mie.mind_entry_record mie.mind_entry_finite inds nmr recargs cst coq-8.4pl4/kernel/typeops.ml0000644000175000017500000004003012326224777015145 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* let c' = try default_conv CUMUL env t1 t2 with NotConvertible -> raise (NotConvertibleVect i) in union_constraints c c') empty_constraint v1 v2 (* This should be a type (a priori without intension to be an assumption) *) let type_judgment env j = match kind_of_term(whd_betadeltaiota env j.uj_type) with | Sort s -> {utj_val = j.uj_val; utj_type = s } | _ -> error_not_type env j (* This should be a type intended to be assumed. The error message is *) (* not as useful as for [type_judgment]. *) let assumption_of_judgment env j = try (type_judgment env j).utj_val with TypeError _ -> error_assumption env j (************************************************) (* Incremental typing rules: builds a typing judgement given the *) (* judgements for the subterms. *) (*s Type of sorts *) (* Prop and Set *) let judge_of_prop = { uj_val = mkProp; uj_type = mkSort type1_sort } let judge_of_set = { uj_val = mkSet; uj_type = mkSort type1_sort } let judge_of_prop_contents = function | Null -> judge_of_prop | Pos -> judge_of_set (* Type of Type(i). *) let judge_of_type u = let uu = super u in { uj_val = mkType u; uj_type = mkType uu } (*s Type of a de Bruijn index. *) let judge_of_relative env n = try let (_,_,typ) = lookup_rel n env in { uj_val = mkRel n; uj_type = lift n typ } with Not_found -> error_unbound_rel env n (* Type of variables *) let judge_of_variable env id = try let ty = named_type id env in make_judge (mkVar id) ty with Not_found -> error_unbound_var env id (* Management of context of variables. *) (* Checks if a context of variable can be instantiated by the variables of the current env *) (* TODO: check order? *) let rec check_hyps_inclusion env sign = Sign.fold_named_context (fun (id,_,ty1) () -> let ty2 = named_type id env in if not (eq_constr ty2 ty1) then error "types do not match") sign ~init:() let check_args env c hyps = try check_hyps_inclusion env hyps with UserError _ | Not_found -> error_reference_variables env c (* Checks if the given context of variables [hyps] is included in the current context of [env]. *) (* let check_hyps id env hyps = let hyps' = named_context env in if not (hyps_inclusion env hyps hyps') then error_reference_variables env id *) (* Instantiation of terms on real arguments. *) (* Make a type polymorphic if an arity *) let extract_level env p = let _,c = dest_prod_assum env p in match kind_of_term c with Sort (Type u) -> Some u | _ -> None let extract_context_levels env = List.fold_left (fun l (_,b,p) -> if b=None then extract_level env p::l else l) [] let make_polymorphic_if_constant_for_ind env {uj_val = c; uj_type = t} = let params, ccl = dest_prod_assum env t in match kind_of_term ccl with | Sort (Type u) when isInd (fst (decompose_app (whd_betadeltaiota env c))) -> let param_ccls = extract_context_levels env params in let s = { poly_param_levels = param_ccls; poly_level = u} in PolymorphicArity (params,s) | _ -> NonPolymorphicType t (* Type of constants *) let type_of_constant_knowing_parameters env t paramtyps = match t with | NonPolymorphicType t -> t | PolymorphicArity (sign,ar) -> let ctx = List.rev sign in let ctx,s = instantiate_universes env ctx ar paramtyps in mkArity (List.rev ctx,s) let type_of_constant_type env t = type_of_constant_knowing_parameters env t [||] let type_of_constant env cst = type_of_constant_type env (constant_type env cst) let judge_of_constant_knowing_parameters env cst jl = let c = mkConst cst in let cb = lookup_constant cst env in let _ = check_args env c cb.const_hyps in let paramstyp = Array.map (fun j -> j.uj_type) jl in let t = type_of_constant_knowing_parameters env cb.const_type paramstyp in make_judge c t let judge_of_constant env cst = judge_of_constant_knowing_parameters env cst [||] (* Type of a lambda-abstraction. *) (* [judge_of_abstraction env name var j] implements the rule env, name:typ |- j.uj_val:j.uj_type env, |- (name:typ)j.uj_type : s ----------------------------------------------------------------------- env |- [name:typ]j.uj_val : (name:typ)j.uj_type Since all products are defined in the Calculus of Inductive Constructions and no upper constraint exists on the sort $s$, we don't need to compute $s$ *) let judge_of_abstraction env name var j = { uj_val = mkLambda (name, var.utj_val, j.uj_val); uj_type = mkProd (name, var.utj_val, j.uj_type) } (* Type of let-in. *) let judge_of_letin env name defj typj j = { uj_val = mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val) ; uj_type = subst1 defj.uj_val j.uj_type } (* Type of an application. *) let judge_of_apply env funj argjv = let rec apply_rec n typ cst = function | [] -> { uj_val = mkApp (j_val funj, Array.map j_val argjv); uj_type = typ }, cst | hj::restjl -> (match kind_of_term (whd_betadeltaiota env typ) with | Prod (_,c1,c2) -> (try let c = conv_leq false env hj.uj_type c1 in let cst' = union_constraints cst c in apply_rec (n+1) (subst1 hj.uj_val c2) cst' restjl with NotConvertible -> error_cant_apply_bad_type env (n,c1, hj.uj_type) funj argjv) | _ -> error_cant_apply_not_functional env funj argjv) in apply_rec 1 funj.uj_type empty_constraint (Array.to_list argjv) (* Type of product *) let sort_of_product env domsort rangsort = match (domsort, rangsort) with (* Product rule (s,Prop,Prop) *) | (_, Prop Null) -> rangsort (* Product rule (Prop/Set,Set,Set) *) | (Prop _, Prop Pos) -> rangsort (* Product rule (Type,Set,?) *) | (Type u1, Prop Pos) -> if engagement env = Some ImpredicativeSet then (* Rule is (Type,Set,Set) in the Set-impredicative calculus *) rangsort else (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) Type (sup u1 type0_univ) (* Product rule (Prop,Type_i,Type_i) *) | (Prop Pos, Type u2) -> Type (sup type0_univ u2) (* Product rule (Prop,Type_i,Type_i) *) | (Prop Null, Type _) -> rangsort (* Product rule (Type_i,Type_i,Type_i) *) | (Type u1, Type u2) -> Type (sup u1 u2) (* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule env |- typ1:s1 env, name:typ1 |- typ2 : s2 ------------------------------------------------------------------------- s' >= (s1,s2), env |- (name:typ)j.uj_val : s' where j.uj_type is convertible to a sort s2 *) let judge_of_product env name t1 t2 = let s = sort_of_product env t1.utj_type t2.utj_type in { uj_val = mkProd (name, t1.utj_val, t2.utj_val); uj_type = mkSort s } (* Type of a type cast *) (* [judge_of_cast env (c,typ1) (typ2,s)] implements the rule env |- c:typ1 env |- typ2:s env |- typ1 <= typ2 --------------------------------------------------------------------- env |- c:typ2 *) let judge_of_cast env cj k tj = let expected_type = tj.utj_val in try let c, cst = match k with | VMcast -> mkCast (cj.uj_val, k, expected_type), vm_conv CUMUL env cj.uj_type expected_type | DEFAULTcast -> mkCast (cj.uj_val, k, expected_type), conv_leq false env cj.uj_type expected_type | REVERTcast -> cj.uj_val, conv_leq true env cj.uj_type expected_type in { uj_val = c; uj_type = expected_type }, cst with NotConvertible -> error_actual_type env cj expected_type (* Inductive types. *) (* The type is parametric over the uniform parameters whose conclusion is in Type; to enforce the internal constraints between the parameters and the instances of Type occurring in the type of the constructors, we use the level variables _statically_ assigned to the conclusions of the parameters as mediators: e.g. if a parameter has conclusion Type(alpha), static constraints of the form alpha<=v exist between alpha and the Type's occurring in the constructor types; when the parameters is finally instantiated by a term of conclusion Type(u), then the constraints u<=alpha is computed in the App case of execute; from this constraints, the expected dynamic constraints of the form u<=v are enforced *) let judge_of_inductive_knowing_parameters env ind jl = let c = mkInd ind in let (mib,mip) = lookup_mind_specif env ind in check_args env c mib.mind_hyps; let paramstyp = Array.map (fun j -> j.uj_type) jl in let t = Inductive.type_of_inductive_knowing_parameters env mip paramstyp in make_judge c t let judge_of_inductive env ind = judge_of_inductive_knowing_parameters env ind [||] (* Constructors. *) let judge_of_constructor env c = let constr = mkConstruct c in let _ = let ((kn,_),_) = c in let mib = lookup_mind kn env in check_args env constr mib.mind_hyps in let specif = lookup_mind_specif env (inductive_of_constructor c) in make_judge constr (type_of_constructor c specif) (* Case. *) let check_branch_types env ind cj (lfj,explft) = try conv_leq_vecti env (Array.map j_type lfj) explft with NotConvertibleVect i -> error_ill_formed_branch env cj.uj_val (ind,i+1) lfj.(i).uj_type explft.(i) | Invalid_argument _ -> error_number_branches env cj (Array.length explft) let judge_of_case env ci pj cj lfj = let indspec = try find_rectype env cj.uj_type with Not_found -> error_case_not_inductive env cj in let _ = check_case_info env (fst indspec) ci in let (bty,rslty,univ) = type_case_branches env indspec pj cj.uj_val in let univ' = check_branch_types env (fst indspec) cj (lfj,bty) in ({ uj_val = mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, Array.map j_val lfj); uj_type = rslty }, union_constraints univ univ') (* Fixpoints. *) (* Checks the type of a general (co)fixpoint, i.e. without checking *) (* the specific guard condition. *) let type_fixpoint env lna lar vdefj = let lt = Array.length vdefj in assert (Array.length lar = lt); try conv_leq_vecti env (Array.map j_type vdefj) (Array.map (fun ty -> lift lt ty) lar) with NotConvertibleVect i -> error_ill_typed_rec_body env i lna vdefj lar (************************************************************************) (************************************************************************) (* This combinator adds the universe constraints both in the local graph and in the universes of the environment. This is to ensure that the infered local graph is satisfiable. *) let univ_combinator (cst,univ) (j,c') = (j,(union_constraints cst c', merge_constraints c' univ)) (* The typing machine. *) (* ATTENTION : faudra faire le typage du contexte des Const, Ind et Constructsi un jour cela devient des constructions arbitraires et non plus des variables *) let rec execute env cstr cu = match kind_of_term cstr with (* Atomic terms *) | Sort (Prop c) -> (judge_of_prop_contents c, cu) | Sort (Type u) -> (judge_of_type u, cu) | Rel n -> (judge_of_relative env n, cu) | Var id -> (judge_of_variable env id, cu) | Const c -> (judge_of_constant env c, cu) (* Lambda calculus operators *) | App (f,args) -> let (jl,cu1) = execute_array env args cu in let (j,cu2) = match kind_of_term f with | Ind ind -> (* Sort-polymorphism of inductive types *) judge_of_inductive_knowing_parameters env ind jl, cu1 | Const cst -> (* Sort-polymorphism of constant *) judge_of_constant_knowing_parameters env cst jl, cu1 | _ -> (* No sort-polymorphism *) execute env f cu1 in univ_combinator cu2 (judge_of_apply env j jl) | Lambda (name,c1,c2) -> let (varj,cu1) = execute_type env c1 cu in let env1 = push_rel (name,None,varj.utj_val) env in let (j',cu2) = execute env1 c2 cu1 in (judge_of_abstraction env name varj j', cu2) | Prod (name,c1,c2) -> let (varj,cu1) = execute_type env c1 cu in let env1 = push_rel (name,None,varj.utj_val) env in let (varj',cu2) = execute_type env1 c2 cu1 in (judge_of_product env name varj varj', cu2) | LetIn (name,c1,c2,c3) -> let (j1,cu1) = execute env c1 cu in let (j2,cu2) = execute_type env c2 cu1 in let (_,cu3) = univ_combinator cu2 (judge_of_cast env j1 DEFAULTcast j2) in let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in let (j',cu4) = execute env1 c3 cu3 in (judge_of_letin env name j1 j2 j', cu4) | Cast (c,k, t) -> let (cj,cu1) = execute env c cu in let (tj,cu2) = execute_type env t cu1 in univ_combinator cu2 (judge_of_cast env cj k tj) (* Inductive types *) | Ind ind -> (judge_of_inductive env ind, cu) | Construct c -> (judge_of_constructor env c, cu) | Case (ci,p,c,lf) -> let (cj,cu1) = execute env c cu in let (pj,cu2) = execute env p cu1 in let (lfj,cu3) = execute_array env lf cu2 in univ_combinator cu3 (judge_of_case env ci pj cj lfj) | Fix ((vn,i as vni),recdef) -> let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in let fix = (vni,recdef') in check_fix env fix; (make_judge (mkFix fix) fix_ty, cu1) | CoFix (i,recdef) -> let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in let cofix = (i,recdef') in check_cofix env cofix; (make_judge (mkCoFix cofix) fix_ty, cu1) (* Partial proofs: unsupported by the kernel *) | Meta _ -> anomaly "the kernel does not support metavariables" | Evar _ -> anomaly "the kernel does not support existential variables" and execute_type env constr cu = let (j,cu1) = execute env constr cu in (type_judgment env j, cu1) and execute_recdef env (names,lar,vdef) i cu = let (larj,cu1) = execute_array env lar cu in let lara = Array.map (assumption_of_judgment env) larj in let env1 = push_rec_types (names,lara,vdef) env in let (vdefj,cu2) = execute_array env1 vdef cu1 in let vdefv = Array.map j_val vdefj in let cst = type_fixpoint env1 names lara vdefj in univ_combinator cu2 ((lara.(i),(names,lara,vdefv)),cst) and execute_array env = array_fold_map' (execute env) (* Derived functions *) let infer env constr = let (j,(cst,_)) = execute env constr (empty_constraint, universes env) in assert (eq_constr j.uj_val constr); (j, cst) let infer_type env constr = let (j,(cst,_)) = execute_type env constr (empty_constraint, universes env) in (j, cst) let infer_v env cv = let (jv,(cst,_)) = execute_array env cv (empty_constraint, universes env) in (jv, cst) (* Typing of several terms. *) let infer_local_decl env id = function | LocalDef c -> let (j,cst) = infer env c in (Name id, Some j.uj_val, j.uj_type), cst | LocalAssum c -> let (j,cst) = infer env c in (Name id, None, assumption_of_judgment env j), cst let infer_local_decls env decls = let rec inferec env = function | (id, d) :: l -> let env, l, cst1 = inferec env l in let d, cst2 = infer_local_decl env id d in push_rel d env, add_rel_decl d l, union_constraints cst1 cst2 | [] -> env, empty_rel_context, empty_constraint in inferec env decls (* Exported typing functions *) let typing env c = let (j,cst) = infer env c in let _ = add_constraints cst env in j coq-8.4pl4/kernel/cbytegen.ml0000644000175000017500000010011412326224777015242 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* *) (* type = [Ct1 | .... | Ctn] *) (* Ci is the code pointer of the i-th body *) (* At runtime, a fixpoint environment (which is the same as the fixpoint *) (* itself) is a pointer to the field holding its code pointer. *) (* In each fixpoint body, de Bruijn [nbr] represents the first fixpoint *) (* and de Bruijn [1] the last one. *) (* Access to these variables is performed by the [Koffsetclosure n] *) (* instruction that shifts the environment pointer of [n] fields. *) (* This allows to represent mutual fixpoints in just one block. *) (* [Ct1 | ... | Ctn] is an array holding code pointers of the fixpoint *) (* types. They are used in conversion tests (which requires that *) (* fixpoint types must be convertible). Their environment is the one of *) (* the last fixpoint : *) (* [t1|C1| ... |tc|Cc| ... |t(nbr)|C(nbr)| fv1 | fv2 | .... | fvn | type] *) (* ^ *) (* Representation of mutual cofix : *) (* a1 = [A_t | accumulate | [Cfx_t | fcofix1 ] ] *) (* ... *) (* anbr = [A_t | accumulate | [Cfx_t | fcofixnbr ] ] *) (* *) (* fcofix1 = [clos_t | code1 | a1 |...| anbr | fv1 |...| fvn | type] *) (* ^ *) (* ... *) (* fcofixnbr = [clos_t | codenbr | a1 |...| anbr | fv1 |...| fvn | type] *) (* ^ *) (* The [ai] blocks are functions that accumulate their arguments: *) (* ai arg1 argp ---> *) (* ai' = [A_t | accumulate | [Cfx_t | fcofixi] | arg1 | ... | argp ] *) (* If such a block is matched against, we have to force evaluation, *) (* function [fcofixi] is then applied to [ai'] [arg1] ... [argp] *) (* Once evaluation is completed [ai'] is updated with the result: *) (* ai' <-- *) (* [A_t | accumulate | [Cfxe_t |fcofixi|result] | arg1 | ... | argp ] *) (* This representation is nice because the application of the cofix is *) (* evaluated only once (it simulates a lazy evaluation) *) (* Moreover, when cofix don't have arguments, it is possible to create *) (* a cycle, e.g.: *) (* cofix one := cons 1 one *) (* a1 = [A_t | accumulate | [Cfx_t|fcofix1] ] *) (* fcofix1 = [clos_t | code | a1] *) (* The result of evaluating [a1] is [cons_t | 1 | a1]. *) (* When [a1] is updated : *) (* a1 = [A_t | accumulate | [Cfxe_t | fcofix1 | [cons_t | 1 | a1]] ] *) (* The cycle is created ... *) (* *) (* In Cfxe_t accumulators, we need to store [fcofixi] for testing *) (* conversion of cofixpoints (which is intentional). *) let empty_fv = { size= 0; fv_rev = [] } let fv r = !(r.in_env) let empty_comp_env ()= { nb_stack = 0; in_stack = []; nb_rec = 0; pos_rec = []; offset = 0; in_env = ref empty_fv; } (*i Creation functions for comp_env *) let rec add_param n sz l = if n = 0 then l else add_param (n - 1) sz (n+sz::l) let comp_env_fun arity = { nb_stack = arity; in_stack = add_param arity 0 []; nb_rec = 0; pos_rec = []; offset = 1; in_env = ref empty_fv } let comp_env_fix_type rfv = { nb_stack = 0; in_stack = []; nb_rec = 0; pos_rec = []; offset = 1; in_env = rfv } let comp_env_fix ndef curr_pos arity rfv = let prec = ref [] in for i = ndef downto 1 do prec := Koffsetclosure (2 * (ndef - curr_pos - i)) :: !prec done; { nb_stack = arity; in_stack = add_param arity 0 []; nb_rec = ndef; pos_rec = !prec; offset = 2 * (ndef - curr_pos - 1)+1; in_env = rfv } let comp_env_cofix_type ndef rfv = { nb_stack = 0; in_stack = []; nb_rec = 0; pos_rec = []; offset = 1+ndef; in_env = rfv } let comp_env_cofix ndef arity rfv = let prec = ref [] in for i = 1 to ndef do prec := Kenvacc i :: !prec done; { nb_stack = arity; in_stack = add_param arity 0 []; nb_rec = ndef; pos_rec = !prec; offset = ndef+1; in_env = rfv } (* [push_param ] add function parameters on the stack *) let push_param n sz r = { r with nb_stack = r.nb_stack + n; in_stack = add_param n sz r.in_stack } (* [push_local sz r] add a new variable on the stack at position [sz] *) let push_local sz r = { r with nb_stack = r.nb_stack + 1; in_stack = (sz + 1) :: r.in_stack } (*i Compilation of variables *) let find_at el l = let rec aux n = function | [] -> raise Not_found | hd :: tl -> if hd = el then n else aux (n+1) tl in aux 1 l let pos_named id r = let env = !(r.in_env) in let cid = FVnamed id in try Kenvacc(r.offset + env.size - (find_at cid env.fv_rev)) with Not_found -> let pos = env.size in r.in_env := { size = pos+1; fv_rev = cid:: env.fv_rev}; Kenvacc (r.offset + pos) let pos_rel i r sz = if i <= r.nb_stack then Kacc(sz - (List.nth r.in_stack (i-1))) else let i = i - r.nb_stack in if i <= r.nb_rec then try List.nth r.pos_rec (i-1) with (Failure _|Invalid_argument _) -> assert false else let i = i - r.nb_rec in let db = FVrel(i) in let env = !(r.in_env) in try Kenvacc(r.offset + env.size - (find_at db env.fv_rev)) with Not_found -> let pos = env.size in r.in_env := { size = pos+1; fv_rev = db:: env.fv_rev}; Kenvacc(r.offset + pos) (*i Examination of the continuation *) (* Discard all instructions up to the next label. *) (* This function is to be applied to the continuation before adding a *) (* non-terminating instruction (branch, raise, return, appterm) *) (* in front of it. *) let rec discard_dead_code cont = cont (*function [] -> [] | (Klabel _ | Krestart ) :: _ as cont -> cont | _ :: cont -> discard_dead_code cont *) (* Return a label to the beginning of the given continuation. *) (* If the sequence starts with a branch, use the target of that branch *) (* as the label, thus avoiding a jump to a jump. *) let label_code = function | Klabel lbl :: _ as cont -> (lbl, cont) | Kbranch lbl :: _ as cont -> (lbl, cont) | cont -> let lbl = Label.create() in (lbl, Klabel lbl :: cont) (* Return a branch to the continuation. That is, an instruction that, when executed, branches to the continuation or performs what the continuation performs. We avoid generating branches to returns. *) (* spiwack: make_branch was only used once. Changed it back to the ZAM one to match the appropriate semantics (old one avoided the introduction of an unconditional branch operation, which seemed appropriate for the 31-bit integers' code). As a memory, I leave the former version in this comment. let make_branch cont = match cont with | (Kreturn _ as return) :: cont' -> return, cont' | Klabel lbl as b :: _ -> b, cont | _ -> let b = Klabel(Label.create()) in b,b::cont *) let rec make_branch_2 lbl n cont = function Kreturn m :: _ -> (Kreturn (n + m), cont) | Klabel _ :: c -> make_branch_2 lbl n cont c | Kpop m :: c -> make_branch_2 lbl (n + m) cont c | _ -> match lbl with Some lbl -> (Kbranch lbl, cont) | None -> let lbl = Label.create() in (Kbranch lbl, Klabel lbl :: cont) let make_branch cont = match cont with (Kbranch _ as branch) :: _ -> (branch, cont) | (Kreturn _ as return) :: _ -> (return, cont) | Klabel lbl :: _ -> make_branch_2 (Some lbl) 0 cont cont | _ -> make_branch_2 (None) 0 cont cont (* Check if we're in tailcall position *) let rec is_tailcall = function | Kreturn k :: _ -> Some k | Klabel _ :: c -> is_tailcall c | _ -> None (* Extention of the continuation *) (* Add a Kpop n instruction in front of a continuation *) let rec add_pop n = function | Kpop m :: cont -> add_pop (n+m) cont | Kreturn m:: cont -> Kreturn (n+m) ::cont | cont -> if n = 0 then cont else Kpop n :: cont let add_grab arity lbl cont = if arity = 1 then Klabel lbl :: cont else Krestart :: Klabel lbl :: Kgrab (arity - 1) :: cont let add_grabrec rec_arg arity lbl cont = if arity = 1 then Klabel lbl :: Kgrabrec 0 :: Krestart :: cont else Krestart :: Klabel lbl :: Kgrabrec rec_arg :: Krestart :: Kgrab (arity - 1) :: cont (* continuation of a cofix *) let cont_cofix arity = (* accu = res *) (* stk = ai::args::ra::... *) (* ai = [At|accumulate|[Cfx_t|fcofix]|args] *) [ Kpush; Kpush; (* stk = res::res::ai::args::ra::... *) Kacc 2; Kfield 1; Kfield 0; Kmakeblock(2, cofix_evaluated_tag); Kpush; (* stk = [Cfxe_t|fcofix|res]::res::ai::args::ra::...*) Kacc 2; Ksetfield 1; (* ai = [At|accumulate|[Cfxe_t|fcofix|res]|args] *) (* stk = res::ai::args::ra::... *) Kacc 0; (* accu = res *) Kreturn (arity+2) ] (*i Global environment *) let global_env = ref empty_env let set_global_env env = global_env := env (* Code of closures *) let fun_code = ref [] let init_fun_code () = fun_code := [] (* Compilation of constructors and inductive types *) (* Inv : nparam + arity > 0 *) let code_construct tag nparams arity cont = let f_cont = add_pop nparams (if arity = 0 then [Kconst (Const_b0 tag); Kreturn 0] else [Kacc 0; Kpop 1; Kmakeblock(arity, tag); Kreturn 0]) in let lbl = Label.create() in fun_code := [Ksequence (add_grab (nparams+arity) lbl f_cont,!fun_code)]; Kclosure(lbl,0) :: cont let get_strcst = function | Bstrconst sc -> sc | _ -> raise Not_found let rec str_const c = match kind_of_term c with | Sort s -> Bstrconst (Const_sorts s) | Cast(c,_,_) -> str_const c | App(f,args) -> begin match kind_of_term f with | Construct((kn,j),i) -> begin let oib = lookup_mind kn !global_env in let oip = oib.mind_packets.(j) in let num,arity = oip.mind_reloc_tbl.(i-1) in let nparams = oib.mind_nparams in if nparams + arity = Array.length args then (* spiwack: *) (* 1/ tries to compile the constructor in an optimal way, it is supposed to work only if the arguments are all fully constructed, fails with Cbytecodes.NotClosed. it can also raise Not_found when there is no special treatment for this constructor for instance: tries to to compile an integer of the form I31 D1 D2 ... D31 to [D1D2...D31] as a processor number (a caml number actually) *) try try Bstrconst (Retroknowledge.get_vm_constant_static_info (!global_env).retroknowledge (kind_of_term f) args) with NotClosed -> (* 2/ if the arguments are not all closed (this is expectingly (and it is currently the case) the only reason why this exception is raised) tries to give a clever, run-time behavior to the constructor. Raises Not_found if there is no special treatment for this integer. this is done in a lazy fashion, using the constructor Bspecial because it needs to know the continuation and such, which can't be done at this time. for instance, for int31: if one of the digit is not closed, it's not impossible that the number gets fully instanciated at run-time, thus to ensure uniqueness of the representation in the vm it is necessary to try and build a caml integer during the execution *) let rargs = Array.sub args nparams arity in let b_args = Array.map str_const rargs in Bspecial ((Retroknowledge.get_vm_constant_dynamic_info (!global_env).retroknowledge (kind_of_term f)), b_args) with Not_found -> (* 3/ if no special behavior is available, then the compiler falls back to the normal behavior *) if arity = 0 then Bstrconst(Const_b0 num) else let rargs = Array.sub args nparams arity in let b_args = Array.map str_const rargs in try let sc_args = Array.map get_strcst b_args in Bstrconst(Const_bn(num, sc_args)) with Not_found -> Bmakeblock(num,b_args) else let b_args = Array.map str_const args in (* spiwack: tries first to apply the run-time compilation behavior of the constructor, as in 2/ above *) try Bspecial ((Retroknowledge.get_vm_constant_dynamic_info (!global_env).retroknowledge (kind_of_term f)), b_args) with Not_found -> Bconstruct_app(num, nparams, arity, b_args) end | _ -> Bconstr c end | Ind ind -> Bstrconst (Const_ind ind) | Construct ((kn,j),i) -> begin (* spiwack: tries first to apply the run-time compilation behavior of the constructor, as in 2/ above *) try Bspecial ((Retroknowledge.get_vm_constant_dynamic_info (!global_env).retroknowledge (kind_of_term c)), [| |]) with Not_found -> let oib = lookup_mind kn !global_env in let oip = oib.mind_packets.(j) in let num,arity = oip.mind_reloc_tbl.(i-1) in let nparams = oib.mind_nparams in if nparams + arity = 0 then Bstrconst(Const_b0 num) else Bconstruct_app(num,nparams,arity,[||]) end | _ -> Bconstr c (* compiling application *) let comp_args comp_expr reloc args sz cont = let nargs_m_1 = Array.length args - 1 in let c = ref (comp_expr reloc args.(0) (sz + nargs_m_1) cont) in for i = 1 to nargs_m_1 do c := comp_expr reloc args.(i) (sz + nargs_m_1 - i) (Kpush :: !c) done; !c let comp_app comp_fun comp_arg reloc f args sz cont = let nargs = Array.length args in match is_tailcall cont with | Some k -> comp_args comp_arg reloc args sz (Kpush :: comp_fun reloc f (sz + nargs) (Kappterm(nargs, k + nargs) :: (discard_dead_code cont))) | None -> if nargs < 4 then comp_args comp_arg reloc args sz (Kpush :: (comp_fun reloc f (sz+nargs) (Kapply nargs :: cont))) else let lbl,cont1 = label_code cont in Kpush_retaddr lbl :: (comp_args comp_arg reloc args (sz + 3) (Kpush :: (comp_fun reloc f (sz+3+nargs) (Kapply nargs :: cont1)))) (* Compiling free variables *) let compile_fv_elem reloc fv sz cont = match fv with | FVrel i -> pos_rel i reloc sz :: cont | FVnamed id -> pos_named id reloc :: cont let rec compile_fv reloc l sz cont = match l with | [] -> cont | [fvn] -> compile_fv_elem reloc fvn sz cont | fvn :: tl -> compile_fv_elem reloc fvn sz (Kpush :: compile_fv reloc tl (sz + 1) cont) (* Compiling constants *) let rec get_allias env kn = let tps = (lookup_constant kn env).const_body_code in match Cemitcodes.force tps with | BCallias kn' -> get_allias env kn' | _ -> kn (* Compiling expressions *) let rec compile_constr reloc c sz cont = match kind_of_term c with | Meta _ -> raise (Invalid_argument "Cbytegen.compile_constr : Meta") | Evar _ -> raise (Invalid_argument "Cbytegen.compile_constr : Evar") | Cast(c,_,_) -> compile_constr reloc c sz cont | Rel i -> pos_rel i reloc sz :: cont | Var id -> pos_named id reloc :: cont | Const kn -> compile_const reloc kn [||] sz cont | Sort _ | Ind _ | Construct _ -> compile_str_cst reloc (str_const c) sz cont | LetIn(_,xb,_,body) -> compile_constr reloc xb sz (Kpush :: (compile_constr (push_local sz reloc) body (sz+1) (add_pop 1 cont))) | Prod(id,dom,codom) -> let cont1 = Kpush :: compile_constr reloc dom (sz+1) (Kmakeprod :: cont) in compile_constr reloc (mkLambda(id,dom,codom)) sz cont1 | Lambda _ -> let params, body = decompose_lam c in let arity = List.length params in let r_fun = comp_env_fun arity in let lbl_fun = Label.create() in let cont_fun = compile_constr r_fun body arity [Kreturn arity] in fun_code := [Ksequence(add_grab arity lbl_fun cont_fun,!fun_code)]; let fv = fv r_fun in compile_fv reloc fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont) | App(f,args) -> begin match kind_of_term f with | Construct _ -> compile_str_cst reloc (str_const c) sz cont | Const kn -> compile_const reloc kn args sz cont | _ -> comp_app compile_constr compile_constr reloc f args sz cont end | Fix ((rec_args,init),(_,type_bodies,rec_bodies)) -> let ndef = Array.length type_bodies in let rfv = ref empty_fv in let lbl_types = Array.create ndef Label.no in let lbl_bodies = Array.create ndef Label.no in (* Compilation des types *) let env_type = comp_env_fix_type rfv in for i = 0 to ndef - 1 do let lbl,fcode = label_code (compile_constr env_type type_bodies.(i) 0 [Kstop]) in lbl_types.(i) <- lbl; fun_code := [Ksequence(fcode,!fun_code)] done; (* Compiling bodies *) for i = 0 to ndef - 1 do let params,body = decompose_lam rec_bodies.(i) in let arity = List.length params in let env_body = comp_env_fix ndef i arity rfv in let cont1 = compile_constr env_body body arity [Kreturn arity] in let lbl = Label.create () in lbl_bodies.(i) <- lbl; let fcode = add_grabrec rec_args.(i) arity lbl cont1 in fun_code := [Ksequence(fcode,!fun_code)] done; let fv = !rfv in compile_fv reloc fv.fv_rev sz (Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont) | CoFix(init,(_,type_bodies,rec_bodies)) -> let ndef = Array.length type_bodies in let lbl_types = Array.create ndef Label.no in let lbl_bodies = Array.create ndef Label.no in (* Compiling types *) let rfv = ref empty_fv in let env_type = comp_env_cofix_type ndef rfv in for i = 0 to ndef - 1 do let lbl,fcode = label_code (compile_constr env_type type_bodies.(i) 0 [Kstop]) in lbl_types.(i) <- lbl; fun_code := [Ksequence(fcode,!fun_code)] done; (* Compiling bodies *) for i = 0 to ndef - 1 do let params,body = decompose_lam rec_bodies.(i) in let arity = List.length params in let env_body = comp_env_cofix ndef arity rfv in let lbl = Label.create () in let cont1 = compile_constr env_body body (arity+1) (cont_cofix arity) in let cont2 = add_grab (arity+1) lbl cont1 in lbl_bodies.(i) <- lbl; fun_code := [Ksequence(cont2,!fun_code)]; done; let fv = !rfv in compile_fv reloc fv.fv_rev sz (Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont) | Case(ci,t,a,branchs) -> let ind = ci.ci_ind in let mib = lookup_mind (fst ind) !global_env in let oib = mib.mind_packets.(snd ind) in let tbl = oib.mind_reloc_tbl in let lbl_consts = Array.create oib.mind_nb_constant Label.no in let lbl_blocks = Array.create (oib.mind_nb_args+1) Label.no in let branch1,cont = make_branch cont in (* Compiling return type *) let lbl_typ,fcode = label_code (compile_constr reloc t sz [Kpop sz; Kstop]) in fun_code := [Ksequence(fcode,!fun_code)]; (* Compiling branches *) let lbl_sw = Label.create () in let sz_b,branch,is_tailcall = match branch1 with | Kreturn k -> assert (k = sz); sz, branch1, true | _ -> sz+3, Kjump, false in let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall} in (* Compiling branch for accumulators *) let lbl_accu, code_accu = label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch::cont) in lbl_blocks.(0) <- lbl_accu; let c = ref code_accu in (* Compiling regular constructor branches *) for i = 0 to Array.length tbl - 1 do let tag, arity = tbl.(i) in if arity = 0 then let lbl_b,code_b = label_code(compile_constr reloc branchs.(i) sz_b (branch :: !c)) in lbl_consts.(tag) <- lbl_b; c := code_b else let args, body = decompose_lam branchs.(i) in let nargs = List.length args in let lbl_b,code_b = label_code( if nargs = arity then Kpushfields arity :: compile_constr (push_param arity sz_b reloc) body (sz_b+arity) (add_pop arity (branch :: !c)) else let sz_appterm = if is_tailcall then sz_b + arity else arity in Kpushfields arity :: compile_constr reloc branchs.(i) (sz_b+arity) (Kappterm(arity,sz_appterm) :: !c)) in lbl_blocks.(tag) <- lbl_b; c := code_b done; c := Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: !c; let code_sw = match branch1 with (* spiwack : branch1 can't be a lbl anymore it's a Branch instead | Klabel lbl -> Kpush_retaddr lbl :: !c *) | Kbranch lbl -> Kpush_retaddr lbl :: !c | _ -> !c in compile_constr reloc a sz (try let entry = Term.Ind ind in Retroknowledge.get_vm_before_match_info (!global_env).retroknowledge entry code_sw with Not_found -> code_sw) and compile_str_cst reloc sc sz cont = match sc with | Bconstr c -> compile_constr reloc c sz cont | Bstrconst sc -> Kconst sc :: cont | Bmakeblock(tag,args) -> let nargs = Array.length args in comp_args compile_str_cst reloc args sz (Kmakeblock(nargs,tag) :: cont) | Bconstruct_app(tag,nparams,arity,args) -> if Array.length args = 0 then code_construct tag nparams arity cont else comp_app (fun _ _ _ cont -> code_construct tag nparams arity cont) compile_str_cst reloc () args sz cont | Bspecial (comp_fx, args) -> comp_fx reloc args sz cont (* spiwack : compilation of constants with their arguments. Makes a special treatment with 31-bit integer addition *) and compile_const = fun reloc-> fun kn -> fun args -> fun sz -> fun cont -> let nargs = Array.length args in (* spiwack: checks if there is a specific way to compile the constant if there is not, Not_found is raised, and the function falls back on its normal behavior *) try Retroknowledge.get_vm_compiling_info (!global_env).retroknowledge (kind_of_term (mkConst kn)) reloc args sz cont with Not_found -> if nargs = 0 then Kgetglobal (get_allias !global_env kn) :: cont else comp_app (fun _ _ _ cont -> Kgetglobal (get_allias !global_env kn) :: cont) compile_constr reloc () args sz cont let compile env c = set_global_env env; init_fun_code (); Label.reset_label_counter (); let reloc = empty_comp_env () in let init_code = compile_constr reloc c 0 [Kstop] in let fv = List.rev (!(reloc.in_env).fv_rev) in (* draw_instr init_code; draw_instr !fun_code; Format.print_string "fv = "; List.iter (fun v -> match v with | FVnamed id -> Format.print_string ((string_of_id id)^"; ") | FVrel i -> Format.print_string ((string_of_int i)^"; ")) fv; Format .print_string "\n"; Format.print_flush(); *) init_code,!fun_code, Array.of_list fv let compile_constant_body env = function | Undef _ | OpaqueDef _ -> BCconstant | Def sb -> let body = Declarations.force sb in match kind_of_term body with | Const kn' -> (* we use the canonical name of the constant*) let con= constant_of_kn (canonical_con kn') in BCallias (get_allias env con) | _ -> let res = compile env body in let to_patch = to_memory res in BCdefined to_patch (* Shortcut of the previous function used during module strengthening *) let compile_alias kn = BCallias (constant_of_kn (canonical_con kn)) (* spiwack: additional function which allow different part of compilation of the 31-bit integers *) let make_areconst n else_lbl cont = if n <=0 then cont else Kareconst (n, else_lbl)::cont (* try to compile int31 as a const_b0. Succeed if all the arguments are closed fails otherwise by raising NotClosed*) let compile_structured_int31 fc args = if not fc then raise Not_found else Const_b0 (Array.fold_left (fun temp_i -> fun t -> match kind_of_term t with | Construct (_,d) -> 2*temp_i+d-1 | _ -> raise NotClosed) 0 args ) (* this function is used for the compilation of the constructor of the int31, it is used when it appears not fully applied, or applied to at least one non-closed digit *) let dynamic_int31_compilation fc reloc args sz cont = if not fc then raise Not_found else let nargs = Array.length args in if nargs = 31 then let (escape,labeled_cont) = make_branch cont in let else_lbl = Label.create() in comp_args compile_str_cst reloc args sz ( Kisconst else_lbl::Kareconst(30,else_lbl)::Kcompint31::escape::Klabel else_lbl::Kmakeblock(31, 1)::labeled_cont) else let code_construct cont = (* spiwack: variant of the global code_construct which handles dynamic compilation of integers *) let f_cont = let else_lbl = Label.create () in [Kacc 0; Kpop 1; Kisconst else_lbl; Kareconst(30,else_lbl); Kcompint31; Kreturn 0; Klabel else_lbl; Kmakeblock(31, 1); Kreturn 0] in let lbl = Label.create() in fun_code := [Ksequence (add_grab 31 lbl f_cont,!fun_code)]; Kclosure(lbl,0) :: cont in if nargs = 0 then code_construct cont else comp_app (fun _ _ _ cont -> code_construct cont) compile_str_cst reloc () args sz cont (*(* template compilation for 2ary operation, it probably possible to make a generic such function with arity abstracted *) let op2_compilation op = let code_construct normal cont = (*kn cont =*) let f_cont = let else_lbl = Label.create () in Kareconst(2, else_lbl):: Kacc 0:: Kpop 1:: op:: Kreturn 0:: Klabel else_lbl:: (* works as comp_app with nargs = 2 and tailcall cont [Kreturn 0]*) (*Kgetglobal (get_allias !global_env kn):: *) normal:: Kappterm(2, 2):: [] (* = discard_dead_code [Kreturn 0] *) in let lbl = Label.create () in fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)]; Kclosure(lbl, 0)::cont in fun normal fc _ reloc args sz cont -> if not fc then raise Not_found else let nargs = Array.length args in if nargs=2 then (*if it is a fully applied addition*) let (escape, labeled_cont) = make_branch cont in let else_lbl = Label.create () in comp_args compile_constr reloc args sz (Kisconst else_lbl::(make_areconst 1 else_lbl (*Kaddint31::escape::Klabel else_lbl::Kpush::*) (op::escape::Klabel else_lbl::Kpush:: (* works as comp_app with nargs = 2 and non-tailcall cont*) (*Kgetglobal (get_allias !global_env kn):: *) normal:: Kapply 2::labeled_cont))) else if nargs=0 then code_construct normal cont else comp_app (fun _ _ _ cont -> code_construct normal cont) compile_constr reloc () args sz cont *) (*template for n-ary operation, invariant: n>=1, the operations does the following : 1/ checks if all the arguments are constants (i.e. non-block values) 2/ if they are, uses the "op" instruction to execute 3/ if at least one is not, branches to the normal behavior: Kgetglobal (get_allias !global_env kn) *) let op_compilation n op = let code_construct kn cont = let f_cont = let else_lbl = Label.create () in Kareconst(n, else_lbl):: Kacc 0:: Kpop 1:: op:: Kreturn 0:: Klabel else_lbl:: (* works as comp_app with nargs = n and tailcall cont [Kreturn 0]*) Kgetglobal (get_allias !global_env kn):: Kappterm(n, n):: [] (* = discard_dead_code [Kreturn 0] *) in let lbl = Label.create () in fun_code := [Ksequence (add_grab n lbl f_cont, !fun_code)]; Kclosure(lbl, 0)::cont in fun kn fc reloc args sz cont -> if not fc then raise Not_found else let nargs = Array.length args in if nargs=n then (*if it is a fully applied addition*) let (escape, labeled_cont) = make_branch cont in let else_lbl = Label.create () in comp_args compile_constr reloc args sz (Kisconst else_lbl::(make_areconst (n-1) else_lbl (*Kaddint31::escape::Klabel else_lbl::Kpush::*) (op::escape::Klabel else_lbl::Kpush:: (* works as comp_app with nargs = n and non-tailcall cont*) Kgetglobal (get_allias !global_env kn):: Kapply n::labeled_cont))) else if nargs=0 then code_construct kn cont else comp_app (fun _ _ _ cont -> code_construct kn cont) compile_constr reloc () args sz cont let int31_escape_before_match fc cont = if not fc then raise Not_found else let escape_lbl, labeled_cont = label_code cont in (Kisconst escape_lbl)::Kdecompint31::labeled_cont coq-8.4pl4/kernel/cbytegen.mli0000644000175000017500000000331612326224777015421 0ustar stephstephopen Names open Cbytecodes open Cemitcodes open Term open Declarations open Pre_env val compile : env -> constr -> bytecodes * bytecodes * fv (** init, fun, fv *) val compile_constant_body : env -> constant_def -> body_code (** Shortcut of the previous function used during module strengthening *) val compile_alias : constant -> body_code (** spiwack: this function contains the information needed to perform the static compilation of int31 (trying and obtaining a 31-bit integer in processor representation at compile time) *) val compile_structured_int31 : bool -> constr array -> structured_constant (** this function contains the information needed to perform the dynamic compilation of int31 (trying and obtaining a 31-bit integer in processor representation at runtime when it failed at compile time *) val dynamic_int31_compilation : bool -> comp_env -> block array -> int -> bytecodes -> bytecodes (*spiwack: template for the compilation n-ary operation, invariant: n>=1. works as follow: checks if all the arguments are non-pointers if they are applies the operation (second argument) if not all of them are, returns to a coq definition (third argument) *) val op_compilation : int -> instruction -> constant -> bool -> comp_env -> constr array -> int -> bytecodes-> bytecodes (*spiwack: compiling function to insert dynamic decompilation before matching integers (in case they are in processor representation) *) val int31_escape_before_match : bool -> bytecodes -> bytecodes coq-8.4pl4/kernel/declarations.ml0000644000175000017500000003151112326224777016116 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* None | Def c -> Some c | OpaqueDef lc -> Some (force_lazy_constr lc) let constant_has_body cb = match cb.const_body with | Undef _ -> false | Def _ | OpaqueDef _ -> true let is_opaque cb = match cb.const_body with | OpaqueDef _ -> true | Undef _ | Def _ -> false (* Substitutions of [constant_body] *) let subst_rel_declaration sub (id,copt,t as x) = let copt' = Option.smartmap (subst_mps sub) copt in let t' = subst_mps sub t in if copt == copt' & t == t' then x else (id,copt',t') let subst_rel_context sub = list_smartmap (subst_rel_declaration sub) (* TODO: these substitution functions could avoid duplicating things when the substitution have preserved all the fields *) let subst_const_type sub arity = if is_empty_subst sub then arity else match arity with | NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s) | PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s) let subst_const_def sub = function | Undef inl -> Undef inl | Def c -> Def (subst_constr_subst sub c) | OpaqueDef lc -> OpaqueDef (subst_lazy_constr sub lc) let subst_const_body sub cb = { const_hyps = (assert (cb.const_hyps=[]); []); const_body = subst_const_def sub cb.const_body; const_type = subst_const_type sub cb.const_type; const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code; const_constraints = cb.const_constraints} (* Hash-consing of [constant_body] *) let hcons_rel_decl ((n,oc,t) as d) = let n' = hcons_name n and oc' = Option.smartmap hcons_constr oc and t' = hcons_types t in if n' == n && oc' == oc && t' == t then d else (n',oc',t') let hcons_rel_context l = list_smartmap hcons_rel_decl l let hcons_polyarity ar = { poly_param_levels = list_smartmap (Option.smartmap hcons_univ) ar.poly_param_levels; poly_level = hcons_univ ar.poly_level } let hcons_const_type = function | NonPolymorphicType t -> NonPolymorphicType (hcons_constr t) | PolymorphicArity (ctx,s) -> PolymorphicArity (hcons_rel_context ctx, hcons_polyarity s) let hcons_const_def = function | Undef inl -> Undef inl | Def l_constr -> let constr = force l_constr in Def (from_val (hcons_constr constr)) | OpaqueDef lc -> if lazy_constr_is_val lc then let constr = force_opaque lc in OpaqueDef (opaque_from_val (hcons_constr constr)) else OpaqueDef lc let hcons_const_body cb = { cb with const_body = hcons_const_def cb.const_body; const_type = hcons_const_type cb.const_type; const_constraints = hcons_constraints cb.const_constraints } (*s Inductive types (internal representation with redundant information). *) type recarg = | Norec | Mrec of inductive | Imbr of inductive let subst_recarg sub r = match r with | Norec -> r | Mrec (kn,i) -> let kn' = subst_ind sub kn in if kn==kn' then r else Mrec (kn',i) | Imbr (kn,i) -> let kn' = subst_ind sub kn in if kn==kn' then r else Imbr (kn',i) type wf_paths = recarg Rtree.t let mk_norec = Rtree.mk_node Norec [||] let mk_paths r recargs = Rtree.mk_node r (Array.map (fun l -> Rtree.mk_node Norec (Array.of_list l)) recargs) let dest_recarg p = fst (Rtree.dest_node p) (* dest_subterms returns the sizes of each argument of each constructor of an inductive object of size [p]. This should never be done for Norec, because the number of sons does not correspond to the number of constructors. *) let dest_subterms p = let (ra,cstrs) = Rtree.dest_node p in assert (ra<>Norec); Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs let recarg_length p j = let (_,cstrs) = Rtree.dest_node p in Array.length (snd (Rtree.dest_node cstrs.(j-1))) let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p (**********************************************************************) (* Representation of mutual inductive types in the kernel *) (* Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1 ... with In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn *) type monomorphic_inductive_arity = { mind_user_arity : constr; mind_sort : sorts; } type inductive_arity = | Monomorphic of monomorphic_inductive_arity | Polymorphic of polymorphic_arity type one_inductive_body = { (* Primitive datas *) (* Name of the type: [Ii] *) mind_typename : identifier; (* Arity context of [Ii] with parameters: [forall params, Ui] *) mind_arity_ctxt : rel_context; (* Arity sort, original user arity, and allowed elim sorts, if monomorphic *) mind_arity : inductive_arity; (* Names of the constructors: [cij] *) mind_consnames : identifier array; (* Types of the constructors with parameters: [forall params, Tij], where the Ik are replaced by de Bruijn index in the context I1:forall params, U1 .. In:forall params, Un *) mind_user_lc : types array; (* Derived datas *) (* Number of expected real arguments of the type (no let, no params) *) mind_nrealargs : int; (* Length of realargs context (with let, no params) *) mind_nrealargs_ctxt : int; (* List of allowed elimination sorts *) mind_kelim : sorts_family list; (* Head normalized constructor types so that their conclusion is atomic *) mind_nf_lc : types array; (* Length of the signature of the constructors (with let, w/o params) *) mind_consnrealdecls : int array; (* Signature of recursive arguments in the constructors *) mind_recargs : wf_paths; (* Datas for bytecode compilation *) (* number of constant constructor *) mind_nb_constant : int; (* number of no constant constructor *) mind_nb_args : int; mind_reloc_tbl : Cbytecodes.reloc_table; } type mutual_inductive_body = { (* The component of the mutual inductive block *) mind_packets : one_inductive_body array; (* Whether the inductive type has been declared as a record *) mind_record : bool; (* Whether the type is inductive or coinductive *) mind_finite : bool; (* Number of types in the block *) mind_ntypes : int; (* Section hypotheses on which the block depends *) mind_hyps : section_context; (* Number of expected parameters *) mind_nparams : int; (* Number of recursively uniform (i.e. ordinary) parameters *) mind_nparams_rec : int; (* The context of parameters (includes let-in declaration) *) mind_params_ctxt : rel_context; (* Universes constraints enforced by the inductive declaration *) mind_constraints : constraints; } let subst_indarity sub = function | Monomorphic s -> Monomorphic { mind_user_arity = subst_mps sub s.mind_user_arity; mind_sort = s.mind_sort; } | Polymorphic s as x -> x let subst_mind_packet sub mbp = { mind_consnames = mbp.mind_consnames; mind_consnrealdecls = mbp.mind_consnrealdecls; mind_typename = mbp.mind_typename; mind_nf_lc = array_smartmap (subst_mps sub) mbp.mind_nf_lc; mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt; mind_arity = subst_indarity sub mbp.mind_arity; mind_user_lc = array_smartmap (subst_mps sub) mbp.mind_user_lc; mind_nrealargs = mbp.mind_nrealargs; mind_nrealargs_ctxt = mbp.mind_nrealargs_ctxt; mind_kelim = mbp.mind_kelim; mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); mind_nb_constant = mbp.mind_nb_constant; mind_nb_args = mbp.mind_nb_args; mind_reloc_tbl = mbp.mind_reloc_tbl } let subst_mind sub mib = { mind_record = mib.mind_record ; mind_finite = mib.mind_finite ; mind_ntypes = mib.mind_ntypes ; mind_hyps = (assert (mib.mind_hyps=[]); []) ; mind_nparams = mib.mind_nparams; mind_nparams_rec = mib.mind_nparams_rec; mind_params_ctxt = map_rel_context (subst_mps sub) mib.mind_params_ctxt; mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ; mind_constraints = mib.mind_constraints } let hcons_indarity = function | Monomorphic a -> Monomorphic { mind_user_arity = hcons_constr a.mind_user_arity; mind_sort = hcons_sorts a.mind_sort } | Polymorphic a -> Polymorphic (hcons_polyarity a) let hcons_mind_packet oib = { oib with mind_typename = hcons_ident oib.mind_typename; mind_arity_ctxt = hcons_rel_context oib.mind_arity_ctxt; mind_arity = hcons_indarity oib.mind_arity; mind_consnames = array_smartmap hcons_ident oib.mind_consnames; mind_user_lc = array_smartmap hcons_types oib.mind_user_lc; mind_nf_lc = array_smartmap hcons_types oib.mind_nf_lc } let hcons_mind mib = { mib with mind_packets = array_smartmap hcons_mind_packet mib.mind_packets; mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt; mind_constraints = hcons_constraints mib.mind_constraints } (*s Modules: signature component specifications, module types, and module declarations *) type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body | SFBmodtype of module_type_body and structure_body = (label * structure_field_body) list and struct_expr_body = | SEBident of module_path | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body | SEBapply of struct_expr_body * struct_expr_body * constraints | SEBstruct of structure_body | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = With_module_body of identifier list * module_path | With_definition_body of identifier list * constant_body and module_body = { mod_mp : module_path; mod_expr : struct_expr_body option; mod_type : struct_expr_body; mod_type_alg : struct_expr_body option; mod_constraints : constraints; mod_delta : delta_resolver; mod_retroknowledge : Retroknowledge.action list} and module_type_body = { typ_mp : module_path; typ_expr : struct_expr_body; typ_expr_alg : struct_expr_body option ; typ_constraints : constraints; typ_delta :delta_resolver} coq-8.4pl4/kernel/retroknowledge.ml0000644000175000017500000002045212326224777016503 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* continuation -> result *) (bool->Cbytecodes.comp_env->constr array -> int->Cbytecodes.bytecodes->Cbytecodes.bytecodes) option; vm_constant_static : (*fastcomputation flag -> constructor -> args -> result*) (bool->constr array->Cbytecodes.structured_constant) option; vm_constant_dynamic : (*fastcomputation flag -> constructor -> reloc -> args -> sz -> cont -> result *) (bool->Cbytecodes.comp_env->Cbytecodes.block array->int-> Cbytecodes.bytecodes->Cbytecodes.bytecodes) option; (* fastcomputation flag -> cont -> result *) vm_before_match : (bool -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes) option; (* tag (= compiled int for instance) -> result *) vm_decompile_const : (int -> Term.constr) option} and reactive = reactive_end Reactive.t and retroknowledge = {flags : flags; proactive : proactive; reactive : reactive} (* This type represent an atomic action of the retroknowledge. It is stored in the compiled libraries *) (* As per now, there is only the possibility of registering things the possibility of unregistering or changing the flag is under study *) type action = | RKRegister of field*entry (*initialisation*) let initial_flags = {fastcomputation = true;} let initial_proactive = (Proactive.empty:proactive) let initial_reactive = (Reactive.empty:reactive) let initial_retroknowledge = {flags = initial_flags; proactive = initial_proactive; reactive = initial_reactive } let empty_reactive_end = { vm_compiling = None ; vm_constant_static = None; vm_constant_dynamic = None; vm_before_match = None; vm_decompile_const = None } (* acces functions for proactive retroknowledge *) let add_field knowledge field value = {knowledge with proactive = Proactive.add field value knowledge.proactive} let mem knowledge field = Proactive.mem field knowledge.proactive let remove knowledge field = {knowledge with proactive = Proactive.remove field knowledge.proactive} let find knowledge field = Proactive.find field knowledge.proactive (*access functions for reactive retroknowledge*) (* used for compiling of functions (add, mult, etc..) *) let get_vm_compiling_info knowledge key = match (Reactive.find key knowledge.reactive).vm_compiling with | None -> raise Not_found | Some f -> f knowledge.flags.fastcomputation (* used for compilation of fully applied constructors *) let get_vm_constant_static_info knowledge key = match (Reactive.find key knowledge.reactive).vm_constant_static with | None -> raise Not_found | Some f -> f knowledge.flags.fastcomputation (* used for compilation of partially applied constructors *) let get_vm_constant_dynamic_info knowledge key = match (Reactive.find key knowledge.reactive).vm_constant_dynamic with | None -> raise Not_found | Some f -> f knowledge.flags.fastcomputation let get_vm_before_match_info knowledge key = match (Reactive.find key knowledge.reactive).vm_before_match with | None -> raise Not_found | Some f -> f knowledge.flags.fastcomputation let get_vm_decompile_constant_info knowledge key = match (Reactive.find key knowledge.reactive).vm_decompile_const with | None -> raise Not_found | Some f -> f (* functions manipulating reactive knowledge *) let add_vm_compiling_info knowledge value nfo = {knowledge with reactive = try Reactive.add value {(Reactive.find value (knowledge.reactive)) with vm_compiling = Some nfo} knowledge.reactive with Not_found -> Reactive.add value {empty_reactive_end with vm_compiling = Some nfo} knowledge.reactive } let add_vm_constant_static_info knowledge value nfo = {knowledge with reactive = try Reactive.add value {(Reactive.find value (knowledge.reactive)) with vm_constant_static = Some nfo} knowledge.reactive with Not_found -> Reactive.add value {empty_reactive_end with vm_constant_static = Some nfo} knowledge.reactive } let add_vm_constant_dynamic_info knowledge value nfo = {knowledge with reactive = try Reactive.add value {(Reactive.find value (knowledge.reactive)) with vm_constant_dynamic = Some nfo} knowledge.reactive with Not_found -> Reactive.add value {empty_reactive_end with vm_constant_dynamic = Some nfo} knowledge.reactive } let add_vm_before_match_info knowledge value nfo = {knowledge with reactive = try Reactive.add value {(Reactive.find value (knowledge.reactive)) with vm_before_match = Some nfo} knowledge.reactive with Not_found -> Reactive.add value {empty_reactive_end with vm_before_match = Some nfo} knowledge.reactive } let add_vm_decompile_constant_info knowledge value nfo = {knowledge with reactive = try Reactive.add value {(Reactive.find value (knowledge.reactive)) with vm_decompile_const = Some nfo} knowledge.reactive with Not_found -> Reactive.add value {empty_reactive_end with vm_decompile_const = Some nfo} knowledge.reactive } let clear_info knowledge value = {knowledge with reactive = Reactive.remove value knowledge.reactive} coq-8.4pl4/kernel/csymtable.ml0000644000175000017500000001451112326224777015432 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int -> tcode = "coq_tcode_of_code" external eval_tcode : tcode -> values array -> values = "coq_eval_tcode" (*******************) (* Linkage du code *) (*******************) (* Table des globaux *) (* [global_data] contient les valeurs des constantes globales (axiomes,definitions), les annotations des switch et les structured constant *) external global_data : unit -> values array = "get_coq_global_data" (* [realloc_global_data n] augmente de n la taille de [global_data] *) external realloc_global_data : int -> unit = "realloc_coq_global_data" let check_global_data n = if n >= Array.length (global_data()) then realloc_global_data n let num_global = ref 0 let set_global v = let n = !num_global in check_global_data n; (global_data()).(n) <- v; incr num_global; n (* [global_transp],[global_boxed] contiennent les valeurs des definitions gelees. Les deux versions sont maintenues en //. [global_transp] contient la version transparente. [global_boxed] contient la version gelees. *) external global_boxed : unit -> bool array = "get_coq_global_boxed" (* [realloc_global_data n] augmente de n la taille de [global_data] *) external realloc_global_boxed : int -> unit = "realloc_coq_global_boxed" let check_global_boxed n = if n >= Array.length (global_boxed()) then realloc_global_boxed n let num_boxed = ref 0 let boxed_tbl = Hashtbl.create 53 let cst_opaque = ref Cpred.full let is_opaque kn = Cpred.mem kn !cst_opaque let set_global_boxed kn v = let n = !num_boxed in check_global_boxed n; (global_boxed()).(n) <- (is_opaque kn); Hashtbl.add boxed_tbl kn n ; incr num_boxed; set_global (val_of_constant_def n kn v) (* table pour les structured_constant et les annotations des switchs *) let str_cst_tbl = Hashtbl.create 31 (* (structured_constant * int) Hashtbl.t*) let annot_tbl = Hashtbl.create 31 (* (annot_switch * int) Hashtbl.t *) (*************************************************************) (*** Mise a jour des valeurs des variables et des constantes *) (*************************************************************) exception NotEvaluated open Pp let key rk = match !rk with | Some k -> (*Pp.msgnl (str"found at: "++int k);*) k | _ -> raise NotEvaluated (************************) (* traduction des patch *) (* slot_for_*, calcul la valeur de l'objet, la place dans la table global, rend sa position dans la table *) let slot_for_str_cst key = try Hashtbl.find str_cst_tbl key with Not_found -> let n = set_global (val_of_str_const key) in Hashtbl.add str_cst_tbl key n; n let slot_for_annot key = try Hashtbl.find annot_tbl key with Not_found -> let n = set_global (val_of_annot_switch key) in Hashtbl.add annot_tbl key n; n let rec slot_for_getglobal env kn = let (cb,rk) = lookup_constant_key kn env in try key rk with NotEvaluated -> (* Pp.msgnl(str"not yet evaluated");*) let pos = match Cemitcodes.force cb.const_body_code with | BCdefined(code,pl,fv) -> let v = eval_to_patch env (code,pl,fv) in set_global v | BCallias kn' -> slot_for_getglobal env kn' | BCconstant -> set_global (val_of_constant kn) in (*Pp.msgnl(str"value stored at: "++int pos);*) rk := Some pos; pos and slot_for_fv env fv = match fv with | FVnamed id -> let nv = Pre_env.lookup_named_val id env in begin match !nv with | VKvalue (v,_) -> v | VKnone -> let (_, b, _) = Sign.lookup_named id env.env_named_context in let v,d = match b with | None -> (val_of_named id, Idset.empty) | Some c -> (val_of_constr env c, Environ.global_vars_set (Environ.env_of_pre_env env) c) in nv := VKvalue (v,d); v end | FVrel i -> let rv = Pre_env.lookup_rel_val i env in begin match !rv with | VKvalue (v, _) -> v | VKnone -> let (_, b, _) = lookup_rel i env.env_rel_context in let (v, d) = match b with | None -> (val_of_rel (nb_rel env - i), Idset.empty) | Some c -> let renv = env_of_rel i env in (val_of_constr renv c, Environ.global_vars_set (Environ.env_of_pre_env renv) c) in rv := VKvalue (v,d); v end and eval_to_patch env (buff,pl,fv) = (* copy code *before* patching because of nested evaluations: the code we are patching might be called (and thus "concurrently" patched) and results in wrong results. Side-effects... *) let buff = Cemitcodes.copy buff in let patch = function | Reloc_annot a, pos -> patch_int buff pos (slot_for_annot a) | Reloc_const sc, pos -> patch_int buff pos (slot_for_str_cst sc) | Reloc_getglobal kn, pos -> (* Pp.msgnl (str"patching global: "++str(debug_string_of_con kn));*) patch_int buff pos (slot_for_getglobal env kn); (* Pp.msgnl (str"patch done: "++str(debug_string_of_con kn))*) in List.iter patch pl; let vm_env = Array.map (slot_for_fv env) fv in let tc = tcode_of_code buff (length buff) in (*Pp.msgnl (str"execute code");*) eval_tcode tc vm_env and val_of_constr env c = let (_,fun_code,_ as ccfv) = try compile env c with reraise -> print_string "can not compile \n";Format.print_flush();raise reraise in eval_to_patch env (to_memory ccfv) let set_transparent_const kn = cst_opaque := Cpred.remove kn !cst_opaque; List.iter (fun n -> (global_boxed()).(n) <- false) (Hashtbl.find_all boxed_tbl kn) let set_opaque_const kn = cst_opaque := Cpred.add kn !cst_opaque; List.iter (fun n -> (global_boxed()).(n) <- true) (Hashtbl.find_all boxed_tbl kn) coq-8.4pl4/kernel/names.mli0000644000175000017500000001716712326224777014735 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string val id_of_string : string -> identifier val id_ord : identifier -> identifier -> int (** Identifiers sets and maps *) module Idset : Set.S with type elt = identifier module Idpred : Predicate.S with type elt = identifier module Idmap : sig include Map.S with type key = identifier val exists : (identifier -> 'a -> bool) -> 'a t -> bool val singleton : key -> 'a -> 'a t end (** {6 Various types based on identifiers } *) type name = Name of identifier | Anonymous type variable = identifier (** {6 Directory paths = section names paths } *) type module_ident = identifier module ModIdmap : Map.S with type key = module_ident type dir_path (** Inner modules idents on top of list (to improve sharing). For instance: A.B.C is ["C";"B";"A"] *) val make_dirpath : module_ident list -> dir_path val repr_dirpath : dir_path -> module_ident list val empty_dirpath : dir_path (** Printing of directory paths as ["coq_root.module.submodule"] *) val string_of_dirpath : dir_path -> string (** {6 Names of structure elements } *) type label val mk_label : string -> label val string_of_label : label -> string val pr_label : label -> Pp.std_ppcmds val label_of_id : identifier -> label val id_of_label : label -> identifier module Labset : Set.S with type elt = label module Labmap : Map.S with type key = label (** {6 Unique names for bound modules } *) type mod_bound_id (** The first argument is a file name - to prevent conflict between different files *) val make_mbid : dir_path -> identifier -> mod_bound_id val repr_mbid : mod_bound_id -> int * identifier * dir_path val id_of_mbid : mod_bound_id -> identifier val debug_string_of_mbid : mod_bound_id -> string val string_of_mbid : mod_bound_id -> string (** {6 The module part of the kernel name } *) type module_path = | MPfile of dir_path | MPbound of mod_bound_id | MPdot of module_path * label val check_bound_mp : module_path -> bool val string_of_mp : module_path -> string module MPset : Set.S with type elt = module_path module MPmap : Map.S with type key = module_path (** Initial "seed" of the unique identifier generator *) val initial_dir : dir_path (** Name of the toplevel structure *) val initial_path : module_path (** [= MPfile initial_dir] *) (** {6 The absolute names of objects seen by kernel } *) type kernel_name (** Constructor and destructor *) val make_kn : module_path -> dir_path -> label -> kernel_name val repr_kn : kernel_name -> module_path * dir_path * label val modpath : kernel_name -> module_path val label : kernel_name -> label val string_of_kn : kernel_name -> string val pr_kn : kernel_name -> Pp.std_ppcmds val kn_ord : kernel_name -> kernel_name -> int module KNset : Set.S with type elt = kernel_name module KNpred : Predicate.S with type elt = kernel_name module KNmap : Map.S with type key = kernel_name (** {6 Specific paths for declarations } *) type constant type mutual_inductive (** Beware: first inductive has index 0 *) type inductive = mutual_inductive * int (** Beware: first constructor has index 1 *) type constructor = inductive * int (** *_env modules consider an order on user part of names the others consider an order on canonical part of names*) module Cmap : Map.S with type key = constant module Cmap_env : Map.S with type key = constant module Cpred : Predicate.S with type elt = constant module Cset : Set.S with type elt = constant module Cset_env : Set.S with type elt = constant module Mindmap : Map.S with type key = mutual_inductive module Mindmap_env : Map.S with type key = mutual_inductive module Mindset : Set.S with type elt = mutual_inductive module Indmap : Map.S with type key = inductive module Constrmap : Map.S with type key = constructor module Indmap_env : Map.S with type key = inductive module Constrmap_env : Map.S with type key = constructor val constant_of_kn : kernel_name -> constant val constant_of_kn_equiv : kernel_name -> kernel_name -> constant val make_con : module_path -> dir_path -> label -> constant val make_con_equiv : module_path -> module_path -> dir_path -> label -> constant val user_con : constant -> kernel_name val canonical_con : constant -> kernel_name val repr_con : constant -> module_path * dir_path * label val eq_constant : constant -> constant -> bool val con_with_label : constant -> label -> constant val string_of_con : constant -> string val con_label : constant -> label val con_modpath : constant -> module_path val pr_con : constant -> Pp.std_ppcmds val debug_pr_con : constant -> Pp.std_ppcmds val debug_string_of_con : constant -> string val mind_of_kn : kernel_name -> mutual_inductive val mind_of_kn_equiv : kernel_name -> kernel_name -> mutual_inductive val make_mind : module_path -> dir_path -> label -> mutual_inductive val make_mind_equiv : module_path -> module_path -> dir_path -> label -> mutual_inductive val user_mind : mutual_inductive -> kernel_name val canonical_mind : mutual_inductive -> kernel_name val repr_mind : mutual_inductive -> module_path * dir_path * label val eq_mind : mutual_inductive -> mutual_inductive -> bool val string_of_mind : mutual_inductive -> string val mind_label : mutual_inductive -> label val mind_modpath : mutual_inductive -> module_path val pr_mind : mutual_inductive -> Pp.std_ppcmds val debug_pr_mind : mutual_inductive -> Pp.std_ppcmds val debug_string_of_mind : mutual_inductive -> string val ind_modpath : inductive -> module_path val constr_modpath : constructor -> module_path val ith_mutual_inductive : inductive -> int -> inductive val ith_constructor_of_inductive : inductive -> int -> constructor val inductive_of_constructor : constructor -> inductive val index_of_constructor : constructor -> int val eq_ind : inductive -> inductive -> bool val eq_constructor : constructor -> constructor -> bool (** Better to have it here that in Closure, since required in grammar.cma *) type evaluable_global_reference = | EvalVarRef of identifier | EvalConstRef of constant val eq_egr : evaluable_global_reference -> evaluable_global_reference -> bool (** {6 Hash-consing } *) val hcons_string : string -> string val hcons_ident : identifier -> identifier val hcons_name : name -> name val hcons_dirpath : dir_path -> dir_path val hcons_con : constant -> constant val hcons_mind : mutual_inductive -> mutual_inductive val hcons_ind : inductive -> inductive val hcons_construct : constructor -> constructor (******) type 'a tableKey = | ConstKey of constant | VarKey of identifier | RelKey of 'a type transparent_state = Idpred.t * Cpred.t val empty_transparent_state : transparent_state val full_transparent_state : transparent_state val var_full_transparent_state : transparent_state val cst_full_transparent_state : transparent_state type inv_rel_key = int (** index in the [rel_context] part of environment starting by the end, {e inverse} of de Bruijn indice *) type id_key = inv_rel_key tableKey val eq_id_key : id_key -> id_key -> bool (*equalities on constant and inductive names for the checker*) val eq_con_chk : constant -> constant -> bool val eq_ind_chk : inductive -> inductive -> bool coq-8.4pl4/kernel/mod_subst.mli0000644000175000017500000001176112326224777015623 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* module_path -> delta_resolver -> delta_resolver val add_kn_delta_resolver : kernel_name -> kernel_name -> delta_resolver -> delta_resolver val add_inline_delta_resolver : kernel_name -> (int * constr option) -> delta_resolver -> delta_resolver val add_delta_resolver : delta_resolver -> delta_resolver -> delta_resolver (** Effect of a [delta_resolver] on kernel name, constant, inductive, etc *) val kn_of_delta : delta_resolver -> kernel_name -> kernel_name val constant_of_delta_kn : delta_resolver -> kernel_name -> constant val constant_of_delta : delta_resolver -> constant -> constant val mind_of_delta_kn : delta_resolver -> kernel_name -> mutual_inductive val mind_of_delta : delta_resolver -> mutual_inductive -> mutual_inductive val mp_of_delta : delta_resolver -> module_path -> module_path (** Extract the set of inlined constant in the resolver *) val inline_of_delta : int option -> delta_resolver -> (int * kernel_name) list (** Does a [delta_resolver] contains a [mp], a constant, an inductive ? *) val mp_in_delta : module_path -> delta_resolver -> bool val con_in_delta : constant -> delta_resolver -> bool val mind_in_delta : mutual_inductive -> delta_resolver -> bool (** {6 Substitution} *) type substitution val empty_subst : substitution val is_empty_subst : substitution -> bool (** add_* add [arg2/arg1]\{arg3\} to the substitution with no sequential composition *) val add_mbid : mod_bound_id -> module_path -> delta_resolver -> substitution -> substitution val add_mp : module_path -> module_path -> delta_resolver -> substitution -> substitution (** map_* create a new substitution [arg2/arg1]\{arg3\} *) val map_mbid : mod_bound_id -> module_path -> delta_resolver -> substitution val map_mp : module_path -> module_path -> delta_resolver -> substitution (** sequential composition: [substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)] *) val join : substitution -> substitution -> substitution (** Apply the substitution on the domain of the resolver *) val subst_dom_delta_resolver : substitution -> delta_resolver -> delta_resolver (** Apply the substitution on the codomain of the resolver *) val subst_codom_delta_resolver : substitution -> delta_resolver -> delta_resolver val subst_dom_codom_delta_resolver : substitution -> delta_resolver -> delta_resolver type 'a substituted val from_val : 'a -> 'a substituted val force : (substitution -> 'a -> 'a) -> 'a substituted -> 'a val subst_substituted : substitution -> 'a substituted -> 'a substituted (**/**) (* debugging *) val debug_string_of_subst : substitution -> string val debug_pr_subst : substitution -> Pp.std_ppcmds val debug_string_of_delta : delta_resolver -> string val debug_pr_delta : delta_resolver -> Pp.std_ppcmds (**/**) (** [subst_mp sub mp] guarantees that whenever the result of the substitution is structutally equal [mp], it is equal by pointers as well [==] *) val subst_mp : substitution -> module_path -> module_path val subst_ind : substitution -> mutual_inductive -> mutual_inductive val subst_kn : substitution -> kernel_name -> kernel_name val subst_con : substitution -> constant -> constant * constr (** Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? Does the user mean "Unfold X.t" or does she mean "Unfold y" where X.t is later on instantiated with y? I choose the first interpretation (i.e. an evaluable reference is never expanded). *) val subst_evaluable_reference : substitution -> evaluable_global_reference -> evaluable_global_reference (** [replace_mp_in_con mp mp' con] replaces [mp] with [mp'] in [con] *) val replace_mp_in_kn : module_path -> module_path -> kernel_name -> kernel_name (** [subst_mps sub c] performs the substitution [sub] on all kernel names appearing in [c] *) val subst_mps : substitution -> constr -> constr (** [occur_*id id sub] returns true iff [id] occurs in [sub] on either side *) val occur_mbid : mod_bound_id -> substitution -> bool (** [repr_substituted r] dumps the representation of a substituted: - [None, a] when r is a value - [Some s, a] when r is a delayed substitution [s] applied to [a] *) val repr_substituted : 'a substituted -> substitution list option * 'a coq-8.4pl4/kernel/entries.mli0000644000175000017500000000526212326224777015274 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* patch -> patch type emitcodes val copy : emitcodes -> emitcodes val length : emitcodes -> int val patch_int : emitcodes -> (*pos*)int -> int -> unit type to_patch = emitcodes * (patch list) * fv val subst_to_patch : Mod_subst.substitution -> to_patch -> to_patch type body_code = | BCdefined of to_patch | BCallias of constant | BCconstant type to_patch_substituted val from_val : body_code -> to_patch_substituted val force : to_patch_substituted -> body_code val subst_to_patch_subst : Mod_subst.substitution -> to_patch_substituted -> to_patch_substituted val repr_body_code : to_patch_substituted -> Mod_subst.substitution list option * body_code val to_memory : bytecodes * bytecodes * fv -> to_patch (** init code, fun code, fv *) coq-8.4pl4/kernel/vm.mli0000644000175000017500000000460312326224777014243 0ustar stephstephopen Names open Term open Cbytecodes open Cemitcodes (** Efficient Virtual Machine *) val set_drawinstr : unit -> unit val transp_values : unit -> bool val set_transp_values : bool -> unit (** Machine code *) type tcode (** Values *) type vprod type vfun type vfix type vcofix type vblock type vswitch type arguments type atom = | Aid of id_key | Aiddef of id_key * values | Aind of inductive (** Zippers *) type zipper = | Zapp of arguments | Zfix of vfix * arguments (** might be empty *) | Zswitch of vswitch type stack = zipper list type to_up type whd = | Vsort of sorts | Vprod of vprod | Vfun of vfun | Vfix of vfix * arguments option | Vcofix of vcofix * to_up * arguments option | Vconstr_const of int | Vconstr_block of vblock | Vatom_stk of atom * stack (** Constructors *) val val_of_str_const : structured_constant -> values val val_of_rel : int -> values val val_of_rel_def : int -> values -> values val val_of_named : identifier -> values val val_of_named_def : identifier -> values -> values val val_of_constant : constant -> values val val_of_constant_def : int -> constant -> values -> values external val_of_annot_switch : annot_switch -> values = "%identity" (** Destructors *) val whd_val : values -> whd (** Arguments *) val nargs : arguments -> int val arg : arguments -> int -> values (** Product *) val dom : vprod -> values val codom : vprod -> vfun (** Function *) val body_of_vfun : int -> vfun -> values val decompose_vfun2 : int -> vfun -> vfun -> int * values * values (** Fix *) val current_fix : vfix -> int val check_fix : vfix -> vfix -> bool val rec_args : vfix -> int array val reduce_fix : int -> vfix -> vfun array * values array (** bodies , types *) (** CoFix *) val current_cofix : vcofix -> int val check_cofix : vcofix -> vcofix -> bool val reduce_cofix : int -> vcofix -> values array * values array (** bodies , types *) (** Block *) val btag : vblock -> int val bsize : vblock -> int val bfield : vblock -> int -> values (** Switch *) val check_switch : vswitch -> vswitch -> bool val case_info : vswitch -> case_info val type_of_switch : vswitch -> values val branch_of_switch : int -> vswitch -> (int * values) array (** Evaluation *) val whd_stack : values -> stack -> whd val force_whd : values -> stack -> whd val eta_whd : int -> whd -> values coq-8.4pl4/kernel/doc.tex0000644000175000017500000000042512326224777014403 0ustar stephsteph \newpage \section*{The Coq kernel} \ocwsection \label{kernel} This chapter describes the \Coq\ kernel, which is a type checker for the \CCI. The modules of the kernel are organized as follows. \bigskip \begin{center}\epsfig{file=kernel.dep.ps,width=\linewidth}\end{center} coq-8.4pl4/kernel/univ.mli0000644000175000017500000000724012326224777014602 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 *) val type0m_univ : universe (** image of Prop in the universes hierarchy *) val type0_univ : universe (** image of Set in the universes hierarchy *) val type1_univ : universe (** the universe of the type of Prop/Set *) val make_universe_level : Names.dir_path * int -> universe_level val make_universe : universe_level -> universe val make_univ : Names.dir_path * int -> universe val is_type0_univ : universe -> bool val is_type0m_univ : universe -> bool val is_univ_variable : universe -> bool val universe_level : universe -> universe_level option val compare_levels : universe_level -> universe_level -> int (** The type of a universe *) val super : universe -> universe (** The max of 2 universes *) val sup : universe -> universe -> universe (** {6 Graphs of universes. } *) type universes type check_function = universes -> universe -> universe -> bool val check_geq : check_function val check_eq : check_function (** The empty graph of universes *) val initial_universes : universes val is_initial_universes : universes -> bool (** {6 Constraints. } *) type constraints val empty_constraint : constraints val union_constraints : constraints -> constraints -> constraints val is_empty_constraint : constraints -> bool type constraint_function = universe -> universe -> constraints -> constraints val enforce_geq : constraint_function val enforce_eq : constraint_function (** {6 ... } *) (** Merge of constraints in a universes graph. The function [merge_constraints] merges a set of constraints in a given universes graph. It raises the exception [UniverseInconsistency] if the constraints are not satisfiable. *) type constraint_type = Lt | Le | Eq exception UniverseInconsistency of constraint_type * universe * universe val merge_constraints : constraints -> universes -> universes val normalize_universes : universes -> universes val sort_universes : universes -> universes (** {6 Support for sort-polymorphic inductive types } *) val fresh_local_univ : unit -> universe val solve_constraints_system : universe option array -> universe array -> universe array val subst_large_constraint : universe -> universe -> universe -> universe val subst_large_constraints : (universe * universe) list -> universe -> universe val no_upper_constraints : universe -> constraints -> bool (** Is u mentionned in v (or equals to v) ? *) val univ_depends : universe -> universe -> bool (** {6 Pretty-printing of universes. } *) val pr_uni_level : universe_level -> Pp.std_ppcmds val pr_uni : universe -> Pp.std_ppcmds val pr_universes : universes -> Pp.std_ppcmds val pr_constraints : constraints -> Pp.std_ppcmds (** {6 Dumping to a file } *) val dump_universes : (constraint_type -> string -> string -> unit) -> universes -> unit (** {6 Hash-consing } *) val hcons_univlevel : universe_level -> universe_level val hcons_univ : universe -> universe val hcons_constraints : constraints -> constraints coq-8.4pl4/kernel/univ.ml0000644000175000017500000007505512326224777014442 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 0 | Set, _ -> -1 | _, Set -> 1 | Level (dp1, i1), Level (dp2, i2) -> if i1 < i2 then -1 else if i1 > i2 then 1 else compare dp1 dp2 let to_string = function | Set -> "Set" | Level (d,n) -> Names.string_of_dirpath d^"."^string_of_int n end module UniverseLMap = Map.Make (UniverseLevel) module UniverseLSet = Set.Make (UniverseLevel) type universe_level = UniverseLevel.t let compare_levels = UniverseLevel.compare (* An algebraic universe [universe] is either a universe variable [UniverseLevel.t] or a formal universe known to be greater than some universe variables and strictly greater than some (other) universe variables Universes variables denote universes initially present in the term to type-check and non variable algebraic universes denote the universes inferred while type-checking: it is either the successor of a universe present in the initial term to type-check or the maximum of two algebraic universes *) type universe = | Atom of UniverseLevel.t | Max of UniverseLevel.t list * UniverseLevel.t list let make_universe_level (m,n) = UniverseLevel.Level (m,n) let make_universe l = Atom l let make_univ c = Atom (make_universe_level c) let universe_level = function | Atom l -> Some l | Max _ -> None let pr_uni_level u = str (UniverseLevel.to_string u) let pr_uni = function | Atom u -> pr_uni_level u | Max ([],[u]) -> str "(" ++ pr_uni_level u ++ str ")+1" | Max (gel,gtl) -> str "max(" ++ hov 0 (prlist_with_sep pr_comma pr_uni_level gel ++ (if gel <> [] & gtl <> [] then pr_comma () else mt ()) ++ prlist_with_sep pr_comma (fun x -> str "(" ++ pr_uni_level x ++ str ")+1") gtl) ++ str ")" (* Returns the formal universe that lies juste above the universe variable u. Used to type the sort u. *) let super = function | Atom u -> Max ([],[u]) | Max _ -> anomaly ("Cannot take the successor of a non variable universe:\n"^ "(maybe a bugged tactic)") (* Returns the formal universe that is greater than the universes u and v. Used to type the products. *) let sup u v = match u,v with | Atom u, Atom v -> if UniverseLevel.compare u v = 0 then Atom u else Max ([u;v],[]) | u, Max ([],[]) -> u | Max ([],[]), v -> v | Atom u, Max (gel,gtl) -> Max (list_add_set u gel,gtl) | Max (gel,gtl), Atom v -> Max (list_add_set v gel,gtl) | Max (gel,gtl), Max (gel',gtl') -> let gel'' = list_union gel gel' in let gtl'' = list_union gtl gtl' in Max (list_subtract gel'' gtl'',gtl'') (* Comparison on this type is pointer equality *) type canonical_arc = { univ: UniverseLevel.t; lt: UniverseLevel.t list; le: UniverseLevel.t list; rank: int } let terminal u = {univ=u; lt=[]; le=[]; rank=0} (* A UniverseLevel.t is either an alias for another one, or a canonical one, for which we know the universes that are above *) type univ_entry = Canonical of canonical_arc | Equiv of UniverseLevel.t type universes = univ_entry UniverseLMap.t let enter_equiv_arc u v g = UniverseLMap.add u (Equiv v) g let enter_arc ca g = UniverseLMap.add ca.univ (Canonical ca) g (* The lower predicative level of the hierarchy that contains (impredicative) Prop and singleton inductive types *) let type0m_univ = Max ([],[]) let is_type0m_univ = function | Max ([],[]) -> true | _ -> false (* The level of predicative Set *) let type0_univ = Atom UniverseLevel.Set let is_type0_univ = function | Atom UniverseLevel.Set -> true | Max ([UniverseLevel.Set], []) -> msg_warn "Non canonical Set"; true | u -> false let is_univ_variable = function | Atom a when a<>UniverseLevel.Set -> true | _ -> false (* When typing [Prop] and [Set], there is no constraint on the level, hence the definition of [type1_univ], the type of [Prop] *) let type1_univ = Max ([], [UniverseLevel.Set]) let initial_universes = UniverseLMap.empty let is_initial_universes = UniverseLMap.is_empty (* Every UniverseLevel.t has a unique canonical arc representative *) (* repr : universes -> UniverseLevel.t -> canonical_arc *) (* canonical representative : we follow the Equiv links *) let repr g u = let rec repr_rec u = let a = try UniverseLMap.find u g with Not_found -> anomalylabstrm "Univ.repr" (str"Universe " ++ pr_uni_level u ++ str" undefined") in match a with | Equiv v -> repr_rec v | Canonical arc -> arc in repr_rec u let can g = List.map (repr g) (* [safe_repr] also search for the canonical representative, but if the graph doesn't contain the searched universe, we add it. *) let safe_repr g u = let rec safe_repr_rec u = match UniverseLMap.find u g with | Equiv v -> safe_repr_rec v | Canonical arc -> arc in try g, safe_repr_rec u with Not_found -> let can = terminal u in enter_arc can g, can (* reprleq : canonical_arc -> canonical_arc list *) (* All canonical arcv such that arcu<=arcv with arcv#arcu *) let reprleq g arcu = let rec searchrec w = function | [] -> w | v :: vl -> let arcv = repr g v in if List.memq arcv w || arcu==arcv then searchrec w vl else searchrec (arcv :: w) vl in searchrec [] arcu.le (* between : UniverseLevel.t -> canonical_arc -> canonical_arc list *) (* between u v = {w|u<=w<=v, w canonical} *) (* between is the most costly operation *) let between g arcu arcv = (* good are all w | u <= w <= v *) (* bad are all w | u <= w ~<= v *) (* find good and bad nodes in {w | u <= w} *) (* explore b u = (b or "u is good") *) let rec explore ((good, bad, b) as input) arcu = if List.memq arcu good then (good, bad, true) (* b or true *) else if List.memq arcu bad then input (* (good, bad, b or false) *) else let leq = reprleq g arcu in (* is some universe >= u good ? *) let good, bad, b_leq = List.fold_left explore (good, bad, false) leq in if b_leq then arcu::good, bad, true (* b or true *) else good, arcu::bad, b (* b or false *) in let good,_,_ = explore ([arcv],[],false) arcu in good (* We assume compare(u,v) = LE with v canonical (see compare below). In this case List.hd(between g u v) = repr u Otherwise, between g u v = [] *) type order = EQ | LT | LE | NLE (** [compare_neq] : is [arcv] in the transitive upward closure of [arcu] ? In [strict] mode, we fully distinguish between LE and LT, while in non-strict mode, we simply answer LE for both situations. If [arcv] is encountered in a LT part, we could directly answer without visiting unneeded parts of this transitive closure. In [strict] mode, if [arcv] is encountered in a LE part, we could only change the default answer (1st arg [c]) from NLE to LE, since a strict constraint may appear later. During the recursive traversal, [lt_done] and [le_done] are universes we have already visited, they do not contain [arcv]. The 4rd arg is [(lt_todo,le_todo)], two lists of universes not yet considered, known to be above [arcu], strictly or not. We use depth-first search, but the presence of [arcv] in [new_lt] is checked as soon as possible : this seems to be slightly faster on a test. *) let compare_neq strict g arcu arcv = let rec cmp c lt_done le_done = function | [],[] -> c | arc::lt_todo, le_todo -> if List.memq arc lt_done then cmp c lt_done le_done (lt_todo,le_todo) else let lt_new = can g (arc.lt@arc.le) in if List.memq arcv lt_new then if strict then LT else LE else cmp c (arc::lt_done) le_done (lt_new@lt_todo,le_todo) | [], arc::le_todo -> if arc == arcv then (* No need to continue inspecting universes above arc: if arcv is strictly above arc, then we would have a cycle. But we cannot answer LE yet, a stronger constraint may come later from [le_todo]. *) if strict then cmp LE lt_done le_done ([],le_todo) else LE else if (List.memq arc lt_done) || (List.memq arc le_done) then cmp c lt_done le_done ([],le_todo) else let lt_new = can g arc.lt in if List.memq arcv lt_new then if strict then LT else LE else let le_new = can g arc.le in cmp c lt_done (arc::le_done) (lt_new, le_new@le_todo) in cmp NLE [] [] ([],[arcu]) let compare g arcu arcv = if arcu == arcv then EQ else compare_neq true g arcu arcv let is_leq g arcu arcv = arcu == arcv || (compare_neq false g arcu arcv = LE) let is_lt g arcu arcv = (compare g arcu arcv = LT) (* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ compare(u,v) = LT or LE => compare(v,u) = NLE compare(u,v) = NLE => compare(v,u) = NLE or LE or LT Adding u>=v is consistent iff compare(v,u) # LT and then it is redundant iff compare(u,v) # NLE Adding u>v is consistent iff compare(v,u) = NLE and then it is redundant iff compare(u,v) = LT *) (** * Universe checks [check_eq] and [check_geq], used in coqchk *) let compare_eq g u v = let g, arcu = safe_repr g u in let _, arcv = safe_repr g v in arcu == arcv type check_function = universes -> universe -> universe -> bool let incl_list cmp l1 l2 = List.for_all (fun x1 -> List.exists (fun x2 -> cmp x1 x2) l2) l1 let compare_list cmp l1 l2 = incl_list cmp l1 l2 && incl_list cmp l2 l1 let rec check_eq g u v = match (u,v) with | Atom ul, Atom vl -> compare_eq g ul vl | Max(ule,ult), Max(vle,vlt) -> (* TODO: remove elements of lt in le! *) compare_list (compare_eq g) ule vle && compare_list (compare_eq g) ult vlt | _ -> anomaly "check_eq" (* not complete! (Atom(u) = Max([u],[]) *) let compare_greater g strict u v = let g, arcu = safe_repr g u in let g, arcv = safe_repr g v in if strict then is_lt g arcv arcu else arcv == snd (safe_repr g UniverseLevel.Set) || is_leq g arcv arcu (* let compare_greater g strict u v = let b = compare_greater g strict u v in ppnl(str (if b then if strict then ">" else ">=" else "NOT >=")); b *) let check_geq g u v = match u, v with | Atom ul, Atom vl -> compare_greater g false ul vl | Atom ul, Max(le,lt) -> List.for_all (fun vl -> compare_greater g false ul vl) le && List.for_all (fun vl -> compare_greater g true ul vl) lt | _ -> anomaly "check_greater" (** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *) (* setlt : UniverseLevel.t -> UniverseLevel.t -> unit *) (* forces u > v *) (* this is normally an update of u in g rather than a creation. *) let setlt g arcu arcv = let arcu' = {arcu with lt=arcv.univ::arcu.lt} in enter_arc arcu' g, arcu' (* checks that non-redundant *) let setlt_if (g,arcu) v = let arcv = repr g v in if is_lt g arcu arcv then g, arcu else setlt g arcu arcv (* setleq : UniverseLevel.t -> UniverseLevel.t -> unit *) (* forces u >= v *) (* this is normally an update of u in g rather than a creation. *) let setleq g arcu arcv = let arcu' = {arcu with le=arcv.univ::arcu.le} in enter_arc arcu' g, arcu' (* checks that non-redundant *) let setleq_if (g,arcu) v = let arcv = repr g v in if is_leq g arcu arcv then g, arcu else setleq g arcu arcv (* merge : UniverseLevel.t -> UniverseLevel.t -> unit *) (* we assume compare(u,v) = LE *) (* merge u v forces u ~ v with repr u as canonical repr *) let merge g arcu arcv = (* we find the arc with the biggest rank, and we redirect all others to it *) let arcu, g, v = let best_ranked (max_rank, old_max_rank, best_arc, rest) arc = if arc.rank >= max_rank then (arc.rank, max_rank, arc, best_arc::rest) else (max_rank, old_max_rank, best_arc, arc::rest) in match between g arcu arcv with | [] -> anomaly "Univ.between" | arc::rest -> let (max_rank, old_max_rank, best_arc, rest) = List.fold_left best_ranked (arc.rank, min_int, arc, []) rest in if max_rank > old_max_rank then best_arc, g, rest else begin (* one redirected node also has max_rank *) let arcu = {best_arc with rank = max_rank + 1} in arcu, enter_arc arcu g, rest end in let redirect (g,w,w') arcv = let g' = enter_equiv_arc arcv.univ arcu.univ g in (g',list_unionq arcv.lt w,arcv.le@w') in let (g',w,w') = List.fold_left redirect (g,[],[]) v in let g_arcu = (g',arcu) in let g_arcu = List.fold_left setlt_if g_arcu w in let g_arcu = List.fold_left setleq_if g_arcu w' in fst g_arcu (* merge_disc : UniverseLevel.t -> UniverseLevel.t -> unit *) (* we assume compare(u,v) = compare(v,u) = NLE *) (* merge_disc u v forces u ~ v with repr u as canonical repr *) let merge_disc g arc1 arc2 = let arcu, arcv = if arc1.rank < arc2.rank then arc2, arc1 else arc1, arc2 in let arcu, g = if arc1.rank <> arc2.rank then arcu, g else let arcu = {arcu with rank = succ arcu.rank} in arcu, enter_arc arcu g in let g' = enter_equiv_arc arcv.univ arcu.univ g in let g_arcu = (g',arcu) in let g_arcu = List.fold_left setlt_if g_arcu arcv.lt in let g_arcu = List.fold_left setleq_if g_arcu arcv.le in fst g_arcu (* Universe inconsistency: error raised when trying to enforce a relation that would create a cycle in the graph of universes. *) type constraint_type = Lt | Le | Eq exception UniverseInconsistency of constraint_type * universe * universe let error_inconsistency o u v = raise (UniverseInconsistency (o,Atom u,Atom v)) (* enforce_univ_leq : UniverseLevel.t -> UniverseLevel.t -> unit *) (* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *) let enforce_univ_leq u v g = let g,arcu = safe_repr g u in let g,arcv = safe_repr g v in if is_leq g arcu arcv then g else match compare g arcv arcu with | LT -> error_inconsistency Le u v | LE -> merge g arcv arcu | NLE -> fst (setleq g arcu arcv) | EQ -> anomaly "Univ.compare" (* enforc_univ_eq : UniverseLevel.t -> UniverseLevel.t -> unit *) (* enforc_univ_eq u v will force u=v if possible, will fail otherwise *) let enforce_univ_eq u v g = let g,arcu = safe_repr g u in let g,arcv = safe_repr g v in match compare g arcu arcv with | EQ -> g | LT -> error_inconsistency Eq u v | LE -> merge g arcu arcv | NLE -> (match compare g arcv arcu with | LT -> error_inconsistency Eq u v | LE -> merge g arcv arcu | NLE -> merge_disc g arcu arcv | EQ -> anomaly "Univ.compare") (* enforce_univ_lt u v will force u g | LE -> fst (setlt g arcu arcv) | EQ -> error_inconsistency Lt u v | NLE -> if is_leq g arcv arcu then error_inconsistency Lt u v else fst (setlt g arcu arcv) (* Constraints and sets of consrtaints. *) type univ_constraint = UniverseLevel.t * constraint_type * UniverseLevel.t let enforce_constraint cst g = match cst with | (u,Lt,v) -> enforce_univ_lt u v g | (u,Le,v) -> enforce_univ_leq u v g | (u,Eq,v) -> enforce_univ_eq u v g module Constraint = Set.Make( struct type t = univ_constraint let compare (u,c,v) (u',c',v') = let i = Pervasives.compare c c' in if i <> 0 then i else let i' = UniverseLevel.compare u u' in if i' <> 0 then i' else UniverseLevel.compare v v' end) type constraints = Constraint.t let empty_constraint = Constraint.empty let is_empty_constraint = Constraint.is_empty let union_constraints = Constraint.union type constraint_function = universe -> universe -> constraints -> constraints let constraint_add_leq v u c = if v = UniverseLevel.Set then c else Constraint.add (v,Le,u) c let enforce_geq u v c = match u, v with | Atom u, Atom v -> constraint_add_leq v u c | Atom u, Max (gel,gtl) -> let d = List.fold_right (fun v -> constraint_add_leq v u) gel c in List.fold_right (fun v -> Constraint.add (v,Lt,u)) gtl d | _ -> anomaly "A universe bound can only be a variable" let enforce_eq u v c = match (u,v) with | Atom u, Atom v -> Constraint.add (u,Eq,v) c | _ -> anomaly "A universe comparison can only happen between variables" let merge_constraints c g = Constraint.fold enforce_constraint c g (* Normalization *) let lookup_level u g = try Some (UniverseLMap.find u g) with Not_found -> None (** [normalize_universes g] returns a graph where all edges point directly to the canonical representent of their target. The output graph should be equivalent to the input graph from a logical point of view, but optimized. We maintain the invariant that the key of a [Canonical] element is its own name, by keeping [Equiv] edges (see the assertion)... I (StÃĐphane Glondu) am not sure if this plays a role in the rest of the module. *) let normalize_universes g = let rec visit u arc cache = match lookup_level u cache with | Some x -> x, cache | None -> match Lazy.force arc with | None -> u, UniverseLMap.add u u cache | Some (Canonical {univ=v; lt=_; le=_}) -> v, UniverseLMap.add u v cache | Some (Equiv v) -> let v, cache = visit v (lazy (lookup_level v g)) cache in v, UniverseLMap.add u v cache in let cache = UniverseLMap.fold (fun u arc cache -> snd (visit u (Lazy.lazy_from_val (Some arc)) cache)) g UniverseLMap.empty in let repr x = UniverseLMap.find x cache in let lrepr us = List.fold_left (fun e x -> UniverseLSet.add (repr x) e) UniverseLSet.empty us in let canonicalize u = function | Equiv _ -> Equiv (repr u) | Canonical {univ=v; lt=lt; le=le; rank=rank} -> assert (u == v); (* avoid duplicates and self-loops *) let lt = lrepr lt and le = lrepr le in let le = UniverseLSet.filter (fun x -> x != u && not (UniverseLSet.mem x lt)) le in UniverseLSet.iter (fun x -> assert (x != u)) lt; Canonical { univ = v; lt = UniverseLSet.elements lt; le = UniverseLSet.elements le; rank = rank } in UniverseLMap.mapi canonicalize g (** [check_sorted g sorted]: [g] being a universe graph, [sorted] being a map to levels, checks that all constraints in [g] are satisfied in [sorted]. *) let check_sorted g sorted = let get u = try UniverseLMap.find u sorted with | Not_found -> assert false in UniverseLMap.iter (fun u arc -> let lu = get u in match arc with | Equiv v -> assert (lu = get v) | Canonical {univ=u'; lt=lt; le=le} -> assert (u == u'); List.iter (fun v -> assert (lu <= get v)) le; List.iter (fun v -> assert (lu < get v)) lt) g (** Bellman-Ford algorithm with a few customizations: - [weight(eq|le) = 0], [weight(lt) = -1] - a [le] edge is initially added from [bottom] to all other vertices, and [bottom] is used as the source vertex *) let bellman_ford bottom g = assert (lookup_level bottom g = None); let ( << ) a b = match a, b with | _, None -> true | None, _ -> false | Some x, Some y -> x < y and ( ++ ) a y = match a with | None -> None | Some x -> Some (x-y) and push u x m = match x with | None -> m | Some y -> UniverseLMap.add u y m in let relax u v uv distances = let x = lookup_level u distances ++ uv in if x << lookup_level v distances then push v x distances else distances in let init = UniverseLMap.add bottom 0 UniverseLMap.empty in let vertices = UniverseLMap.fold (fun u arc res -> let res = UniverseLSet.add u res in match arc with | Equiv e -> UniverseLSet.add e res | Canonical {univ=univ; lt=lt; le=le} -> assert (u == univ); let add res v = UniverseLSet.add v res in let res = List.fold_left add res le in let res = List.fold_left add res lt in res) g UniverseLSet.empty in let g = let node = Canonical { univ = bottom; lt = []; le = UniverseLSet.elements vertices; rank = 0 } in UniverseLMap.add bottom node g in let rec iter count accu = if count <= 0 then accu else let accu = UniverseLMap.fold (fun u arc res -> match arc with | Equiv e -> relax e u 0 (relax u e 0 res) | Canonical {univ=univ; lt=lt; le=le} -> assert (u == univ); let res = List.fold_left (fun res v -> relax u v 0 res) res le in let res = List.fold_left (fun res v -> relax u v 1 res) res lt in res) g accu in iter (count-1) accu in let distances = iter (UniverseLSet.cardinal vertices) init in let () = UniverseLMap.iter (fun u arc -> let lu = lookup_level u distances in match arc with | Equiv v -> let lv = lookup_level v distances in assert (not (lu << lv) && not (lv << lu)) | Canonical {univ=univ; lt=lt; le=le} -> assert (u == univ); List.iter (fun v -> assert (not (lu ++ 0 << lookup_level v distances))) le; List.iter (fun v -> assert (not (lu ++ 1 << lookup_level v distances))) lt) g in distances (** [sort_universes g] builds a map from universes in [g] to natural numbers. It outputs a graph containing equivalence edges from each level appearing in [g] to [Type.n], and [lt] edges between the [Type.n]s. The output graph should imply the input graph (and the implication will be strict most of the time), but is not necessarily minimal. Note: the result is unspecified if the input graph already contains [Type.n] nodes (calling a module Type is probably a bad idea anyway). *) let sort_universes orig = let mp = Names.make_dirpath [Names.id_of_string "Type"] in let rec make_level accu g i = let type0 = UniverseLevel.Level (mp, i) in let distances = bellman_ford type0 g in let accu, continue = UniverseLMap.fold (fun u x (accu, continue) -> let continue = continue || x < 0 in let accu = if x = 0 && u != type0 then UniverseLMap.add u i accu else accu in accu, continue) distances (accu, false) in let filter x = not (UniverseLMap.mem x accu) in let push g u = if UniverseLMap.mem u g then g else UniverseLMap.add u (Equiv u) g in let g = UniverseLMap.fold (fun u arc res -> match arc with | Equiv v as x -> begin match filter u, filter v with | true, true -> UniverseLMap.add u x res | true, false -> push res u | false, true -> push res v | false, false -> res end | Canonical {univ=v; lt=lt; le=le; rank=r} -> assert (u == v); if filter u then let lt = List.filter filter lt in let le = List.filter filter le in UniverseLMap.add u (Canonical {univ=u; lt=lt; le=le; rank=r}) res else let res = List.fold_left (fun g u -> if filter u then push g u else g) res lt in let res = List.fold_left (fun g u -> if filter u then push g u else g) res le in res) g UniverseLMap.empty in if continue then make_level accu g (i+1) else i, accu in let max, levels = make_level UniverseLMap.empty orig 0 in (* defensively check that the result makes sense *) check_sorted orig levels; let types = Array.init (max+1) (fun x -> UniverseLevel.Level (mp, x)) in let g = UniverseLMap.map (fun x -> Equiv types.(x)) levels in let g = let rec aux i g = if i < max then let u = types.(i) in let g = UniverseLMap.add u (Canonical { univ = u; le = []; lt = [types.(i+1)]; rank = 1 }) g in aux (i+1) g else g in aux 0 g in g (**********************************************************************) (* Tools for sort-polymorphic inductive types *) (* Temporary inductive type levels *) let fresh_level = let n = ref 0 in fun () -> incr n; UniverseLevel.Level (Names.make_dirpath [],!n) let fresh_local_univ () = Atom (fresh_level ()) (* Miscellaneous functions to remove or test local univ assumed to occur only in the le constraints *) let make_max = function | ([u],[]) -> Atom u | (le,lt) -> Max (le,lt) let remove_large_constraint u = function | Atom u' as x -> if u = u' then Max ([],[]) else x | Max (le,lt) -> make_max (list_remove u le,lt) let is_direct_constraint u = function | Atom u' -> u = u' | Max (le,lt) -> List.mem u le (* Solve a system of universe constraint of the form u_s11, ..., u_s1p1, w1 <= u1 ... u_sn1, ..., u_snpn, wn <= un where - the ui (1 <= i <= n) are universe variables, - the sjk select subsets of the ui for each equations, - the wi are arbitrary complex universes that do not mention the ui. *) let is_direct_sort_constraint s v = match s with | Some u -> is_direct_constraint u v | None -> false let solve_constraints_system levels level_bounds = let levels = Array.map (Option.map (function Atom u -> u | _ -> anomaly "expects Atom")) levels in let v = Array.copy level_bounds in let nind = Array.length v in for i=0 to nind-1 do for j=0 to nind-1 do if i<>j & is_direct_sort_constraint levels.(j) v.(i) then v.(i) <- sup v.(i) level_bounds.(j) done; for j=0 to nind-1 do match levels.(j) with | Some u -> v.(i) <- remove_large_constraint u v.(i) | None -> () done done; v let subst_large_constraint u u' v = match u with | Atom u -> if is_direct_constraint u v then sup u' (remove_large_constraint u v) else v | _ -> anomaly "expect a universe level" let subst_large_constraints = List.fold_right (fun (u,u') -> subst_large_constraint u u') let no_upper_constraints u cst = match u with | Atom u -> Constraint.for_all (fun (u1,_,_) -> u1 <> u) cst | Max _ -> anomaly "no_upper_constraints" (* Is u mentionned in v (or equals to v) ? *) let univ_depends u v = match u, v with | Atom u, Atom v -> u = v | Atom u, Max (gel,gtl) -> List.mem u gel || List.mem u gtl | _ -> anomaly "univ_depends given a non-atomic 1st arg" (* Pretty-printing *) let pr_arc = function | _, Canonical {univ=u; lt=[]; le=[]} -> mt () | _, Canonical {univ=u; lt=lt; le=le} -> pr_uni_level u ++ str " " ++ v 0 (prlist_with_sep pr_spc (fun v -> str "< " ++ pr_uni_level v) lt ++ (if lt <> [] & le <> [] then spc () else mt()) ++ prlist_with_sep pr_spc (fun v -> str "<= " ++ pr_uni_level v) le) ++ fnl () | u, Equiv v -> pr_uni_level u ++ str " = " ++ pr_uni_level v ++ fnl () let pr_universes g = let graph = UniverseLMap.fold (fun u a l -> (u,a)::l) g [] in prlist pr_arc graph let pr_constraints c = Constraint.fold (fun (u1,op,u2) pp_std -> let op_str = match op with | Lt -> " < " | Le -> " <= " | Eq -> " = " in pp_std ++ pr_uni_level u1 ++ str op_str ++ pr_uni_level u2 ++ fnl () ) c (str "") (* Dumping constraints to a file *) let dump_universes output g = let dump_arc u = function | Canonical {univ=u; lt=lt; le=le} -> let u_str = UniverseLevel.to_string u in List.iter (fun v -> output Lt u_str (UniverseLevel.to_string v)) lt; List.iter (fun v -> output Le u_str (UniverseLevel.to_string v)) le | Equiv v -> output Eq (UniverseLevel.to_string u) (UniverseLevel.to_string v) in UniverseLMap.iter dump_arc g (* Hash-consing *) module Hunivlevel = Hashcons.Make( struct type t = universe_level type u = Names.dir_path -> Names.dir_path let hash_sub hdir = function | UniverseLevel.Set -> UniverseLevel.Set | UniverseLevel.Level (d,n) -> UniverseLevel.Level (hdir d,n) let equal l1 l2 = match l1,l2 with | UniverseLevel.Set, UniverseLevel.Set -> true | UniverseLevel.Level (d,n), UniverseLevel.Level (d',n') -> n == n' && d == d' | _ -> false let hash = Hashtbl.hash end) module Huniv = Hashcons.Make( struct type t = universe type u = universe_level -> universe_level let hash_sub hdir = function | Atom u -> Atom (hdir u) | Max (gel,gtl) -> Max (List.map hdir gel, List.map hdir gtl) let equal u v = match u, v with | Atom u, Atom v -> u == v | Max (gel,gtl), Max (gel',gtl') -> (list_for_all2eq (==) gel gel') && (list_for_all2eq (==) gtl gtl') | _ -> false let hash = Hashtbl.hash end) let hcons_univlevel = Hashcons.simple_hcons Hunivlevel.f Names.hcons_dirpath let hcons_univ = Hashcons.simple_hcons Huniv.f hcons_univlevel module Hconstraint = Hashcons.Make( struct type t = univ_constraint type u = universe_level -> universe_level let hash_sub hul (l1,k,l2) = (hul l1, k, hul l2) let equal (l1,k,l2) (l1',k',l2') = l1 == l1' && k = k' && l2 == l2' let hash = Hashtbl.hash end) module Hconstraints = Hashcons.Make( struct type t = constraints type u = univ_constraint -> univ_constraint let hash_sub huc s = Constraint.fold (fun x -> Constraint.add (huc x)) s Constraint.empty let equal s s' = list_for_all2eq (==) (Constraint.elements s) (Constraint.elements s') let hash = Hashtbl.hash end) let hcons_constraint = Hashcons.simple_hcons Hconstraint.f hcons_univlevel let hcons_constraints = Hashcons.simple_hcons Hconstraints.f hcons_constraint coq-8.4pl4/kernel/vm.ml0000644000175000017500000004724612326224777014104 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit = "coq_set_drawinstr" (******************************************) (* Utility Functions about Obj ************) (******************************************) external offset_closure : Obj.t -> int -> Obj.t = "coq_offset_closure" external offset : Obj.t -> int = "coq_offset" let accu_tag = 0 (*******************************************) (* Initalization of the abstract machine ***) (*******************************************) external init_vm : unit -> unit = "init_coq_vm" let _ = init_vm () external transp_values : unit -> bool = "get_coq_transp_value" external set_transp_values : bool -> unit = "coq_set_transp_value" (*******************************************) (* Machine code *** ************************) (*******************************************) type tcode let tcode_of_obj v = ((Obj.obj v):tcode) let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0) external mkAccuCode : int -> tcode = "coq_makeaccu" external mkPopStopCode : int -> tcode = "coq_pushpop" external mkAccuCond : int -> tcode = "coq_accucond" external offset_tcode : tcode -> int -> tcode = "coq_offset_tcode" external int_tcode : tcode -> int -> int = "coq_int_tcode" external accumulate : unit -> tcode = "accumulate_code" let accumulate = accumulate () external is_accumulate : tcode -> bool = "coq_is_accumulate_code" let popstop_tbl = ref (Array.init 30 mkPopStopCode) let popstop_code i = let len = Array.length !popstop_tbl in if i < len then !popstop_tbl.(i) else begin popstop_tbl := Array.init (i+10) (fun j -> if j < len then !popstop_tbl.(j) else mkPopStopCode j); !popstop_tbl.(i) end let stop = popstop_code 0 (******************************************************) (* Abstract data types and utility functions **********) (******************************************************) (* Values of the abstract machine *) let val_of_obj v = ((Obj.obj v):values) let crazy_val = (val_of_obj (Obj.repr 0)) (* Abstract data *) type vprod type vfun type vfix type vcofix type vblock type arguments type vm_env type vstack = values array type vswitch = { sw_type_code : tcode; sw_code : tcode; sw_annot : annot_switch; sw_stk : vstack; sw_env : vm_env } (* Representation of values *) (* + Products : *) (* - vprod = 0_[ dom | codom] *) (* dom : values, codom : vfun *) (* *) (* + Functions have two representations : *) (* - unapplied fun : vf = Ct_[ C | fv1 | ... | fvn] *) (* C:tcode, fvi : values *) (* Remark : a function and its environment is the same value. *) (* - partially applied fun : Ct_[Restart:C| vf | arg1 | ... argn] *) (* *) (* + Fixpoints : *) (* - Ct_[C1|Infix_t|C2|...|Infix_t|Cn|fv1|...|fvn] *) (* One single block to represent all of the fixpoints, each fixpoint *) (* is the pointer to the field holding the pointer to its code, and *) (* the infix tag is used to know where the block starts. *) (* - Partial application follows the scheme of partially applied *) (* functions. Note: only fixpoints not having been applied to its *) (* recursive argument are coded this way. When the rec. arg. is *) (* applied, either it's a constructor and the fix reduces, or it's *) (* and the fix is coded as an accumulator. *) (* *) (* + Cofixpoints : see cbytegen.ml *) (* *) (* + vblock's encode (non constant) constructors as in Ocaml, but *) (* starting from 0 up. tag 0 ( = accu_tag) is reserved for *) (* accumulators. *) (* *) (* + vm_env is the type of the machine environments (i.e. a function or *) (* a fixpoint) *) (* *) (* + Accumulators : At_[accumulate| accu | arg1 | ... | argn ] *) (* - representation of [accu] : tag_[....] *) (* -- tag <= 2 : encoding atom type (sorts, free vars, etc.) *) (* -- 3_[accu|fix_app] : a fixpoint blocked by an accu *) (* -- 4_[accu|vswitch] : a match blocked by an accu *) (* -- 5_[fcofix] : a cofix function *) (* -- 6_[fcofix|val] : a cofix function, val represent the value *) (* of the function applied to arg1 ... argn *) (* The [arguments] type, which is abstracted as an array, represents : *) (* tag[ _ | _ |v1|... | vn] *) (* Generally the first field is a code pointer. *) (* Do not edit this type without editing C code, especially "coq_values.h" *) type atom = | Aid of id_key | Aiddef of id_key * values | Aind of inductive (* Zippers *) type zipper = | Zapp of arguments | Zfix of vfix*arguments (* Possibly empty *) | Zswitch of vswitch type stack = zipper list type to_up = values type whd = | Vsort of sorts | Vprod of vprod | Vfun of vfun | Vfix of vfix * arguments option | Vcofix of vcofix * to_up * arguments option | Vconstr_const of int | Vconstr_block of vblock | Vatom_stk of atom * stack (*************************************************) (* Destructors ***********************************) (*************************************************) let rec whd_accu a stk = let stk = if Obj.size a = 2 then stk else Zapp (Obj.obj a) :: stk in let at = Obj.field a 1 in match Obj.tag at with | i when i <= 2 -> Vatom_stk(Obj.magic at, stk) | 3 (* fix_app tag *) -> let fa = Obj.field at 1 in let zfix = Zfix (Obj.obj (Obj.field fa 1), Obj.obj fa) in whd_accu (Obj.field at 0) (zfix :: stk) | 4 (* switch tag *) -> let zswitch = Zswitch (Obj.obj (Obj.field at 1)) in whd_accu (Obj.field at 0) (zswitch :: stk) | 5 (* cofix_tag *) -> let vcfx = Obj.obj (Obj.field at 0) in let to_up = Obj.obj a in begin match stk with | [] -> Vcofix(vcfx, to_up, None) | [Zapp args] -> Vcofix(vcfx, to_up, Some args) | _ -> assert false end | 6 (* cofix_evaluated_tag *) -> let vcofix = Obj.obj (Obj.field at 0) in let res = Obj.obj a in begin match stk with | [] -> Vcofix(vcofix, res, None) | [Zapp args] -> Vcofix(vcofix, res, Some args) | _ -> assert false end | _ -> assert false external kind_of_closure : Obj.t -> int = "coq_kind_of_closure" let whd_val : values -> whd = fun v -> let o = Obj.repr v in if Obj.is_int o then Vconstr_const (Obj.obj o) else let tag = Obj.tag o in if tag = accu_tag then ( if Obj.size o = 1 then Obj.obj o (* sort *) else if is_accumulate (fun_code o) then whd_accu o [] else (Vprod(Obj.obj o))) else if tag = Obj.closure_tag || tag = Obj.infix_tag then ( match kind_of_closure o with | 0 -> Vfun(Obj.obj o) | 1 -> Vfix(Obj.obj o, None) | 2 -> Vfix(Obj.obj (Obj.field o 1), Some (Obj.obj o)) | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) | _ -> Util.anomaly "Vm.whd : kind_of_closure does not work") else Vconstr_block(Obj.obj o) (************************************************) (* Abstrct machine ******************************) (************************************************) (* gestion de la pile *) external push_ra : tcode -> unit = "coq_push_ra" external push_val : values -> unit = "coq_push_val" external push_arguments : arguments -> unit = "coq_push_arguments" external push_vstack : vstack -> unit = "coq_push_vstack" (* interpreteur *) external interprete : tcode -> values -> vm_env -> int -> values = "coq_interprete_ml" (* Functions over arguments *) let nargs : arguments -> int = fun args -> (Obj.size (Obj.repr args)) - 2 let arg args i = if 0 <= i && i < (nargs args) then val_of_obj (Obj.field (Obj.repr args) (i+2)) else raise (Invalid_argument ("Vm.arg size = "^(string_of_int (nargs args))^ " acces "^(string_of_int i))) let apply_arguments vf vargs = let n = nargs vargs in if n = 0 then vf else begin push_ra stop; push_arguments vargs; interprete (fun_code vf) vf (Obj.magic vf) (n - 1) end let apply_vstack vf vstk = let n = Array.length vstk in if n = 0 then vf else begin push_ra stop; push_vstack vstk; interprete (fun_code vf) vf (Obj.magic vf) (n - 1) end (**********************************************) (* Constructors *******************************) (**********************************************) let obj_of_atom : atom -> Obj.t = fun a -> let res = Obj.new_block accu_tag 2 in Obj.set_field res 0 (Obj.repr accumulate); Obj.set_field res 1 (Obj.repr a); res (* obj_of_str_const : structured_constant -> Obj.t *) let rec obj_of_str_const str = match str with | Const_sorts s -> Obj.repr (Vsort s) | Const_ind ind -> obj_of_atom (Aind ind) | Const_b0 tag -> Obj.repr tag | Const_bn(tag, args) -> let len = Array.length args in let res = Obj.new_block tag len in for i = 0 to len - 1 do Obj.set_field res i (obj_of_str_const args.(i)) done; res let val_of_obj o = ((Obj.obj o) : values) let val_of_str_const str = val_of_obj (obj_of_str_const str) let val_of_atom a = val_of_obj (obj_of_atom a) let idkey_tbl = Hashtbl.create 31 let val_of_idkey key = try Hashtbl.find idkey_tbl key with Not_found -> let v = val_of_atom (Aid key) in Hashtbl.add idkey_tbl key v; v let val_of_rel k = val_of_idkey (RelKey k) let val_of_rel_def k v = val_of_atom(Aiddef(RelKey k, v)) let val_of_named id = val_of_idkey (VarKey id) let val_of_named_def id v = val_of_atom(Aiddef(VarKey id, v)) let val_of_constant c = val_of_idkey (ConstKey c) let val_of_constant_def n c v = let res = Obj.new_block accu_tag 2 in Obj.set_field res 0 (Obj.repr (mkAccuCond n)); Obj.set_field res 1 (Obj.repr (Aiddef(ConstKey c, v))); val_of_obj res external val_of_annot_switch : annot_switch -> values = "%identity" let mkrel_vstack k arity = let max = k + arity - 1 in Array.init arity (fun i -> val_of_rel (max - i)) (*************************************************) (** Operations manipulating data types ***********) (*************************************************) (* Functions over products *) let dom : vprod -> values = fun p -> val_of_obj (Obj.field (Obj.repr p) 0) let codom : vprod -> vfun = fun p -> (Obj.obj (Obj.field (Obj.repr p) 1)) (* Functions over vfun *) external closure_arity : vfun -> int = "coq_closure_arity" let body_of_vfun k vf = let vargs = mkrel_vstack k 1 in apply_vstack (Obj.magic vf) vargs let decompose_vfun2 k vf1 vf2 = let arity = min (closure_arity vf1) (closure_arity vf2) in assert (0 < arity && arity < Sys.max_array_length); let vargs = mkrel_vstack k arity in let v1 = apply_vstack (Obj.magic vf1) vargs in let v2 = apply_vstack (Obj.magic vf2) vargs in arity, v1, v2 (* Functions over fixpoint *) let first o = (offset_closure o (offset o)) let last o = (Obj.field o (Obj.size o - 1)) let current_fix vf = - (offset (Obj.repr vf) / 2) let unsafe_fb_code fb i = tcode_of_obj (Obj.field (Obj.repr fb) (2 * i)) let unsafe_rec_arg fb i = int_tcode (unsafe_fb_code fb i) 1 let rec_args vf = let fb = first (Obj.repr vf) in let size = Obj.size (last fb) in Array.init size (unsafe_rec_arg fb) exception FALSE let check_fix f1 f2 = let i1, i2 = current_fix f1, current_fix f2 in (* Checking starting point *) if i1 = i2 then let fb1,fb2 = first (Obj.repr f1), first (Obj.repr f2) in let n = Obj.size (last fb1) in (* Checking number of definitions *) if n = Obj.size (last fb2) then (* Checking recursive arguments *) try for i = 0 to n - 1 do if unsafe_rec_arg fb1 i <> unsafe_rec_arg fb2 i then raise FALSE done; true with FALSE -> false else false else false (* Functions over vfix *) external atom_rel : unit -> atom array = "get_coq_atom_tbl" external realloc_atom_rel : int -> unit = "realloc_coq_atom_tbl" let relaccu_tbl = let atom_rel = atom_rel() in let len = Array.length atom_rel in for i = 0 to len - 1 do atom_rel.(i) <- Aid (RelKey i) done; ref (Array.init len mkAccuCode) let relaccu_code i = let len = Array.length !relaccu_tbl in if i < len then !relaccu_tbl.(i) else begin realloc_atom_rel i; let atom_rel = atom_rel () in let nl = Array.length atom_rel in for j = len to nl - 1 do atom_rel.(j) <- Aid(RelKey j) done; relaccu_tbl := Array.init nl (fun j -> if j < len then !relaccu_tbl.(j) else mkAccuCode j); !relaccu_tbl.(i) end let reduce_fix k vf = let fb = first (Obj.repr vf) in (* computing types *) let fc_typ = ((Obj.obj (last fb)) : tcode array) in let ndef = Array.length fc_typ in let et = offset_closure fb (2*(ndef - 1)) in let ftyp = Array.map (fun c -> interprete c crazy_val (Obj.magic et) 0) fc_typ in (* Construction of the environment of fix bodies *) let e = Obj.dup fb in for i = 0 to ndef - 1 do Obj.set_field e (2 * i) (Obj.repr (relaccu_code (k + i))) done; let fix_body i = let jump_grabrec c = offset_tcode c 2 in let c = jump_grabrec (unsafe_fb_code fb i) in let res = Obj.new_block Obj.closure_tag 2 in Obj.set_field res 0 (Obj.repr c); Obj.set_field res 1 (offset_closure e (2*i)); ((Obj.obj res) : vfun) in (Array.init ndef fix_body, ftyp) (* Functions over vcofix *) let get_fcofix vcf i = match whd_val (Obj.obj (Obj.field (Obj.repr vcf) (i+1))) with | Vcofix(vcfi, _, _) -> vcfi | _ -> assert false let current_cofix vcf = let ndef = Obj.size (last (Obj.repr vcf)) in let rec find_cofix pos = if pos < ndef then if get_fcofix vcf pos == vcf then pos else find_cofix (pos+1) else raise Not_found in try find_cofix 0 with Not_found -> assert false let check_cofix vcf1 vcf2 = (current_cofix vcf1 = current_cofix vcf2) && (Obj.size (last (Obj.repr vcf1)) = Obj.size (last (Obj.repr vcf2))) let reduce_cofix k vcf = let fc_typ = ((Obj.obj (last (Obj.repr vcf))) : tcode array) in let ndef = Array.length fc_typ in let ftyp = (* Evaluate types *) Array.map (fun c -> interprete c crazy_val (Obj.magic vcf) 0) fc_typ in (* Construction of the environment of cofix bodies *) let e = Obj.dup (Obj.repr vcf) in for i = 0 to ndef - 1 do Obj.set_field e (i+1) (Obj.repr (val_of_rel (k+i))) done; let cofix_body i = let vcfi = get_fcofix vcf i in let c = Obj.field (Obj.repr vcfi) 0 in Obj.set_field e 0 c; let atom = Obj.new_block cofix_tag 1 in let self = Obj.new_block accu_tag 2 in Obj.set_field self 0 (Obj.repr accumulate); Obj.set_field self 1 (Obj.repr atom); apply_vstack (Obj.obj e) [|Obj.obj self|] in (Array.init ndef cofix_body, ftyp) (* Functions over vblock *) let btag : vblock -> int = fun b -> Obj.tag (Obj.repr b) let bsize : vblock -> int = fun b -> Obj.size (Obj.repr b) let bfield b i = if 0 <= i && i < (bsize b) then val_of_obj (Obj.field (Obj.repr b) i) else raise (Invalid_argument "Vm.bfield") (* Functions over vswitch *) let check_switch sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl let case_info sw = sw.sw_annot.ci let type_of_switch sw = push_vstack sw.sw_stk; interprete sw.sw_type_code crazy_val sw.sw_env 0 let branch_arg k (tag,arity) = if arity = 0 then ((Obj.magic tag):values) else let b = Obj.new_block tag arity in for i = 0 to arity - 1 do Obj.set_field b i (Obj.repr (val_of_rel (k+i))) done; val_of_obj b let apply_switch sw arg = let tc = sw.sw_annot.tailcall in if tc then (push_ra stop;push_vstack sw.sw_stk) else (push_vstack sw.sw_stk; push_ra (popstop_code (Array.length sw.sw_stk))); interprete sw.sw_code arg sw.sw_env 0 let branch_of_switch k sw = let eval_branch (_,arity as ta) = let arg = branch_arg k ta in let v = apply_switch sw arg in (arity, v) in Array.map eval_branch sw.sw_annot.rtbl (* Evaluation *) let rec whd_stack v stk = match stk with | [] -> whd_val v | Zapp args :: stkt -> whd_stack (apply_arguments v args) stkt | Zfix (f,args) :: stkt -> let o = Obj.repr v in if Obj.is_block o && Obj.tag o = accu_tag then whd_accu (Obj.repr v) stk else let v', stkt = match stkt with | Zapp args' :: stkt -> push_ra stop; push_arguments args'; push_val v; push_arguments args; let v' = interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args+ nargs args') in v', stkt | _ -> push_ra stop; push_val v; push_arguments args; let v' = interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args) in v', stkt in whd_stack v' stkt | Zswitch sw :: stkt -> let o = Obj.repr v in if Obj.is_block o && Obj.tag o = accu_tag then if Obj.tag (Obj.field o 1) < cofix_tag then whd_accu (Obj.repr v) stk else let to_up = match whd_accu (Obj.repr v) [] with | Vcofix (_, to_up, _) -> to_up | _ -> assert false in whd_stack (apply_switch sw to_up) stkt else whd_stack (apply_switch sw v) stkt let rec force_whd v stk = match whd_stack v stk with | Vatom_stk(Aiddef(_,v),stk) -> force_whd v stk | res -> res let rec eta_stack a stk v = match stk with | [] -> apply_vstack a [|v|] | Zapp args :: stk -> eta_stack (apply_arguments a args) stk v | Zfix(f,args) :: stk -> let a,stk = match stk with | Zapp args' :: stk -> push_ra stop; push_arguments args'; push_val a; push_arguments args; let a = interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args+ nargs args') in a, stk | _ -> push_ra stop; push_val a; push_arguments args; let a = interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args) in a, stk in eta_stack a stk v | Zswitch sw :: stk -> eta_stack (apply_switch sw a) stk v let eta_whd k whd = let v = val_of_rel k in match whd with | Vsort _ | Vprod _ | Vconstr_const _ | Vconstr_block _ -> assert false | Vfun f -> body_of_vfun k f | Vfix(f, None) -> push_ra stop; push_val v; interprete (fun_code f) (Obj.magic f) (Obj.magic f) 0 | Vfix(f, Some args) -> push_ra stop; push_val v; push_arguments args; interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args) | Vcofix(_,to_up,_) -> push_ra stop; push_val v; interprete (fun_code to_up) (Obj.magic to_up) (Obj.magic to_up) 0 | Vatom_stk(a,stk) -> eta_stack (val_of_atom a) stk v coq-8.4pl4/kernel/reduction.ml0000644000175000017500000004711012326224777015444 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* None | ConstKey cst when not (Cpred.mem cst csts) -> None | _ -> unfold_reference infos k let rec is_empty_stack = function [] -> true | Zupdate _::s -> is_empty_stack s | Zshift _::s -> is_empty_stack s | _ -> false (* Compute the lift to be performed on a term placed in a given stack *) let el_stack el stk = let n = List.fold_left (fun i z -> match z with Zshift n -> i+n | _ -> i) 0 stk in el_shft n el let compare_stack_shape stk1 stk2 = let rec compare_rec bal stk1 stk2 = match (stk1,stk2) with ([],[]) -> bal=0 | ((Zupdate _|Zshift _)::s1, _) -> compare_rec bal s1 stk2 | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2 | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2 | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 | (Zcase(c1,_,_)::s1, Zcase(c2,_,_)::s2) -> bal=0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> bal=0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 | (_,_) -> false in compare_rec 0 stk1 stk2 type lft_constr_stack_elt = Zlapp of (lift * fconstr) array | Zlfix of (lift * fconstr) * lft_constr_stack | Zlcase of case_info * lift * fconstr * fconstr array and lft_constr_stack = lft_constr_stack_elt list let rec zlapp v = function Zlapp v2 :: s -> zlapp (Array.append v v2) s | s -> Zlapp v :: s let pure_stack lfts stk = let rec pure_rec lfts stk = match stk with [] -> (lfts,[]) | zi::s -> (match (zi,pure_rec lfts s) with (Zupdate _,lpstk) -> lpstk | (Zshift n,(l,pstk)) -> (el_shft n l, pstk) | (Zapp a, (l,pstk)) -> (l,zlapp (Array.map (fun t -> (l,t)) a) pstk) | (Zfix(fx,a),(l,pstk)) -> let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) | (Zcase(ci,p,br),(l,pstk)) -> (l,Zlcase(ci,l,p,br)::pstk)) in snd (pure_rec lfts stk) (****************************************************************************) (* Reduction Functions *) (****************************************************************************) let whd_betaiota t = whd_val (create_clos_infos betaiota empty_env) (inject t) let nf_betaiota t = norm_val (create_clos_infos betaiota empty_env) (inject t) let whd_betaiotazeta x = match kind_of_term x with | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> x | _ -> whd_val (create_clos_infos betaiotazeta empty_env) (inject x) let whd_betadeltaiota env t = match kind_of_term t with | (Sort _|Meta _|Evar _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> t | _ -> whd_val (create_clos_infos betadeltaiota env) (inject t) let whd_betadeltaiota_nolet env t = match kind_of_term t with | (Sort _|Meta _|Evar _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t | _ -> whd_val (create_clos_infos betadeltaiotanolet env) (inject t) (* Beta *) let beta_appvect c v = let rec stacklam env t stack = match kind_of_term t, stack with Lambda(_,_,c), arg::stacktl -> stacklam (arg::env) c stacktl | _ -> applist (substl env t, stack) in stacklam [] c (Array.to_list v) let betazeta_appvect n c v = let rec stacklam n env t stack = if n = 0 then applist (substl env t, stack) else match kind_of_term t, stack with Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl | LetIn(_,b,_,c), _ -> stacklam (n-1) (b::env) c stack | _ -> anomaly "Not enough lambda/let's" in stacklam n [] c (Array.to_list v) (********************************************************************) (* Conversion *) (********************************************************************) (* Conversion utility functions *) type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints type 'a trans_conversion_function = transparent_state -> env -> 'a -> 'a -> Univ.constraints exception NotConvertible exception NotConvertibleVect of int let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = let rec cmp_rec pstk1 pstk2 cuniv = match (pstk1,pstk2) with | (z1::s1, z2::s2) -> let cu1 = cmp_rec s1 s2 cuniv in (match (z1,z2) with | (Zlapp a1,Zlapp a2) -> array_fold_right2 f a1 a2 cu1 | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> let cu2 = f fx1 fx2 cu1 in cmp_rec a1 a2 cu2 | (Zlcase(ci1,l1,p1,br1),Zlcase(ci2,l2,p2,br2)) -> if not (fmind ci1.ci_ind ci2.ci_ind) then raise NotConvertible; let cu2 = f (l1,p1) (l2,p2) cu1 in array_fold_right2 (fun c1 c2 -> f (l1,c1) (l2,c2)) br1 br2 cu2 | _ -> assert false) | _ -> cuniv in if compare_stack_shape stk1 stk2 then cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2) cuniv else raise NotConvertible (* Convertibility of sorts *) (* The sort cumulativity is Prop <= Set <= Type 1 <= ... <= Type i <= ... and this holds whatever Set is predicative or impredicative *) type conv_pb = | CONV | CUMUL let sort_cmp pb s0 s1 cuniv = match (s0,s1) with | (Prop c1, Prop c2) when pb = CUMUL -> if c1 = Null or c2 = Pos then cuniv (* Prop <= Set *) else raise NotConvertible | (Prop c1, Prop c2) -> if c1 = c2 then cuniv else raise NotConvertible | (Prop c1, Type u) when pb = CUMUL -> assert (is_univ_variable u); cuniv | (Type u1, Type u2) -> assert (is_univ_variable u2); (match pb with | CONV -> enforce_eq u1 u2 cuniv | CUMUL -> enforce_geq u2 u1 cuniv) | (_, _) -> raise NotConvertible let conv_sort env s0 s1 = sort_cmp CONV s0 s1 empty_constraint let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 empty_constraint let rec no_arg_available = function | [] -> true | Zupdate _ :: stk -> no_arg_available stk | Zshift _ :: stk -> no_arg_available stk | Zapp v :: stk -> Array.length v = 0 && no_arg_available stk | Zcase _ :: _ -> true | Zfix _ :: _ -> true let rec no_nth_arg_available n = function | [] -> true | Zupdate _ :: stk -> no_nth_arg_available n stk | Zshift _ :: stk -> no_nth_arg_available n stk | Zapp v :: stk -> let k = Array.length v in if n >= k then no_nth_arg_available (n-k) stk else false | Zcase _ :: _ -> true | Zfix _ :: _ -> true let rec no_case_available = function | [] -> true | Zupdate _ :: stk -> no_case_available stk | Zshift _ :: stk -> no_case_available stk | Zapp _ :: stk -> no_case_available stk | Zcase _ :: _ -> false | Zfix _ :: _ -> true let in_whnf (t,stk) = match fterm_of t with | (FLetIn _ | FCases _ | FApp _ | FCLOS _ | FLIFT _ | FCast _) -> false | FLambda _ -> no_arg_available stk | FConstruct _ -> no_case_available stk | FCoFix _ -> no_case_available stk | FFix(((ri,n),(_,_,_)),_) -> no_nth_arg_available ri.(n) stk | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _) -> true | FLOCKED -> assert false (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *) and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = Util.check_for_interrupt (); (* First head reduce both terms *) let rec whd_both (t1,stk1) (t2,stk2) = let st1' = whd_stack (snd infos) t1 stk1 in let st2' = whd_stack (snd infos) t2 stk2 in (* Now, whd_stack on term2 might have modified st1 (due to sharing), and st1 might not be in whnf anymore. If so, we iterate ccnv. *) if in_whnf st1' then (st1',st2') else whd_both st1' st2' in let ((hd1,v1),(hd2,v2)) = whd_both st1 st2 in let appr1 = (lft1,(hd1,v1)) and appr2 = (lft2,(hd2,v2)) in (* compute the lifts that apply to the head of the term (hd1 and hd2) *) let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in match (fterm_of hd1, fterm_of hd2) with (* case of leaves *) | (FAtom a1, FAtom a2) -> (match kind_of_term a1, kind_of_term a2 with | (Sort s1, Sort s2) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly "conversion was given ill-typed terms (Sort)"; sort_cmp cv_pb s1 s2 cuniv | (Meta n, Meta m) -> if n=m then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | _ -> raise NotConvertible) | (FEvar ((ev1,args1),env1), FEvar ((ev2,args2),env2)) -> if ev1=ev2 then let u1 = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in convert_vect l2r infos el1 el2 (Array.map (mk_clos env1) args1) (Array.map (mk_clos env2) args2) u1 else raise NotConvertible (* 2 index known to be bound to no constant *) | (FRel n, FRel m) -> if reloc_rel n el1 = reloc_rel m el2 then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible (* 2 constants, 2 local defined vars or 2 defined rels *) | (FFlex fl1, FFlex fl2) -> (try (* try first intensional equality *) if eq_table_key fl1 fl2 then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible with NotConvertible -> (* else the oracle tells which constant is to be expanded *) let (app1,app2) = if Conv_oracle.oracle_order l2r fl1 fl2 then match unfold_reference infos fl1 with | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2) | None -> (match unfold_reference infos fl2 with | Some def2 -> (appr1, (lft2, whd_stack (snd infos) def2 v2)) | None -> raise NotConvertible) else match unfold_reference infos fl2 with | Some def2 -> (appr1, (lft2, whd_stack (snd infos) def2 v2)) | None -> (match unfold_reference infos fl1 with | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2) | None -> raise NotConvertible) in eqappr cv_pb l2r infos app1 app2 cuniv) (* other constructors *) | (FLambda _, FLambda _) -> (* Inconsistency: we tolerate that v1, v2 contain shift and update but we throw them away *) if not (is_empty_stack v1 && is_empty_stack v2) then anomaly "conversion was given ill-typed terms (FLambda)"; let (_,ty1,bd1) = destFLambda mk_clos hd1 in let (_,ty2,bd2) = destFLambda mk_clos hd2 in let u1 = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 u1 | (FProd (_,c1,c2), FProd (_,c'1,c'2)) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly "conversion was given ill-typed terms (FProd)"; (* Luo's system *) let u1 = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 u1 (* Eta-expansion on the fly *) | (FLambda _, _) -> if v1 <> [] then anomaly "conversion was given unreduced term (FLambda)"; let (_,_ty1,bd1) = destFLambda mk_clos hd1 in eqappr CONV l2r infos (el_lift lft1, (bd1, [])) (el_lift lft2, (hd2, eta_expand_stack v2)) cuniv | (_, FLambda _) -> if v2 <> [] then anomaly "conversion was given unreduced term (FLambda)"; let (_,_ty2,bd2) = destFLambda mk_clos hd2 in eqappr CONV l2r infos (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv (* only one constant, defined var or defined rel *) | (FFlex fl1, _) -> (match unfold_reference infos fl1 with | Some def1 -> eqappr cv_pb l2r infos (lft1, whd_stack (snd infos) def1 v1) appr2 cuniv | None -> raise NotConvertible) | (_, FFlex fl2) -> (match unfold_reference infos fl2 with | Some def2 -> eqappr cv_pb l2r infos appr1 (lft2, whd_stack (snd infos) def2 v2) cuniv | None -> raise NotConvertible) (* Inductive types: MutInd MutConstruct Fix Cofix *) | (FInd ind1, FInd ind2) -> if eq_ind ind1 ind2 then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | (FConstruct (ind1,j1), FConstruct (ind2,j2)) -> if j1 = j2 && eq_ind ind1 ind2 then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | (FFix ((op1,(_,tys1,cl1)),e1), FFix((op2,(_,tys2,cl2)),e2)) -> if op1 = op2 then let n = Array.length cl1 in let fty1 = Array.map (mk_clos e1) tys1 in let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let u2 = convert_vect l2r infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in convert_stacks l2r infos lft1 lft2 v1 v2 u2 else raise NotConvertible | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> if op1 = op2 then let n = Array.length cl1 in let fty1 = Array.map (mk_clos e1) tys1 in let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let u2 = convert_vect l2r infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in convert_stacks l2r infos lft1 lft2 v1 v2 u2 else raise NotConvertible (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) | ( (FLetIn _, _) | (FCases _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) | (_, FLetIn _) | (_,FCases _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) | (FLOCKED,_) | (_,FLOCKED) ) -> assert false (* In all other cases, terms are not convertible *) | _ -> raise NotConvertible and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = compare_stacks (fun (l1,t1) (l2,t2) c -> ccnv CONV l2r infos l1 l2 t1 t2 c) (eq_ind) lft1 stk1 lft2 stk2 cuniv and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = let lv1 = Array.length v1 in let lv2 = Array.length v2 in if lv1 = lv2 then let rec fold n univ = if n >= lv1 then univ else let u1 = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) univ in fold (n+1) u1 in fold 0 cuniv else raise NotConvertible let clos_fconv trans cv_pb l2r evars env t1 t2 = let infos = trans, create_clos_infos ~evars betaiotazeta env in ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) empty_constraint let trans_fconv reds cv_pb l2r evars env t1 t2 = if eq_constr t1 t2 then empty_constraint else clos_fconv reds cv_pb l2r evars env t1 t2 let trans_conv_cmp ?(l2r=false) conv reds = trans_fconv reds conv l2r (fun _->None) let trans_conv ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CONV l2r evars let trans_conv_leq ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CUMUL l2r evars let fconv = trans_fconv (Idpred.full, Cpred.full) let conv_cmp ?(l2r=false) cv_pb = fconv cv_pb l2r (fun _->None) let conv ?(l2r=false) ?(evars=fun _->None) = fconv CONV l2r evars let conv_leq ?(l2r=false) ?(evars=fun _->None) = fconv CUMUL l2r evars let conv_leq_vecti ?(l2r=false) ?(evars=fun _->None) env v1 v2 = array_fold_left2_i (fun i c t1 t2 -> let c' = try conv_leq ~l2r ~evars env t1 t2 with NotConvertible -> raise (NotConvertibleVect i) in union_constraints c c') empty_constraint v1 v2 (* option for conversion *) let vm_conv = ref (fun cv_pb -> fconv cv_pb false (fun _->None)) let set_vm_conv f = vm_conv := f let vm_conv cv_pb env t1 t2 = try !vm_conv cv_pb env t1 t2 with Not_found | Invalid_argument _ -> (* If compilation fails, fall-back to closure conversion *) fconv cv_pb false (fun _->None) env t1 t2 let default_conv = ref (fun cv_pb ?(l2r=false) -> fconv cv_pb l2r (fun _->None)) let set_default_conv f = default_conv := f let default_conv cv_pb ?(l2r=false) env t1 t2 = try !default_conv ~l2r cv_pb env t1 t2 with Not_found | Invalid_argument _ -> (* If compilation fails, fall-back to closure conversion *) fconv cv_pb false (fun _->None) env t1 t2 let default_conv_leq = default_conv CUMUL (* let convleqkey = Profile.declare_profile "Kernel_reduction.conv_leq";; let conv_leq env t1 t2 = Profile.profile4 convleqkey conv_leq env t1 t2;; let convkey = Profile.declare_profile "Kernel_reduction.conv";; let conv env t1 t2 = Profile.profile4 convleqkey conv env t1 t2;; *) (********************************************************************) (* Special-Purpose Reduction *) (********************************************************************) (* pseudo-reduction rule: * [hnf_prod_app env s (Prod(_,B)) N --> B[N] * with an HNF on the first argument to produce a product. * if this does not work, then we use the string S as part of our * error message. *) let hnf_prod_app env t n = match kind_of_term (whd_betadeltaiota env t) with | Prod (_,_,b) -> subst1 n b | _ -> anomaly "hnf_prod_app: Need a product" let hnf_prod_applist env t nl = List.fold_left (hnf_prod_app env) t nl (* Dealing with arities *) let dest_prod env = let rec decrec env m c = let t = whd_betadeltaiota env c in match kind_of_term t with | Prod (n,a,c0) -> let d = (n,None,a) in decrec (push_rel d env) (add_rel_decl d m) c0 | _ -> m,t in decrec env empty_rel_context (* The same but preserving lets *) let dest_prod_assum env = let rec prodec_rec env l ty = let rty = whd_betadeltaiota_nolet env ty in match kind_of_term rty with | Prod (x,t,c) -> let d = (x,None,t) in prodec_rec (push_rel d env) (add_rel_decl d l) c | LetIn (x,b,t,c) -> let d = (x,Some b,t) in prodec_rec (push_rel d env) (add_rel_decl d l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> l,rty in prodec_rec env empty_rel_context exception NotArity let dest_arity env c = let l, c = dest_prod_assum env c in match kind_of_term c with | Sort s -> l,s | _ -> raise NotArity let is_arity env c = try let _ = dest_arity env c in true with NotArity -> false coq-8.4pl4/kernel/closure.ml0000644000175000017500000010150512326224777015123 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* red_kind val fVAR : identifier -> red_kind val no_red : reds val red_add : reds -> red_kind -> reds val red_sub : reds -> red_kind -> reds val red_add_transparent : reds -> transparent_state -> reds val mkflags : red_kind list -> reds val red_set : reds -> red_kind -> bool end module RedFlags = (struct (* [r_const=(true,cl)] means all constants but those in [cl] *) (* [r_const=(false,cl)] means only those in [cl] *) (* [r_delta=true] just mean [r_const=(true,[])] *) type reds = { r_beta : bool; r_delta : bool; r_const : transparent_state; r_zeta : bool; r_iota : bool } type red_kind = BETA | DELTA | IOTA | ZETA | CONST of constant | VAR of identifier let fBETA = BETA let fDELTA = DELTA let fIOTA = IOTA let fZETA = ZETA let fCONST kn = CONST kn let fVAR id = VAR id let no_red = { r_beta = false; r_delta = false; r_const = all_opaque; r_zeta = false; r_iota = false } let red_add red = function | BETA -> { red with r_beta = true } | DELTA -> { red with r_delta = true; r_const = all_transparent } | CONST kn -> let (l1,l2) = red.r_const in { red with r_const = l1, Cpred.add kn l2 } | IOTA -> { red with r_iota = true } | ZETA -> { red with r_zeta = true } | VAR id -> let (l1,l2) = red.r_const in { red with r_const = Idpred.add id l1, l2 } let red_sub red = function | BETA -> { red with r_beta = false } | DELTA -> { red with r_delta = false } | CONST kn -> let (l1,l2) = red.r_const in { red with r_const = l1, Cpred.remove kn l2 } | IOTA -> { red with r_iota = false } | ZETA -> { red with r_zeta = false } | VAR id -> let (l1,l2) = red.r_const in { red with r_const = Idpred.remove id l1, l2 } let red_add_transparent red tr = { red with r_const = tr } let mkflags = List.fold_left red_add no_red let red_set red = function | BETA -> incr_cnt red.r_beta beta | CONST kn -> let (_,l) = red.r_const in let c = Cpred.mem kn l in incr_cnt c delta | VAR id -> (* En attendant d'avoir des kn pour les Var *) let (l,_) = red.r_const in let c = Idpred.mem id l in incr_cnt c delta | ZETA -> incr_cnt red.r_zeta zeta | IOTA -> incr_cnt red.r_iota iota | DELTA -> (* Used for Rel/Var defined in context *) incr_cnt red.r_delta delta end : RedFlagsSig) open RedFlags let betadeltaiota = mkflags [fBETA;fDELTA;fZETA;fIOTA] let betadeltaiotanolet = mkflags [fBETA;fDELTA;fIOTA] let betaiota = mkflags [fBETA;fIOTA] let beta = mkflags [fBETA] let betaiotazeta = mkflags [fBETA;fIOTA;fZETA] (* Removing fZETA for finer behaviour would break many developments *) let unfold_side_flags = [fBETA;fIOTA;fZETA] let unfold_side_red = mkflags [fBETA;fIOTA;fZETA] let unfold_red kn = let flag = match kn with | EvalVarRef id -> fVAR id | EvalConstRef kn -> fCONST kn in mkflags (flag::unfold_side_flags) (* Flags of reduction and cache of constants: 'a is a type that may be * mapped to constr. 'a infos implements a cache for constants and * abstractions, storing a representation (of type 'a) of the body of * this constant or abstraction. * * i_tab is the cache table of the results * * i_repr is the function to get the representation from the current * state of the cache and the body of the constant. The result * is stored in the table. * * i_rels = (4,[(1,c);(3,d)]) means there are 4 free rel variables * and only those with index 1 and 3 have bodies which are c and d resp. * * i_vars is the list of _defined_ named variables. * * ref_value_cache searchs in the tab, otherwise uses i_repr to * compute the result and store it in the table. If the constant can't * be unfolded, returns None, but does not store this failure. * This * doesn't take the RESET into account. You mustn't keep such a table * after a Reset. * This type is not exported. Only its two * instantiations (cbv or lazy) are. *) type table_key = id_key let eq_table_key = Names.eq_id_key type 'a infos = { i_flags : reds; i_repr : 'a infos -> constr -> 'a; i_env : env; i_sigma : existential -> constr option; i_rels : int * (int * constr) list; i_vars : (identifier * constr) list; i_tab : (table_key, 'a) Hashtbl.t } let info_flags info = info.i_flags let ref_value_cache info ref = try Some (Hashtbl.find info.i_tab ref) with Not_found -> try let body = match ref with | RelKey n -> let (s,l) = info.i_rels in lift n (List.assoc (s-n) l) | VarKey id -> List.assoc id info.i_vars | ConstKey cst -> constant_value info.i_env cst in let v = info.i_repr info body in Hashtbl.add info.i_tab ref v; Some v with | Not_found (* List.assoc *) | NotEvaluableConst _ (* Const *) -> None let evar_value info ev = info.i_sigma ev let defined_vars flags env = (* if red_local_const (snd flags) then*) Sign.fold_named_context (fun (id,b,_) e -> match b with | None -> e | Some body -> (id, body)::e) (named_context env) ~init:[] (* else []*) let defined_rels flags env = (* if red_local_const (snd flags) then*) Sign.fold_rel_context (fun (id,b,t) (i,subs) -> match b with | None -> (i+1, subs) | Some body -> (i+1, (i,body) :: subs)) (rel_context env) ~init:(0,[]) (* else (0,[])*) let create mk_cl flgs env evars = { i_flags = flgs; i_repr = mk_cl; i_env = env; i_sigma = evars; i_rels = defined_rels flgs env; i_vars = defined_vars flgs env; i_tab = Hashtbl.create 17 } (**********************************************************************) (* Lazy reduction: the one used in kernel operations *) (* type of shared terms. fconstr and frterm are mutually recursive. * Clone of the constr structure, but completely mutable, and * annotated with reduction state (reducible or not). * - FLIFT is a delayed shift; allows sharing between 2 lifted copies * of a given term. * - FCLOS is a delayed substitution applied to a constr * - FLOCKED is used to erase the content of a reference that must * be updated. This is to allow the garbage collector to work * before the term is computed. *) (* Norm means the term is fully normalized and cannot create a redex when substituted Cstr means the term is in head normal form and that it can create a redex when substituted (i.e. constructor, fix, lambda) Whnf means we reached the head normal form and that it cannot create a redex when substituted Red is used for terms that might be reduced *) type red_state = Norm | Cstr | Whnf | Red let neutr = function | (Whnf|Norm) -> Whnf | (Red|Cstr) -> Red type fconstr = { mutable norm: red_state; mutable term: fterm } and fterm = | FRel of int | FAtom of constr (* Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key | FInd of inductive | FConstruct of constructor | FApp of fconstr * fconstr array | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCases of case_info * fconstr * fconstr * fconstr array | FLambda of int * (name * constr) list * constr * fconstr subs | FProd of name * fconstr * fconstr | FLetIn of name * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED let fterm_of v = v.term let set_norm v = v.norm <- Norm let is_val v = v.norm = Norm let mk_atom c = {norm=Norm;term=FAtom c} (* Could issue a warning if no is still Red, pointing out that we loose sharing. *) let update v1 (no,t) = if !share then (v1.norm <- no; v1.term <- t; v1) else {norm=no;term=t} (**********************************************************************) (* The type of (machine) stacks (= lambda-bar-calculus' contexts) *) type stack_member = | Zapp of fconstr array | Zcase of case_info * fconstr * fconstr array | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr and stack = stack_member list let empty_stack = [] let append_stack v s = if Array.length v = 0 then s else match s with | Zapp l :: s -> Zapp (Array.append v l) :: s | _ -> Zapp v :: s (* Collapse the shifts in the stack *) let zshift n s = match (n,s) with (0,_) -> s | (_,Zshift(k)::s) -> Zshift(n+k)::s | _ -> Zshift(n)::s let rec stack_args_size = function | Zapp v :: s -> Array.length v + stack_args_size s | Zshift(_)::s -> stack_args_size s | Zupdate(_)::s -> stack_args_size s | _ -> 0 (* When used as an argument stack (only Zapp can appear) *) let rec decomp_stack = function | Zapp v :: s -> (match Array.length v with 0 -> decomp_stack s | 1 -> Some (v.(0), s) | _ -> Some (v.(0), (Zapp (Array.sub v 1 (Array.length v - 1)) :: s))) | _ -> None let array_of_stack s = let rec stackrec = function | [] -> [] | Zapp args :: s -> args :: (stackrec s) | _ -> assert false in Array.concat (stackrec s) let rec stack_assign s p c = match s with | Zapp args :: s -> let q = Array.length args in if p >= q then Zapp args :: stack_assign s (p-q) c else (let nargs = Array.copy args in nargs.(p) <- c; Zapp nargs :: s) | _ -> s let rec stack_tail p s = if p = 0 then s else match s with | Zapp args :: s -> let q = Array.length args in if p >= q then stack_tail (p-q) s else Zapp (Array.sub args p (q-p)) :: s | _ -> failwith "stack_tail" let rec stack_nth s p = match s with | Zapp args :: s -> let q = Array.length args in if p >= q then stack_nth s (p-q) else args.(p) | _ -> raise Not_found (* Lifting. Preserves sharing (useful only for cell with norm=Red). lft_fconstr always create a new cell, while lift_fconstr avoids it when the lift is 0. *) let rec lft_fconstr n ft = match ft.term with | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)) -> ft | FRel i -> {norm=Norm;term=FRel(i+n)} | FLambda(k,tys,f,e) -> {norm=Cstr; term=FLambda(k,tys,f,subs_shft(n,e))} | FFix(fx,e) -> {norm=Cstr; term=FFix(fx,subs_shft(n,e))} | FCoFix(cfx,e) -> {norm=Cstr; term=FCoFix(cfx,subs_shft(n,e))} | FLIFT(k,m) -> lft_fconstr (n+k) m | FLOCKED -> assert false | _ -> {norm=ft.norm; term=FLIFT(n,ft)} let lift_fconstr k f = if k=0 then f else lft_fconstr k f let lift_fconstr_vect k v = if k=0 then v else Array.map (fun f -> lft_fconstr k f) v let clos_rel e i = match expand_rel i e with | Inl(n,mt) -> lift_fconstr n mt | Inr(k,None) -> {norm=Norm; term= FRel k} | Inr(k,Some p) -> lift_fconstr (k-p) {norm=Red;term=FFlex(RelKey p)} (* since the head may be reducible, we might introduce lifts of 0 *) let compact_stack head stk = let rec strip_rec depth = function | Zshift(k)::s -> strip_rec (depth+k) s | Zupdate(m)::s -> (* Be sure to create a new cell otherwise sharing would be lost by the update operation *) let h' = lft_fconstr depth head in let _ = update m (h'.norm,h'.term) in strip_rec depth s | stk -> zshift depth stk in strip_rec 0 stk (* Put an update mark in the stack, only if needed *) let zupdate m s = if !share & m.norm = Red then let s' = compact_stack m s in let _ = m.term <- FLOCKED in Zupdate(m)::s' else s (* Closure optimization: *) let rec compact_constr (lg, subs as s) c k = match kind_of_term c with Rel i -> if i < k then c,s else (try mkRel (k + lg - list_index (i-k+1) subs), (lg,subs) with Not_found -> mkRel (k+lg), (lg+1, (i-k+1)::subs)) | (Sort _|Var _|Meta _|Ind _|Const _|Construct _) -> c,s | Evar(ev,v) -> let (v',s) = compact_vect s v k in if v==v' then c,s else mkEvar(ev,v'),s | Cast(a,ck,b) -> let (a',s) = compact_constr s a k in let (b',s) = compact_constr s b k in if a==a' && b==b' then c,s else mkCast(a', ck, b'), s | App(f,v) -> let (f',s) = compact_constr s f k in let (v',s) = compact_vect s v k in if f==f' && v==v' then c,s else mkApp(f',v'), s | Lambda(n,a,b) -> let (a',s) = compact_constr s a k in let (b',s) = compact_constr s b (k+1) in if a==a' && b==b' then c,s else mkLambda(n,a',b'), s | Prod(n,a,b) -> let (a',s) = compact_constr s a k in let (b',s) = compact_constr s b (k+1) in if a==a' && b==b' then c,s else mkProd(n,a',b'), s | LetIn(n,a,ty,b) -> let (a',s) = compact_constr s a k in let (ty',s) = compact_constr s ty k in let (b',s) = compact_constr s b (k+1) in if a==a' && ty==ty' && b==b' then c,s else mkLetIn(n,a',ty',b'), s | Fix(fi,(na,ty,bd)) -> let (ty',s) = compact_vect s ty k in let (bd',s) = compact_vect s bd (k+Array.length ty) in if ty==ty' && bd==bd' then c,s else mkFix(fi,(na,ty',bd')), s | CoFix(i,(na,ty,bd)) -> let (ty',s) = compact_vect s ty k in let (bd',s) = compact_vect s bd (k+Array.length ty) in if ty==ty' && bd==bd' then c,s else mkCoFix(i,(na,ty',bd')), s | Case(ci,p,a,br) -> let (p',s) = compact_constr s p k in let (a',s) = compact_constr s a k in let (br',s) = compact_vect s br k in if p==p' && a==a' && br==br' then c,s else mkCase(ci,p',a',br'),s and compact_vect s v k = compact_v [] s v k (Array.length v - 1) and compact_v acc s v k i = if i < 0 then let v' = Array.of_list acc in if array_for_all2 (==) v v' then v,s else v',s else let (a',s') = compact_constr s v.(i) k in compact_v (a'::acc) s' v k (i-1) (* Computes the minimal environment of a closure. Idea: if the subs is not identity, the term will have to be reallocated entirely (to propagate the substitution). So, computing the set of free variables does not change the complexity. *) let optimise_closure env c = if is_subs_id env then (env,c) else let (c',(_,s)) = compact_constr (0,[]) c 1 in let env' = Array.map (fun i -> clos_rel env i) (Array.of_list s) in (subs_cons (env', subs_id 0),c') let mk_lambda env t = let (env,t) = optimise_closure env t in let (rvars,t') = decompose_lam t in FLambda(List.length rvars, List.rev rvars, t', env) let destFLambda clos_fun t = match t.term with FLambda(_,[(na,ty)],b,e) -> (na,clos_fun e ty,clos_fun (subs_lift e) b) | FLambda(n,(na,ty)::tys,b,e) -> (na,clos_fun e ty,{norm=Cstr;term=FLambda(n-1,tys,b,subs_lift e)}) | _ -> assert false (* t must be a FLambda and binding list cannot be empty *) (* Optimization: do not enclose variables in a closure. Makes variable access much faster *) let mk_clos e t = match kind_of_term t with | Rel i -> clos_rel e i | Var x -> { norm = Red; term = FFlex (VarKey x) } | Const c -> { norm = Red; term = FFlex (ConstKey c) } | Meta _ | Sort _ -> { norm = Norm; term = FAtom t } | Ind kn -> { norm = Norm; term = FInd kn } | Construct kn -> { norm = Cstr; term = FConstruct kn } | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _) -> {norm = Red; term = FCLOS(t,e)} let mk_clos_vect env v = Array.map (mk_clos env) v (* Translate the head constructor of t from constr to fconstr. This function is parameterized by the function to apply on the direct subterms. Could be used insted of mk_clos. *) let mk_clos_deep clos_fun env t = match kind_of_term t with | (Rel _|Ind _|Const _|Construct _|Var _|Meta _ | Sort _) -> mk_clos env t | Cast (a,k,b) -> { norm = Red; term = FCast (clos_fun env a, k, clos_fun env b)} | App (f,v) -> { norm = Red; term = FApp (clos_fun env f, Array.map (clos_fun env) v) } | Case (ci,p,c,v) -> { norm = Red; term = FCases (ci, clos_fun env p, clos_fun env c, Array.map (clos_fun env) v) } | Fix fx -> { norm = Cstr; term = FFix (fx, env) } | CoFix cfx -> { norm = Cstr; term = FCoFix(cfx,env) } | Lambda _ -> { norm = Cstr; term = mk_lambda env t } | Prod (n,t,c) -> { norm = Whnf; term = FProd (n, clos_fun env t, clos_fun (subs_lift env) c) } | LetIn (n,b,t,c) -> { norm = Red; term = FLetIn (n, clos_fun env b, clos_fun env t, c, env) } | Evar ev -> { norm = Red; term = FEvar(ev,env) } (* A better mk_clos? *) let mk_clos2 = mk_clos_deep mk_clos (* The inverse of mk_clos_deep: move back to constr *) let rec to_constr constr_fun lfts v = match v.term with | FRel i -> mkRel (reloc_rel i lfts) | FFlex (RelKey p) -> mkRel (reloc_rel p lfts) | FFlex (VarKey x) -> mkVar x | FAtom c -> exliftn lfts c | FCast (a,k,b) -> mkCast (constr_fun lfts a, k, constr_fun lfts b) | FFlex (ConstKey op) -> mkConst op | FInd op -> mkInd op | FConstruct op -> mkConstruct op | FCases (ci,p,c,ve) -> mkCase (ci, constr_fun lfts p, constr_fun lfts c, Array.map (constr_fun lfts) ve) | FFix ((op,(lna,tys,bds)),e) -> let n = Array.length bds in let ftys = Array.map (mk_clos e) tys in let fbds = Array.map (mk_clos (subs_liftn n e)) bds in let lfts' = el_liftn n lfts in mkFix (op, (lna, Array.map (constr_fun lfts) ftys, Array.map (constr_fun lfts') fbds)) | FCoFix ((op,(lna,tys,bds)),e) -> let n = Array.length bds in let ftys = Array.map (mk_clos e) tys in let fbds = Array.map (mk_clos (subs_liftn n e)) bds in let lfts' = el_liftn (Array.length bds) lfts in mkCoFix (op, (lna, Array.map (constr_fun lfts) ftys, Array.map (constr_fun lfts') fbds)) | FApp (f,ve) -> mkApp (constr_fun lfts f, Array.map (constr_fun lfts) ve) | FLambda _ -> let (na,ty,bd) = destFLambda mk_clos2 v in mkLambda (na, constr_fun lfts ty, constr_fun (el_lift lfts) bd) | FProd (n,t,c) -> mkProd (n, constr_fun lfts t, constr_fun (el_lift lfts) c) | FLetIn (n,b,t,f,e) -> let fc = mk_clos2 (subs_lift e) f in mkLetIn (n, constr_fun lfts b, constr_fun lfts t, constr_fun (el_lift lfts) fc) | FEvar ((ev,args),env) -> mkEvar(ev,Array.map (fun a -> constr_fun lfts (mk_clos2 env a)) args) | FLIFT (k,a) -> to_constr constr_fun (el_shft k lfts) a | FCLOS (t,env) -> let fr = mk_clos2 env t in let unfv = update v (fr.norm,fr.term) in to_constr constr_fun lfts unfv | FLOCKED -> assert false (*mkVar(id_of_string"_LOCK_")*) (* This function defines the correspondance between constr and fconstr. When we find a closure whose substitution is the identity, then we directly return the constr to avoid possibly huge reallocation. *) let term_of_fconstr = let rec term_of_fconstr_lift lfts v = match v.term with | FCLOS(t,env) when is_subs_id env & is_lift_id lfts -> t | FLambda(_,tys,f,e) when is_subs_id e & is_lift_id lfts -> compose_lam (List.rev tys) f | FFix(fx,e) when is_subs_id e & is_lift_id lfts -> mkFix fx | FCoFix(cfx,e) when is_subs_id e & is_lift_id lfts -> mkCoFix cfx | _ -> to_constr term_of_fconstr_lift lfts v in term_of_fconstr_lift el_id (* fstrong applies unfreeze_fun recursively on the (freeze) term and * yields a term. Assumes that the unfreeze_fun never returns a * FCLOS term. let rec fstrong unfreeze_fun lfts v = to_constr (fstrong unfreeze_fun) lfts (unfreeze_fun v) *) let rec zip m stk = match stk with | [] -> m | Zapp args :: s -> zip {norm=neutr m.norm; term=FApp(m, args)} s | Zcase(ci,p,br)::s -> let t = FCases(ci, p, m, br) in zip {norm=neutr m.norm; term=t} s | Zfix(fx,par)::s -> zip fx (par @ append_stack [|m|] s) | Zshift(n)::s -> zip (lift_fconstr n m) s | Zupdate(rf)::s -> zip (update rf (m.norm,m.term)) s let fapp_stack (m,stk) = zip m stk (*********************************************************************) (* The assertions in the functions below are granted because they are called only when m is a constructor, a cofix (strip_update_shift_app), a fix (get_nth_arg) or an abstraction (strip_update_shift, through get_arg). *) (* optimised for the case where there are no shifts... *) let strip_update_shift_app head stk = assert (head.norm <> Red); let rec strip_rec rstk h depth = function | Zshift(k) as e :: s -> strip_rec (e::rstk) (lift_fconstr k h) (depth+k) s | (Zapp args :: s) -> strip_rec (Zapp args :: rstk) {norm=h.norm;term=FApp(h,args)} depth s | Zupdate(m)::s -> strip_rec rstk (update m (h.norm,h.term)) depth s | stk -> (depth,List.rev rstk, stk) in strip_rec [] head 0 stk let get_nth_arg head n stk = assert (head.norm <> Red); let rec strip_rec rstk h n = function | Zshift(k) as e :: s -> strip_rec (e::rstk) (lift_fconstr k h) n s | Zapp args::s' -> let q = Array.length args in if n >= q then strip_rec (Zapp args::rstk) {norm=h.norm;term=FApp(h,args)} (n-q) s' else let bef = Array.sub args 0 n in let aft = Array.sub args (n+1) (q-n-1) in let stk' = List.rev (if n = 0 then rstk else (Zapp bef :: rstk)) in (Some (stk', args.(n)), append_stack aft s') | Zupdate(m)::s -> strip_rec rstk (update m (h.norm,h.term)) n s | s -> (None, List.rev rstk @ s) in strip_rec [] head n stk (* Beta reduction: look for an applied argument in the stack. Since the encountered update marks are removed, h must be a whnf *) let rec get_args n tys f e stk = match stk with Zupdate r :: s -> let _hd = update r (Cstr,FLambda(n,tys,f,e)) in get_args n tys f e s | Zshift k :: s -> get_args n tys f (subs_shft (k,e)) s | Zapp l :: s -> let na = Array.length l in if n == na then (Inl (subs_cons(l,e)),s) else if n < na then (* more arguments *) let args = Array.sub l 0 n in let eargs = Array.sub l n (na-n) in (Inl (subs_cons(args,e)), Zapp eargs :: s) else (* more lambdas *) let etys = list_skipn na tys in get_args (n-na) etys f (subs_cons(l,e)) s | _ -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk) (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *) let rec eta_expand_stack = function | (Zapp _ | Zfix _ | Zcase _ | Zshift _ | Zupdate _ as e) :: s -> e :: eta_expand_stack s | [] -> [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]] (* Iota reduction: extract the arguments to be passed to the Case branches *) let rec reloc_rargs_rec depth stk = match stk with Zapp args :: s -> Zapp (lift_fconstr_vect depth args) :: reloc_rargs_rec depth s | Zshift(k)::s -> if k=depth then s else reloc_rargs_rec (depth-k) s | _ -> stk let reloc_rargs depth stk = if depth = 0 then stk else reloc_rargs_rec depth stk let rec drop_parameters depth n argstk = match argstk with Zapp args::s -> let q = Array.length args in if n > q then drop_parameters depth (n-q) s else if n = q then reloc_rargs depth s else let aft = Array.sub args n (q-n) in reloc_rargs depth (append_stack aft s) | Zshift(k)::s -> drop_parameters (depth-k) n s | [] -> (* we know that n < stack_args_size(argstk) (if well-typed term) *) if n=0 then [] else anomaly "ill-typed term: found a match on a partially applied constructor" | _ -> assert false (* strip_update_shift_app only produces Zapp and Zshift items *) (* Iota reduction: expansion of a fixpoint. * Given a fixpoint and a substitution, returns the corresponding * fixpoint body, and the substitution in which it should be * evaluated: its first variables are the fixpoint bodies * * FCLOS(fix Fi {F0 := T0 .. Fn-1 := Tn-1}, S) * -> (S. FCLOS(F0,S) . ... . FCLOS(Fn-1,S), Ti) *) (* does not deal with FLIFT *) let contract_fix_vect fix = let (thisbody, make_body, env, nfix) = match fix with | FFix (((reci,i),(_,_,bds as rdcl)),env) -> (bds.(i), (fun j -> { norm = Cstr; term = FFix (((reci,j),rdcl),env) }), env, Array.length bds) | FCoFix ((i,(_,_,bds as rdcl)),env) -> (bds.(i), (fun j -> { norm = Cstr; term = FCoFix ((j,rdcl),env) }), env, Array.length bds) | _ -> assert false in (subs_cons(Array.init nfix make_body, env), thisbody) (*********************************************************************) (* A machine that inspects the head of a term until it finds an atom or a subterm that may produce a redex (abstraction, constructor, cofix, letin, constant), or a neutral term (product, inductive) *) let rec knh m stk = match m.term with | FLIFT(k,a) -> knh a (zshift k stk) | FCLOS(t,e) -> knht e t (zupdate m stk) | FLOCKED -> assert false | FApp(a,b) -> knh a (append_stack b (zupdate m stk)) | FCases(ci,p,t,br) -> knh t (Zcase(ci,p,br)::zupdate m stk) | FFix(((ri,n),(_,_,_)),_) -> (match get_nth_arg m ri.(n) stk with (Some(pars,arg),stk') -> knh arg (Zfix(m,pars)::stk') | (None, stk') -> (m,stk')) | FCast(t,_,_) -> knh t stk (* cases where knh stops *) | (FFlex _|FLetIn _|FConstruct _|FEvar _| FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) -> (m, stk) (* The same for pure terms *) and knht e t stk = match kind_of_term t with | App(a,b) -> knht e a (append_stack (mk_clos_vect e b) stk) | Case(ci,p,t,br) -> knht e t (Zcase(ci, mk_clos e p, mk_clos_vect e br)::stk) | Fix _ -> knh (mk_clos2 e t) stk | Cast(a,_,_) -> knht e a stk | Rel n -> knh (clos_rel e n) stk | (Lambda _|Prod _|Construct _|CoFix _|Ind _| LetIn _|Const _|Var _|Evar _|Meta _|Sort _) -> (mk_clos2 e t, stk) (************************************************************************) (* Computes a weak head normal form from the result of knh. *) let rec knr info m stk = match m.term with | FLambda(n,tys,f,e) when red_set info.i_flags fBETA -> (match get_args n tys f e stk with Inl e', s -> knit info e' f s | Inr lam, s -> (lam,s)) | FFlex(ConstKey kn) when red_set info.i_flags (fCONST kn) -> (match ref_value_cache info (ConstKey kn) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FFlex(VarKey id) when red_set info.i_flags (fVAR id) -> (match ref_value_cache info (VarKey id) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FFlex(RelKey k) when red_set info.i_flags fDELTA -> (match ref_value_cache info (RelKey k) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FConstruct(ind,c) when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with (depth, args, Zcase(ci,_,br)::s) -> assert (ci.ci_npar>=0); let rargs = drop_parameters depth ci.ci_npar args in kni info br.(c-1) (rargs@s) | (_, cargs, Zfix(fx,par)::s) -> let rarg = fapp_stack(m,cargs) in let stk' = par @ append_stack [|rarg|] s in let (fxe,fxbd) = contract_fix_vect fx.term in knit info fxe fxbd stk' | (_,args,s) -> (m,args@s)) | FCoFix _ when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with (_, args, ((Zcase _::_) as stk')) -> let (fxe,fxbd) = contract_fix_vect m.term in knit info fxe fxbd (args@stk') | (_,args,s) -> (m,args@s)) | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA -> knit info (subs_cons([|v|],e)) bd stk | FEvar(ev,env) -> (match evar_value info ev with Some c -> knit info env c stk | None -> (m,stk)) | _ -> (m,stk) (* Computes the weak head normal form of a term *) and kni info m stk = let (hm,s) = knh m stk in knr info hm s and knit info e t stk = let (ht,s) = knht e t stk in knr info ht s let kh info v stk = fapp_stack(kni info v stk) (************************************************************************) let rec zip_term zfun m stk = match stk with | [] -> m | Zapp args :: s -> zip_term zfun (mkApp(m, Array.map zfun args)) s | Zcase(ci,p,br)::s -> let t = mkCase(ci, zfun p, m, Array.map zfun br) in zip_term zfun t s | Zfix(fx,par)::s -> let h = mkApp(zip_term zfun (zfun fx) par,[|m|]) in zip_term zfun h s | Zshift(n)::s -> zip_term zfun (lift n m) s | Zupdate(rf)::s -> zip_term zfun m s (* Computes the strong normal form of a term. 1- Calls kni 2- tries to rebuild the term. If a closure still has to be computed, calls itself recursively. *) let rec kl info m = if is_val m then (incr prune; term_of_fconstr m) else let (nm,s) = kni info m [] in let _ = fapp_stack(nm,s) in (* to unlock Zupdates! *) zip_term (kl info) (norm_head info nm) s (* no redex: go up for atoms and already normalized terms, go down otherwise. *) and norm_head info m = if is_val m then (incr prune; term_of_fconstr m) else match m.term with | FLambda(n,tys,f,e) -> let (e',rvtys) = List.fold_left (fun (e,ctxt) (na,ty) -> (subs_lift e, (na,kl info (mk_clos e ty))::ctxt)) (e,[]) tys in let bd = kl info (mk_clos e' f) in List.fold_left (fun b (na,ty) -> mkLambda(na,ty,b)) bd rvtys | FLetIn(na,a,b,f,e) -> let c = mk_clos (subs_lift e) f in mkLetIn(na, kl info a, kl info b, kl info c) | FProd(na,dom,rng) -> mkProd(na, kl info dom, kl info rng) | FCoFix((n,(na,tys,bds)),e) -> let ftys = Array.map (mk_clos e) tys in let fbds = Array.map (mk_clos (subs_liftn (Array.length na) e)) bds in mkCoFix(n,(na, Array.map (kl info) ftys, Array.map (kl info) fbds)) | FFix((n,(na,tys,bds)),e) -> let ftys = Array.map (mk_clos e) tys in let fbds = Array.map (mk_clos (subs_liftn (Array.length na) e)) bds in mkFix(n,(na, Array.map (kl info) ftys, Array.map (kl info) fbds)) | FEvar((i,args),env) -> mkEvar(i, Array.map (fun a -> kl info (mk_clos env a)) args) | t -> term_of_fconstr m (* Initialization and then normalization *) (* weak reduction *) let whd_val info v = with_stats (lazy (term_of_fconstr (kh info v []))) (* strong reduction *) let norm_val info v = with_stats (lazy (kl info v)) let inject = mk_clos (subs_id 0) let whd_stack infos m stk = let k = kni infos m stk in let _ = fapp_stack k in (* to unlock Zupdates! *) k (* cache of constants: the body is computed only when needed. *) type clos_infos = fconstr infos let create_clos_infos ?(evars=fun _ -> None) flgs env = create (fun _ -> inject) flgs env evars let unfold_reference = ref_value_cache coq-8.4pl4/kernel/pre_env.mli0000644000175000017500000000433412326224777015260 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* int val push_rel : rel_declaration -> env -> env val lookup_rel_val : int -> env -> lazy_val val env_of_rel : int -> env -> env (** Named context *) val push_named_context_val : named_declaration -> named_context_val -> named_context_val val push_named : named_declaration -> env -> env val lookup_named_val : identifier -> env -> lazy_val val env_of_named : identifier -> env -> env (** Global constants *) val lookup_constant_key : constant -> env -> constant_key val lookup_constant : constant -> env -> constant_body (** Mutual Inductives *) val lookup_mind : mutual_inductive -> env -> mutual_inductive_body coq-8.4pl4/kernel/typeops.mli0000644000175000017500000000704212326224777015324 0ustar stephsteph(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* constr -> unsafe_judgment * constraints val infer_v : env -> constr array -> unsafe_judgment array * constraints val infer_type : env -> types -> unsafe_type_judgment * constraints val infer_local_decls : env -> (identifier * local_entry) list -> env * rel_context * constraints (** {6 Basic operations of the typing machine. } *) (** If [j] is the judgement {% $ %}c:t{% $ %}, then [assumption_of_judgement env j] returns the type {% $ %}c{% $ %}, checking that {% $ %}t{% $ %} is a sort. *) val assumption_of_judgment : env -> unsafe_judgment -> types val type_judgment : env -> unsafe_judgment -> unsafe_type_judgment (** {6 Type of sorts. } *) val judge_of_prop_contents : contents -> unsafe_judgment val judge_of_type : universe -> unsafe_judgment (** {6 Type of a bound variable. } *) val judge_of_relative : env -> int -> unsafe_judgment (** {6 Type of variables } *) val judge_of_variable : env -> variable -> unsafe_judgment (** {6 type of a constant } *) val judge_of_constant : env -> constant -> unsafe_judgment val judge_of_constant_knowing_parameters : env -> constant -> unsafe_judgment array -> unsafe_judgment (** {6 Type of application. } *) val judge_of_apply : env -> unsafe_judgment -> unsafe_judgment array -> unsafe_judgment * constraints (** {6 Type of an abstraction. } *) val judge_of_abstraction : env -> name -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment (** {6 Type of a product. } *) val judge_of_product : env -> name -> unsafe_type_judgment -> unsafe_type_judgment -> unsafe_judgment (** s Type of a let in. *) val judge_of_letin : env -> name -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment (** {6 Type of a cast. } *) val judge_of_cast : env -> unsafe_judgment -> cast_kind -> unsafe_type_judgment -> unsafe_judgment * constraints (** {6 Inductive types. } *) val judge_of_inductive : env -> inductive -> unsafe_judgment val judge_of_inductive_knowing_parameters : env -> inductive -> unsafe_judgment array -> unsafe_judgment val judge_of_constructor : env -> constructor -> unsafe_judgment (** {6 Type of Cases. } *) val judge_of_case : env -> case_info -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array -> unsafe_judgment * constraints (** Typecheck general fixpoint (not checking guard conditions) *) val type_fixpoint : env -> name array -> types array -> unsafe_judgment array -> constraints (** Kernel safe typing but applicable to partial proofs *) val typing : env -> constr -> unsafe_judgment val type_of_constant : env -> constant -> types val type_of_constant_type : env -> constant_type -> types val type_of_constant_knowing_parameters : env -> constant_type -> constr array -> types (** Make a type polymorphic if an arity *) val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment -> constant_type coq-8.4pl4/build0000755000175000017500000000122012326224777012653 0ustar stephsteph#!/bin/sh FLAGS= OCAMLBUILD=ocamlbuild CFG=config/coq_config.ml MYCFG=myocamlbuild_config.ml export CAML_LD_LIBRARY_PATH=`pwd`/_build/kernel/byterun check_config() { [ -f $CFG ] || (echo "please run ./configure first"; exit 1) [ -L $MYCFG ] || ln -sf $CFG $MYCFG } # NB: we exec ocamlbuild and run ocb last for a correct exit code ocb() { exec $OCAMLBUILD $FLAGS $*; } rule() { check_config case $1 in clean) rm -rf bin/* $MYCFG && ocb -clean;; all) ocb coq.otarget;; win32) ocb coq-win32.otarget;; *) ocb $1;; esac; } if [ $# -eq 0 ]; then rule all else while [ $# -gt 0 ]; do rule $1; shift done fi